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@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@1: FromJson = fn _ => error Uhoh!}