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])