# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1291309195 18000
# Node ID 478524b9d23afcd550a8d2a9b63679c86b6c6b81
# Parent  4d103b4450ee9e8725db1076af65c847777214b6
Parsed a JSON record

diff -r 4d103b4450ee -r 478524b9d23a json.ur
--- a/json.ur	Thu Dec 02 11:35:01 2010 -0500
+++ b/json.ur	Thu Dec 02 11:59:55 2010 -0500
@@ -198,4 +198,57 @@
                                                                        "" => ""
                                                                      | _ => "," ^ acc))
                              "" fl jss names r ^ "}",
-     FromJson = fn _ => error <xml>Uhoh!</xml>}
+     FromJson = fn s =>
+                   let
+                       fun fromJ s (r : $(map option ts)) : $(map option ts) * 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 naem</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 _ => error <xml>Unknown JSON object field name {[name]}</xml>)
+                                                  fl jss names 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 (String.substring s {Start = 1, Len = String.length s - 1})
+                                                   (@map0 [option] (fn [t ::_] => None) fl)
+                           in
+                               (@map2 [option] [fn _ => string] [id] (fn [t] (v : option t) name =>
+                                                                         case v of
+                                                                             None => error <xml>Missing JSON object field {[name]}</xml>
+                                                                           | Some v => v) fl r names, s')
+                           end
+                   end}
diff -r 4d103b4450ee -r 478524b9d23a tests/testJson.ur
--- a/tests/testJson.ur	Thu Dec 02 11:35:01 2010 -0500
+++ b/tests/testJson.ur	Thu Dec 02 11:59:55 2010 -0500
@@ -3,18 +3,21 @@
 val json_abcd : json {A : int, B : float, C : string, D : bool} =
     json_record {A = "a", B = "b", C = "c", D = "d"}
 
-fun main () : transaction page = return <xml><body>
-  {[toJson (1 :: 2 :: 8 :: [])]}<br/>
-  {[fromJson "[1,2, 8]" : list int]}
-  <hr/>
-  {[toJson (1.2 :: 2.4 :: (-8.8) :: [])]}<br/>
-  {[fromJson "[1.4,-2.7, 8.215506]" : list float]}
-  <hr/>
-  {[toJson ("hi" :: "bye" :: "tricky\\\" one!" :: [])]}<br/>
-  {[fromJson "[\"abc\", \"\\\\whoa\"]" : list string]}
-  <hr/>
-  {[toJson (True :: False :: True :: [])]}<br/>
-  {[fromJson "[true,false, true]" : list bool]}
-  <hr/>
-  {[toJson {A = 1, B = 2.3, C = "Hi", D = True}]}
-</body></xml>
+fun main () : transaction page =
+    d <- return (fromJson "{\"a\": 1, \"b\": 2.3, \"c\": \"Hi\", \"d\": true}" : {A : int, B : float, C : string, D : bool});
+    return <xml><body>
+      {[toJson (1 :: 2 :: 8 :: [])]}<br/>
+      {[fromJson "[1,2, 8]" : list int]}
+      <hr/>
+      {[toJson (1.2 :: 2.4 :: (-8.8) :: [])]}<br/>
+      {[fromJson "[1.4,-2.7, 8.215506]" : list float]}
+      <hr/>
+      {[toJson ("hi" :: "bye" :: "tricky\\\" one!" :: [])]}<br/>
+      {[fromJson "[\"abc\", \"\\\\whoa\"]" : list string]}
+      <hr/>
+      {[toJson (True :: False :: True :: [])]}<br/>
+      {[fromJson "[true,false, true]" : list bool]}
+      <hr/>
+      {[toJson {A = 1, B = 2.3, C = "Hi", D = True}]}<br/>
+      A: {[d.A]}, B: {[d.B]}, C: {[d.C]}, D: {[d.D]}
+    </body></xml>