--- a/json.ur	Thu Jan 05 18:04:04 2012 -0500
+++ b/json.ur	Wed May 02 11:47:37 2012 -0400
@@ -222,7 +222,7 @@
                                    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>
+                                                error <xml>No colon after JSON object field name</xml>
                                             else
                                                 skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
 
@@ -265,3 +265,52 @@
                                                                               | Some v => v) fl r names, s')
                            end
                    end}
+
+fun json_variant [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json (variant ts) =
+    {ToJson = fn r => let val jnames = @map2 [json] [fn _ => string] [fn x => json x * string]
+                                     (fn [t] (j : json t) (name : string) => (j, name)) fl jss names
+                      in @Variant.destrR [ident] [fn x => json x * string]
+                          (fn [p ::_] (v : p) (j : json p, name : string) =>
+                            "{" ^ escape name ^ ":" ^ j.ToJson v ^ "}") fl r jnames
+                      end,
+     FromJson = fn s =>
+                   if String.length s = 0 || String.sub s 0 <> #"{" then
+                       error <xml>JSON variant doesn't begin with brace</xml>
+                   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 => ts' :: {Type} -> [ts ~ ts'] => variant (ts ++ ts') * string]
+                                            (fn [nm ::_] [t ::_] [rest ::_] [[nm] ~ rest] (j : json t) name'
+                                             (acc : ts' :: {Type} -> [rest ~ ts'] => variant (rest ++ ts') * string) [fwd ::_] [[nm = t] ++ rest ~ fwd] =>
+                                                if name = name'
+                                                    then
+                                                        let val (v, s') = j.FromJson s'
+                                                        in (make [nm] v, s')
+                                                        end
+                                                    else acc [fwd ++ [nm = t]]
+                                            )
+                                            (fn [fwd ::_] [[] ~ fwd] => error <xml>Unknown JSON object variant name {[name]}</xml>)
+                                            fl jss names) [[]] !
+
+                           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
+                           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 error <xml>Junk after JSON value in object</xml>
+                       end
+                   }
+
+val json_unit : json unit = json_record {} {}