Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

merge branches/record-disambiguation

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13112 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
commit c8273a179cb0bc835924eeca522922a1769d9d54 2 parents 705510e + 17fc404
Jacques Garrigue authored
View
2  man/ocamlc.m
@@ -752,7 +752,7 @@ compilation in any way (even if it is marked). If a warning is enabled,
.IP
The default setting is
-.BR \-w\ +a\-4\-6\-9\-27\-29\-32..39 .
+.BR \-w\ +a\-4\-6\-9\-27\-29\-32..39\-41 .
Note that warnings
.BR 5 \ and \ 10
are not always triggered, depending on the internals of the type checker.
View
4 testsuite/makefiles/Makefile.toplevel
@@ -12,9 +12,9 @@
default:
@for file in *.ml; do \
- $(OCAML) < $$file 2>&1 | grep -v '^ OCaml version' > $$file.result; \
+ $(OCAML) $(TOPFLAGS) < $$file 2>&1 | grep -v '^ OCaml version' > $$file.result; \
if [ -f $$file.principal.reference ]; then \
- $(OCAML) -principal < $$file 2>&1 | grep -v '^ OCaml version' > $$file.principal.result; \
+ $(OCAML) $(TOPFLAGS) -principal < $$file 2>&1 | grep -v '^ OCaml version' > $$file.principal.result; \
fi; \
done
@for file in *.reference; do \
View
3  testsuite/tests/typing-gadts/test.ml.reference
@@ -75,8 +75,7 @@ Error: This pattern matches values of type ([? `A ] as 'a) * bool t
# Characters 87-88:
let f = function A -> 1 | B -> 2
^
-Error: This pattern matches values of type b
- but a pattern was expected which matches values of type a
+Error: The variant type a has no constructor B
# type _ t = Int : int t
# val ky : 'a -> 'a -> 'a = <fun>
# val test : 'a t -> 'a = <fun>
View
20 testsuite/tests/typing-misc/records.ml
@@ -20,10 +20,16 @@ let f {M.x; y} = x+y;;
let r = {M.x=1; y=2};;
let z = f r;;
-module M = struct
- type t = {x: int; y: int}
- type u = {y: bool}
-end;;
-(* path abbreviation is syntactic *)
-let f {M.x; y} = x+y;; (* fails *)
-let r = {M.x=1; y=2};; (* fails *)
+(* messages *)
+type foo = { mutable y:int };;
+let f (r: int) = r.y <- 3;;
+
+(* bugs *)
+type foo = { y: int; z: int };;
+type bar = { x: int };;
+let f (r: bar) = ({ r with z = 3 } : foo)
+
+type foo = { x: int };;
+let r : foo = { ZZZ.x = 2 };;
+
+(ZZZ.X : int option);;
View
50 testsuite/tests/typing-misc/records.ml.principal.reference
@@ -0,0 +1,50 @@
+
+# type t = { x : int; y : int; }
+# Characters 5-6:
+ {x=3;z=2};;
+ ^
+Error: Unbound record field z
+# Characters 9-10:
+ fun {x=3;z=2} -> ();;
+ ^
+Error: Unbound record field z
+# Characters 26-34:
+ {x=3; contents=2};;
+ ^^^^^^^^
+Error: The record field contents belongs to the type 'a ref
+ but is mixed here with fields of type t
+# type u = private { mutable u : int; }
+# Characters 0-5:
+ {u=3};;
+ ^^^^^
+Error: Cannot create values of the private type u
+# Characters 11-12:
+ fun x -> x.u <- 3;;
+ ^
+Error: Cannot assign field u of the private type u
+# module M : sig type t = { x : int; y : int; } end
+# val f : M.t -> int = <fun>
+# val r : M.t = {M.x = 1; y = 2}
+# val z : int = 3
+# type foo = { mutable y : int; }
+# Characters 17-18:
+ let f (r: int) = r.y <- 3;;
+ ^
+Error: This expression has type int but an expression was expected of type
+ foo
+# type foo = { y : int; z : int; }
+# type bar = { x : int; }
+# Characters 20-21:
+ let f (r: bar) = ({ r with z = 3 } : foo)
+ ^
+Error: This expression has type bar but an expression was expected of type
+ foo
+# Characters 16-21:
+ let r : foo = { ZZZ.x = 2 };;
+ ^^^^^
+Error: Unbound module ZZZ
+# Characters 2-7:
+ (ZZZ.X : int option);;
+ ^^^^^
+Error: Unbound module ZZZ
+#
View
40 testsuite/tests/typing-misc/records.ml.reference
@@ -3,16 +3,16 @@
# Characters 5-6:
{x=3;z=2};;
^
-Error: Unbound record field label z
+Error: Unbound record field z
# Characters 9-10:
fun {x=3;z=2} -> ();;
^
-Error: Unbound record field label z
+Error: Unbound record field z
# Characters 26-34:
{x=3; contents=2};;
^^^^^^^^
-Error: The record field label Pervasives.contents belongs to the type
- 'a ref but is mixed here with labels of type t
+Error: The record field contents belongs to the type 'a ref
+ but is mixed here with fields of type t
# type u = private { mutable u : int; }
# Characters 0-5:
{u=3};;
@@ -26,15 +26,25 @@ Error: Cannot assign field u of the private type u
# val f : M.t -> int = <fun>
# val r : M.t = {M.x = 1; y = 2}
# val z : int = 3
-# module M : sig type t = { x : int; y : int; } type u = { y : bool; } end
-# Characters 43-51:
- let f {M.x; y} = x+y;; (* fails *)
- ^^^^^^^^
-Error: This pattern matches values of type M.u
- but a pattern was expected which matches values of type M.t
-# Characters 16-17:
- let r = {M.x=1; y=2};; (* fails *)
- ^
-Error: The record field label M.y belongs to the type M.u
- but is mixed here with labels of type M.t
+# type foo = { mutable y : int; }
+# Characters 17-18:
+ let f (r: int) = r.y <- 3;;
+ ^
+Error: This expression has type int but an expression was expected of type
+ foo
+# type foo = { y : int; z : int; }
+# type bar = { x : int; }
+# Characters 20-21:
+ let f (r: bar) = ({ r with z = 3 } : foo)
+ ^
+Error: This expression has type bar but an expression was expected of type
+ foo
+# Characters 16-21:
+ let r : foo = { ZZZ.x = 2 };;
+ ^^^^^
+Error: Unbound module ZZZ
+# Characters 2-7:
+ (ZZZ.X : int option);;
+ ^^^^^
+Error: Unbound module ZZZ
#
View
16 testsuite/tests/typing-warnings/Makefile
@@ -0,0 +1,16 @@
+#########################################################################
+# #
+# OCaml #
+# #
+# Xavier Clerc, SED, INRIA Rocquencourt #
+# #
+# Copyright 2010 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+TOPFLAGS = -w A
View
128 testsuite/tests/typing-warnings/records.ml
@@ -0,0 +1,128 @@
+(* Use type information *)
+module M1 = struct
+ type t = {x: int; y: int}
+ type u = {x: bool; y: bool}
+end;;
+
+module OK = struct
+ open M1
+ let f1 (r:t) = r.x (* ok *)
+ let f2 r = ignore (r:t); r.x (* non principal *)
+
+ let f3 (r: t) =
+ match r with {x; y} -> y + y (* ok *)
+end;;
+
+module F1 = struct
+ open M1
+ let f r = match r with {x; y} -> y + y
+end;; (* fails *)
+
+module F2 = struct
+ open M1
+ let f r =
+ ignore (r: t);
+ match r with
+ {x; y} -> y + y
+end;; (* fails for -principal *)
+
+(* Use type information with modules*)
+module M = struct
+ type t = {x:int}
+ type u = {x:bool}
+end;;
+let f (r:M.t) = r.M.x;; (* ok *)
+let f (r:M.t) = r.x;; (* warning *)
+
+module M = struct
+ type t = {x: int; y: int}
+end;;
+module N = struct
+ type u = {x: bool; y: bool}
+end;;
+module OK = struct
+ open M
+ open N
+ let f (r:M.t) = r.x
+end;;
+
+module M = struct
+ type t = {x:int}
+ module N = struct type s = t = {x:int} end
+ type u = {x:bool}
+end;;
+module OK = struct
+ open M.N
+ let f (r:M.t) = r.x
+end;;
+
+(* Use field information *)
+module M = struct
+ type u = {x:bool;y:int;z:char}
+ type t = {x:int;y:bool}
+end;;
+module OK = struct
+ open M
+ let f {x;z} = x,z
+end;; (* ok *)
+module F3 = struct
+ open M
+ let r = {x=true;z='z'}
+end;; (* fail for missing label *)
+
+module OK = struct
+ type u = {x:int;y:bool}
+ type t = {x:bool;y:int;z:char}
+ let r = {x=3; y=true}
+end;; (* ok *)
+
+(* Corner cases *)
+
+module F4 = struct
+ type foo = {x:int; y:int}
+ type bar = {x:int}
+ let b : bar = {x=3; y=4}
+end;; (* fail but don't warn *)
+
+module M = struct type foo = {x:int;y:int} end;;
+module N = struct type bar = {x:int;y:int} end;;
+let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+
+module MN = struct include M include N end
+module NM = struct include N include M end;;
+let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+
+(* Lpw25 *)
+
+module M = struct
+ type foo = { x: int; y: int }
+ type bar = { x:int; y: int; z: int}
+end;;
+module F5 = struct
+ open M
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+end;;
+module M = struct
+ include M
+ type other = { a: int; b: int }
+end;;
+module F6 = struct
+ open M
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+end;;
+module F7 = struct
+ open M
+ let r = {x=1; y=2}
+ let r: other = {x=1; y=2}
+end;;
+
+module A = struct type t = {x: int} end
+module B = struct type t = {x: int} end;;
+let f (r : B.t) = r.A.x;; (* fail *)
+
+(* Spellchecking *)
+
+module F8 = struct
+ type t = {x:int; yyy:int}
+ let a : t = {x=1;yyz=2}
+end;;
View
151 testsuite/tests/typing-warnings/records.ml.principal.reference
@@ -0,0 +1,151 @@
+
+# module M1 :
+ sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
+# Characters 89-90:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^
+Warning 18: this type-based field disambiguation is not principal.
+Characters 81-103:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^^^^^^^^^^^^^^^^^^^^^^
+Warning 34: unused type u.
+Characters 148-149:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 27: unused variable x.
+module OK :
+ sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
+# Characters 55-61:
+ let f r = match r with {x; y} -> y + y
+ ^^^^^^
+Warning 41: this record contains fields that are ambiguous: x y.
+Characters 65-66:
+ let f r = match r with {x; y} -> y + y
+ ^
+Error: This expression has type bool but an expression was expected of type
+ int
+# Characters 85-91:
+ {x; y} -> y + y
+ ^^^^^^
+Warning 41: this record contains fields that are ambiguous: x y.
+Characters 85-91:
+ {x; y} -> y + y
+ ^^^^^^
+Error: This pattern matches values of type M1.u
+ but a pattern was expected which matches values of type M1.t
+# module M : sig type t = { x : int; } type u = { x : bool; } end
+# val f : M.t -> int = <fun>
+# Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 40: x is used out of scope.
+val f : M.t -> int = <fun>
+# module M : sig type t = { x : int; y : int; } end
+# module N : sig type u = { x : bool; y : bool; } end
+# Characters 30-36:
+ open N
+ ^^^^^^
+Warning 33: unused open N.
+Characters 25-47:
+ ...... M
+ open N
+ let f (r...........
+Warning 34: unused type u.
+module OK : sig val f : M.t -> int end
+# module M :
+ sig
+ type t = { x : int; }
+ module N : sig type s = t = { x : int; } end
+ type u = { x : bool; }
+ end
+# module OK : sig val f : M.t -> int end
+# module M :
+ sig
+ type u = { x : bool; y : int; z : char; }
+ type t = { x : int; y : bool; }
+ end
+# Characters 36-41:
+ let f {x;z} = x,z
+ ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+y
+Either bind these labels explicitly or add '; _' to the pattern.
+Characters 87-105:
+ Warning 34: unused type t.
+module OK : sig val f : M.u -> bool * char end
+# Characters 38-52:
+ let r = {x=true;z='z'}
+ ^^^^^^^^^^^^^^
+Error: Some record fields are undefined: y
+# module OK :
+ sig
+ type u = { x : int; y : bool; }
+ type t = { x : bool; y : int; z : char; }
+ val r : u
+ end
+# Characters 111-112:
+ let b : bar = {x=3; y=4}
+ ^
+Error: The record type bar has no field y
+# module M : sig type foo = { x : int; y : int; } end
+# module N : sig type bar = { x : int; y : int; } end
+# Characters 19-22:
+ let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+ ^^^
+Error: The record field N.y belongs to the type N.bar
+ but is mixed here with fields of type M.foo
+# module MN :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = N.bar = { x : int; y : int; }
+ end
+module NM :
+ sig
+ type bar = N.bar = { x : int; y : int; }
+ type foo = M.foo = { x : int; y : int; }
+ end
+# Characters 8-28:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 41: this record contains fields that are ambiguous: x y.
+Characters 19-23:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^
+Error: The record field NM.y belongs to the type NM.foo = M.foo
+ but is mixed here with fields of type MN.bar = N.bar
+# module M :
+ sig
+ type foo = { x : int; y : int; }
+ type bar = { x : int; y : int; z : int; }
+ end
+# Characters 72-73:
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+ ^
+Error: The record type M.foo has no field z
+# module M :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = M.bar = { x : int; y : int; z : int; }
+ type other = { a : int; b : int; }
+ end
+# Characters 73-74:
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+ ^
+Error: The record type M.foo has no field a
+# Characters 67-68:
+ let r: other = {x=1; y=2}
+ ^
+Error: The record type M.other has no field x
+# module A : sig type t = { x : int; } end
+module B : sig type t = { x : int; } end
+# Characters 20-23:
+ let f (r : B.t) = r.A.x;; (* fail *)
+ ^^^
+Error: The field A.x belongs to the record type A.t
+ but a field was expected belonging to the record type B.t
+# Characters 88-91:
+ let a : t = {x=1;yyz=2}
+ ^^^
+Error: The record type t has no field yyz
+Did you mean yyy?
+#
View
147 testsuite/tests/typing-warnings/records.ml.reference
@@ -0,0 +1,147 @@
+
+# module M1 :
+ sig type t = { x : int; y : int; } type u = { x : bool; y : bool; } end
+# Characters 81-103:
+ let f2 r = ignore (r:t); r.x (* non principal *)
+ ^^^^^^^^^^^^^^^^^^^^^^
+Warning 34: unused type u.
+Characters 148-149:
+ match r with {x; y} -> y + y (* ok *)
+ ^
+Warning 27: unused variable x.
+module OK :
+ sig val f1 : M1.t -> int val f2 : M1.t -> int val f3 : M1.t -> int end
+# Characters 55-61:
+ let f r = match r with {x; y} -> y + y
+ ^^^^^^
+Warning 41: this record contains fields that are ambiguous: x y.
+Characters 65-66:
+ let f r = match r with {x; y} -> y + y
+ ^
+Error: This expression has type bool but an expression was expected of type
+ int
+# Characters 81-103:
+ ... {x; y} -> y + y
+ en..............................
+Warning 34: unused type u.
+Characters 86-87:
+ {x; y} -> y + y
+ ^
+Warning 27: unused variable x.
+module F2 : sig val f : M1.t -> int end
+# module M : sig type t = { x : int; } type u = { x : bool; } end
+# val f : M.t -> int = <fun>
+# Characters 18-19:
+ let f (r:M.t) = r.x;; (* warning *)
+ ^
+Warning 40: x is used out of scope.
+val f : M.t -> int = <fun>
+# module M : sig type t = { x : int; y : int; } end
+# module N : sig type u = { x : bool; y : bool; } end
+# Characters 30-36:
+ open N
+ ^^^^^^
+Warning 33: unused open N.
+Characters 25-47:
+ ...... M
+ open N
+ let f (r...........
+Warning 34: unused type u.
+module OK : sig val f : M.t -> int end
+# module M :
+ sig
+ type t = { x : int; }
+ module N : sig type s = t = { x : int; } end
+ type u = { x : bool; }
+ end
+# module OK : sig val f : M.t -> int end
+# module M :
+ sig
+ type u = { x : bool; y : int; z : char; }
+ type t = { x : int; y : bool; }
+ end
+# Characters 36-41:
+ let f {x;z} = x,z
+ ^^^^^
+Warning 9: the following labels are not bound in this record pattern:
+y
+Either bind these labels explicitly or add '; _' to the pattern.
+Characters 87-105:
+ Warning 34: unused type t.
+module OK : sig val f : M.u -> bool * char end
+# Characters 38-52:
+ let r = {x=true;z='z'}
+ ^^^^^^^^^^^^^^
+Error: Some record fields are undefined: y
+# module OK :
+ sig
+ type u = { x : int; y : bool; }
+ type t = { x : bool; y : int; z : char; }
+ val r : u
+ end
+# Characters 111-112:
+ let b : bar = {x=3; y=4}
+ ^
+Error: The record type bar has no field y
+# module M : sig type foo = { x : int; y : int; } end
+# module N : sig type bar = { x : int; y : int; } end
+# Characters 19-22:
+ let r = { M.x = 3; N.y = 4; };; (* error: different definitions *)
+ ^^^
+Error: The record field N.y belongs to the type N.bar
+ but is mixed here with fields of type M.foo
+# module MN :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = N.bar = { x : int; y : int; }
+ end
+module NM :
+ sig
+ type bar = N.bar = { x : int; y : int; }
+ type foo = M.foo = { x : int; y : int; }
+ end
+# Characters 8-28:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^^^^^^^^^^^^^^^^^
+Warning 41: this record contains fields that are ambiguous: x y.
+Characters 19-23:
+ let r = {MN.x = 3; NM.y = 4};; (* error: type would change with order *)
+ ^^^^
+Error: The record field NM.y belongs to the type NM.foo = M.foo
+ but is mixed here with fields of type MN.bar = N.bar
+# module M :
+ sig
+ type foo = { x : int; y : int; }
+ type bar = { x : int; y : int; z : int; }
+ end
+# Characters 72-73:
+ let f r = ignore (r: foo); {r with x = 2; z = 3}
+ ^
+Error: The record type M.foo has no field z
+# module M :
+ sig
+ type foo = M.foo = { x : int; y : int; }
+ type bar = M.bar = { x : int; y : int; z : int; }
+ type other = { a : int; b : int; }
+ end
+# Characters 73-74:
+ let f r = ignore (r: foo); { r with x = 3; a = 4 }
+ ^
+Error: The record type M.foo has no field a
+# Characters 67-68:
+ let r: other = {x=1; y=2}
+ ^
+Error: The record type M.other has no field x
+# module A : sig type t = { x : int; } end
+module B : sig type t = { x : int; } end
+# Characters 20-23:
+ let f (r : B.t) = r.A.x;; (* fail *)
+ ^^^
+Error: The field A.x belongs to the record type A.t
+ but a field was expected belonging to the record type B.t
+# Characters 88-91:
+ let a : t = {x=1;yyz=2}
+ ^^^
+Error: The record type t has no field yyz
+Did you mean yyy?
+#
View
15 typing/ctype.ml
@@ -1400,6 +1400,21 @@ let expand_head env ty =
Btype.backtrack snap;
repr ty
+(* Expand until we find a non-abstract type declaration *)
+
+let rec extract_concrete_typedecl env ty =
+ let ty = repr ty in
+ match ty.desc with
+ Tconstr (p, _, _) ->
+ let decl = Env.find_type p env in
+ if decl.type_kind <> Type_abstract then (p, p, decl) else
+ let ty =
+ try try_expand_once env ty with Cannot_expand -> raise Not_found
+ in
+ let (_, p', decl) = extract_concrete_typedecl env ty in
+ (p, p', decl)
+ | _ -> raise Not_found
+
(* Implementing function [expand_head_opt], the compiler's own version of
[expand_head] used for type-based optimisations.
[expand_head_opt] uses [Env.find_type_expansion_opt] to access the
View
5 typing/ctype.mli
@@ -145,6 +145,11 @@ val expand_head_opt: Env.t -> type_expr -> type_expr
(** The compiler's own version of [expand_head] necessary for type-based
optimisations. *)
val full_expand: Env.t -> type_expr -> type_expr
+val extract_concrete_typedecl:
+ Env.t -> type_expr -> Path.t * Path.t * type_declaration
+ (* Return the original path of the types, and the first concrete
+ type declaration found expanding it.
+ Raise [Not_found] if none appears or not a type constructor. *)
val enforce_constraints: Env.t -> type_expr -> unit
View
190 typing/env.ml
@@ -132,6 +132,10 @@ module EnvTbl =
slot := true;
x
+ let find_all s tbl =
+ let xs = Ident.find_all s tbl in
+ List.map (fun (x, slot) -> (x, (fun () -> slot := true))) xs
+
let with_slot slot f x =
let old_slot = !current_slot in
current_slot := slot;
@@ -139,16 +143,18 @@ module EnvTbl =
(fun () -> f x)
(fun () -> current_slot := old_slot)
- let keys tbl =
- Ident.keys tbl
+ let fold_name f = Ident.fold_name (fun k (d,_) -> f k d)
+ let keys tbl = Ident.fold_all (fun k _ accu -> k::accu) tbl []
end
+type type_descriptions =
+ constructor_description list * label_description list
+
type t = {
values: (Path.t * value_description) EnvTbl.t;
constrs: constructor_description EnvTbl.t;
labels: label_description EnvTbl.t;
- constrs_by_path: (Path.t * (constructor_description list)) EnvTbl.t;
- types: (Path.t * type_declaration) EnvTbl.t;
+ types: (Path.t * (type_declaration * type_descriptions)) EnvTbl.t;
modules: (Path.t * module_type) EnvTbl.t;
modtypes: (Path.t * modtype_declaration) EnvTbl.t;
components: (Path.t * module_components) EnvTbl.t;
@@ -169,11 +175,10 @@ and module_components_repr =
and structure_components = {
mutable comp_values: (string, (value_description * int)) Tbl.t;
- mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
- mutable comp_labels: (string, (label_description * int)) Tbl.t;
- mutable comp_constrs_by_path:
- (string, (constructor_description list * int)) Tbl.t;
- mutable comp_types: (string, (type_declaration * int)) Tbl.t;
+ mutable comp_constrs: (string, (constructor_description * int) list) Tbl.t;
+ mutable comp_labels: (string, (label_description * int) list) Tbl.t;
+ mutable comp_types:
+ (string, ((type_declaration * type_descriptions) * int)) Tbl.t;
mutable comp_modules:
(string, ((Subst.t * Types.module_type,module_type) EnvLazy.t * int)) Tbl.t;
mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
@@ -196,7 +201,6 @@ let subst_modtype_maker (subst, mty) = Subst.modtype subst mty
let empty = {
values = EnvTbl.empty; constrs = EnvTbl.empty;
labels = EnvTbl.empty; types = EnvTbl.empty;
- constrs_by_path = EnvTbl.empty;
modules = EnvTbl.empty; modtypes = EnvTbl.empty;
components = EnvTbl.empty; classes = EnvTbl.empty;
cltypes = EnvTbl.empty;
@@ -400,10 +404,8 @@ let find proj1 proj2 path env =
let find_value =
find (fun env -> env.values) (fun sc -> sc.comp_values)
-and find_type =
+and find_type_full =
find (fun env -> env.types) (fun sc -> sc.comp_types)
-and find_constructors =
- find (fun env -> env.constrs_by_path) (fun sc -> sc.comp_constrs_by_path)
and find_modtype =
find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
and find_class =
@@ -411,6 +413,11 @@ and find_class =
and find_cltype =
find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
+let find_type p env =
+ fst (find_type_full p env)
+let find_type_descrs p env =
+ snd (find_type_full p env)
+
(* Find the manifest type associated to a type when appropriate:
- the type should be public or should have a private row,
- the type should have an associated manifest type. *)
@@ -565,14 +572,51 @@ let lookup_simple proj1 proj2 lid env =
| Lapply(l1, l2) ->
raise Not_found
+let lookup_all_simple proj1 proj2 shadow lid env =
+ match lid with
+ Lident s ->
+ let xl = EnvTbl.find_all s (proj1 env) in
+ let rec do_shadow =
+ function
+ | [] -> []
+ | ((x, f) :: xs) ->
+ (x, f) ::
+ (do_shadow (List.filter (fun (y, g) -> not (shadow x y)) xs))
+ in
+ do_shadow xl
+ | Ldot(l, s) ->
+ let (p, desc) = lookup_module_descr l env in
+ begin match EnvLazy.force !components_of_module_maker' desc with
+ Structure_comps c ->
+ let comps =
+ try Tbl.find s (proj2 c) with Not_found -> []
+ in
+ List.map
+ (fun (data, pos) -> (data, (fun () -> ())))
+ comps
+ | Functor_comps f ->
+ raise Not_found
+ end
+ | Lapply(l1, l2) ->
+ raise Not_found
+
let has_local_constraints env = env.local_constraints
+let cstr_shadow cstr1 cstr2 =
+ match cstr1.cstr_tag, cstr2.cstr_tag with
+ Cstr_exception _, Cstr_exception _ -> true
+ | _ -> false
+
+let lbl_shadow lbl1 lbl2 = false
+
let lookup_value =
lookup (fun env -> env.values) (fun sc -> sc.comp_values)
-let lookup_constructor =
- lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
-and lookup_label =
- lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
+and lookup_all_constructors =
+ lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+ cstr_shadow
+and lookup_all_labels =
+ lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
+ lbl_shadow
and lookup_type =
lookup (fun env -> env.types) (fun sc -> sc.comp_types)
and lookup_modtype =
@@ -626,9 +670,9 @@ let lookup_value lid env =
r
let lookup_type lid env =
- let (_, desc) as r = lookup_type lid env in
- mark_type_used (Longident.last lid) desc;
- r
+ let (path, (decl, _)) = lookup_type lid env in
+ mark_type_used (Longident.last lid) decl;
+ (path, decl)
(* [path] must be the path to a type, not to a module ! *)
let path_subst_last path id =
@@ -641,14 +685,33 @@ let mark_type_path env path =
let decl = try find_type path env with Not_found -> assert false in
mark_type_used (Path.last path) decl
-let ty_path = function
+let ty_path t =
+ match repr t with
| {desc=Tconstr(path, _, _)} -> path
| _ -> assert false
let lookup_constructor lid env =
- let desc = lookup_constructor lid env in
- mark_type_path env (ty_path desc.cstr_res);
- desc
+ match lookup_all_constructors lid env with
+ [] -> raise Not_found
+ | (desc, use) :: _ ->
+ mark_type_path env (ty_path desc.cstr_res);
+ use ();
+ desc
+
+let is_lident = function
+ Lident _ -> true
+ | _ -> false
+
+let lookup_all_constructors lid env =
+ try
+ let cstrs = lookup_all_constructors lid env in
+ let wrap_use desc use () =
+ mark_type_path env (ty_path desc.cstr_res);
+ use ()
+ in
+ List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs
+ with
+ Not_found when is_lident lid -> []
let mark_constructor usage env name desc =
match desc.cstr_tag with
@@ -664,9 +727,23 @@ let mark_constructor usage env name desc =
mark_constructor_used usage ty_name ty_decl name
let lookup_label lid env =
- let desc = lookup_label lid env in
- mark_type_path env (ty_path desc.lbl_res);
- desc
+ match lookup_all_labels lid env with
+ [] -> raise Not_found
+ | (desc, use) :: _ ->
+ mark_type_path env (ty_path desc.lbl_res);
+ use ();
+ desc
+
+let lookup_all_labels lid env =
+ try
+ let lbls = lookup_all_labels lid env in
+ let wrap_use desc use () =
+ mark_type_path env (ty_path desc.lbl_res);
+ use ()
+ in
+ List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls
+ with
+ Not_found when is_lident lid -> []
let lookup_class lid env =
let (_, desc) as r = lookup_class lid env in
@@ -802,6 +879,11 @@ let rec prefix_idents root pos sub = function
(* Compute structure descriptions *)
+let add_to_tbl id decl tbl =
+ let decls =
+ try Tbl.find id tbl with Not_found -> [] in
+ Tbl.add id (decl :: decls) tbl
+
let rec components_of_module env sub path mty =
EnvLazy.create (env, sub, path, mty)
@@ -812,7 +894,6 @@ and components_of_module_maker (env, sub, path, mty) =
{ comp_values = Tbl.empty;
comp_constrs = Tbl.empty;
comp_labels = Tbl.empty; comp_types = Tbl.empty;
- comp_constrs_by_path = Tbl.empty;
comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
comp_components = Tbl.empty; comp_classes = Tbl.empty;
comp_cltypes = Tbl.empty } in
@@ -830,29 +911,29 @@ and components_of_module_maker (env, sub, path, mty) =
end
| Sig_type(id, decl, _) ->
let decl' = Subst.type_declaration sub decl in
- c.comp_types <-
- Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
let constructors = List.map snd (constructors_of_type path decl') in
- c.comp_constrs_by_path <-
+ let labels = List.map snd (labels_of_type path decl') in
+ c.comp_types <-
Tbl.add (Ident.name id)
- (constructors, nopos) c.comp_constrs_by_path;
+ ((decl', (constructors, labels)), nopos)
+ c.comp_types;
List.iter
(fun descr ->
c.comp_constrs <-
- Tbl.add descr.cstr_name (descr, nopos) c.comp_constrs)
+ add_to_tbl descr.cstr_name (descr, nopos) c.comp_constrs)
constructors;
- let labels = labels_of_type path decl' in
List.iter
- (fun (_, descr) ->
+ (fun descr ->
c.comp_labels <-
- Tbl.add descr.lbl_name (descr, nopos) c.comp_labels)
+ add_to_tbl descr.lbl_name (descr, nopos) c.comp_labels)
labels;
env := store_type_infos id path decl !env
| Sig_exception(id, decl) ->
let decl' = Subst.exception_declaration sub decl in
let cstr = Datarepr.exception_descr path decl' in
+ let s = Ident.name id in
c.comp_constrs <-
- Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
+ add_to_tbl s (cstr, !pos) c.comp_constrs;
incr pos
| Sig_module(id, mty, _) ->
let mty' = EnvLazy.create (sub, mty) in
@@ -895,7 +976,7 @@ and components_of_module_maker (env, sub, path, mty) =
comp_values = Tbl.empty;
comp_constrs = Tbl.empty;
comp_labels = Tbl.empty;
- comp_types = Tbl.empty; comp_constrs_by_path = Tbl.empty;
+ comp_types = Tbl.empty;
comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
comp_components = Tbl.empty; comp_classes = Tbl.empty;
comp_cltypes = Tbl.empty })
@@ -927,6 +1008,7 @@ and store_type id path info env =
type_declarations;
let constructors = constructors_of_type path info in
let labels = labels_of_type path info in
+ let descrs = (List.map snd constructors, List.map snd labels) in
if not loc.Location.loc_ghost &&
Warnings.is_active (Warnings.Unused_constructor ("", false, false))
@@ -954,15 +1036,12 @@ and store_type id path info env =
(fun (id, descr) constrs -> EnvTbl.add id descr constrs)
constructors
env.constrs;
-
- constrs_by_path =
- EnvTbl.add id (path, List.map snd constructors) env.constrs_by_path;
labels =
List.fold_right
(fun (id, descr) labels -> EnvTbl.add id descr labels)
labels
env.labels;
- types = EnvTbl.add id (path, info) env.types;
+ types = EnvTbl.add id (path, (info, descrs)) env.types;
summary = Env_type(env.summary, id, info) }
and store_type_infos id path info env =
@@ -972,7 +1051,7 @@ and store_type_infos id path info env =
keep track of type abbreviations (e.g. type t = float) in the
computation of label representations. *)
{ env with
- types = EnvTbl.add id (path, info) env.types;
+ types = EnvTbl.add id (path, (info,([],[]))) env.types;
summary = Env_type(env.summary, id, info) }
and store_exception id path decl env =
@@ -1217,16 +1296,11 @@ let save_signature sg modname filename =
save_signature_with_imports sg modname filename (imported_units())
(* Folding on environments *)
-let ident_tbl_fold f t acc =
- List.fold_right
- (fun key acc -> f key (EnvTbl.find_same_not_using key t) acc)
- (EnvTbl.keys t)
- acc
let find_all proj1 proj2 f lid env acc =
match lid with
| None ->
- ident_tbl_fold
+ EnvTbl.fold_name
(fun id (p, data) acc -> f (Ident.name id) p data acc)
(proj1 env) acc
| Some l ->
@@ -1240,18 +1314,22 @@ let find_all proj1 proj2 f lid env acc =
raise Not_found
end
-let find_all_simple proj1 proj2 f lid env acc =
+let find_all_simple_list proj1 proj2 f lid env acc =
match lid with
| None ->
- ident_tbl_fold
- (fun _id data acc -> f data acc)
+ EnvTbl.fold_name
+ (fun id data acc -> f data acc)
(proj1 env) acc
| Some l ->
let p, desc = lookup_module_descr l env in
begin match EnvLazy.force components_of_module_maker desc with
Structure_comps c ->
Tbl.fold
- (fun s (data, pos) acc -> f data acc)
+ (fun s comps acc ->
+ match comps with
+ [] -> acc
+ | (data, pos) :: _ ->
+ f data acc)
(proj2 c) acc
| Functor_comps _ ->
raise Not_found
@@ -1261,7 +1339,7 @@ let fold_modules f lid env acc =
match lid with
| None ->
let acc =
- ident_tbl_fold
+ EnvTbl.fold_name
(fun id (p, data) acc -> f (Ident.name id) p data acc)
env.modules
acc
@@ -1292,9 +1370,9 @@ let fold_modules f lid env acc =
let fold_values f =
find_all (fun env -> env.values) (fun sc -> sc.comp_values) f
and fold_constructors f =
- find_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
+ find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
and fold_labels f =
- find_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) f
+ find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f
and fold_types f =
find_all (fun env -> env.types) (fun sc -> sc.comp_types) f
and fold_modtypes f =
View
27 typing/env.mli
@@ -31,11 +31,14 @@ val empty: t
val initial: t
val diff: t -> t -> Ident.t list
+type type_descriptions =
+ constructor_description list * label_description list
+
(* Lookup by paths *)
val find_value: Path.t -> t -> value_description
val find_type: Path.t -> t -> type_declaration
-val find_constructors: Path.t -> t -> constructor_description list
+val find_type_descrs: Path.t -> t -> type_descriptions
val find_module: Path.t -> t -> module_type
val find_modtype: Path.t -> t -> modtype_declaration
val find_class: Path.t -> t -> class_declaration
@@ -47,7 +50,7 @@ val find_type_expansion_opt:
Path.t -> t -> type_expr list * type_expr * int option
(* Find the manifest type information associated to a type for the sake
of the compiler's type-based optimisations. *)
-val find_modtype_expansion: Path.t -> t -> Types.module_type
+val find_modtype_expansion: Path.t -> t -> module_type
val has_local_constraints: t -> bool
val add_gadt_instance_level: int -> t -> t
@@ -59,7 +62,11 @@ val add_gadt_instance_chain: t -> int -> type_expr -> unit
val lookup_value: Longident.t -> t -> Path.t * value_description
val lookup_constructor: Longident.t -> t -> constructor_description
+val lookup_all_constructors:
+ Longident.t -> t -> (constructor_description * (unit -> unit)) list
val lookup_label: Longident.t -> t -> label_description
+val lookup_all_labels:
+ Longident.t -> t -> (label_description * (unit -> unit)) list
val lookup_type: Longident.t -> t -> Path.t * type_declaration
val lookup_module: Longident.t -> t -> Path.t * module_type
val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration
@@ -186,29 +193,29 @@ val add_delayed_check_forward: ((unit -> unit) -> unit) ref
(** Folding over all identifiers (for analysis purpose) *)
val fold_values:
- (string -> Path.t -> Types.value_description -> 'a -> 'a) ->
+ (string -> Path.t -> value_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_types:
- (string -> Path.t -> Types.type_declaration -> 'a -> 'a) ->
+ (string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_constructors:
- (Types.constructor_description -> 'a -> 'a) ->
+ (constructor_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_labels:
- (Types.label_description -> 'a -> 'a) ->
+ (label_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
(** Persistent structures are only traversed if they are already loaded. *)
val fold_modules:
- (string -> Path.t -> Types.module_type -> 'a -> 'a) ->
+ (string -> Path.t -> module_type -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_modtypes:
- (string -> Path.t -> Types.modtype_declaration -> 'a -> 'a) ->
+ (string -> Path.t -> modtype_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_classs:
- (string -> Path.t -> Types.class_declaration -> 'a -> 'a) ->
+ (string -> Path.t -> class_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_cltypes:
- (string -> Path.t -> Types.class_type_declaration -> 'a -> 'a) ->
+ (string -> Path.t -> class_type_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
View
32 typing/ident.ml
@@ -170,13 +170,37 @@ let rec find_name name = function
else
find_name name (if c < 0 then l else r)
-let rec keys_aux stack accu = function
+let rec get_all = function
+ | None -> []
+ | Some k -> k.data :: get_all k.previous
+
+let rec find_all name = function
+ Empty ->
+ []
+ | Node(l, k, r, _) ->
+ let c = compare name k.ident.name in
+ if c = 0 then
+ k.data :: get_all k.previous
+ else
+ find_all name (if c < 0 then l else r)
+
+let rec fold_aux f stack accu = function
Empty ->
begin match stack with
[] -> accu
- | a :: l -> keys_aux l accu a
+ | a :: l -> fold_aux f l accu a
end
| Node(l, k, r, _) ->
- keys_aux (l :: stack) (k.ident :: accu) r
+ fold_aux f (l :: stack) (f k accu) r
+
+let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl
+
+let rec fold_data f d accu =
+ match d with
+ None -> accu
+ | Some k -> f k.ident k.data (fold_data f k.previous accu)
+
+let fold_all f tbl accu =
+ fold_aux (fun k -> fold_data f (Some k)) [] accu tbl
-let keys tbl = keys_aux [] [] tbl
+(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *)
View
4 typing/ident.mli
@@ -54,4 +54,6 @@ val empty: 'a tbl
val add: t -> 'a -> 'a tbl -> 'a tbl
val find_same: t -> 'a tbl -> 'a
val find_name: string -> 'a tbl -> 'a
-val keys: 'a tbl -> t list
+val find_all: string -> 'a tbl -> 'a list
+val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
+val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
View
4 typing/parmatch.ml
@@ -772,8 +772,8 @@ let complete_constrs p all_tags =
| Tpat_construct (_,c,_,_) ->
begin try
let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
- let constrs =
- Env.find_constructors (adt_path p.pat_env p.pat_type) p.pat_env in
+ let (constrs, _) =
+ Env.find_type_descrs (adt_path p.pat_env p.pat_type) p.pat_env in
map_filter
(fun cnstr ->
if List.mem cnstr.cstr_tag not_tags then Some cnstr else None)
View
34 typing/printtyp.ml
@@ -930,6 +930,10 @@ let type_expansion t ppf t' =
let t' = if proxy t == proxy t' then unalias t' else t' in
fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
+let type_path_expansion tp ppf tp' =
+ if Path.same tp tp' then path ppf tp else
+ fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp'
+
let rec trace fst txt ppf = function
| (t1, t1') :: (t2, t2') :: rem ->
if not fst then fprintf ppf "@,";
@@ -948,6 +952,14 @@ let rec filter_trace = function
else (t1, t1') :: (t2, t2') :: rem'
| _ -> []
+let rec type_path_list ppf = function
+ | [tp, tp'] -> type_path_expansion tp ppf tp'
+ | (tp, tp') :: rem ->
+ fprintf ppf "%a@;<2 0>%a"
+ (type_path_expansion tp) tp'
+ type_path_list rem
+ | [] -> ()
+
(* Hide variant name and var, to force printing the expanded type *)
let hide_variant_name t =
match repr t with
@@ -1132,3 +1144,25 @@ let report_subtyping_error ppf tr1 txt1 tr2 =
let mis = mismatch true tr2 in
trace false "is not compatible with type" ppf tr2;
explanation true mis ppf
+
+let report_ambiguous_type_error ppf (tp0, tp0') tpl txt1 txt2 txt3 =
+ reset ();
+ List.iter
+ (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp')
+ tpl;
+ match tpl with
+ [] -> assert false
+ | [tp, tp'] ->
+ fprintf ppf
+ "@[%t@;<1 2>%a@ \
+ %t@;<1 2>%a\
+ @]"
+ txt1 (type_path_expansion tp) tp'
+ txt3 (type_path_expansion tp0) tp0'
+ | _ ->
+ fprintf ppf
+ "@[%t@;<1 2>@[<hv>%a@]\
+ @ %t@;<1 2>%a\
+ @]"
+ txt2 type_path_list tpl
+ txt3 (type_path_expansion tp0) tp0'
View
4 typing/printtyp.mli
@@ -72,3 +72,7 @@ val report_unification_error:
val report_subtyping_error:
formatter -> (type_expr * type_expr) list ->
string -> (type_expr * type_expr) list -> unit
+val report_ambiguous_type_error:
+ formatter -> (Path.t * Path.t) -> (Path.t * Path.t) list ->
+ (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit
+
View
455 typing/typecore.ml
@@ -33,6 +33,9 @@ type error =
| Label_multiply_defined of string
| Label_missing of Ident.t list
| Label_not_mutable of Longident.t
+ | Wrong_name of string * Env.t * Path.t * Longident.t
+ | Name_type_mismatch of
+ string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
| Incomplete_format of string
| Bad_conversion of string * int * char
| Undefined_method of type_expr * string
@@ -241,20 +244,23 @@ let extract_option_type env ty =
when Path.same path Predef.path_option -> ty
| _ -> assert false
-let rec extract_label_names sexp env ty =
- let ty = expand_head env ty in
- match ty.desc with
- | Tconstr (path, _, _) ->
- let td = Env.find_type path env in
- begin match td.type_kind with
- | Type_record (fields, _) ->
- List.map (fun (name, _, _) -> name) fields
- | Type_abstract when td.type_manifest <> None ->
- extract_label_names sexp env (expand_head env ty)
- | _ -> assert false
- end
- | _ ->
- assert false
+let extract_concrete_record env ty =
+ match extract_concrete_typedecl env ty with
+ (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
+ | _ -> raise Not_found
+
+let extract_concrete_variant env ty =
+ match extract_concrete_typedecl env ty with
+ (* exclude exceptions *)
+ (p0, p, {type_kind=Type_variant (_::_ as cstrs)}) -> (p0, p, cstrs)
+ | _ -> raise Not_found
+
+let extract_label_names sexp env ty =
+ try
+ let (_, _,fields) = extract_concrete_record env ty in
+ List.map (fun (name, _, _) -> name) fields
+ with Not_found ->
+ assert false
(* Typing of patterns *)
@@ -516,43 +522,239 @@ let build_or_pat env loc lid =
pat pats in
(path, rp { r with pat_loc = loc },ty)
+(* Type paths *)
+
+let rec expand_path env p =
+ let decl =
+ try Some (Env.find_type p env) with Not_found -> None
+ in
+ match decl with
+ Some {type_manifest = Some ty} ->
+ begin match repr ty with
+ {desc=Tconstr(p,_,_)} -> expand_path env p
+ | _ -> assert false
+ end
+ | _ -> p
+
+let compare_type_path env tpath1 tpath2 =
+ Path.same (expand_path env tpath1) (expand_path env tpath2)
+
(* Records *)
+module NameChoice(Name : sig
+ type t
+ val type_kind: string
+ val get_name: t -> string
+ val get_type: t -> type_expr
+ val get_descrs: Env.type_descriptions -> t list
+ val fold: (t -> 'a -> 'a) -> Longident.t option -> Env.t -> 'a -> 'a
+ val unbound_name_error: Env.t -> Longident.t loc -> unit
+end) = struct
+ open Name
+
+ let get_type_path env d =
+ match (get_type d).desc with
+ | Tconstr(p, _, _) -> p
+ | _ -> assert false
+
+ let spellcheck ppf env p lid =
+ Typetexp.spellcheck_simple ppf fold
+ (fun d ->
+ if compare_type_path env p (get_type_path env d)
+ then get_name d else "") env lid
+
+ let lookup_from_type env tpath lid =
+ let descrs = get_descrs (Env.find_type_descrs tpath env) in
+ Env.mark_type_used (Path.last tpath) (Env.find_type tpath env);
+ match lid.txt with
+ Longident.Lident s -> begin
+ try
+ List.find (fun nd -> get_name nd = s) descrs
+ with Not_found ->
+ raise (Error (lid.loc, Wrong_name (type_kind, env, tpath, lid.txt)))
+ end
+ | _ -> raise Not_found
+
+ let is_ambiguous env lbl others =
+ let tpath = get_type_path env lbl in
+ let different_tpath (lbl, _) =
+ let lbl_tpath = get_type_path env lbl in
+ not (compare_type_path env tpath lbl_tpath)
+ in
+ let others =
+ List.filter different_tpath others
+ in
+ others <> []
+
+ let disambiguate_by_type env tpath lbls =
+ let check_type (lbl, _) =
+ let lbl_tpath = get_type_path env lbl in
+ compare_type_path env tpath lbl_tpath
+ in
+ List.find check_type lbls
+
+ let disambiguate ?(warn=Location.prerr_warning) ?scope lid env opath lbls =
+ match opath with
+ None ->
+ begin match lbls with
+ [] -> unbound_name_error env lid; assert false
+ | (lbl, use) :: rest ->
+ use ();
+ if is_ambiguous env lbl rest then
+ warn lid.loc
+ (Warnings.Ambiguous_name ([Longident.last lid.txt], false));
+ lbl
+ end
+ | Some(tpath0, tpath, pr) ->
+ let scope = match scope with None -> lbls | Some l -> l in
+ let warn_pr () =
+ let kind = if type_kind = "record" then "field" else "constructor" in
+ warn lid.loc
+ (Warnings.Not_principal
+ ("this type-based " ^ kind ^ " disambiguation"))
+ in
+ try
+ let lbl, use = disambiguate_by_type env tpath scope in
+ use ();
+ if not pr then begin
+ (* Check if non-principal type is affecting result *)
+ match lbls with
+ [] -> warn_pr ()
+ | (lbl', use') :: rest ->
+ let lbl_tpath = get_type_path env lbl' in
+ if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
+ else if is_ambiguous env lbl' rest then
+ warn lid.loc
+ (Warnings.Ambiguous_name ([Longident.last lid.txt], false))
+ end;
+ lbl
+ with Not_found -> try
+ let lbl = lookup_from_type env tpath lid in
+ warn lid.loc
+ (Warnings.Name_out_of_scope ([Longident.last lid.txt], false));
+ if not pr then warn_pr ();
+ lbl
+ with Not_found ->
+ let tp = (tpath0, expand_path env tpath) in
+ let tpl =
+ List.map
+ (fun (lbl, _) ->
+ let tp0 = get_type_path env lbl in
+ let tp = expand_path env tp0 in
+ (tp0, tp))
+ lbls
+ in
+ raise (Error (lid.loc, Name_type_mismatch (type_kind, lid.txt, tp, tpl)))
+end
+
+module Label = NameChoice (struct
+ type t = label_description
+ let type_kind = "record"
+ let get_name lbl = lbl.lbl_name
+ let get_type lbl = lbl.lbl_res
+ let get_descrs = snd
+ let fold = Env.fold_labels
+ let unbound_name_error = Typetexp.unbound_label_error
+end)
+
+let disambiguate_label_by_ids keep env closed ids labels =
+ let check_ids (lbl, _) =
+ let lbls = Hashtbl.create 8 in
+ Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
+ List.for_all (Hashtbl.mem lbls) ids
+ and check_closed (lbl, _) =
+ (not closed || List.length ids = Array.length lbl.lbl_all)
+ in
+ let labels' = List.filter check_ids labels in
+ if keep && labels' = [] then (false, labels) else
+ let labels'' = List.filter check_closed labels' in
+ if keep && labels'' = [] then (false, labels') else (true, labels'')
+
+(* Only issue warnings once per record constructor/pattern *)
+let disambiguate_lid_a_list loc closed env opath lid_a_list =
+ let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
+ let w_pr = ref false and w_amb = ref [] and w_scope = ref [] in
+ let warn loc msg =
+ let open Warnings in
+ match msg with
+ | Not_principal _ -> w_pr := true
+ | Ambiguous_name([s], _) -> w_amb := s :: !w_amb
+ | Name_out_of_scope([s], _) -> w_scope := s :: !w_scope
+ | _ -> Location.prerr_warning loc msg
+ in
+ let process_label lid =
+ (* Strategy for each field:
+ * collect all the labels in scope for that name
+ * if the type is known and principal, just eventually warn
+ if the real label was not in scope
+ * fail if there is no known type and no label found
+ * otherwise use other fields to reduce the list of candidates
+ * if there is no known type reduce it incrementally, so that
+ there is still at least one candidate (for error message)
+ * if the reduced list is valid, call Label.disambiguate
+ *)
+ let scope = Typetexp.find_all_labels env lid.loc lid.txt in
+ if opath = None && scope = [] then
+ Typetexp.unbound_label_error env lid;
+ let (ok, labels) =
+ match opath with
+ Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *)
+ | _ -> disambiguate_label_by_ids (opath=None) env closed ids scope
+ in
+ if ok then Label.disambiguate lid env opath labels ~warn ~scope
+ else fst (List.hd labels) (* will fail later *)
+ in
+ let lbl_a_list =
+ List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
+ if !w_pr then
+ Location.prerr_warning loc
+ (Warnings.Not_principal "this type-based record disambiguation");
+ if !w_amb <> [] && not !w_pr then
+ Location.prerr_warning loc
+ (Warnings.Ambiguous_name (List.rev !w_amb, true));
+ if !w_scope <> [] then
+ Location.prerr_warning loc
+ (Warnings.Name_out_of_scope (List.rev !w_scope, true));
+ lbl_a_list
+
let rec find_record_qual = function
| [] -> None
| ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
| _ :: rest -> find_record_qual rest
-let type_label_a_list ?labels env type_lbl_a lid_a_list =
- let record_qual = find_record_qual lid_a_list in
+let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list =
let lbl_a_list =
- List.map
- (fun (lid, a) ->
- let label =
- match lid.txt, labels, record_qual with
- Longident.Lident s, Some labels, _ when Hashtbl.mem labels s ->
- (Hashtbl.find labels s : Types.label_description)
- | Longident.Lident s, _, Some modname ->
- Typetexp.find_label env lid.loc (Longident.Ldot (modname, s))
- | _ ->
- Typetexp.find_label env lid.loc lid.txt
- in (lid, label, a)
- ) lid_a_list in
+ match lid_a_list, labels with
+ ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
+ (* Special case for rebuilt syntax trees *)
+ List.map
+ (function lid, a -> match lid.txt with
+ Longident.Lident s -> lid, Hashtbl.find labels s, a
+ | _ -> assert false)
+ lid_a_list
+ | _ ->
+ let lid_a_list =
+ match find_record_qual lid_a_list with
+ None -> lid_a_list
+ | Some modname ->
+ List.map
+ (fun (lid, a as lid_a) ->
+ match lid.txt with Longident.Lident s ->
+ {lid with txt=Longident.Ldot (modname, s)}, a
+ | _ -> lid_a)
+ lid_a_list
+ in
+ disambiguate_lid_a_list loc closed env opath lid_a_list
+ in
(* Invariant: records are sorted in the typed tree *)
let lbl_a_list =
List.sort
- (fun (_, lbl1,_) (_, lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
+ (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
lbl_a_list
in
List.map type_lbl_a lbl_a_list
;;
-let lid_of_label label =
- match repr label.lbl_res with
- | {desc = Tconstr(Path.Pdot(mpath,_,_),_,_)} ->
- Longident.Ldot(lid_of_path mpath, label.lbl_name)
- | _ -> Longident.Lident label.lbl_name
-
(* Checks over the labels mentioned in a record pattern:
no duplicate definitions (error); properly closed (warning) *)
@@ -580,6 +782,25 @@ let check_recordpat_labels loc lbl_pat_list closed =
end
end
+(* Constructors *)
+
+let lookup_constructor_from_type env tpath lid =
+ let (constructors, _) = Env.find_type_descrs tpath env in
+ match lid with
+ Longident.Lident s ->
+ List.find (fun cstr -> cstr.cstr_name = s) constructors
+ | _ -> raise Not_found
+
+module Constructor = NameChoice (struct
+ type t = constructor_description
+ let type_kind = "variant"
+ let get_name cstr = cstr.cstr_name
+ let get_type cstr = cstr.cstr_res
+ let get_descrs = fst
+ let fold = Env.fold_constructors
+ let unbound_name_error = Typetexp.unbound_constructor_error
+end)
+
(* unification of a type with a tconstr with
freshly created arguments *)
let unify_head_only loc env ty constr =
@@ -680,12 +901,19 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_type = expected_ty;
pat_env = !env }
| Ppat_construct(lid, sarg, explicit_arity) ->
- let constr =
+ let opath =
+ try
+ let (p0, p, _) = extract_concrete_variant !env expected_ty in
+ Some (p0, p, true)
+ with Not_found -> None
+ in
+ let constrs =
match lid.txt, constrs with
Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
- Hashtbl.find constrs s
- | _ -> Typetexp.find_constructor !env loc lid.txt
+ [Hashtbl.find constrs s, (fun () -> ())]
+ | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt
in
+ let constr = Constructor.disambiguate lid !env opath constrs in
Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
if no_existentials && constr.cstr_existentials <> [] then
raise (Error (loc, Unexpected_existential));
@@ -737,14 +965,20 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_type = expected_ty;
pat_env = !env }
| Ppat_record(lid_sp_list, closed) ->
+ let opath, record_ty =
+ try
+ let (p0, p,_) = extract_concrete_record !env expected_ty in
+ Some (p0, p, true), expected_ty
+ with Not_found -> None, newvar ()
+ in
let type_label_pat (label_lid, label, sarg) =
begin_def ();
let (vars, ty_arg, ty_res) = instance_label false label in
if vars = [] then end_def ();
begin try
- unify_pat_types loc !env ty_res expected_ty
+ unify_pat_types loc !env ty_res record_ty
with Unify trace ->
- raise(Error(loc, Label_mismatch(lid_of_label label, trace)))
+ raise(Error(label_lid.loc, Label_mismatch(label_lid.txt, trace)))
end;
let arg = type_pat sarg ty_arg in
if vars <> [] then begin
@@ -755,13 +989,15 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
let tv = expand_head !env tv in
not (is_Tvar tv) || tv.level <> generic_level in
if List.exists instantiated vars then
- raise (Error(loc, Polymorphic_label (lid_of_label label)))
+ raise (Error(label_lid.loc, Polymorphic_label label_lid.txt))
end;
(label_lid, label, arg)
in
let lbl_pat_list =
- type_label_a_list ?labels !env type_label_pat lid_sp_list in
+ type_label_a_list ?labels loc false !env type_label_pat opath
+ lid_sp_list in
check_recordpat_labels loc lbl_pat_list closed;
+ unify_pat_types loc !env record_ty expected_ty;
rp {
pat_desc = Tpat_record (lbl_pat_list, closed);
pat_loc = loc; pat_extra=[];
@@ -1761,9 +1997,43 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_env = env }
end
| Pexp_record(lid_sexp_list, opt_sexp) ->
+ let opt_exp =
+ match opt_sexp with
+ None -> None
+ | Some sexp ->
+ if !Clflags.principal then begin_def ();
+ let exp = type_exp env sexp in
+ if !Clflags.principal then begin
+ end_def ();
+ generalize_structure exp.exp_type
+ end;
+ Some exp
+ in
+ let ty_record, opath =
+ let get_path ty =
+ try
+ let (p0, p,_) = extract_concrete_record env ty in
+ (* XXX level may be wrong *)
+ Some (p0, p, ty.level = generic_level || not !Clflags.principal)
+ with Not_found -> None
+ in
+ match get_path ty_expected with
+ None ->
+ let op =
+ match opt_exp with
+ None -> None
+ | Some exp -> get_path exp.exp_type
+ in
+ newvar (), op
+ | op -> ty_expected, op
+ in
+ let closed = (opt_sexp = None) in
let lbl_exp_list =
- type_label_a_list env (type_label_exp true env loc ty_expected)
- lid_sexp_list in
+ type_label_a_list loc closed env
+ (type_label_exp true env loc ty_record)
+ opath lid_sexp_list in
+ unify_exp_types loc env ty_record (instance env ty_expected);
+
(* type_label_a_list returns a list of labels sorted by lbl_pos *)
(* note: check_duplicates would better be implemented in
type_label_a_list directly *)
@@ -1776,28 +2046,24 @@ and type_expect_ ?in_function env sexp ty_expected =
in
check_duplicates lbl_exp_list;
let opt_exp =
- match opt_sexp, lbl_exp_list with
+ match opt_exp, lbl_exp_list with
None, _ -> None
- | Some sexp, (_, lbl, _) :: _ ->
- if !Clflags.principal then begin_def ();
- let ty_exp = newvar () in
+ | Some exp, (lid, lbl, lbl_exp) :: _ ->
+ let ty_exp = instance env exp.exp_type in
let unify_kept lbl =
+ (* do not connect overridden labels *)
if List.for_all
(fun (_, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
lbl_exp_list
then begin
let _, ty_arg1, ty_res1 = instance_label false lbl
and _, ty_arg2, ty_res2 = instance_label false lbl in
- unify env ty_exp ty_res1;
+ unify env ty_arg1 ty_arg2;
unify env (instance env ty_expected) ty_res2;
- unify env ty_arg1 ty_arg2
+ unify_exp_types exp.exp_loc env ty_exp ty_res1;
end in
Array.iter unify_kept lbl.lbl_all;
- if !Clflags.principal then begin
- end_def ();
- generalize_structure ty_exp
- end;
- Some(type_expect env sexp ty_exp)
+ Some {exp with exp_type = ty_exp}
| _ -> assert false
in
let num_fields =
@@ -1823,22 +2089,21 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
exp_env = env }
- | Pexp_field(sarg, lid) ->
- let arg = type_exp env sarg in
- let label = Typetexp.find_label env loc lid.txt in
+ | Pexp_field(srecord, lid) ->
+ let (record, label, _) = type_label_access env loc srecord lid in
let (_, ty_arg, ty_res) = instance_label false label in
- unify_exp env arg ty_res;
+ unify_exp env record ty_res;
rue {
- exp_desc = Texp_field(arg, lid, label);
+ exp_desc = Texp_field(record, lid, label);
exp_loc = loc; exp_extra = [];
exp_type = ty_arg;
exp_env = env }
| Pexp_setfield(srecord, lid, snewval) ->
- let record = type_exp env srecord in
- let label = Typetexp.find_label env loc lid.txt in
+ let (record, label, opath) = type_label_access env loc srecord lid in
+ let ty_record = if opath = None then newvar () else record.exp_type in
let (label_loc, label, newval) =
- type_label_exp false env loc record.exp_type
- (lid, label, snewval) in
+ type_label_exp false env loc ty_record (lid, label, snewval) in
+ unify_exp env record ty_record;
if label.lbl_mut = Immutable then
raise(Error(loc, Label_not_mutable lid.txt));
rue {
@@ -1908,7 +2173,6 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_type = instance_def Predef.type_unit;
exp_env = env }
| Pexp_constraint(sarg, sty, sty') ->
-
let separate = true (* always separate, 1% slowdown for lablgtk *)
(* !Clflags.principal || Env.has_local_constraints env *) in
let (arg, ty',cty,cty') =
@@ -2354,7 +2618,25 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra;
}
-and type_label_exp create env loc ty_expected
+and type_label_access env loc srecord lid =
+ if !Clflags.principal then begin_def ();
+ let record = type_exp env srecord in
+ if !Clflags.principal then begin
+ end_def ();
+ generalize_structure record.exp_type
+ end;
+ let ty_exp = record.exp_type in
+ let opath =
+ try
+ let (p0, p,_) = extract_concrete_record env ty_exp in
+ Some(p0, p, ty_exp.level = generic_level || not !Clflags.principal)
+ with Not_found -> None
+ in
+ let labels = Typetexp.find_all_labels env lid.loc lid.txt in
+ let label = Label.disambiguate lid env opath labels in
+ (record, label, opath)
+
+and type_label_exp create env loc ty_expected
(lid, label, sarg) =
(* Here also ty_expected may be at generic_level *)
begin_def ();
@@ -2370,7 +2652,7 @@ and type_label_exp create env loc ty_expected
begin try
unify env (instance_def ty_res) (instance env ty_expected)
with Unify trace ->
- raise (Error(lid.loc, Label_mismatch(lid_of_label label, trace)))
+ raise (Error(lid.loc, Label_mismatch(lid.txt, trace)))
end;
(* Instantiate so that we can generalize internal nodes *)
let ty_arg = instance_def ty_arg in
@@ -2383,7 +2665,7 @@ and type_label_exp create env loc ty_expected
if create then
raise (Error(loc, Private_type ty_expected))
else
- raise (Error(lid.loc, Private_label(lid_of_label label, ty_expected)));
+ raise (Error(lid.loc, Private_label(lid.txt, ty_expected)));
let arg =
let snap = if vars = [] then None else Some (Btype.snapshot ()) in
let arg = type_argument env sarg ty_arg (instance env ty_arg) in
@@ -2664,7 +2946,14 @@ and type_application env funct sargs =
type_args [] [] ty (instance env ty) ty sargs []
and type_construct env loc lid sarg explicit_arity ty_expected =
- let constr = Typetexp.find_constructor env loc lid.txt in
+ let opath =
+ try
+ let (p0, p,_) = extract_concrete_variant env ty_expected in
+ Some(p0, p, ty_expected.level = generic_level || not !Clflags.principal)
+ with Not_found -> None
+ in
+ let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in
+ let constr = Constructor.disambiguate lid env opath constrs in
Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
let sargs =
match sarg with
@@ -3054,7 +3343,7 @@ open Printtyp
let report_error ppf = function
| Polymorphic_label lid ->
- fprintf ppf "@[The record field label %a is polymorphic.@ %s@]"
+ fprintf ppf "@[The record field %a is polymorphic.@ %s@]"
longident lid "You cannot instantiate it in a pattern."
| Constructor_arity_mismatch(lid, expected, provided) ->
fprintf ppf
@@ -3064,10 +3353,10 @@ let report_error ppf = function
| Label_mismatch(lid, trace) ->
report_unification_error ppf trace
(function ppf ->
- fprintf ppf "The record field label %a@ belongs to the type"
+ fprintf ppf "The record field %a@ belongs to the type"
longident lid)
(function ppf ->
- fprintf ppf "but is mixed here with labels of type")
+ fprintf ppf "but is mixed here with fields of type")
| Pattern_type_clash trace ->
report_unification_error ppf trace
(function ppf ->
@@ -3114,10 +3403,28 @@ let report_error ppf = function
| Label_missing labels ->
let print_labels ppf =
List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
- fprintf ppf "@[<hov>Some record field labels are undefined:%a@]"
+ fprintf ppf "@[<hov>Some record fields are undefined:%a@]"
print_labels labels
| Label_not_mutable lid ->
- fprintf ppf "The record field label %a is not mutable" longident lid
+ fprintf ppf "The record field %a is not mutable" longident lid
+ | Wrong_name (kind, env, p, lid) ->
+ fprintf ppf "The %s type %a has no %s %a" kind path p
+ (if kind = "record" then "field" else "constructor")
+ longident lid;
+ if kind = "record" then Label.spellcheck ppf env p lid
+ else Constructor.spellcheck ppf env p lid
+ | Name_type_mismatch (kind, lid, tp, tpl) ->
+ let name = if kind = "record" then "field" else "constructor" in
+ report_ambiguous_type_error ppf tp tpl
+ (function ppf ->
+ fprintf ppf "The %s %a@ belongs to the %s type"
+ name longident lid kind)
+ (function ppf ->
+ fprintf ppf "The %s %a@ belongs to one of the following %s types:"
+ name longident lid kind)
+ (function ppf ->
+ fprintf ppf "but a %s was expected belonging to the %s type"
+ name kind)
| Incomplete_format s ->
fprintf ppf "Premature end of format string ``%S''" s
| Bad_conversion (fmt, i, c) ->
View
3  typing/typecore.mli
@@ -75,6 +75,9 @@ type error =
| Label_multiply_defined of string
| Label_missing of Ident.t list
| Label_not_mutable of Longident.t
+ | Wrong_name of string * Env.t * Path.t * Longident.t
+ | Name_type_mismatch of
+ string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
| Incomplete_format of string
| Bad_conversion of string * int * char
| Undefined_method of type_expr * string
View
21 typing/typetexp.ml
@@ -96,9 +96,15 @@ let find_type =
let find_constructor =
find_component Env.lookup_constructor
(fun env lid -> Unbound_constructor (env, lid))
+let find_all_constructors =
+ find_component Env.lookup_all_constructors
+ (fun env lid -> Unbound_constructor (env, lid))
let find_label =
find_component Env.lookup_label
(fun env lid -> Unbound_label (env, lid))
+let find_all_labels =
+ find_component Env.lookup_all_labels
+ (fun env lid -> Unbound_label (env, lid))
let find_class =
find_component Env.lookup_class
(fun env lid -> Unbound_class (env, lid))
@@ -115,6 +121,14 @@ let find_class_type =
find_component Env.lookup_cltype
(fun env lid -> Unbound_cltype (env, lid))
+let unbound_constructor_error env lid =
+ narrow_unbound_lid_error env lid.loc lid.txt
+ (fun env lid -> Unbound_constructor (env, lid))
+
+let unbound_label_error env lid =
+ narrow_unbound_lid_error env lid.loc lid.txt
+ (fun env lid -> Unbound_label (env, lid))
+
(* Support for first-class modules. *)
let transl_modtype_longident = ref (fun _ -> assert false)
@@ -719,6 +733,8 @@ let spellcheck_simple ppf fold extr =
let spellcheck ppf fold =
spellcheck ppf (fun f -> fold (fun s _ _ x -> f s x))
+type cd = string list * int
+
let report_error ppf = function
| Unbound_type_variable name ->
fprintf ppf "Unbound type parameter %s@." name
@@ -796,9 +812,10 @@ let report_error ppf = function
spellcheck ppf Env.fold_modules env lid;
| Unbound_constructor (env, lid) ->
fprintf ppf "Unbound constructor %a" longident lid;
- spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name) env lid;
+ spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name)
+ env lid;
| Unbound_label (env, lid) ->
- fprintf ppf "Unbound record field label %a" longident lid;
+ fprintf ppf "Unbound record field %a" longident lid;
spellcheck_simple ppf Env.fold_labels (fun d -> d.lbl_name) env lid;
| Unbound_class (env, lid) ->
fprintf ppf "Unbound class %a" longident lid;
View
15 typing/typetexp.mli
@@ -80,8 +80,14 @@ val find_type:
Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration
val find_constructor:
Env.t -> Location.t -> Longident.t -> Types.constructor_description
+val find_all_constructors:
+ Env.t -> Location.t -> Longident.t ->
+ (Types.constructor_description * (unit -> unit)) list
val find_label:
Env.t -> Location.t -> Longident.t -> Types.label_description
+val find_all_labels:
+ Env.t -> Location.t -> Longident.t ->
+ (Types.label_description * (unit -> unit)) list
val find_value:
Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description
val find_class:
@@ -92,3 +98,12 @@ val find_modtype:
Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration
val find_class_type:
Env.t -> Location.t -> Longident.t -> Path.t * Types.class_type_declaration
+
+val unbound_constructor_error: Env.t -> Longident.t Location.loc -> unit
+val unbound_label_error: Env.t -> Longident.t Location.loc -> unit
+
+type cd
+val spellcheck_simple:
+ Format.formatter ->
+ (('a -> cd -> cd) -> Longident.t option -> 'b -> cd -> cd) ->
+ ('a -> string) -> 'b -> Longident.t -> unit
View
22 utils/warnings.ml
@@ -57,6 +57,8 @@ type t =
| Unused_constructor of string * bool * bool (* 37 *)
| Unused_exception of string * bool (* 38 *)
| Unused_rec_flag (* 39 *)
+ | Name_out_of_scope of string list * bool (* 40 *)
+ | Ambiguous_name of string list * bool (* 41 *)
;;
(* If you remove a warning, leave a hole in the numbering. NEVER change
@@ -105,9 +107,11 @@ let number = function
| Unused_constructor _ -> 37
| Unused_exception _ -> 38
| Unused_rec_flag -> 39
+ | Name_out_of_scope _ -> 40
+ | Ambiguous_name _ -> 41
;;
-let last_warning_number = 39
+let last_warning_number = 41
(* Must be the max number returned by the [number] function. *)
let letter = function
@@ -202,7 +206,7 @@ let parse_opt flags s =
let parse_options errflag s = parse_opt (if errflag then error else active) s;;
(* If you change these, don't forget to change them in man/ocamlc.m *)
-let defaults_w = "+a-4-6-7-9-27-29-32..39";;
+let defaults_w = "+a-4-6-7-9-27-29-32..39-41";;
let defaults_warn_error = "-a";;
let () = parse_options false defaults_w;;
@@ -302,6 +306,18 @@ let message = function
(However, this constructor appears in patterns.)"
| Unused_rec_flag ->
"unused rec flag."
+ | Name_out_of_scope ([s], false) ->
+ s ^ " is used out of scope."
+ | Name_out_of_scope (_, false) -> assert false
+ | Name_out_of_scope (slist, true) ->
+ "this record contains fields that are out of scope: "
+ ^ String.concat " " slist ^ "."
+ | Ambiguous_name ([s], false) ->
+ "this use of " ^ s ^ " is ambiguous."
+ | Ambiguous_name (_, false) -> assert false
+ | Ambiguous_name (slist, true) ->
+ "this record contains fields that are ambiguous: "
+ ^ String.concat " " slist ^ "."
;;
let nerrors = ref 0;;
@@ -387,6 +403,8 @@ let descriptions =
37, "Unused constructor.";
38, "Unused exception constructor.";
39, "Unused rec flag.";
+ 40, "Constructor or label name used out of scope.";
+ 41, "Ambiguous constructor or label name.";
]
;;
View
2  utils/warnings.mli
@@ -52,6 +52,8 @@ type t =
| Unused_constructor of string * bool * bool (* 37 *)
| Unused_exception of string * bool (* 38 *)
| Unused_rec_flag (* 39 *)
+ | Name_out_of_scope of string list * bool (* 40 *)
+ | Ambiguous_name of string list * bool (* 41 *)
;;
val parse_options : bool -> string -> unit;;
Please sign in to comment.
Something went wrong with that request. Please try again.