Skip to content

Commit

Permalink
Expand structure and signature items before applying attribute rules
Browse files Browse the repository at this point in the history 
Signed-off-by: Nathan Rebours <nathan.p.rebours@gmail.com>
  • Loading branch information
@NathanReb
NathanReb committed Sep 13, 2021
1 parent 304bdfb commit 53adb13
Show file tree
Hide file tree
Showing 4 changed files with 90 additions and 79 deletions.
4 changes: 4 additions & 0 deletions CHANGES.md
View file
Original file line number Diff line number Diff line change
@@ -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)
-------------------

Expand Down
4 changes: 4 additions & 0 deletions HISTORY.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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*
150 changes: 76 additions & 74 deletions src/context_free.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down
11 changes: 6 additions & 5 deletions test/extensions_and_deriving/test.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -128,14 +128,15 @@ let () = Driver.register_transformation ~rules:[id] "id"
val id : Context_free.Rule.t = <abstr>
|}]

(* 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"
|}]

0 comments on commit 53adb13

Please sign in to comment.