From d8e41ae2954eb34c509f97a9ee7682e4178bbf6d Mon Sep 17 00:00:00 2001 From: Guillaume Huysmans Date: Sat, 18 Mar 2023 03:08:37 +0100 Subject: [PATCH 1/2] Test [@print] in polymorphic variant definitions --- src_test/show/test_deriving_show.cppo.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src_test/show/test_deriving_show.cppo.ml b/src_test/show/test_deriving_show.cppo.ml index 4a27818..9c89a9d 100644 --- a/src_test/show/test_deriving_show.cppo.ml +++ b/src_test/show/test_deriving_show.cppo.ml @@ -234,6 +234,17 @@ let test_variant_printer ctxt = assert_equal ~printer "fourth: 8 4" (show_variant_printer (Fourth(8,4))) +type polyvar_printer = [ + | `First [@printer fun fmt _ -> Format.pp_print_string fmt "first"] + | `Second of int [@printer fun fmt i -> Format.fprintf fmt "second: %d" i] +] [@@deriving show] + +let test_polyvar_printer ctxt = + assert_equal ~printer + "first" (show_polyvar_printer `First); + assert_equal ~printer + "second: 42" (show_polyvar_printer (`Second 42)); + type no_full = NoFull of int [@@deriving show { with_path = false }] type with_full = WithFull of int [@@deriving show { with_path = true }] module WithFull = struct @@ -265,6 +276,7 @@ let suite = "Test deriving(show)" >::: [ "test_std_shadowing" >:: test_std_shadowing; "test_poly_app" >:: test_poly_app; "test_variant_printer" >:: test_variant_printer; + "test_polyvar_printer" >:: test_polyvar_printer; "test_paths" >:: test_paths_printer; "test_result" >:: test_result; "test_result_result" >:: test_result_result; From 8cc4912ef938f6f220d8372ab73dd2ae0157c912 Mon Sep 17 00:00:00 2001 From: Guillaume Huysmans Date: Sat, 18 Mar 2023 14:51:26 +0100 Subject: [PATCH 2/2] show: handle [@printer] in polymorphic variants --- src_plugins/show/ppx_deriving_show.cppo.ml | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src_plugins/show/ppx_deriving_show.cppo.ml b/src_plugins/show/ppx_deriving_show.cppo.ml index 7b0f574..72cd451 100644 --- a/src_plugins/show/ppx_deriving_show.cppo.ml +++ b/src_plugins/show/ppx_deriving_show.cppo.ml @@ -173,20 +173,31 @@ let rec expr_of_typ quoter typ = | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let cases = fields |> List.map (fun field -> - match field.prf_desc with - | Rtag(label, true (*empty*), []) -> + match attr_printer field.prf_attributes, field.prf_desc with + | None, Rtag(label, true (*empty*), []) -> let label = label.txt in Exp.case (Pat.variant label None) [%expr Ppx_deriving_runtime.Format.pp_print_string fmt [%e str ("`" ^ label)]] - | Rtag(label, false, [typ]) -> + | Some printer, Rtag(label, true (*empty*), []) -> + let label = label.txt in + Exp.case (Pat.variant label None) + [%expr [%e printer] fmt ()] + | None, Rtag(label, false, [typ]) -> let label = label.txt in Exp.case (Pat.variant label (Some [%pat? x])) [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str ("`" ^ label ^ " (@[")]; [%e expr_of_typ typ] x; Ppx_deriving_runtime.Format.fprintf fmt "@])"] - | Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> + | Some printer, Rtag(label, false, [typ]) -> + let label = label.txt in + Exp.case (Pat.variant label (Some [%pat? x])) + [%expr [%e printer] fmt x] + | None, Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e expr_of_typ typ] x] + | Some printer, Rinherit({ ptyp_desc = Ptyp_constr (tname, _) }) -> + Exp.case [%pat? [%p Pat.type_ tname] as x] + [%expr [%e printer] fmt x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ))