Mercurial > meta
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>