From 53adb1388461c96a21b09afaa984359ddcc669cc Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Fri, 10 Sep 2021 14:19:53 +0200 Subject: [PATCH] Expand structure and signature items before applying attribute rules Signed-off-by: Nathan Rebours --- CHANGES.md | 4 + HISTORY.md | 4 + src/context_free.ml | 150 ++++++++++++++------------- test/extensions_and_deriving/test.ml | 11 +- 4 files changed, 90 insertions(+), 79 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 2f7597148..e9b897733 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,10 @@ unreleased ---------- +- Expand nodes before applying derivers or other inline attributes based + transformation, allowing better interactions between extensions and + derivers (#279, @NathanReb) + 0.23.0 (31/08/2021) ------------------- diff --git a/HISTORY.md b/HISTORY.md index 9a837e8ed..75802172e 100644 --- a/HISTORY.md +++ b/HISTORY.md @@ -545,3 +545,7 @@ generates new structure or signature items based on the value of an item with that attribute attached. This rule is applied before the item has been transformed meaning the input of the expander function might contain "wrong" information. +*Note that this behaviour was changed in +[#279](https://github.com/ocaml-ppx/ppxlib/pull/279) and that nodes are now +expanded before derivers and other attributes-based inline code generation rules +are applied* diff --git a/src/context_free.ml b/src/context_free.ml index a30ae57ef..9aeadae8e 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -561,7 +561,6 @@ class map_top_down ?(expect_mismatch_handler=Expect_mismatch_handler.nop) (*$*) method! structure base_ctxt st = let rec with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code = - let item = super#structure_item base_ctxt item in let extra_items = loop (rev_concat extra_items) ~in_generated_code:true in if not in_generated_code then Generated_code_hook.insert_after hook Structure_item item.pstr_loc @@ -599,50 +598,51 @@ class map_top_down ?(expect_mismatch_handler=Expect_mismatch_handler.nop) (Many items); items @ loop rest ~in_generated_code end - - | Pstr_type(rf, tds) -> - let extra_items = - handle_attr_group_inline attr_str_type_decls rf tds ~loc ~base_ctxt - in - let expect_items = - handle_attr_group_inline attr_str_type_decls_expect rf tds ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Pstr_modtype mtd -> - let extra_items = - handle_attr_inline attr_str_module_type_decls mtd ~loc ~base_ctxt - in - let expect_items = - handle_attr_inline attr_str_module_type_decls_expect mtd ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Pstr_typext te -> - let extra_items = handle_attr_inline attr_str_type_exts te ~loc ~base_ctxt in - let expect_items = - handle_attr_inline attr_str_type_exts_expect te ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Pstr_exception ec -> - let extra_items = handle_attr_inline attr_str_exceptions ec ~loc ~base_ctxt in - let expect_items = - handle_attr_inline attr_str_exceptions_expect ec ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - | _ -> - let item = self#structure_item base_ctxt item in - let rest = self#structure base_ctxt rest in - item :: rest + let item = super#structure_item base_ctxt item in + match item.pstr_desc with + | Pstr_type(rf, tds) -> + let extra_items = + handle_attr_group_inline attr_str_type_decls rf tds ~loc ~base_ctxt + in + let expect_items = + handle_attr_group_inline attr_str_type_decls_expect rf tds ~loc ~base_ctxt + in + with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code + + | Pstr_modtype mtd -> + let extra_items = + handle_attr_inline attr_str_module_type_decls mtd ~loc ~base_ctxt + in + let expect_items = + handle_attr_inline attr_str_module_type_decls_expect mtd ~loc ~base_ctxt + in + with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code + + | Pstr_typext te -> + let extra_items = handle_attr_inline attr_str_type_exts te ~loc ~base_ctxt in + let expect_items = + handle_attr_inline attr_str_type_exts_expect te ~loc ~base_ctxt + in + with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code + + | Pstr_exception ec -> + let extra_items = handle_attr_inline attr_str_exceptions ec ~loc ~base_ctxt in + let expect_items = + handle_attr_inline attr_str_exceptions_expect ec ~loc ~base_ctxt + in + with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code + + | _ -> + let item = self#structure_item base_ctxt item in + let rest = self#structure base_ctxt rest in + item :: rest in loop st ~in_generated_code:false (*$ str_to_sig _last_text_block *) method! signature base_ctxt sg = let rec with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code = - let item = super#signature_item base_ctxt item in let extra_items = loop (rev_concat extra_items) ~in_generated_code:true in if not in_generated_code then Generated_code_hook.insert_after hook Signature_item item.psig_loc @@ -680,43 +680,45 @@ class map_top_down ?(expect_mismatch_handler=Expect_mismatch_handler.nop) (Many items); items @ loop rest ~in_generated_code end - - | Psig_type(rf, tds) -> - let extra_items = - handle_attr_group_inline attr_sig_type_decls rf tds ~loc ~base_ctxt - in - let expect_items = - handle_attr_group_inline attr_sig_type_decls_expect rf tds ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Psig_modtype mtd -> - let extra_items = - handle_attr_inline attr_sig_module_type_decls mtd ~loc ~base_ctxt - in - let expect_items = - handle_attr_inline attr_sig_module_type_decls_expect mtd ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Psig_typext te -> - let extra_items = handle_attr_inline attr_sig_type_exts te ~loc ~base_ctxt in - let expect_items = - handle_attr_inline attr_sig_type_exts_expect te ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - - | Psig_exception ec -> - let extra_items = handle_attr_inline attr_sig_exceptions ec ~loc ~base_ctxt in - let expect_items = - handle_attr_inline attr_sig_exceptions_expect ec ~loc ~base_ctxt - in - with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code - | _ -> - let item = self#signature_item base_ctxt item in - let rest = self#signature base_ctxt rest in - item :: rest + let item = super#signature_item base_ctxt item in + match item.psig_desc with + | Psig_type(rf, tds) -> + let extra_items = + handle_attr_group_inline attr_sig_type_decls rf tds ~loc ~base_ctxt + in + let expect_items = + handle_attr_group_inline attr_sig_type_decls_expect rf tds ~loc ~base_ctxt + in + with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code + + | Psig_modtype mtd -> + let extra_items = + handle_attr_inline attr_sig_module_type_decls mtd ~loc ~base_ctxt + in + let expect_items = + handle_attr_inline attr_sig_module_type_decls_expect mtd ~loc ~base_ctxt + in + with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code + + | Psig_typext te -> + let extra_items = handle_attr_inline attr_sig_type_exts te ~loc ~base_ctxt in + let expect_items = + handle_attr_inline attr_sig_type_exts_expect te ~loc ~base_ctxt + in + with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code + + | Psig_exception ec -> + let extra_items = handle_attr_inline attr_sig_exceptions ec ~loc ~base_ctxt in + let expect_items = + handle_attr_inline attr_sig_exceptions_expect ec ~loc ~base_ctxt + in + with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code + + | _ -> + let item = self#signature_item base_ctxt item in + let rest = self#signature base_ctxt rest in + item :: rest in loop sg ~in_generated_code:false diff --git a/test/extensions_and_deriving/test.ml b/test/extensions_and_deriving/test.ml index fd66503ab..391cc728b 100644 --- a/test/extensions_and_deriving/test.ml +++ b/test/extensions_and_deriving/test.ml @@ -128,14 +128,15 @@ let () = Driver.register_transformation ~rules:[id] "id" val id : Context_free.Rule.t = |}] -(* At the time of writing this test, attribute rules are applied before - expanding the node they're attached to. That seems slightly wrong as - it's likely that expander function doesn't expect to find uninterpreted - extensions in its input. *) +(* Nodes with attributes are expanded before attribute-based, inline + code generation rules are applied. + In this below, the `[[%id: int]]` is interpreted before the deriver + is applied, meaning it can't see this extension point in its expand + function argument. *) type t = [%id: int] [@@deriving derived] [%%expect{| type t = int -val derived_t : string = "uninterpreted extension in input" +val derived_t : string = "ok" |}]