unikernel/duniverse/ppxlib/test/recursive_replacement/driver.ml

@@ -0,0 +1,67 @@
+open Ppxlib
+
+let payload : unit -> (structure_item, label list -> 'a, 'a) Ast_pattern.t =
+ fun () ->
+  Ast_pattern.(
+    pstr_eval (elist (pexp_constant (pconst_string __ drop drop))) drop)
+
+let make_payload ~loc labels =
+  let open Ast_builder.Make (struct
+    let loc = loc
+  end) in
+  pstr_eval (elist (List.map estring labels)) []
+
+let expand ~loc ident recurse =
+  let open Ast_builder.Make (struct
+    let loc = loc
+  end) in
+  let ident =
+    Located.mk
+      (match ident with
+      | Lident x -> Lident (x ^ "x")
+      | _ -> Location.raise_errorf ~loc "ident must be simple")
+  in
+  match recurse with
+  | [] -> pexp_ident ident
+  | "%ext" :: recurse ->
+      pexp_extension
+        ( Located.mk "ext",
+          PStr [ pstr_eval (pexp_ident ident) []; make_payload ~loc recurse ] )
+  | "@attr" :: recurse ->
+      {
+        pexp_desc = Pexp_ident ident;
+        pexp_attributes =
+          [
+            attribute ~name:(Located.mk "attr")
+              ~payload:(PStr [ make_payload ~loc recurse ]);
+          ];
+        pexp_loc = loc;
+        pexp_loc_stack = [];
+      }
+  | hd :: _ -> Location.raise_errorf ~loc "invalid rewrite: %s" hd
+
+let () =
+  Driver.register_transformation "recursive"
+    ~rules:
+      [
+        Context_free.Rule.extension
+          (Extension.V3.declare "ext" Extension.Context.expression
+             Ast_pattern.(
+               pstr (pstr_eval (pexp_ident __) drop ^:: payload () ^:: nil))
+             (fun ~ctxt ident recurse ->
+               let loc = Expansion_context.Extension.extension_point_loc ctxt in
+               let loc = { loc with loc_ghost = true } in
+               expand ~loc ident recurse));
+        Context_free.Rule.attr_replace "attr" Extension.Context.expression
+          (Attribute.declare "attr" Attribute.Context.Expression
+             Ast_pattern.(pstr (payload () ^:: nil))
+             (fun x -> x))
+          (fun ~ctxt:_ x recurse ->
+            match x.pexp_desc with
+            | Pexp_ident ident -> expand ~loc:x.pexp_loc ident.txt recurse
+            | _ ->
+                Location.raise_errorf ~loc:x.pexp_loc
+                  "rewrite must be applied to an identifier");
+      ]
+
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/recursive_replacement/dune

@@ -0,0 +1,7 @@
+(executable
+ (name driver)
+ (modules driver)
+ (libraries ppxlib))
+
+(cram
+ (deps driver.exe))

unikernel/duniverse/ppxlib/test/recursive_replacement/run.t

@@ -0,0 +1,43 @@
+This test checks that an extension point or attribute that expands to another extension
+point or attribute will continue to be expanded recursively until it cannot be
+expanded anymore.
+
+It uses the extension and attribute defined in driver.ml which expands:
+- [%ext x ;; ["%ext", "@attr", ...]] into [%ext xx ;; ["@attr", ...]]
+- [%ext x ;; ["@attr", "%ext", ...]] into xx [@attr ["%ext", ...]]
+- [%ext x ;; []] into xx
+- x [@attr ["%ext", "@attr", ...]] into [%ext xx ;; ["@attr", ...]]
+- x [@attr ["@attr", "%ext", ...]] into xx [@attr ["%ext", ...]]
+- x [@attr []] into xx
+
+It adds an "x" to the ident to make it clear how many times the attribute has been applied.
+
+First check that an extension point is expanded recursively:
+  $ cat > test.ml << EOF
+  > let () = [%ext a ;; ["%ext"]];;
+  > EOF
+  $ ./driver.exe test.ml
+  let () = axx
+
+An attribute is also expanded recursively:
+  $ cat > test.ml << EOF
+  > let () = b [@attr ["@attr"]];;
+  > EOF
+  $ ./driver.exe test.ml
+  let () = bxx
+
+An extension that expands into an attribute and vice versa work:
+  $ cat > test.ml << EOF
+  > let () = [%ext c ;; ["@attr"]];;
+  > let () = d [@attr ["%ext"]];;
+  > EOF
+  $ ./driver.exe test.ml
+  let () = cxx
+  let () = dxx
+
+Something a bit silly to validate it carries on until it's done:
+  $ cat > test.ml << EOF
+  > let () = e [@attr ["%ext"; "@attr"; "@attr"; "%ext"; "%ext"]];;
+  > EOF
+  $ ./driver.exe test.ml
+  let () = exxxxxx