Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #457 from diml/expect-tests 

Rewrite typing tests as expect tests
master
Jérémie Dimino 2016-03-01 10:59:18 +00:00
parent e8e352f1ed 3e255b5e07
commit c973f75799
19 changed files with 1326 additions and 1415 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -225,6 +225,7 @@
/testsuite/**/*.result
/testsuite/**/*.opt_result
/testsuite/**/*.corrected
/testsuite/**/*.byte
/testsuite/**/*.native
/testsuite/**/program
@ -292,6 +293,8 @@
/testsuite/tests/warnings/w55.opt.opt_result
/testsuite/tests/warnings/w58.opt.opt_result
/testsuite/tools/expect_test
/tools/ocamldep
/tools/ocamldep.opt
/tools/ocamldep.bak

14
testsuite/Makefile
View File

@ -32,6 +32,7 @@ default:
@echo " one DIR=p launch the tests located in path p"
@echo " promote DIR=p promote the reference files for the tests in p"
@echo " lib build library modules"
@echo " tools build test tools"
@echo " clean delete generated files"
@echo " report print the report for the last execution"
@echo
@ -40,7 +41,7 @@ default:
@echo "(default value = $(MAX_TESTSUITE_DIR_RETRIES))"
.PHONY: all
all: lib
all: lib tools
@for dir in tests/*; do \
$(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
done 2>&1 | tee _log
@ -48,7 +49,7 @@ all: lib
@$(MAKE) report
.PHONY: all-%
all-%: lib
all-%: lib tools
@for dir in tests/$**; do \
$(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
done 2>&1 | tee _log
@ -100,7 +101,7 @@ parallel-%: lib
parallel: parallel-*
.PHONY: list
list: lib
list: lib tools
@if [ -z "$(FILE)" ]; \
then echo "No value set for variable 'FILE'."; \
exit 1; \
@ -112,7 +113,7 @@ list: lib
@$(MAKE) report
.PHONY: one
one: lib
one: lib tools
@if [ -z "$(DIR)" ]; then \
echo "No value set for variable 'DIR'."; \
exit 1; \
@ -165,9 +166,14 @@ promote:
lib:
@cd lib && $(MAKE) -s BASEDIR=$(BASEDIR)
.PHONY: tools
tools:
@cd tools && $(MAKE) -s BASEDIR=$(BASEDIR)
.PHONY: clean
clean:
@cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean
@cd tools && $(MAKE) BASEDIR=$(BASEDIR) clean
@for file in `$(FIND) interactive tests -name Makefile`; do \
(cd `dirname $$file` && $(MAKE) BASEDIR=$(BASEDIR) clean); \
done

1
testsuite/makefiles/Makefile.common
View File

@ -68,6 +68,7 @@ endif
OCAML=$(OCAMLRUN) $(OTOPDIR)/ocaml $(OCFLAGS) \
-init $(OTOPDIR)/testsuite/lib/empty
EXPECT_TEST=$(OCAMLRUN) $(OTOPDIR)/testsuite/tools/expect_test$(EXE)
ifeq "$(FLEXLINK)" ""
FLEXLINK_PREFIX=
else

32
testsuite/makefiles/Makefile.expect Normal file
View File

@ -0,0 +1,32 @@
#########################################################################
# #
# OCaml #
# #
# Jeremie Dimino, Jane Street Europe #
# #
# Copyright 2016 Jane Street Group LLC #
# #
# All rights reserved. This file is distributed under the terms of #
# the GNU Lesser General Public License version 2.1, with the #
# special exception on linking described in the file LICENSE. #
# #
#########################################################################
default:
@for file in *.ml; do \
printf " ... testing '$$file':"; \
TERM=dumb $(EXPECT_TEST) -repo-root $(OTOPDIR) $$file && \
TERM=dumb $(EXPECT_TEST) -repo-root $(OTOPDIR) -principal \
$$file.corrected && \
mv $$file.corrected.corrected $$file.corrected && \
cmp $$file $$file.corrected && \
echo " => passed" || echo " => failed"; \
done
promote:
@for file in *.corrected; do \
cp $$file `basename $$file .corrected`; \
done
clean: defaultclean
@rm -f *.corrected

2
testsuite/tests/typing-immediate/Makefile
View File

@ -14,5 +14,5 @@
#**************************************************************************
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.expect
include $(BASEDIR)/makefiles/Makefile.common

76
testsuite/tests/typing-immediate/immediate.ml
View File

@ -1,5 +1,9 @@
module type S = sig type t [@@immediate] end;;
module F (M : S) : S = M;;
[%%expect{|
module type S = sig type t [@@immediate] end
module F : functor (M : S) -> S
|}];;
(* VALID DECLARATIONS *)
@ -17,40 +21,74 @@ module A = struct
type p = q [@@immediate]
and q = int
end;;
[%%expect{|
module A :
sig
type t [@@immediate]
type s = t [@@immediate]
type r = s
type p = q [@@immediate]
and q = int
end
|}];;
(* Valid using with constraints *)
module type X = sig type t end;;
module Y = struct type t = int end;;
module Z = ((Y : X with type t = int) : sig type t [@@immediate] end);;
[%%expect{|
module type X = sig type t end
module Y : sig type t = int end
module Z : sig type t [@@immediate] end
|}];;
(* Valid using an explicit signature *)
module M_valid : S = struct type t = int end;;
module FM_valid = F (struct type t = int end);;
[%%expect{|
module M_valid : S
module FM_valid : S
|}];;
(* Practical usage over modules *)
module Foo : sig type t val x : t ref end = struct
type t = int
let x = ref 0
end;;
[%%expect{|
module Foo : sig type t val x : t ref end
|}];;
module Bar : sig type t [@@immediate] val x : t ref end = struct
type t = int
let x = ref 0
end;;
[%%expect{|
module Bar : sig type t [@@immediate] val x : t ref end
|}];;
let test f =
let start = Sys.time() in f ();
(Sys.time() -. start);;
[%%expect{|
val test : (unit -> 'a) -> float = <fun>
|}];;
let test_foo () =
for i = 0 to 100_000_000 do
Foo.x := !Foo.x
done;;
[%%expect{|
val test_foo : unit -> unit = <fun>
|}];;
let test_bar () =
for i = 0 to 100_000_000 do
Bar.x := !Bar.x
done;;
[%%expect{|
val test_bar : unit -> unit = <fun>
|}];;
(* Uncomment these to test. Should see substantial speedup!
let () = Printf.printf "No @@immediate: %fs\n" (test test_foo)
@ -63,24 +101,62 @@ let () = Printf.printf "With @@immediate: %fs\n" (test test_bar) *)
module B = struct
type t = string [@@immediate]
end;;
[%%expect{|
Line _, characters 2-31:
Error: Types marked with the immediate attribute must be
non-pointer types like int or bool
|}];;
(* Not guaranteed that t is immediate, so this is an invalid declaration *)
module C = struct
type t
type s = t [@@immediate]
end;;
[%%expect{|
Line _, characters 2-26:
Error: Types marked with the immediate attribute must be
non-pointer types like int or bool
|}];;
(* Can't ascribe to an immediate type signature with a non-immediate type *)
module D : sig type t [@@immediate] end = struct
type t = string
end;;
[%%expect{|
Line _, characters 42-70:
Error: Signature mismatch:
Modules do not match:
sig type t = string end
is not included in
sig type t [@@immediate] end
Type declarations do not match:
type t = string
is not included in
type t [@@immediate]
the first is not an immediate type.
|}];;
(* Same as above but with explicit signature *)
module M_invalid : S = struct type t = string end;;
module FM_invalid = F (struct type t = string end);;
[%%expect{|
Line _, characters 23-49:
Error: Signature mismatch:
Modules do not match: sig type t = string end is not included in S
Type declarations do not match:
type t = string
is not included in
type t [@@immediate]
the first is not an immediate type.
|}];;
(* Can't use a non-immediate type even if mutually recursive *)
module E = struct
type t = s [@@immediate]
and s = string
end;;
[%%expect{|
Line _, characters 2-26:
Error: Types marked with the immediate attribute must be
non-pointer types like int or bool
|}];;

71
testsuite/tests/typing-immediate/immediate.ml.reference
View File

@ -1,71 +0,0 @@
# module type S = sig type t [@@immediate] end
# module F : functor (M : S) -> S
# module A :
sig
type t [@@immediate]
type s = t [@@immediate]
type r = s
type p = q [@@immediate]
and q = int
end
# module type X = sig type t end
# module Y : sig type t = int end
# module Z : sig type t [@@immediate] end
# module M_valid : S
# module FM_valid : S
# module Foo : sig type t val x : t ref end
# module Bar : sig type t [@@immediate] val x : t ref end
# val test : (unit -> 'a) -> float = <fun>
# val test_foo : unit -> unit = <fun>
# val test_bar : unit -> unit = <fun>
# * * Characters 306-335:
type t = string [@@immediate]
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Types marked with the immediate attribute must be
non-pointer types like int or bool
# Characters 106-130:
type s = t [@@immediate]
^^^^^^^^^^^^^^^^^^^^^^^^
Error: Types marked with the immediate attribute must be
non-pointer types like int or bool
# Characters 120-148:
..........................................struct
type t = string
end..
Error: Signature mismatch:
Modules do not match:
sig type t = string end
is not included in
sig type t [@@immediate] end
Type declarations do not match:
type t = string
is not included in
type t [@@immediate]
the first is not an immediate type.
# Characters 72-98:
module M_invalid : S = struct type t = string end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match: sig type t = string end is not included in S
Type declarations do not match:
type t = string
is not included in
type t [@@immediate]
the first is not an immediate type.
# Characters 23-49:
module FM_invalid = F (struct type t = string end);;
^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match: sig type t = string end is not included in S
Type declarations do not match:
type t = string
is not included in
type t [@@immediate]
the first is not an immediate type.
# Characters 85-109:
type t = s [@@immediate]
^^^^^^^^^^^^^^^^^^^^^^^^
Error: Types marked with the immediate attribute must be
non-pointer types like int or bool
#

2
testsuite/tests/typing-poly/Makefile
View File

@ -14,5 +14,5 @@
#**************************************************************************
BASEDIR=../..
include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.expect
include $(BASEDIR)/makefiles/Makefile.common

748
testsuite/tests/typing-poly/poly.ml
View File

File diff suppressed because it is too large Load Diff

675
testsuite/tests/typing-poly/poly.ml.principal.reference
View File

@ -1,675 +0,0 @@
# * * * # type 'a t = { t : 'a; }
# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
# val f : 'a list -> 'a fold = <fun>
# - : int = 6
# class ['b] ilist :
'b list ->
object ('c)
val l : 'b list
method add : 'b -> 'c
method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
end
# class virtual ['a] vlist :
object ('c)
method virtual add : 'a -> 'c
method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
end
# class ilist2 :
int list ->
object ('a)
val l : int list
method add : int -> 'a
method fold : f:('b -> int -> 'b) -> init:'b -> 'b
end
# val ilist2 : 'a list -> 'a vlist = <fun>
# class ['a] ilist3 :
'a list ->
object ('c)
val l : 'a list
method add : 'a -> 'c
method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
end
# class ['a] ilist4 :
'a list ->
object ('c)
val l : 'a list
method add : 'a -> 'c
method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
end
# class ['a] ilist5 :
'a list ->
object ('c)
val l : 'a list
method add : 'a -> 'c
method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
end
# class ['a] ilist6 :
'a list ->
object ('c)
val l : 'a list
method add : 'a -> 'c
method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
end
# class virtual ['a] olist :
object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
# class ['a] onil :
object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
# class ['a] ocons :
hd:'a ->
tl:'a olist ->
object
val hd : 'a
val tl : 'a olist
method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
end
# class ['a] ostream :
hd:'a ->
tl:'a ostream ->
object
val hd : 'a
val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
method empty : bool
method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
end
# Characters 166-178:
self#tl#fold ~f ~init:(f self#hd init)
^^^^^^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
class ['a] ostream1 :
hd:'a ->
tl:'b ->
object ('b)
val hd : 'a
val tl : 'b
method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
method hd : 'a
method tl : 'b
end
# class vari : object method m : [< `A | `B | `C ] -> int end
# class vari : object method m : [< `A | `B | `C ] -> int end
# module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
# class varj : object method m : [< V.v ] -> int end
# module type T =
sig class vari : object method m : [< `A | `B | `C ] -> int end end
# module M0 :
sig class vari : object method m : [< `A | `B | `C ] -> int end end
# module M : T
# val v : M.vari = <obj>
# - : int = 1
# class point :
x:int ->
y:int -> object val x : int val y : int method x : int method y : int end
# class color_point :
x:int ->
y:int ->
color:string ->
object
val color : string
val x : int
val y : int
method color : string
method x : int
method y : int
end
# class circle :
#point ->
r:int ->
object val p : point val r : int method distance : #point -> float end
# val p0 : point = <obj>
val p1 : point = <obj>
val cp : color_point = <obj>
val c : circle = <obj>
val d : float = 11.
# val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
# Characters 41-42:
let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
^
Error: This expression has type < m : 'b. 'b -> 'b list >
but an expression was expected of type < m : 'b. 'b -> 'c >
The universal variable 'b would escape its scope
# class id : object method id : 'a -> 'a end
# class type id_spec = object method id : 'a -> 'a end
# class id_impl : object method id : 'a -> 'a end
# class a : object method m : bool end
and b : object method id : 'a -> 'a end
# Characters 72-77:
method id x = x
^^^^^
Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
# Characters 75-80:
method id x = x
^^^^^
Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
# Characters 80-85:
method id _ = x
^^^^^
Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
# Characters 92-159:
............x =
match r with
None -> r <- Some x; x
| Some y -> y
Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
# class c : object method m : 'a -> 'b -> 'a end
# val f1 : id -> int * bool = <fun>
# val f2 : id -> int * bool = <fun>
# Characters 24-28:
let f3 f = f#id 1, f#id true
^^^^
Error: This expression has type bool but an expression was expected of type
int
# Characters 27-31:
let f4 f = ignore(f : id); f#id 1, f#id true
^^^^
Warning 18: this use of a polymorphic method is not principal.
Characters 35-39:
let f4 f = ignore(f : id); f#id 1, f#id true
^^^^
Warning 18: this use of a polymorphic method is not principal.
val f4 : id -> int * bool = <fun>
# class c : object method m : #id -> int * bool end
# class id2 : object method id : 'a -> 'a method mono : int -> int end
# val app : int * bool = (1, true)
# Characters 0-25:
type 'a foo = 'a foo list
^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The type abbreviation foo is cyclic
# class ['a] bar : 'a -> object end
# type 'a foo = 'a foo bar
# - : (< m : 'a. 'a * 'b > as 'b) -> 'c * (< m : 'a. 'a * 'd > as 'd) = <fun>
# - : (< m : 'a. 'b * 'a list > as 'b) ->
(< m : 'a. 'c * 'a list > as 'c) * 'd list
= <fun>
# val f :
(< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
(< m : 'd. 'c * (< n : 'd; .. > as 'd) > as 'c) * (< n : 'e; .. > as 'e) =
<fun>
# - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
(< m : 'c; n : < p : 'e. < m : 'e; n : 'd; .. > as 'e > as 'd; .. > as 'c)
= <fun>
# - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
('f *
< p : 'b.
'b * 'e *
(< m : 'a. 'a * < p : 'b0. 'b0 * 'h * 'g > as 'h > as 'g) >
as 'e)
= <fun>
# - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = <fun>
# type sum = T of < id : 'a. 'a -> 'a >
# - : sum -> 'a -> 'a = <fun>
# type record = { r : < id : 'a. 'a -> 'a >; }
# - : record -> 'a -> 'a = <fun>
# - : record -> 'a -> 'a = <fun>
# class myself : object ('b) method self : 'a -> 'b end
# class number :
object ('b)
val num : int
method num : int
method prev : 'b
method succ : 'b
method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
end
# val id : 'a -> 'a = <fun>
# class c : object method id : 'a -> 'a end
# class c' : object method id : 'a -> 'a end
# class d :
object
val mutable count : int
method count : int
method id : 'a -> 'a
method old : 'a -> 'a
end
# class ['a] olist :
'a list ->
object ('c)
val l : 'a list
method cons : 'a -> 'c
method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
end
# val sum : int #olist -> int = <fun>
# val count : 'a #olist -> int = <fun>
# val append : 'a #olist -> ('a #olist as 'b) -> 'b = <fun>
# type 'a t = unit
# class o : object method x : [> `A ] t -> unit end
# class c : object method m : d end
and d : ?x:int -> unit -> object end
# class d : ?x:int -> unit -> object end
and c : object method m : d end
# class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
# class type node_type = object method as_variant : [> `Node of node_type ] end
# class node : node_type
# class node : object method as_variant : [> `Node of node_type ] end
# type bad = { bad : 'a. 'a option ref; }
# Characters 17-25:
let bad = {bad = ref None};;
^^^^^^^^
Error: This field value has type 'b option ref which is less general than
'a. 'a option ref
# type bad2 = { mutable bad2 : 'a. 'a option ref option; }
# val bad2 : bad2 = {bad2 = None}
# Characters 13-28:
bad2.bad2 <- Some (ref None);;
^^^^^^^^^^^^^^^
Error: This field value has type 'b option ref option
which is less general than 'a. 'a option ref option
# val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = <fun>
# val f :
< m : 'a. 'a * (< p : int * 'b > as 'b) > ->
(< p : int * 'c > as 'c) -> unit = <fun>
# type 'a t = [ `A of 'a ]
# class c : object method m : ([> 'a t ] as 'a) -> unit end
# class c : object method m : ([> 'a t ] as 'a) -> unit end
# class c : object method m : ([> 'a t ] as 'a) -> 'a end
# class c : object method m : ([> `A ] as 'a) option -> 'a end
# Characters 145-166:
object method virtual visit : 'a.('a visitor -> 'a) end;;
^^^^^^^^^^^^^^^^^^^^^
Error: The universal type variable 'a cannot be generalized:
it escapes its scope.
# type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
# Characters 15-25:
type t = u and u = t;;
^^^^^^^^^^
Error: The type abbreviation t is cyclic
# class ['a] a : object constraint 'a = [> `A of 'a a ] end
type t = [ `A of t a ]
# Characters 71-80:
type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
^^^^^^^^^
Error: Constraints are not satisfied in this type.
Type ('a, 'b) t should be an instance of ('c, 'c) t
# type 'a t = 'a
and u = int t
# type 'a t constraint 'a = int
# Characters 26-32:
type 'a u = 'a and 'a v = 'a u t;;
^^^^^^
Error: Constraints are not satisfied in this type.
Type 'a u t should be an instance of int t
# type 'a u = 'a constraint 'a = int
and 'a v = 'a u t constraint 'a = int
# type g = int
# type 'a t = unit constraint 'a = g
# Characters 26-32:
type 'a u = 'a and 'a v = 'a u t;;
^^^^^^
Error: Constraints are not satisfied in this type.
Type 'a u t should be an instance of g t
# type 'a u = 'a constraint 'a = g
and 'a v = 'a u t constraint 'a = g
# Characters 34-58:
type 'a u = < m : 'a v > and 'a v = 'a list u;;
^^^^^^^^^^^^^^^^^^^^^^^^
Error: In the definition of v, type 'a list u should be 'a u
# type 'a t = 'a
type 'a u = A of 'a t
# type 'a t = < a : 'a >
# - : ('a t as 'a) -> ('b t as 'b) t = <fun>
# type u = 'a t as 'a
# type t = A | B
# - : [> `A ] * t -> int = <fun>
# - : [> `A ] * t -> int = <fun>
# - : [> `A ] option * t -> int = <fun>
# - : [> `A ] option * t -> int = <fun>
# - : t * [< `A | `B ] -> int = <fun>
# - : [< `A | `B ] * t -> int = <fun>
# Characters 0-41:
function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
(`AnyExtraTag, `AnyExtraTag)
- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
# Characters 0-29:
function `B,1 -> 1 | _,1 -> 2;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
(_, 0)
Characters 21-24:
function `B,1 -> 1 | _,1 -> 2;;
^^^
Warning 11: this match case is unused.
- : [< `B ] * int -> int = <fun>
# Characters 0-29:
function 1,`B -> 1 | 1,_ -> 2;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
(0, _)
Characters 21-24:
function 1,`B -> 1 | 1,_ -> 2;;
^^^
Warning 11: this match case is unused.
- : int * [< `B ] -> int = <fun>
# Characters 64-135:
type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Constraints are not satisfied in this type.
Type
([> `B of 'a ], 'a) b as 'a
should be an instance of
(('b, [> `A of ('d, 'c) a as 'd ] as 'c) a as 'b, 'c) b
# * class type ['a, 'b] a =
object
constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
method as_a : 'c
method b : 'b
end
and ['a, 'b] b =
object
constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
method a : 'a
method as_b : ('a, 'b) b
end
# class type ['a] ca =
object ('b)
constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. >
method as_a : ('b, 'a) a
method b : 'a
end
# class type ['a] cb =
object ('b)
constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
method a : 'a
method as_b : ('a, 'b) b
end
# type bt = 'a ca cb as 'a
# class c : object method m : int end
# val f : unit -> c = <fun>
# val f : unit -> c = <fun>
# Characters 11-60:
let f () = object method private n = 1 method m = {<>}#n end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 15: the following private methods were made public implicitly:
n.
val f : unit -> < m : int; n : int > = <fun>
# Characters 11-56:
let f () = object (self:c) method n = 1 method m = 2 end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This object is expected to have type c but actually has type
< m : int; n : 'a >
The first object type has no method n
# Characters 11-69:
let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This object is expected to have type < n : int > but actually has type
< m : 'a >
The second object type has no method n
# Characters 66-124:
object (self: 's) method x = 3 method private m = self end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This object is expected to have type < x : int; .. >
but actually has type < x : int >
Self type cannot be unified with a closed object type
# val o : < x : int > = <obj>
# Characters 76-77:
(x : <m : 'a. 'a * (<m:'b. 'a * <m:'c. 'c * 'bar> > as 'bar) >);;
^
Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
but an expression was expected of type
< m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
Types for method m are incompatible
# Characters 176-177:
let f (x : foo') = (x : bar');;
^
Error: This expression has type foo' = < m : 'a. 'a * 'a foo >
but an expression was expected of type bar' = < m : 'a. 'a * 'a bar >
Type 'a foo = < m : 'a * 'a foo > is not compatible with type
'a bar = < m : 'a * < m : 'c. 'c * 'a bar > >
Type 'a foo = < m : 'a * 'a foo > is not compatible with type
< m : 'c. 'c * 'a bar >
Types for method m are incompatible
# Characters 67-68:
(x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('c * 'bar)>)> as 'bar);;
^
Error: This expression has type
< m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
but an expression was expected of type
< m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
Types for method m are incompatible
# Characters 66-67:
(x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('b * 'bar)>)> as 'bar);;
^
Error: This expression has type
< m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
but an expression was expected of type
< m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd
Types for method m are incompatible
# Characters 51-52:
(x : <m : 'b. 'b * ('b * <m:'c. 'c * 'bar> as 'bar)>);;
^
Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
but an expression was expected of type
< m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) >
Types for method m are incompatible
# Characters 14-115:
....(x : <m : 'a. 'a -> ('a * <m:'c. 'c -> 'bar> as 'bar)>
:> <m : 'a. 'a -> ('a * 'foo)> as 'foo)..
Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f
Type 'c. 'e is not a subtype of 'a. 'g
# Characters 88-150:
= struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
is not included in
sig
val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
end
Values do not match:
val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
is not included in
val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
# Characters 78-132:
= struct type t = <m : 'a. 'a * ('a * 'foo)> as 'foo end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end
is not included in
sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end
Type declarations do not match:
type t = < m : 'a. 'a * ('a * 'b) > as 'b
is not included in
type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
# module M : sig type 'a t type u = < m : 'a. 'a t > end
# module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
# module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
# val f :
(< m : 'a. 'a -> (< m : 'a. 'a -> 'c * < > > as 'c) * < .. >; .. > as 'b) ->
'b -> bool = <fun>
# type t = [ `A | `B ]
# type v = private [> t ]
# - : t -> v = <fun>
# type u = private [< t ]
# - : u -> v = <fun>
# Characters 9-21:
fun x -> (x : v :> u);;
^^^^^^^^^^^^
Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ]
# type v = private [< t ]
# Characters 9-21:
fun x -> (x : u :> v);;
^^^^^^^^^^^^
Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ]
# type p = < x : p >
# type q = private < x : p; .. >
# - : q -> p = <fun>
# Characters 9-21:
fun x -> (x : p :> q);;
^^^^^^^^^^^^
Error: Type p = < x : p > is not a subtype of q = < x : p; .. >
# Characters 14-100:
..(x : <m:'a. (<p:int;..> as 'a) -> int>
:> <m:'b. (<p:int;q:int;..> as 'b) -> int>)..
Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
< m : 'b. (< p : int; q : int; .. > as 'b) -> int >
Type < p : int; q : int; .. > as 'c is not a subtype of
< p : int; .. > as 'd
# val f2 :
< m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
< m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = <fun>
# Characters 13-107:
..(x : <m:'a. (<p:<a:int;b:int>;..> as 'a) -> int>
:> <m:'b. (<p:<a:int>;..> as 'b) -> int>)..
Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int >
Type < a : int > is not a subtype of < a : int; b : int >
# Characters 11-55:
let f4 x = (x : <p:<a:int;b:int>;..> :> <p:<a:int>;..>);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type < p : < a : int; b : int >; .. > is not a subtype of
< p : < a : int >; .. >
The second object type has no method b
# val f5 :
< m : 'a. [< `A of < p : int > ] as 'a > ->
< m : 'b. [< `A of < > ] as 'b > = <fun>
# Characters 13-83:
(x : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of
< m : 'b. [< `A of < p : int > ] as 'b >
Type < > is not a subtype of < p : int >
# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
# Characters 9-16:
fun x -> (f x)#m;; (* Warning 18 *)
^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
# val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun>
# Characters 9-20:
fun x -> (f (x,x))#m;; (* Warning 18 *)
^^^^^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = <fun>
# Characters 9-20:
fun x -> (f x).(0)#m;; (* Warning 18 *)
^^^^^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
# class c : object method id : 'a -> 'a end
# type u = c option
# val just : 'a option -> 'a = <fun>
# Characters 42-62:
let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;;
^^^^^^^^^^^^^^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
val f : c -> 'a -> 'a = <fun>
# Characters 101-112:
let x = List.hd [Some x; none] in (just x)#id;;
^^^^^^^^^^^
Warning 18: this use of a polymorphic method is not principal.
val g : c -> 'a -> 'a = <fun>
# val h : < id : 'a; .. > -> 'a = <fun>
# type 'a u = c option
# val just : 'a option -> 'a = <fun>
# val f : c -> 'a -> 'a = <fun>
# val f : 'a -> int = <fun>
val g : 'a -> int = <fun>
# type 'a t = Leaf of 'a | Node of ('a * 'a) t
# val depth : 'a t -> int = <fun>
# Characters 34-74:
function Leaf _ -> 1 | Node x -> 1 + d x
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type 'a t -> int which is less general than
'a0. 'a0 t -> int
# Characters 34-78:
function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type int t -> int which is less general than
'a. 'a t -> int
# Characters 34-74:
function Leaf x -> x | Node x -> depth x;; (* fails *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type 'a t -> 'a which is less general than
'a0. 'a0 t -> 'a
# Characters 38-78:
function Leaf x -> x | Node x -> depth x;; (* fails *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type 'b. 'b t -> 'b which is less general than
'a 'b. 'a t -> 'b
# val r : 'a list * '_b list ref = ([], {contents = []})
val q : unit -> 'a list * '_b list ref = <fun>
# val f : 'a -> 'a = <fun>
# val zero : [> `B of 'a | `Int of int ] as 'a = `Int 0
# Characters 39-45:
let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *)
^^^^^^
Error: This expression has type [> `Int of int ]
but an expression was expected of type [< `Int of int ]
Types for tag `Int are incompatible
# type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; }
val zero : t = {f = `Int 0}
# Characters 56-62:
let zero = {f = `Int 0} ;; (* fails *)
^^^^^^
Error: This expression has type [> `Int of int ]
but an expression was expected of type [< `Int of int ]
Types for tag `Int are incompatible
# val id : 'a -> 'a = <fun>
val neg : int -> bool -> int * bool = <fun>
# type t = A of int | B of (int * t) list | C of (string * t) list
val transf : (int -> t) -> t -> t = <fun>
val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = <fun>
# type t = { f : 'a. ('a list -> int) Lazy.t; }
val l : t = {f = <lazy>}
# type t = { f : 'a. 'a -> unit; }
# - : t = {f = <fun>}
# Characters 19-20:
let f ?x y = y in {f};; (* fail *)
^
Error: This field value has type unit -> unit which is less general than
'a. 'a -> unit
# module Polux :
sig
type 'par t = 'par
val ident : 'a -> 'a
class alias : object method alias : 'a t -> 'a end
val f : < m : 'a. 'a t > -> < m : 'a. 'a >
end
# Exception: Pervasives.Exit.
# Exception: Pervasives.Exit.
# Exception: Pervasives.Exit.
# Characters 16-44:
type 'x t = < f : 'y. 'y t >;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In the definition of t, type 'y t should be 'x t
# val using_match : bool -> int * ('a -> 'a) = <fun>
# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
# val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = <obj>
# Characters 89-110:
object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
^^^^^^^^^^^^^^^^^^^^^
Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
which is less general than 'x. 'a -> 'x
# Characters 104-125:
object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
^^^^^^^^^^^^^^^^^^^^^
Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
which is less general than 'x. 'a -> 'x
# Characters 128-149:
object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
^^^^^^^^^^^^^^^^^^^^^
Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b
which is less general than 'x. 'a -> 'x
# Characters 94-97:
if b then x else M.A;;
^^^
Error: This expression has type M.t but an expression was expected of type 'x
The type constructor M.t would escape its scope
#

629
testsuite/tests/typing-poly/poly.ml.reference
View File

@ -1,629 +0,0 @@
# * * * # type 'a t = { t : 'a; }
# type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
# val f : 'a list -> 'a fold = <fun>
# - : int = 6
# class ['b] ilist :
'b list ->
object ('c)
val l : 'b list
method add : 'b -> 'c
method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
end
# class virtual ['a] vlist :
object ('c)
method virtual add : 'a -> 'c
method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
end
# class ilist2 :
int list ->
object ('a)
val l : int list
method add : int -> 'a
method fold : f:('b -> int -> 'b) -> init:'b -> 'b
end
# val ilist2 : 'a list -> 'a vlist = <fun>
# class ['a] ilist3 :
'a list ->
object ('c)
val l : 'a list
method add : 'a -> 'c
method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
end
# class ['a] ilist4 :
'a list ->
object ('c)
val l : 'a list
method add : 'a -> 'c
method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
end
# class ['a] ilist5 :
'a list ->
object ('c)
val l : 'a list
method add : 'a -> 'c
method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
end
# class ['a] ilist6 :
'a list ->
object ('c)
val l : 'a list
method add : 'a -> 'c
method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
end
# class virtual ['a] olist :
object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
# class ['a] onil :
object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
# class ['a] ocons :
hd:'a ->
tl:'a olist ->
object
val hd : 'a
val tl : 'a olist
method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
end
# class ['a] ostream :
hd:'a ->
tl:'a ostream ->
object
val hd : 'a
val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
method empty : bool
method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
end
# class ['a] ostream1 :
hd:'a ->
tl:'b ->
object ('b)
val hd : 'a
val tl : 'b
method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
method hd : 'a
method tl : 'b
end
# class vari : object method m : [< `A | `B | `C ] -> int end
# class vari : object method m : [< `A | `B | `C ] -> int end
# module V : sig type v = [ `A | `B | `C ] val m : [< v ] -> int end
# class varj : object method m : [< V.v ] -> int end
# module type T =
sig class vari : object method m : [< `A | `B | `C ] -> int end end
# module M0 :
sig class vari : object method m : [< `A | `B | `C ] -> int end end
# module M : T
# val v : M.vari = <obj>
# - : int = 1
# class point :
x:int ->
y:int -> object val x : int val y : int method x : int method y : int end
# class color_point :
x:int ->
y:int ->
color:string ->
object
val color : string
val x : int
val y : int
method color : string
method x : int
method y : int
end
# class circle :
#point ->
r:int ->
object val p : point val r : int method distance : #point -> float end
# val p0 : point = <obj>
val p1 : point = <obj>
val cp : color_point = <obj>
val c : circle = <obj>
val d : float = 11.
# val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
# Characters 41-42:
let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
^
Error: This expression has type < m : 'b. 'b -> 'b list >
but an expression was expected of type < m : 'b. 'b -> 'c >
The universal variable 'b would escape its scope
# class id : object method id : 'a -> 'a end
# class type id_spec = object method id : 'a -> 'a end
# class id_impl : object method id : 'a -> 'a end
# class a : object method m : bool end
and b : object method id : 'a -> 'a end
# Characters 72-77:
method id x = x
^^^^^
Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
# Characters 75-80:
method id x = x
^^^^^
Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
# Characters 80-85:
method id _ = x
^^^^^
Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
# Characters 92-159:
............x =
match r with
None -> r <- Some x; x
| Some y -> y
Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
# class c : object method m : 'a -> 'b -> 'a end
# val f1 : id -> int * bool = <fun>
# val f2 : id -> int * bool = <fun>
# Characters 24-28:
let f3 f = f#id 1, f#id true
^^^^
Error: This expression has type bool but an expression was expected of type
int
# val f4 : id -> int * bool = <fun>
# class c : object method m : #id -> int * bool end
# class id2 : object method id : 'a -> 'a method mono : int -> int end
# val app : int * bool = (1, true)
# Characters 0-25:
type 'a foo = 'a foo list
^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The type abbreviation foo is cyclic
# class ['a] bar : 'a -> object end
# type 'a foo = 'a foo bar
# - : (< m : 'a. 'a * 'b > as 'b) -> 'c * 'b = <fun>
# - : (< m : 'a. 'b * 'a list > as 'b) -> 'b * 'c list = <fun>
# val f :
(< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
'a * (< n : 'c; .. > as 'c) = <fun>
# - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
(< m : 'c; n : 'a; .. > as 'c)
= <fun>
# - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
('f * < p : 'b. 'b * 'e * 'c > as 'e)
= <fun>
# - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = <fun>
# type sum = T of < id : 'a. 'a -> 'a >
# - : sum -> 'a -> 'a = <fun>
# type record = { r : < id : 'a. 'a -> 'a >; }
# - : record -> 'a -> 'a = <fun>
# - : record -> 'a -> 'a = <fun>
# class myself : object ('b) method self : 'a -> 'b end
# class number :
object ('b)
val num : int
method num : int
method prev : 'b
method succ : 'b
method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
end
# val id : 'a -> 'a = <fun>
# class c : object method id : 'a -> 'a end
# class c' : object method id : 'a -> 'a end
# class d :
object
val mutable count : int
method count : int
method id : 'a -> 'a
method old : 'a -> 'a
end
# class ['a] olist :
'a list ->
object ('c)
val l : 'a list
method cons : 'a -> 'c
method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
end
# val sum : int #olist -> int = <fun>
# val count : 'a #olist -> int = <fun>
# val append : 'a #olist -> ('a #olist as 'b) -> 'b = <fun>
# type 'a t = unit
# class o : object method x : [> `A ] t -> unit end
# class c : object method m : d end
and d : ?x:int -> unit -> object end
# class d : ?x:int -> unit -> object end
and c : object method m : d end
# class type numeral = object method fold : ('a -> 'a) -> 'a -> 'a end
class zero : object method fold : ('a -> 'a) -> 'a -> 'a end
class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
# class type node_type = object method as_variant : [> `Node of node_type ] end
# class node : node_type
# class node : object method as_variant : [> `Node of node_type ] end
# type bad = { bad : 'a. 'a option ref; }
# Characters 17-25:
let bad = {bad = ref None};;
^^^^^^^^
Error: This field value has type 'b option ref which is less general than
'a. 'a option ref
# type bad2 = { mutable bad2 : 'a. 'a option ref option; }
# val bad2 : bad2 = {bad2 = None}
# Characters 13-28:
bad2.bad2 <- Some (ref None);;
^^^^^^^^^^^^^^^
Error: This field value has type 'b option ref option
which is less general than 'a. 'a option ref option
# val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = <fun>
# val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = <fun>
# type 'a t = [ `A of 'a ]
# class c : object method m : ([> 'a t ] as 'a) -> unit end
# class c : object method m : ([> 'a t ] as 'a) -> unit end
# class c : object method m : ([> 'a t ] as 'a) -> 'a end
# class c : object method m : ([> `A ] as 'a) option -> 'a end
# Characters 145-166:
object method virtual visit : 'a.('a visitor -> 'a) end;;
^^^^^^^^^^^^^^^^^^^^^
Error: The universal type variable 'a cannot be generalized:
it escapes its scope.
# type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
# Characters 15-25:
type t = u and u = t;;
^^^^^^^^^^
Error: The type abbreviation t is cyclic
# class ['a] a : object constraint 'a = [> `A of 'a a ] end
type t = [ `A of t a ]
# Characters 71-80:
type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
^^^^^^^^^
Error: Constraints are not satisfied in this type.
Type ('a, 'b) t should be an instance of ('c, 'c) t
# type 'a t = 'a
and u = int t
# type 'a t constraint 'a = int
# Characters 26-32:
type 'a u = 'a and 'a v = 'a u t;;
^^^^^^
Error: Constraints are not satisfied in this type.
Type 'a u t should be an instance of int t
# type 'a u = 'a constraint 'a = int
and 'a v = 'a u t constraint 'a = int
# type g = int
# type 'a t = unit constraint 'a = g
# Characters 26-32:
type 'a u = 'a and 'a v = 'a u t;;
^^^^^^
Error: Constraints are not satisfied in this type.
Type 'a u t should be an instance of g t
# type 'a u = 'a constraint 'a = g
and 'a v = 'a u t constraint 'a = g
# Characters 34-58:
type 'a u = < m : 'a v > and 'a v = 'a list u;;
^^^^^^^^^^^^^^^^^^^^^^^^
Error: In the definition of v, type 'a list u should be 'a u
# type 'a t = 'a
type 'a u = A of 'a t
# type 'a t = < a : 'a >
# - : ('a t as 'a) -> 'a t = <fun>
# type u = 'a t as 'a
# type t = A | B
# - : [> `A ] * t -> int = <fun>
# - : [> `A ] * t -> int = <fun>
# - : [> `A ] option * t -> int = <fun>
# - : [> `A ] option * t -> int = <fun>
# - : t * [< `A | `B ] -> int = <fun>
# - : [< `A | `B ] * t -> int = <fun>
# Characters 0-41:
function (`A|`B), _ -> 0 | _,(`A|`B) -> 1;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
(`AnyExtraTag, `AnyExtraTag)
- : [> `A | `B ] * [> `A | `B ] -> int = <fun>
# Characters 0-29:
function `B,1 -> 1 | _,1 -> 2;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
(_, 0)
Characters 21-24:
function `B,1 -> 1 | _,1 -> 2;;
^^^
Warning 11: this match case is unused.
- : [< `B ] * int -> int = <fun>
# Characters 0-29:
function 1,`B -> 1 | 1,_ -> 2;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
(0, _)
Characters 21-24:
function 1,`B -> 1 | 1,_ -> 2;;
^^^
Warning 11: this match case is unused.
- : int * [< `B ] -> int = <fun>
# Characters 64-135:
type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b]
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Constraints are not satisfied in this type.
Type
([> `B of 'a ], 'a) b as 'a
should be an instance of
(('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
# * class type ['a, 'b] a =
object
constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
method as_a : 'c
method b : 'b
end
and ['a, 'b] b =
object
constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
constraint 'b = < a : 'a; as_b : ('a, 'b) b; .. >
method a : 'a
method as_b : ('a, 'b) b
end
# class type ['a] ca =
object ('b)
constraint 'a = < a : 'b; as_b : ('b, 'a) b; .. >
method as_a : ('b, 'a) a
method b : 'a
end
# class type ['a] cb =
object ('b)
constraint 'a = < as_a : ('a, 'b) a; b : 'b; .. >
method a : 'a
method as_b : ('a, 'b) b
end
# type bt = 'a ca cb as 'a
# class c : object method m : int end
# val f : unit -> c = <fun>
# val f : unit -> c = <fun>
# Characters 11-60:
let f () = object method private n = 1 method m = {<>}#n end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 15: the following private methods were made public implicitly:
n.
val f : unit -> < m : int; n : int > = <fun>
# Characters 11-56:
let f () = object (self:c) method n = 1 method m = 2 end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This object is expected to have type c but actually has type
< m : int; n : 'a >
The first object type has no method n
# Characters 11-69:
let f () = object (_:'s) constraint 's = < n : int > method m = 1 end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This object is expected to have type < n : int > but actually has type
< m : 'a >
The second object type has no method n
# Characters 66-124:
object (self: 's) method x = 3 method private m = self end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This object is expected to have type < x : int; .. >
but actually has type < x : int >
Self type cannot be unified with a closed object type
# val o : < x : int > = <obj>
# Characters 76-77:
(x : <m : 'a. 'a * (<m:'b. 'a * <m:'c. 'c * 'bar> > as 'bar) >);;
^
Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
but an expression was expected of type
< m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
Types for method m are incompatible
# Characters 176-177:
let f (x : foo') = (x : bar');;
^
Error: This expression has type foo' = < m : 'a. 'a * 'a foo >
but an expression was expected of type bar' = < m : 'a. 'a * 'a bar >
Type 'a foo = < m : 'a * 'a foo > is not compatible with type
'a bar = < m : 'a * < m : 'c. 'c * 'a bar > >
Type 'a foo = < m : 'a * 'a foo > is not compatible with type
< m : 'c. 'c * 'a bar >
Types for method m are incompatible
# Characters 67-68:
(x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('c * 'bar)>)> as 'bar);;
^
Error: This expression has type
< m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
but an expression was expected of type
< m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
Types for method m are incompatible
# Characters 66-67:
(x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('b * 'bar)>)> as 'bar);;
^
Error: This expression has type
< m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
but an expression was expected of type
< m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd
Types for method m are incompatible
# Characters 51-52:
(x : <m : 'b. 'b * ('b * <m:'c. 'c * 'bar> as 'bar)>);;
^
Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
but an expression was expected of type
< m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) >
Types for method m are incompatible
# Characters 14-115:
....(x : <m : 'a. 'a -> ('a * <m:'c. 'c -> 'bar> as 'bar)>
:> <m : 'a. 'a -> ('a * 'foo)> as 'foo)..
Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f
Type 'c. 'e is not a subtype of 'a. 'g
# Characters 88-150:
= struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
...
Values do not match:
val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
is not included in
val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
# Characters 78-132:
= struct type t = <m : 'a. 'a * ('a * 'foo)> as 'foo end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end
is not included in
sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end
Type declarations do not match:
type t = < m : 'a. 'a * ('a * 'b) > as 'b
is not included in
type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
# module M : sig type 'a t type u = < m : 'a. 'a t > end
# module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
# module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
# val f :
(< m : 'a. 'a -> (< m : 'a. 'a -> 'c * < > > as 'c) * < .. >; .. > as 'b) ->
'b -> bool = <fun>
# type t = [ `A | `B ]
# type v = private [> t ]
# - : t -> v = <fun>
# type u = private [< t ]
# - : u -> v = <fun>
# Characters 9-21:
fun x -> (x : v :> u);;
^^^^^^^^^^^^
Error: Type v = [> `A | `B ] is not a subtype of u = [< `A | `B ]
# type v = private [< t ]
# Characters 9-21:
fun x -> (x : u :> v);;
^^^^^^^^^^^^
Error: Type u = [< `A | `B ] is not a subtype of v = [< `A | `B ]
# type p = < x : p >
# type q = private < x : p; .. >
# - : q -> p = <fun>
# Characters 9-21:
fun x -> (x : p :> q);;
^^^^^^^^^^^^
Error: Type p = < x : p > is not a subtype of q = < x : p; .. >
# Characters 14-100:
..(x : <m:'a. (<p:int;..> as 'a) -> int>
:> <m:'b. (<p:int;q:int;..> as 'b) -> int>)..
Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
< m : 'b. (< p : int; q : int; .. > as 'b) -> int >
Type < p : int; q : int; .. > as 'c is not a subtype of
< p : int; .. > as 'd
# val f2 :
< m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
< m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = <fun>
# Characters 13-107:
..(x : <m:'a. (<p:<a:int;b:int>;..> as 'a) -> int>
:> <m:'b. (<p:<a:int>;..> as 'b) -> int>)..
Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int >
Type < a : int > is not a subtype of < a : int; b : int >
# Characters 11-55:
let f4 x = (x : <p:<a:int;b:int>;..> :> <p:<a:int>;..>);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type < p : < a : int; b : int >; .. > is not a subtype of
< p : < a : int >; .. >
The second object type has no method b
# val f5 :
< m : 'a. [< `A of < p : int > ] as 'a > ->
< m : 'b. [< `A of < > ] as 'b > = <fun>
# Characters 13-83:
(x : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of
< m : 'b. [< `A of < p : int > ] as 'b >
Type < > is not a subtype of < p : int >
# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
# val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun>
# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = <fun>
# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
# class c : object method id : 'a -> 'a end
# type u = c option
# val just : 'a option -> 'a = <fun>
# val f : c -> 'a -> 'a = <fun>
# val g : c -> 'a -> 'a = <fun>
# val h : < id : 'a; .. > -> 'a = <fun>
# type 'a u = c option
# val just : 'a option -> 'a = <fun>
# val f : c -> 'a -> 'a = <fun>
# val f : 'a -> int = <fun>
val g : 'a -> int = <fun>
# type 'a t = Leaf of 'a | Node of ('a * 'a) t
# val depth : 'a t -> int = <fun>
# Characters 34-74:
function Leaf _ -> 1 | Node x -> 1 + d x
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type 'a t -> int which is less general than
'a0. 'a0 t -> int
# Characters 34-78:
function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type int t -> int which is less general than
'a. 'a t -> int
# Characters 34-74:
function Leaf x -> x | Node x -> depth x;; (* fails *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type 'a t -> 'a which is less general than
'a0. 'a0 t -> 'a
# Characters 38-78:
function Leaf x -> x | Node x -> depth x;; (* fails *)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This definition has type 'b. 'b t -> 'b which is less general than
'a 'b. 'a t -> 'b
# val r : 'a list * '_b list ref = ([], {contents = []})
val q : unit -> 'a list * '_b list ref = <fun>
# val f : 'a -> 'a = <fun>
# val zero : [> `B of 'a | `Int of int ] as 'a = `Int 0
# Characters 39-45:
let zero : 'a. [< `Int of int] as 'a = `Int 0;; (* fails *)
^^^^^^
Error: This expression has type [> `Int of int ]
but an expression was expected of type [< `Int of int ]
Types for tag `Int are incompatible
# type t = { f : 'a. [> `B of 'a | `Int of int ] as 'a; }
val zero : t = {f = `Int 0}
# Characters 56-62:
let zero = {f = `Int 0} ;; (* fails *)
^^^^^^
Error: This expression has type [> `Int of int ]
but an expression was expected of type [< `Int of int ]
Types for tag `Int are incompatible
# val id : 'a -> 'a = <fun>
val neg : int -> bool -> int * bool = <fun>
# type t = A of int | B of (int * t) list | C of (string * t) list
val transf : (int -> t) -> t -> t = <fun>
val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = <fun>
# type t = { f : 'a. ('a list -> int) Lazy.t; }
val l : t = {f = <lazy>}
# type t = { f : 'a. 'a -> unit; }
# - : t = {f = <fun>}
# Characters 19-20:
let f ?x y = y in {f};; (* fail *)
^
Error: This field value has type unit -> unit which is less general than
'a. 'a -> unit
# module Polux :
sig
type 'par t = 'par
val ident : 'a -> 'a
class alias : object method alias : 'a t -> 'a end
val f : < m : 'a. 'a t > -> < m : 'a. 'a >
end
# Exception: Pervasives.Exit.
# Exception: Pervasives.Exit.
# Exception: Pervasives.Exit.
# Characters 16-44:
type 'x t = < f : 'y. 'y t >;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: In the definition of t, type 'y t should be 'x t
# val using_match : bool -> int * ('a -> 'a) = <fun>
# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>)
# val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = <obj>
# val n : < m : 'x. [< `Foo of 'x ] -> 'x > = <obj>
# Characters 59-129:
object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
but an expression was expected of type
< m : 'a. [< `Foo of int ] -> 'a >
The universal variable 'x would escape its scope
# Characters 83-153:
object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x >
but an expression was expected of type
< m : 'a. [< `Foo of int ] -> 'a >
The universal variable 'x would escape its scope
# Characters 94-97:
if b then x else M.A;;
^^^
Error: This expression has type M.t but an expression was expected of type 'x
The type constructor M.t would escape its scope
#

31
testsuite/tools/Makefile Normal file
View File

@ -0,0 +1,31 @@
#########################################################################
# #
# OCaml #
# #
# Jeremie Dimino, Jane Street Europe #
# #
# Copyright 2016 Jane Street Group LLC #
# #
# All rights reserved. This file is distributed under the terms of #
# the GNU Lesser General Public License version 2.1, with the #
# special exception on linking described in the file LICENSE. #
# #
#########################################################################
BASEDIR=..
MAIN=expect_test
PROG=$(MAIN)$(EXE)
COMPFLAGS=-I $(OTOPDIR)/parsing -I $(OTOPDIR)/utils \
-I $(OTOPDIR)/driver -I $(OTOPDIR)/toplevel
LIBRARIES=../../compilerlibs/ocamlcommon \
../../compilerlibs/ocamlbytecomp \
../../compilerlibs/ocamltoplevel
$(PROG): $(MAIN).cmo
$(OCAMLC) -linkall -o $(PROG) $(LIBRARIES:=.cma) $(MAIN).cmo
include $(BASEDIR)/makefiles/Makefile.common
.PHONY: clean
clean: defaultclean
rm -f $(PROG)

333
testsuite/tools/expect_test.ml Normal file
View File

@ -0,0 +1,333 @@
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Jeremie Dimino, Jane Street Europe *)
(* *)
(* Copyright 2016 Jane Street Group LLC *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(***********************************************************************)
(* Execute a list of phrase from a .ml file and compare the result to the
expected output, written inside [%%expect ...] nodes. At the end, create
a .corrected file containing the corrected expectations. The test is
successul if there is no differences between the two files.
An [%%expect] node always contains both the expected outcome with and
without -principal. When the two differ the expection is written as follow:
{[
[%%expect {|
output without -principal
|}, Principal{|
output with -principal
|}]
]}
*)
[@@@ocaml.warning "-40"]
open StdLabels
(* representation of: {tag|str|tag} *)
type string_constant =
{ str : string
; tag : string
}
type expectation =
{ extid_loc : Location.t (* Location of "expect" in "[%%expect ...]" *)
; payload_loc : Location.t (* Location of the whole payload *)
; normal : string_constant (* expectation without -principal *)
; principal : string_constant (* expectation with -principal *)
}
(* A list of phrases with the expected toplevel output *)
type chunk =
{ phrases : Parsetree.toplevel_phrase list
; expectation : expectation
}
type correction =
{ corrected_expectations : expectation list
; trailing_output : string
}
let match_expect_extension (ext : Parsetree.extension) =
match ext with
| ({Asttypes.txt="expect"|"ocaml.expect"; loc = extid_loc}, payload) ->
let invalid_payload () =
Location.raise_errorf ~loc:extid_loc
"invalid [%%%%expect payload]"
in
let string_constant (e : Parsetree.expression) =
match e.pexp_desc with
| Pexp_constant (Pconst_string (str, Some tag)) ->
{ str; tag }
| _ -> invalid_payload ()
in
let expectation =
match payload with
| PStr [{ pstr_desc = Pstr_eval (e, []) }] ->
let normal, principal =
match e.pexp_desc with
| Pexp_tuple
[ a
; { pexp_desc = Pexp_construct
({ txt = Lident "Principal"; _ }, Some b) }
] ->
(string_constant a, string_constant b)
| _ -> let s = string_constant e in (s, s)
in
{ extid_loc
; payload_loc = e.pexp_loc
; normal
; principal
}
| PStr [] ->
let s = { tag = ""; str = "" } in
{ extid_loc
; payload_loc = { extid_loc with loc_start = extid_loc.loc_end }
; normal = s
; principal = s
}
| _ -> invalid_payload ()
in
Some expectation
| _ ->
None
(* Split a list of phrases from a .ml file *)
let split_chunks phrases =
let rec loop (phrases : Parsetree.toplevel_phrase list) code_acc acc =
match phrases with
| [] ->
if code_acc = [] then
(List.rev acc, None)
else
(List.rev acc, Some (List.rev code_acc))
| phrase :: phrases ->
match phrase with
| Ptop_def [] -> loop phrases code_acc acc
| Ptop_def [{pstr_desc = Pstr_extension(ext, [])}] -> begin
match match_expect_extension ext with
| None -> loop phrases (phrase :: code_acc) acc
| Some expectation ->
let chunk =
{ phrases = List.rev code_acc
; expectation
}
in
loop phrases [] (chunk :: acc)
end
| _ -> loop phrases (phrase :: code_acc) acc
in
loop phrases [] []
module Compiler_messages = struct
let print_loc ppf (loc : Location.t) =
let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
Format.fprintf ppf "Line _";
if startchar >= 0 then
Format.fprintf ppf ", characters %d-%d" startchar endchar;
Format.fprintf ppf ":@."
let rec error_reporter ppf ({loc; msg; sub; if_highlight=_} : Location.error) =
print_loc ppf loc;
Format.pp_print_string ppf msg;
List.iter sub ~f:(fun err ->
Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err)
let warning_printer loc ppf w =
if Warnings.is_active w then begin
print_loc ppf loc;
Format.fprintf ppf "Warning %a@." Warnings.print w
end
let capture ppf ~f =
Misc.protect_refs
[ R (Location.formatter_for_warnings , ppf )
; R (Location.warning_printer , warning_printer)
; R (Location.error_reporter , error_reporter )
]
f
end
let exec_phrase ppf phrase =
if !Clflags.dump_parsetree then Printast. top_phrase ppf phrase;
if !Clflags.dump_source then Pprintast.top_phrase ppf phrase;
Toploop.execute_phrase true ppf phrase
let parse_contents ~fname contents =
let lexbuf = Lexing.from_string contents in
Location.init lexbuf fname;
Location.input_name := fname;
Parse.use_file lexbuf
let eval_expectation expectation ~output =
let s =
if !Clflags.principal then
expectation.principal
else
expectation.normal
in
if s.str = output then
None
else
let s = { s with str = output } in
Some (
if !Clflags.principal then
{ expectation with principal = s }
else
{ expectation with normal = s }
)
let shift_lines delta phrases =
let position (pos : Lexing.position) =
{ pos with pos_lnum = pos.pos_lnum + delta }
in
let location _this (loc : Location.t) =
{ loc with
loc_start = position loc.loc_start
; loc_end = position loc.loc_end
}
in
let mapper = { Ast_mapper.default_mapper with location } in
List.map phrases ~f:(function
| Parsetree.Ptop_dir _ as p -> p
| Parsetree.Ptop_def st ->
Parsetree.Ptop_def (mapper.structure mapper st))
let rec min_line_number : Parsetree.toplevel_phrase list -> int option = function
| [] -> None
| (Ptop_dir _ | Ptop_def []) :: l -> min_line_number l
| Ptop_def (st :: _) :: _ -> Some st.pstr_loc.loc_start.pos_lnum
let eval_expect_file _fname ~file_contents =
Warnings.reset_fatal ();
let chunks, trailing_code =
parse_contents ~fname:"" file_contents |> split_chunks
in
let buf = Buffer.create 1024 in
let ppf = Format.formatter_of_buffer buf in
let exec_phrases phrases =
let phrases =
match min_line_number phrases with
| None -> phrases
| Some lnum -> shift_lines (1 - lnum) phrases
in
(* For formatting purposes *)
Buffer.add_char buf '\n';
let _ : bool =
List.fold_left phrases ~init:true ~f:(fun acc phrase ->
acc &&
try
exec_phrase ppf phrase
with exn ->
Location.report_exception ppf exn;
false)
in
Format.pp_print_flush ppf ();
let len = Buffer.length buf in
if len > 0 && Buffer.nth buf (len - 1) <> '\n' then
(* For formatting purposes *)
Buffer.add_char buf '\n';
let s = Buffer.contents buf in
Buffer.clear buf;
Misc.delete_eol_spaces s
in
let corrected_expectations =
Compiler_messages.capture ppf ~f:(fun () ->
List.fold_left chunks ~init:[] ~f:(fun acc chunk ->
let output = exec_phrases chunk.phrases in
match eval_expectation chunk.expectation ~output with
| None -> acc
| Some correction -> correction :: acc)
|> List.rev)
in
let trailing_output =
match trailing_code with
| None -> ""
| Some phrases ->
Compiler_messages.capture ppf ~f:(fun () -> exec_phrases phrases)
in
{ corrected_expectations; trailing_output }
let output_slice oc s a b =
output_string oc (String.sub s ~pos:a ~len:(b - a))
let output_corrected oc ~file_contents correction =
let output_body oc { str; tag } =
Printf.fprintf oc "{%s|%s|%s}" tag str tag
in
let ofs =
List.fold_left correction.corrected_expectations ~init:0
~f:(fun ofs c ->
output_slice oc file_contents ofs c.payload_loc.loc_start.pos_cnum;
output_body oc c.normal;
if c.normal.str <> c.principal.str then begin
output_string oc ", Principal";
output_body oc c.principal
end;
c.payload_loc.loc_end.pos_cnum)
in
output_slice oc file_contents ofs (String.length file_contents);
match correction.trailing_output with
| "" -> ()
| s -> Printf.fprintf oc "\n[%%%%expect{|%s|}]\n" s
let write_corrected ~file ~file_contents correction =
let oc = open_out file in
output_corrected oc ~file_contents correction;
close_out oc
let process_expect_file fname =
let corrected_fname = fname ^ ".corrected" in
let file_contents =
let ic = open_in_bin fname in
match really_input_string ic (in_channel_length ic) with
| s -> close_in ic; s
| exception e -> close_in ic; raise e
in
let correction = eval_expect_file fname ~file_contents in
write_corrected ~file:corrected_fname ~file_contents correction
let repo_root = ref ""
let main fname =
Toploop.override_sys_argv
(Array.sub Sys.argv ~pos:!Arg.current
~len:(Array.length Sys.argv - !Arg.current));
(* Ignore OCAMLRUNPARAM=b to be reproducible *)
Printexc.record_backtrace false;
List.iter [ "stdlib" ] ~f:(fun s ->
Topdirs.dir_directory (Filename.concat !repo_root s));
Toploop.initialize_toplevel_env ();
Sys.interactive := false;
process_expect_file fname;
exit 0
let args =
Arg.align
[ "-repo-root", Set_string repo_root,
"<dir> root of the OCaml repository"
; "-principal", Set Clflags.principal,
" Evaluate the file with -principal set"
]
let usage = "Usage: expect_test <options> [script-file [arguments]]\n\
options are:"
let () =
try
Arg.parse args main usage;
Printf.eprintf "expect_test: no input file\n";
exit 2
with exn ->
Location.report_exception Format.err_formatter exn;
exit 2

24
toplevel/opttoploop.ml
View File

@ -392,19 +392,6 @@ let execute_phrase print_outcome ppf phr =
false
end
(* Temporary assignment to a reference *)
let protect r newval body =
let oldval = !r in
try
r := newval;
let res = body() in
r := oldval;
res
with x ->
r := oldval;
raise x
(* Read and execute commands from a file, or from stdin if [name] is "". *)
let use_print_results = ref true
@ -439,7 +426,7 @@ let use_file ppf wrap_mod name =
(* Skip initial #! line if any *)
Lexer.skip_sharp_bang lb;
let success =
protect Location.input_name filename (fun () ->
protect_refs [ R (Location.input_name, filename) ] (fun () ->
try
List.iter
(fun ph ->
@ -462,7 +449,7 @@ let mod_use_file ppf name = use_file ppf true name
let use_file ppf name = use_file ppf false name
let use_silently ppf name =
protect use_print_results false (fun () -> use_file ppf name)
protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name)
(* Reading function for interactive use *)
@ -578,6 +565,13 @@ let loop ppf =
(* Execute a script. If [name] is "", read the script from stdin. *)
let override_sys_argv args =
let len = Array.length args in
if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
Array.blit args 0 Sys.argv 0 len;
Obj.truncate (Obj.repr Sys.argv) len;
Arg.current := 0
let run_script ppf name args =
let len = Array.length args in
if Array.length Sys.argv < len then invalid_arg "Toploop.run_script";

10
toplevel/opttoploop.mli
View File

@ -120,3 +120,13 @@ val read_interactive_input : (string -> bytes -> int -> int * bool) ref
(* Hooks for initialization *)
val toplevel_startup_hook : (unit -> unit) ref
(* Misc *)
val override_sys_argv : string array -> unit
(* [override_sys_argv args] replaces the contents of [Sys.argv] by [args]
and reset [Arg.current] to [0].
This is called by [run_script] so that [Sys.argv] represents
"script.ml args..." instead of the full command line:
"ocamlrun unix.cma ... script.ml args...". *)

26
toplevel/toploop.ml
View File

@ -352,19 +352,6 @@ let execute_phrase print_outcome ppf phr =
Warnings.reset_fatal ();
raise exn
(* Temporary assignment to a reference *)
let protect r newval body =
let oldval = !r in
try
r := newval;
let res = body() in
r := oldval;
res
with x ->
r := oldval;
raise x
(* Read and execute commands from a file, or from stdin if [name] is "". *)
let use_print_results = ref true
@ -400,7 +387,7 @@ let use_file ppf wrap_mod name =
(* Skip initial #! line if any *)
Lexer.skip_sharp_bang lb;
let success =
protect Location.input_name filename (fun () ->
protect_refs [ R (Location.input_name, filename) ] (fun () ->
try
List.iter
(fun ph ->
@ -423,7 +410,7 @@ let mod_use_file ppf name = use_file ppf true name
let use_file ppf name = use_file ppf false name
let use_silently ppf name =
protect use_print_results false (fun () -> use_file ppf name)
protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name)
(* Reading function for interactive use *)
@ -552,12 +539,15 @@ let loop ppf =
(* Execute a script. If [name] is "", read the script from stdin. *)
let run_script ppf name args =
let override_sys_argv args =
let len = Array.length args in
if Array.length Sys.argv < len then invalid_arg "Toploop.run_script";
if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv";
Array.blit args 0 Sys.argv 0 len;
Obj.truncate (Obj.repr Sys.argv) len;
Arg.current := 0;
Arg.current := 0
let run_script ppf name args =
override_sys_argv args;
Compmisc.init_path ~dir:(Filename.dirname name) true;
(* Note: would use [Filename.abspath] here, if we had it. *)
begin

10
toplevel/toploop.mli
View File

@ -145,3 +145,13 @@ val toplevel_startup_hook : (unit -> unit) ref
(* Used by Trace module *)
val may_trace : bool ref
(* Misc *)
val override_sys_argv : string array -> unit
(* [override_sys_argv args] replaces the contents of [Sys.argv] by [args]
and reset [Arg.current] to [0].
This is called by [run_script] so that [Sys.argv] represents
"script.ml args..." instead of the full command line:
"ocamlrun unix.cma ... script.ml args...". *)

43
utils/misc.ml
View File

@ -30,6 +30,17 @@ let try_finally work cleanup =
result
;;
type ref_and_value = R : 'a ref * 'a -> ref_and_value
let protect_refs =
let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in
fun refs f ->
let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in
set_refs refs;
match f () with
| x -> set_refs backup; x
| exception e -> set_refs backup; raise e
(* List functions *)
let rec map_end f l1 l2 =
@ -641,3 +652,35 @@ let normalise_eol s =
if s.[i] <> '\r' then Buffer.add_char b s.[i]
done;
Buffer.contents b
let delete_eol_spaces src =
let len_src = String.length src in
let dst = Bytes.create len_src in
let rec loop i_src i_dst =
if i_src = len_src then
i_dst
else
match src.[i_src] with
| ' ' | '\t' ->
loop_spaces 1 (i_src + 1) i_dst
| c ->
Bytes.set dst i_dst c;
loop (i_src + 1) (i_dst + 1)
and loop_spaces spaces i_src i_dst =
if i_src = len_src then
i_dst
else
match src.[i_src] with
| ' ' | '\t' ->
loop_spaces (spaces + 1) (i_src + 1) i_dst
| '\n' ->
Bytes.set dst i_dst '\n';
loop (i_src + 1) (i_dst + 1)
| c ->
for n = 0 to spaces do
Bytes.set dst (i_dst + n) src.[i_src - spaces + n]
done;
loop (i_src + 1) (i_dst + spaces + 1)
in
let stop = loop 0 0 in
Bytes.sub_string dst 0 stop

11
utils/misc.mli
View File

@ -40,6 +40,13 @@ val split_last: 'a list -> 'a list * 'a
val may: ('a -> unit) -> 'a option -> unit
val may_map: ('a -> 'b) -> 'a option -> 'b option
type ref_and_value = R : 'a ref * 'a -> ref_and_value
val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a
(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l]
while executing [f]. The previous contents of the references is restored
even if [f] raises an exception. *)
module Stdlib : sig
module List : sig
type 'a t = 'a list
@ -303,3 +310,7 @@ val normalise_eol : string -> string
(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters
removed. Intended for pre-processing text which will subsequently be printed
on a channel which performs EOL transformations (i.e. Windows) *)
val delete_eol_spaces : string -> string
(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of line spaces
removed. Intended to normalize the output of the toplevel for tests. *)