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
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@1: {ToJson = fn r => "{" ^ @foldR3 [json] [fn _ => string] [id] [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
adam@2: error No colon after JSON object field naem
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@2: (@map2 [option] [fn _ => string] [id] (fn [t] (v : option t) name =>
adam@2: case v of
adam@2: None => error Missing JSON object field {[name]}
adam@2: | Some v => v) fl r names, s')
adam@2: end
adam@2: end}