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 10, 2021
1 parent 304bdfb commit ce0183a
Show file tree
Hide file tree
Showing 3 changed files with 81 additions and 75 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
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
2 changes: 1 addition & 1 deletion test/extensions_and_deriving/test.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -137,5 +137,5 @@ type t = [%id: int]

[%%expect{|
type t = int
val derived_t : string = "uninterpreted extension in input"
val derived_t : string = "ok"
|}]

0 comments on commit ce0183a

Please sign in to comment.