Add support for OCaml 4.03

This (rather large) commit introduces basic support for OCaml's
new constructors with inline arguments.
(No, I am not proud of the quality of this code ...)

Signed-off-by: Christoph Höger <[email protected]>

Author: Christoph Höger

_tags

@@ -1,5 +1,4 @@
-true: warn(@5@8@10@11@12@14@23@24@26@29@40), bin_annot, safe_string
-
+true: warn(@5@8@10@11@12@14@23@24@26@29@40), bin_annot, safe_string, cppo_V_OCAML
 "src": include
 <src/*.{ml,mli,byte,native}>: package(ppx_tools.metaquot), package(ppx_deriving.api)
 <src_test/*.{ml,byte,native}>: debug, package(oUnit), use_morphism

myocamlbuild.ml

@@ -1,24 +1,25 @@
-open Ocamlbuild_plugin
+open Ocamlbuild_plugin   
 
 let () = dispatch (
-  function
-  | After_rules ->
-    let ppx_loc = (Findlib.query "ppx_deriving").Findlib.location in
-    let std_deriver deriver =
-       ppx_loc ^ "/" ^ deriver
-    in
-    flag ["ocaml";"link";"byte";"use_morphism"] &
-    A (ppx_loc ^ "/ppx_deriving_runtime.cma") ;
-
-    flag ["ocaml";"link";"native";"use_morphism"] &
-    A (ppx_loc ^ "/ppx_deriving_runtime.cmxa") ;
-    
-    flag ["ocaml"; "compile"; "use_morphism"] &
-    S[A"-ppx"; A"ocamlfind ppx_import/ppx_import";
-      A"-I"; A ppx_loc ;
-      A"-ppx"; A("ocamlfind ppx_deriving/ppx_deriving "^
-                 "src/ppx_deriving_folder.cma "^
-                 "src/ppx_deriving_mapper.cma "^
-                 (std_deriver "ppx_deriving_show.cma")) ;
-       ]; 
-  | _ -> ())
+    fun hook ->
+      Ocamlbuild_cppo.dispatcher hook ;
+      match hook with
+      | After_rules ->
+        let ppx_loc = (Findlib.query "ppx_deriving").Findlib.location in
+        let std_deriver deriver =
+          ppx_loc ^ "/" ^ deriver
+        in
+        flag ["ocaml";"link";"byte";"use_morphism"] &
+        A (ppx_loc ^ "/ppx_deriving_runtime.cma") ;
+        
+        flag ["ocaml";"link";"native";"use_morphism"] &
+        A (ppx_loc ^ "/ppx_deriving_runtime.cmxa") ;
+        
+        flag ["ocaml"; "compile"; "use_morphism"] &
+        S[A"-I"; A ppx_loc ;
+          A"-ppx"; A("ocamlfind ppx_deriving/ppx_deriving "^
+                     "src/ppx_deriving_folder.cma "^
+                     "src/ppx_deriving_mapper.cma "^
+                     (std_deriver "ppx_deriving_show.cma")) ;
+         ]; 
+      | _ -> ())

opam

@@ -18,8 +18,10 @@ build-test: [
 ]
 depends: [
   "ppx_deriving" {>= "3.0" & < "4.0" }
+  "ppx_tools" {>= "4.02.3"}
   "ocamlfind"    {build}
+  "cppo"       {build}
   "ounit"        {test}
   "ppx_import"   {test}
 ]
-
+available: [ ocaml-version >= "4.02.1" & opam-version >= "1.2" ]

pkg/build.ml

@@ -2,8 +2,12 @@
 #directory "pkg"
 #use "topkg.ml"
 
+
+let ocamlbuild =
+  "ocamlbuild -use-ocamlfind -classic-display -plugin-tag 'package(cppo_ocamlbuild)'"
+
 let () =
-  Pkg.describe "ppx_deriving_morphism" ~builder:`OCamlbuild [
+  Pkg.describe "ppx_deriving_morphism" ~builder:(`Other (ocamlbuild, "_build")) [
     Pkg.lib "pkg/META";
     Pkg.lib ~exts:Exts.library "src/ppx_deriving_morphism";
     Pkg.lib ~exts:Exts.library "src/ppx_deriving_folder";

src/ppx_deriving_folder.ml renamed to src/ppx_deriving_folder.cppo.ml

@@ -25,6 +25,12 @@
  * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  *
  *)
+#if OCAML_VERSION < (4, 03, 0)
+#define STR_TYPE_RECURSIVE 
+#define Pcstr_tuple(core_types) core_types
+#else
+#define STR_TYPE_RECURSIVE Recursive
+#endif
 
 (** Generate folder-record(s) for a given type. 
 
@@ -100,7 +106,9 @@ let attr_fold attrs =
 
 let argn =
   Printf.sprintf "arg%d"
-
+let argl =
+  Printf.sprintf "arg%s"
+    
 let opt_pattn folds =
   List.mapi (fun i e -> match e with Some _ -> pvar (argn i) | None -> Pat.any ()) folds
 
@@ -115,6 +123,10 @@ let pat_tuple = function
   | [p] -> p
   | ps -> Pat.tuple ps
 
+let pattl labels = List.map (fun { pld_name = { txt = n } } -> n, pvar (argl n)) labels
+
+let pconstrrec name fields = pconstr name [precord ~closed:Closed fields]
+
 let core_type_of_decl ~options ~path type_decl =
   let typ = Ppx_deriving.core_type_of_type_decl type_decl in
   Ppx_deriving.poly_arrow_of_type_decl
@@ -180,7 +192,7 @@ let rec expr_of_typ names quoter typ =
 
       (* select the approppriate fold_routines for arguments and pass them through *)
       let arg_folds = args |> List.map
-                        (fun ct -> match expr_of_typ ct with Some e -> ("", e) | None -> ("", fold_pass))
+                        (fun ct -> match expr_of_typ ct with Some e -> (Label.nolabel, e) | None -> (Label.nolabel, fold_pass))
       in
       if arg_folds = [] then Some [%expr [%e fold_fn] self] else
         Some [%expr [%e Exp.apply fold_fn arg_folds] self]
@@ -222,11 +234,29 @@ let process_decl quoter fold_arg_t
       (* create a default folder implementation for each variant *)
       let fields =
         constrs |>
-        List.map (fun { pcd_name; pcd_args = typs } ->
-            let folds = List.map (expr_of_typ names quoter) typs in
-            let pat = pat_tuple (opt_pattn folds) in
+        List.map (
+          fun { pcd_name; pcd_args } ->
+            (* Get a pattern and a corresponding folding-sequence from the constructor args *)
+            let (pat, folds) = match pcd_args with
+              (* Classic constructor arguments, we make up names *)
+                Pcstr_tuple typs ->
+                let appls = List.map (expr_of_typ names quoter) typs in
+                (pat_tuple (opt_pattn appls), List.combine (varn typs) appls)
+#if OCAML_VERSION >= (4, 03, 0)                                    
+              | Pcstr_record labels ->
+                (* New stuff, args have names themselves *)
+                let opt_pattl {pld_name = { txt = l } ; pld_type = typ} (ps,fs) =
+                  let fold = expr_of_typ names quoter typ in
+                  (** Filter unused variables on-the-fly *)
+                  match fold with None -> ((Pat.any ()) :: ps,fs)
+                                | Some _ -> ((pvar (argl l))::ps, (evar (argl l), fold)::fs)
+                in
+                let (ps, fs) = List.fold_right opt_pattl labels ([],[]) in                
+                (pat_tuple ps, fs)
+#endif               
+            in
             let subfield = Ppx_deriving.mangle_lid (`Prefix "fold") (Lident pcd_name.txt) in
-            (mknoloc subfield, [%expr fun self [%p pat] -> [%e reduce_fold_seq (List.combine (varn typs) folds)]]))
+            (mknoloc subfield, [%expr fun self [%p pat] -> [%e reduce_fold_seq folds]]))
       in
       (mknoloc (Lident on_var), (Exp.record fields None)) :: defaults
     | _ -> defaults
@@ -240,12 +270,20 @@ let process_decl quoter fold_arg_t
       *)
       let cases =
         constrs |>
-        List.map (fun { pcd_name; pcd_args = typs } ->
+        List.map (fun { pcd_name; pcd_args} ->
+            let (pat, vars) = match pcd_args with
+                Pcstr_tuple typs -> (pconstr pcd_name.txt (pattn typs), varn typs)
+#if OCAML_VERSION >= (4, 03, 0)                                    
+              | Pcstr_record labels ->
+                (pconstrrec pcd_name.txt (pattl labels),
+                 List.map (fun {pld_name = {txt=l}} -> evar (argl l)) labels)
+#endif
+            in
             let subfield = Ppx_deriving.mangle_lid (`Prefix "fold") (Lident pcd_name.txt) in
-            Exp.case (pconstr pcd_name.txt (pattn typs))
+            Exp.case (pat)
               (Exp.apply 
                      (Exp.field (Exp.field [%expr self] (mknoloc (Lident on_var))) (mknoloc subfield))
-                     ["", evar "self"; "", tuple (varn typs)]))
+                     [Label.nolabel, evar "self"; Label.nolabel, tuple vars]))
       in      
       [%expr fun self x -> [%e Exp.match_ [%expr x] cases]]                           
     | Ptype_record labels ->
@@ -282,8 +320,15 @@ let process_decl quoter fold_arg_t
         | ts -> [%type: ([%t fold_arg_t], [%t Typ.tuple ts]) fold_routine]
       in
       (* create the fold_fn signature for the rhs of a constructor *)
-      let typs_to_field { pcd_name; pcd_args = typs } =
-        Type.field (mknoloc ("fold_" ^ pcd_name.txt)) (merge_typs typs) in
+      let typs_to_field { pcd_name; pcd_args} =
+        let typs = 
+        match pcd_args with
+        Pcstr_tuple typs -> typs
+#if OCAML_VERSION >= (4, 03, 0)                                    
+        | Pcstr_record labels -> List.map (fun {pld_type} -> pld_type) labels
+#endif
+        in Type.field (mknoloc ("fold_" ^ pcd_name.txt)) (merge_typs typs)
+      in
 
       let fields = constrs |> List.map typs_to_field in
       ( (Type.field (mknoloc field_name) [%type: ([%t fold_arg_t], [%t folded]) fold_routine])::
@@ -307,7 +352,8 @@ let process_decl quoter fold_arg_t
 
 let folder_to_str fold_arg_t {names; defaults; sub_folders; folder_fields} =
   [
-    (Str.type_ (
+    (Str.type_ STR_TYPE_RECURSIVE
+       (
         Type.mk
           ~params:[fold_arg_t, Invariant]
           ~kind:(Ptype_record folder_fields) (mknoloc "fold_routines") ::

src/ppx_deriving_mapper.ml renamed to src/ppx_deriving_mapper.cppo.ml

@@ -25,6 +25,12 @@
  * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  *
  *)
+#if OCAML_VERSION < (4, 03, 0)
+#define STR_TYPE_RECURSIVE 
+#define Pcstr_tuple(core_types) core_types
+#else
+#define STR_TYPE_RECURSIVE Recursive
+#endif
 
 (** Generate mapper-record(s) for a given type. 
 
@@ -113,13 +119,20 @@ let attr_map attrs =
 
 let argn =
   Printf.sprintf "arg%d"
+let argl =
+  Printf.sprintf "arg%s"
 
 let opt_pattn maps =
   List.mapi (fun i e -> match e with Some _ -> pvar (argn i) | None -> Pat.any ()) maps
 
 let pattn typs =
   List.mapi (fun i _ -> pvar (argn i)) typs
 
+let pattl labels = List.map (fun { pld_name = { txt = n } } -> n, pvar (argl n)) labels
+
+let pconstrrec name fields = pconstr name [precord ~closed:Closed fields]
+let constrrec name fields = constr name [record fields]
+    
 let varn typs =
   List.mapi (fun i _ -> evar (argn i)) typs
 
@@ -156,10 +169,19 @@ let reduce_map_seq ets =
     | (x,None) :: es -> reduce_ (x::ds) es
   in
 
-  match reduce_ [] ets with
-    [] -> None
-  | [e] -> Some e
-  | es -> Some (Exp.tuple es)
+  reduce_ [] ets 
+
+let reduce_record_map_seq ets =
+  (* Reduce a set of mapped arguments from record labels by applying all map-routines and create a tuple *)
+  let rec reduce_ ds = function
+    (* For each argument with a map-routine, apply that routine *)
+      [] -> List.rev ds
+    | (x,Some f) :: es -> reduce_ ((x, [%expr [%e f] [%e (evar (argl x))]])::ds) es
+    | (x,None) :: es -> reduce_ ((x, evar (argl x))::ds) es
+  in
+  
+  reduce_ [] ets 
+
 
 (* generate the map routine for a given type. 
    In case of unknown types, returns None
@@ -189,8 +211,8 @@ let rec expr_of_typ names quoter typ =
       let maps = List.map expr_of_typ typs in
       let pat = pat_tuple (pattn maps) in
       let map = match reduce_map_seq (List.combine (varn typs) maps) with
-          Some e -> e
-        | None -> raise (Failure "Tuple invariant broken")
+          e::es -> tuple (e::es)
+        | [] -> raise (Failure "Tuple invariant broken")
       in
       Some [%expr fun [%p pat] -> [%e map]]
 
@@ -202,7 +224,7 @@ let rec expr_of_typ names quoter typ =
 
       (* select the approppriate map_routines for arguments and pass them through *)
       let arg_maps = args |> List.map
-                       (fun ct -> match expr_of_typ ct with Some e -> ("", e) | None -> ("", map_pass))
+                       (fun ct -> match expr_of_typ ct with Some e -> (Label.nolabel, e) | None -> (Label.nolabel, map_pass))
       in
       if arg_maps = [] then Some [%expr [%e map_fn] self] else
         Some [%expr [%e Exp.apply map_fn arg_maps] self]
@@ -230,16 +252,19 @@ let process_decl quoter
       (* create a default mapper implementation for each variant *)
       let fields =
         constrs |>
-        List.map (fun { pcd_name; pcd_args = typs } ->
-            let maps = List.map (expr_of_typ names quoter) typs in
-            let pat = pat_tuple (pattn maps) in
+        List.map (fun { pcd_name; pcd_args } ->            
+            let (pat, rhs) = match pcd_args with              
+                Pcstr_tuple typs ->
+                let maps = List.map (expr_of_typ names quoter) typs in
+                (pat_tuple (pattn maps), constr pcd_name.txt (reduce_map_seq (List.combine (varn typs) maps)))
+#if OCAML_VERSION >= (4, 03, 0)                                    
+              | Pcstr_record labels ->
+                let map_seq = List.map (fun {pld_name = {txt=l}; pld_type} -> (l, expr_of_typ names quoter pld_type)) labels in
+                (pat_tuple (List.map (fun {pld_name={txt=l}} -> pvar (argl l)) labels), constrrec pcd_name.txt (reduce_record_map_seq map_seq))
+#endif
+            in
             let subfield = Ppx_deriving.mangle_lid (`Prefix "map") (Lident pcd_name.txt) in
-            (mknoloc subfield, [%expr fun self [%p pat] ->
-                     [%e
-                       (Exp.construct
-                          {pcd_name with txt=Lident pcd_name.txt}
-                          (reduce_map_seq (List.combine (varn typs) maps)))]
-              ]))
+            (mknoloc subfield, [%expr fun self [%p pat] -> [%e rhs]]))
       in
       (mknoloc (Lident on_var), (Exp.record fields None)) :: defaults
     | _ -> defaults
@@ -253,14 +278,22 @@ let process_decl quoter
       *)
       let cases =
         constrs |>
-        List.map (fun { pcd_name; pcd_args = typs } ->
+        List.map (fun { pcd_name; pcd_args } ->
             let subfield = Ppx_deriving.mangle_lid (`Prefix "map") (Lident pcd_name.txt) in
-            Exp.case (pconstr pcd_name.txt (pattn typs))
+            let (pat, mk) = match pcd_args with
+                Pcstr_tuple typs -> ((pconstr pcd_name.txt (pattn typs)), tuple (varn typs))
+#if OCAML_VERSION >= (4, 03, 0)                                    
+              | Pcstr_record labels ->
+                (pconstrrec pcd_name.txt (pattl labels),
+                 tuple (List.map (fun {pld_name = { txt = l } } -> evar (argl l)) labels))
+#endif
+            in
+            Exp.case pat
               (Exp.apply 
                  (Exp.field
                     (Exp.field [%expr self] (mknoloc (Lident on_var)))
                     (mknoloc subfield))
-                 ["", evar "self"; "", tuple (varn typs)]))
+                 [Label.nolabel, evar "self"; Label.nolabel, mk]))
       in      
       [%expr fun self x -> [%e Exp.match_ [%expr x] cases]]                           
     | Ptype_record labels ->
@@ -272,7 +305,7 @@ let process_decl quoter
             ({pld_name with txt = Lident pld_name.txt}, 
              match expr_of_typ names quoter pld_type with
                None -> evar pld_name.txt
-             | Some map -> Exp.apply map ["", evar pld_name.txt]
+             | Some map -> Exp.apply map [Label.nolabel, evar pld_name.txt]
             )
         end                  
       in
@@ -312,7 +345,14 @@ let process_decl quoter
       in
 
       (* create the map_fn signature for the rhs of a constructor *)
-      let typs_to_field { pcd_name; pcd_args = typs } =
+      let typs_to_field { pcd_name; pcd_args} =
+        let typs = 
+          match pcd_args with
+            Pcstr_tuple typs -> typs
+#if OCAML_VERSION >= (4, 03, 0)                                    
+          | Pcstr_record labels -> List.map (fun {pld_type} -> pld_type) labels
+#endif
+        in         
         Type.field (mknoloc ("map_" ^ pcd_name.txt)) (merge_typs typs) in
 
       let fields = constrs |> List.map typs_to_field in
@@ -336,7 +376,7 @@ let process_decl quoter
 
 let mapper_to_str {names; defaults; sub_mappers; mapper_fields} =
   [
-    (Str.type_ (
+    (Str.type_ STR_TYPE_RECURSIVE (
         Type.mk
           ~kind:(Ptype_record mapper_fields) (mknoloc "map_routines") ::
         Type.mk