Add characterization tests for context-free rule application order

Signed-off-by: Nathan Rebours <nathan.p.rebours@gmail.com>

HISTORY.md

@@ -518,3 +518,30 @@ let expression_of_t ~loc t : Ast.expression =
   end in
   lift#t t
 ```
+
+Context-free rules
+------------------
+
+Ppxlib expresses most transformation as context-free rules. Each of these rules
+describe how specific AST nodes (extensions points, nodes with particular
+attributes attached, numeric literals with specific suffixes, etc...) must be
+transformed.
+
+All those transformation rules are applied in a single AST traversal. They are
+also recursively applied to code generated by such rules until they don't apply
+anymore.
+
+It happens that different rules might apply to the same nodes and an order must
+be picked. In an effort to document how ppxlib deals with such nodes, I wrote
+characterization tests, that you can find
+[here](test/extensions_and_deriving/test.ml). Some of those test behaviour that
+we believe we should preserve, some act more as documentation of what the
+current behaviour is.
+
+The most debatable behaviour is how it handles attributes based rules. ppxlib
+allows one to generate new code based on a node with specific attributes
+attached. The most common such rule is the `[@@deriving ...]` one which
+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.

test/extensions_and_deriving/dune

@@ -0,0 +1,13 @@
+(rule
+ (alias runtest)
+ (enabled_if
+  (>= %{ocaml_version} "4.10.0"))
+ (deps
+  (:test test.ml)
+  (package ppxlib))
+ (action
+  (chdir
+   %{project_root}
+   (progn
+    (run expect-test %{test})
+    (diff? %{test} %{test}.corrected)))))

test/extensions_and_deriving/test.ml

@@ -0,0 +1,141 @@
+open Ppxlib
+
+(* Generates a [let derived_<type_name> = "ok"] or a
+   [let derived_<type_name> = "uninterpreted extension in input"] if
+   the type manifest is an uninterpreted extension. *)
+let deriver =
+  let binding ~loc type_name expr =
+    let var_name = "derived_" ^ type_name in
+    let pat = Ast_builder.Default.ppat_var ~loc {txt = var_name; loc} in
+    let vb = Ast_builder.Default.value_binding ~loc ~pat ~expr in
+    [Ast_builder.Default.pstr_value ~loc Nonrecursive [vb]]
+  in
+  let str_type_decl =
+    Deriving.Generator.V2.make_noarg
+      (fun ~ctxt (_rec_flag, type_decls) ->
+         let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+         match type_decls with
+         | { ptype_manifest = Some {ptyp_desc = Ptyp_extension _; _}
+           ; ptype_name = {txt; _}; _}::_ ->
+           binding ~loc txt [%expr "uninterpreted extension in input"]
+         | {ptype_name = {txt; _}; _}::_ ->
+           binding ~loc txt [%expr "ok"]
+         | [] -> assert false)
+  in
+  Deriving.add ~str_type_decl "derived"
+
+[%%expect{|
+val deriver : Deriving.t = <abstr>
+|}]
+
+(* Generates a [type t = int] *)
+let gen_type_decl =
+  Extension.V3.declare
+    "gen_type_decl"
+    Extension.Context.structure_item
+    Ast_pattern.(pstr nil)
+    (fun ~ctxt ->
+       let loc = Expansion_context.Extension.extension_point_loc ctxt in
+       [%stri type t = int])
+  |> Context_free.Rule.extension
+
+let () = Driver.register_transformation ~rules:[gen_type_decl] "gen_type_decl"
+
+[%%expect{|
+val gen_type_decl : Context_free.Rule.t = <abstr>
+|}]
+
+(* You cannot attach attributes to structure item extension points *)
+[%%gen_type_decl]
+[@@deriving derived]
+
+[%%expect{|
+Line _, characters 3-19:
+Error: Attributes not allowed here
+|}]
+
+(* Generates a [type t = int[@@deriving derived]] *)
+let gen_type_decl_with_derived =
+  Extension.V3.declare
+    "gen_type_decl_with_derived"
+    Extension.Context.structure_item
+    Ast_pattern.(pstr nil)
+    (fun ~ctxt ->
+       let loc = Expansion_context.Extension.extension_point_loc ctxt in
+       [%stri type t = int[@@deriving derived]])
+  |> Context_free.Rule.extension
+
+let () =
+  Driver.register_transformation
+    ~rules:[gen_type_decl_with_derived]
+    "gen_type_decl_with_derived"
+
+[%%expect{|
+val gen_type_decl_with_derived : Context_free.Rule.t = <abstr>
+|}]
+
+(* Attributes rule must be applied in code generated by a structure item
+   extension *)
+[%%gen_type_decl_with_derived]
+
+[%%expect{|
+type t = int
+val derived_t : string = "ok"
+|}]
+
+let gen_inline_type_decls_with_derived =
+  Extension.V3.declare_inline
+    "gen_inline_type_decls_with_derived"
+    Extension.Context.structure_item
+    Ast_pattern.(pstr nil)
+    (fun ~ctxt ->
+       let loc = Expansion_context.Extension.extension_point_loc ctxt in
+       [%str
+         type t = int[@@deriving derived]
+         type u = float[@@deriving derived]])
+  |> Context_free.Rule.extension
+
+let () =
+  Driver.register_transformation
+    ~rules:[gen_inline_type_decls_with_derived]
+    "gen_inline_type_decls_with_derived"
+
+[%%expect{|
+val gen_inline_type_decls_with_derived : Context_free.Rule.t = <abstr>
+|}]
+
+(* That also stands for inline extension rules *)
+[%%gen_inline_type_decls_with_derived]
+
+[%%expect{|
+type t = int
+val derived_t : string = "ok"
+type u = float
+val derived_u : string = "ok"
+|}]
+
+let id =
+  Extension.V3.declare
+    "id"
+    Extension.Context.core_type
+    Ast_pattern.(ptyp __)
+    (fun ~ctxt:_ core_type -> core_type)
+  |> Context_free.Rule.extension
+
+let () = Driver.register_transformation ~rules:[id] "id"
+
+[%%expect{|
+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. *)
+type t = [%id: int]
+[@@deriving derived]
+
+[%%expect{|
+type t = int
+val derived_t : string = "uninterpreted extension in input"
+|}]