From 654496a5ca2d11f80f5f86cc4ecda6293f81fa83 Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Thu, 25 Jul 2019 19:46:11 +0100 Subject: [PATCH 1/2] do not produce a suprious empty correction when deriving_inline expands into an extension that undergoes further expansion Signed-off-by: Arseniy Alekseyev --- src/context_free.ml | 3 +- test/deriving/inline/example/dune | 5 ++ .../inline/example/ppx_deriving_example.ml | 2 + test/deriving/inline/foo-deriver/dune | 5 ++ .../inline/foo-deriver/ppx_foo_deriver.ml | 69 +++++++++++++++++++ 5 files changed, 83 insertions(+), 1 deletion(-) create mode 100644 test/deriving/inline/example/dune create mode 100644 test/deriving/inline/example/ppx_deriving_example.ml create mode 100644 test/deriving/inline/foo-deriver/dune create mode 100644 test/deriving/inline/foo-deriver/ppx_foo_deriver.ml diff --git a/src/context_free.ml b/src/context_free.ml index 0c35258e5..ce930e60e 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -527,13 +527,14 @@ class map_top_down ?(expect_mismatch_handler=Expect_mismatch_handler.nop) if not in_generated_code then Generated_code_hook.insert_after hook Structure_item item.pstr_loc (Many extra_items); + let original_rest = rest in let rest = loop rest ~in_generated_code in (match expect_items with | [] -> () | _ -> let expected = rev_concat expect_items in let pos = item.pstr_loc.loc_end in - Code_matcher.match_structure rest ~pos ~expected + Code_matcher.match_structure original_rest ~pos ~expected ~mismatch_handler:(fun loc repl -> expect_mismatch_handler.f Structure_item loc repl)); item :: (extra_items @ rest) diff --git a/test/deriving/inline/example/dune b/test/deriving/inline/example/dune new file mode 100644 index 000000000..ffc44d327 --- /dev/null +++ b/test/deriving/inline/example/dune @@ -0,0 +1,5 @@ +(library + (name ppx_deriving_example) + (inline_tests) + (preprocess (pps ppxlib ppx_foo_deriver ppxlib.runner)) +) diff --git a/test/deriving/inline/example/ppx_deriving_example.ml b/test/deriving/inline/example/ppx_deriving_example.ml new file mode 100644 index 000000000..1427aad58 --- /dev/null +++ b/test/deriving/inline/example/ppx_deriving_example.ml @@ -0,0 +1,2 @@ +type t = A [@@deriving_inline foo, foo] +[@@@deriving.end] diff --git a/test/deriving/inline/foo-deriver/dune b/test/deriving/inline/foo-deriver/dune new file mode 100644 index 000000000..11928404d --- /dev/null +++ b/test/deriving/inline/foo-deriver/dune @@ -0,0 +1,5 @@ +(library + (kind ppx_deriver) + (name ppx_foo_deriver) + (libraries base ppxlib) +) diff --git a/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml b/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml new file mode 100644 index 000000000..1f02c9240 --- /dev/null +++ b/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml @@ -0,0 +1,69 @@ +open Ppxlib + +(* + [[@@deriving foo]] expands to: + {[ + let _ = [%foo] + ]} + + and then [[%foo]] expands to ["foo"]. +*) + +let add_deriver () = + let str_type_decl = + Deriving.Generator.make_noarg ( + fun ~loc ~path:_ _ -> + let expr desc : expression= + { pexp_desc = desc; + pexp_loc = loc; + pexp_attributes = []; + } + in + [ + {pstr_loc = loc; + pstr_desc = + (Pstr_value (Nonrecursive, [{ + pvb_pat = + { ppat_desc = Ppat_any; + ppat_loc = loc; + ppat_attributes = []; + } + ; + pvb_expr = expr ( + Pexp_extension ({loc; txt = "foo"}, PStr [])); + pvb_attributes = []; + pvb_loc = loc; + }])); + } + ] + ) + ~attributes:[] + in + let sig_type_decl = + Deriving.Generator.make_noarg ( + fun ~loc ~path decl -> + ignore loc; + ignore path; + ignore decl; + [ + ] + ) + in + Deriving.add "foo" + ~str_type_decl + ~sig_type_decl + +let () = + Driver.register_transformation "foo" + ~rules:[ + Context_free.Rule.extension + (Extension.declare "foo" + Expression Ast_pattern.__ + (fun ~loc ~path:_ _payload -> + { pexp_desc = Pexp_constant (Pconst_string ("foo", None)); + pexp_loc = loc; + pexp_attributes = []; + })) + ] + +let (_ : Deriving.t) = add_deriver () From 1f8fcfc731739a9c2c0fb1dd04674ba11f24dfd4 Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Mon, 29 Jul 2019 12:14:56 +0100 Subject: [PATCH 2/2] fixes Signed-off-by: Arseniy Alekseyev --- src/context_free.ml | 3 ++- src/dune | 4 +++- test/deriving/inline/example/dune | 6 +++++- test/deriving/inline/example/ppx_deriving_example.ml | 4 +++- 4 files changed, 13 insertions(+), 4 deletions(-) diff --git a/src/context_free.ml b/src/context_free.ml index ce930e60e..5d28a7fbe 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -599,13 +599,14 @@ class map_top_down ?(expect_mismatch_handler=Expect_mismatch_handler.nop) if not in_generated_code then Generated_code_hook.insert_after hook Signature_item item.psig_loc (Many extra_items); + let original_rest = rest in let rest = loop rest ~in_generated_code in (match expect_items with | [] -> () | _ -> let expected = rev_concat expect_items in let pos = item.psig_loc.loc_end in - Code_matcher.match_signature rest ~pos ~expected + Code_matcher.match_signature original_rest ~pos ~expected ~mismatch_handler:(fun loc repl -> expect_mismatch_handler.f Signature_item loc repl)); item :: (extra_items @ rest) diff --git a/src/dune b/src/dune index 4fd21af66..0608caac9 100644 --- a/src/dune +++ b/src/dune @@ -40,7 +40,9 @@ (action (progn (run %{bin:cinaps} -no-color -diff-cmd - %{ml} %{mli}) (diff? code_matcher.ml code_matcher.ml.cinaps-corrected) - (diff? driver.ml driver.ml.cinaps-corrected)))) + (diff? driver.ml driver.ml.cinaps-corrected) + (diff? context_free.ml context_free.ml.cinaps-corrected) + ))) ;; This is to make the code compatible with different versions of ;; OCaml diff --git a/test/deriving/inline/example/dune b/test/deriving/inline/example/dune index ffc44d327..dd0aeac91 100644 --- a/test/deriving/inline/example/dune +++ b/test/deriving/inline/example/dune @@ -1,5 +1,9 @@ (library (name ppx_deriving_example) - (inline_tests) (preprocess (pps ppxlib ppx_foo_deriver ppxlib.runner)) ) + +(alias + (name runtest) + (deps ppx_deriving_example.cma) + ) diff --git a/test/deriving/inline/example/ppx_deriving_example.ml b/test/deriving/inline/example/ppx_deriving_example.ml index 1427aad58..bbd561054 100644 --- a/test/deriving/inline/example/ppx_deriving_example.ml +++ b/test/deriving/inline/example/ppx_deriving_example.ml @@ -1,2 +1,4 @@ -type t = A [@@deriving_inline foo, foo] +type t = A [@@deriving_inline foo] +let _ = fun (_ : t) -> () +let _ = [%foo ] [@@@deriving.end]