unikernel/duniverse/ppxlib/test/501_migrations/compare_on.ml

@@ -0,0 +1,30 @@
+let run () =
+  let example_fn, ppx =
+    let args = Sys.argv in
+    if not (Array.length args = 3) then failwith "expected exactly two args"
+    else (Array.get args 1, Array.get args 2)
+  in
+  let direct = "without_migrations" in
+  let migrations = "with_migrations" in
+  let direct_ec =
+    Sys.command ("ocamlc -dparsetree " ^ example_fn ^ " 2> " ^ direct)
+  in
+  if direct_ec > 0 then (
+    print_endline "compile error even without migrations";
+    let _ = Sys.command ("cat " ^ direct) in
+    ())
+  else
+    let migrations_ec =
+      Sys.command
+        ("ocamlc -dparsetree -ppx '" ^ ppx ^ " -as-ppx' " ^ example_fn ^ " 2> "
+       ^ migrations)
+    in
+    if migrations_ec > 0 then (
+      print_endline "compile error after migrations";
+      let _ = Sys.command ("cat " ^ migrations) in
+      ())
+    else
+      let _ = Sys.command ("diff -U 0 " ^ direct ^ " " ^ migrations) in
+      ()
+
+let () = run ()

unikernel/duniverse/ppxlib/test/501_migrations/dune

@@ -0,0 +1,39 @@
+(executable
+ (name identity_driver)
+ (modules identity_driver)
+ (libraries ppxlib))
+
+(executable
+ (name reverse_migrations)
+ (modules reverse_migrations)
+ (libraries ppxlib))
+
+(executable
+ (name compare_on)
+ (libraries unix)
+ (modules compare_on))
+
+(cram
+ (package ppxlib)
+ (enabled_if
+  (and
+   (>= %{ocaml_version} "5.1.0~alpha2")
+   (< %{ocaml_version} "5.2.0")))
+ (applies_to normal_migrations)
+ (deps identity_driver.exe compare_on.exe))
+
+(cram
+ (package ppxlib)
+ (enabled_if
+  (= %{ocaml_version} "5.0.0"))
+ (applies_to reverse_migrations)
+ (deps reverse_migrations.exe compare_on.exe))
+
+(cram
+ (package ppxlib)
+ (enabled_if
+  (and
+   (>= %{ocaml_version} "5.0.0")
+   (< %{ocaml_version} "5.2.0")))
+ (applies_to one_migration)
+ (deps identity_driver.exe compare_on.exe))

unikernel/duniverse/ppxlib/test/501_migrations/identity_driver.ml

@@ -0,0 +1 @@
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/501_migrations/normal_migrations.t

@@ -0,0 +1,146 @@
+The 501 parsetree contains a parsing modificacion.
+[compare_on.exe <file>] checks if there's a diff between the
+AST's resulting from
+1. parsing <file> on 5.1.0 directly
+2. parsing <file> on 5.1.0, migrating down to 5.0.0 and migrating back to 5.1.0
+
+------------------
+
+Tests for the Parsetree change for type constraints in value bindings
+
+  $ echo "let x : int = 5" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let (x) : int = 5" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let _ : int = 5" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f : type a b c. a -> b -> c = fun x y -> assert false" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let _ = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f : type a . a -> a = fun x -> x" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let (x, y) : (int * int) = assert false" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f : type a . a = assert false" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x : [`A] :> [`A | `B] = `A' > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x : [`A | `B] = (`A : [`A] :> [`A | `B])' > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x : <m:int; n:int> :> <m:int> = object method m = 0 method n = 1 end' > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x :> <m:int> = object method m = 0 method n = 1 end' > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+
+There used to be a problem in the upward migration to 5.1.0: the 5.1.0 parser parses the constraint as a pattern constraint.
+However, the upward migration makes a value binding constraint out of it. Since the internal AST was bumped to 5.2.0, this is no longer an issue.
+  $ echo "let ((x,y) : (int*int)) = (assert false: int * int)" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f: type a. a option -> _ = assert false" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+
+Here we may expect a diff (downwards migrating should yield the same as in the example right above).
+However, those case are recoverable.
+
+First, both
+
+  $ echo "let f : 'a . 'a = (fun (type a) -> (assert false : a))" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+and
+  $ echo "let f : type a . a = assert false" > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+are translated to the same 5.0 AST tree. But the locations on the expression
+constraint and pattern constraint are only the same in the second case.
+Thus, we can distinguish between the two.
+
+Similarly, the syntactic translation for
+
+  $ echo 'let x :> [`A | `B] = `A' > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+and
+
+  $ echo 'let x : [`A | `B] = (`A :> [ `A | `B ] )' > file.ml
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+are pretty close: The former is translated to "let (x: ø .  [`A | `B]) = (`A :> [`A | `B])"
+whereas the latter is mapped to "let (x: ø .  [`A | `B]) = ((`A :> [`A | `B]): [`A | `B]) ".
+However, the two case can be distingued by the fact that we have either an outward coercion
+or an outward constraint associated to a `Ptyp_poly([],...)` pattern constraint.
+
+Let's make sure that in the examples with diffs,
+the location invariants are still fulfilled.
+  $ echo "let ((x,y) : (int*int)) = (assert false: int * int)" > file.ml
+  $ ./identity_driver.exe -check -locations-check file.ml > /dev/null
+
+------------------
+
+Tests for the Parsetree change for generative functor applications
+
+
+  $ cat > file.ml << EOF
+  > module F () = struct end
+  > module M = F ()
+  > EOF
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ cat > file.ml << EOF
+  > module F () = struct end
+  > module M = F [@attr1] () [@attr2]
+  > EOF
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ cat > file.ml << EOF
+  > module F () = struct end
+  > module M = F(struct end)
+  > EOF
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ cat > file.ml << EOF
+  > module F (N : sig end) = struct end
+  > module M = F (struct end)
+  > EOF
+  $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]

unikernel/duniverse/ppxlib/test/501_migrations/one_migration.t

@@ -0,0 +1,45 @@
+This test is enabled both on 5.0.0 and 5.1.0. The test makes sense for as long
+as the ppxlib AST is either 5.0.0 or 5.1.0. While the ppxlib AST is on 5.0.0, the
+test checks whether parsing on 5.0.0 (result of test running on 5.0.0) is the same as
+parsing on 5.1.0 and then migrating down to 5.0.0 (result of test running on 5.1.0).
+
+The test is mostly useful for debugging problems in a full round-trip.
+
+  $ echo "let x : int = 5" > file.ml
+  $ ./identity_driver.exe -dparsetree file.ml
+  [ Pstr_value
+      ( Nonrecursive
+      , [ { pvb_pat = Ppat_var "x"
+          ; pvb_expr = Pexp_constant (Pconst_integer ( "5", None))
+          ; pvb_constraint =
+              Some
+                (Pvc_constraint
+                   { locally_abstract_univars = []
+                   ; typ = Ptyp_constr ( Lident "int", [])
+                   })
+          ; pvb_attributes = __attrs
+          ; pvb_loc = __loc
+          }
+        ]
+      )
+  ]
+
+  $ cat > file.ml << EOF
+  > module F () = struct end
+  > module M = F ()
+  > EOF
+
+  $ ./identity_driver.exe -dparsetree file.ml
+  [ Pstr_module
+      { pmb_name = Some "F"
+      ; pmb_expr = Pmod_functor ( Unit, Pmod_structure [])
+      ; pmb_attributes = __attrs
+      ; pmb_loc = __loc
+      }
+  ; Pstr_module
+      { pmb_name = Some "M"
+      ; pmb_expr = Pmod_apply_unit (Pmod_ident (Lident "F"))
+      ; pmb_attributes = __attrs
+      ; pmb_loc = __loc
+      }
+  ]

unikernel/duniverse/ppxlib/test/501_migrations/reverse_migrations.ml

@@ -0,0 +1,9 @@
+module Reverse = Ppxlib_ast.Select_ast (Ppxlib_ast__.Versions.OCaml_501)
+
+let () =
+  let impl str =
+    Reverse.Of_ocaml.copy_structure @@ Reverse.To_ocaml.copy_structure str
+  in
+  Ppxlib.Driver.register_transformation ~impl "reverse_migrations"
+
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/501_migrations/reverse_migrations.t

@@ -0,0 +1,201 @@
+The 501 parsetree contains a parsing modificacion.
+[compare_on.exe <file> ./reverse_migrations.exe] checks if there's a diff between the
+AST's resulting from
+1. parsing <file> on 5.0.0 directly
+2. parsing <file> on 5.0.0, migrating up to 5.1.0 and migrating back to 5.0.0
+
+------------------
+
+Tests for the Parsetree change for type constraints in value bindings
+
+  $ echo "let x : int = 5" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let _ : int = 5" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f : type a b c. a -> b -> c = fun x y -> assert false" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let _ = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f : type a . a -> a = fun x -> x" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f: type a. a option -> _ = assert false" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f : 'a . 'a = (fun (type a) -> (assert false : a))" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f : type a . a = assert false" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x :> [`A | `B] = `A' > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x : [`A] :> [`A | `B] = `A' > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x : [`A | `B] = (`A : [`A] :> [`A | `B])' > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x : <m:int; n:int> :> <m:int> = object method m = 0 method n = 1 end' > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x :> <m:int> = object method m = 0 method n = 1 end' > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe   | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+The downward migration isn't able to recover the whole pattern location range,
+since it doesn't track the location of the closing brackets.
+  $ echo "let (x, y) : (int * int) = assert false" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  @@ -6 +6 @@
+  -        pattern (file.ml[1,0+4]..[1,0+24]) ghost
+  +        pattern (file.ml[1,0+4]..[1,0+23]) ghost
+
+  $ echo "let (x, y) : (int * int) = assert false" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  @@ -6 +6 @@
+  -        pattern (file.ml[1,0+4]..[1,0+24]) ghost
+  +        pattern (file.ml[1,0+4]..[1,0+23]) ghost
+
+  $ echo "let f: type a. a option -> _ = assert false" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f : 'a . 'a = (fun (type a) -> (assert false : a))" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo "let f : type a . a = assert false" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x :> [`A | `B] = `A' > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x : [`A] :> [`A | `B] = `A' > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x : [`A | `B] = (`A : [`A] :> [`A | `B])' > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x : <m:int; n:int> :> <m:int> = object method m = 0 method n = 1 end' > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+  $ echo 'let x :> <m:int> = object method m = 0 method n = 1 end' > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe  | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+The diffs are on locations. If the location modification
+at least preserved the location invariants, it might be acceptable.
+However, in several cases it doesn't.
+
+  $ echo "let x : int = 5" > file.ml
+  $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null
+
+  $ echo "let (x as y) : int = 5" > file.ml
+  $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null
+
+  $ cat > file.ml << EOF
+  > type t = {a : int}
+  > let {a} = {a = 5}
+  > EOF
+  $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null
+
+
+  $ echo "let _ : int = 5" > file.ml
+  $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null
+
+  $ echo "let f : type a b c. a -> b -> c = fun x y -> assert false" > file.ml
+  $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null
+
+  $ echo "let f = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml
+  $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null
+
+  $ echo "let _ = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml
+  $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null
+
+Here we're expecting a similar location diff as above. However, the downward
+migration is faulty: it turns [let (x) : int = 5] (constraint only on pattern)
+into [let x : int = 5] (contraint on both pattern an expression).
+  $ echo "let (x) : int = 5" > file.ml
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  @@ -9,0 +10,9 @@
+  +          core_type (file.ml[1,0+10]..[1,0+13]) ghost
+  +            Ptyp_poly
+  +            core_type (file.ml[1,0+10]..[1,0+13])
+  +              Ptyp_constr "int" (file.ml[1,0+10]..[1,0+13])
+  +              []
+  +        expression (file.ml[1,0+4]..[1,0+17])
+  +          Pexp_constraint
+  +          expression (file.ml[1,0+16]..[1,0+17])
+  +            Pexp_constant PConst_int (5,None)
+  @@ -13,2 +21,0 @@
+  -        expression (file.ml[1,0+16]..[1,0+17])
+  -          Pexp_constant PConst_int (5,None)
+
+Let's make sure that in the examples with diffs,
+the location invariants are still fulfilled.
+
+  $ echo "let (x, y) : (int * int) = assert false" > file.ml
+  $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null
+
+  $ echo "let (x) : int = 5" > file.ml
+  $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null
+
+
+------------------
+
+Tests for the Parsetree change for generative functor applications
+
+  $ cat > file.ml << EOF
+  > module F () = struct end
+  > module M = F ()
+  > EOF
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  [1]
+
+When going up, F(struct end) is turned into F(), which makes the location be lost.
+It could be stored in an attribute, or turned into F(struct end [@warning "-73"]).
+
+  $ cat > file.ml << EOF
+  > module F () = struct end
+  > module M = F(struct end)
+  > EOF
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  @@ -17 +17 @@
+  -        module_expr (file.ml[2,25+13]..[2,25+23])
+  +        module_expr (file.ml[2,25+11]..[2,25+24])
+
+  $ cat > file.ml << EOF
+  > module F (N : sig end) = struct end
+  > module M = F (struct end)
+  > EOF
+  $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations"
+  @@ -20 +20 @@
+  -        module_expr (file.ml[2,36+14]..[2,36+24])
+  +        module_expr (file.ml[2,36+11]..[2,36+25])

unikernel/duniverse/ppxlib/test/502_pexpfun/driver.ml

@@ -0,0 +1 @@
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/502_pexpfun/dune

@@ -0,0 +1,27 @@
+(executable
+ (name driver)
+ (modules driver)
+ (enabled_if
+  (>= %{ocaml_version} "5.2"))
+ (libraries ppxlib))
+
+(cram
+ (package ppxlib)
+ (enabled_if
+  (>= %{ocaml_version} "5.2"))
+ (deps driver.exe))
+
+(rule
+ (package ppxlib)
+ (alias runtest)
+ (enabled_if
+  (>= %{ocaml_version} "5.2"))
+ (deps
+  (:test test.ml)
+  (package ppxlib))
+ (action
+  (chdir
+   %{project_root}
+   (progn
+    (run expect-test %{test})
+    (diff? %{test} %{test}.corrected)))))

unikernel/duniverse/ppxlib/test/502_pexpfun/run.t

@@ -0,0 +1,19 @@
+We want to make sure that migrations from 5.2 to previous versions still
+produce valid location ranges between parent and child.
+
+  $ cat > test.ml << EOF
+  > let make ~foo ~bar = foo ^ bar
+  > EOF
+
+We run a custom driver that will read our ast, migrate it back to 5.01, and
+check that the locations are valid (the parent range is larger than the child
+range).
+
+  $ ./driver.exe -locations-check --impl test.ml -o ignore.ml
+
+Locations should also be well formed for Pparam_newtype
+  $ cat > test.ml << EOF
+  > let make (type t) (type u) foo = foo
+  > EOF
+
+  $ ./driver.exe -locations-check --impl test.ml -o ignore.ml

unikernel/duniverse/ppxlib/test/502_pexpfun/test.ml

@@ -0,0 +1,23 @@
+open Ppxlib
+
+module B = Ast_builder.Make (struct
+  let loc = !Ast_helper.default_loc
+end)
+[%%ignore]
+
+(** Using multiple calls to [pexp_fun] still produces a maximum arity function
+*)
+let _ =
+  let inner =
+    B.pexp_fun Nolabel None
+      (B.ppat_var { txt = "y"; loc = B.loc })
+      (B.pexp_apply (B.evar "Int.add")
+         [ (Nolabel, B.evar "x"); (Nolabel, B.evar "y") ])
+  in
+  let e =
+    B.pexp_fun Nolabel None (B.ppat_var { txt = "x"; loc = B.loc }) inner
+  in
+  Format.asprintf "%a" Pprintast.expression e
+[%%expect{|
+- : string = "fun x y -> Int.add x y"
+|}]

unikernel/duniverse/ppxlib/test/503_migrations/preserve-effect-downward/driver.ml

@@ -0,0 +1,15 @@
+module To_before_503 =
+  Ppxlib_ast.Convert (Ppxlib_ast.Js) (Ppxlib_ast__.Versions.OCaml_502)
+
+module From_before_503 =
+  Ppxlib_ast.Convert (Ppxlib_ast__.Versions.OCaml_502) (Ppxlib_ast.Js)
+
+let impl _ctxt str =
+  (* This manual migration is here to ensure the test still works even once our
+     internal AST has been bumped past 5.3 *)
+  let before_503_ast = To_before_503.copy_structure str in
+  let roundtrip = From_before_503.copy_structure before_503_ast in
+  roundtrip
+
+let () = Ppxlib.Driver.V2.register_transformation ~impl "503-downward-roundtrip"
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/503_migrations/preserve-effect-downward/dune

@@ -0,0 +1,10 @@
+(executable
+ (name driver)
+ (enabled_if
+  (>= %{ocaml_version} "5.3"))
+ (libraries ppxlib ocaml-compiler-libs.common compiler-libs.common))
+
+(cram
+ (enabled_if
+  (>= %{ocaml_version} "5.3"))
+ (deps driver.exe))

unikernel/duniverse/ppxlib/test/503_migrations/preserve-effect-downward/run.t

@@ -0,0 +1,24 @@
+We should be able to migrate the effect syntax downward and back. This allows users
+to run ppx-es on 5.3 on source files that use the effect syntax until we update our
+internal AST to fully support it.
+
+We have a custom driver that will force migration of the AST down to 5.2 and back to
+the compiler's version and print it as source code using the compiler's printer,
+regardless of ppxlib's internal AST version.
+
+If we run the driver on the following source file:
+
+  $ cat > test.ml << EOF
+  > let handler f =
+  > match f () with
+  > | x -> x
+  > | effect Random_bits, k -> Effect.Deep.continue k (Random.bits ())
+  > EOF
+
+it should successfully roundtrip to 5.2 and print the source code unchanged:
+
+  $ ./driver.exe test.ml --use-compiler-pp
+  let handler f =
+    match f () with
+    | x -> x
+    | effect Random_bits,  k -> Effect.Deep.continue k (Random.bits ())

unikernel/duniverse/ppxlib/test/ast_builder_value_binding/dune

@@ -0,0 +1,16 @@
+(rule
+ (package ppxlib)
+ (alias runtest)
+ ; #install_printer is not working on older compilers for some reason
+ ; This is fine as this does not need to be tested on older compilers anyway
+ (enabled_if
+  (>= %{ocaml_version} 5.1))
+ (deps
+  (:test test.ml)
+  (package ppxlib))
+ (action
+  (chdir
+   %{project_root}
+   (progn
+    (run expect-test %{test})
+    (diff? %{test} %{test}.corrected)))))

unikernel/duniverse/ppxlib/test/ast_builder_value_binding/test.ml

@@ -0,0 +1,198 @@
+open Ppxlib
+
+(* This file contains tests to ensure that [Ast_builder.value_binding] properly
+   translates the given [pattern] and [expression] pair into the correct
+   [pattern], [expression] and [value_constraint] triple. *)
+
+
+(* ------- Test Setup -------- *)
+
+#install_printer Pp_ast.Default.structure_item;;
+#install_printer Pp_ast.Default.expression;;
+#install_printer Pp_ast.Default.pattern;;
+
+let loc = Location.none
+[%%ignore]
+
+(* --------- Simple case, no translation --------- *)
+
+let pat = [%pat? f]
+let expr = [%expr fun x -> x + 1]
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "f"
+        ; pvb_expr =
+            Pexp_function
+              ( [ { pparam_loc = __loc
+                  ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_var "x")
+                  }
+                ]
+              , None
+              , Pfunction_body
+                  (Pexp_apply
+                     ( Pexp_ident (Lident "+")
+                     , [ ( Nolabel, Pexp_ident (Lident "x"))
+                       ; ( Nolabel
+                         , Pexp_constant (Pconst_integer ( "1", None))
+                         )
+                       ]
+                     ))
+              )
+        ; pvb_constraint = None
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* As expected here, the [pvb_constraint] field is none, the pattern and
+   expression are used as is. *)
+
+(* --------- No var Ppat_constraint to pvb_constraint --------- *)
+
+let pat = [%pat? (x : int)]
+let expr = [%expr 12]
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "x"
+        ; pvb_expr = Pexp_constant (Pconst_integer ( "12", None))
+        ; pvb_constraint =
+            Some
+              (Pvc_constraint
+                 { locally_abstract_univars = []
+                 ; typ = Ptyp_constr ( Lident "int", [])
+                 })
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* --------- poly Ppat_constraint to pvb_constraint --------- *)
+
+let pat =
+  Ast_builder.Default.ppat_constraint ~loc
+    [%pat? f]
+    (Ast_builder.Default.ptyp_poly ~loc
+       [ Loc.make ~loc "a" ]
+       [%type: 'a -> unit])
+
+let expr = [%expr fun x -> unit]
+
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "f"
+        ; pvb_expr =
+            Pexp_function
+              ( [ { pparam_loc = __loc
+                  ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_var "x")
+                  }
+                ]
+              , None
+              , Pfunction_body (Pexp_ident (Lident "unit"))
+              )
+        ; pvb_constraint =
+            Some
+              (Pvc_constraint
+                 { locally_abstract_univars = []
+                 ; typ =
+                     Ptyp_poly
+                       ( [ "a"]
+                       , Ptyp_arrow
+                           ( Nolabel
+                           , Ptyp_var "a"
+                           , Ptyp_constr ( Lident "unit", [])
+                           )
+                       )
+                 })
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* --------- desugared locally abstract univars to pvb_constraint --------- *)
+
+let pat =
+  Ast_builder.Default.ppat_constraint ~loc
+    [%pat? f]
+    (Ast_builder.Default.ptyp_poly ~loc
+       [ Loc.make ~loc "a" ]
+       [%type: 'a -> unit])
+
+let expr = [%expr fun (type a) -> (fun _ -> unit : a -> unit)]
+
+[%%ignore]
+
+let vb =
+  let open Ast_builder.Default in
+  pstr_value ~loc Nonrecursive [value_binding ~pat ~expr ~loc]
+
+[%%expect{|
+val vb : structure_item =
+  Pstr_value
+    ( Nonrecursive
+    , [ { pvb_pat = Ppat_var "f"
+        ; pvb_expr =
+            Pexp_function
+              ( [ { pparam_loc = __loc
+                  ; pparam_desc = Pparam_val ( Nolabel, None, Ppat_any)
+                  }
+                ]
+              , None
+              , Pfunction_body (Pexp_ident (Lident "unit"))
+              )
+        ; pvb_constraint =
+            Some
+              (Pvc_constraint
+                 { locally_abstract_univars = [ "a"]
+                 ; typ =
+                     Ptyp_arrow
+                       ( Nolabel
+                       , Ptyp_constr ( Lident "a", [])
+                       , Ptyp_constr ( Lident "unit", [])
+                       )
+                 })
+        ; pvb_attributes = __attrs
+        ; pvb_loc = __loc
+        }
+      ]
+    )
+|}]
+
+(* As expected here, the matching constraint from the pattern and expression or
+   recombined into a single value constraint with locally abstract univars set
+   correctly. *)
+
+(* --------- coercion to pvb_constraint --------- *)
+
+(*TODO*)
+[%%expect{|
+|}]

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

@@ -0,0 +1,285 @@
+open Ppxlib
+
+let string_pattern = Ast_pattern.(single_expr_payload (estring __))
+
+let template_class_expr ~ctxt:_ class_expr payload =
+  match class_expr.pcl_desc with
+  | Pcl_constr ({ txt = Lident name; loc }, args) ->
+      {
+        class_expr with
+        pcl_desc =
+          Pcl_constr ({ txt = Lident (name ^ "__" ^ payload); loc }, args);
+      }
+  | _ -> class_expr
+
+let () =
+  Driver.register_transformation "test.clx"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.clx" Extension.Context.class_expr
+          (Attribute.declare "test.clx" Class_expr string_pattern Fun.id)
+          template_class_expr;
+      ]
+
+let template_class_field ~ctxt:_ class_field payload =
+  match class_field.pcf_desc with
+  | Pcf_val ({ txt = name; loc }, flag, kind) ->
+      {
+        class_field with
+        pcf_desc = Pcf_val ({ txt = name ^ "__" ^ payload; loc }, flag, kind);
+      }
+  | _ -> class_field
+
+let () =
+  Driver.register_transformation "test.clf"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.clf" Extension.Context.class_field
+          (Attribute.declare "test.clf" Class_field string_pattern Fun.id)
+          template_class_field;
+      ]
+
+let template_class_type ~ctxt:_ class_type payload =
+  match class_type.pcty_desc with
+  | Pcty_constr ({ txt = Lident name; loc }, args) ->
+      {
+        class_type with
+        pcty_desc =
+          Pcty_constr ({ txt = Lident (name ^ "__" ^ payload); loc }, args);
+      }
+  | _ -> class_type
+
+let () =
+  Driver.register_transformation "test.clt"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.clt" Extension.Context.class_type
+          (Attribute.declare "test.clt" Class_type string_pattern Fun.id)
+          template_class_type;
+      ]
+
+let template_class_type_field ~ctxt:_ class_type_field payload =
+  match class_type_field.pctf_desc with
+  | Pctf_val ({ txt = name; loc }, mut_flag, virt_flag, ty) ->
+      {
+        class_type_field with
+        pctf_desc =
+          Pctf_val
+            ({ txt = name ^ "__" ^ payload; loc }, mut_flag, virt_flag, ty);
+      }
+  | _ -> class_type_field
+
+let () =
+  Driver.register_transformation "test.ctf"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.ctf"
+          Extension.Context.class_type_field
+          (Attribute.declare "test.ctf" Class_type_field string_pattern Fun.id)
+          template_class_type_field;
+      ]
+
+let template_core_type ~ctxt:_ core_type payload =
+  match core_type.ptyp_desc with
+  | Ptyp_constr ({ txt = Lident name; loc }, args) ->
+      {
+        core_type with
+        ptyp_desc =
+          Ptyp_constr ({ txt = Lident (name ^ "__" ^ payload); loc }, args);
+      }
+  | _ -> core_type
+
+let () =
+  Driver.register_transformation "test.typ"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.typ" Extension.Context.core_type
+          (Attribute.declare "test.typ" Core_type string_pattern Fun.id)
+          template_core_type;
+      ]
+
+let template_expression ~ctxt:_ expression payload =
+  match expression.pexp_desc with
+  | Pexp_ident { txt = Lident name; loc } ->
+      {
+        expression with
+        pexp_desc = Pexp_ident { txt = Lident (name ^ "__" ^ payload); loc };
+      }
+  | _ -> expression
+
+let () =
+  Driver.register_transformation "test.exp"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.exp" Extension.Context.expression
+          (Attribute.declare "test.exp" Expression string_pattern Fun.id)
+          template_expression;
+      ]
+
+let template_module_expr ~ctxt:_ module_expr payload =
+  match module_expr.pmod_desc with
+  | Pmod_ident { txt = Lident name; loc } ->
+      {
+        module_expr with
+        pmod_desc = Pmod_ident { txt = Lident (name ^ "__" ^ payload); loc };
+      }
+  | _ -> module_expr
+
+let () =
+  Driver.register_transformation "test.mod_exp"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.mod_exp"
+          Extension.Context.module_expr
+          (Attribute.declare "test.mod_exp" Module_expr string_pattern Fun.id)
+          template_module_expr;
+      ]
+
+let template_module_type ~ctxt:_ module_type payload =
+  match module_type.pmty_desc with
+  | Pmty_ident { txt = Lident name; loc } ->
+      {
+        module_type with
+        pmty_desc = Pmty_ident { txt = Lident (name ^ "__" ^ payload); loc };
+      }
+  | _ -> module_type
+
+let () =
+  Driver.register_transformation "test.mod_typ"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.mod_typ"
+          Extension.Context.module_type
+          (Attribute.declare "test.mod_typ" Module_type string_pattern Fun.id)
+          template_module_type;
+      ]
+
+let template_pattern ~ctxt:_ pattern payload =
+  match pattern.ppat_desc with
+  | Ppat_var { txt = name; loc } ->
+      { pattern with ppat_desc = Ppat_var { txt = name ^ "__" ^ payload; loc } }
+  | _ -> pattern
+
+let () =
+  Driver.register_transformation "test.pat"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.pat" Extension.Context.pattern
+          (Attribute.declare "test.pat" Pattern string_pattern Fun.id)
+          template_pattern;
+      ]
+
+let template_sig_extension ~ctxt:_ sig_item payload =
+  match sig_item.psig_desc with
+  | Psig_extension ((ext, inner_payload), attrs) ->
+      {
+        sig_item with
+        psig_desc =
+          Psig_extension
+            (({ ext with txt = ext.txt ^ "__" ^ payload }, inner_payload), attrs);
+      }
+  | _ -> assert false
+
+let () =
+  Driver.register_transformation "test.sig.ext"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.sig.ext"
+          Extension.Context.signature_item
+          (Attribute.declare "test.sig.ext" Psig_extension string_pattern Fun.id)
+          template_sig_extension;
+      ]
+
+let template_str_extension ~ctxt:_ structure_item payload =
+  match structure_item.pstr_desc with
+  | Pstr_extension ((ext, inner_payload), attrs) ->
+      {
+        structure_item with
+        pstr_desc =
+          Pstr_extension
+            (({ ext with txt = ext.txt ^ "__" ^ payload }, inner_payload), attrs);
+      }
+  | _ -> assert false
+
+let () =
+  Driver.register_transformation "test.str.ext"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.str.ext"
+          Extension.Context.structure_item
+          (Attribute.declare "test.str.ext" Pstr_extension string_pattern Fun.id)
+          template_str_extension;
+      ]
+
+let template_str_eval ~ctxt:_ structure_item payload =
+  match structure_item.pstr_desc with
+  | Pstr_eval (expression, attributes) ->
+      let expression =
+        match expression.pexp_desc with
+        | Pexp_ident { txt = Lident name; loc } ->
+            {
+              expression with
+              pexp_desc =
+                Pexp_ident { txt = Lident (name ^ "__" ^ payload); loc };
+            }
+        | _ -> expression
+      in
+      { structure_item with pstr_desc = Pstr_eval (expression, attributes) }
+  | _ -> assert false
+
+let () =
+  Driver.register_transformation "test.str.evl"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.str.evl"
+          Extension.Context.structure_item
+          (Attribute.declare "test.str.evl" Pstr_eval string_pattern Fun.id)
+          template_str_eval;
+      ]
+
+let template_ppx_import ~ctxt:_ _payload = assert false
+
+let () =
+  Driver.register_transformation "test.ppx.import"
+    ~rules:
+      [
+        Context_free.Rule.attr_replace "test.ppx.import"
+          Extension.Context.Ppx_import
+          (Attribute.declare "test.ppx.import" Type_declaration string_pattern
+             Fun.id)
+          template_ppx_import;
+      ]
+
+let attr_multi ~ctxt:_ expression
+    ([ prefix; suffix ] :
+      _ Context_free.Rule.Attr_multiple_replace.Parsed_payload_list.t) =
+  match (prefix, suffix) with
+  | None, None -> assert false
+  | _ -> (
+      ();
+      match expression.pexp_desc with
+      | Pexp_ident { txt = Lident name; loc } ->
+          let prefixed = Option.value ~default:"" prefix ^ name in
+          let suffixed = prefixed ^ Option.value ~default:"" suffix in
+          {
+            expression with
+            pexp_desc = Pexp_ident { txt = Lident suffixed; loc };
+          }
+      | _ -> expression)
+
+let () =
+  Driver.register_transformation "test"
+    ~rules:
+      [
+        Context_free.Rule.Attr_multiple_replace.attr_multiple_replace
+          "test.multi.exp" Extension.Context.expression
+          [
+            Attribute.declare "test.multi.exp.prefix" Expression string_pattern
+              Fun.id;
+            Attribute.declare "test.multi.exp.suffix" Expression string_pattern
+              Fun.id;
+          ]
+          attr_multi;
+      ]
+
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/attr_replace/dune

@@ -0,0 +1,11 @@
+(executable
+ (name driver)
+ (modules driver)
+ (libraries ppxlib)
+ (preprocess
+  (pps ppxlib.metaquot)))
+
+(cram
+ (enabled_if
+  (>= %{ocaml_version} "4.10.0"))
+ (deps driver.exe))

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

@@ -0,0 +1,125 @@
+Test that attribute replacement works in all the various contexts it can be applied.
+
+We include extra alert attributes where possible as they should pass through unchanged and
+in the same order.
+
+Class expressions
+  $ cat > test.ml << EOF
+  > class class_ = c [@test.clx "suffix"]
+  > EOF
+  $ ./driver.exe test.ml
+  class class_ = c__suffix
+
+Class fields
+  $ cat > test.ml << EOF
+  > class class_field =
+  >   object
+  >     val foo = () [@@alert "-1"] [@@test.clf "suffix"] [@@alert "-2"]
+  >   end
+  > EOF
+  $ ./driver.exe test.ml
+  class class_field =
+    object val foo__suffix = ()[@@alert "-1"][@@alert "-2"] end
+
+Class types
+  $ cat > test.ml << EOF
+  > class type class_type = ct[@test.clt "suffix"]
+  > EOF
+  $ ./driver.exe test.ml
+  class type class_type = ct__suffix
+
+Class type fields
+  $ cat > test.ml << EOF
+  > class type class_type_field = object
+  >   val x : int [@@alert "-1"] [@@test.ctf "suffix"] [@@alert "-2"]
+  > end
+  > EOF
+  $ ./driver.exe test.ml
+  class type class_type_field =
+    object val  x__suffix : int[@@alert "-1"][@@alert "-2"] end
+
+Types
+  $ cat > test.ml << EOF
+  > module type S = sig
+  >   val _e : (t[@alert "-1"] [@test.typ "suffix"] [@alert "-2"])
+  > end
+  > EOF
+  $ ./driver.exe test.ml
+  module type S  = sig val _e : ((t__suffix)[@alert "-1"][@alert "-2"]) end
+
+Expressions
+  $ cat > test.ml << EOF
+  > let _ = foo [@alert "-1"] [@test.exp "suffix"] [@alert "-2"]
+  > EOF
+  $ ./driver.exe test.ml
+  let _ = ((foo__suffix)[@alert "-1"][@alert "-2"])
+
+Explicit test for the ident in a function application because it acts differently due to
+"special functions".
+  $ cat > test.ml << EOF
+  > let _ = (foo [@alert "-1"] [@test.exp "suffix"] [@alert "-2"]) ()
+  > EOF
+  $ ./driver.exe test.ml
+  let _ = ((foo__suffix)[@alert "-1"][@alert "-2"]) ()
+
+Module expressions
+  $ cat > test.ml << EOF
+  > include M [@alert "-1"] [@test.mod_exp "suffix"] [@alert "-2"]
+  > EOF
+  $ ./driver.exe test.ml
+  include ((M__suffix)[@alert "-1"][@alert "-2"])
+
+Module types
+  $ cat > test.ml << EOF
+  > module F : S [@alert "-1"] [@test.mod_typ "suffix"] [@alert "-2"] = struct end
+  > EOF
+  $ ./driver.exe test.ml
+  module F : ((S__suffix)[@alert "-1"][@alert "-2"]) = struct  end 
+
+Patterns
+  $ cat > test.ml << EOF
+  > let _ = match () with (a [@test.pat "suffix"]) -> ignore a__suffix
+  > EOF
+  $ ./driver.exe test.ml
+  let _ = match () with | a__suffix -> ignore a__suffix
+
+Extension signature item
+  $ cat > test.ml << EOF
+  > module type S = sig
+  >   [%%foo] [@@test.sig.ext "suffix"]
+  > end
+  > EOF
+  $ ./driver.exe test.ml
+  module type S  = sig [%%foo__suffix ] end
+
+Extension structure item
+  $ cat > test.ml << EOF
+  > module S = struct
+  >   [%%foo] [@@test.str.ext "suffix"]
+  > end
+  > EOF
+  $ ./driver.exe test.ml
+  module S = struct [%%foo__suffix ] end
+
+Eval structure item 
+  $ cat > test.ml << EOF
+  > module _ = struct
+  >   ident [@@test.str.evl "suffix"]
+  > end
+  > EOF
+  $ ./driver.exe test.ml
+  module _ = struct ;;ident__suffix end
+
+
+Test that the "attr_multiple_replace" infrastructure works.
+  $ cat > test.ml << EOF
+  > let _ =
+  >   foo
+  >   [@alert "-1"]
+  >   [@suffix "_suffix"]
+  >   [@alert "-2"]
+  >   [@prefix "prefix_"]
+  >   [@alert "-3"]
+  > EOF
+  $ ./driver.exe test.ml
+  let _ = ((prefix_foo_suffix)[@alert "-1"][@alert "-2"][@alert "-3"])

unikernel/duniverse/ppxlib/test/base/dune

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

unikernel/duniverse/ppxlib/test/base/test.ml

@@ -0,0 +1,299 @@
+let () = Printexc.record_backtrace false
+
+open Ppxlib
+
+module N = Ppxlib_private.Name
+[%%expect{|
+module N = Ppxlib.Ppxlib_private.Name
+|}]
+
+
+let dot_suffixes name =
+  Printf.sprintf "%s"
+    (Sexplib0.Sexp.to_string_hum
+       (Sexplib0.Sexp_conv.sexp_of_list Sexplib0.Sexp_conv.sexp_of_string (N.dot_suffixes name)))
+[%%expect{|
+val dot_suffixes : string -> string = <fun>
+|}]
+
+let _ = dot_suffixes "foo.bar.baz"
+[%%expect{|
+- : string = "(baz bar.baz foo.bar.baz)"
+|}]
+
+let _ = dot_suffixes "foo.@bar.baz"
+[%%expect{|
+- : string = "(bar.baz foo.bar.baz)"
+|}]
+
+
+let split_path name =
+    let a, b = N.split_path name in
+    Printf.sprintf "%s"
+      (Sexplib0.Sexp.to_string_hum
+         (List [Sexplib0.Sexp_conv.sexp_of_string a; Sexplib0.Sexp_conv.sexp_of_option Sexplib0.Sexp_conv.sexp_of_string b]))
+[%%expect{|
+val split_path : string -> string = <fun>
+|}]
+
+let _ = split_path "a.b.c"
+[%%expect{|
+- : string = "(a.b.c ())"
+|}]
+
+let _ = split_path "a.b.c.D"
+[%%expect{|
+- : string = "(a.b.c (D))"
+|}]
+
+let _ = split_path ".D"
+[%%expect{|
+- : string = "(\"\" (D))"
+|}]
+
+let convert_longident string =
+  let lident = Longident.parse string in
+  let name = Longident.name lident in
+  (name, lident)
+[%%expect{|
+val convert_longident : string -> string * longident = <fun>
+|}]
+
+let _ = convert_longident "x"
+[%%expect_in <= 5.3 {|
+- : string * longident = ("x", Ppxlib.Longident.Lident "x")
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident = ("x", Longident.Lident "x")
+|}]
+
+let _ = convert_longident "(+)"
+[%%expect_in <= 5.3 {|
+- : string * longident = ("( + )", Ppxlib.Longident.Lident "+")
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident = ("( + )", Longident.Lident "+")
+|}]
+
+let _ = convert_longident "( + )"
+[%%expect_in <= 5.3 {|
+- : string * longident = ("( + )", Ppxlib.Longident.Lident "+")
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident = ("( + )", Longident.Lident "+")
+|}]
+
+let _ = convert_longident "Base.x"
+[%%expect_in <= 5.3 {|
+- : string * longident =
+("Base.x", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "x"))
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident =
+("Base.x", Longident.Ldot (Longident.Lident "Base", "x"))
+|}]
+
+let _ = convert_longident "Base.(+)"
+[%%expect_in <= 5.3 {|
+- : string * longident =
+("Base.( + )", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "+"))
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident =
+("Base.( + )", Longident.Ldot (Longident.Lident "Base", "+"))
+|}]
+
+let _ = convert_longident "Base.( + )"
+[%%expect_in <= 5.3 {|
+- : string * longident =
+("Base.( + )", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "+"))
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident =
+("Base.( + )", Longident.Ldot (Longident.Lident "Base", "+"))
+|}]
+
+let _ = convert_longident "Base.( land )"
+[%%expect_in <= 5.3 {|
+- : string * longident =
+("Base.( land )",
+ Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "land"))
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident =
+("Base.( land )", Longident.Ldot (Longident.Lident "Base", "land"))
+|}]
+
+let _ = convert_longident "A(B)"
+[%%expect_in <= 5.3 {|
+Exception:
+Invalid_argument "Ppxlib.Longident.parse(application in path): \"A(B)\"".
+|}]
+[%%expect_in >= 5.4 {|
+Exception:
+Invalid_argument "Ppxlib.Longident.parse(application in path): \"A(B)\"".
+|}]
+
+let _ = convert_longident "A.B(C)"
+[%%expect_in <= 5.3 {|
+Exception:
+Invalid_argument "Ppxlib.Longident.parse(application in path): \"A.B(C)\"".
+|}]
+[%%expect_in >= 5.4 {|
+Exception:
+Invalid_argument "Ppxlib.Longident.parse(application in path): \"A.B(C)\"".
+|}]
+
+let _ = convert_longident ")"
+[%%expect_in <= 5.3 {|
+Exception:
+Invalid_argument "Ppxlib.Longident.parse(unbalanced parenthesis): \")\"".
+|}]
+[%%expect_in >= 5.4 {|
+Exception:
+Invalid_argument "Ppxlib.Longident.parse(unbalanced parenthesis): \")\"".
+|}]
+
+let _ = convert_longident "("
+[%%expect{|
+Exception:
+Invalid_argument "Ppxlib.Longident.parse(unbalanced parenthesis): \"(\"".
+|}]
+
+let _ = convert_longident "A.(()"
+[%%expect{|
+Exception:
+Invalid_argument "Ppxlib.Longident.parse(unbalanced parenthesis): \"A.(()\"".
+|}]
+
+let _ = convert_longident "A.())()"
+[%%expect{|
+Exception:
+Invalid_argument
+ "Ppxlib.Longident.parse(right parenthesis misplaced): \"A.())()\"".
+|}]
+
+let _ = convert_longident "+."
+[%%expect_in <= 5.3 {|
+- : string * longident = ("( +. )", Ppxlib.Longident.Lident "+.")
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident = ("( +. )", Longident.Lident "+.")
+|}]
+
+let _ = convert_longident "(+.)"
+[%%expect_in <= 5.3 {|
+- : string * longident = ("( +. )", Ppxlib.Longident.Lident "+.")
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident = ("( +. )", Longident.Lident "+.")
+|}]
+
+let _ = convert_longident "Foo.(+.)"
+[%%expect_in <= 5.3 {|
+- : string * longident =
+("Foo.( +. )", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Foo", "+."))
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident =
+("Foo.( +. )", Longident.Ldot (Longident.Lident "Foo", "+."))
+|}]
+
+let _ = convert_longident "Foo.( *. )"
+[%%expect_in <= 5.3 {|
+- : string * longident =
+("Foo.( *. )", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Foo", "*."))
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident =
+("Foo.( *. )", Longident.Ldot (Longident.Lident "Foo", "*."))
+|}]
+
+(* Indexing operators  *)
+let _ = convert_longident "(.!())"
+[%%expect_in <= 5.3 {|
+- : string * longident = ("( .!() )", Ppxlib.Longident.Lident ".!()")
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident = ("( .!() )", Longident.Lident ".!()")
+|}]
+
+let _ = convert_longident "(.%(;..)<-)"
+[%%expect_in <= 5.3 {|
+- : string * longident =
+("( .%(;..)<- )", Ppxlib.Longident.Lident ".%(;..)<-")
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident = ("( .%(;..)<- )", Longident.Lident ".%(;..)<-")
+|}]
+
+let _ = convert_longident "Vec.(.%(;..)<-)"
+[%%expect_in <= 5.3 {|
+- : string * longident =
+("Vec.( .%(;..)<- )",
+ Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Vec", ".%(;..)<-"))
+|}]
+[%%expect_in >= 5.4 {|
+- : string * longident =
+("Vec.( .%(;..)<- )", Longident.Ldot (Longident.Lident "Vec", ".%(;..)<-"))
+|}]
+
+let _ = Ppxlib.Code_path.(file_path @@ top_level ~file_path:"dir/main.ml")
+[%%expect{|
+- : string = "dir/main.ml"
+|}]
+
+let _ = Ppxlib.Code_path.(fully_qualified_path @@ top_level ~file_path:"dir/main.ml")
+[%%expect{|
+- : string = "Main"
+|}]
+
+let complex_path =
+  let open Ppxlib.Code_path in
+  let loc = Ppxlib.Location.none in
+  top_level ~file_path:"dir/main.ml"
+  |> enter_module ~loc "Sub"
+  |> enter_module ~loc "Sub_sub"
+  |> enter_value ~loc "some_val"
+[%%expect{|
+val complex_path : Code_path.t = <abstr>
+|}]
+
+let _ = Ppxlib.Code_path.fully_qualified_path complex_path
+[%%expect{|
+- : string = "Main.Sub.Sub_sub.some_val"
+|}]
+
+let _ = Ppxlib.Code_path.to_string_path complex_path
+[%%expect{|
+- : string = "dir/main.ml.Sub.Sub_sub"
+|}]
+
+let _ =
+  let a = gen_symbol () ~prefix:"__prefix__" in
+  let b = gen_symbol () ~prefix:a in
+  a, b
+[%%expect{|
+- : string * string = ("__prefix____001_", "__prefix____002_")
+|}]
+
+let _ =
+  let open Ast_builder.Make (struct let loc = Location.none end) in
+  let params decl =
+    List.map (fun (core_type, _) -> core_type.ptyp_desc) decl.ptype_params
+  in
+  let decl =
+    type_declaration
+      ~name:{ txt = "t"; loc = Location.none }
+      ~params:(List.init 3 (fun _ -> ptyp_any, (NoVariance, NoInjectivity)))
+      ~cstrs:[]
+      ~kind:Ptype_abstract
+      ~private_:Public
+      ~manifest:None
+  in
+  params decl, params (name_type_params_in_td decl)
+[%%expect{|
+- : core_type_desc list * core_type_desc list =
+([Ptyp_any; Ptyp_any; Ptyp_any],
+ [Ptyp_var "a__003_"; Ptyp_var "b__004_"; Ptyp_var "c__005_"])
+|}]

unikernel/duniverse/ppxlib/test/code_path/dune

@@ -0,0 +1,14 @@
+(rule
+ (package ppxlib)
+ (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)))))

unikernel/duniverse/ppxlib/test/code_path/test.ml

@@ -0,0 +1,160 @@
+open Ppxlib
+
+let sexp_of_code_path code_path =
+  Sexplib0.Sexp.message
+    "code_path"
+    [ "main_module_name", Sexplib0.Sexp_conv.sexp_of_string (Code_path.main_module_name code_path)
+    ; "submodule_path", Sexplib0.Sexp_conv.sexp_of_list Sexplib0.Sexp_conv.sexp_of_string (Code_path.submodule_path code_path)
+    ; "enclosing_module", Sexplib0.Sexp_conv.sexp_of_string (Code_path.enclosing_module code_path)
+    ; "enclosing_value", Sexplib0.Sexp_conv.sexp_of_option Sexplib0.Sexp_conv.sexp_of_string (Code_path.enclosing_value code_path)
+    ; "value", Sexplib0.Sexp_conv.sexp_of_option Sexplib0.Sexp_conv.sexp_of_string (Code_path.value code_path)
+    ; "fully_qualified_path", Sexplib0.Sexp_conv.sexp_of_string (Code_path.fully_qualified_path code_path)
+    ]
+
+let () =
+  Driver.register_transformation "test"
+    ~extensions:[
+      Extension.V3.declare "code_path"
+        Expression
+        Ast_pattern.(pstr nil)
+        (fun ~ctxt ->
+           let loc = Expansion_context.Extension.extension_point_loc ctxt in
+           let code_path = Expansion_context.Extension.code_path ctxt in
+           Ast_builder.Default.estring ~loc
+             (Sexplib0.Sexp.to_string (sexp_of_code_path code_path)))
+    ]
+[%%expect{|
+val sexp_of_code_path : Code_path.t -> Sexplib0.Sexp.t = <fun>
+|}]
+
+let s =
+  let module A = struct
+    module A' = struct
+      let a =
+        let module B = struct
+          module B' = struct
+            let b =
+              let module C = struct
+                module C' = struct
+                  let c = [%code_path]
+                end
+              end
+              in C.C'.c
+          end
+        end
+        in B.B'.b
+    end
+  end
+  in A.A'.a
+;;
+[%%expect{|
+val s : string =
+  "(code_path(main_module_name Test)(submodule_path())(enclosing_module C')(enclosing_value(c))(value(s))(fully_qualified_path Test.s))"
+|}]
+
+let module M = struct
+  let m = [%code_path]
+  end
+  in
+  M.m
+[%%expect{|
+- : string =
+"(code_path(main_module_name Test)(submodule_path())(enclosing_module M)(enclosing_value(m))(value())(fully_qualified_path Test))"
+|}]
+
+module Outer = struct
+  module Inner = struct
+    let code_path = [%code_path]
+  end
+end
+let _ = Outer.Inner.code_path
+[%%expect{|
+module Outer : sig module Inner : sig val code_path : string end end
+- : string =
+"(code_path(main_module_name Test)(submodule_path(Outer Inner))(enclosing_module Inner)(enclosing_value(code_path))(value(code_path))(fully_qualified_path Test.Outer.Inner.code_path))"
+|}]
+
+module Functor() = struct
+  let code_path = ref ""
+  module _ = struct
+    let x =
+      let module First_class = struct
+        code_path := [%code_path]
+      end in
+      let module _ = First_class in
+      ()
+    ;;
+
+    ignore x
+  end
+end
+let _ = let module M = Functor() in !M.code_path
+[%%expect_in <= 5.2 {|
+module Functor : functor () -> sig val code_path : string ref end
+- : string =
+"(code_path(main_module_name Test)(submodule_path(Functor _))(enclosing_module First_class)(enclosing_value(x))(value(x))(fully_qualified_path Test.Functor._.x))"
+|}]
+[%%expect_in >= 5.3 {|
+module Functor : () -> sig val code_path : string ref end
+- : string =
+"(code_path(main_module_name Test)(submodule_path(Functor _))(enclosing_module First_class)(enclosing_value(x))(value(x))(fully_qualified_path Test.Functor._.x))"
+|}]
+
+module Actual = struct
+  let code_path = [%code_path]
+end [@enter_module Dummy]
+let _ = Actual.code_path
+[%%expect{|
+module Actual : sig val code_path : string end
+- : string =
+"(code_path(main_module_name Test)(submodule_path(Actual Dummy))(enclosing_module Dummy)(enclosing_value(code_path))(value(code_path))(fully_qualified_path Test.Actual.Dummy.code_path))"
+|}]
+
+module Ignore_me = struct
+  let code_path = [%code_path]
+end [@@do_not_enter_module]
+let _ = Ignore_me.code_path
+[%%expect{|
+module Ignore_me : sig val code_path : string end
+- : string =
+"(code_path(main_module_name Test)(submodule_path())(enclosing_module Test)(enclosing_value(code_path))(value(code_path))(fully_qualified_path Test.code_path))"
+|}]
+
+let _ =
+  (let module Ignore_me = struct
+     let code_path = [%code_path]
+   end
+   in
+   Ignore_me.code_path)
+  [@do_not_enter_module]
+[%%expect{|
+- : string =
+"(code_path(main_module_name Test)(submodule_path())(enclosing_module Test)(enclosing_value(code_path))(value())(fully_qualified_path Test))"
+|}]
+
+let _ = ([%code_path] [@ppxlib.enter_value dummy])
+[%%expect{|
+- : string =
+"(code_path(main_module_name Test)(submodule_path())(enclosing_module Test)(enclosing_value(dummy))(value(dummy))(fully_qualified_path Test.dummy))"
+|}]
+
+let _ =
+  let ignore_me = [%code_path]
+  [@@do_not_enter_value]
+  in
+  ignore_me
+[%%expect{|
+- : string =
+"(code_path(main_module_name Test)(submodule_path())(enclosing_module Test)(enclosing_value())(value())(fully_qualified_path Test))"
+|}]
+
+
+let _ =
+  (* The main module name should properly remove all extensions *)
+  let code_path =
+    Code_path.top_level ~file_path:"some_dir/module_name.cppo.ml"
+  in
+  Code_path.main_module_name code_path
+[%%expect{|
+- : string = "Module_name"
+|}]

unikernel/duniverse/ppxlib/test/deriving/dune

@@ -0,0 +1,14 @@
+(rule
+ (package ppxlib)
+ (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)))))

unikernel/duniverse/ppxlib/test/deriving/inline/example/dune

@@ -0,0 +1,9 @@
+(library
+ (name ppx_deriving_example)
+ (preprocess
+  (pps ppx_foo_deriver)))
+
+(alias
+ (package ppxlib)
+ (name runtest)
+ (deps ppx_deriving_example.cma))

unikernel/duniverse/ppxlib/test/deriving/inline/example/ppx_deriving_example.ml

@@ -0,0 +1,16 @@
+type t = A [@@deriving_inline foo]
+
+include struct
+  [@@@ocaml.warning "-60"]
+
+  let _ = fun (_ : t) -> ()
+
+  module Foo = struct end
+
+  let _ =
+    ();
+    ();
+    [%foo]
+end [@@ocaml.doc "@inline"]
+
+[@@@inline.end]

unikernel/duniverse/ppxlib/test/deriving/inline/foo-deriver/dune

@@ -0,0 +1,5 @@
+(library
+ (package ppxlib)
+ (kind ppx_deriver)
+ (name ppx_foo_deriver)
+ (libraries ppxlib))

unikernel/duniverse/ppxlib/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml

@@ -0,0 +1,99 @@
+open Ppxlib
+open Ast_builder.Default
+
+(*
+   [[@@deriving foo]] expands to:
+   {[
+     module Foo = struct end
+
+     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 = [];
+            pexp_loc_stack = [];
+          }
+        in
+        [
+          {
+            pstr_loc = loc;
+            pstr_desc =
+              Pstr_module
+                {
+                  pmb_loc = loc;
+                  pmb_name = { loc; txt = Some "Foo" };
+                  pmb_expr =
+                    {
+                      pmod_loc = loc;
+                      pmod_desc = Pmod_structure [];
+                      pmod_attributes = [];
+                    };
+                  pmb_attributes = [];
+                };
+          };
+          {
+            pstr_loc = loc;
+            pstr_desc =
+              Pstr_value
+                ( Nonrecursive,
+                  [
+                    {
+                      pvb_pat =
+                        {
+                          ppat_desc = Ppat_any;
+                          ppat_loc = loc;
+                          ppat_attributes = [];
+                          ppat_loc_stack = [];
+                        };
+                      pvb_expr =
+                        esequence ~loc
+                          [
+                            eunit ~loc;
+                            eunit ~loc;
+                            expr
+                              (Pexp_extension ({ loc; txt = "foo" }, PStr []));
+                          ];
+                      pvb_attributes = [];
+                      pvb_loc = loc;
+                      pvb_constraint = None;
+                    };
+                  ] );
+          };
+        ])
+      ~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", loc, None));
+                 pexp_loc = loc;
+                 pexp_attributes = [];
+                 pexp_loc_stack = [];
+               }));
+      ]
+
+let (_ : Deriving.t) = add_deriver ()

unikernel/duniverse/ppxlib/test/deriving/test.ml

@@ -0,0 +1,101 @@
+open Ppxlib
+
+
+let foo =
+  Deriving.add "foo"
+    ~str_type_decl:(Deriving.Generator.make_noarg
+                      (fun ~loc ~path:_ _ -> [%str let foo = 42]))
+    ~sig_type_decl:(Deriving.Generator.make_noarg
+                      (fun ~loc ~path:_ _ -> [%sig: val foo : int]))
+[%%expect{|
+val foo : Deriving.t = <abstr>
+|}]
+
+let bar =
+  Deriving.add "bar"
+    ~str_type_decl:(Deriving.Generator.make_noarg
+                      ~deps:[foo]
+                      (fun ~loc ~path:_ _ -> [%str let bar = foo + 1]))
+[%%expect{|
+val bar : Deriving.t = <abstr>
+|}]
+
+let mtd =
+  Deriving.add "mtd"
+    ~sig_module_type_decl:(
+      Deriving.Generator.make_noarg
+        (fun ~loc ~path:_ _ -> [%sig: val y : int]))
+    ~str_module_type_decl:(
+      Deriving.Generator.make_noarg
+        (fun ~loc ~path:_ _ -> [%str let y = 42]))
+[%%expect{|
+val mtd : Deriving.t = <abstr>
+|}]
+
+let cd =
+  Deriving.add "cd"
+    ~sig_class_type_decl:(Deriving.Generator.make_noarg (fun ~loc ~path:_ _ -> [%sig: val y : int]))
+    ~str_class_type_decl:(Deriving.Generator.make_noarg (fun ~loc ~path:_ _ -> [%str let y = 42]))
+[%%expect{|
+val cd : Deriving.t = <abstr>
+|}]
+
+type t = int [@@deriving bar, foo]
+[%%expect{|
+Line _, characters 25-33:
+Error: Deriver foo is needed for bar, you need to add it before in the list
+|}]
+
+type nonrec int = int [@@deriving foo, bar]
+[%%expect{|
+type nonrec int = int
+val foo : int = 42
+val bar : int = 43
+|}]
+
+module type Foo_sig = sig
+  type t [@@deriving foo]
+end
+[%%expect{|
+module type Foo_sig = sig type t val foo : int end
+|}]
+
+module type X = sig end [@@deriving mtd]
+[%%expect{|
+module type X = sig end
+val y : int = 42
+|}]
+
+module Y : sig
+  module type X = sig end [@@deriving mtd]
+end = struct
+  module type X = sig end
+  let y = 42
+end
+[%%expect{|
+module Y : sig module type X = sig end val y : int end
+|}]
+
+class type x = object end[@@deriving cd]
+[%%expect{|
+class type x = object  end
+val y : int = 42
+|}]
+
+
+let mbmd =
+  Deriving.add "mbmd"
+    ~sig_module_decl:(Deriving.Generator.make_noarg (fun ~loc ~path:_ _ -> [%sig: val y : int]))
+    ~str_module_binding:(Deriving.Generator.make_noarg (fun ~loc ~path:_ _ -> [%str let y = 42]))
+
+[%%expect{|
+val mbmd : Deriving.t = <abstr>
+|}]
+
+module X = struct
+  type t
+end[@@deriving mbmd]
+[%%expect{|
+module X : sig type t end
+val y : int = 42
+|}]

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

@@ -0,0 +1,97 @@
+open Ppxlib
+
+let () =
+  let unused_code_warnings = true in
+  Deriving.add "zero_do_warn"
+    ~str_type_decl:
+      (Deriving.Generator.make_noarg ~unused_code_warnings
+         (fun ~loc ~path:_ _ ->
+           [%str
+             module Zero = struct
+               type t = T0
+             end
+
+             let zero = Zero.T0]))
+    ~sig_type_decl:
+      (Deriving.Generator.make_noarg ~unused_code_warnings
+         (fun ~loc ~path:_ _ ->
+           [%sig:
+             module Zero : sig
+               type t
+             end
+
+             val zero : Zero.t]))
+  |> Deriving.ignore
+
+let () =
+  let unused_code_warnings = false in
+  Deriving.add "one_no_warn"
+    ~str_type_decl:
+      (Deriving.Generator.make_noarg ~unused_code_warnings
+         (fun ~loc ~path:_ _ ->
+           [%str
+             module One = struct
+               type 'a t = T1 of 'a
+             end
+
+             let one = One.T1 zero]))
+    ~sig_type_decl:
+      (Deriving.Generator.make_noarg ~unused_code_warnings
+         (fun ~loc ~path:_ _ ->
+           [%sig:
+             module One : sig
+               type 'a t
+             end
+
+             val one : Zero.t One.t]))
+  |> Deriving.ignore
+
+let () =
+  let unused_code_warnings = true in
+  Deriving.add "two_do_warn"
+    ~str_type_decl:
+      (Deriving.Generator.make_noarg ~unused_code_warnings
+         (fun ~loc ~path:_ _ ->
+           [%str
+             module Two = struct
+               type ('a, 'b) t = T2 of 'a * 'b
+             end
+
+             let two = Two.T2 (zero, one)]))
+    ~sig_type_decl:
+      (Deriving.Generator.make_noarg ~unused_code_warnings
+         (fun ~loc ~path:_ _ ->
+           [%sig:
+             module Two : sig
+               type ('a, 'b) t
+             end
+
+             val two : (Zero.t, Zero.t One.t) Two.t]))
+  |> Deriving.ignore
+
+let () =
+  let alias_do_warn =
+    let unused_code_warnings = true in
+    Deriving.add "alias_do_warn"
+      ~str_type_decl:
+        (Deriving.Generator.make_noarg ~unused_code_warnings
+           (fun ~loc ~path:_ _ -> [%str let unit_one = ()]))
+      ~sig_type_decl:
+        (Deriving.Generator.make_noarg ~unused_code_warnings
+           (fun ~loc ~path:_ _ -> [%sig: val unit_one : unit]))
+  in
+  let alias_no_warn =
+    let unused_code_warnings = false in
+    Deriving.add "alias_no_warn"
+      ~str_type_decl:
+        (Deriving.Generator.make_noarg ~unused_code_warnings
+           (fun ~loc ~path:_ _ -> [%str let unit_two = unit_one]))
+      ~sig_type_decl:
+        (Deriving.Generator.make_noarg ~unused_code_warnings
+           (fun ~loc ~path:_ _ -> [%sig: val unit_two : unit]))
+  in
+  (* The derivers are added from right to left *)
+  Deriving.add_alias "alias_warn" [ alias_no_warn; alias_do_warn ]
+  |> Deriving.ignore
+
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/deriving_warning/dune

@@ -0,0 +1,9 @@
+(executable
+ (name driver)
+ (libraries ppxlib)
+ (preprocess
+  (pps ppxlib.metaquot)))
+
+(cram
+ (package ppxlib)
+ (deps driver.exe))

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

@@ -0,0 +1,390 @@
+Ppxlib driver has a variety of ways to disable warnings that can be triggered
+when using `[@@deriving ...]`. These are all enabled by default but we added
+flags to let driver users disable them. To allow smooth transition from always
+adding them to never do so and let individual ppx-es do what they must to avoid
+triggering warnings, we also added optional arguments to `Deriving.make` so that
+the ppx themselves can declare whether they need the driver to disable warnings
+or not.
+
+The following tests describe the behaviour of flags and features used to control
+the emission of such warning silencing features.
+
+One such flag and optional argument pair is the `-unused-code-warnings` flag and
+`?unused_code_warning` `Deriving.V2.make` argument. Both of those default to
+`false` and control whether we disable warnings 32, 34 and 60 for generated code
+and behave as described by the following table:
+
+ Deriver arg | Driver Flag | Unused Code Warnings
+-------------|-------------|----------------------
+ true        | true        | Enabled
+ true        | false       | Disabled*
+ true        | force       | Enabled
+ false       | true        | Disabled
+ false       | false       | Disabled
+ false       | force       | Enabled
+* By adding warning silencers like [@@@ocaml.waring "-60"] or producing code like
+`let _ = zero in...` or `let _ = fun (_ : t) -> ()`.
+
+We have a driver with 4 derivers linked in:
+- zero_do_warn
+- one_no_warn
+- two_do_warn
+- alias_warn
+
+--------------------------------------------------------------------------------
+
+Let's consider the following ocaml source file using the zero_do_warn deriver
+
+  $ cat > zero_do_warn.ml << EOF
+  > type t = int [@@deriving zero_do_warn]
+  > EOF
+
+Zero_do_warn is registered with unused_code_warning set to true meaning it allows
+the driver not to silence unused code and unused module warnings if the
+-unused-code-warning flag is set to true.
+
+Let's call the driver with -unused-code-warnings=false:
+
+  $ ./driver.exe -unused-code-warnings=false -impl zero_do_warn.ml
+  type t = int[@@deriving zero_do_warn]
+  include struct let _ = fun (_ : t) -> () end[@@ocaml.doc "@inline"][@@merlin.hide
+                                                                      ]
+  include
+    struct
+      [@@@ocaml.warning "-60"]
+      module Zero = struct type t =
+                             | T0  end
+      let zero = Zero.T0
+      let _ = zero
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+The generated code is wrapped in an include struct ... end to disable unused module
+warnings, as expected. The derived value zero is followed by a let _ = zero to
+disable unused value warning, and the type is used by `let _ = fun (_ : t) -> ()`.
+
+Now if we use -unused-code-warnings=true:
+
+  $ ./driver.exe -unused-code-warnings=true -impl zero_do_warn.ml
+  type t = int[@@deriving zero_do_warn]
+  include struct module Zero = struct type t =
+                                        | T0  end
+                 let zero = Zero.T0 end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+Here the warning silencing was disabled as it was both allowed by the driver
+invocation and the deriver itself. No include wrapping, no warning disabled, no
+let _.
+
+Note that this also applies to .mli files.
+
+Consider:
+
+  $ cat > zero_do_warn.mli << EOF
+  > type t = int [@@deriving zero_do_warn]
+  > EOF
+
+and compare the result of both driver invocations:
+
+  $ ./driver.exe -unused-code-warnings=false -intf zero_do_warn.mli
+  type t = int[@@deriving zero_do_warn]
+  include
+    sig
+      [@@@ocaml.warning "-32-60"]
+      module Zero : sig type t end
+      val zero : Zero.t
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+  $ ./driver.exe -unused-code-warnings=true -intf zero_do_warn.mli
+  type t = int[@@deriving zero_do_warn]
+  include sig module Zero : sig type t end val zero : Zero.t end[@@ocaml.doc
+                                                                  "@inline"]
+  [@@merlin.hide ]
+
+--------------------------------------------------------------------------------
+
+The default value of the -unused-code-warnings should be false:
+
+  $ ./driver.exe -impl zero_do_warn.ml
+  type t = int[@@deriving zero_do_warn]
+  include struct let _ = fun (_ : t) -> () end[@@ocaml.doc "@inline"][@@merlin.hide
+                                                                      ]
+  include
+    struct
+      [@@@ocaml.warning "-60"]
+      module Zero = struct type t =
+                             | T0  end
+      let zero = Zero.T0
+      let _ = zero
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+As we can see here, the warnings were disabled by the driver, as is expected
+with -unused-code-warnings=false.
+
+--------------------------------------------------------------------------------
+
+There is another value possible for the -unused-code-warnings flag: "force".
+This allows the warnings to be enabled even if the deriver does not allow it. In
+this example though, using `force` or `true` results in the same output, since
+the deriver `zero_do_warn` already allows the warning to be enabled.
+
+  $ ./driver.exe -unused-code-warnings=force -impl zero_do_warn.ml
+  type t = int[@@deriving zero_do_warn]
+  include struct module Zero = struct type t =
+                                        | T0  end
+                 let zero = Zero.T0 end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+We'll see below other examples where the `force` flag is actually useful.
+
+--------------------------------------------------------------------------------
+
+Let's consider the following ocaml source file using the one_no_warn deriver
+
+  $ cat > one_no_warn.ml << EOF
+  > type t = int [@@deriving one_no_warn]
+  > EOF
+
+One_no_warn is registered with unused_code_warning set to false, meaning the driver
+should disable warnings for the generated code, even when the value of the
+-unused-code-warning is set to true. The following driver invocations have the
+same output:
+
+  $ ./driver.exe -unused-code-warnings=false -impl one_no_warn.ml
+  type t = int[@@deriving one_no_warn]
+  include
+    struct
+      [@@@ocaml.warning "-60"]
+      let _ = fun (_ : t) -> ()
+      module One = struct type 'a t =
+                            | T1 of 'a  end
+      let one = One.T1 zero
+      let _ = one
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+  $ ./driver.exe -unused-code-warnings=true -impl one_no_warn.ml
+  type t = int[@@deriving one_no_warn]
+  include
+    struct
+      [@@@ocaml.warning "-60"]
+      let _ = fun (_ : t) -> ()
+      module One = struct type 'a t =
+                            | T1 of 'a  end
+      let one = One.T1 zero
+      let _ = one
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+Same goes for .mli files:
+
+  $ cat > one_no_warn.mli << EOF
+  > type t = int [@@deriving one_no_warn]
+  > EOF
+
+  $ ./driver.exe -unused-code-warnings=false -intf one_no_warn.mli
+  type t = int[@@deriving one_no_warn]
+  include
+    sig
+      [@@@ocaml.warning "-32-60"]
+      module One : sig type 'a t end
+      val one : Zero.t One.t
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+  $ ./driver.exe -unused-code-warnings=true -intf one_no_warn.mli
+  type t = int[@@deriving one_no_warn]
+  include
+    sig
+      [@@@ocaml.warning "-32-60"]
+      module One : sig type 'a t end
+      val one : Zero.t One.t
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+--------------------------------------------------------------------------------
+
+When using a deriving that does not allow the warning to be enabled (such as
+`one_no_warn` here), it is still possible to force it from the user side. That's
+what the `force` argument for the driver flag is for. See below:
+
+  $ ./driver.exe -unused-code-warnings=force -impl one_no_warn.ml
+  type t = int[@@deriving one_no_warn]
+  include
+    struct
+      module One = struct type 'a t =
+                            | T1 of 'a  end
+      let one = One.T1 zero
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+Same goes for .mli files:
+
+  $ ./driver.exe -unused-code-warnings=force -intf one_no_warn.mli
+  type t = int[@@deriving one_no_warn]
+  include sig module One : sig type 'a t end val one : Zero.t One.t end
+  [@@ocaml.doc "@inline"][@@merlin.hide ]
+
+--------------------------------------------------------------------------------
+
+The alias_warn deriver is in fact an alias for two derivers:
+- alias_do_warn, which is registered with unused_code_warnings=true
+and derives a single `unit_one : unit` value
+- alias_no_warn, which is registered with unused_code_warnings=false
+and derives a single `unit_two : unit` value
+
+For the following code:
+
+  $ cat > alias_warn.ml << EOF
+  > type t = int [@@deriving alias_warn]
+  > EOF
+
+We expect that the driver will do the right thing and disable the warning only for
+unit_one:
+
+  $ ./driver.exe -unused-code-warnings=true -impl alias_warn.ml
+  type t = int[@@deriving alias_warn]
+  include struct let _ = fun (_ : t) -> () end[@@ocaml.doc "@inline"][@@merlin.hide
+                                                                      ]
+  include struct let unit_one = () end[@@ocaml.doc "@inline"][@@merlin.hide ]
+  include struct let unit_two = unit_one
+                 let _ = unit_two end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+As expected, there is a let _ = unit_two but nothing for unit_one. Since unit_one does
+not allow the warning 34 to be enabled, you can see that the combination of both derivers
+still keeps the `let _ = fun (_ : t) -> ()` construct.
+
+If we turn off the unused-code-warnings flag, there will be a `let _ = ...` for both:
+
+  $ ./driver.exe -unused-code-warnings=false -impl alias_warn.ml
+  type t = int[@@deriving alias_warn]
+  include struct let _ = fun (_ : t) -> () end[@@ocaml.doc "@inline"][@@merlin.hide
+                                                                      ]
+  include struct let unit_one = ()
+                 let _ = unit_one end[@@ocaml.doc "@inline"][@@merlin.hide ]
+  include struct let unit_two = unit_one
+                 let _ = unit_two end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+As expected, if we force the unused-code-warnings, there will be no let _ for
+any of the two values, and no construct to use the type t:
+
+  $ ./driver.exe -unused-code-warnings=force -impl alias_warn.ml
+  type t = int[@@deriving alias_warn]
+  include struct let unit_one = () end[@@ocaml.doc "@inline"][@@merlin.hide ]
+  include struct let unit_two = unit_one end[@@ocaml.doc "@inline"][@@merlin.hide
+                                                                     ]
+
+Same goes for .mli:
+
+  $ cat > alias_warn.mli << EOF
+  > type t = int [@@deriving alias_warn]
+  > EOF
+
+  $ ./driver.exe -unused-code-warnings=true -intf alias_warn.mli
+  type t = int[@@deriving alias_warn]
+  include sig val unit_one : unit end[@@ocaml.doc "@inline"][@@merlin.hide ]
+  include sig [@@@ocaml.warning "-32"] val unit_two : unit end[@@ocaml.doc
+                                                                "@inline"]
+  [@@merlin.hide ]
+
+  $ ./driver.exe -unused-code-warnings=false -intf alias_warn.mli
+  type t = int[@@deriving alias_warn]
+  include sig [@@@ocaml.warning "-32"] val unit_one : unit end[@@ocaml.doc
+                                                                "@inline"]
+  [@@merlin.hide ]
+  include sig [@@@ocaml.warning "-32"] val unit_two : unit end[@@ocaml.doc
+                                                                "@inline"]
+  [@@merlin.hide ]
+
+  $ ./driver.exe -unused-code-warnings=force -intf alias_warn.mli
+  type t = int[@@deriving alias_warn]
+  include sig val unit_one : unit end[@@ocaml.doc "@inline"][@@merlin.hide ]
+  include sig val unit_two : unit end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+--------------------------------------------------------------------------------
+
+Whenever a set of types has a [@@deriving ...] attached, ppxlib's driver always
+generates structure items meant to disable unused type warnings (warning 34) for
+any of those types.
+
+Let's consider the following piece of OCaml code:
+
+  $ cat > unused_types.ml << EOF
+  > type t = int
+  > and u = string
+  > [@@deriving zero_do_warn]
+  > EOF
+
+If we run the driver:
+
+  $ ./driver.exe -impl unused_types.ml
+  type t = int
+  and u = string[@@deriving zero_do_warn]
+  include struct let _ = fun (_ : t) -> ()
+                 let _ = fun (_ : u) -> () end[@@ocaml.doc "@inline"][@@merlin.hide
+                                                                      ]
+  include
+    struct
+      [@@@ocaml.warning "-60"]
+      module Zero = struct type t =
+                             | T0  end
+      let zero = Zero.T0
+      let _ = zero
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+We can see that the driver generated two `let _ = fun (_ : ...`, one for each type
+in the set.
+
+As we mentioned before, the driver flag (`-unused-code-warnings`) allows the
+user to disable all warnings. In addition to this more general flag, we have a
+flag that disables only this part, and allows unused type warnings to be reported
+properly. Passing that flag to the driver should remove the two previously
+mentioned items, without affecting the rest of the generated anti-warning items:
+
+  $ ./driver.exe -unused-type-warnings=true -impl unused_types.ml
+  type t = int
+  and u = string[@@deriving zero_do_warn]
+  include
+    struct
+      [@@@ocaml.warning "-60"]
+      module Zero = struct type t =
+                             | T0  end
+      let zero = Zero.T0
+      let _ = zero
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+Similarly to `-unused-code-warnings`, it is possible to force disabling the generation
+of this construct even when the ppx generator does not allow it.
+
+For example, consider:
+
+  $ ./driver.exe -impl one_no_warn.ml
+  type t = int[@@deriving one_no_warn]
+  include
+    struct
+      [@@@ocaml.warning "-60"]
+      let _ = fun (_ : t) -> ()
+      module One = struct type 'a t =
+                            | T1 of 'a  end
+      let one = One.T1 zero
+      let _ = one
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+See how `-unused-type-warnings=true` does not affect the generated code:
+
+  $ ./driver.exe -unused-type-warnings=true -impl one_no_warn.ml
+  type t = int[@@deriving one_no_warn]
+  include
+    struct
+      [@@@ocaml.warning "-60"]
+      let _ = fun (_ : t) -> ()
+      module One = struct type 'a t =
+                            | T1 of 'a  end
+      let one = One.T1 zero
+      let _ = one
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+But if we force it, the driver omits the `let _ = fun (_ : t) -> ()`:
+
+  $ ./driver.exe -unused-type-warnings=force -impl one_no_warn.ml
+  type t = int[@@deriving one_no_warn]
+  include
+    struct
+      [@@@ocaml.warning "-60"]
+      module One = struct type 'a t =
+                            | T1 of 'a  end
+      let one = One.T1 zero
+      let _ = one
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]

unikernel/duniverse/ppxlib/test/driver/attributes/dune

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

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

@@ -0,0 +1,264 @@
+open Ppxlib
+
+let () = Driver.enable_checks ()
+
+let x = 1 [@@foo]
+[%%expect{|
+Line _, characters 13-16:
+Error: Attribute `foo' was not used
+|}]
+
+let f x = 1 [@@deprecatd "..."]
+[%%expect{|
+Line _, characters 15-24:
+Error: Attribute `deprecatd' was not used.
+       Hint: Did you mean deprecated?
+|}]
+
+let attr : _ Attribute.t =
+  Attribute.declare "blah"
+    Attribute.Context.type_declaration
+    Ast_pattern.(__)
+    ignore
+[%%expect{|
+val attr : (type_declaration, unit) Attribute.t = <abstr>
+|}]
+
+type t = int [@blah]
+[%%expect{|
+Line _, characters 15-19:
+Error: Attribute `blah' was not used.
+       Hint: `blah' is available for type declarations but is used here in
+       the
+       context of a core type.
+       Did you put it at the wrong level?
+|}]
+
+let attr : _ Attribute.t =
+  Attribute.declare "blah"
+    Attribute.Context.expression
+    Ast_pattern.(__)
+    ignore
+[%%expect{|
+val attr : (expression, unit) Attribute.t = <abstr>
+|}]
+
+type t = int [@blah]
+[%%expect{|
+Line _, characters 15-19:
+Error: Attribute `blah' was not used.
+       Hint: `blah' is available for expressions and type declarations but is
+       used
+       here in the context of a core type.
+       Did you put it at the wrong level?
+|}]
+
+let _ = () [@blah]
+[%%expect{|
+Line _, characters 13-17:
+Error: Attribute `blah' was not used
+|}]
+
+(* Attribute drops *)
+
+let faulty_transformation = object
+  inherit Ast_traverse.map as super
+
+  method! expression e =
+    match e.pexp_desc with
+    | Pexp_constant c ->
+      Ast_builder.Default.pexp_constant ~loc:e.pexp_loc c
+    | _ -> super#expression e
+end
+[%%expect{|
+val faulty_transformation : Ast_traverse.map = <obj>
+|}]
+
+let () =
+  Driver.register_transformation "faulty" ~impl:faulty_transformation#structure
+
+let x = (42 [@foo])
+[%%expect{|
+Line _, characters 14-17:
+Error: Attribute `foo' was silently dropped
+|}]
+
+type t1 = < >
+type t2 = < t1 >
+type t3 = < (t1[@foo]) >
+[%%expect{|
+type t1 = <  >
+type t2 = <  >
+Line _, characters 17-20:
+Error: Attribute `foo' was not used
+|}]
+
+(* Reserved Namespaces *)
+
+(* ppxlib checks that unreserved attributes aren't dropped *)
+
+let x = (42 [@bar])
+[%%expect{|
+Line _, characters 14-17:
+Error: Attribute `bar' was silently dropped
+|}]
+
+let x = (42 [@bar.baz])
+[%%expect{|
+Line _, characters 14-21:
+Error: Attribute `bar.baz' was silently dropped
+|}]
+
+(* But reserving a namespace disables those checks. *)
+
+let () = Reserved_namespaces.reserve "bar"
+
+let x = (42 [@bar])
+let x = (42 [@bar.baz])
+[%%expect{|
+val x : int = 42
+val x : int = 42
+|}]
+
+let x = (42 [@bar_not_proper_sub_namespace])
+[%%expect{|
+Line _, characters 14-42:
+Error: Attribute `bar_not_proper_sub_namespace' was silently dropped
+|}]
+
+(* The namespace reservation process understands dots as namespace
+   separators. *)
+
+let () = Reserved_namespaces.reserve "baz.qux"
+
+let x = (42 [@baz])
+[%%expect{|
+Line _, characters 14-17:
+Error: Attribute `baz' was silently dropped
+|}]
+
+let x = (42 [@baz.qux])
+[%%expect{|
+val x : int = 42
+|}]
+
+let x = (42 [@baz.qux.quux])
+[%%expect{|
+val x : int = 42
+|}]
+
+let x = (42 [@baz.qux_not_proper_sub_namespace])
+[%%expect{|
+Line _, characters 14-46:
+Error: Attribute `baz.qux_not_proper_sub_namespace' was silently dropped
+|}]
+
+(* You can reserve multiple subnamespaces under the same namespace *)
+
+let () = Reserved_namespaces.reserve "baz.qux2"
+
+let x = (42 [@baz.qux])
+let x = (42 [@baz.qux2])
+[%%expect{|
+val x : int = 42
+val x : int = 42
+|}]
+
+let x = (42 [@baz.qux3])
+[%%expect{|
+Line _, characters 14-22:
+Error: Attribute `baz.qux3' was silently dropped
+|}]
+
+(* Testing flags *)
+
+let flag = Attribute.declare_flag "flag" Attribute.Context.expression
+[%%expect{|
+val flag : expression Attribute.flag = <abstr>
+|}]
+
+let extend name f =
+  let ext =
+    Extension.V3.declare
+      name
+      Expression
+      Ast_pattern.(single_expr_payload __)
+      (fun ~ctxt:_ e -> f e)
+  in
+  Driver.register_transformation name ~rules:[ Context_free.Rule.extension ext ]
+[%%expect{|
+val extend : string -> (expression -> expression) -> unit = <fun>
+|}]
+
+let () =
+  extend "flagged" (fun e ->
+    if Attribute.has_flag flag e
+    then e
+    else Location.raise_errorf ~loc:e.pexp_loc "flag not found")
+
+let e1 = [%flagged "Absent flag"]
+[%%expect{|
+Line _, characters 19-32:
+Error: flag not found
+|}]
+
+let e2 = [%flagged "Found flag" [@flag]]
+[%%expect{|
+val e2 : string = "Found flag"
+|}]
+
+let e3 = [%flagged "Misused flag" [@flag 12]]
+[%%expect{|
+Line _, characters 41-43:
+Error: [] expected
+|}]
+
+(* Testing attribute in trivial transformation *)
+
+open Ast_builder.Default
+
+let flagged e =
+  let loc = e.pexp_loc in
+  pexp_extension ~loc ({ loc; txt = "flagged" }, PStr [pstr_eval ~loc e []])
+[%%expect{|
+val flagged : expression -> expression = <fun>
+|}]
+
+let () = extend "simple" flagged
+
+let e = [%simple "flagged" [@flag]]
+[%%expect{|
+val e : string = "flagged"
+|}]
+
+(* When duplicating code, apply [ghost] to all but one copy. *)
+
+let ghost = object
+  inherit Ast_traverse.map
+  method! location l = { l with loc_ghost = true }
+end
+[%%expect{|
+val ghost : Ast_traverse.map = <obj>
+|}]
+
+(* Test attribute lookup in non-ghosted subexpression. *)
+
+let () =
+  extend "flag_alive" (fun e ->
+    pexp_tuple ~loc:e.pexp_loc [ flagged e; ghost#expression e ])
+
+let e = [%flag_alive "hello" [@flag]]
+[%%expect{|
+val e : string * string = ("hello", "hello")
+|}]
+
+(* Test attribute lookup in ghosted subexpression. *)
+
+let () =
+  extend "flag_ghost" (fun e ->
+    pexp_tuple ~loc:e.pexp_loc [ e; flagged (ghost#expression e) ])
+
+let e = [%flag_ghost "bye" [@flag]]
+[%%expect{|
+val e : string * string = ("bye", "bye")
+|}]

unikernel/duniverse/ppxlib/test/driver/compiler-pp/driver.ml

@@ -0,0 +1,34 @@
+open Ppxlib
+
+let existential ~loc =
+  let lident = { loc; txt = Longident.parse "Constructor" } in
+  let pattern =
+    {
+      ppat_loc = loc;
+      ppat_loc_stack = [];
+      ppat_attributes = [];
+      ppat_desc =
+        Ppat_construct (lident, Some ([ { loc; txt = "a" } ], [%pat? _]));
+    }
+  in
+  [%stri let f x = match x with [%p pattern] -> ()]
+
+let named_existential =
+  Context_free.Rule.extension
+    (Extension.V3.declare "named_existentials" Extension.Context.structure_item
+       Ast_pattern.(pstr nil)
+       (fun ~ctxt ->
+         let loc = Expansion_context.Extension.extension_point_loc ctxt in
+         existential ~loc))
+
+let () =
+  Driver.V2.register_transformation ~rules:[ named_existential ]
+    "named_existentials"
+
+let str_type_decl =
+  Deriving.Generator.V2.make_noarg (fun ~ctxt _type_decl ->
+      let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+      [ existential ~loc ])
+
+let _ = Deriving.add ~str_type_decl "named_existentials"
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/compiler-pp/dune

@@ -0,0 +1,16 @@
+(executable
+ (name driver)
+ (enabled_if
+  (and
+   (>= %{ocaml_version} "4.09")
+   (< %{ocaml_version} "4.13")))
+ (libraries ppxlib)
+ (preprocess
+  (pps ppxlib.metaquot)))
+
+(cram
+ (enabled_if
+  (and
+   (>= %{ocaml_version} "4.09")
+   (< %{ocaml_version} "4.13")))
+ (deps driver.exe))

unikernel/duniverse/ppxlib/test/driver/compiler-pp/run.t

@@ -0,0 +1,65 @@
+The --use-compiler-pp flag can be used when using the driver's source code
+output, either directly when generating a .corrected file or to force
+printing the AST as source using the installed compiler's printer.
+
+Our driver has a deriver and an extension that produces a pattern-matching with
+named existentials.
+
+This feature has been introduced in 4.13 so the syntax is unsupported before that.
+
+If we run the driver in source output mode, without the `--use-compiler-pp` flag,
+it will successfully print out the source using the 4.13 syntax. If we're running
+on an older compiler, like we are for this test, that can be troublesome.
+
+If instead we use the flag, this will force the migration thus causing an error as
+named existentials can't be migrated down to 4.12.
+
+Let's consider the following file:
+
+  $ cat > test.ml << EOF
+  > [%%named_existentials]
+  > EOF
+
+Running the driver will generate a function with a single pattern matching in it:
+
+  $ ./driver.exe test.ml
+  let f x = match x with | Constructor (type a) _ -> ()
+
+Now if we run it with `--use-compiler-pp`, we should get the migration error:
+
+  $ ./driver.exe --use-compiler-pp test.ml
+  File "test.ml", line 1, characters 0-22:
+  1 | [%%named_existentials]
+      ^^^^^^^^^^^^^^^^^^^^^^
+  Error: migration error: existentials in pattern-matching is not supported before OCaml 4.13
+  [1]
+
+This should also work for correction based code gen:
+
+  $ cat > test_inline.ml << EOF
+  > type t = int
+  > [@@deriving_inline named_existentials]
+  > [@@@end]
+  > EOF
+
+If we run the driver without `--use-compiler-pp`:
+
+  $ ./driver.exe test_inline.ml -diff-cmd -
+  type t = int[@@deriving_inline named_existentials]
+  [@@@end ]
+  $ cat test_inline.ml.ppx-corrected
+  type t = int
+  [@@deriving_inline named_existentials]
+  let _ = fun (_ : t) -> ()
+  let f x = match x with | Constructor (type a) _ -> ()
+  let _ = f
+  [@@@end]
+
+and with the flag:
+
+  $ ./driver.exe test_inline.ml -diff-cmd - --use-compiler-pp
+  File "test_inline.ml", lines 1-2, characters 0-38:
+  1 | type t = int
+  2 | [@@deriving_inline named_existentials]
+  Error: migration error: existentials in pattern-matching is not supported before OCaml 4.13
+  [1]

unikernel/duniverse/ppxlib/test/driver/error_embedding/dune

@@ -0,0 +1,7 @@
+(executables
+ (names raiser pp)
+ (libraries ppxlib))
+
+(cram
+ (package ppxlib)
+ (deps raiser.exe pp.exe))

unikernel/duniverse/ppxlib/test/driver/error_embedding/pp.ml

@@ -0,0 +1 @@
+let () = Ppxlib.Location.raise_errorf "Raising inside the preprocessor"

unikernel/duniverse/ppxlib/test/driver/error_embedding/raiser.ml

@@ -0,0 +1,13 @@
+open Ppxlib
+
+let rule =
+  let expand ~loc ~path:_ =
+    Location.raise_errorf ~loc "Raising inside the rewriter"
+  in
+  Extension.declare "raise" Extension.Context.expression
+    Ast_pattern.(pstr nil)
+    expand
+  |> Context_free.Rule.extension
+
+let () = Driver.register_transformation ~rules:[ rule ] "test"
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/error_embedding/test.t/run.t

@@ -0,0 +1,54 @@
+Keep the error output short in order to avoid different error output between
+different compiler versions in the subsequent tests
+
+  $ export OCAML_ERROR_STYLE=short
+
+With the `-embed-errors` options, if a PPX raises, the first such exception
+is caught and prepended to the last valid AST
+
+  $ echo "let _ = [%raise]" > impl.ml
+  $ ../raiser.exe -embed-errors impl.ml
+  let _ = [%ocaml.error "Raising inside the rewriter"]
+
+The same is true when using the `-as-ppx` mode (note that the error is reported
+by ocaml itself)
+
+  $ ocaml -ppx '../raiser.exe -as-ppx' impl.ml
+  File "./impl.ml", line 1, characters 8-16:
+  Error: Raising inside the rewriter
+  [2]
+
+Also exceptions raised in a preprocessor get embedded into an AST(while the
+error from the preprocessor's stderr also gets reported on the driver's stderr)
+
+  $ touch file.ml
+  $ ../raiser.exe -embed-errors -pp ../pp.exe file.ml | sed "s/> '.*'/> tmpfile/"
+  Fatal error: exception Raising inside the preprocessor
+  [%%ocaml.error
+    "Error while running external preprocessor\nCommand line: ../pp.exe 'file.ml' > tmpfile\n"]
+
+Also `unknown version` errors are embedded into an AST when using the
+main standalone
+
+  $ ../raiser.exe -embed-errors -intf unknown_version_binary_ast
+  [%%ocaml.error
+    "File is a binary ast for an unknown version of OCaml with magic number 'Caml1999N012'"]
+
+... but the `-as-ppx` standalone raises them
+
+  $ ../raiser.exe -as-ppx unknown_version_binary_ast output
+  File "unknown_version_binary_ast", line 1:
+  Error: The input is a binary ast for an unknown version of OCaml with magic number 'Caml1999N012'
+  [1]
+
+Similar for 'input doesn't exist' errors: they get embedded by the main standalone...
+
+  $ ../raiser.exe -embed-errors -impl non_existing_file
+  [%%ocaml.error "I/O error: non_existing_file: No such file or directory"]
+
+... but not by the `-as-ppx` standalone
+
+  $ ../raiser.exe -as-ppx non_existing_file output
+  File "non_existing_file", line 1:
+  Error: I/O error: non_existing_file: No such file or directory
+  [1]

unikernel/duniverse/ppxlib/test/driver/exception_handling/constant_type.ml

@@ -0,0 +1,13 @@
+open Ppxlib
+
+let kind = Context_free.Rule.Constant_kind.Integer
+
+let rewriter loc s =
+  Location.raise_errorf ~loc
+    "A raised located error in the constant rewriting transformation." s
+
+let rule = Context_free.Rule.constant kind 'g' rewriter;;
+
+Driver.register_transformation ~rules:[ rule ] "constant"
+
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/exception_handling/deriver.ml

@@ -0,0 +1,59 @@
+open Ppxlib
+
+let generate_impl_extension_node ~ctxt (_rec_flag, _type_declarations) =
+  let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+  let extension_node =
+    Location.error_extensionf ~loc "An error message in an extension node"
+  in
+  [ Ast_builder.Default.pstr_extension ~loc extension_node [] ]
+
+let generate_impl_located_error ~ctxt (_rec_flag, _type_declarations) =
+  let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+  Location.raise_errorf ~loc "A raised located error"
+
+let generate_impl_located_error2 ~ctxt (_rec_flag, _type_declarations) =
+  let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+  Location.raise_errorf ~loc "A second raised located error"
+
+let generate_impl_raised_exception ~ctxt:_ (_rec_flag, _type_declarations) =
+  failwith "A raised exception"
+
+let generate_impl_raised_exception2 ~ctxt:_ (_rec_flag, _type_declarations) =
+  failwith "A Second raised exception"
+
+let impl_generator_extension_node =
+  Deriving.Generator.V2.make_noarg generate_impl_extension_node
+
+let impl_generator_located_error =
+  Deriving.Generator.V2.make_noarg generate_impl_located_error
+
+let impl_generator_located_error2 =
+  Deriving.Generator.V2.make_noarg generate_impl_located_error2
+
+let impl_generator_raised_exception =
+  Deriving.Generator.V2.make_noarg generate_impl_raised_exception
+
+let impl_generator_raised_exception2 =
+  Deriving.Generator.V2.make_noarg generate_impl_raised_exception2
+
+let _ =
+  Deriving.add "deriver_extension_node"
+    ~str_type_decl:impl_generator_extension_node
+
+let _ =
+  Deriving.add "deriver_located_error"
+    ~str_type_decl:impl_generator_located_error
+
+let _ =
+  Deriving.add "deriver_located_error2"
+    ~str_type_decl:impl_generator_located_error2
+
+let _ =
+  Deriving.add "deriver_raised_exception"
+    ~str_type_decl:impl_generator_raised_exception
+
+let _ =
+  Deriving.add "deriver_raised_exception2"
+    ~str_type_decl:impl_generator_raised_exception2
+
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/exception_handling/dune

@@ -0,0 +1,23 @@
+(executables
+ (names
+  whole_file_exception
+  whole_file_extension_point
+  whole_file_located_error
+  extender
+  deriver
+  whole_file_multiple_errors
+  constant_type
+  special_functions)
+ (libraries ppxlib))
+
+(cram
+ (package ppxlib)
+ (deps
+  extender.exe
+  whole_file_exception.exe
+  whole_file_located_error.exe
+  deriver.exe
+  whole_file_extension_point.exe
+  whole_file_multiple_errors.exe
+  constant_type.exe
+  special_functions.exe))

unikernel/duniverse/ppxlib/test/driver/exception_handling/extender.ml

@@ -0,0 +1,50 @@
+open Ppxlib
+
+let expand_into_extension_node ~ctxt =
+  let loc = Expansion_context.Extension.extension_point_loc ctxt in
+  let extension_node =
+    Location.error_extensionf ~loc "An error message in an extension node"
+  in
+  Ast_builder.Default.pexp_extension ~loc extension_node
+
+let expand_raise_exception ~ctxt:_ = failwith "A raised exception"
+
+let expand_raise_located_error ~ctxt =
+  let loc = Expansion_context.Extension.extension_point_loc ctxt in
+  Location.raise_errorf ~loc "A raised located error"
+
+let expand_raise_located_error2 ~ctxt =
+  let loc = Expansion_context.Extension.extension_point_loc ctxt in
+  Location.raise_errorf ~loc "A second raised located error"
+
+let extension_point_extension =
+  Extension.V3.declare "gen_ext_node" Extension.Context.expression
+    Ast_pattern.(pstr nil)
+    expand_into_extension_node
+
+let raise_exception_extension =
+  Extension.V3.declare "gen_raise_exc" Extension.Context.expression
+    Ast_pattern.(pstr nil)
+    expand_raise_exception
+
+let raise_located_error_extension =
+  Extension.V3.declare "gen_raise_located_error" Extension.Context.expression
+    Ast_pattern.(pstr nil)
+    expand_raise_located_error
+
+let raise_located_error_extension2 =
+  Extension.V3.declare "gen_raise_located_error2" Extension.Context.expression
+    Ast_pattern.(pstr nil)
+    expand_raise_located_error2
+
+let rule1 = Ppxlib.Context_free.Rule.extension extension_point_extension
+let rule2 = Ppxlib.Context_free.Rule.extension raise_exception_extension
+let rule3 = Ppxlib.Context_free.Rule.extension raise_located_error_extension
+let rule4 = Ppxlib.Context_free.Rule.extension raise_located_error_extension2
+
+let () =
+  Driver.register_transformation
+    ~rules:[ rule1; rule2; rule3; rule4 ]
+    "gen_errors"
+
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/exception_handling/run.t

@@ -0,0 +1,231 @@
+In this test we verify the behavior of ppxlib with regard to rewriters
+error generations. We test both extenders, derivers and whole file
+rewriters.
+
+There is mainly three way for ppxs to handle errors, from best to
+worst practice:
+
+1. Putting an "error extension node" in the AST. In this test, the AST
+is rewritten to contain two of these nodes.
+
+ In the case of extenders
+
+  $ echo "let _ = [%gen_ext_node] + [%gen_ext_node]" > impl.ml
+  $ ./extender.exe impl.ml
+  let _ =
+    ([%ocaml.error "An error message in an extension node"]) +
+      ([%ocaml.error "An error message in an extension node"])
+
+ In the case of derivers
+
+  $ echo "type a = int [@@deriving deriver_extension_node]" > impl.ml
+  $ ./deriver.exe impl.ml
+  type a = int[@@deriving deriver_extension_node]
+  include
+    struct
+      let _ = fun (_ : a) -> ()
+      [%%ocaml.error "An error message in an extension node"]
+    end[@@ocaml.doc "@inline"][@@merlin.hide ]
+
+ In the case of whole file transformations:
+
+  $ echo "let x = 1+1. " > impl.ml
+  $ ./whole_file_extension_point.exe impl.ml
+  [%%ocaml.error "An error message in an extension node"]
+
+(Note that Merlin will notify all errors, while the compiler only
+notifies the first.)
+
+2. Raising a located error. In these tests, such an error is raised
+during the rewritting of the AST. By default, the exception is not
+caught, so no AST is produced.
+
+ In the case of extenders:
+
+  $ echo "let x = 1+1. " > impl.ml
+  $ echo "let _ = [%gen_raise_located_error]" >> impl.ml
+  $ echo "let _ = [%gen_raise_located_error2]" >> impl.ml
+  $ export OCAML_ERROR_STYLE=short
+
+ when the -embed-errors flag is not passed  
+  $ ./extender.exe impl.ml
+  File "impl.ml", line 2, characters 8-34:
+  Error: A raised located error
+  [1]
+
+
+ when the -embed-errors flag is  passed
+  $ ./extender.exe -embed-errors impl.ml
+  let x = 1 + 1.
+  let _ = [%ocaml.error "A raised located error"]
+  let _ = [%ocaml.error "A second raised located error"]
+
+ In the case of derivers
+
+  $ echo "type a = int" > impl.ml
+  $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml
+  $ echo "type c = int [@@deriving deriver_located_error2]" >> impl.ml
+
+ when the -embed-errors flag is not passed  
+  $ ./deriver.exe impl.ml
+  File "impl.ml", line 2, characters 0-47:
+  Error: A raised located error
+  [1]
+
+ when the -embed-errors flag is  passed
+  $ ./deriver.exe -embed-errors impl.ml
+  type a = int
+  type b = int[@@deriving deriver_located_error]
+  [%%ocaml.error "A raised located error"]
+  type c = int[@@deriving deriver_located_error2]
+  [%%ocaml.error "A second raised located error"]
+
+ In the case of whole file transformations:
+
+  $ echo "let x = 1+1. " > impl.ml
+  $ ./whole_file_located_error.exe impl.ml
+  File "impl.ml", line 1, characters 0-12:
+  Error: A located error in a whole file transform
+  [1]
+
+When the argument `-embed-errors` is added, the exception is caught
+and the whole AST is prepended with an error extension node.
+
+ In the case of extenders:
+
+  $ echo "let x = 1+1. " > impl.ml
+  $ echo "let _ = [%gen_raise_located_error]" >> impl.ml
+  $ echo "let _ = [%gen_raise_located_error2]" >> impl.ml
+
+when the -embed-errors flag is not passed
+  $ ./extender.exe impl.ml
+  File "impl.ml", line 2, characters 8-34:
+  Error: A raised located error
+  [1]
+
+ when the -embed-errors flag is  passed 
+  $ ./extender.exe -embed-errors impl.ml
+  let x = 1 + 1.
+  let _ = [%ocaml.error "A raised located error"]
+  let _ = [%ocaml.error "A second raised located error"]
+
+ In the case of derivers
+
+  $ echo "let x = 1+1. " > impl.ml
+  $ echo "type a = int" >> impl.ml
+  $ echo "type b = int [@@deriving deriver_located_error]" >> impl.ml
+  $ echo "type b = int [@@deriving deriver_located_error2]" >> impl.ml
+ 
+ when the -embed-errors flag is not passed 
+  $ ./deriver.exe impl.ml
+  File "impl.ml", line 3, characters 0-47:
+  Error: A raised located error
+  [1]
+ when the -embed-errors flag is passed 
+  $ ./deriver.exe -embed-errors impl.ml
+  let x = 1 + 1.
+  type a = int
+  type b = int[@@deriving deriver_located_error]
+  [%%ocaml.error "A raised located error"]
+  type b = int[@@deriving deriver_located_error2]
+  [%%ocaml.error "A second raised located error"]
+
+ In the case of whole file transformations:
+
+  $ echo "let x = 1+1. " > impl.ml
+  $ ./whole_file_located_error.exe -embed-errors impl.ml
+  [%%ocaml.error "A located error in a whole file transform"]
+  let x = 1 + 1.
+
+3. Raising an exception. The exception is not caught by the driver.
+
+ In the case of extensions:
+
+  $ echo "let _ = [%gen_raise_exc] + [%gen_raise_exc]" > impl.ml
+  $ ./extender.exe impl.ml
+  Fatal error: exception Failure("A raised exception")
+  [2]
+  $ ./extender.exe -embed-errors impl.ml
+  Fatal error: exception Failure("A raised exception")
+  [2]
+
+ In the case of derivers
+
+  $ echo "type a = int" > impl.ml
+  $ echo "type b = int [@@deriving deriver_raised_exception]" >> impl.ml
+  $ echo "type b = int [@@deriving deriver_raised_exception2]" >> impl.ml
+  $ ./deriver.exe -embed-errors impl.ml
+  Fatal error: exception Failure("A raised exception")
+  [2]
+
+ In the case of Constant types
+
+  $ echo "let x = 2g + 3g" > impl.ml
+  $ echo "let x = 2g + 3g" >> impl.ml
+
+ When embed-errors is not passed 
+  $ ./constant_type.exe impl.ml
+  File "impl.ml", line 1, characters 8-10:
+  Error: A raised located error in the constant rewriting transformation.
+  [1]
+
+ When embed-errors is not passed
+  $ ./constant_type.exe -embed-errors impl.ml
+  let x =
+    ([%ocaml.error
+       "A raised located error in the constant rewriting transformation."])
+      +
+      ([%ocaml.error
+         "A raised located error in the constant rewriting transformation."])
+  let x =
+    ([%ocaml.error
+       "A raised located error in the constant rewriting transformation."])
+      +
+      ([%ocaml.error
+         "A raised located error in the constant rewriting transformation."])
+
+ In the case of Special functions
+
+  $ echo "let x1 = n_args" > impl.ml
+  $ echo "let x2 = n_args2" >> impl.ml
+ When embed-errors is not passed 
+  $ ./special_functions.exe impl.ml
+  File "impl.ml", line 1, characters 9-15:
+  Error: error special function
+  [1]
+
+ When embed-errors is not passed
+  $ ./special_functions.exe -embed-errors impl.ml
+  let x1 = [%ocaml.error "error special function"]
+  let x2 = [%ocaml.error "second error special function"]
+
+ In the case of whole file transformations:
+
+  $ echo "let _ = [%gen_raise_exc] + [%gen_raise_exc]" > impl.ml
+  $ ./whole_file_exception.exe impl.ml
+  Fatal error: exception Failure("An exception in a whole file transform")
+  [2]
+  $ ./whole_file_exception.exe -embed-errors impl.ml
+  Fatal error: exception Failure("An exception in a whole file transform")
+  [2]
+
+
+4. Reporting Multiple Exceptions
+
+When the `-embed-error` flag is not set, exceptions stop the rewriting process. Therefore, only the first exception is reported to the user
+  $ ./whole_file_multiple_errors.exe impl.ml
+  File "impl.ml", line 1, characters 0-43:
+  Error: Raising a located exception during the first instrumentation phase
+  [1]
+
+When the `-embed-error` flag is set, located exceptions thrown during the rewriting process are caught, and collected. The "throwing transformations" are ignored. After all transformations have been applied, the collected errors are appended at the beginning of the AST.
+  $ echo 'let () = print_endline "Hello, World!" ' > impl.ml
+  $ ./whole_file_multiple_errors.exe -embed-errors impl.ml
+  [%%ocaml.error
+    "Raising a located exception during the first instrumentation phase"]
+  [%%ocaml.error
+    "Raising a located exception during the Global transformation phase"]
+  [%%ocaml.error
+    "Raising a located exception during the Last instrumentation phase"]
+  let () = print_endline "Hello, World!"
+

unikernel/duniverse/ppxlib/test/driver/exception_handling/special_functions.ml

@@ -0,0 +1,13 @@
+open Ppxlib
+
+let expand e = Location.raise_errorf ~loc:e.pexp_loc "error special function"
+
+let expand2 e =
+  Location.raise_errorf ~loc:e.pexp_loc "second error special function"
+
+let rule = Context_free.Rule.special_function "n_args" expand
+let rule2 = Context_free.Rule.special_function "n_args2" expand2;;
+
+Driver.register_transformation ~rules:[ rule; rule2 ] "special_function_demo"
+
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/exception_handling/whole_file_exception.ml

@@ -0,0 +1,9 @@
+open Ppxlib
+
+let () =
+  Driver.V2.(
+    register_transformation
+      ~impl:(fun _ _ -> failwith "An exception in a whole file transform")
+      "raise_exc")
+
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/exception_handling/whole_file_extension_point.ml

@@ -0,0 +1,18 @@
+open Ppxlib
+
+let () =
+  Driver.V2.(
+    register_transformation
+      ~impl:(fun ctxt str ->
+        let loc =
+          match str with
+          | [] -> Location.in_file (Expansion_context.Base.input_name ctxt)
+          | hd :: _ -> hd.pstr_loc
+        in
+        let extension_node =
+          Location.error_extensionf ~loc "An error message in an extension node"
+        in
+        [ Ast_builder.Default.pstr_extension ~loc extension_node [] ])
+      "raise_exc")
+
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/exception_handling/whole_file_located_error.ml

@@ -0,0 +1,15 @@
+open Ppxlib
+
+let () =
+  Driver.V2.(
+    register_transformation
+      ~impl:(fun ctxt str ->
+        let loc =
+          match str with
+          | [] -> Location.in_file (Expansion_context.Base.input_name ctxt)
+          | hd :: _ -> hd.pstr_loc
+        in
+        Location.raise_errorf ~loc "A located error in a whole file transform")
+      "raise_exc")
+
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/exception_handling/whole_file_multiple_errors.ml

@@ -0,0 +1,46 @@
+open Ppxlib
+
+let () =
+  let instrument =
+    let transformation ctxt str =
+      let loc =
+        match str with
+        | [] -> Location.in_file (Expansion_context.Base.input_name ctxt)
+        | hd :: _ -> hd.pstr_loc
+      in
+      Location.raise_errorf ~loc
+        "Raising a located exception during the first instrumentation phase"
+    in
+    Driver.Instrument.V2.make ~position:Driver.Instrument.Before transformation
+  in
+  Driver.V2.(register_transformation ~instrument "a_raise_exc")
+
+let () =
+  Driver.V2.(
+    register_transformation
+      ~impl:(fun ctxt str ->
+        let loc =
+          match str with
+          | [] -> Location.in_file (Expansion_context.Base.input_name ctxt)
+          | hd :: _ -> hd.pstr_loc
+        in
+        Location.raise_errorf ~loc
+          "Raising a located exception during the Global transformation phase")
+      "b_raise_exc_second")
+
+let () =
+  let instrument =
+    let transformation ctxt str =
+      let loc =
+        match str with
+        | [] -> Location.in_file (Expansion_context.Base.input_name ctxt)
+        | hd :: _ -> hd.pstr_loc
+      in
+      Location.raise_errorf ~loc
+        "Raising a located exception during the Last instrumentation phase"
+    in
+    Driver.Instrument.V2.make ~position:Driver.Instrument.After transformation
+  in
+  Driver.V2.(register_transformation ~instrument "c_raise_exc")
+
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/flag_cookie/dune

@@ -0,0 +1,9 @@
+(executable
+ (name print_cookie_driver)
+ (libraries ppxlib)
+ (preprocess
+  (pps ppxlib.metaquot)))
+
+(cram
+ (package ppxlib)
+ (deps print_cookie_driver.exe))

unikernel/duniverse/ppxlib/test/driver/flag_cookie/print_cookie_driver.ml

@@ -0,0 +1,33 @@
+open Ppxlib
+
+let value_x = ref ""
+
+let f = function
+  | Some value_of_x ->
+      value_x := Printf.sprintf "Value of cookie x: %i" value_of_x
+  | None -> value_x := "Cookie x isn't set."
+
+let () = Ppxlib.Driver.Cookies.(add_simple_handler ~f "x" Ast_pattern.(eint __))
+
+let print_cookie_x =
+  object
+    inherit Ast_traverse.map as super
+
+    method! structure str =
+      let new_str =
+        List.fold_left
+          (fun acc str_item ->
+            match str_item with
+            | [%stri [@@@print_cookie_x]] ->
+                let _ = print_endline !value_x in
+                acc
+            | _ -> str_item :: acc)
+          [] str
+      in
+      super#structure (List.rev new_str)
+  end
+
+let () =
+  Driver.register_transformation ~impl:print_cookie_x#structure "test_cookies"
+
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/flag_cookie/run.t

@@ -0,0 +1,10 @@
+The cookie flag is taken into account, both by the main standalone
+
+  $ echo "[@@@print_cookie_x]" > impl.ml
+  $ ./print_cookie_driver.exe -cookie x=1 impl.ml
+  Value of cookie x: 1
+
+...and by the `-as-ppx` standalone
+
+  $ ocaml -ppx './print_cookie_driver.exe --as-ppx -cookie x=1' impl.ml
+  Value of cookie x: 1

unikernel/duniverse/ppxlib/test/driver/instrument/dune

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

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

@@ -0,0 +1,36 @@
+open Ppxlib
+
+let extend_list_by name = object
+  inherit Ast_traverse.map as super
+
+  method! expression e =
+    match e.pexp_desc with
+    | Pexp_construct ({txt = Lident "[]"; _}, None) -> Ast_builder.Default.elist ~loc:e.pexp_loc [Ast_builder.Default.estring ~loc:e.pexp_loc name]
+    | _ -> super#expression e
+end
+[%%expect{|
+val extend_list_by : string -> Ast_traverse.map = <fun>
+|}]
+
+let () =
+  let name = "a: instr pos=Before" in
+  let transform = extend_list_by name in
+  Driver.(register_transformation ~instrument:(Instrument.make ~position:Before transform#structure) name)
+
+let () =
+  let name = "b: instr pos=After" in
+  let transform = extend_list_by name in
+  Driver.(register_transformation ~instrument:(Instrument.make ~position:After transform#structure) name)
+
+let () =
+  let name = "c: impl" in
+  let transform = extend_list_by name in
+  Driver.register_transformation ~impl:transform#structure name
+
+(* The order of the list should only depend on how the rewriters got registered,
+   not on the alphabetic order of the names they got registered with. *)
+let x = []
+[%%expect{|
+val x : string list =
+  ["a: instr pos=Before"; "c: impl"; "b: instr pos=After"]
+|}]

unikernel/duniverse/ppxlib/test/driver/keywords-option/driver.ml

@@ -0,0 +1 @@
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/keywords-option/dune

@@ -0,0 +1,11 @@
+(executable
+ (name driver)
+ (enabled_if
+  (>= %{ocaml_version} "5.3"))
+ (libraries ppxlib))
+
+(cram
+ (package ppxlib)
+ (enabled_if
+  (>= %{ocaml_version} "5.3"))
+ (deps driver.exe))

unikernel/duniverse/ppxlib/test/driver/keywords-option/run.t

@@ -0,0 +1,38 @@
+This test can only work with OCaml 5.3 or higher.
+
+OCaml 5.3 introduced the new `effect` keyword. To allow old code to compile
+under 5.3 it also introduced a `-keyword=version+list` CLI option, allowing one to
+override the set of keywords.
+
+The ppxlib driver also has such an option now to properly configure the lexer before
+attempting to parse source code.
+
+Let's consider the following source file:
+
+  $ cat > test.ml << EOF
+  > let effect = 1
+  > EOF
+
+If passed to the driver as is, it will trigger a parse error:
+
+  $ ./driver.exe --impl test.ml -o ignore.ml
+  File "test.ml", line 1, characters 4-10:
+  1 | let effect = 1
+          ^^^^^^
+  Error: Syntax error
+  [1]
+
+Now, if we use the 5.2 set of keywords, it should happily handle the file:
+
+  $ ./driver.exe --keywords 5.2 --impl test.ml -o ignore.ml
+
+It can also be set using OCAMLPARAM:
+
+  $ OCAMLPARAM=_,keywords=5.2 ./driver.exe --impl test.ml -o ignore.ml
+
+The priority between the CLI option and OCAMLPARAM must be respected, therefore
+both of the following invocation should parse:
+
+  $ OCAMLPARAM=_,keywords=5.2 ./driver.exe --keywords 5.3 --impl test.ml -o ignore.ml
+
+  $ OCAMLPARAM=keywords=5.3,_ ./driver.exe --keywords 5.2 --impl test.ml -o ignore.ml

unikernel/duniverse/ppxlib/test/driver/non-compressible-suffix/dune

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

unikernel/duniverse/ppxlib/test/driver/non-compressible-suffix/test.ml

@@ -0,0 +1,35 @@
+open Ppxlib;;
+open Ast_builder.Default;;
+
+Driver.register_transformation "blah"
+  ~rules:[ Context_free.Rule.extension
+             (Extension.declare "foo"
+                Expression
+                Ast_pattern.(pstr nil)
+                (fun ~loc ~path:_ -> eint ~loc 42))
+         ; Context_free.Rule.extension
+             (Extension.declare "@foo.bar"
+                Expression
+                Ast_pattern.(pstr nil)
+                (fun ~loc ~path:_ -> eint ~loc 42))
+         ]
+;;
+[%%expect{|
+- : unit = ()
+|}]
+
+[%foo];;
+[%%expect{|
+- : int = 42
+|}]
+
+[%foo.bar];;
+[%%expect{|
+- : int = 42
+|}]
+
+[%bar];;
+[%%expect{|
+Line _, characters 2-5:
+Error: Uninterpreted extension 'bar'.
+|}]

unikernel/duniverse/ppxlib/test/driver/ocaml-ppx-context-load-path-migration/driver.ml

@@ -0,0 +1,92 @@
+module To_before_502 =
+  Ppxlib_ast.Convert (Ppxlib_ast.Js) (Ppxlib_ast__.Versions.OCaml_501)
+
+module From_before_502 =
+  Ppxlib_ast.Convert (Ppxlib_ast__.Versions.OCaml_501) (Ppxlib_ast.Js)
+
+module Before_502_to_ocaml =
+  Ppxlib_ast.Convert
+    (Ppxlib_ast__.Versions.OCaml_501)
+    (Ppxlib_ast.Compiler_version)
+
+module OCaml_501 = Ppxlib_ast__.Versions.OCaml_501.Ast
+
+let rec unfold_list_lit x next =
+  let open OCaml_501.Parsetree in
+  let open Astlib.Longident in
+  match next.pexp_desc with
+  | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> [ x ]
+  | Pexp_construct
+      ( { txt = Lident "::"; _ },
+        Some { pexp_desc = Pexp_tuple [ elm; rest ]; _ } ) ->
+      x :: unfold_list_lit elm rest
+  | _ -> invalid_arg "list_lit"
+
+(* Only deals with the basic blocks needed for ocaml.ppx.context *)
+let rec basic_expr_to_string expr =
+  let open OCaml_501.Parsetree in
+  let open Astlib.Longident in
+  match expr.pexp_desc with
+  | Pexp_constant (Pconst_string (s, _, None)) -> Printf.sprintf "%S" s
+  | Pexp_ident { txt = Lident name; _ } -> name
+  | Pexp_tuple l ->
+      let strs = List.map basic_expr_to_string l in
+      "(" ^ String.concat ", " strs ^ ")"
+  | Pexp_construct ({ txt = Lident s; _ }, None) -> s
+  | Pexp_construct
+      ( { txt = Lident "::"; _ },
+        Some { pexp_desc = Pexp_tuple [ elm; rest ]; _ } ) ->
+      let exprs = unfold_list_lit elm rest in
+      let strs = List.map basic_expr_to_string exprs in
+      "[" ^ String.concat "; " strs ^ "]"
+  | _ -> invalid_arg "basic_expr_to_string"
+
+let print_field (lident_loc, expr) =
+  match lident_loc with
+  | { OCaml_501.Asttypes.txt = Astlib.Longident.Lident name; _ } ->
+      Printf.printf "    %s: %s;\n" name (basic_expr_to_string expr)
+  | _ -> ()
+
+let print_ocaml_ppx_context stri =
+  let open OCaml_501.Parsetree in
+  match stri.pstr_desc with
+  | Pstr_attribute
+      {
+        attr_payload =
+          PStr
+            [
+              {
+                pstr_desc =
+                  Pstr_eval ({ pexp_desc = Pexp_record (fields, None); _ }, _);
+                _;
+              };
+            ];
+        _;
+      } ->
+      Printf.printf "[@@@ocaml.ppx.context\n";
+      Printf.printf "  {\n";
+      List.iter print_field fields;
+      Printf.printf "  }\n";
+      Printf.printf "]\n"
+  | _ -> ()
+
+let is_ppx_context stri =
+  let open OCaml_501.Parsetree in
+  match stri.pstr_desc with
+  | Pstr_attribute
+      { attr_name = { OCaml_501.Asttypes.txt = "ocaml.ppx.context"; _ }; _ } ->
+      true
+  | _ -> false
+
+let impl _ctxt str =
+  let before_502_ast = To_before_502.copy_structure str in
+  let ppx_context = List.find is_ppx_context before_502_ast in
+  Printf.printf "ocaml.ppx.context before 5.02:\n";
+  print_ocaml_ppx_context ppx_context;
+  let round_trip = Before_502_to_ocaml.copy_structure_item ppx_context in
+  Printf.printf "ocaml.ppx.context round tripped:\n";
+  Ocaml_common.Pprintast.structure_item Format.std_formatter round_trip;
+  str
+
+let () = Ppxlib.Driver.V2.register_transformation ~impl "ocaml.ppx.context-test"
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/ocaml-ppx-context-load-path-migration/dune

@@ -0,0 +1,16 @@
+(executable
+ (name driver)
+ (enabled_if
+  (>= %{ocaml_version} "5.2"))
+ (libraries
+  ppxlib
+  ppxlib.ast
+  ppxlib.astlib
+  ocaml-compiler-libs.common
+  compiler-libs.common))
+
+(cram
+ (package ppxlib)
+ (enabled_if
+  (>= %{ocaml_version} "5.2"))
+ (deps driver.exe))

unikernel/duniverse/ppxlib/test/driver/ocaml-ppx-context-load-path-migration/run.t

@@ -0,0 +1,73 @@
+In 5.2 the format of ocaml.ppx.context load_path changed.
+To ensure compat, we defined migration for ocaml.ppx.context attributes
+
+We write such an attribute to an .ml file. The compiler will add its own
+and it should be consumed by the driver but our handwritten attribute will
+be migrated as well and should remain in the AST.
+  $ cat > test.ml << EOF
+  > let x = 1
+  > [@@@ocaml.ppx.context
+  >   {
+  >     tool_name = "ocaml";
+  >     include_dirs = ["foo"];
+  >     hidden_include_dirs = [];
+  >     load_path = (["foo"; "bar"], ["baz"]);
+  >     open_modules = [];
+  >     for_package = None;
+  >     debug = true;
+  >     use_threads = false;
+  >     use_vmthreads = false;
+  >     recursive_types = false;
+  >     principal = false;
+  >     transparent_modules = false;
+  >     unboxed_types = false;
+  >     unsafe_string = false;
+  >     cookies = []
+  >   }]
+  > EOF
+
+We then run a custom driver that will read our ast, migrate it back to 5.01,
+pretty print the ocaml.ppx.context, convert it back to the latest version and
+pretty print it again. This last, round-tripped version should be identical to
+the one above.
+
+  $ ./driver.exe --impl test.ml -o ignore.ml
+  ocaml.ppx.context before 5.02:
+  [@@@ocaml.ppx.context
+    {
+      tool_name: "ocaml";
+      include_dirs: ["foo"];
+      hidden_include_dirs: [];
+      load_path: ["foo"; "bar"; "baz"];
+      open_modules: [];
+      for_package: None;
+      debug: true;
+      use_threads: false;
+      use_vmthreads: false;
+      recursive_types: false;
+      principal: false;
+      transparent_modules: false;
+      unboxed_types: false;
+      unsafe_string: false;
+      cookies: [];
+    }
+  ]
+  ocaml.ppx.context round tripped:
+  [@@@ocaml.ppx.context
+    {
+      tool_name = "ocaml";
+      include_dirs = ["foo"];
+      hidden_include_dirs = [];
+      load_path = (["foo"; "bar"], ["baz"]);
+      open_modules = [];
+      for_package = None;
+      debug = true;
+      use_threads = false;
+      use_vmthreads = false;
+      recursive_types = false;
+      principal = false;
+      transparent_modules = false;
+      unboxed_types = false;
+      unsafe_string = false;
+      cookies = []
+    }]

unikernel/duniverse/ppxlib/test/driver/parse_error_locations/dune

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

unikernel/duniverse/ppxlib/test/driver/parse_error_locations/identity_standalone.ml

@@ -0,0 +1 @@
+let _ = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/parse_error_locations/run.t

@@ -0,0 +1,15 @@
+Keep the error output short in order to avoid different error output between
+different compiler versions in the subsequent test
+
+  $ export OCAML_ERROR_STYLE=short
+
+Syntax errors in files parsed by ppxlib are reported correctly
+
+  $ cat > test.ml << EOF
+  > let x = 5
+  > let let
+  > EOF
+  $ ./identity_standalone.exe -impl test.ml
+  File "test.ml", line 2, characters 4-7:
+  Error: Syntax error
+  [1]

unikernel/duniverse/ppxlib/test/driver/run_as_ppx_rewriter/dune

@@ -0,0 +1,9 @@
+(executable
+ (name print_greetings)
+ (libraries ppxlib)
+ (preprocess
+  (pps ppxlib.metaquot)))
+
+(cram
+ (package ppxlib)
+ (deps print_greetings.exe))

unikernel/duniverse/ppxlib/test/driver/run_as_ppx_rewriter/print_greetings.ml

@@ -0,0 +1,20 @@
+open Ppxlib
+
+let hi_rule =
+  let expand ~loc ~path:_ = [%expr print_endline "hi"] in
+  Extension.declare "print_hi" Extension.Context.expression
+    Ast_pattern.(pstr nil)
+    expand
+  |> Context_free.Rule.extension
+
+let bye_rule =
+  let expand ~loc ~path:_ = [%expr print_endline "bye"] in
+  Extension.declare "print_bye" Extension.Context.expression
+    Ast_pattern.(pstr nil)
+    expand
+  |> Context_free.Rule.extension
+
+(* the two rules need to be registered separately in order to test the `-apply` flag in run.t *)
+let () = Driver.register_transformation ~rules:[ hi_rule ] "print_hi"
+let () = Driver.register_transformation ~rules:[ bye_rule ] "print_bye"
+let () = Ppxlib.Driver.run_as_ppx_rewriter ()

unikernel/duniverse/ppxlib/test/driver/run_as_ppx_rewriter/run.t

@@ -0,0 +1,92 @@
+Keep the error output short in order to avoid different error output between
+different compiler versions in the subsequent tests
+
+  $ export OCAML_ERROR_STYLE=short
+
+The registered rewriters get applied when using `run_as_ppx_rewriter` as entry point
+
+  $ cat > file.ml << EOF
+  > let () = [%print_hi]
+  > let () = [%print_bye]
+  > EOF
+  $ ocaml -ppx './print_greetings.exe' file.ml
+  hi
+  bye
+
+The driver's `shared_args` are taken into account, such as `-apply`...
+
+  $ ocaml -ppx './print_greetings.exe -apply print_hi' file.ml
+  hi
+  File "./file.ml", line 2, characters 11-20:
+  Error: Uninterpreted extension 'print_bye'.
+  [2]
+
+... and `-check`
+
+  $ echo "[@@@attr non_registered_attr]" > attribute_file.ml
+  $ ocaml -ppx './print_greetings.exe -check' attribute_file.ml
+  File "./attribute_file.ml", line 1, characters 4-8:
+  Error: Attribute `attr' was not used
+  [2]
+
+
+If a non-compatible file gets fed, the file name is reported correctly
+
+  $ touch no_binary_ast.ml
+  $ ./print_greetings.exe no_binary_ast.ml some_output
+  File "no_binary_ast.ml", line 1:
+  Error: Expected a binary AST as input
+  [1]
+
+The only possible usage is [extra_args] <infile> <outfile>...
+
+  $ ./print_greetings.exe some_input
+  Usage: print_greetings.exe [extra_args] <infile> <outfile>
+  [2]
+
+...in particular the order between the flags and the input/output matters.
+
+  $ touch some_output
+  $ ./print_greetings.exe some_input some_output -check
+  ./print_greetings.exe: anonymous arguments not accepted.
+  print_greetings.exe [extra_args] <infile> <outfile>
+    -loc-filename <string>      File name to use in locations
+    -reserve-namespace <string> Mark the given namespace as reserved
+    -no-check                   Disable checks (unsafe)
+    -check                      Enable checks
+    -no-check-on-extensions     Disable checks on extension point only
+    -check-on-extensions        Enable checks on extension point only
+    -no-locations-check         Disable locations check only
+    -locations-check            Enable locations check only
+    -apply <names>              Apply these transformations in order (comma-separated list)
+    -dont-apply <names>         Exclude these transformations
+    -no-merge                   Do not merge context free transformations (better for debugging rewriters). As a result, the context-free transformations are not all applied before all impl and intf.
+    -cookie NAME=EXPR           Set the cookie NAME to EXPR
+    --cookie                    Same as -cookie
+    -raise-embedded-errors      Raise the first embedded error found in the processed AST
+    -allow-deriving-end         Whether to allow [@@@deriving.end], which will soon be deprecated.
+    -help                       Display this list of options
+    --help                      Display this list of options
+  [2]
+
+The only exception is consulting help
+
+  $ ./print_greetings.exe -help
+  print_greetings.exe [extra_args] <infile> <outfile>
+    -loc-filename <string>      File name to use in locations
+    -reserve-namespace <string> Mark the given namespace as reserved
+    -no-check                   Disable checks (unsafe)
+    -check                      Enable checks
+    -no-check-on-extensions     Disable checks on extension point only
+    -check-on-extensions        Enable checks on extension point only
+    -no-locations-check         Disable locations check only
+    -locations-check            Enable locations check only
+    -apply <names>              Apply these transformations in order (comma-separated list)
+    -dont-apply <names>         Exclude these transformations
+    -no-merge                   Do not merge context free transformations (better for debugging rewriters). As a result, the context-free transformations are not all applied before all impl and intf.
+    -cookie NAME=EXPR           Set the cookie NAME to EXPR
+    --cookie                    Same as -cookie
+    -raise-embedded-errors      Raise the first embedded error found in the processed AST
+    -allow-deriving-end         Whether to allow [@@@deriving.end], which will soon be deprecated.
+    -help                       Display this list of options
+    --help                      Display this list of options

unikernel/duniverse/ppxlib/test/driver/run_as_ppx_rewriter_preserve_version/dune

@@ -0,0 +1,20 @@
+(executable
+ (name identity_standalone)
+ (libraries ppxlib)
+ (modules identity_standalone))
+
+(executable
+ (name print_magic_number)
+ (libraries astlib)
+ (modules print_magic_number))
+
+(cram
+ (package ppxlib)
+ (enabled_if
+  (or
+   (= %{system} linux)
+   (= %{system} linux_elf)
+   (= %{system} elf)
+   (= %{system} linux_eabihf)
+   (= %{system} linux_eabi)))
+ (deps identity_standalone.exe print_magic_number.exe))

unikernel/duniverse/ppxlib/test/driver/run_as_ppx_rewriter_preserve_version/identity_standalone.ml

@@ -0,0 +1 @@
+let () = Ppxlib.Driver.run_as_ppx_rewriter ()

unikernel/duniverse/ppxlib/test/driver/run_as_ppx_rewriter_preserve_version/print_magic_number.ml

@@ -0,0 +1,5 @@
+let magic_length = String.length Astlib.Config.ast_impl_magic_number
+let buf = Bytes.create magic_length
+let len = input stdin buf 0 magic_length
+let s = Bytes.sub_string buf 0 len
+let () = Printf.printf "Magic number: %s" s

unikernel/duniverse/ppxlib/test/driver/run_as_ppx_rewriter_preserve_version/test.t/run.t

@@ -0,0 +1,8 @@
+Binary AST's of any by ppxlib supported OCaml version are supported.
+The version is preserved.
+
+  $ cat 408_binary_ast | ../print_magic_number.exe
+  Magic number: Caml1999M025
+
+  $ ../identity_standalone.exe 408_binary_ast /dev/stdout | ../print_magic_number.exe
+  Magic number: Caml1999M025

unikernel/duniverse/ppxlib/test/driver/skip-hash-bang/dune

@@ -0,0 +1,12 @@
+(library
+ (name empty_rewriter)
+ (modules empty_rewriter)
+ (kind ppx_rewriter)
+ (libraries ppxlib))
+
+(tests
+ (package ppxlib)
+ (names test test2)
+ (modules test test2)
+ (preprocess
+  (pps empty_rewriter)))

unikernel/duniverse/ppxlib/test/driver/skip-hash-bang/test.expected

@@ -0,0 +1 @@
+OK

unikernel/duniverse/ppxlib/test/driver/skip-hash-bang/test.ml

@@ -0,0 +1,3 @@
+#!ignored_line
+
+let () = print_endline "OK"

unikernel/duniverse/ppxlib/test/driver/skip-hash-bang/test2.expected

@@ -0,0 +1 @@
+OK

unikernel/duniverse/ppxlib/test/driver/skip-hash-bang/test2.ml

@@ -0,0 +1,3 @@
+#!ignored line
+
+let () = print_endline "OK"

unikernel/duniverse/ppxlib/test/driver/source-quotation-in-errors/dune

@@ -0,0 +1,15 @@
+(executable
+ (name raising_driver)
+ (modules raising_driver)
+ (libraries ppxlib))
+
+(executable
+ (name identity_driver)
+ (modules identity_driver)
+ (libraries ppxlib))
+
+(cram
+ (package ppxlib)
+ (enabled_if
+  (>= %{ocaml_version} "4.08.0"))
+ (deps raising_driver.exe identity_driver.exe))

unikernel/duniverse/ppxlib/test/driver/source-quotation-in-errors/identity_driver.ml

@@ -0,0 +1 @@
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/source-quotation-in-errors/raising_driver.ml

@@ -0,0 +1,14 @@
+open Ppxlib
+
+let rules =
+  [
+    Extension.V3.declare "raise" Extension.Context.expression
+      Ast_pattern.(pstr nil)
+      (fun ~ctxt ->
+        let loc = Expansion_context.Extension.extension_point_loc ctxt in
+        Location.raise_errorf ~loc "An exception, raise be!")
+    |> Context_free.Rule.extension;
+  ]
+
+let () = Driver.V2.register_transformation ~rules "raise"
+let () = Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/source-quotation-in-errors/run.t

@@ -0,0 +1,45 @@
+When the ppxlib driver reports an error by itself, source quotation should work
+properly.
+
+We start off by explicitly setting the error reporting style to contextual to
+ensure source quotation is enabled:
+
+  $ export OCAML_ERROR_STYLE=contextual
+
+Here we have a driver compiled with a single rule that will raise a located
+exception for every "[%raise]" extension point.
+
+We need an input file:
+
+  $ cat > file.ml << EOF
+  > let x = [%raise]
+  > EOF
+
+When running the driver on this file, it should report the error and show
+the relevant quoted source:
+
+  $ ./raising_driver.exe -impl file.ml
+  File "file.ml", line 1, characters 8-16:
+  1 | let x = [%raise]
+              ^^^^^^^^
+  Error: An exception, raise be!
+  [1]
+
+This should also work when the input is a binary AST as the file contains the name
+of the original source file. Our driver should be able to properly set the input
+lexbuf and get the source quotation to work, assuming the information in the binary
+AST file is correct.
+
+Here we use an identity driver to generate the binary AST for our .ml file above:
+
+  $ ./identity_driver.exe -impl file.ml -dump-ast -o file.pp.ml 
+
+We then call our raising driver on the binary AST, it should be able to report the
+error with source quotation:
+
+  $ ./raising_driver.exe -impl file.pp.ml
+  File "file.ml", line 1, characters 8-16:
+  1 | let x = [%raise]
+              ^^^^^^^^
+  Error: An exception, raise be!
+  [1]

unikernel/duniverse/ppxlib/test/driver/standalone-supports-old-binary-ast/dune

@@ -0,0 +1,20 @@
+(executable
+ (name identity_standalone)
+ (libraries ppxlib)
+ (modules identity_standalone))
+
+(executable
+ (name print_magic_number)
+ (libraries astlib)
+ (modules print_magic_number))
+
+(cram
+ (package ppxlib)
+ (enabled_if
+  (or
+   (= %{system} linux)
+   (= %{system} linux_elf)
+   (= %{system} elf)
+   (= %{system} linux_eabihf)
+   (= %{system} linux_eabi)))
+ (deps identity_standalone.exe print_magic_number.exe))

unikernel/duniverse/ppxlib/test/driver/standalone-supports-old-binary-ast/identity_standalone.ml

@@ -0,0 +1 @@
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/standalone-supports-old-binary-ast/print_magic_number.ml

@@ -0,0 +1,5 @@
+let magic_length = String.length Astlib.Config.ast_impl_magic_number
+let buf = Bytes.create magic_length
+let len = input stdin buf 0 magic_length
+let s = Bytes.sub_string buf 0 len
+let () = Printf.printf "Magic number: %s" s

unikernel/duniverse/ppxlib/test/driver/standalone-supports-old-binary-ast/test.t/run.t

@@ -0,0 +1,10 @@
+Binary AST's of any by ppxlib supported OCaml version are supported.
+The version is preserved.
+
+  $ cat 408_binary_ast | ../print_magic_number.exe
+  Magic number: Caml1999N025
+
+  $ ../identity_standalone.exe --intf 408_binary_ast -o transformed --dump-ast
+
+  $ ../print_magic_number.exe < transformed
+  Magic number: Caml1999N025

unikernel/duniverse/ppxlib/test/driver/standalone_run_as_ppx/dune

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

unikernel/duniverse/ppxlib/test/driver/standalone_run_as_ppx/print_stuff.ml

@@ -0,0 +1,45 @@
+open Ppxlib
+
+let mk_expression ~loc pexp_desc =
+  { pexp_desc; pexp_loc_stack = []; pexp_loc = loc; pexp_attributes = [] }
+
+let print_string s ~loc =
+  let print_exp =
+    mk_expression ~loc (Pexp_ident { txt = Lident "print_endline"; loc })
+  in
+  let string_exp =
+    mk_expression ~loc (Pexp_constant (Pconst_string (s, loc, None)))
+  in
+  mk_expression ~loc (Pexp_apply (print_exp, [ (Nolabel, string_exp) ]))
+
+let hi_rule =
+  let expand ~loc ~path:_ = print_string "hi" ~loc in
+  Extension.declare "print_hi" Extension.Context.expression
+    Ast_pattern.(pstr nil)
+    expand
+  |> Context_free.Rule.extension
+
+let tool_name_rule =
+  let expand ~ctxt =
+    let loc = Expansion_context.Extension.extension_point_loc ctxt in
+    let tool_name = Expansion_context.Extension.tool_name ctxt in
+    print_string tool_name ~loc
+  in
+  Extension.V3.declare "print_tool_name" Extension.Context.expression
+    Ast_pattern.(pstr nil)
+    expand
+  |> Context_free.Rule.extension
+
+let fname_rule =
+  let expand ~loc ~path:_ = print_string ~loc loc.loc_start.pos_fname in
+  Extension.declare "print_fname" Extension.Context.expression
+    Ast_pattern.(pstr nil)
+    expand
+  |> Context_free.Rule.extension
+
+let () =
+  Driver.register_transformation
+    ~rules:[ hi_rule; tool_name_rule; fname_rule ]
+    "test"
+
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/standalone_run_as_ppx/run.t

@@ -0,0 +1,37 @@
+Keep the error output short in order to avoid different error output between different compiler versions in the subsequent tests
+
+  $ export OCAML_ERROR_STYLE=short
+
+The rewriter gets applied when using `--as-ppx`
+
+  $ echo "let _ = [%print_hi]" > impl.ml
+  $ ocaml -ppx './print_stuff.exe --as-ppx' impl.ml
+  hi
+
+If a non-compatible file gets fed, the file name is reported correctly
+
+  $ touch no_binary_ast.ml
+  $ ./print_stuff.exe --as-ppx no_binary_ast.ml some_output
+  File "no_binary_ast.ml", line 1:
+  Error: Expected a binary AST as input
+  [1]
+
+The ocaml.ppx.context attribute gets parsed correctly; in particular, the tool name gets set correctly
+
+  $ echo "let _ = [%print_tool_name]" > impl.ml
+  $ ocaml -ppx './print_stuff.exe --as-ppx' impl.ml
+  ocaml
+
+The driver's `shared_args` arguments are taken into account. For example, `-loc-filename`
+
+  $ echo "let _ = [%print_fname]" > impl.ml
+  $ ocaml -ppx './print_stuff.exe --as-ppx -loc-filename new_fn.ml' impl.ml
+  new_fn.ml
+
+or `dont-apply`
+
+  $ echo "let _ = [%print_hi]" > impl.ml
+  $ ocaml -ppx './print_stuff.exe --as-ppx -dont-apply test' impl.ml
+  File "./impl.ml", line 1, characters 10-18:
+  Error: Uninterpreted extension 'print_hi'.
+  [2]

unikernel/duniverse/ppxlib/test/driver/stdin_input/dune

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

unikernel/duniverse/ppxlib/test/driver/stdin_input/identity_driver.ml

@@ -0,0 +1 @@
+let () = Ppxlib.Driver.standalone ()

unikernel/duniverse/ppxlib/test/driver/stdin_input/test.t/run.t

@@ -0,0 +1,20 @@
+The driver can read from stdin.
+
+It works with sources...
+
+  $ ../identity_driver.exe -impl - << EOF
+  > let a = 1
+  > EOF
+  let a = 1
+
+... but it should also work with binary ASTs.
+We generate a binary AST file...
+
+  $ ../identity_driver.exe --dump-ast -o binary_ast -impl - << EOF
+  > let b = 2
+  > EOF
+
+... and ensure the driver can also read it from stdin
+
+  $ cat binary_ast | ../identity_driver.exe -impl -
+  let b = 2

unikernel/duniverse/ppxlib/test/driver/transformations/dune

@@ -0,0 +1,40 @@
+; The error-reporting format changed in 4.12; thus the expect-tests need to be duplicated
+
+(rule
+ (package ppxlib)
+ (alias runtest)
+ (enabled_if
+  (and
+   (>= %{ocaml_version} "4.08.0")
+   (< %{ocaml_version} "4.12.0")))
+ (deps
+  (:test test.ml)
+  (package ppxlib))
+ (action
+  (chdir
+   %{project_root}
+   (progn
+    (run expect-test %{test})
+    (diff? %{test} %{test}.corrected)))))
+
+; This runs expect-test on the same input test.ml but compares the .corrected
+; file to test_412.ml
+
+(rule
+ (package ppxlib)
+ (alias runtest)
+ (enabled_if
+  (>= %{ocaml_version} "4.12.0"))
+ (deps
+  (:test test.ml)
+  (:t test_412.ml)
+  (package ppxlib))
+ (action
+  (chdir
+   %{project_root}
+   (progn
+    (run mv %{t} %{t}.old)
+    (run cp %{test} %{t})
+    (run expect-test %{t})
+    (run mv %{t}.old %{t})
+    (diff? %{t} %{t}.corrected)))))

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

@@ -0,0 +1,103 @@
+open Stdppx
+open Ppxlib
+
+
+(* Linters *)
+
+let lint = object
+  inherit [Driver.Lint_error.t list] Ast_traverse.fold as super
+
+  method! type_declaration td acc =
+    let acc = super#type_declaration td acc in
+    match td.ptype_kind with
+    | Ptype_record lds ->
+      if Poly.(<>)
+           (List.sort lds ~cmp:(fun a b -> String.compare a.pld_name.txt b.pld_name.txt))
+           lds
+      then
+        Driver.Lint_error.of_string { td.ptype_loc with loc_ghost = true }
+          "Fields are not sorted!"
+        :: acc
+      else
+        acc
+    | _ -> acc
+end
+let () =
+  Driver.register_transformation "lint" ~lint_impl:(fun st -> lint#structure st [])
+[%%expect{|
+val lint : Driver.Lint_error.t list Ast_traverse.fold = <obj>
+|}]
+
+type t =
+  { b : int
+  ; a : int
+  }
+[%%expect{|
+Line _, characters 0-36:
+Error (warning 22): Fields are not sorted!
+|}]
+
+
+(* Extension with a path argument *)
+
+let () =
+  Driver.register_transformation "plop"
+    ~rules:[Context_free.Rule.extension
+              (Extension.declare_with_path_arg "plop"
+                 Expression
+                 Ast_pattern.(pstr nil)
+                 (fun ~loc ~path:_ ~arg ->
+                    let open Ast_builder.Default in
+                    match arg with
+                    | None -> estring ~loc "-"
+                    | Some { loc; txt } -> estring ~loc (Longident.name txt)))]
+[%%expect{|
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop]
+[%%expect{|
+- : string = "-\n"
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop.Truc]
+[%%expect{|
+- : string = "Truc\n"
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop.Truc.Bidule]
+[%%expect{|
+- : string = "Truc.Bidule\n"
+|}]
+
+
+(* Extension with a path argument and ctxt *)
+
+let () =
+  Driver.register_transformation "plop_ctxt"
+    ~rules:[Context_free.Rule.extension
+              (Extension.V3.declare_with_path_arg "plop_ctxt"
+                 Expression
+                 Ast_pattern.(pstr nil)
+                 (fun ~ctxt ~arg ->
+                    let open Ast_builder.Default in
+                    let loc = Expansion_context.Extension.extension_point_loc ctxt in
+                    match arg with
+                    | None -> estring ~loc "-"
+                    | Some { loc; txt } -> estring ~loc (Longident.name txt)))]
+[%%expect{|
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt]
+[%%expect{|
+- : string = "-\n"
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt.Truc]
+[%%expect{|
+- : string = "Truc\n"
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt.Truc.Bidule]
+[%%expect{|
+- : string = "Truc.Bidule\n"
+|}]

unikernel/duniverse/ppxlib/test/driver/transformations/test_412.ml

@@ -0,0 +1,103 @@
+open Stdppx
+open Ppxlib
+
+
+(* Linters *)
+
+let lint = object
+  inherit [Driver.Lint_error.t list] Ast_traverse.fold as super
+
+  method! type_declaration td acc =
+    let acc = super#type_declaration td acc in
+    match td.ptype_kind with
+    | Ptype_record lds ->
+      if Poly.(<>)
+           (List.sort lds ~cmp:(fun a b -> String.compare a.pld_name.txt b.pld_name.txt))
+           lds
+      then
+        Driver.Lint_error.of_string { td.ptype_loc with loc_ghost = true }
+          "Fields are not sorted!"
+        :: acc
+      else
+        acc
+    | _ -> acc
+end
+let () =
+  Driver.register_transformation "lint" ~lint_impl:(fun st -> lint#structure st [])
+[%%expect{|
+val lint : Driver.Lint_error.t list Ast_traverse.fold = <obj>
+|}]
+
+type t =
+  { b : int
+  ; a : int
+  }
+[%%expect{|
+Line _, characters 0-36:
+Error (warning 22 [preprocessor]): Fields are not sorted!
+|}]
+
+
+(* Extension with a path argument *)
+
+let () =
+  Driver.register_transformation "plop"
+    ~rules:[Context_free.Rule.extension
+              (Extension.declare_with_path_arg "plop"
+                 Expression
+                 Ast_pattern.(pstr nil)
+                 (fun ~loc ~path:_ ~arg ->
+                    let open Ast_builder.Default in
+                    match arg with
+                    | None -> estring ~loc "-"
+                    | Some { loc; txt } -> estring ~loc (Longident.name txt)))]
+[%%expect{|
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop]
+[%%expect{|
+- : string = "-\n"
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop.Truc]
+[%%expect{|
+- : string = "Truc\n"
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop.Truc.Bidule]
+[%%expect{|
+- : string = "Truc.Bidule\n"
+|}]
+
+
+(* Extension with a path argument and ctxt *)
+
+let () =
+  Driver.register_transformation "plop_ctxt"
+    ~rules:[Context_free.Rule.extension
+              (Extension.V3.declare_with_path_arg "plop_ctxt"
+                 Expression
+                 Ast_pattern.(pstr nil)
+                 (fun ~ctxt ~arg ->
+                    let open Ast_builder.Default in
+                    let loc = Expansion_context.Extension.extension_point_loc ctxt in
+                    match arg with
+                    | None -> estring ~loc "-"
+                    | Some { loc; txt } -> estring ~loc (Longident.name txt)))]
+[%%expect{|
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt]
+[%%expect{|
+- : string = "-\n"
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt.Truc]
+[%%expect{|
+- : string = "Truc\n"
+|}]
+
+let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt.Truc.Bidule]
+[%%expect{|
+- : string = "Truc.Bidule\n"
+|}]