Merge pull request #2025 from trefis/fix-expect

expect_test: cleanup typer state on type error

4 files changed, 86 insertions, 1 deletions

diff --git a/testsuite/tests/tool-expect-test/clean_typer.ml b/testsuite/tests/tool-expect-test/clean_typer.ml
new file mode 100644
index 0000000000..3009a17719
--- /dev/null
+++ b/testsuite/tests/tool-expect-test/clean_typer.ml
@@ -0,0 +1,82 @@
+(* TEST
+    * expect
+*)
+
+module Variants = struct
+  type bar = [ `Bar ]
+  type foo = private [< `Foo | `Bar ]
+end
+
+open Variants
+
+module M : sig
+  type +'a t
+
+  val foo : unit -> foo t
+  val bar : unit -> bar t
+end = struct
+  type 'a t = 'a list
+
+  let foo () = []
+  let bar () = []
+end
+
+module type Foo = sig
+  val x : foo M.t -> unit
+end
+
+let ffoo t (module F : Foo) =
+  F.x t
+
+module type Bar = sig
+  val x : bar M.t -> unit
+end
+
+let fbar t (module B : Bar) =
+  B.x t
+
+let (foo : foo M.t) = M.foo ()
+let (bar : bar M.t) = M.bar ()
+[%%expect {|
+module Variants :
+  sig type bar = [ `Bar ] type foo = private [< `Bar | `Foo ] end
+module M :
+  sig
+    type +'a t
+    val foo : unit -> Variants.foo t
+    val bar : unit -> Variants.bar t
+  end
+module type Foo = sig val x : Variants.foo M.t -> unit end
+val ffoo : Variants.foo M.t -> (module Foo) -> unit = <fun>
+module type Bar = sig val x : Variants.bar M.t -> unit end
+val fbar : Variants.bar M.t -> (module Bar) -> unit = <fun>
+val foo : Variants.foo M.t = <abstr>
+val bar : Variants.bar M.t = <abstr>
+|}]
+
+let f1 = ffoo foo;;
+[%%expect {|
+val f1 : (module Foo) -> unit = <fun>
+|}]
+
+let f2 = ffoo bar;;
+[%%expect {|
+Line 1, characters 14-17:
+  let f2 = ffoo bar;;
+                ^^^
+Error: This expression has type Variants.bar M.t
+       but an expression was expected of type Variants.foo M.t
+       Type Variants.bar = [ `Bar ] is not compatible with type Variants.foo
+       The first variant type does not allow tag(s) `Foo
+|}]
+
+let f3 = fbar foo;;
+[%%expect {|
+Line 1, characters 14-17:
+  let f3 = fbar foo;;
+                ^^^
+Error: This expression has type Variants.foo M.t
+       but an expression was expected of type Variants.bar M.t
+       Type Variants.foo is not compatible with type Variants.bar = [ `Bar ]
+       The second variant type does not allow tag(s) `Foo
+|}]
diff --git a/testsuite/tests/tool-expect-test/ocamltests b/testsuite/tests/tool-expect-test/ocamltests
new file mode 100644
index 0000000000..c7e19b8732
--- /dev/null
+++ b/testsuite/tests/tool-expect-test/ocamltests
@@ -0,0 +1 @@
+clean_typer.ml
diff --git a/testsuite/tools/Makefile b/testsuite/tools/Makefile
index 97e50ff9b3..c14fade18c 100644
--- a/testsuite/tools/Makefile
+++ b/testsuite/tools/Makefile
@@ -17,7 +17,7 @@ include $(BASEDIR)/../config/Makefile
 expect_MAIN=expect_test
 expect_PROG=$(expect_MAIN)$(EXE)
 expect_COMPFLAGS=-I $(OTOPDIR)/parsing -I $(OTOPDIR)/utils \
-          -I $(OTOPDIR)/driver -I $(OTOPDIR)/toplevel
+          -I $(OTOPDIR)/driver -I $(OTOPDIR)/typing -I $(OTOPDIR)/toplevel
 expect_LIBRARIES=../../compilerlibs/ocamlcommon \
           ../../compilerlibs/ocamlbytecomp \
           ../../compilerlibs/ocamltoplevel
diff --git a/testsuite/tools/expect_test.ml b/testsuite/tools/expect_test.ml
index 2bace33432..2940a32f95 100644
--- a/testsuite/tools/expect_test.ml
+++ b/testsuite/tools/expect_test.ml
@@ -250,6 +250,7 @@ let eval_expect_file _fname ~file_contents =
     let _ : bool =
       List.fold_left phrases ~init:true ~f:(fun acc phrase ->
         acc &&
+        let snap = Btype.snapshot () in
         try
           exec_phrase ppf phrase
         with exn ->
@@ -260,6 +261,7 @@ let eval_expect_file _fname ~file_contents =
               (Printexc.to_string exn)
               (Printexc.raw_backtrace_to_string bt)
           end;
+          Btype.backtrack snap;
           false
       )
     in