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 2046d0fdc..5676c8da1 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -550,7 +550,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 @@ -592,52 +591,54 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) Generated_code_hook.replace hook Structure_item item.pstr_loc (Many items); items @ loop rest ~in_generated_code) - | 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 rest = self#structure base_ctxt rest in + item :: rest)) in loop st ~in_generated_code:false @@ -645,7 +646,6 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) 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 @@ -687,52 +687,54 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) Generated_code_hook.replace hook Signature_item item.psig_loc (Many items); items @ loop rest ~in_generated_code) - | 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 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" |}]