Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Add show @printer support for polymorphic variants #286

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Add show @printer support for polymorphic variants #286

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
4da03cd
Add test for show polymorphic variant @printer
sim642 Jun 1, 2024
b40f911
Add show @printer support for polymorphic variants
sim642 Jun 1, 2024
fc7e50d
Add PR #286 to CHANGELOG
sim642 Jun 2, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
7 changes: 7 additions & 0 deletions CHANGELOG.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,3 +1,10 @@
unreleased
----------

* Add show @printer support for polymorphic variants
#286
(Simmo Saan and Guillaume Huysmans)

6.0.2
-----

Expand Down
19 changes: 14 additions & 5 deletions src_plugins/show/ppx_deriving_show.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,6 +23,7 @@ let attr_printer context = Attribute.declare "deriving.show.printer" context
Ast_pattern.(single_expr_payload __) (fun e -> e)
let ct_attr_printer = attr_printer Attribute.Context.core_type
let constr_attr_printer = attr_printer Attribute.Context.constructor_declaration
let rtag_attr_printer = attr_printer Attribute.Context.rtag
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I was lost for a while as to what rtag means. The answer is that this obscure name comes from the parsetree, and it means "a constructor declaration in a polymorphic variant type" (r means row and tag is supposed to suggest constructor, I guess). The other PR #267 uses attr_printer field.prf_attributes directly, and I suppose that usig the ppxlib mechanism as in here is better.


let ct_attr_polyprinter = Attribute.declare "deriving.show.polyprinter" Attribute.Context.core_type
Ast_pattern.(single_expr_payload __) (fun e -> e)
Expand Down Expand Up @@ -160,21 +161,29 @@ 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 Attribute.get rtag_attr_printer field, field.prf_desc with
| Some printer, Rtag(label, true (*empty*), []) ->
let label = label.txt in
Exp.case (Pat.variant label None)
[%expr [%e wrap_printer quoter printer] fmt ()]
| 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, false, [typ]) ->
let label = label.txt in
Exp.case (Pat.variant label (Some [%pat? x]))
[%expr [%e wrap_printer quoter printer] fmt x]
| 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 ^ " (@[<hov>")];
[%e expr_of_typ typ] x;
Ppx_deriving_runtime.Format.fprintf fmt "@])"]
| Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
| _, Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
Exp.case [%pat? [%p Pat.type_ tname] as x]
[%expr [%e expr_of_typ typ] x]
| _ ->
| _, _ ->
raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
deriver (Ppx_deriving.string_of_core_type typ))
in
Expand Down
20 changes: 20 additions & 0 deletions src_test/show/test_deriving_show.cppo.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -233,6 +233,25 @@ let test_variant_printer ctxt =
assert_equal ~printer
"fourth: 8 4" (show_variant_printer (Fourth(8,4)))

type poly_variant_printer = [
| `First [@printer fun fmt _ -> Format.pp_print_string fmt "first"]
| `Second of int [@printer fun fmt i -> fprintf fmt "second: %d" i]
| `Third
| `Fourth of int * int
[@printer fun fmt (a,b) -> fprintf fmt "fourth: %d %d" a b]
]
[@@deriving show]

let test_poly_variant_printer ctxt =
assert_equal ~printer
"first" (show_poly_variant_printer `First);
assert_equal ~printer
"second: 42" (show_poly_variant_printer (`Second 42));
assert_equal ~printer
"`Third" (show_poly_variant_printer `Third);
assert_equal ~printer
"fourth: 8 4" (show_poly_variant_printer (`Fourth(8,4)))

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
Expand Down Expand Up @@ -264,6 +283,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_poly_variant_printer" >:: test_poly_variant_printer;
"test_paths" >:: test_paths_printer;
"test_result" >:: test_result;
"test_result_result" >:: test_result_result;
Expand Down