New upstream version 4.2.1

8 files changed, 130 insertions, 42 deletions

diff --git a/src_plugins/ppx_deriving_enum.cppo.ml b/src_plugins/ppx_deriving_enum.cppo.ml
index 3c8bf84..aec3fbc 100644
--- a/src_plugins/ppx_deriving_enum.cppo.ml
+++ b/src_plugins/ppx_deriving_enum.cppo.ml
@@ -47,7 +47,10 @@ let mappings_of_type type_decl =
             raise_errorf ~loc:ptyp_loc
                          "%s cannot be derived for inherited variant cases" deriver
           | Rtag (name, attrs, true, []) ->
-            map acc mappings attrs { txt = name; loc = ptyp_loc }
+#if OCAML_VERSION < (4, 06, 0)
+            let name = mkloc name ptyp_loc in
+#endif
+            map acc mappings attrs name
           | Rtag _ ->
             raise_errorf ~loc:ptyp_loc
                          "%s can be derived only for argumentless constructors" deriver)
diff --git a/src_plugins/ppx_deriving_eq.cppo.ml b/src_plugins/ppx_deriving_eq.cppo.ml
index 4b20e51..41e505e 100644
--- a/src_plugins/ppx_deriving_eq.cppo.ml
+++ b/src_plugins/ppx_deriving_eq.cppo.ml
@@ -98,7 +98,8 @@ and expr_of_typ quoter typ =
           | None, None -> true
           | Some a, Some b -> [%e expr_of_typ typ] a b
           | _ -> false]
-      | true, [%type: ([%t? ok_t], [%t? err_t]) Result.result] ->
+      | true, ([%type: ([%t? ok_t], [%t? err_t]) result] |
+               [%type: ([%t? ok_t], [%t? err_t]) Result.result]) ->
         [%expr fun x y ->
           match x, y with
           | Result.Ok a, Result.Ok b -> [%e expr_of_typ ok_t] a b
@@ -120,11 +121,18 @@ and expr_of_typ quoter typ =
       let cases =
         (fields |> List.map (fun field ->
           let pdup f = ptuple [f "lhs"; f "rhs"] in
+          let variant label popt =
+#if OCAML_VERSION < (4, 06, 0)
+            Pat.variant label popt
+#else
+            Pat.variant label.txt popt
+#endif
+          in
           match field with
           | Rtag (label, _, true (*empty*), []) ->
-            Exp.case (pdup (fun _ -> Pat.variant label None)) [%expr true]
+            Exp.case (pdup (fun _ -> variant label None)) [%expr true]
           | Rtag (label, _, false, [typ]) ->
-            Exp.case (pdup (fun var -> Pat.variant label (Some (pvar var))))
+            Exp.case (pdup (fun var -> variant label (Some (pvar var))))
                      (app (expr_of_typ typ) [evar "lhs"; evar "rhs"])
           | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
             Exp.case (pdup (fun var -> Pat.alias (Pat.type_ tname) (mknoloc var)))
@@ -190,7 +198,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       core_type_of_decl  ~options ~path type_decl in
   let eq_var =
     pvar (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl) in
-  [Vb.mk (Pat.constraint_ eq_var out_type)
+  [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]]
+         (Pat.constraint_ eq_var out_type)
          (Ppx_deriving.sanitize ~quoter (polymorphize comparator))]
 
 let () =
diff --git a/src_plugins/ppx_deriving_fold.cppo.ml b/src_plugins/ppx_deriving_fold.cppo.ml
index 43f3c1a..c3b8d6f 100644
--- a/src_plugins/ppx_deriving_fold.cppo.ml
+++ b/src_plugins/ppx_deriving_fold.cppo.ml
@@ -44,7 +44,8 @@ let rec expr_of_typ typ =
       [%expr Ppx_deriving_runtime.Array.fold_left [%e expr_of_typ typ]]
     | true, [%type: [%t? typ] option] ->
       [%expr fun acc -> function None -> acc | Some x -> [%e expr_of_typ typ] acc x]
-    | true, [%type: ([%t? ok_t], [%t? err_t]) Result.result] ->
+    | true, ([%type: ([%t? ok_t], [%t? err_t]) result] |
+             [%type: ([%t? ok_t], [%t? err_t]) Result.result]) ->
       [%expr
         fun acc -> function
         | Result.Ok ok -> [%e expr_of_typ ok_t] acc ok
@@ -62,11 +63,18 @@ let rec expr_of_typ typ =
   | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } ->
     let cases =
       fields |> List.map (fun field ->
+        let variant label popt =
+#if OCAML_VERSION < (4, 06, 0)
+          Pat.variant label popt
+#else
+          Pat.variant label.txt popt
+#endif
+        in
         match field with
         | Rtag (label, _, true (*empty*), []) ->
-          Exp.case (Pat.variant label None) [%expr acc]
+          Exp.case (variant label None) [%expr acc]
         | Rtag (label, _, false, [typ]) ->
-          Exp.case (Pat.variant label (Some [%pat? x]))
+          Exp.case (variant label (Some [%pat? x]))
                    [%expr [%e expr_of_typ typ] acc x]
         | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
           Exp.case [%pat? [%p Pat.type_ tname] as x]
@@ -119,16 +127,24 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       raise_errorf ~loc "%s cannot be derived for open types" deriver
   in
   let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in
-  [Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl))
-               (polymorphize mapper)]
+  [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]]
+         (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl))
+         (polymorphize mapper)]
 
 let sig_of_type ~options ~path type_decl =
   parse_options options;
+  let loc = type_decl.ptype_loc in
   let typ = Ppx_deriving.core_type_of_type_decl type_decl in
-  let acc = Typ.var Ppx_deriving.(fresh_var (free_vars_in_core_type typ)) in
+  let vars =
+#if OCAML_VERSION >= (4, 05, 0)
+    (List.map (fun tyvar -> tyvar.txt))
+#endif
+      (Ppx_deriving.free_vars_in_core_type typ)
+  in
+  let acc = Typ.var ~loc Ppx_deriving.(fresh_var vars) in
   let polymorphize = Ppx_deriving.poly_arrow_of_type_decl
                         (fun var -> [%type: [%t acc] -> [%t var] -> [%t acc]]) type_decl in
-  [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl))
+  [Sig.value ~loc (Val.mk (mkloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl) loc)
               (polymorphize [%type: [%t acc] -> [%t typ] -> [%t acc]]))]
 
 let () =
diff --git a/src_plugins/ppx_deriving_iter.cppo.ml b/src_plugins/ppx_deriving_iter.cppo.ml
index 16feddb..0c53c53 100644
--- a/src_plugins/ppx_deriving_iter.cppo.ml
+++ b/src_plugins/ppx_deriving_iter.cppo.ml
@@ -60,11 +60,18 @@ let rec expr_of_typ typ =
   | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } ->
     let cases =
       fields |> List.map (fun field ->
+        let variant label popt =
+#if OCAML_VERSION < (4, 06, 0)
+          Pat.variant label popt
+#else
+          Pat.variant label.txt popt
+#endif
+        in
         match field with
         | Rtag (label, _, true (*empty*), []) ->
-          Exp.case (Pat.variant label None) [%expr ()]
+          Exp.case (variant label None) [%expr ()]
         | Rtag (label, _, false, [typ]) ->
-          Exp.case (Pat.variant label (Some [%pat? x]))
+          Exp.case (variant label (Some [%pat? x]))
                    [%expr [%e expr_of_typ typ] x]
         | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
           Exp.case [%pat? [%p Pat.type_ tname] as x]
@@ -119,8 +126,9 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       raise_errorf ~loc "%s cannot be derived for open types" deriver
   in
   let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in
-  [Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl))
-               (polymorphize iterator)]
+  [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]]
+         (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl))
+         (polymorphize iterator)]
 
 let sig_of_type ~options ~path type_decl =
   parse_options options;
diff --git a/src_plugins/ppx_deriving_make.mllib b/src_plugins/ppx_deriving_make.mllib
index 1b2681b..7f23204 100644
--- a/src_plugins/ppx_deriving_make.mllib
+++ b/src_plugins/ppx_deriving_make.mllib
@@ -1 +1 @@
-ppx_deriving_create
+ppx_deriving_make
diff --git a/src_plugins/ppx_deriving_map.cppo.ml b/src_plugins/ppx_deriving_map.cppo.ml
index 24bc446..99e10d6 100644
--- a/src_plugins/ppx_deriving_map.cppo.ml
+++ b/src_plugins/ppx_deriving_map.cppo.ml
@@ -42,7 +42,8 @@ let rec expr_of_typ ?decl typ =
       [%expr Ppx_deriving_runtime.Array.map [%e expr_of_typ ?decl typ]]
     | true, [%type: [%t? typ] option] ->
       [%expr function None -> None | Some x -> Some ([%e expr_of_typ ?decl typ] x)]
-    | true, [%type: ([%t? ok_t], [%t? err_t]) Result.result] ->
+    | true, ([%type: ([%t? ok_t], [%t? err_t]) result] |
+             [%type: ([%t? ok_t], [%t? err_t]) Result.result]) ->
       [%expr
         function
         | Result.Ok ok -> Result.Ok ([%e expr_of_typ ?decl ok_t] ok)
@@ -58,12 +59,26 @@ let rec expr_of_typ ?decl typ =
   | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } ->
     let cases =
       fields |> List.map (fun field ->
+        let pat_variant label popt =
+#if OCAML_VERSION < (4, 06, 0)
+          Pat.variant label popt
+#else
+          Pat.variant label.txt popt
+#endif
+        in
+        let exp_variant label popt =
+#if OCAML_VERSION < (4, 06, 0)
+          Exp.variant label popt
+#else
+          Exp.variant label.txt popt
+#endif
+        in
         match field with
         | Rtag (label, _, true (*empty*), []) ->
-          Exp.case (Pat.variant label None) (Exp.variant label None)
+          Exp.case (pat_variant label None) (exp_variant label None)
         | Rtag (label, _, false, [typ]) ->
-          Exp.case (Pat.variant label (Some [%pat? x]))
-                   (Exp.variant label (Some [%expr [%e expr_of_typ ?decl typ] x]))
+          Exp.case (pat_variant label (Some [%pat? x]))
+                   (exp_variant label (Some [%expr [%e expr_of_typ ?decl typ] x]))
         | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> begin
           match decl with
           | None -> 
@@ -119,8 +134,9 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       raise_errorf ~loc "%s cannot be derived for open types" deriver
   in
   let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in
-  [Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl))
-               (polymorphize mapper)]
+  [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]]
+         (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl))
+         (polymorphize mapper)]
 
 let sig_of_type ~options ~path type_decl =
   parse_options options;
diff --git a/src_plugins/ppx_deriving_ord.cppo.ml b/src_plugins/ppx_deriving_ord.cppo.ml
index 800e8f1..a534352 100644
--- a/src_plugins/ppx_deriving_ord.cppo.ml
+++ b/src_plugins/ppx_deriving_ord.cppo.ml
@@ -32,7 +32,8 @@ let argl kind =
 let compare_reduce acc expr =
   [%expr match [%e expr] with 0 -> [%e acc] | x -> x]
 
-let reduce_compare = function
+let reduce_compare l =
+  match List.rev l with
   | [] -> [%expr 0]
   | x :: xs -> List.fold_left compare_reduce x xs
 
@@ -75,7 +76,8 @@ and expr_of_typ quoter typ =
               | [%type: int64] | [%type: Int64.t] | [%type: nativeint]
               | [%type: Nativeint.t] | [%type: float] | [%type: bool]
               | [%type: char] | [%type: string] | [%type: bytes]) ->
-        [%expr Pervasives.compare]
+        let compare_fn = [%expr fun (a:[%t typ]) b -> Pervasives.compare a b] in
+        Ppx_deriving.quote quoter compare_fn
       | true, [%type: [%t? typ] ref] ->
         [%expr fun a b -> [%e expr_of_typ typ] !a !b]
       | true, [%type: [%t? typ] list]  ->
@@ -104,7 +106,8 @@ and expr_of_typ quoter typ =
           | Some a, Some b -> [%e expr_of_typ typ] a b
           | None, Some _ -> -1
           | Some _, None -> 1]
-      | true, [%type: ([%t? ok_t], [%t? err_t]) Result.result] ->
+      | true, ([%type: ([%t? ok_t], [%t? err_t]) result] |
+               [%type: ([%t? ok_t], [%t? err_t]) Result.result]) ->
         [%expr fun x y ->
           match x, y with
           | Result.Error a, Result.Error b -> [%e expr_of_typ err_t] a b
@@ -122,16 +125,23 @@ and expr_of_typ quoter typ =
       end
     | { ptyp_desc = Ptyp_tuple typs } ->
       [%expr fun [%p ptuple (pattn `lhs typs)] [%p ptuple (pattn `rhs typs)] ->
-        [%e exprn quoter typs |> List.rev |> reduce_compare]]
+        [%e exprn quoter typs |> reduce_compare]]
     | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } ->
+      let variant label popt =
+#if OCAML_VERSION < (4, 06, 0)
+        Pat.variant label popt
+#else
+        Pat.variant label.txt popt
+#endif
+      in
       let cases =
         fields |> List.map (fun field ->
           let pdup f = ptuple [f "lhs"; f "rhs"] in
           match field with
           | Rtag (label, _, true (*empty*), []) ->
-            Exp.case (pdup (fun _ -> Pat.variant label None)) [%expr 0]
+            Exp.case (pdup (fun _ -> variant label None)) [%expr 0]
           | Rtag (label, _, false, [typ]) ->
-            Exp.case (pdup (fun var -> Pat.variant label (Some (pvar var))))
+            Exp.case (pdup (fun var -> variant label (Some (pvar var))))
                      (app (expr_of_typ typ) [evar "lhs"; evar "rhs"])
           | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
             Exp.case (pdup (fun var -> Pat.alias (Pat.type_ tname) (mknoloc var)))
@@ -144,9 +154,9 @@ and expr_of_typ quoter typ =
         fields |> List.mapi (fun i field ->
           match field with
           | Rtag (label, _, true (*empty*), []) ->
-            Exp.case (Pat.variant label None) (int i)
+            Exp.case (variant label None) (int i)
           | Rtag (label, _, false, [typ]) ->
-            Exp.case (Pat.variant label (Some [%pat? _])) (int i)
+            Exp.case (variant label (Some [%pat? _])) (int i)
           | Rinherit { ptyp_desc = Ptyp_constr (tname, []) } ->
             Exp.case (Pat.type_ tname) (int i)
           | _ -> assert false)
@@ -186,12 +196,12 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
         constrs |> List.map (fun { pcd_name = { txt = name }; pcd_args } ->
           match pcd_args with
           | Pcstr_tuple(typs) ->
-            exprn quoter typs |> List.rev |> reduce_compare |>
+            exprn quoter typs |> reduce_compare |>
             Exp.case (ptuple [pconstr name (pattn `lhs typs);
                               pconstr name (pattn `rhs typs)])
 #if OCAML_VERSION >= (4, 03, 0)
           | Pcstr_record(labels) ->
-            exprl quoter labels |> List.rev |> reduce_compare |>
+            exprl quoter labels |> reduce_compare |>
             Exp.case (ptuple [pconstrrec name (pattl `lhs labels);
                               pconstrrec name (pattl `rhs labels)])
 #endif
@@ -219,7 +229,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       core_type_of_decl ~options ~path type_decl in
   let out_var =
     pvar (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl) in
-  [Vb.mk (Pat.constraint_ out_var out_type)
+  [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]]
+         (Pat.constraint_ out_var out_type)
          (Ppx_deriving.sanitize ~quoter (polymorphize comparator))]
 
 let () =
diff --git a/src_plugins/ppx_deriving_show.cppo.ml b/src_plugins/ppx_deriving_show.cppo.ml
index 17642b9..06a0f2e 100644
--- a/src_plugins/ppx_deriving_show.cppo.ml
+++ b/src_plugins/ppx_deriving_show.cppo.ml
@@ -12,10 +12,25 @@ open Ast_convenience
 let deriver = "show"
 let raise_errorf = Ppx_deriving.raise_errorf
 
+type options = { with_path : bool }
+
+(* The option [with_path] controls whether a full path should be displayed
+   as part of data constructor names and record field names. (In the case
+   of record fields, it is displayed only as part of the name of the first
+   field.) By default, this option is [true], which means that full paths
+   are shown. *)
+
+let expand_path show_opts ~path name =
+  let path = if show_opts.with_path then path else [] in
+  Ppx_deriving.expand_path ~path name
+
 let parse_options options =
+  let with_path = ref true in
   options |> List.iter (fun (name, expr) ->
     match name with
-    | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name)
+    | "with_path" -> with_path := Ppx_deriving.Arg.(get_expr ~deriver bool) expr
+    | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name);
+  { with_path = !with_path }
 
 let attr_nobuiltin attrs =
   Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver)
@@ -42,7 +57,7 @@ let wrap_printer quoter printer =
     [%expr (let fprintf = Format.fprintf in [%e printer]) [@ocaml.warning "-26"]]
 
 let pp_type_of_decl ~options ~path type_decl =
-  parse_options options;
+  let _ = parse_options options in
   let typ = Ppx_deriving.core_type_of_type_decl type_decl in
   Ppx_deriving.poly_arrow_of_type_decl
     (fun var -> [%type: Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit])
@@ -50,7 +65,7 @@ let pp_type_of_decl ~options ~path type_decl =
     [%type: Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit]
 
 let show_type_of_decl ~options ~path type_decl =
-  parse_options options;
+  let _ = parse_options options in
   let typ = Ppx_deriving.core_type_of_type_decl type_decl in
   Ppx_deriving.poly_arrow_of_type_decl
     (fun var -> [%type: Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit])
@@ -58,7 +73,7 @@ let show_type_of_decl ~options ~path type_decl =
     [%type: [%t typ] -> Ppx_deriving_runtime.string]
 
 let sig_of_type ~options ~path type_decl =
-  parse_options options;
+  let _ = parse_options options in
   [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl))
               (pp_type_of_decl ~options ~path type_decl));
    Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl))
@@ -120,7 +135,8 @@ let rec expr_of_typ quoter typ =
             Format.pp_print_string fmt "(Some ";
             [%e expr_of_typ typ] x;
             Format.pp_print_string fmt ")"]
-      | true, [%type: ([%t? ok_t],[%t? err_t]) Result.result] ->
+      | true, ([%type: ([%t? ok_t], [%t? err_t]) result] |
+               [%type: ([%t? ok_t], [%t? err_t]) Result.result]) ->
         [%expr
           function
           | Result.Ok ok ->
@@ -160,9 +176,15 @@ let rec expr_of_typ quoter typ =
         fields |> List.map (fun field ->
           match field with
           | Rtag (label, _, true (*empty*), []) ->
+#if OCAML_VERSION >= (4, 06, 0)
+            let label = label.txt in
+#endif
             Exp.case (Pat.variant label None)
                      [%expr Format.pp_print_string fmt [%e str ("`" ^ label)]]
           | Rtag (label, _, false, [typ]) ->
+#if OCAML_VERSION >= (4, 06, 0)
+            let label = label.txt in
+#endif
             Exp.case (Pat.variant label (Some [%pat? x]))
                      [%expr Format.fprintf fmt [%e str ("`" ^ label ^ " (@[<hov>")];
                             [%e expr_of_typ typ] x;
@@ -182,7 +204,7 @@ let rec expr_of_typ quoter typ =
                    deriver (Ppx_deriving.string_of_core_type typ)
 
 let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
-  parse_options options;
+  let show_opts = parse_options options in
   let quoter = Ppx_deriving.create_quoter () in
   let path = Ppx_deriving.path_of_type_decl ~path type_decl in
   let prettyprinter =
@@ -192,7 +214,10 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
     | Ptype_variant constrs, _ ->
       let cases =
         constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } ->
-          let constr_name = Ppx_deriving.expand_path ~path name' in
+          let constr_name =
+            expand_path show_opts ~path name'
+          in
+
           match attr_printer pcd_attributes, pcd_args with
           | Some printer, Pcstr_tuple(args) ->
             let rec range from_idx to_idx =
@@ -260,7 +285,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
     | Ptype_record labels, _ ->
       let fields =
         labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type; pld_attributes } ->
-          let field_name = if i = 0 then Ppx_deriving.expand_path ~path name else name in
+          let field_name = if i = 0 then expand_path show_opts ~path name else name in
           let pld_type = {pld_type with ptyp_attributes=pld_attributes@pld_type.ptyp_attributes} in
           [%expr
             Format.fprintf fmt "@[%s =@ " [%e str field_name];