From 7bf7583bb784342d417b0d27131c925a31a8ef17 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Sat, 6 Jul 2019 10:03:15 +0200 Subject: [PATCH] Fix handling of attributes of record fields in inline records fixes #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. --- src_plugins/eq/ppx_deriving_eq.cppo.ml | 17 +++++++++++------ src_plugins/fold/ppx_deriving_fold.cppo.ml | 13 +++++++++---- src_plugins/iter/ppx_deriving_iter.cppo.ml | 13 +++++++++---- src_plugins/map/ppx_deriving_map.cppo.ml | 13 +++++++++---- src_plugins/ord/ppx_deriving_ord.cppo.ml | 16 ++++++++++------ src_plugins/show/ppx_deriving_show.cppo.ml | 15 ++++++++++----- src_test/show/test_deriving_show.cppo.ml | 11 +++++++++++ 7 files changed, 69 insertions(+), 29 deletions(-) diff --git a/src_plugins/eq/ppx_deriving_eq.cppo.ml b/src_plugins/eq/ppx_deriving_eq.cppo.ml index feb2128a..3646c018 100644 --- 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 index d5b5ad0a..a20c51bd 100644 --- 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 index c1c666f1..a6ec2734 100644 --- 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,8 +109,8 @@ 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 @@ -114,8 +118,9 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = 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 index 903fcbb8..c35f5c58 100644 --- 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,8 +116,9 @@ 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 @@ -121,8 +126,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = 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 index 6339234e..89998ee3 100644 --- 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 index 21986311..9e762241 100644 --- 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 index a8cf4b99..093ce0f9 100644 --- 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 = }" (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 = }" + (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;