summaryrefslogtreecommitdiff
path: root/lib/ur/json.ur
diff options
context:
space:
mode:
Diffstat (limited to 'lib/ur/json.ur')
-rw-r--r--lib/ur/json.ur190
1 files changed, 176 insertions, 14 deletions
diff --git a/lib/ur/json.ur b/lib/ur/json.ur
index 817ec16e..1222cdbf 100644
--- a/lib/ur/json.ur
+++ b/lib/ur/json.ur
@@ -51,9 +51,7 @@ fun escape s =
| #"\r" => "\\r"
| #"\t" => "\\t"
| #"\"" => "\\\""
- | #"\'" => "\\\'"
| #"\\" => "\\\\"
- | #"/" => "\\/"
| x => String.str ch
) ^ esc (String.suffix s 1)
end
@@ -61,64 +59,143 @@ fun escape s =
"\"" ^ esc s
end
+fun unhex ch =
+ if Char.isDigit ch then
+ Char.toInt ch - Char.toInt #"0"
+ else if Char.isXdigit ch then
+ if Char.isUpper ch then
+ 10 + (Char.toInt ch - Char.toInt #"A")
+ else
+ 10 + (Char.toInt ch - Char.toInt #"a")
+ else
+ error <xml>Invalid hexadecimal digit "{[ch]}"</xml>
+
fun unescape s =
let
val len = String.length s
- fun findEnd i =
+ fun findEnd i s =
if i >= len then
error <xml>JSON unescape: string ends before quote: {[s]}</xml>
else
let
- val ch = String.sub s i
+ val ch = String.sub s 0
in
case ch of
#"\"" => i
| #"\\" =>
if i+1 >= len then
error <xml>JSON unescape: Bad escape sequence: {[s]}</xml>
+ else if String.sub s 1 = #"u" then
+ if i+5 >= len then
+ error <xml>JSON unescape: Bad escape sequence: {[s]}</xml>
+ else
+ findEnd (i+6) (String.suffix s 6)
else
- findEnd (i+2)
- | _ => findEnd (i+1)
+ findEnd (i+2) (String.suffix s 2)
+ | _ => findEnd (i+1) (String.suffix s 1)
end
- val last = findEnd 1
+ val last = findEnd 1 (String.suffix s 1)
- fun unesc i =
+ fun unesc i s =
if i >= last then
""
else
let
- val ch = String.sub s i
+ val ch = String.sub s 0
in
case ch of
#"\\" =>
if i+1 >= len then
error <xml>JSON unescape: Bad escape sequence: {[s]}</xml>
+ else if String.sub s 1 = #"u" then
+ if i+5 >= len then
+ error <xml>JSON unescape: Unicode ends early</xml>
+ else
+ let
+ val n =
+ unhex (String.sub s 2) * (256*16)
+ + unhex (String.sub s 3) * 256
+ + unhex (String.sub s 4) * 16
+ + unhex (String.sub s 5)
+ in
+ ofUnicode n ^ unesc (i+6) (String.suffix s 6)
+ end
else
- (case String.sub s (i+1) of
+ (case String.sub s 1 of
#"n" => "\n"
| #"r" => "\r"
| #"t" => "\t"
| #"\"" => "\""
- | #"\'" => "\'"
| #"\\" => "\\"
| #"/" => "/"
| x => error <xml>JSON unescape: Bad escape char: {[x]}</xml>)
^
- unesc (i+2)
- | _ => String.str ch ^ unesc (i+1)
+ unesc (i+2) (String.suffix s 2)
+ | _ => String.str ch ^ unesc (i+1) (String.suffix s 1)
end
in
if len = 0 || String.sub s 0 <> #"\"" then
error <xml>JSON unescape: String doesn't start with double quote: {[s]}</xml>
else
- (unesc 1, String.substring s {Start = last+1, Len = len-last-1})
+ (unesc 1 (String.suffix s 1), String.suffix s (last+1))
end
val json_string = {ToJson = escape,
FromJson = unescape}
+fun rfc3339_out s =
+ let
+ val out1 = timef "%Y-%m-%dT%H:%M:%S%z" s
+ val len = String.length out1
+ in
+ if len < 2 then
+ error <xml>timef output too short</xml>
+ else
+ String.substring out1 {Start = 0, Len = len - 2} ^ ":"
+ ^ String.suffix out1 (len - 2)
+ end
+
+fun rfc3339_in s =
+ case String.split s #"T" of
+ None => error <xml>Invalid RFC 3339 string "{[s]}"</xml>
+ | Some (date, time) =>
+ case String.msplit {Haystack = time, Needle = "Z+-"} of
+ None => error <xml>Invalid RFC 3339 string "{[s]}"</xml>
+ | Some (time, sep, rest) =>
+ let
+ val time = case String.split time #"." of
+ None => time
+ | Some (time, _) => time
+
+ val t = case readUtc (date ^ " " ^ time) of
+ None => error <xml>Invalid RFC 3339 string "{[s]}"</xml>
+ | Some t => t
+
+ fun withOffset multiplier =
+ case String.split rest #":" of
+ None => error <xml>Invalid RFC 3339 string "{[s]}"</xml>
+ | Some (h, m) =>
+ case (read h, read m) of
+ (Some h, Some m) => addSeconds t (multiplier * 60 * (60 * h + m))
+ | _ => error <xml>Invalid RFC 3339 string "{[s]}"</xml>
+ in
+ case sep of
+ #"Z" => t
+ | #"+" => withOffset (-1)
+ | #"-" => withOffset 1
+ | _ => error <xml>msplit returns impossible separator</xml>
+ end
+
+val json_time = {ToJson = fn tm => escape (rfc3339_out tm),
+ FromJson = fn s =>
+ let
+ val (v, s') = unescape s
+ in
+ (rfc3339_in v, s')
+ end}
+
fun numIn [a] (_ : read a) s : a * string =
let
val len = String.length s
@@ -261,6 +338,91 @@ fun skipOne s =
skipOne s False False 0 0
end
+fun json_record_withOptional [ts ::: {Type}] [ots ::: {Type}] [ts ~ ots]
+ (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts))
+ (ofl : folder ots) (ojss : $(map json ots)) (onames : $(map (fn _ => string) ots)): json $(ts ++ map option ots) =
+ {ToJson = fn r =>
+ let
+ val withRequired =
+ @foldR3 [json] [fn _ => string] [ident] [fn _ => string]
+ (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc =>
+ escape name ^ ":" ^ j.ToJson v ^ (case acc of
+ "" => ""
+ | acc => "," ^ acc))
+ "" fl jss names (r --- _)
+
+ val withOptional =
+ @foldR3 [json] [fn _ => string] [option] [fn _ => string]
+ (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc =>
+ case v of
+ None => acc
+ | Some v =>
+ escape name ^ ":" ^ j.ToJson v ^ (case acc of
+ "" => ""
+ | acc => "," ^ acc))
+ withRequired ofl ojss onames (r --- _)
+ in
+ "{" ^ withOptional ^ "}"
+ end,
+ FromJson = fn s =>
+ let
+ fun fromJ s (r : $(map option (ts ++ ots))) : $(map option (ts ++ ots)) * string =
+ if String.length s = 0 then
+ error <xml>JSON object doesn't end in brace</xml>
+ else if String.sub s 0 = #"}" then
+ (r, String.substring s {Start = 1, Len = String.length s - 1})
+ else let
+ val (name, s') = unescape s
+ val s' = skipSpaces s'
+ val s' = if String.length s' = 0 || String.sub s' 0 <> #":" then
+ error <xml>No colon after JSON object field name</xml>
+ else
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+
+ val (r, s') = @foldR2 [json] [fn _ => string] [fn ts => $(map option ts) -> $(map option ts) * string]
+ (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name' acc r =>
+ if name = name' then
+ let
+ val (v, s') = j.FromJson s'
+ in
+ (r -- nm ++ {nm = Some v}, s')
+ end
+ else
+ let
+ val (r', s') = acc (r -- nm)
+ in
+ (r' ++ {nm = r.nm}, s')
+ end)
+ (fn r => (r, skipOne s'))
+ (@Folder.concat ! fl ofl) (jss ++ ojss) (names ++ onames) r
+
+ val s' = skipSpaces s'
+ val s' = if String.length s' <> 0 && String.sub s' 0 = #"," then
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+ else
+ s'
+ in
+ fromJ s' r
+ end
+ in
+ if String.length s = 0 || String.sub s 0 <> #"{" then
+ error <xml>JSON record doesn't begin with brace</xml>
+ else
+ let
+ val (r, s') = fromJ (skipSpaces (String.substring s {Start = 1, Len = String.length s - 1}))
+ (@map0 [option] (fn [t ::_] => None) (@Folder.concat ! fl ofl))
+ in
+ (@map2 [option] [fn _ => string] [ident] (fn [t] (v : option t) name =>
+ case v of
+ None => error <xml>Missing JSON object field {[name]}</xml>
+ | Some v => v) fl (r --- _) names
+ ++ (r --- _), s')
+ end
+end}
+
+(* At the moment, the below code is largely copied and pasted from the last
+ * definition, because otherwise the compiler fails to inline enough for
+ * compilation to succeed. *)
fun json_record [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json $ts =
{ToJson = fn r => "{" ^ @foldR3 [json] [fn _ => string] [ident] [fn _ => string]
(fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc =>
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-28 21:56:56 +0000