adam@0: class json a = {ToJson : a -> string,
adam@0: FromJson : string -> a * string}
adam@0:
adam@0: fun mkJson [a] (x : {ToJson : a -> string,
adam@0: FromJson : string -> a * string}) = x
adam@0:
adam@0: fun skipSpaces s =
adam@0: let
adam@0: val len = String.length s
adam@0:
adam@0: fun skip i =
adam@0: if i >= len then
adam@0: ""
adam@0: else
adam@0: let
adam@0: val ch = String.sub s i
adam@0: in
adam@0: if Char.isSpace ch then
adam@0: skip (i+1)
adam@0: else
adam@0: String.substring s {Start = i, Len = len-i}
adam@0: end
adam@0: in
adam@0: skip 0
adam@0: end
adam@0:
adam@0: fun toJson [a] (j : json a) : a -> string = j.ToJson
ezyang@23: fun fromJson' [a] (j : json a) : string -> a * string = j.FromJson
adam@0:
adam@0: fun fromJson [a] (j : json a) (s : string) : a =
adam@0: let
adam@0: val (v, s') = j.FromJson (skipSpaces s)
adam@0: in
adam@0: if String.all Char.isSpace s' then
adam@0: v
adam@0: else
adam@0: error Extra content at end of JSON record: {[s']}
adam@0: end
adam@0:
adam@0: fun escape s =
adam@0: let
adam@0: val len = String.length s
adam@0:
adam@0: fun esc i =
adam@0: if i >= len then
adam@0: "\""
adam@0: else
adam@0: let
adam@0: val ch = String.sub s i
adam@0: in
adam@0: (if ch = #"\"" || ch = #"\\" then
adam@0: "\\" ^ String.str ch
adam@0: else
adam@0: String.str ch) ^ esc (i+1)
adam@0: end
adam@0: in
adam@0: "\"" ^ esc 0
adam@0: end
adam@0:
adam@0: fun unescape s =
adam@0: let
adam@0: val len = String.length s
adam@0:
adam@0: fun findEnd i =
adam@0: if i >= len then
adam@0: error JSON unescape: string ends before quote: {[s]}
adam@0: else
adam@0: let
adam@0: val ch = String.sub s i
adam@0: in
adam@0: case ch of
adam@0: #"\"" => i
adam@0: | #"\\" =>
adam@0: if i+1 >= len then
adam@0: error JSON unescape: Bad escape sequence: {[s]}
adam@0: else
adam@0: findEnd (i+2)
adam@0: | _ => findEnd (i+1)
adam@0: end
adam@0:
adam@0: val last = findEnd 1
adam@0:
adam@0: fun unesc i =
adam@0: if i >= last then
adam@0: ""
adam@0: else
adam@0: let
adam@0: val ch = String.sub s i
adam@0: in
adam@0: case ch of
adam@0: #"\\" =>
adam@0: if i+1 >= len then
adam@0: error JSON unescape: Bad escape sequence: {[s]}
adam@0: else
adam@0: String.str (String.sub s (i+1)) ^ unesc (i+2)
adam@0: | _ => String.str ch ^ unesc (i+1)
adam@0: end
adam@0: in
adam@0: if len = 0 || String.sub s 0 <> #"\"" then
adam@0: error JSON unescape: String doesn't start with double quote: {[s]}
adam@0: else
adam@0: (unesc 1, String.substring s {Start = last+1, Len = len-last-1})
adam@0: end
adam@0:
adam@0: val json_string = {ToJson = escape,
adam@0: FromJson = unescape}
adam@0:
adam@0: fun numIn [a] (_ : read a) s : a * string =
adam@0: let
adam@0: val len = String.length s
adam@0:
adam@0: fun findEnd i =
adam@0: if i >= len then
adam@0: i
adam@0: else
adam@0: let
adam@0: val ch = String.sub s i
adam@0: in
adam@0: if Char.isDigit ch || ch = #"-" || ch = #"." || ch = #"E" || ch = #"e" then
adam@0: findEnd (i+1)
adam@0: else
adam@0: i
adam@0: end
adam@0:
adam@0: val last = findEnd 0
adam@0: in
adam@0: (readError (String.substring s {Start = 0, Len = last}), String.substring s {Start = last, Len = len-last})
adam@0: end
adam@0:
adam@0: fun json_num [a] (_ : show a) (_ : read a) : json a = {ToJson = show,
adam@0: FromJson = numIn}
adam@0:
adam@0: val json_int = json_num
adam@0: val json_float = json_num
adam@0:
adam@0: val json_bool = {ToJson = fn b => if b then "true" else "false",
adam@0: FromJson = fn s => if String.isPrefix {Full = s, Prefix = "true"} then
adam@0: (True, String.substring s {Start = 4, Len = String.length s - 4})
adam@0: else if String.isPrefix {Full = s, Prefix = "false"} then
adam@0: (False, String.substring s {Start = 5, Len = String.length s - 5})
adam@0: else
adam@0: error JSON: bad boolean string: {[s]}}
adam@0:
adam@4: fun json_option [a] (j : json a) : json (option a) =
adam@4: {ToJson = fn v => case v of
adam@4: None => "null"
adam@4: | Some v => j.ToJson v,
adam@4: FromJson = fn s => if String.isPrefix {Full = s, Prefix = "null"} then
adam@4: (None, String.substring s {Start = 4, Len = String.length s - 4})
adam@4: else
adam@4: let
adam@4: val (v, s') = j.FromJson s
adam@4: in
adam@4: (Some v, s')
adam@4: end}
adam@4:
adam@0: fun json_list [a] (j : json a) : json (list a) =
adam@0: let
adam@0: fun toJ' (ls : list a) : string =
adam@0: case ls of
adam@0: [] => ""
adam@0: | x :: ls => "," ^ toJson j x ^ toJ' ls
adam@0:
adam@0: fun toJ (x : list a) : string =
adam@0: case x of
adam@0: [] => "[]"
adam@0: | x :: [] => "[" ^ toJson j x ^ "]"
adam@0: | x :: ls => "[" ^ toJson j x ^ toJ' ls ^ "]"
adam@0:
adam@0: fun fromJ (s : string) : list a * string =
adam@0: let
adam@0: fun fromJ' (s : string) : list a * string =
adam@0: if String.length s = 0 then
adam@0: error JSON list doesn't end with ']'
adam@0: else
adam@0: let
adam@0: val ch = String.sub s 0
adam@0: in
adam@0: case ch of
adam@0: #"]" => ([], String.substring s {Start = 1, Len = String.length s - 1})
adam@0: | _ =>
adam@0: let
adam@0: val (x, s') = j.FromJson s
adam@0: val s' = skipSpaces s'
adam@0: val s' = if String.length s' = 0 then
adam@0: error JSON list doesn't end with ']'
adam@0: else if String.sub s' 0 = #"," then
adam@0: skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
adam@0: else
adam@0: s'
adam@0:
adam@0: val (ls, s'') = fromJ' s'
adam@0: in
adam@0: (x :: ls, s'')
adam@0: end
adam@0: end
adam@0: in
adam@0: if String.length s = 0 || String.sub s 0 <> #"[" then
adam@0: error JSON list doesn't start with '[': {[s]}
adam@0: else
adam@0: fromJ' (skipSpaces (String.substring s {Start = 1, Len = String.length s - 1}))
adam@0: end
adam@0: in
adam@0: {ToJson = toJ,
adam@0: FromJson = fromJ}
adam@0: end
adam@1:
adam@1: fun json_record [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json $ts =
adam@18: {ToJson = fn r => "{" ^ @foldR3 [json] [fn _ => string] [ident] [fn _ => string]
adam@1: (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc =>
adam@1: escape name ^ ":" ^ j.ToJson v ^ (case acc of
adam@1: "" => ""
adam@1: | _ => "," ^ acc))
adam@1: "" fl jss names r ^ "}",
adam@2: FromJson = fn s =>
adam@2: let
adam@2: fun fromJ s (r : $(map option ts)) : $(map option ts) * string =
adam@2: if String.length s = 0 then
adam@2: error JSON object doesn't end in brace
adam@2: else if String.sub s 0 = #"}" then
adam@2: (r, String.substring s {Start = 1, Len = String.length s - 1})
adam@2: else let
adam@2: val (name, s') = unescape s
adam@2: val s' = skipSpaces s'
adam@2: val s' = if String.length s' = 0 || String.sub s' 0 <> #":" then
ezyang@22: error No colon after JSON object field name
adam@2: else
adam@2: skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
adam@2:
adam@2: val (r, s') = @foldR2 [json] [fn _ => string] [fn ts => $(map option ts) -> $(map option ts) * string]
adam@2: (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name' acc r =>
adam@2: if name = name' then
adam@2: let
adam@2: val (v, s') = j.FromJson s'
adam@2: in
adam@2: (r -- nm ++ {nm = Some v}, s')
adam@2: end
adam@2: else
adam@2: let
adam@2: val (r', s') = acc (r -- nm)
adam@2: in
adam@2: (r' ++ {nm = r.nm}, s')
adam@2: end)
adam@2: (fn _ => error Unknown JSON object field name {[name]})
adam@2: fl jss names r
adam@2:
adam@2: val s' = skipSpaces s'
adam@2: val s' = if String.length s' <> 0 && String.sub s' 0 = #"," then
adam@2: skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
adam@2: else
adam@2: s'
adam@2: in
adam@2: fromJ s' r
adam@2: end
adam@2: in
adam@2: if String.length s = 0 || String.sub s 0 <> #"{" then
adam@2: error JSON record doesn't begin with brace
adam@2: else
adam@2: let
adam@3: val (r, s') = fromJ (skipSpaces (String.substring s {Start = 1, Len = String.length s - 1}))
adam@2: (@map0 [option] (fn [t ::_] => None) fl)
adam@2: in
adam@18: (@map2 [option] [fn _ => string] [ident] (fn [t] (v : option t) name =>
adam@18: case v of
adam@18: None => error Missing JSON object field {[name]}
adam@18: | Some v => v) fl r names, s')
adam@2: end
adam@2: end}
ezyang@22:
ezyang@22: fun json_variant [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json (variant ts) =
ezyang@22: {ToJson = fn r => let val jnames = @map2 [json] [fn _ => string] [fn x => json x * string]
ezyang@22: (fn [t] (j : json t) (name : string) => (j, name)) fl jss names
ezyang@22: in @Variant.destrR [ident] [fn x => json x * string]
ezyang@22: (fn [p ::_] (v : p) (j : json p, name : string) =>
ezyang@22: "{" ^ escape name ^ ":" ^ j.ToJson v ^ "}") fl r jnames
ezyang@22: end,
ezyang@22: FromJson = fn s =>
ezyang@22: if String.length s = 0 || String.sub s 0 <> #"{" then
ezyang@22: error JSON variant doesn't begin with brace
ezyang@22: else
ezyang@22: let
ezyang@23: val (name, s') = unescape (skipSpaces (String.suffix s 1))
ezyang@22: val s' = skipSpaces s'
ezyang@22: val s' = if String.length s' = 0 || String.sub s' 0 <> #":" then
ezyang@22: error No colon after JSON object field name
ezyang@22: else
ezyang@22: skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
ezyang@22:
ezyang@22: val (r, s') = (@foldR2 [json] [fn _ => string]
ezyang@22: [fn ts => ts' :: {Type} -> [ts ~ ts'] => variant (ts ++ ts') * string]
ezyang@22: (fn [nm ::_] [t ::_] [rest ::_] [[nm] ~ rest] (j : json t) name'
ezyang@22: (acc : ts' :: {Type} -> [rest ~ ts'] => variant (rest ++ ts') * string) [fwd ::_] [[nm = t] ++ rest ~ fwd] =>
ezyang@22: if name = name'
ezyang@22: then
ezyang@22: let val (v, s') = j.FromJson s'
ezyang@22: in (make [nm] v, s')
ezyang@22: end
ezyang@22: else acc [fwd ++ [nm = t]]
ezyang@22: )
ezyang@22: (fn [fwd ::_] [[] ~ fwd] => error Unknown JSON object variant name {[name]})
ezyang@22: fl jss names) [[]] !
ezyang@22:
ezyang@22: val s' = skipSpaces s'
ezyang@22: val s' = if String.length s' <> 0 && String.sub s' 0 = #"," then
ezyang@22: skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
ezyang@22: else
ezyang@22: s'
ezyang@22: in
ezyang@22: if String.length s' = 0 then
ezyang@22: error JSON object doesn't end in brace
ezyang@22: else if String.sub s' 0 = #"}" then
ezyang@22: (r, String.substring s' {Start = 1, Len = String.length s' - 1})
ezyang@22: else error Junk after JSON value in object
ezyang@22: end
ezyang@22: }
ezyang@22:
ezyang@22: val json_unit : json unit = json_record {} {}
ezyang@23:
ezyang@23: functor Recursive (M : sig
ezyang@23: con t :: Type -> Type
ezyang@23: val json_t : a ::: Type -> json a -> json (t a)
ezyang@23: end) = struct
ezyang@23: open M
ezyang@23:
ezyang@23: datatype r = Rec of t r
ezyang@23:
ezyang@23: fun rTo (Rec x) = (json_t {ToJson = rTo,
ezyang@23: FromJson = fn _ => error Tried to FromJson in ToJson!}).ToJson x
ezyang@23:
ezyang@23: fun rFrom s =
ezyang@23: let
ezyang@23: val (x, s') = (json_t {ToJson = fn _ => error Tried to ToJson in FromJson!,
ezyang@23: FromJson = rFrom}).FromJson s
ezyang@23: in
ezyang@23: (Rec x, s')
ezyang@23: end
ezyang@23:
ezyang@23: val json_r = {ToJson = rTo, FromJson = rFrom}
ezyang@23: end