Fix handling of attributes of record fields in inline records

fixes ocaml-ppx#194 This bug is likely to also affect out-of-tree plugins, which should probably be notified -- attribute propagation is currently not centralized and has to be done by each plugin.
gasche · Jul 6, 2019 · 7bf7583 · 7bf7583
1 parent 403d384
commit 7bf7583
Show file tree

Hide file tree

Showing 7 changed files with 69 additions and 29 deletions.
diff --git a/src_plugins/eq/ppx_deriving_eq.cppo.ml b/src_plugins/eq/ppx_deriving_eq.cppo.ml
@@ -54,8 +54,14 @@ let rec exprn quoter typs =
     app (expr_of_typ quoter typ) [evar (argn `lhs i); evar (argn `rhs i)])
 
 and exprl quoter typs =
-  typs |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
-    app (expr_of_typ quoter typ) [evar (argl `lhs n); evar (argl `rhs n)])
+  typs |> List.map (fun ({ pld_name = { txt = n }; pld_loc; _ } as pld) ->
+    with_default_loc pld_loc @@ fun () ->
+    app (expr_of_label_decl quoter pld)
+      [evar (argl `lhs n); evar (argl `rhs n)])
+
+and expr_of_label_decl quoter { pld_type; pld_attributes } =
+  let attrs = pld_type.ptyp_attributes @ pld_attributes in
+  expr_of_typ quoter { pld_type with ptyp_attributes = attrs }
 
 and expr_of_typ quoter typ =
   let typ = Ppx_deriving.remove_pervasives ~deriver typ in
@@ -176,13 +182,12 @@ 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; pld_loc } ->
+        labels |> List.map (fun ({ pld_loc; pld_name = { txt = name }; _ } as pld) ->
           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
           let field obj = Exp.field obj (mknoloc (Lident name)) in
-          app (expr_of_typ quoter pld_type) [field (evar "lhs"); field (evar "rhs")])
+          app (expr_of_label_decl quoter pld)
+            [field (evar "lhs"); field (evar "rhs")])
       in
       [%expr fun lhs rhs -> [%e exprs |> Ppx_deriving.(fold_exprs (binop_reduce [%expr (&&)]))]]
     | Ptype_abstract, None ->

diff --git a/src_plugins/fold/ppx_deriving_fold.cppo.ml b/src_plugins/fold/ppx_deriving_fold.cppo.ml
@@ -89,6 +89,10 @@ let rec expr_of_typ typ =
     raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                  deriver (Ppx_deriving.string_of_core_type typ)
 
+and expr_of_label_decl { pld_type; pld_attributes } =
+  let attrs = pld_type.ptyp_attributes @ pld_attributes in
+  expr_of_typ { pld_type with ptyp_attributes = attrs }
+
 let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
   parse_options options;
   let mapper =
@@ -104,8 +108,9 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
                    Ppx_deriving.(fold_exprs ~unit:[%expr acc] reduce_acc args)
 #if OCAML_VERSION >= (4, 03, 0)
         | Pcstr_record(labels) ->
-          let args = labels |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
-                        [%expr [%e expr_of_typ typ] acc [%e evar (argl n)]]) in
+          let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) ->
+                        [%expr [%e expr_of_label_decl pld]
+                            acc [%e evar (argl n)]]) in
           Exp.case (pconstrrec name' (pattl labels))
                    Ppx_deriving.(fold_exprs ~unit:[%expr acc] reduce_acc args)
 #endif
@@ -114,8 +119,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       [%expr fun acc -> [%e Exp.function_ cases]]
     | Ptype_record labels, _ ->
       let fields =
-        labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type } ->
-          [%expr [%e expr_of_typ pld_type] acc
+        labels |> List.mapi (fun i ({ pld_name = { txt = name }; _ } as pld) ->
+          [%expr [%e expr_of_label_decl pld] acc
                  [%e Exp.field (evar "x") (mknoloc (Lident name))]])
       in
       [%expr fun acc x -> [%e Ppx_deriving.(fold_exprs ~unit:[%expr acc] reduce_acc fields)]]

diff --git a/src_plugins/iter/ppx_deriving_iter.cppo.ml b/src_plugins/iter/ppx_deriving_iter.cppo.ml
@@ -86,6 +86,10 @@ let rec expr_of_typ typ =
     raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                  deriver (Ppx_deriving.string_of_core_type typ)
 
+and expr_of_label_decl { pld_type; pld_attributes } =
+  let attrs = pld_type.ptyp_attributes @ pld_attributes in
+  expr_of_typ { pld_type with ptyp_attributes = attrs }
+
 let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
   parse_options options;
   let iterator =
@@ -105,17 +109,18 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
           Exp.case (pconstr name' (pattn typs)) result
 #if OCAML_VERSION >= (4, 03, 0)
         | Pcstr_record(labels) ->
-          let args = labels |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
-                        [%expr [%e expr_of_typ typ] [%e evar (argl n)]]) in
+          let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) ->
+                        [%expr [%e expr_of_label_decl pld] [%e evar (argl n)]]) in
           Exp.case (pconstrrec name' (pattl labels))
                    (Ppx_deriving.(fold_exprs seq_reduce) args)
 #endif
         ) |>
       Exp.function_
     | Ptype_record labels, _ ->
       let fields =
-        labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type } ->
-          [%expr [%e expr_of_typ pld_type] [%e Exp.field (evar "x") (mknoloc (Lident name))]])
+        labels |> List.mapi (fun i ({ pld_name = { txt = name }; _ } as pld) ->
+          [%expr [%e expr_of_label_decl pld]
+              [%e Exp.field (evar "x") (mknoloc (Lident name))]])
       in
       [%expr fun x -> [%e Ppx_deriving.(fold_exprs seq_reduce) fields]]
     | Ptype_abstract, None ->

diff --git a/src_plugins/map/ppx_deriving_map.cppo.ml b/src_plugins/map/ppx_deriving_map.cppo.ml
@@ -97,6 +97,10 @@ let rec expr_of_typ ?decl typ =
     raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                  deriver (Ppx_deriving.string_of_core_type typ)
 
+and expr_of_label_decl ?decl { pld_type; pld_attributes } =
+  let attrs = pld_type.ptyp_attributes @ pld_attributes in
+  expr_of_typ ?decl { pld_type with ptyp_attributes = attrs }
+
 let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
   parse_options options;
   let mapper =
@@ -112,17 +116,18 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
                    (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 ~decl:type_decl typ] [%e evar (argl n)]]) in
+          let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) ->
+                        n, [%expr [%e expr_of_label_decl ~decl:type_decl pld]
+                               [%e evar (argl n)]]) in
           Exp.case (pconstrrec name' (pattl labels))
                    (constrrec name' args)
 #endif
         ) |>
       Exp.function_
     | Ptype_record labels, _ ->
       let fields =
-        labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type } ->
-          name, [%expr [%e expr_of_typ ~decl:type_decl pld_type]
+        labels |> List.mapi (fun i ({ pld_name = { txt = name }; _ } as pld) ->
+          name, [%expr [%e expr_of_label_decl ~decl:type_decl pld]
                        [%e Exp.field (evar "x") (mknoloc (Lident name))]])
       in
       let annot_typ = Ppx_deriving.core_type_of_type_decl type_decl in

diff --git a/src_plugins/ord/ppx_deriving_ord.cppo.ml b/src_plugins/ord/ppx_deriving_ord.cppo.ml
@@ -54,8 +54,13 @@ let rec exprn quoter typs =
     app (expr_of_typ quoter typ) [evar (argn `lhs i); evar (argn `rhs i)])
 
 and exprl quoter typs =
-  typs |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
-    app (expr_of_typ quoter typ) [evar (argl `lhs n); evar (argl `rhs n)])
+  typs |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) ->
+    app (expr_of_label_decl quoter pld)
+      [evar (argl `lhs n); evar (argl `rhs n)])
+
+and expr_of_label_decl quoter { pld_type; pld_attributes } =
+  let attrs = pld_type.ptyp_attributes @ pld_attributes in
+  expr_of_typ quoter { pld_type with ptyp_attributes = attrs }
 
 and expr_of_typ quoter typ =
   let expr_of_typ = expr_of_typ quoter in
@@ -211,11 +216,10 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
         [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case int_cases])]]
     | Ptype_record labels, _ ->
       let exprs =
-        labels |> List.map (fun { pld_name = { txt = name }; pld_type; pld_attributes } ->
-          let attrs = pld_attributes @ pld_type.ptyp_attributes in
-          let pld_type = {pld_type with ptyp_attributes=attrs} in
+        labels |> List.map (fun ({ pld_name = { txt = name }; _ } as pld) ->
           let field obj = Exp.field obj (mknoloc (Lident name)) in
-          app (expr_of_typ quoter pld_type) [field (evar "lhs"); field (evar "rhs")])
+          app (expr_of_label_decl quoter pld)
+            [field (evar "lhs"); field (evar "rhs")])
       in
       [%expr fun lhs rhs -> [%e reduce_compare exprs]]
     | Ptype_abstract, None ->

diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml
@@ -201,6 +201,10 @@ let rec expr_of_typ quoter typ =
       raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                    deriver (Ppx_deriving.string_of_core_type typ)
 
+and expr_of_label_decl quoter { pld_type; pld_attributes } =
+  let attrs = pld_type.ptyp_attributes @ pld_attributes in
+  expr_of_typ quoter { pld_type with ptyp_attributes = attrs }
+
 let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
   let show_opts = parse_options options in
   let quoter = Ppx_deriving.create_quoter () in
@@ -261,10 +265,11 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
 #if OCAML_VERSION >= (4, 03, 0)
           | None, Pcstr_record(labels) ->
             let args =
-              labels |> List.map (fun { pld_name = { txt = n }; pld_type = typ } ->
+              labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) ->
                 [%expr
                   Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str n];
-                  [%e expr_of_typ quoter typ] [%e evar (argl n)];
+                  [%e expr_of_label_decl quoter pld]
+                    [%e evar (argl n)];
                   Ppx_deriving_runtime.Format.fprintf fmt "@]"
                 ])
             in
@@ -282,12 +287,12 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
       [%expr fun fmt -> [%e Exp.function_ cases]]
     | Ptype_record labels, _ ->
       let fields =
-        labels |> List.mapi (fun i { pld_name = { txt = name }; pld_type; pld_attributes } ->
+        labels |> List.mapi (fun i ({ pld_name = { txt = name }; _} as pld) ->
           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
             Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str field_name];
-            [%e expr_of_typ quoter pld_type] [%e Exp.field (evar "x") (mknoloc (Lident name))];
+            [%e expr_of_label_decl quoter pld]
+              [%e Exp.field (evar "x") (mknoloc (Lident name))];
             Ppx_deriving_runtime.Format.fprintf fmt "@]"
           ])
       in

diff --git a/src_test/show/test_deriving_show.cppo.ml b/src_test/show/test_deriving_show.cppo.ml
@@ -85,6 +85,16 @@ let test_record ctxt =
   assert_equal ~printer "{ Test_deriving_show.f1 = 1; f2 = \"foo\"; f3 = <opaque> }"
                         (show_re { f1 = 1; f2 = "foo"; f3 = 1.0 })
 
+type variant = Foo of {
+  f1 : int;
+  f2 : string;
+  f3 : float [@opaque];
+} [@@deriving show]
+let test_variant_record ctxt =
+  assert_equal ~printer
+    "Test_deriving_show.Foo {f1 = 1; f2 = \"foo\"; f3 = <opaque>}"
+    (show_variant (Foo { f1 = 1; f2 = "foo"; f3 = 1.0 }))
+
 
 module M : sig
   type t = A [@@deriving show]
@@ -247,6 +257,7 @@ let suite = "Test deriving(show)" >::: [
     "test_poly"            >:: test_poly;
     "test_poly_inherit"    >:: test_poly_inherit;
     "test_record"          >:: test_record;
+    "test_variant_record"  >:: test_variant_record;
     "test_abstr"           >:: test_abstr;
     "test_custom"          >:: test_custom;
     "test_parametric"      >:: test_parametric;