--- pa_json_static.orig.ml	2007-03-05 01:34:08.000000000 +0100
+++ pa_json_static.ml	2007-03-25 21:00:21.000000000 +0200
@@ -30,7 +30,7 @@
 THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)
 
-
+open Camlp4.PreCast
 open Printf
 
 let check_unique f l =
@@ -39,7 +39,7 @@
     (fun x -> 
        let (_loc, id) = f x in
        if Hashtbl.mem tbl id then
-	 Stdpp.raise_with_loc _loc
+	 Loc.raise _loc
 	   (Failure "this tag or label is not unique")
        else Hashtbl.add tbl id ())
     l
@@ -59,17 +59,17 @@
 type field = { field_caml_name : string;
 	       field_json_name : string;
 	       field_type : t;
-	       field_caml_loc : Token.flocation;
-	       field_json_loc : Token.flocation;
+	       field_caml_loc : Loc.t;
+	       field_json_loc : Loc.t;
 	       optional : bool;
-	       default : MLast.expr option;
+	       default : Ast.expr option;
 	       is_mutable : bool }
 
 and constructor = { cons_caml_name : string;
 		    cons_json_name : string;
 		    cons_args : t list;
-		    cons_caml_loc : Token.flocation;
-		    cons_json_loc : Token.flocation }
+		    cons_caml_loc : Loc.t;
+		    cons_json_loc : Loc.t }
 
 and type_expr =
     List of t
@@ -91,7 +91,7 @@
   | Raw
   | Custom of string
 
-and t = Token.flocation * type_expr
+and t = Loc.t * type_expr
 
 and type_def = { def : t;
 		 is_predefined : bool;
@@ -106,43 +106,47 @@
       | Array x -> <:ctyp< array $convert x$ >>
       | Option x -> <:ctyp< option $convert x$ >>
       | Object l -> 
-	  let ml = List.map (fun x -> (x.field_caml_name,
-				       convert x.field_type)) l in
-	  <:ctyp< < $list:ml$ > >>
+	  let ml = List.fold_right (fun x acc ->
+            <:ctyp< $lid:x.field_caml_name$ : $convert x.field_type$ ; $acc$ >>)
+            l <:ctyp<>> in
+	  <:ctyp< < $ml$ > >>
       | Record r -> 
 	  let l = 
-	    List.map (fun x -> (x.field_caml_loc,
-				x.field_caml_name,
-				x.is_mutable,
-				convert x.field_type)) r in
-	  <:ctyp< { $list:l$ } >>
+	    List.fold_right begin fun x acc ->
+              let _loc = x.field_caml_loc in
+              let t = convert x.field_type in
+              let t = if x.is_mutable then <:ctyp< mutable $t$ >> else t in
+              <:ctyp< $lid:x.field_caml_name$ : $t$; $acc$ >>
+            end r <:ctyp<>> in
+	  <:ctyp< { $l$ } >>
       | Hashtbl x -> <:ctyp< Hashtbl.t string $convert x$ >>
       | Assoc x -> <:ctyp< list (string * $convert x$) >>
       | Tuple l -> 
 	  let tl = List.map convert l in
-	  <:ctyp< ( $list:tl$ ) >>
+	  <:ctyp< ( $tup:Ast.tySta_of_list tl$ ) >>
       | Poly l -> 
 	  let rfl = 
-	    List.map (fun c ->
+	    List.fold_right (fun c acc ->
 			let name = c.cons_caml_name in
 			match c.cons_args with
-			    [] -> MLast.RfTag (name, true, [])
-			  | [x] -> MLast.RfTag (name, false, [convert x])
+			    [] -> <:ctyp< `$name$ | $acc$ >>
+			  | [x] -> <:ctyp< `$name$ of $convert x$ | $acc$ >>
 			  | _ -> assert false)
-	      l in
-	  <:ctyp< [ = $list:rfl$ ] >>
+	      l <:ctyp<>> in
+	  <:ctyp< [ = $rfl$ ] >>
       | Variant v -> 
 	  let l = 
-	    List.map 
-	      (fun x ->
+	    List.fold_right
+	      (fun x acc ->
 		 let cal = List.map convert x.cons_args in
-		 (x.cons_caml_loc, x.cons_caml_name, cal))
-	      v in
-	  <:ctyp< [ $list:l$ ] >>
+                 let _loc = x.cons_caml_loc in
+		 <:ctyp< $uid:x.cons_caml_name$ of $list:cal$ | $acc$ >>)
+	      v <:ctyp<>> in
+	  <:ctyp< [ $l$ ] >>
       | Name x -> 
 	  if StringMap.mem x names then <:ctyp< $lid:x$ >>
 	  else
-	    Stdpp.raise_with_loc _loc 
+	    Loc.raise _loc 
 	      (Failure ("type name " ^ x ^ 
 			" is undefined or not defined in the same \
                          'type ... and ...' block"))
@@ -155,17 +159,13 @@
       | Custom s -> <:ctyp< $uid:s$ . t >> in
 
   let tdl = 
-    optmap 
-      (fun (name, x) ->
-	 if x.is_predefined then None
-	 else
-	   let ctyp = convert x.def in
-	   Some (name, [], ctyp, []))
-      l in
-  if tdl <> [] then
-    <:str_item< type $list:tdl$ >>
-  else
-    <:str_item< declare end >>
+    List.fold_right begin fun ((_loc, name), x) acc ->
+      if x.is_predefined then acc
+      else
+        let dcl = Ast.TyDcl (_loc, name, [], convert x.def, []) in
+        <:ctyp< $dcl$ and $acc$ >>
+    end l <:ctyp<>> in
+  <:str_item< type $tdl$ >>
 
 let numbered_list l =
   Array.to_list
@@ -174,8 +174,8 @@
        (Array.of_list l))
 
 let eta_expand = function
-    (<:expr< fun [ $list:_$ ] >>) as f -> f
-  | e -> let _loc = MLast.loc_of_expr e in (<:expr< fun x -> $e$ x >>)
+    <:expr< fun [ $_$ ] >> as f -> f
+  | e -> let _loc = Ast.loc_of_expr e in <:expr< fun x -> $e$ x >>
 
 let make_ofjson _loc l =
   let browse _loc f = <:expr< Json_type.Browse.$lid:f$ >> in
@@ -209,10 +209,10 @@
 	      (fun ((_loc, _), name) tl -> <:patt< [ $lid:name$ :: $tl$ ] >>) 
 	      nl <:patt< [] >> in
 	  let el = 
-	    List.map (fun ((_loc, _) as x, name) ->
-			<:expr< $convert x$ $lid:name$ >>)
-	      nl in
-	  <:expr< fun [ Json_type.Array [ $list:pl$ ] -> ( $list:el$ )
+	    List.fold_right (fun ((_loc, _) as x, name) acc ->
+			<:expr< $convert x$ $lid:name$, $acc$ >>)
+	      nl <:expr<>> in
+	  <:expr< fun [ Json_type.Array $pl$ -> ( $tup:el$ )
 		      | Json_type.Array _ as x ->
 			  __json_static_error x
 			    "wrong number of elements in JSON array"
@@ -234,17 +234,13 @@
 
    and convert_object _loc l =
      let pel = convert_field_list _loc l in
-     let ml = 
-       List.map 
-	 (fun x -> 
+     let methods = 
+       List.fold_right
+	 (fun x acc ->
 	    let name = x.field_caml_name in
-	    <:class_str_item< method $name$ = $lid:name$ >>)
-	 l in
-     let obj = 
-       (* <:expr< object $list:ml$ end >> *)
-       MLast.ExObj (_loc, None, ml)
-     in
-     eval_with_tbl _loc <:expr< let $list:pel$ in $obj$ >>
+            <:class_str_item< method $name$ = $lid:name$ ; $acc$ >>)
+	 l <:class_str_item<>> in
+     eval_with_tbl _loc <:expr< let $list:pel$ in object $methods$ end >>
 
   and convert_record _loc r =
      let pel = convert_field_list _loc r in
@@ -259,8 +255,7 @@
 	      default = default } ->
 	  let e1 = 
 	    let f = if optional then "fieldx" else "field" in
-	    <:expr< 
-	  (Json_type.Browse.$lid:f$ tbl $str:json_name$) >> in
+	    <:expr< Json_type.Browse.$lid:f$ tbl $str:json_name$ >> in
 	  let e2 =
 	    match default with
 		Some e -> 
@@ -269,30 +264,28 @@
 		       [ Json_type.Null -> $e$
 		       | x -> $convert x$ x ] >>)
 	      | None -> <:expr< $convert x$ $e1$ >> in
-	  
-	  (<:patt< $lid:name$ >>, e2))
+
+	  <:binding< $lid:name$ = $e2$ >>)
        l
 
   and convert_variants make_cons _loc l =
     let l0, l1 =
       List.partition (fun x -> x.cons_args = []) l in
     let pwel0 =
-      List.map
+      List.fold_right
 	(fun { cons_caml_name = name;
-	       cons_json_name = json_name } ->
-	   (<:patt< $str:json_name$ >>, 
-	    None,
-	    make_cons _loc name))
-	l0 in
+	       cons_json_name = json_name } acc ->
+	   <:match_case< $str:json_name$ -> $make_cons _loc name$ | $acc$ >>)
+	l0 <:match_case<>> in
     let pwel1 =
-      List.map
+      List.fold_right
 	(fun { cons_caml_name = name;
 	       cons_json_name = json_name;
-	       cons_args = args } ->
+	       cons_args = args } acc ->
 	   let argnames = numbered_list args in
 	   let list_patt =
 	     List.fold_right 
-	       (fun (arg, s) l -> 
+	       (fun (_, s) l -> 
 		  <:patt< [ $lid:s$ :: $l$ ] >>)
 	       argnames <:patt< [] >> in
 	   let e =
@@ -300,24 +293,21 @@
 	       (fun cons (arg, s) -> 
 		  <:expr< $cons$ ($convert arg$ $lid:s$) >>)
 	     (make_cons _loc name) argnames in
-	   (<:patt< ($str:json_name$, $list_patt$) >>, 
-	    None, 
-	    e))
-	l1 in
-    let full_pwel pwel =
-      pwel @ [ <:patt< _ >>, None, 
-	       <:expr< __json_static_error x
-                 "invalid variant name or \
-                  wrong number of arguments" >> ]
+	   <:match_case< ($str:json_name$, $list_patt$) -> $e$ | $acc$ >>)
+	l1 <:match_case<>> in
+    let default_case =
+      <:match_case< _ -> __json_static_error x
+                           "invalid variant name or \
+                            wrong number of arguments" >>
     in
     
     (<:expr< 
      fun
 	 [ Json_type.String s as x -> 
-	     match s with [ $list:full_pwel pwel0$ ]
+	     match s with [ $pwel0$ | $default_case$ ]
 	       | Json_type.Array 
 		   [ Json_type.String s :: ([ _ :: _ ] as args) ] as x -> 
-		   match (s, args) with [ $list:full_pwel pwel1$ ]
+		   match (s, args) with [ $pwel1$ | $default_case$ ]
 	       | x -> __json_static_error x
 		   "not able to read this as \
                     a variant" ]
@@ -343,18 +333,16 @@
       Json_type.json_error (msg ^ ":\n" ^ obj_string) >> in
 
   let defs = 
-    optmap
-      (fun ((_loc, name), x) -> 
-	 (*if x.is_private then None
+    List.fold_right
+      (fun ((_loc, name), x) acc -> 
+	 (*if x.is_private then acc
 	 else*)
 	   let fname = name ^ "_of_json" in
-	   Some (<:patt< ( $lid:fname$ : Json_type.t -> $lid:name$ ) >>, 
-		 eta_expand (convert x.def))) l in
-  if defs = [] then 
-    <:str_item< declare end >>
-  else
-   <:str_item< declare $error$; value rec $list:defs$; end >>
-
+           <:binding< ( $lid:fname$ : Json_type.t -> $lid:name$ ) = 
+                      $eta_expand (convert x.def)$ and $acc$ >>)
+      l <:binding<>>
+  in
+    <:str_item< $error$; value rec $defs$ >>
 
 let make_tojson _loc l =
   let build _loc s = <:expr< Json_type.Build. $lid:s$ >> in
@@ -385,44 +373,40 @@
 	        ((List.map (fun (key, data) -> (key, $convert x$ data))) x) >>
       | Tuple l ->
 	  let nl = numbered_list l in
-	  let pl = List.map (fun (_, name) -> <:patt< $lid:name$ >>) nl in
+	  let pl = List.fold_right 
+                    (fun (_, name) acc -> <:patt< $lid:name$, $acc$ >>)
+                    nl <:patt<>> in
 	  let a = List.fold_right 
 		    (fun (x, name) tl -> 
 		       <:expr< [ $convert x$ $lid:name$ :: $tl$ ] >>)
 		    nl <:expr< [] >> in
-	  <:expr< fun [ ( $list:pl$ ) -> Json_type.Array $a$ ] >>
+	  <:expr< fun [ ( $tup:pl$ ) -> Json_type.Array $a$ ] >>
       | Poly l -> 
-	  let pwel =
+	  let match_cases =
 	    List.map
 	      (fun { cons_caml_name = name;
 		     cons_json_name = json_name;
 		     cons_args = args } ->
 		 match args with
 		     [] -> 
-		       (<:patt< ` $name$ >>, 
-			None,
-			<:expr< Json_type.String $str:json_name$ >>)
+		       <:match_case< `$name$ -> Json_type.String $str:json_name$ >>
 		   | [x] ->
-		       (<:patt< ` $name$ arg >>, 
-			None, 
-			<:expr<
+		       <:match_case< `$name$ arg ->
 			Json_type.Array 
 			  [ Json_type.String $str:json_name$;
-			    $convert x$ arg ] >>)
+			    $convert x$ arg ] >>
 		   | _ -> assert false)
 	      l in
-	  <:expr< fun [ $list:pwel$ ] >>
+	  <:expr< fun [ $list:match_cases$ ] >>
       | Variant v -> 
-	  let pwel =
+	  let match_cases =
 	    List.map
 	      (fun { cons_caml_name = name;
 		     cons_json_name = json_name;
 		     cons_args = args } ->
 		 match args with
 		     [] -> 
-		       (<:patt< $uid:name$ >>, 
-			None,
-			<:expr< Json_type.String $str:json_name$ >>)
+		       <:match_case< $uid:name$ -> Json_type.String $str:json_name$ >>
 		   | l ->
 		       let args = numbered_list l in
 		       let p =
@@ -434,13 +418,11 @@
 			   (fun (x, s) l -> 
 			      <:expr< [ $convert x$ $lid:s$ :: $l$ ] >>)
 			   args <:expr< [] >> in
-		       (p, 
-			None, 
-			<:expr<
+		       <:match_case< $p$ ->
 			Json_type.Array 
-			  [ Json_type.String $str:json_name$ :: $e$ ] >>))
+			  [ Json_type.String $str:json_name$ :: $e$ ] >>)
 	      v in
-	  <:expr< fun [ $list:pwel$ ] >>
+	  <:expr< fun [ $list:match_cases$ ] >>
       | Name x -> <:expr< $lid: "json_of_" ^ x$ >>
       | String -> build _loc "string"
       | Bool -> build _loc "bool"
@@ -463,25 +445,25 @@
   in
 
   let defs = 
-    List.map
-      (fun ((_loc, name), x) -> 
+    List.fold_right
+      (fun ((_loc, name), x) acc -> 
 	 let fname = "json_of_" ^ name in
-	 (<:patt< ( $lid:fname$ : $lid:name$ -> Json_type.t ) >>, 
-	  eta_expand (convert x.def)))
-      l in
-  <:str_item< value rec $list:defs$ >>
+	 <:binding< ( $lid:fname$ : $lid:name$ -> Json_type.t ) =
+	            $eta_expand (convert x.def)$ and $acc$ >>)
+      l <:binding<>> in
+  <:str_item< value rec $defs$ >>
 
 
 let expand_typedefs _loc l =
-  check_unique (fun (name, x) -> name) l;
+  check_unique (fun (name, _) -> name) l;
   let names = 
     List.fold_left 
-      (fun m (((_loc, name), x) as data) -> StringMap.add name data m)
+      (fun m (((_loc, name), _) as data) -> StringMap.add name data m)
       StringMap.empty l in
   let typedef = make_typedef _loc names l in
   let ofjson = make_ofjson _loc l in
   let tojson = make_tojson _loc l in
-  <:str_item< declare $typedef$; $ofjson$; $tojson$; end >>
+  <:str_item< $typedef$; $ofjson$; $tojson$ >>
 
 let o2b = function None -> false | _ -> true
 
@@ -493,24 +475,25 @@
   List.iter (fun s -> Hashtbl.add tbl s ()) l;
   Hashtbl.mem tbl
 
-open Pcaml
-
 let list_of_opt = function None -> [] | Some x -> [x]
 let list_of_optlist = function None -> [] | Some x -> x
 
 let check_methods l =
   List.iter (fun x ->
 	       if x.is_mutable then
-		 Stdpp.raise_with_loc x.field_caml_loc 
+		 Loc.raise x.field_caml_loc 
 		   (Failure "object fields cannot be made mutable")) l
 
 let string_assoc _loc = function
     (_loc, Tuple [ (_, String); (_, x) ]) -> (_loc, x)
   | (_, _) -> 
-      Stdpp.raise_with_loc _loc
+      Loc.raise _loc
 	(Failure "must be of the form (string * ...) assoc")
 
-EXTEND
+open Syntax
+let eval_string s = Camlp4.Struct.Token.Eval.string ~strict:() s
+
+EXTEND Gram
   GLOBAL: str_item;
   str_item: LEVEL "top" [
     [ "type"; LIDENT "json"; 
@@ -520,7 +503,7 @@
   type_binding: [
     [ name = [ s = LIDENT -> 
 		 if is_reserved s then
-		   Stdpp.raise_with_loc _loc 
+		   Loc.raise _loc 
 		     (Failure ("you can't use '" ^ s ^ "' as a type name"))
 		 else (_loc, s) ]; 
       "=";
@@ -549,7 +532,7 @@
     [ l = 
 	LIST1 [ id = [ id = UIDENT -> (_loc, id) ]; 
 		label = OPT [ s = STRING -> 
-				(_loc, Token.eval_string _loc s) ];
+				(_loc, eval_string s) ];
 		typ = OPT [ "of";
 			    x = LIST1 type_expr LEVEL "simple" 
 				SEP "*" -> x ] -> 
@@ -582,7 +565,6 @@
     | "("; LIDENT "string"; ","; x = type_expr; ")"; 
       UIDENT "Hashtbl"; "."; LIDENT "t" -> 
 	(_loc, Hashtbl x)
-    | name = LIDENT -> (_loc, Name name)
     | LIDENT "string" -> (_loc, String)
     | LIDENT "bool" -> (_loc, Bool)
     | LIDENT "int" -> (_loc, Int)
@@ -590,6 +572,7 @@
     | LIDENT "number" -> (_loc, Number)
     | [ UIDENT "Json_type"; "."; LIDENT "json_type"
       | LIDENT "json_type" ] -> (_loc, Raw)
+    | name = LIDENT -> (_loc, Name name)
     | module_name = UIDENT; "."; LIDENT "t" -> 
 	if module_name = "Json_type" then (_loc, Raw)
 	else (_loc, Custom module_name) ]
@@ -597,9 +580,9 @@
 
   polymorphic_variants: [
     [ l = 
-	LIST1 [ "`"; id = [ id = [ LIDENT | UIDENT ] -> (_loc, id) ]; 
+        LIST1 [ "`"; id = [ `(LIDENT id | UIDENT id) -> (_loc, id) ]; 
 		label = OPT [ s = STRING -> 
-				(_loc, Token.eval_string _loc s) ];
+				(_loc, eval_string s) ];
 		typ = OPT [ "of"; x = type_expr -> x ] -> 
 		  let id' = unopt id label in
 		  { cons_caml_loc = fst id;
@@ -636,9 +619,9 @@
 
   method_label: [
     [ id_opt = [ id = LIDENT -> ((_loc, id), false)
-	       | id = QUESTIONIDENT -> ((_loc, id), true) ]; 
+               | "?"; id = LIDENT -> ((_loc, id), true) ]; 
       label = OPT [ s = STRING -> 
-		      (_loc, Token.eval_string _loc s) ];
+		      (_loc, eval_string s) ];
       ":" -> (id_opt, label)
     | id = OPTLABEL -> (((_loc, id), true), None) ]
   ];
