New upstream version 4.1

2 files changed, 25 insertions, 20 deletions

diff --git a/src_plugins/ppx_deriving_map.cppo.ml b/src_plugins/ppx_deriving_map.cppo.ml
index 3a696ce..24bc446 100644
--- a/src_plugins/ppx_deriving_map.cppo.ml
+++ b/src_plugins/ppx_deriving_map.cppo.ml
@@ -29,7 +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  constrrec name fields =  constr name [ record                fields]
 
-let rec expr_of_typ typ =
+let rec expr_of_typ ?decl 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]
@@ -37,24 +37,24 @@ let rec expr_of_typ typ =
     let builtin = not (attr_nobuiltin typ.ptyp_attributes) in
     begin match builtin, typ with
     | true, [%type: [%t? typ] list] ->
-      [%expr Ppx_deriving_runtime.List.map [%e expr_of_typ typ]]
+      [%expr Ppx_deriving_runtime.List.map [%e expr_of_typ ?decl typ]]
     | true, [%type: [%t? typ] array] ->
-      [%expr Ppx_deriving_runtime.Array.map [%e expr_of_typ 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 typ] x)]
+      [%expr function None -> None | Some x -> Some ([%e expr_of_typ ?decl 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)]
+        | Result.Ok ok -> Result.Ok ([%e expr_of_typ ?decl ok_t] ok)
+        | Result.Error err -> Result.Error ([%e expr_of_typ ?decl 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)
+          (List.map (expr_of_typ ?decl) args)
     | _ -> assert false
     end
   | { ptyp_desc = Ptyp_tuple typs } ->
     [%expr fun [%p ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)] ->
-      [%e tuple (List.mapi (fun i typ -> app (expr_of_typ typ) [evar (argn i)]) typs)]];
+      [%e tuple (List.mapi (fun i typ -> app (expr_of_typ ?decl typ) [evar (argn i)]) typs)]];
   | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } ->
     let cases =
       fields |> List.map (fun field ->
@@ -63,10 +63,15 @@ let rec expr_of_typ typ =
           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 typ] x]))
-        | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
-          Exp.case [%pat? [%p Pat.type_ tname] as x]
-                   [%expr [%e expr_of_typ typ] 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 -> 
+            raise_errorf "inheritance of polymorphic variants not supported"
+          | Some(d) ->
+            Exp.case [%pat? [%p Pat.type_ tname] as x]
+                     [%expr ([%e expr_of_typ ?decl typ] x :> [%t Ppx_deriving.core_type_of_type_decl d])]
+          end
         | _ ->
           raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                        deriver (Ppx_deriving.string_of_core_type typ))
@@ -74,7 +79,7 @@ let rec expr_of_typ typ =
     Exp.function_ cases
   | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name)
   | { ptyp_desc = Ptyp_alias (typ, name) } ->
-    [%expr fun x -> [%e evar ("poly_"^name)] ([%e expr_of_typ typ] x)]
+    [%expr fun x -> [%e evar ("poly_"^name)] ([%e expr_of_typ ?decl typ] x)]
   | { ptyp_loc } ->
     raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                  deriver (Ppx_deriving.string_of_core_type typ)
@@ -83,19 +88,19 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
   parse_options options;
   let mapper =
     match type_decl.ptype_kind, type_decl.ptype_manifest with
-    | Ptype_abstract, Some manifest -> expr_of_typ manifest
+    | Ptype_abstract, Some manifest -> expr_of_typ ~decl:type_decl manifest
     | Ptype_variant constrs, _ ->
       constrs |>
       List.map (fun { pcd_name = { txt = name' }; pcd_args } ->
         match pcd_args with
         | Pcstr_tuple(typs) ->
-          let args = List.mapi (fun i typ -> app (expr_of_typ typ) [evar (argn i)]) typs in
+          let args = List.mapi (fun i typ -> app (expr_of_typ ~decl:type_decl typ) [evar (argn i)]) typs in
           Exp.case (pconstr name' (pattn typs))
                    (constr name' args)
 #if OCAML_VERSION >= (4, 03, 0)
         | Pcstr_record(labels) ->
           let args = labels |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
-                        n, [%expr [%e expr_of_typ typ] [%e evar (argl n)]]) in
+                        n, [%expr [%e expr_of_typ ~decl:type_decl typ] [%e evar (argl n)]]) in
           Exp.case (pconstrrec name' (pattl labels))
                    (constrrec name' args)
 #endif
@@ -104,7 +109,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 } ->
-          name, [%expr [%e expr_of_typ pld_type]
+          name, [%expr [%e expr_of_typ ~decl:type_decl pld_type]
                        [%e Exp.field (evar "x") (mknoloc (Lident name))]])
       in
       [%expr fun x -> [%e record fields]]
@@ -129,7 +134,7 @@ let sig_of_type ~options ~path type_decl =
 
 let () =
   Ppx_deriving.(register (create deriver
-    ~core_type: expr_of_typ
+    ~core_type: (expr_of_typ ?decl:None)
     ~type_decl_str: (fun ~options ~path type_decls ->
       [Str.value Recursive (List.concat (List.map (str_of_type ~options ~path) type_decls))])
     ~type_decl_sig: (fun ~options ~path type_decls ->
diff --git a/src_plugins/ppx_deriving_show.cppo.ml b/src_plugins/ppx_deriving_show.cppo.ml
index 55925cc..17642b9 100644
--- a/src_plugins/ppx_deriving_show.cppo.ml
+++ b/src_plugins/ppx_deriving_show.cppo.ml
@@ -229,10 +229,10 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
                   Format.fprintf fmt "@])"]
               | args ->
                 [%expr
-                  Format.fprintf fmt [%e str ("@[<2>" ^  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)