Merge branch 'upstream' into dfsg_clean20200209+dfsgdfsg_clean

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 =>