├── .gitignore └── Data ├── JSON.idr └── JSON ├── Semantics.idr └── Type.idr /.gitignore: -------------------------------------------------------------------------------- 1 | *.ibc 2 | *~ 3 | -------------------------------------------------------------------------------- /Data/JSON.idr: -------------------------------------------------------------------------------- 1 | module Data.JSON 2 | 3 | import public Data.JSON.Type 4 | import Data.JSON.Semantics 5 | 6 | import Data.So 7 | 8 | %default total 9 | 10 | ------------------------------------------------------------------------------ 11 | -- show 12 | ------------------------------------------------------------------------------ 13 | 14 | showBeginArray : S_begin_array () ['['] 15 | showBeginArray = MkMap $ MkConsecutive Nil (MkConsecutive MkCharS Nil) 16 | 17 | showEndArray : S_end_array () [']'] 18 | showEndArray = MkMap $ MkConsecutive Nil (MkConsecutive MkCharS Nil) 19 | 20 | showBeginObject : S_begin_object () ['{'] 21 | showBeginObject = MkMap $ MkConsecutive Nil (MkConsecutive MkCharS Nil) 22 | 23 | showEndObject : S_end_object () ['}'] 24 | showEndObject = MkMap $ MkConsecutive Nil (MkConsecutive MkCharS Nil) 25 | 26 | showValueSeparator : S_value_separator () [','] 27 | showValueSeparator = MkMap $ MkConsecutive Nil (MkConsecutive MkCharS Nil) 28 | 29 | toSnd : a -> ((), a) 30 | toSnd v = ((), v) 31 | 32 | mapIdNeutral : (vs : List a) -> map (\x => x) vs = vs 33 | mapIdNeutral [] = Refl 34 | mapIdNeutral (x :: xs) = rewrite mapIdNeutral xs in Refl 35 | 36 | toJsonListLemma : (v : JsonValue) -> 37 | (vs : List JsonValue) -> 38 | v :: vs = toJsonList ((), Just (v, map Data.JSON.toSnd vs), ()) 39 | toJsonListLemma v vs = rewrite ((map Prelude.Basics.snd (map toSnd vs)) = (map (snd . toSnd) vs)) <== mapFusion in 40 | rewrite (map (\x => x) vs = vs) <== mapIdNeutral in 41 | Refl 42 | 43 | showHEXDIG : (x : Nat) -> {auto xOk : x `LTE` 15} -> (text : List Char ** S_HEXDIG x text) 44 | showHEXDIG {xOk} x with (x `isLTE` 9) 45 | showHEXDIG {xOk} x | (Yes prf) = ([chr (ord '0' + (toIntNat x))] ** MkS_HEXDIG_0 x prf) 46 | showHEXDIG {xOk} x | (No contra) = ([chr (ord 'A' - 10 + (toIntNat x))] ** MkS_HEXDIG_A x xOk contra) 47 | 48 | showHexQuad : (value : Int) -> (text : List Char ** HexQuad value text) 49 | 50 | showStringChar : (c : Char) -> (text : List Char ** S_char c text) 51 | showStringChar c with (choose $ allowedUnescaped c) 52 | showStringChar c | (Left prf) = ([c] ** S_unescaped c prf) 53 | showStringChar '"' | _ = (['\\','"'] ** S_escape_quotation_mark) 54 | showStringChar '\\' | _ = (['\\','\\'] ** S_escape_reverse_solidus) 55 | showStringChar '\b' | _ = (['\\','b'] ** S_escape_backspace) 56 | showStringChar '\f' | _ = (['\\','f'] ** S_escape_form_feed) 57 | showStringChar '\n' | _ = (['\\','n'] ** S_escape_line_feed) 58 | showStringChar '\r' | _ = (['\\','r'] ** S_escape_carriage_return) 59 | showStringChar '\t' | _ = (['\\','t'] ** S_escape_tab) 60 | showStringChar c | _ with (choose $ c <= chr 0xFFFF) 61 | showStringChar c | _ | (Left unicodeEscapableProof) = 62 | let (hqText ** hqProof) = showHexQuad (ord c) in 63 | ('\\' :: 'u' :: hqText ** S_unicode_escape c unicodeEscapableProof hqProof) 64 | showStringChar c | _ | (Right surrogatePairProof) = 65 | let (hq1Text ** hq1Proof) = showHexQuad (fst (unicodeSurrogatePair c)) 66 | (hq2Text ** hq2Proof) = showHexQuad (snd (unicodeSurrogatePair c)) in 67 | ('\\' :: 'u' :: hq1Text ++ '\\' :: 'u' :: hq2Text ** 68 | S_unicode_surrogate_pair c surrogatePairProof hq1Proof hq2Proof) 69 | 70 | mutual 71 | showValueList : (vs : List JsonValue) -> 72 | (text : List Char ** ListS (S_value_separator .. S_value) (map Data.JSON.toSnd vs) text) 73 | showValueList [] = ([] ** Nil) 74 | showValueList (v :: vs) = let (vText ** vValue) = showValue v 75 | (vsText ** vsValues) = showValueList vs in 76 | ((',' :: vText ++ vsText) ** (MkConsecutive showValueSeparator vValue) :: vsValues) 77 | 78 | showValue : (v : JsonValue) -> (text : List Char ** S_value v text) 79 | showValue JsonNull = (['n','u','l','l'] ** S_null) 80 | showValue (JsonBool False) = (['f','a','l','s','e'] ** S_false) 81 | showValue (JsonBool True) = (['t','r','u','e'] ** S_true) 82 | showValue (JsonArray []) = (['[',']'] ** array) 83 | where 84 | array : S_value (JsonArray []) ['[',']'] 85 | array = S_array (MkConsecutive showBeginArray (MkConsecutive NothingS showEndArray)) 86 | showValue (JsonArray (v :: vs)) = let (vText ** vValue) = showValue v 87 | (vsText ** vsValues) = showValueList vs 88 | text = '[' :: (vText ++ vsText) ++ [']'] in 89 | (text ** 90 | rewrite (toJsonListLemma v vs) in 91 | S_array (MkConsecutive 92 | showBeginArray 93 | (MkConsecutive 94 | (JustS (MkConsecutive vValue vsValues)) 95 | showEndArray))) 96 | showValue (JsonObject []) = (['{','}'] ** object) 97 | where 98 | object : S_value (JsonObject []) ['{','}'] 99 | object = S_object (MkConsecutive showBeginObject (MkConsecutive NothingS showEndObject)) 100 | showValue (JsonObject (x :: xs)) = ?showValue_rhs_2 101 | showValue (JsonString x) = ?showValue_rhs_3 102 | showValue (JsonNumber x) = ?showValue_rhs_6 103 | 104 | showJSONText : (v : JsonValue) -> (text : List Char ** S_JSON_text v text) 105 | showJSONText v = let (text ** s_value) = showValue v in 106 | (text ** replace (appendNilRightNeutral text) $ 107 | MkS_JSON_text (MkConsecutive Nil (MkConsecutive s_value Nil))) 108 | 109 | implementation Show JsonValue where 110 | show v = pack $ fst $ showJSONText v 111 | -------------------------------------------------------------------------------- /Data/JSON/Semantics.idr: -------------------------------------------------------------------------------- 1 | module Data.JSON.Semantics 2 | 3 | import Data.So 4 | import Data.Bits 5 | import Data.JSON.Type 6 | 7 | %default total 8 | %access public export 9 | 10 | ------------------------------------------------------------------------------ 11 | -- Combinators 12 | ------------------------------------------------------------------------------ 13 | 14 | infixr 7 .. 15 | 16 | ||| (..) combines two sems to relate the pair of their results to the concatenation of 17 | ||| their representations. 18 | data (..) : (fstValueType -> List Char -> Type) -> 19 | (sndValueType -> List Char -> Type) -> 20 | (fstValueType, sndValueType) -> 21 | List Char -> 22 | Type where 23 | MkConsecutive : sem1 v1 text1 -> sem2 v2 text2 -> (..) sem1 sem2 (v1, v2) (text1 ++ text2) 24 | 25 | ||| (MaybeS sem) is semantics for an optional sem. 26 | data MaybeS : (valueType -> List Char -> Type) -> 27 | Maybe valueType -> 28 | List Char -> 29 | Type where 30 | JustS : sem v text -> MaybeS sem (Just v) text 31 | NothingS : MaybeS sem Nothing [] 32 | 33 | ||| (ListS sem) is semantics for zero or more sems (the Kleene operator). 34 | data ListS : (valueType -> List Char -> Type) -> 35 | List valueType -> 36 | List Char -> 37 | Type where 38 | Nil : ListS sem [] [] 39 | (::) : sem v r -> ListS sem vs rs -> ListS sem (v :: vs) (r ++ rs) 40 | 41 | ||| (CharS c) is semantics for a literal character. Its value is the Char itself. 42 | data CharS : Char -> Char -> List Char -> Type where 43 | MkCharS : CharS c c [c] 44 | 45 | ||| Change the type of a sem with a mapping function. 46 | data Map : (func : a -> b) -> 47 | (a -> List Char -> Type) -> 48 | b -> List Char -> Type where 49 | MkMap : sem v text -> Map func sem (func v) text 50 | 51 | ------------------------------------------------------------------------------ 52 | -- Whitespace 53 | ------------------------------------------------------------------------------ 54 | 55 | ||| A whitespace character. 56 | data S_ws' : Char -> List Char -> Type where 57 | Space : S_ws' ' ' [' '] 58 | HorizontalTab : S_ws' '\t' ['\t'] 59 | VerticalTab : S_ws' '\v' ['\v'] 60 | LineFeed : S_ws' '\n' ['\n'] 61 | CarriageReturn : S_ws' '\r' ['\r'] 62 | 63 | ||| Insignificant whitespace, §2 64 | S_ws : List Char -> List Char -> Type 65 | S_ws = ListS S_ws' 66 | 67 | ------------------------------------------------------------------------------ 68 | -- Structural Characters 69 | ------------------------------------------------------------------------------ 70 | 71 | ||| Structural characters, §2 72 | StructuralChar : Char -> () -> List Char -> Type 73 | StructuralChar c = Map (const ()) (S_ws .. CharS c .. S_ws) 74 | 75 | S_begin_array : () -> List Char -> Type 76 | S_begin_array = StructuralChar '[' 77 | 78 | S_begin_object : () -> List Char -> Type 79 | S_begin_object = StructuralChar '{' 80 | 81 | S_end_array : () -> List Char -> Type 82 | S_end_array = StructuralChar ']' 83 | 84 | S_end_object : () -> List Char -> Type 85 | S_end_object = StructuralChar '}' 86 | 87 | S_name_separator : () -> List Char -> Type 88 | S_name_separator = StructuralChar ':' 89 | 90 | S_value_separator : () -> List Char -> Type 91 | S_value_separator = StructuralChar ',' 92 | 93 | ------------------------------------------------------------------------------ 94 | -- Numbers 95 | ------------------------------------------------------------------------------ 96 | 97 | hexValue : Char -> Int 98 | hexValue c = if isDigit c 99 | then ord c - ord '0' 100 | else ord (toUpper c) - ord 'A' + 10 101 | 102 | data S_DIGIT : Int -> List Char -> Type where 103 | MkS_DIGIT : (c : Char) -> {auto ok : So (isDigit c)} -> S_DIGIT (hexValue c) [c] 104 | data S_digit1_9 : Int -> List Char -> Type where 105 | MkS_digit1_9 : (c : Char) -> {auto ok : So (isDigit c && c /= '0')} -> S_digit1_9 (hexValue c) [c] 106 | 107 | data S_int : Integer -> List Char -> Type where 108 | S_zero : S_int 0 ['0'] 109 | NonZero : (S_digit1_9 .. ListS S_DIGIT) (x, xs) text -> S_int (cast $ pack text) text 110 | 111 | data S_e : () -> List Char -> Type where 112 | UpperCaseE : S_e () ['E'] 113 | LowerCaseE : S_e () ['e'] 114 | 115 | data Sign = Plus | Minus 116 | data S_sign : Bool -> Sign -> List Char -> Type where 117 | S_plus : S_sign True Plus ['+'] 118 | S_minus : S_sign plusAllowed Minus ['-'] 119 | 120 | signed : Maybe Sign -> Integer -> Integer 121 | signed (Just Minus) x = -x 122 | signed _ x = x 123 | 124 | fromDigits : Int -> List Int -> Integer 125 | fromDigits x [] = cast x 126 | fromDigits x (y :: ys) = 10 * (cast x) + fromDigits y ys 127 | 128 | data S_decimal_point : () -> List Char -> Type where 129 | MkS_decimal_point : S_decimal_point () ['.'] 130 | 131 | data S_frac : Integer -> List Char -> Type where 132 | MkS_frac : (S_decimal_point .. S_DIGIT .. ListS S_DIGIT) (_, d, ds) text -> 133 | S_frac (fromDigits d ds) text 134 | 135 | data S_exp : Integer -> List Char -> Type where 136 | MkS_exp : (S_e .. MaybeS (S_sign True) .. S_DIGIT .. ListS S_DIGIT) (e, s, d, ds) text -> 137 | S_exp (signed s $ fromDigits d ds) text 138 | 139 | ------------------------------------------------------------------------------ 140 | -- Strings 141 | ------------------------------------------------------------------------------ 142 | 143 | data S_HEXDIG : Nat -> List Char -> Type where 144 | MkS_HEXDIG_0 : (x : Nat) -> x `LTE` 9 -> S_HEXDIG x [chr (ord '0' + (toIntNat x))] 145 | MkS_HEXDIG_A : (x : Nat) -> x `LTE` 15 -> (x `LTE` 9 -> Void) -> S_HEXDIG x [chr (ord 'A' - 10 + (toIntNat x))] 146 | MkS_HEXDIG_a : (x : Nat) -> x `LTE` 15 -> (x `LTE` 9 -> Void) -> S_HEXDIG x [chr (ord 'a' - 10 + (toIntNat x))] 147 | 148 | HexQuad : Int -> List Char -> Type 149 | HexQuad = Map (\(a,b,c,d) => (toIntNat a)*0x1000 + (toIntNat b)*0x100 + (toIntNat c)*0x10 +(toIntNat d)*0x1) (S_HEXDIG .. S_HEXDIG .. S_HEXDIG .. S_HEXDIG) 150 | 151 | unicodeSurrogatePair : (c : Char) -> (Int, Int) 152 | unicodeSurrogatePair c = case (highSurrogate, lowSurrogate) of 153 | (MkBits l, MkBits h) => (prim__sextB32_Int l, prim__sextB32_Int h) 154 | where 155 | cv : Bits 20 156 | cv = cast (the Integer (cast $ ord c - 0x010000)) 157 | 158 | highSurrogate : Bits 20 159 | highSurrogate = (shiftRightLogical cv (cast 10)) `Data.Bits.or` (cast 0xD800) 160 | 161 | lowSurrogate : Bits 20 162 | lowSurrogate = (cv `and` (cast 0x3FF)) `Data.Bits.or` (cast 0xDC00) 163 | 164 | allowedUnescaped : Char -> Bool 165 | allowedUnescaped c = let cv = ord c in 166 | (cv >= 0x20 && cv <= 0x21) || 167 | (cv >= 0x23 && cv <= 0x5B) || 168 | (cv >= 0x5D && cv <= 0x10FFFF) 169 | 170 | ||| Semantics for characters in JSON strings, rfc7159 §7 171 | data S_char : Char -> List Char -> Type where 172 | S_unescaped : (c : Char) -> So (allowedUnescaped c) -> S_char c [c] 173 | 174 | S_unicode_escape : (c : Char) -> 175 | So (c <= chr 0xFFFF) -> 176 | HexQuad (ord c) text -> 177 | S_char c ('\\' :: 'u' :: text) 178 | S_unicode_surrogate_pair : (c : Char) -> 179 | (rangeProof : So (not (c <= chr 0xFFFF))) -> 180 | HexQuad (fst $ unicodeSurrogatePair c) text1 -> 181 | HexQuad (snd $ unicodeSurrogatePair c) text2 -> 182 | S_char c ('\\' :: 'u' :: text1 ++ ('\\' :: 'u' :: text2)) 183 | 184 | 185 | S_escape_quotation_mark : S_char '"' ['\\','"'] 186 | S_escape_reverse_solidus : S_char '\\' ['\\','\\'] 187 | S_escape_solidus : S_char '/' ['\\','/'] 188 | S_escape_backspace : S_char '\b' ['\\','b'] 189 | S_escape_form_feed : S_char '\f' ['\\','f'] 190 | S_escape_line_feed : S_char '\n' ['\\','n'] 191 | S_escape_carriage_return : S_char '\r' ['\\','r'] 192 | S_escape_tab : S_char '\t' ['\\','t'] 193 | 194 | 195 | ||| JSON string semantics, rfc7159 §7 196 | S_string' : String -> List Char -> Type 197 | S_string' = Map (\(_, cs, _) => pack cs) $ CharS '"' .. ListS S_char .. CharS '"' 198 | 199 | ------------------------------------------------------------------------------ 200 | -- Values 201 | ------------------------------------------------------------------------------ 202 | 203 | toJsonList : ((), Maybe (JsonValue, List ((), JsonValue)), ()) -> List JsonValue 204 | toJsonList (_, (Just (v, vs)), _) = v :: map snd vs 205 | toJsonList (_, Nothing, _) = [] 206 | 207 | toJsonPropList : ((), Maybe ((String, JsonValue), List ((), String, JsonValue)), ()) -> List (String, JsonValue) 208 | toJsonPropList (_, Just (kv, kvs), _) = kv :: map snd kvs 209 | toJsonPropList (_, Nothing, _) = [] 210 | 211 | mutual 212 | ||| Semantics for JSON object members, rfc7159 §4 213 | data S_member : (String, JsonValue) -> List Char -> Type where 214 | MkS_member : (S_string' .. S_name_separator .. S_value) (k, _, v) text -> S_member (k, v) text 215 | 216 | ||| JSON value semantics, rfc7159 §3 217 | data S_value : JsonValue -> List Char -> Type where 218 | 219 | ||| JSON null semantics, rfc7159 §3 220 | S_null : S_value JsonNull ['n','u','l','l'] 221 | 222 | ||| JSON true semantics, rfc7159 §3 223 | S_true : S_value (JsonBool True) ['t','r','u','e'] 224 | 225 | ||| JSON false semantics, rfc7159 §3 226 | S_false : S_value (JsonBool False) ['f','a','l','s','e'] 227 | 228 | ||| JSON string semantics, rfc7159 §7 229 | S_string : S_string' s text -> S_value (JsonString s) text 230 | 231 | ||| JSON object semantics, rfc7159 §4 232 | S_object : (S_begin_object .. (MaybeS (S_member .. ListS (S_value_separator .. S_member))) .. S_end_object) value text -> 233 | S_value (JsonObject $ toJsonPropList value) text 234 | 235 | ||| JSON arrays semantics, rfc7159 §5 236 | S_array : (S_begin_array .. (MaybeS (S_value .. ListS (S_value_separator .. S_value))) .. S_end_array) value text -> 237 | S_value (JsonArray $ toJsonList value) text 238 | 239 | ||| JSON number semantics, rfc7159 §6 240 | S_number : (MaybeS (S_sign False) .. S_int .. MaybeS S_frac .. MaybeS S_exp) value text -> 241 | S_value (JsonNumber $ cast $ pack text) text 242 | 243 | ------------------------------------------------------------------------------ 244 | -- Top-level 245 | ------------------------------------------------------------------------------ 246 | 247 | ||| Semantics for the top-level JSON document, rfc7159 §2 248 | data S_JSON_text : JsonValue -> List Char -> Type where 249 | MkS_JSON_text : (S_ws .. S_value .. S_ws) (_, v, _) text -> S_JSON_text v text 250 | -------------------------------------------------------------------------------- /Data/JSON/Type.idr: -------------------------------------------------------------------------------- 1 | module Data.JSON.Type 2 | 3 | public export 4 | data JsonValue : Type where 5 | JsonNull : JsonValue 6 | JsonBool : Bool -> JsonValue 7 | JsonString : String -> JsonValue 8 | JsonArray : List JsonValue -> JsonValue 9 | JsonObject : List (String, JsonValue) -> JsonValue 10 | JsonNumber : Double -> JsonValue 11 | 12 | %name JsonValue v 13 | --------------------------------------------------------------------------------