Imported Upstream version 4.0

8 files changed, 89 insertions, 23 deletions

diff --git a/src_plugins/ppx_deriving_create.cppo.ml b/src_plugins/ppx_deriving_create.cppo.ml
index bdfd16b..f49a3d6 100644
--- a/src_plugins/ppx_deriving_create.cppo.ml
+++ b/src_plugins/ppx_deriving_create.cppo.ml
@@ -49,6 +49,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       in
       List.fold_left (fun accum { pld_name = { txt = name }; pld_type; pld_attributes } ->
         let attrs = pld_attributes @ pld_type.ptyp_attributes in
+        let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
         match attr_default attrs with
         | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default))
                                    (pvar name) accum
@@ -99,6 +100,7 @@ let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       in
       List.fold_left (fun accum { pld_name = { txt = name; loc }; pld_type; pld_attributes } ->
         let attrs = pld_type.ptyp_attributes @ pld_attributes in
+        let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
         match attr_default attrs with
         | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum
         | None ->
diff --git a/src_plugins/ppx_deriving_eq.cppo.ml b/src_plugins/ppx_deriving_eq.cppo.ml
index 2dd2c57..4b20e51 100644
--- a/src_plugins/ppx_deriving_eq.cppo.ml
+++ b/src_plugins/ppx_deriving_eq.cppo.ml
@@ -60,6 +60,7 @@ and exprl quoter typs =
     app (expr_of_typ quoter typ) [evar (argl `lhs n); evar (argl `rhs n)])
 
 and expr_of_typ quoter typ =
+  let typ = Ppx_deriving.remove_pervasives ~deriver typ in
   let expr_of_typ = expr_of_typ quoter in
   match attr_equal typ.ptyp_attributes with
   | Some fn -> Ppx_deriving.quote quoter fn
@@ -97,6 +98,12 @@ 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] ->
+        [%expr fun x y ->
+          match x, y with
+          | Result.Ok a, Result.Ok b -> [%e expr_of_typ ok_t] a b
+          | Result.Error a, Result.Error b -> [%e expr_of_typ err_t] a b
+          | _ -> false]
       | true, ([%type: [%t? typ] lazy_t] | [%type: [%t? typ] Lazy.t]) ->
         [%expr fun (lazy x) (lazy y) -> [%e expr_of_typ typ] x y]
       | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
@@ -142,7 +149,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
     | Ptype_abstract, Some manifest -> expr_of_typ quoter manifest
     | Ptype_variant constrs, _ ->
       let cases =
-        (constrs |> List.map (fun { pcd_name = { txt = name }; pcd_args } ->
+        (constrs |> List.map (fun { pcd_name = { txt = name }; pcd_args; pcd_loc } ->
+          with_default_loc pcd_loc @@ fun () ->
           match pcd_args with
           | Pcstr_tuple(typs) ->
             exprn quoter typs |>
@@ -162,7 +170,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       [%expr fun lhs rhs -> [%e Exp.match_ [%expr lhs, rhs] cases]]
     | Ptype_record labels, _ ->
       let exprs =
-        labels |> List.map (fun { pld_name = { txt = name }; pld_type; pld_attributes } ->
+        labels |> List.map (fun { pld_name = { txt = name }; pld_type; pld_attributes; pld_loc } ->
+          with_default_loc pld_loc @@ fun () ->
           (* combine attributes of type and label *)
           let attrs =  pld_type.ptyp_attributes @ pld_attributes in
           let pld_type = {pld_type with ptyp_attributes=attrs} in
diff --git a/src_plugins/ppx_deriving_fold.cppo.ml b/src_plugins/ppx_deriving_fold.cppo.ml
index 3d5c723..43f3c1a 100644
--- a/src_plugins/ppx_deriving_fold.cppo.ml
+++ b/src_plugins/ppx_deriving_fold.cppo.ml
@@ -31,18 +31,24 @@ let pconstrrec name fields = pconstr name [precord ~closed:Closed fields]
 let reduce_acc a b = [%expr let acc = [%e a] in [%e b]]
 
 let rec expr_of_typ typ =
+  let typ = Ppx_deriving.remove_pervasives ~deriver typ in
   match typ with
   | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun acc _ -> acc]
   | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
     let builtin = not (attr_nobuiltin typ.ptyp_attributes) in
     begin match builtin, typ with
-    | true, [%type: [%t? typ] ref] -> [%expr fun x -> [%e expr_of_typ typ] !x]
+    | true, [%type: [%t? typ] ref] -> [%expr fun acc x -> [%e expr_of_typ typ] acc !x]
     | true, [%type: [%t? typ] list] ->
       [%expr Ppx_deriving_runtime.List.fold_left [%e expr_of_typ typ]]
     | true, [%type: [%t? typ] array] ->
       [%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] ->
+      [%expr
+        fun acc -> function
+        | Result.Ok ok -> [%e expr_of_typ ok_t] acc ok
+        | Result.Error err -> [%e expr_of_typ err_t] acc err]
     | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
       app (Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix deriver) lid)))
           (List.map expr_of_typ args)
diff --git a/src_plugins/ppx_deriving_iter.cppo.ml b/src_plugins/ppx_deriving_iter.cppo.ml
index 932c6d5..16feddb 100644
--- a/src_plugins/ppx_deriving_iter.cppo.ml
+++ b/src_plugins/ppx_deriving_iter.cppo.ml
@@ -29,6 +29,7 @@ let pattl labels = List.map (fun { pld_name = { txt = n } } -> n, pvar (argl n))
 let pconstrrec name fields = pconstr name [precord ~closed:Closed fields]
 
 let rec expr_of_typ typ =
+  let typ = Ppx_deriving.remove_pervasives ~deriver typ in
   match typ with
   | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun _ -> ()]
   | { ptyp_desc = Ptyp_constr _ } ->
@@ -42,6 +43,11 @@ let rec expr_of_typ typ =
       [%expr Ppx_deriving_runtime.Array.iter [%e expr_of_typ typ]]
     | true, [%type: [%t? typ] option] ->
       [%expr function None -> () | Some x -> [%e expr_of_typ typ] x]
+    | true, [%type: ([%t? ok_t], [%t? err_t]) Result.result] ->
+      [%expr
+        function
+        | Result.Ok ok -> ignore ([%e expr_of_typ ok_t] ok)
+        | Result.Error err -> ignore ([%e expr_of_typ err_t] err)]
     | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
       app (Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix deriver) lid)))
           (List.map expr_of_typ args)
diff --git a/src_plugins/ppx_deriving_make.cppo.ml b/src_plugins/ppx_deriving_make.cppo.ml
index 1f99b31..77c49fb 100644
--- a/src_plugins/ppx_deriving_make.cppo.ml
+++ b/src_plugins/ppx_deriving_make.cppo.ml
@@ -37,7 +37,7 @@ let is_optional { pld_name = { txt = name }; pld_type; pld_attributes } =
   | Some _ -> true
   | None ->
     attr_split attrs ||
-    (match pld_type with
+    (match Ppx_deriving.remove_pervasives ~deriver pld_type with
      | [%type: [%t? _] list]
      | [%type: [%t? _] option] -> true
      | _ -> false)
@@ -64,6 +64,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       in
       List.fold_left (fun accum { pld_name = { txt = name }; pld_type; pld_attributes } ->
         let attrs = pld_attributes @ pld_type.ptyp_attributes in
+        let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
         match attr_default attrs with
         | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default))
                                    (pvar name) accum
@@ -115,6 +116,7 @@ let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       in
       List.fold_left (fun accum { pld_name = { txt = name; loc }; pld_type; pld_attributes } ->
         let attrs = pld_type.ptyp_attributes @ pld_attributes in
+        let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in
         match attr_default attrs with
         | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum
         | None ->
diff --git a/src_plugins/ppx_deriving_map.cppo.ml b/src_plugins/ppx_deriving_map.cppo.ml
index b7fd85c..3a696ce 100644
--- a/src_plugins/ppx_deriving_map.cppo.ml
+++ b/src_plugins/ppx_deriving_map.cppo.ml
@@ -30,6 +30,7 @@ let pconstrrec name fields = pconstr name [precord ~closed:Closed fields]
 let  constrrec name fields =  constr name [ record                fields]
 
 let rec expr_of_typ typ =
+  let typ = Ppx_deriving.remove_pervasives ~deriver typ in
   match typ with
   | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun x -> x]
   | { ptyp_desc = Ptyp_constr _ } ->
@@ -41,6 +42,11 @@ let rec expr_of_typ typ =
       [%expr Ppx_deriving_runtime.Array.map [%e expr_of_typ typ]]
     | true, [%type: [%t? typ] option] ->
       [%expr function None -> None | Some x -> Some ([%e expr_of_typ typ] x)]
+    | true, [%type: ([%t? ok_t], [%t? err_t]) Result.result] ->
+      [%expr
+        function
+        | Result.Ok ok -> Result.Ok ([%e expr_of_typ ok_t] ok)
+        | Result.Error err -> Result.Error ([%e expr_of_typ err_t] err)]
     | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
       app (Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix deriver) lid)))
           (List.map expr_of_typ args)
diff --git a/src_plugins/ppx_deriving_ord.cppo.ml b/src_plugins/ppx_deriving_ord.cppo.ml
index 8c13829..800e8f1 100644
--- a/src_plugins/ppx_deriving_ord.cppo.ml
+++ b/src_plugins/ppx_deriving_ord.cppo.ml
@@ -63,6 +63,7 @@ and expr_of_typ quoter typ =
   match attr_compare typ.ptyp_attributes with
   | Some fn -> Ppx_deriving.quote quoter fn
   | None ->
+    let typ = Ppx_deriving.remove_pervasives ~deriver typ in
     match typ with
     | [%type: _] -> [%expr fun _ _ -> 0]
     | { ptyp_desc = Ptyp_constr _ } ->
@@ -103,6 +104,13 @@ 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] ->
+        [%expr fun x y ->
+          match x, y with
+          | Result.Error a, Result.Error b -> [%e expr_of_typ err_t] a b
+          | Result.Ok a, Result.Ok b -> [%e expr_of_typ ok_t] a b
+          | Result.Ok _ , Result.Error _ -> -1
+          | Result.Error _ , Result.Ok _ -> 1]
       | true, ([%type: [%t? typ] lazy_t] | [%type: [%t? typ] Lazy.t]) ->
         [%expr fun (lazy x) (lazy y) -> [%e expr_of_typ typ] x y]
       | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
diff --git a/src_plugins/ppx_deriving_show.cppo.ml b/src_plugins/ppx_deriving_show.cppo.ml
index c3263c0..55925cc 100644
--- a/src_plugins/ppx_deriving_show.cppo.ml
+++ b/src_plugins/ppx_deriving_show.cppo.ml
@@ -81,6 +81,7 @@ let rec expr_of_typ quoter typ =
           [%e expr_of_typ typ] x; true) false x);
         Format.fprintf fmt [%e str finish];]
     in
+    let typ = Ppx_deriving.remove_pervasives ~deriver typ in
     match typ with
     | [%type: _] -> [%expr fun _ -> Format.pp_print_string fmt "_"]
     | { ptyp_desc = Ptyp_arrow _ } ->
@@ -109,8 +110,8 @@ let rec expr_of_typ quoter typ =
           Format.pp_print_string fmt "ref (";
           [%e expr_of_typ typ] !x;
           Format.pp_print_string fmt ")"]
-      | true, [%type: [%t? typ] list]  -> seq "[@[<hov>"   "@]]" [%expr List.fold_left]  typ
-      | true, [%type: [%t? typ] array] -> seq "[|@[<hov>" "@]|]" [%expr Array.fold_left] typ
+      | true, [%type: [%t? typ] list]  -> seq "@[<2>["   "@,]@]" [%expr List.fold_left]  typ
+      | true, [%type: [%t? typ] array] -> seq "@[<2>[|" "@,|]@]" [%expr Array.fold_left] typ
       | true, [%type: [%t? typ] option] ->
         [%expr
           function
@@ -119,6 +120,17 @@ 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] ->
+        [%expr
+          function
+          | Result.Ok ok ->
+            Format.pp_print_string fmt "(Ok ";
+            [%e expr_of_typ ok_t] ok;
+            Format.pp_print_string fmt ")"
+          | Result.Error e ->
+            Format.pp_print_string fmt "(Error ";
+            [%e expr_of_typ err_t] e;
+            Format.pp_print_string fmt ")"]
       | true, ([%type: [%t? typ] lazy_t] | [%type: [%t? typ] Lazy.t]) ->
         [%expr fun x ->
           if Lazy.is_val x then [%e expr_of_typ typ] (Lazy.force x)
@@ -139,7 +151,7 @@ let rec expr_of_typ quoter typ =
       let args = List.mapi (fun i typ -> app (expr_of_typ typ) [evar (argn i)]) typs in
       [%expr
         fun [%p ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)] ->
-        Format.fprintf fmt "(@[<hov>";
+        Format.fprintf fmt "(@[";
         [%e args |> Ppx_deriving.(fold_exprs
                 (seq_reduce ~sep:[%expr Format.fprintf fmt ",@ "]))];
         Format.fprintf fmt "@])"]
@@ -182,12 +194,22 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
         constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } ->
           let constr_name = Ppx_deriving.expand_path ~path name' in
           match attr_printer pcd_attributes, pcd_args with
-          | Some printer, Pcstr_tuple([]) ->
-            Exp.case (pconstr name' [])
-                     [%expr [%e wrap_printer quoter printer] fmt ()]
-          | Some printer, Pcstr_tuple(_) ->
-            Exp.case (pconstr name' [pvar "a"])
-                     [%expr [%e wrap_printer quoter printer] fmt a]
+          | Some printer, Pcstr_tuple(args) ->
+            let rec range from_idx to_idx =
+              if from_idx = to_idx
+              then []
+              else from_idx::(range (from_idx+1) to_idx)
+            in
+            let indices = range 0 (List.length args) in
+            let pattern_vars =
+              List.map (fun i -> pvar ("a" ^ string_of_int i)) indices
+            in
+            let expr_vars =
+              List.map (fun i -> evar ("a" ^ string_of_int i)) indices
+            in
+            Exp.case (pconstr name' pattern_vars)
+              [%expr [%e wrap_printer quoter printer] fmt
+                        [%e tuple expr_vars]]
 #if OCAML_VERSION >= (4, 03, 0)
           | Some printer, Pcstr_record(labels) ->
             let args = labels |> List.map (fun { pld_name = { txt = n } } -> evar (argl n)) in
@@ -202,15 +224,15 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
               | []   -> [%expr Format.pp_print_string fmt [%e str constr_name]]
               | [arg] ->
                 [%expr
-                  Format.fprintf fmt [%e str ("(@[<hov2>" ^  constr_name ^ "@ ")];
+                  Format.fprintf fmt [%e str ("(@[<2>" ^  constr_name ^ "@ ")];
                   [%e arg];
                   Format.fprintf fmt "@])"]
               | args ->
                 [%expr
-                  Format.fprintf fmt [%e str ("@[<hov2>" ^  constr_name ^ " (@,")];
+                  Format.fprintf fmt [%e str ("@[<2>" ^  constr_name ^ " (@,")];
                   [%e args |> Ppx_deriving.(fold_exprs
                         (seq_reduce ~sep:[%expr Format.fprintf fmt ",@ "]))];
-                  Format.fprintf fmt "@])"]
+                  Format.fprintf fmt "@,)@]"]
             in
             Exp.case (pconstr name' (pattn typs)) printer
 #if OCAML_VERSION >= (4, 03, 0)
@@ -218,12 +240,14 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
             let args =
               labels |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
                 [%expr
-                  Format.fprintf fmt [%e str (n ^ " =@ " )];
-                  [%e expr_of_typ quoter typ] [%e evar (argl n)]])
+                  Format.fprintf fmt "@[%s =@ " [%e str n];
+                  [%e expr_of_typ quoter typ] [%e evar (argl n)];
+                  Format.fprintf fmt "@]"
+                ])
             in
             let printer =
               [%expr
-                Format.fprintf fmt [%e str ("@[<hov2>" ^  constr_name ^ " {@,")];
+                Format.fprintf fmt [%e str ("@[<2>" ^  constr_name ^ " {@,")];
                 [%e args |> Ppx_deriving.(fold_exprs
                       (seq_reduce ~sep:[%expr Format.fprintf fmt ";@ "]))];
                 Format.fprintf fmt "@]}"]
@@ -238,14 +262,17 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
         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 pld_type = {pld_type with ptyp_attributes=pld_attributes@pld_type.ptyp_attributes} in
-          [%expr Format.pp_print_string fmt [%e str (field_name ^ " = ")];
-            [%e expr_of_typ quoter pld_type] [%e Exp.field (evar "x") (mknoloc (Lident name))]])
+          [%expr
+            Format.fprintf fmt "@[%s =@ " [%e str field_name];
+            [%e expr_of_typ quoter pld_type] [%e Exp.field (evar "x") (mknoloc (Lident name))];
+            Format.fprintf fmt "@]"
+          ])
       in
       [%expr fun fmt x ->
-        Format.fprintf fmt "{ @[<hov>";
+        Format.fprintf fmt "@[<2>{ ";
         [%e fields |> Ppx_deriving.(fold_exprs
               (seq_reduce ~sep:[%expr Format.fprintf fmt ";@ "]))];
-        Format.fprintf fmt "@] }"]
+        Format.fprintf fmt "@ }@]"]
     | Ptype_abstract, None ->
       raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver
     | Ptype_open, _        ->