changeset 23:9d6b931fbd13

Implement JSON type class for recursive datatypes, using Mu combinator.
author Edward Z. Yang <ezyang@mit.edu>
date Wed, 02 May 2012 11:47:37 -0400
parents 8de201d70b91
children 693ab4dd1e9e
files json.ur json.urs tests/testJson.ur tests/testJson.urs
diffstat 4 files changed, 77 insertions(+), 2 deletions(-) [+]
line wrap: on
line diff
--- a/json.ur	Wed May 02 11:47:37 2012 -0400
+++ b/json.ur	Wed May 02 11:47:37 2012 -0400
@@ -25,6 +25,7 @@
     end
 
 fun toJson [a] (j : json a) : a -> string = j.ToJson
+fun fromJson' [a] (j : json a) : string -> a * string = j.FromJson
 
 fun fromJson [a] (j : json a) (s : string) : a =
     let
@@ -278,7 +279,7 @@
                        error <xml>JSON variant doesn't begin with brace</xml>
                    else
                        let
-                           val (name, s') = unescape s
+                           val (name, s') = unescape (skipSpaces (String.suffix s 1))
                            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>
@@ -314,3 +315,25 @@
                    }
 
 val json_unit : json unit = json_record {} {}
+
+functor Recursive (M : sig
+                       con t :: Type -> Type
+                       val json_t : a ::: Type -> json a -> json (t a)
+                   end) = struct
+    open M
+
+    datatype r = Rec of t r
+
+    fun rTo (Rec x) = (json_t {ToJson = rTo,
+                               FromJson = fn _ => error <xml>Tried to FromJson in ToJson!</xml>}).ToJson x
+
+    fun rFrom s =
+        let
+            val (x, s') = (json_t {ToJson = fn _ => error <xml>Tried to ToJson in FromJson!</xml>,
+                                   FromJson = rFrom}).FromJson s
+        in
+            (Rec x, s')
+        end
+
+    val json_r = {ToJson = rTo, FromJson = rFrom}
+end
--- a/json.urs	Wed May 02 11:47:37 2012 -0400
+++ b/json.urs	Wed May 02 11:47:37 2012 -0400
@@ -4,6 +4,7 @@
 
 val toJson : a ::: Type -> json a -> a -> string
 val fromJson : a ::: Type -> json a -> string -> a
+val fromJson' : a ::: Type -> json a -> string -> a * string
 
 val mkJson : a ::: Type -> {ToJson : a -> string,
                             FromJson : string -> a * string} -> json a
@@ -19,3 +20,12 @@
 val json_variant : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json (variant ts)
 
 val json_unit : json unit
+
+functor Recursive (M : sig
+                       con t :: Type -> Type
+                       val json_t : a ::: Type -> json a -> json (t a)
+                   end) : sig
+    datatype r = Rec of M.t r
+
+    val json_r : json r
+end
--- a/tests/testJson.ur	Wed May 02 11:47:37 2012 -0400
+++ b/tests/testJson.ur	Wed May 02 11:47:37 2012 -0400
@@ -57,7 +57,7 @@
   <b>City:</b> {[p.Address.City]}<br/>
   <b>State:</b> {[p.Address.State]}<br/>
   <b>Postal code:</b> {[p.Address.PostalCode]}<br/>
-  <b>Phone numbers:</b> {List.mapX (fn pn => <xml>{[pn.Number]}; </xml>) p.PhoneNumber}<br/>
+  <!-- <b>Phone numbers:</b> {List.mapX (fn pn => <xml>{[pn.Number]}; </xml>) p.PhoneNumber}<br/> -->
 </xml>
 
 fun parse r = return <xml><body>
@@ -79,3 +79,44 @@
     <submit value="Parse" action={parse}/>
   </form>
 </body></xml>
+
+structure God = Json.Recursive(struct
+                                   con t a = variant [Fun = string * list a,
+                                                      Var = string]
+
+                                   fun json_t [a] (_ : json a) : json (t a) =
+                                       let
+                                           val json_fun : json (string * list a) = json_record ("1", "2")
+                                       in
+                                           json_variant {Fun = "Fun", Var = "Var"}
+                                       end
+                               end)
+
+fun renderGod (God.Rec g) =
+    match g
+          {Fun = fn (s, gs) => <xml>
+            <b>Main god:</b> {[s]}<br/>
+            <b>Subgods:</b> <ul>
+              {List.mapX (fn g' => <xml><li>{renderGod g'}</li></xml>) gs}
+            </ul>
+          </xml>,
+          Var = fn s => <xml>
+            <b>Var:</b> {[s]}
+          </xml>}
+
+fun parseGod r = return <xml><body>
+  <h2>Beautified</h2>
+  {renderGod (fromJson r.Text)}
+
+  <h2>Round-tripped</h2>
+  {[toJson (fromJson r.Text : God.r)]}
+</body></xml>
+
+fun godMain () = return <xml><body>
+  <h1>Parse ye gods</h1>
+
+  <form>
+    <textarea{#Text} rows={10} cols={80}/><br/>
+    <submit value="Parse" action={parseGod}/>
+  </form>
+</body></xml>
--- a/tests/testJson.urs	Wed May 02 11:47:37 2012 -0400
+++ b/tests/testJson.urs	Wed May 02 11:47:37 2012 -0400
@@ -1,1 +1,2 @@
 val main : {} -> transaction page
+val godMain : {} -> transaction page