From c3f8afb09389c4613a3af0f7ddcece09ecc237c2 Mon Sep 17 00:00:00 2001
From: ygrek <ygrek@autistici.org>
Date: Sat, 26 Feb 2011 17:54:22 +0200
Subject: [PATCH] revised syntax in quotations - supports ocaml 3.12

---
 _tags                    |  4 +++-
 myocamlbuild.ml          |  1 +
 syntax/base.ml           | 22 +++++++++---------
 syntax/bounded_class.ml  | 20 ++++++++---------
 syntax/dump_class.ml     | 30 ++++++++++++-------------
 syntax/enum_class.ml     | 10 ++++-----
 syntax/eq_class.ml       | 46 +++++++++++++++++++-------------------
 syntax/extend.ml         | 23 ++++++++++++++-----
 syntax/functor_class.ml  | 16 ++++++-------
 syntax/pickle_class.ml   | 58 ++++++++++++++++++++++++------------------------
 syntax/show_class.ml     | 36 +++++++++++++++---------------
 syntax/type.ml           | 10 ++++-----
 syntax/typeable_class.ml | 22 +++++++++---------
 syntax/utils.ml          |  1 +
 14 files changed, 157 insertions(+), 142 deletions(-)

diff --git a/_tags b/_tags
index c0fe30e..158b68d 100644
--- a/_tags
+++ b/_tags
@@ -1,5 +1,7 @@
+true: annot
+
 <syntax>: include
-<syntax/*.ml> : camlp4of, use_camlp4
+<syntax/*.ml>: camlp4orf, use_camlp4
 
 <lib>: include
 <lib/*.ml>: camlp4of, pa_deriving
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index 96ee375..6938493 100644
--- a/myocamlbuild.ml
+++ b/myocamlbuild.ml
@@ -27,6 +27,7 @@ let mkcamlp4 prod deps =
 let _ =  dispatch begin function
   | After_rules ->
       flag ["pp"; "camlp4of"] & S[A"-loc"; A"loc"];
+      flag ["pp"; "camlp4orf"] & S[A"-loc"; A"loc"];
       flag ["ocaml";"pp";"pa_deriving"] (P"pa_deriving.cma");
       dep ["pa_deriving"] ["pa_deriving.cma"];
 
diff --git a/syntax/base.ml b/syntax/base.ml
index 79fe4fe..2a18430 100644
--- a/syntax/base.ml
+++ b/syntax/base.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -77,17 +77,17 @@ struct
        <:expr<
          let module M = 
              struct
-               type t = $t$
-               let test = function #t -> true | _ -> false
+               type t = $t$;
+               value test = fun [ #t -> True | _ -> False ];
              end in M.test $lid:param$ >>,
        <:expr<
          (let module M = 
               struct
-                type t = $t$
-                let cast = function #t as t -> t | _ -> assert false
+                type t = $t$;
+                value cast = fun [ #t as t -> t | _ -> assert False ];
               end in M.cast $lid:param$ )>>)
 
-  let seq l r = <:expr< $l$ ; $r$ >>
+  let seq l r = <:expr< do { $l$ ; $r$ } >>
 
   let record_pattern ?(prefix="") (fields : Type.field list) : Ast.patt = 
     <:patt<{$list:
@@ -119,14 +119,14 @@ struct
   let expr_list : Ast.expr list -> Ast.expr = 
       (fun exprs ->
          List.fold_right 
-           (fun car cdr -> <:expr< $car$ :: $cdr$ >>)
+           (fun car cdr -> <:expr< [ $car$ :: $cdr$] >>)
            exprs
          <:expr< [] >>)
 
   let patt_list : Ast.patt list -> Ast.patt = 
       (fun patts ->
          List.fold_right 
-           (fun car cdr -> <:patt< $car$ :: $cdr$ >>)
+           (fun car cdr -> <:patt< [ $car$ :: $cdr$] >>)
            patts
          <:patt< [] >>)
 
@@ -289,7 +289,7 @@ struct
         decls in
     let sorted_mbinds = make_safe mbinds in
     let mrec =
-      <:str_item< open $uid:modulename$ module rec $list:sorted_mbinds$ >> in
+      <:str_item< open $uid:modulename$; module rec $list:sorted_mbinds$ >> in
       match context.params with
         | [] -> mrec
         | _ ->
@@ -300,11 +300,11 @@ struct
            let projected =
              List.map (fun (name,params,rhs,_,_) -> 
                          let modname = classname ^ "_"^ name in
-                         let rhs = <:module_expr< struct module P = $applied$ include P.$uid:modname$ end >> in
+                         let rhs = <:module_expr< struct module P = $applied$; include P.$uid:modname$; end >> in
                            <:str_item< module $uid:modname$ = $make_functor rhs$>>)
                decls in
            let m = <:str_item< module $uid:wrapper_name$ = $fixed$ >> in
-             <:str_item< $m$ $list:projected$ >>
+             <:str_item< $m$; $list:projected$ >>
        
     let gen_sig ~classname ~context (tname,params,_,_,generated as decl) = 
       (* FIXME implicit requirement of classname being equal to module name, hence this hack for Enum *)
diff --git a/syntax/bounded_class.ml b/syntax/bounded_class.ml
index dbccfb0..32c30a0 100644
--- a/syntax/bounded_class.ml
+++ b/syntax/bounded_class.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -24,9 +24,9 @@ struct
                     (fun t -> let e = self#expr ctxt t in 
                        <:expr< let module M = $e$ in M.min_bound >>,
                        <:expr< let module M = $e$ in M.max_bound >>) ts) in
-    <:module_expr< struct type a = $atype_expr ctxt (`Tuple ts)$
-                          let min_bound = $tuple_expr minBounds$ 
-                          let max_bound = $tuple_expr maxBounds$ end >>
+    <:module_expr< struct type a = $atype_expr ctxt (`Tuple ts)$;
+                   value min_bound = $tuple_expr minBounds$; 
+                   value max_bound = $tuple_expr maxBounds$; end >>
 
     method sum ?eq ctxt ((tname,_,_,_,_) as decl) summands = 
     let names = ListLabels.map summands
@@ -35,9 +35,9 @@ struct
               | (name,_) -> raise (Underivable ("Bounded cannot be derived for the type "^
                                                   tname ^" because the constructor "^
                                                   name^" is not nullary"))) in
-        <:module_expr< struct type a = $atype ctxt decl$
-                       let min_bound = $uid:List.hd names$ 
-                       and max_bound = $uid:List.last names$ end >>
+        <:module_expr< struct type a = $atype ctxt decl$;
+                       value min_bound = $uid:List.hd names$ 
+                       and max_bound = $uid:List.last names$; end >>
 
     method variant ctxt decl (_, tags) = 
     let names = ListLabels.map tags
@@ -47,9 +47,9 @@ struct
                                                       name^" is not nullary"))
              | _ -> raise (Underivable ("Bounded cannot be derived for this "
                                         ^"polymorphic variant type"))) in
-      <:module_expr< struct type a = $atype ctxt decl$
-                     let min_bound = `$List.hd names$ 
-                     and max_bound = `$List.last names$ end >>
+      <:module_expr< struct type a = $atype ctxt decl$;
+                     value min_bound = `$List.hd names$ 
+                     and max_bound = `$List.last names$; end >>
 
   (* should perhaps implement this one *)
   method record ?eq _ (tname,_,_,_,_) = raise (Underivable ("Bounded cannot be derived for record types (i.e. "^
diff --git a/syntax/dump_class.ml b/syntax/dump_class.ml
index 798875a..5f6f45c 100644
--- a/syntax/dump_class.ml
+++ b/syntax/dump_class.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -16,9 +16,9 @@ struct
   let classname = "Dump"
 
   let wrap ~atype ~dumpers ~undump =
-    <:module_expr< struct type a = $atype$
-                          let to_buffer buffer = function $list:dumpers$
-                          let from_stream stream = $undump$ end >>
+    <:module_expr< struct type a = $atype$;
+                          value to_buffer buffer = fun [ $list:dumpers$ ];
+                          value from_stream stream = $undump$; end >>
 
   let instance = object (self)
     inherit make_module_expr ~classname ~allow_private:false
@@ -26,7 +26,7 @@ struct
     method nargs ctxt (exprs : (name * Type.expr) list) : Ast.expr * Ast.expr =
       List.fold_right
         (fun (id,t) (p,u) -> 
-           <:expr< $mproject (self#expr ctxt t) "to_buffer"$ buffer $lid:id$; $p$ >>,
+           <:expr< do { $mproject (self#expr ctxt t) "to_buffer"$ buffer $lid:id$; $p$ } >>,
            <:expr< let $lid:id$ = $mproject (self#expr ctxt t) "from_stream"$ stream in $u$ >>)
         exprs (<:expr<>>, <:expr< $tuple_expr (List.map (fun (id,_) -> <:expr< $lid:id$ >>) exprs)$>>)
 
@@ -45,14 +45,14 @@ struct
           | Tag (name, args) -> (match args with 
               | None   -> <:match_case< `$name$ -> $dumpn$ >>,
                           <:match_case< $`int:n$ -> `$name$ >>
-              | Some e -> <:match_case< `$name$ x -> $dumpn$;
-                                         $mproject (self#expr ctxt e) "to_buffer"$ buffer x >>,
+              | Some e -> <:match_case< `$name$ x -> do { $dumpn$; 
+                                         $mproject (self#expr ctxt e) "to_buffer"$ buffer x } >>,
                           <:match_case< $`int:n$ -> 
                                         `$name$ ($mproject (self#expr ctxt e) "from_stream"$ stream) >>)
           | Extends t -> 
               let patt, guard, cast = cast_pattern ctxt t in
                 <:match_case< $patt$ when $guard$ -> 
-                               $dumpn$; $mproject (self#expr ctxt t) "to_buffer"$ buffer $cast$ >>,
+                               do { $dumpn$; $mproject (self#expr ctxt t) "to_buffer"$ buffer $cast$ } >>,
                 <:match_case< $`int:n$ -> ($mproject (self#expr ctxt t) "from_stream"$ stream :> a) >>
 
     method case ctxt (ctor,args) n =
@@ -64,8 +64,8 @@ struct
         let patt, exp = tuple nargs in
         let dump, undump = self#nargs ctxt (List.mapn (fun t n -> (Printf.sprintf "v%d" n, t)) args) in
         <:match_case< $uid:ctor$ $patt$ -> 
-                      Dump_int.to_buffer buffer $`int:n$;
-                      $dump$ >>,
+                      do { Dump_int.to_buffer buffer $`int:n$;
+                      $dump$ } >>,
         <:match_case< $`int:n$ -> let $patt$ = $undump$ in $uid:ctor$ $exp$  >>
     
     method field ctxt : Type.field -> Ast.expr * Ast.expr = function
@@ -81,10 +81,10 @@ struct
       let dumpers, undumpers = 
         List.split (List.mapn (self#case ctxt) summands) in
         wrap ~atype:(atype ctxt decl) ~dumpers
-          ~undump:<:expr< match Dump_int.from_stream stream with $list:undumpers$ 
+          ~undump:<:expr< match Dump_int.from_stream stream with [ $list:undumpers$ 
                                 | n -> raise (Dump_error
                                                 (Printf.sprintf $str:msg$ n
-                                                   (Stream.count stream))) >>
+                                                   (Stream.count stream))) ] >>
 
     method record ?eq ctxt decl fields = 
        let dumpers, undumpers = 
@@ -103,11 +103,11 @@ struct
       let msg = "Dump: unexpected tag %d at character %d when deserialising polymorphic variant" in
       let dumpers, undumpers = 
         List.split (List.mapn (self#polycase ctxt) tags) in
-        wrap ~atype:(atype ctxt decl) ~dumpers:(dumpers @ [ <:match_case< _ -> assert false >>])
-          ~undump:<:expr< match Dump_int.from_stream stream with $list:undumpers$ 
+        wrap ~atype:(atype ctxt decl) ~dumpers:(dumpers @ [ <:match_case< _ -> assert False >>])
+          ~undump:<:expr< match Dump_int.from_stream stream with [ $list:undumpers$ 
                                 | n -> raise (Dump_error
                                                 (Printf.sprintf $str:msg$ n
-                                                   (Stream.count stream))) >>
+                                                   (Stream.count stream))) ] >>
   end
 end
 
diff --git a/syntax/enum_class.ml b/syntax/enum_class.ml
index c332f21..389cb86 100644
--- a/syntax/enum_class.ml
+++ b/syntax/enum_class.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -23,21 +23,21 @@ struct
       List.fold_right2
         (fun n ctor rest -> 
            match ctor with
-             | (name, []) -> <:expr< ($uid:name$, $`int:n$) :: $rest$ >>
+             | (name, []) -> <:expr< [ ($uid:name$, $`int:n$) :: $rest$ ] >>
              | (name,_) -> raise (Underivable ("Enum cannot be derived for the type "^
                                   tname ^" because the constructor "^
                                   name^" is not nullary")))
         (List.range 0 (List.length summands))
         summands
         <:expr< [] >> in
-      <:module_expr< Deriving_Enum.Defaults(struct type a = $atype ctxt decl$ let numbering = $numbering$ end) >>
+      <:module_expr< Deriving_Enum.Defaults(struct type a = $atype ctxt decl$; value numbering = $numbering$; end) >>
 
     method variant ctxt decl (_, tags) = 
     let numbering = 
       List.fold_right2
         (fun n tagspec rest -> 
            match tagspec with
-             | Tag (name, None) -> <:expr< (`$name$, $`int:n$) :: $rest$ >>
+             | Tag (name, None) -> <:expr< [ (`$name$, $`int:n$) :: $rest$ ] >>
              | Tag (name, _) -> raise (Underivable ("Enum cannot be derived because the tag "^
                                                       name^" is not nullary"))
              | _ -> raise (Underivable ("Enum cannot be derived for this "
@@ -45,7 +45,7 @@ struct
         (List.range 0 (List.length tags))
         tags
         <:expr< [] >> in
-      <:module_expr< Deriving_Enum.Defaults(struct type a = $atype ctxt decl$ let numbering = $numbering$ end) >>
+      <:module_expr< Deriving_Enum.Defaults(struct type a = $atype ctxt decl$; value numbering = $numbering$; end) >>
 
     method tuple context _ = raise (Underivable "Enum cannot be derived for tuple types")
     method record ?eq _ (tname,_,_,_,_) = raise (Underivable
diff --git a/syntax/eq_class.ml b/syntax/eq_class.ml
index 1d8de1b..8e71ad3 100644
--- a/syntax/eq_class.ml
+++ b/syntax/eq_class.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -17,14 +17,14 @@ struct
 
   let lprefix = "l" and rprefix = "r"
 
-  let wildcard_failure = <:match_case< _ -> false >>
+  let wildcard_failure = <:match_case< _ -> False >>
 
   let tup ctxt ts mexpr exp = 
       match ts with
         | [t] -> 
-            <:module_expr< struct type a = $atype_expr ctxt (`Tuple ts)$
-                                  let eq l r = let module M = $exp ctxt t$ 
-                                   in $mexpr$ l r end >>
+            <:module_expr< struct type a = $atype_expr ctxt (`Tuple ts)$;
+                                  value eq l r = let module M = $exp ctxt t$ 
+                                   in $mexpr$ l r; end >>
         | ts ->
             let _, (lpatt, rpatt), expr = 
               List.fold_right
@@ -36,10 +36,10 @@ struct
                       <:expr< let module M = $exp ctxt t$ 
                               in $mexpr$ $lid:lid$ $lid:rid$ && $expr$ >>))
                 ts
-                (0, (<:patt< >>, <:patt< >>), <:expr< true >>)
+                (0, (<:patt< >>, <:patt< >>), <:expr< True >>)
             in 
-              <:module_expr< struct type a = $atype_expr ctxt (`Tuple ts)$
-                                    let eq $Ast.PaTup (loc, lpatt)$ $Ast.PaTup (loc, rpatt)$ = $expr$ end >>
+              <:module_expr< struct type a = $atype_expr ctxt (`Tuple ts)$;
+                                    value eq $Ast.PaTup (loc, lpatt)$ $Ast.PaTup (loc, rpatt)$ = $expr$; end >>
 
 
   let instance = object (self)
@@ -48,9 +48,9 @@ struct
   method tuple ctxt ts = tup ctxt ts <:expr< M.eq >> (self#expr)
     
   method polycase ctxt : Type.tagspec -> Ast.match_case = function
-    | Tag (name, None) -> <:match_case< `$name$, `$name$ -> true >>
+    | Tag (name, None) -> <:match_case< (`$name$, `$name$) -> True >>
     | Tag (name, Some e) -> <:match_case< 
-        `$name$ l, `$name$ r -> 
+        (`$name$ l, `$name$ r) -> 
            $mproject (self#expr ctxt e) "eq"$ l r >>
     | Extends t -> 
         let lpatt, lguard, lcast = cast_pattern ctxt ~param:"l" t in
@@ -62,7 +62,7 @@ struct
   method case ctxt : Type.summand -> Ast.match_case = 
     fun (name,args) ->
       match args with 
-        | [] -> <:match_case< ($uid:name$, $uid:name$) -> true >>
+        | [] -> <:match_case< ($uid:name$, $uid:name$) -> True >>
         | _ -> 
             let nargs = List.length args in
             let lpatt, lexpr = tuple ~param:"l" nargs
@@ -78,16 +78,16 @@ struct
     | f -> raise (Underivable ("Eq cannot be derived for record types with polymorphic fields")) 
 
   method sum ?eq ctxt decl summands =
-    let wildcard = match summands with [_] -> [] | _ -> [ <:match_case< _ -> false >>] in
+    let wildcard = match summands with [_] -> [] | _ -> [ <:match_case< _ -> False >>] in
   <:module_expr< 
-      struct type a = $atype ctxt decl$
-             let eq l r = match l, r with 
-                          $list:List.map (self#case ctxt) summands @ wildcard$
+      struct type a = $atype ctxt decl$;
+             value eq l r = match (l, r) with 
+                          [ $list:List.map (self#case ctxt) summands @ wildcard$ ];
   end >>
 
   method record ?eq ctxt decl fields = 
     if List.exists (function (_,_,`Mutable) -> true | _ -> false) fields then
-       <:module_expr< struct type a = $atype ctxt decl$ let eq = (==) end >>
+       <:module_expr< struct type a = $atype ctxt decl$; value eq = (==); end >>
     else
     let lpatt = record_pattern ~prefix:"l" fields
     and rpatt = record_pattern ~prefix:"r" fields 
@@ -95,15 +95,15 @@ struct
       List.fold_right
         (fun f e -> <:expr< $self#field ctxt f$ && $e$ >>)
         fields
-        <:expr< true >>
-    in <:module_expr< struct type a = $atype ctxt decl$
-                             let eq $lpatt$ $rpatt$ = $expr$ end >>
+        <:expr< True >>
+    in <:module_expr< struct type a = $atype ctxt decl$;
+                             value eq $lpatt$ $rpatt$ = $expr$; end >>
 
   method variant ctxt decl (spec, tags) = 
-    <:module_expr< struct type a = $atype ctxt decl$
-                          let eq l r = match l, r with
-                                       $list:List.map (self#polycase ctxt) tags$
-                                       | _ -> false end >>
+    <:module_expr< struct type a = $atype ctxt decl$;
+                          value eq l r = match (l, r) with
+                                       [ $list:List.map (self#polycase ctxt) tags$
+                                       | _ -> False ]; end >>
   end
 end
 
diff --git a/syntax/extend.ml b/syntax/extend.ml
index 77b4bb0..05ee55c 100644
--- a/syntax/extend.ml
+++ b/syntax/extend.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -51,7 +51,7 @@ struct
         let decls = display_errors loc Type.Translate.decls types in 
         let module U = Type.Untranslate(struct let loc = loc end) in
         let tdecls = List.map U.decl decls in
-          <:str_item< type $list:tdecls$ $list:List.map (derive_str loc decls) cl$ >>
+          <:str_item< type $list:tdecls$; $list:List.map (derive_str loc decls) cl$ >>
    ]]
   ;
   sig_item:
@@ -61,7 +61,7 @@ struct
        let module U = Type.Untranslate(struct let loc = loc end) in
        let tdecls = List.concat_map U.sigdecl decls in
        let ms = List.map (derive_sig loc decls) cl in
-         <:sig_item< type $list:tdecls$ $list:ms$ >> ]]
+         <:sig_item< type $list:tdecls$; $list:ms$ >> ]]
   ;
   END
 
@@ -72,6 +72,14 @@ struct
   let mk_anti ?(c = "") n s = "\\$"^n^c^":"^s
 
   let derive_ast loc classname methodname t =
+(*
+  EXTEND Gram
+  expr: LEVEL "simple"
+  [
+  [e1 = TRY val_longident ; "<" ; t = ctyp; ">" ->
+     match e1 with
+       | <:ident< $uid:classname$ . $lid:methodname$ >> ->
+*)
          if not (Base.is_registered classname) then
            fatal_error loc ("deriving: "^ classname ^" is not a known `class'")
          else
@@ -85,13 +93,16 @@ struct
                let m = derive_str loc decls classname in
                  <:expr< let module $uid:classname$ = 
                              struct
-                               type $list:tdecls$
-                               $m$ 
-                               include $uid:classname ^ "_inline"$
+                               type $list:tdecls$;
+                               $m$;
+                               include $uid:classname ^ "_inline"$;
                              end
                           in $uid:classname$.$lid:methodname$ >>
 
+  try
   DELETE_RULE Gram expr: val_longident END;
+  with Not_found -> () (* ocaml >= 3.12.0 *)
+;; 
 
   EXTEND Gram
   GLOBAL: expr;
diff --git a/syntax/functor_class.ml b/syntax/functor_class.ml
index d5c7758..56fe8de 100644
--- a/syntax/functor_class.ml
+++ b/syntax/functor_class.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -39,9 +39,9 @@ struct
     let rhs = 
       List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) patts expr in
       <:module_expr< struct
-        open Functor
-        type $tdec name$ 
-        let map = $rhs$
+        open Functor;
+        type $tdec name$;
+        value map = $rhs$;
       end >>
 (*
    prototype: [[t]] : t -> t[b_i/a_i]
@@ -113,13 +113,13 @@ struct
   let rhs = function
     |`Fresh (_, _, `Private) -> raise (Underivable "Functor cannot be derived for private types")
     |`Fresh (_, Sum summands, _)  -> 
-       <:expr<  function $list:List.map case summands$ >>
+       <:expr<  fun [ $list:List.map case summands$ ] >>
     |`Fresh (_, Record fields, _) -> 
        <:expr< fun $record_pattern fields$ -> 
                    $record_expr (List.map (fun ((l,_,_) as f) -> (l,field f)) fields)$ >>
     |`Expr e                  -> expr e
     |`Variant (_, tags) -> 
-       <:expr< function $list:List.map polycase tags$ | _ -> assert false >>
+       <:expr< fun [ $list:List.map polycase tags$ | _ -> assert False ] >>
     | `Nothing -> raise (Underivable "Cannot generate functor instance for the empty type")
 
 
@@ -134,7 +134,7 @@ struct
 
    let signature name : Ast.sig_item list =  
      [ <:sig_item< type $list:sigdec name$ >>; 
-       <:sig_item< val map : $maptype name$ >> ] 
+       <:sig_item< value map : $maptype name$ >> ] 
 
   let decl (name, _, r, _, _) : Camlp4.PreCast.Ast.module_binding =
     if name = "f" then
@@ -155,7 +155,7 @@ struct
         <:sig_item< >>
       else
         <:sig_item< module $uid:classname ^ "_" ^ tname$ :
-                    sig type $tdec tname$ val map : $maptype tname$ end >>
+                    sig type $tdec tname$; value map : $maptype tname$; end >>
 
 end
 
diff --git a/syntax/pickle_class.ml b/syntax/pickle_class.ml
index ca62c70..c1eec54 100644
--- a/syntax/pickle_class.ml
+++ b/syntax/pickle_class.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -28,7 +28,7 @@ struct
       let module Mutable = struct
         type t = $UT.repr 
             (instantiate_modargs_repr ctxt 
-               (Record (List.map (fun (n,p,_) -> (n,p,`Mutable)) fields)))$
+               (Record (List.map (fun (n,p,_) -> (n,p,`Mutable)) fields)))$;
       end in $e$ >>
 
   let unpickle_record ctxt (tname,_,_,_,_ as decl) fields expr = 
@@ -36,7 +36,7 @@ struct
     let assignments = 
       List.fold_right
         (fun (id,_,_) exp ->
-           <:expr< this.Mutable.$lid:id$ <- $lid:id$; $exp$ >>)
+           <:expr< do { this.Mutable.$lid:id$ := $lid:id$; $exp$ } >>)
         fields
       <:expr< return self >> in
     let inner = 
@@ -49,9 +49,9 @@ struct
     let idpat = patt_list (List.map (fun (id,_,_) -> <:patt< $lid:id$ >>) fields) in
       unpickle_record_bindings ctxt decl fields
         (<:expr< W.record
-           (fun self -> function
-                  | $idpat$ -> let this = (Obj.magic self : Mutable.t) in $inner$
-                  | _ -> raise (UnpicklingError $str:msg$)) $`int:List.length fields$ >>)
+           (fun self -> fun
+                  [ $idpat$ -> let this = (Obj.magic self : Mutable.t) in $inner$
+                  | _ -> raise (UnpicklingError $str:msg$)]) $`int:List.length fields$ >>)
 
   let pickle_record ctxt decl fields expr =
     let inner =
@@ -81,19 +81,19 @@ struct
 
   let rebind_params ctxt name : Ast.str_item = 
     NameMap.fold
-      (fun _ param s -> <:str_item< $s$ module $uid:param$ = $uid:param$.$uid:name$ >>)
+      (fun _ param s -> <:str_item< $s$; module $uid:param$ = $uid:param$.$uid:name$ >>)
       ctxt.argmap
       <:str_item< >>
 
   let wrap ~ctxt ~atype ~tymod ~eqmod ~picklers ~unpickler =
-    <:module_expr< struct open Eq open Typeable
-                          module T = $tymod$
-                          module E = $eqmod$
-                          type a = $atype$
-                          open Write
-                          let pickle = let module W = Utils(T)(E) in function $list:picklers$
-                          open Read
-                          let unpickle = let module W = Utils(T) in $unpickler$
+    <:module_expr< struct open Eq; open Typeable;
+                          module T = $tymod$;
+                          module E = $eqmod$;
+                          type a = $atype$;
+                          open Write;
+                          value pickle = let module W = Utils(T)(E) in fun [ $list:picklers$ ];
+                          open Read;
+                          value unpickle = let module W = Utils(T) in $unpickler$;
     end >>
 
     let instance = object (self)
@@ -127,9 +127,9 @@ struct
             ids
             <:expr< return $texpr$ >> in
           <:expr< W.tuple
-            (function
-               | $pidlist$ -> $inner$
-               | _ -> raise (UnpicklingError $str:msg$)) >>
+            (fun
+               [ $pidlist$ -> $inner$
+               | _ -> raise (UnpicklingError $str:msg$)]) >>
       and atype = atype_expr ctxt (`Tuple ts) in
         <:module_expr< Pickle.Defaults($wrap ~ctxt ~atype ~tymod ~eqmod ~picklers ~unpickler$) >>
 
@@ -154,8 +154,8 @@ struct
             ($mproject (self#expr ctxt t) "pickle"$ $cast$) >>
 
     method polycase_un ctxt tagspec : Ast.match_case = match tagspec with
-    | (name, None)   -> <:match_case< $`int:(tag_hash name)$, [] -> return `$name$ >>
-    | (name, Some t) -> <:match_case< $`int:(tag_hash name)$, [x] -> 
+    | (name, None)   -> <:match_case< ($`int:(tag_hash name)$, []) -> return `$name$ >>
+    | (name, Some t) -> <:match_case< ($`int:(tag_hash name)$, [x]) -> 
       $bind$ ($mproject (self#expr ctxt t) "unpickle"$ x) (fun o -> return (`$name$ o)) >>
 
     method extension ctxt tname ts : Ast.match_case =
@@ -172,11 +172,11 @@ struct
         (fun t exp -> <:expr<
            let module M = $(self#expr ctxt t)$ in
              try $exp$
-             with UnknownTag (n,_) -> (M.unpickle id :> a Read.m) >>)
+             with [ UnknownTag (n,_) -> (M.unpickle id :> Read.m a) ] >>)
         ts
         <:expr< raise (UnknownTag (n, ($str:"Unexpected tag encountered during unpickling of "
                                        ^tname$))) >>
-    in <:match_case< n,_ -> $inner$ >>
+    in <:match_case< (n,_) -> $inner$ >>
 
     method variant ctxt (tname,_,_,_,_ as decl) (_, tags) = 
       let unpickler = 
@@ -184,7 +184,7 @@ struct
           (function Tag (name,t) -> Left (name,t) | Extends t -> Right t) tags in
         let tag_cases = List.map (self#polycase_un ctxt) tags in
         let extension_case = self#extension ctxt tname extensions in
-          <:expr< fun id -> W.sum (function $list:tag_cases @ [extension_case]$) id >>
+          <:expr< fun id -> W.sum (fun [ $list:tag_cases @ [extension_case]$ ]) id >>
       in
         wrap ~ctxt ~atype:(atype ctxt decl) ~tymod:(typeable_instance ctxt tname)
           ~eqmod:(eq_instance ctxt tname)
@@ -204,7 +204,7 @@ struct
       match params' with
         | [] -> <:match_case< $uid:name$ as obj -> 
                               W.allocate obj (fun thisid -> $exp$) >>,
-                <:match_case< $`int:n$, [] -> return $uid:name$ >>
+                <:match_case< ($`int:n$, []) -> return $uid:name$ >>
         | _  -> <:match_case< $uid:name$ $fst (tuple ~param:"v" nparams)$ as obj -> 
                               W.allocate obj (fun thisid -> $exp$) >>,
     let _, tuple = tuple ~param:"id" nparams in
@@ -212,13 +212,13 @@ struct
       List.fold_right2 
         (fun n t (pat, exp) ->
            let m = Printf.sprintf "M%d" n and id = Printf.sprintf "id%d" n in
-           <:patt< $lid:id$ :: $pat$ >>,
+           <:patt< [ $lid:id$ :: $pat$] >>,
            <:expr< let module $uid:m$ = $self#expr ctxt t$
                     in $bind$ ($uid:m$.unpickle $lid:id$) (fun $lid:id$ -> $exp$) >>)
         (List.range 0 nparams)
         params'
       (<:patt< [] >>, <:expr< return ($uid:name$ $tuple$) >>) in
-      <:match_case< $`int:n$, $patt$ -> $exp$ >>
+      <:match_case< ($`int:n$, $patt$) -> $exp$ >>
 
   method sum ?eq ctxt (tname,_,_,_,_ as decl) summands =
     let nctors = List.length summands in
@@ -228,9 +228,9 @@ struct
       ~eqmod:(eq_instance ctxt tname)
       ~picklers
       ~unpickler:<:expr< fun id -> 
-        let f = function $list:unpicklers$ 
-                 | n,_ -> raise (UnpicklingError ($str:"Unexpected tag when unpickling "
-                                                  ^tname^": "$^ string_of_int n))
+        let f = fun [ $list:unpicklers$ 
+                 | (n,_) -> raise (UnpicklingError ($str:"Unexpected tag when unpickling "
+                                                  ^tname^": "$^ string_of_int n)) ]
         in W.sum f id >>
 
   method record ?eq ctxt (tname,_,_,_,_ as decl) (fields : Type.field list) = 
diff --git a/syntax/show_class.ml b/syntax/show_class.ml
index 3954b6a..4564203 100644
--- a/syntax/show_class.ml
+++ b/syntax/show_class.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -15,14 +15,14 @@ struct
   let classname = "Show"
     
   let wrap (ctxt:Base.context) (decl : Type.decl) matches = <:module_expr< 
-  struct type a = $atype ctxt decl$
-         let format formatter = function $list:matches$ end >>
+  struct type a = $atype ctxt decl$;
+         value format formatter = fun [ $list:matches$ ]; end >>
     
   let in_a_box box e =
     <:expr< 
-      Format.$lid:box$ formatter 0;
+      do { Format.$lid:box$ formatter 0;
       $e$;
-      Format.pp_close_box formatter () >>
+      Format.pp_close_box formatter () } >>
 
   let in_hovbox = in_a_box "pp_open_hovbox" and in_box = in_a_box "pp_open_box"
 
@@ -37,8 +37,8 @@ struct
       | Tag (name, Some e) ->
           <:match_case< `$uid:name$ x ->
                          $in_hovbox <:expr< 
-                            Format.pp_print_string formatter $str:"`" ^ name ^" "$;
-                            $mproject (self#expr ctxt e) "format"$ formatter x >>$ >>
+                            do { Format.pp_print_string formatter $str:"`" ^ name ^" "$;
+                            $mproject (self#expr ctxt e) "format"$ formatter x } >>$ >>
       | Extends t -> 
           let patt, guard, cast = cast_pattern ctxt t in
             <:match_case<
@@ -63,10 +63,10 @@ struct
     method tuple ctxt args = 
       let n = List.length args in
       let tpatt, _ = tuple n in
-      <:module_expr< Defaults (struct type a = $atype_expr ctxt (`Tuple args)$
-                            let format formatter $tpatt$ = 
+      <:module_expr< Defaults (struct type a = $atype_expr ctxt (`Tuple args)$;
+                            value format formatter $tpatt$ = 
                               $self#nargs ctxt 
-                                (List.mapn (fun t n -> Printf.sprintf "v%d" n, t) args)$ end) >>
+                                (List.mapn (fun t n -> Printf.sprintf "v%d" n, t) args)$; end) >>
 
     method case ctxt : Type.summand -> Ast.match_case = 
       fun (name, args) ->
@@ -77,13 +77,13 @@ struct
                 <:match_case<
                   $uid:name$ $patt$ ->
                   $in_hovbox <:expr<
-                    Format.pp_print_string formatter $str:name$;
+                    do { Format.pp_print_string formatter $str:name$;
                 Format.pp_print_break formatter 1 2;
-                $self#nargs ctxt (List.mapn (fun t n -> Printf.sprintf "v%d" n, t) args)$ >>$ >>
+                $self#nargs ctxt (List.mapn (fun t n -> Printf.sprintf "v%d" n, t) args)$ } >>$ >>
     
     method field ctxt : Type.field -> Ast.expr = function
-      | (name, ([], t), _) -> <:expr< Format.pp_print_string formatter $str:name ^ " ="$;
-                                      $mproject (self#expr ctxt t) "format"$ formatter $lid:name$ >>
+      | (name, ([], t), _) -> <:expr< do { Format.pp_print_string formatter $str:name ^ " ="$;
+                                      $mproject (self#expr ctxt t) "format"$ formatter $lid:name$ } >>
       | f -> raise (Underivable ("Show cannot be derived for record types with polymorphic fields")) 
 
     method sum ?eq ctxt decl summands = wrap ctxt decl (List.map (self#case ctxt) summands)
@@ -91,14 +91,14 @@ struct
     method record ?eq ctxt decl fields = wrap ctxt decl [ <:match_case<
       $record_pattern fields$ -> $in_hovbox
        <:expr<
-          Format.pp_print_char formatter '{';
+          do { Format.pp_print_char formatter '{';
           $List.fold_left1
-            (fun l r -> <:expr< $l$; Format.pp_print_string formatter "; "; $r$ >>)
+            (fun l r -> <:expr< do { $l$; Format.pp_print_string formatter "; "; $r$ } >>)
             (List.map (self#field ctxt) fields)$;
-          Format.pp_print_char formatter '}'; >>$ >>]
+          Format.pp_print_char formatter '}' } >>$ >>]
 
     method variant ctxt decl (_,tags) = wrap ctxt decl (List.map (self#polycase ctxt) tags
-                                                        @ [ <:match_case< _ -> assert false >> ])
+                                                        @ [ <:match_case< _ -> assert False >> ])
   end
 end
 
diff --git a/syntax/type.ml b/syntax/type.ml
index 736ca9a..e42cf78 100644
--- a/syntax/type.ml
+++ b/syntax/type.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -422,8 +422,8 @@ struct
       | _ -> assert false
     and app f = function
       | []    -> f
-      | [x]   -> <:ctyp< $expr x$ $f$ >>
-      | x::xs -> app (<:ctyp< $expr x$ $f$ >>) xs
+      | [x]   -> <:ctyp< $f$ $expr x$ >>
+      | x::xs -> app (<:ctyp< $f$ $expr x$ >>) xs
     in expr
          
   let poly (params, t) =
@@ -436,10 +436,10 @@ struct
   let rec rhs : rhs -> Ast.ctyp = function
       | `Fresh (None, t, `Private) -> <:ctyp< private $repr t$ >>
       | `Fresh (None, t, `Public) -> repr t
-      | `Fresh (Some e, t, `Private) -> <:ctyp< $expr e$ = private $repr t$ >>
+      | `Fresh (Some e, t, `Private) -> <:ctyp< $expr e$ == private $repr t$ >>
       | `Fresh (Some e, t, `Public) -> Ast.TyMan (loc, expr e, repr t)
       | `Expr t          -> expr t
-      | `Variant (`Eq, tags) -> <:ctyp< [  $unlist bar tags tagspec$ ] >>
+      | `Variant (`Eq, tags) -> <:ctyp< [= $unlist bar tags tagspec$ ] >>
       | `Variant (`Gt, tags) -> <:ctyp< [> $unlist bar tags tagspec$ ] >>
       | `Variant (`Lt, tags) -> <:ctyp< [< $unlist bar tags tagspec$ ] >>
       | `Nothing -> <:ctyp< >>
diff --git a/syntax/typeable_class.ml b/syntax/typeable_class.ml
index 21c069f..283260f 100644
--- a/syntax/typeable_class.ml
+++ b/syntax/typeable_class.ml
@@ -1,4 +1,4 @@
-(*pp camlp4of *)
+(*pp camlp4orf *)
 
 (* Copyright Jeremy Yallop 2007.
    This file is free software, distributed under the MIT license.
@@ -23,19 +23,19 @@ struct
     let paramList = 
       List.fold_right 
         (fun (p,_) cdr ->
-             <:expr< $uid:NameMap.find p ctxt.argmap$.type_rep::$cdr$ >>)
+             <:expr< [ $uid:NameMap.find p ctxt.argmap$.type_rep :: $cdr$ ] >>)
         ctxt.params
       <:expr< [] >>
-    in <:module_expr< struct type a = $atype ctxt decl$
-          let type_rep = TypeRep.mkFresh $str:mkName tname$ $paramList$ end >>
+    in <:module_expr< struct type a = $atype ctxt decl$;
+          value type_rep = TypeRep.mkFresh $str:mkName tname$ $paramList$; end >>
 
   let tup ctxt ts mexpr expr = 
       let params = 
         expr_list 
           (List.map (fun t -> <:expr< let module M = $expr ctxt t$ 
                                        in $mexpr$ >>) ts) in
-        <:module_expr< Defaults(struct type a = $atype_expr ctxt (`Tuple ts)$
-                                       let type_rep = Typeable.TypeRep.mkTuple $params$ end) >>
+        <:module_expr< Defaults(struct type a = $atype_expr ctxt (`Tuple ts)$;
+                                       value type_rep = Typeable.TypeRep.mkTuple $params$; end) >>
 
   let instance = object(self)
     inherit make_module_expr ~classname ~allow_private:true 
@@ -47,17 +47,17 @@ struct
     let tags, extends = 
       List.fold_left 
         (fun (tags, extends) -> function
-           | Tag (l, None)  -> <:expr< ($str:l$, None) :: $tags$ >>, extends
+           | Tag (l, None)  -> <:expr< [ ($str:l$, None) :: $tags$ ] >>, extends
            | Tag (l,Some t) ->
-               <:expr< ($str:l$, Some $mproject (self#expr ctxt t) "type_rep"$) ::$tags$ >>,
+               <:expr< [ ($str:l$, Some $mproject (self#expr ctxt t) "type_rep"$) :: $tags$ ] >>,
                extends
            | Extends t -> 
                tags,
-               <:expr< $mproject (self#expr ctxt t) "type_rep"$::$extends$ >>)
+               <:expr< [ $mproject (self#expr ctxt t) "type_rep"$ :: $extends$ ] >>)
         (<:expr< [] >>, <:expr< [] >>) tags in
       <:module_expr< Defaults(
-        struct type a = $atype ctxt decl$
-               let type_rep = Typeable.TypeRep.mkPolyv $tags$ $extends$
+        struct type a = $atype ctxt decl$;
+               value type_rep = Typeable.TypeRep.mkPolyv $tags$ $extends$;
         end) >>
   end
 end
diff --git a/syntax/utils.ml b/syntax/utils.ml
index 6c963bb..802a3c5 100644
--- a/syntax/utils.ml
+++ b/syntax/utils.ml
@@ -127,6 +127,7 @@ struct
     | TyAmp (_, c1, c2) -> "TyAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
     | TyOfAmp (_, c1, c2) -> "TyOfAmp ("^ ctyp c1 ^ ", " ^ ctyp c2 ^")"
     | TyAnt (_, s) -> "TyAnt("^s^")"
+    | _ -> "(?)"
 end
 
 module StringMap =
-- 
2.11.4.GIT