move some things around

src/context/typecore.ml

@@ -506,6 +506,37 @@ let merge_core_doc ctx mt =
 		end
 	| _ -> ())
 
+let check_constraints map params tl =
+	List.iter2 (fun (_,t) tm ->
+		begin match follow t with
+		| TInst ({ cl_kind = KTypeParameter constr; cl_path = path; cl_name_pos = p; },_) ->
+			if constr <> [] then begin match tm with
+			| TMono mono ->
+				List.iter (fun t ->
+					Monomorph.add_constraint mono (s_type_path path) p (map t)
+				) constr
+			| _ ->
+				let tm = map tm in
+				check_constraint (s_type_path path) (fun () ->
+					List.iter (fun t ->
+						Type.unify tm (map t)
+					) constr
+				)
+			end
+		| _ ->
+			assert false
+		end;
+	) params tl
+
+let spawn_constrained_monos ctx map params =
+	let monos = List.map (fun _ ->
+		let mono = Monomorph.create() in
+		TMono mono
+	) params in
+	let map t = map (apply_params params monos t) in
+	check_constraints map params monos;
+	monos
+
 (* -------------- debug functions to activate when debugging typer passes ------------------------------- *)
 (*/*
 

src/core/type.ml

@@ -64,7 +64,7 @@ type t =
 
 and tmono = {
 	mutable tm_type : t option;
-	mutable tm_constraints : (t * string) list;
+	mutable tm_constraints : (t * string * pos) list;
 }
 
 and tlazy =
@@ -391,87 +391,8 @@ type flag_tclass_field =
 	| CfModifiesThis (* This is set for methods which reassign `this`. E.g. `this = value` *)
 
 let unify_ref : (t -> t -> unit) ref = ref (fun _ _ -> ())
-
-type unify_error =
-	| Cannot_unify of t * t
-	| Invalid_field_type of string
-	| Has_no_field of t * string
-	| Has_no_runtime_field of t * string
-	| Has_extra_field of t * string
-	| Invalid_kind of string * field_kind * field_kind
-	| Invalid_visibility of string
-	| Not_matching_optional of string
-	| Cant_force_optional
-	| Invariant_parameter of int
-	| Constraint_failure of string
-	| Missing_overload of tclass_field * t
-	| FinalInvariance (* nice band name *)
-	| Invalid_function_argument of int (* index *) * int (* total *)
-	| Invalid_return_type
-	| Unify_custom of string
-
-exception Unify_error of unify_error list
-
-let check_constraint name f =
-	try
-		f()
-	with Unify_error l ->
-		raise (Unify_error ((Constraint_failure name) :: l))
-
-module Monomorph = struct
-	let create () = {
-		tm_type = None;
-		tm_constraints = [];
-	}
-
-	let unify_merge a b = match a,b with
-		| TAnon an1,TAnon an2 ->
-			let old1 = !(an1.a_status) in
-			let old2 = !(an2.a_status) in
-			an1.a_status := Opened;
-			an2.a_status := Opened;
-			Std.finally (fun () ->
-				an1.a_status := old1;
-				an1.a_status := old2;
-			) (!unify_ref a) b
-		| _ ->
-			!unify_ref a b
-
-	let add_constraint m path t =
-		assert(m.tm_type = None);
-		m.tm_constraints <- (t,path) :: m.tm_constraints
-
-	let rec bind m t =
-		begin match t with
-		| TMono m2 ->
-			begin match m2.tm_type with
-			| None ->
-				(* Inherit constraints. This avoids too-early unification. *)
-				List.iter (fun (t,path) -> add_constraint m2 path t) m.tm_constraints;
-				m.tm_type <- Some t
-			| Some t ->
-				bind m t
-			end;
-		| _ ->
-			List.iter (fun (t',path) ->
-				check_constraint path (fun () -> unify_merge t t')
-			) m.tm_constraints;
-			m.tm_type <- Some t
-		end
-
-	let unbind m =
-		m.tm_type <- None
-
-	let become_single_constraint m =
-		assert(m.tm_type = None);
-		match m.tm_constraints with
-		| [t,_] ->
-			m.tm_type <- Some t;
-			m.tm_constraints <- [];
-			Some t;
-		| _ ->
-			None
-end
+let monomorph_create_ref : (unit -> tmono) ref = ref (fun _ -> assert false)
+let monomorph_bind_ref : (tmono -> t -> unit) ref = ref (fun _ _ -> ())
 
 (* Flags *)
 
@@ -530,7 +451,7 @@ let mk_cast e t p = mk (TCast(e,None)) t p
 
 let null t p = mk (TConst TNull) t p
 
-let mk_mono() = TMono (Monomorph.create ())
+let mk_mono() = TMono (!monomorph_create_ref ())
 
 let rec t_dynamic = TDynamic t_dynamic
 
@@ -828,7 +749,7 @@ let apply_params ?stack cparams params t =
 					(* for dynamic *)
 					let pt = mk_mono() in
 					let t = TInst (c,[pt]) in
-					(match pt with TMono r -> Monomorph.bind r t | _ -> assert false);
+					(match pt with TMono r -> !monomorph_bind_ref r t | _ -> assert false);
 					t
 				| _ -> TInst (c,List.map loop tl))
 			| _ ->
@@ -1202,7 +1123,7 @@ let rec s_type_kind t =
 			| None ->
 				begin match r.tm_constraints with
 				| [] -> "TMono (None)"
-				| tl -> Printf.sprintf "TMono (None : %s)" (String.concat ", " (List.map (fun (t,_) -> s_type_kind t) tl))
+				| tl -> Printf.sprintf "TMono (None : %s)" (String.concat ", " (List.map (fun (t,_,_) -> s_type_kind t) tl))
 				end
 			| Some t -> "TMono (Some (" ^ (s_type_kind t) ^ "))"
 		end
@@ -1236,7 +1157,7 @@ let rec s_type ctx t =
 				| [] ->
 					Printf.sprintf "Unknown<%d>" id
 				| _ ->
-					let s_constraints = String.concat ", " (List.map (fun (t,_) -> s_type ctx t) r.tm_constraints) in
+					let s_constraints = String.concat ", " (List.map (fun (t,_,_) -> s_type ctx t) r.tm_constraints) in
 					Printf.sprintf "(Unknown<%d> : %s)" id s_constraints
 				end
 			end
@@ -1843,6 +1764,93 @@ end
 
 (* ======= Unification ======= *)
 
+type unify_error =
+	| Cannot_unify of t * t
+	| Invalid_field_type of string
+	| Has_no_field of t * string
+	| Has_no_runtime_field of t * string
+	| Has_extra_field of t * string
+	| Invalid_kind of string * field_kind * field_kind
+	| Invalid_visibility of string
+	| Not_matching_optional of string
+	| Cant_force_optional
+	| Invariant_parameter of int
+	| Constraint_failure of string
+	| Missing_overload of tclass_field * t
+	| FinalInvariance (* nice band name *)
+	| Invalid_function_argument of int (* index *) * int (* total *)
+	| Invalid_return_type
+	| Unify_custom of string
+
+exception Unify_error of unify_error list
+
+let check_constraint name f =
+	try
+		f()
+	with Unify_error l ->
+		raise (Unify_error ((Constraint_failure name) :: l))
+
+module Monomorph = struct
+	let create () = {
+		tm_type = None;
+		tm_constraints = [];
+	}
+
+	let unify_merge a b = match a,b with
+		| TAnon an1,TAnon an2 ->
+			let old1 = !(an1.a_status) in
+			let old2 = !(an2.a_status) in
+			an1.a_status := Opened;
+			an2.a_status := Opened;
+			Std.finally (fun () ->
+				an1.a_status := old1;
+				an1.a_status := old2;
+			) (!unify_ref a) b
+		| _ ->
+			!unify_ref a b
+
+	let add_constraint m path p t =
+		assert(m.tm_type = None);
+		(* if p.pfile = "source/Main.hx" then print_endline (Printf.sprintf "add_constraint %s: %s" path (s_type_kind t)); *)
+		m.tm_constraints <- (t,path,p) :: m.tm_constraints
+
+	let do_bind m t =
+		(* assert(m.tm_type = None); *) (* TODO: should be here, but matcher.ml does some weird bind handling at the moment. *)
+		m.tm_type <- Some t
+
+	let rec bind m t =
+		begin match t with
+		| TMono m2 ->
+			begin match m2.tm_type with
+			| None ->
+				(* Inherit constraints. This avoids too-early unification. *)
+				List.iter (fun (t,path,p) -> add_constraint m2 path p t) m.tm_constraints;
+				do_bind m t
+			| Some t ->
+				bind m t
+			end;
+		| _ ->
+			List.iter (fun (t',path,p) ->
+				(* if p.pfile = "source/Main.hx" then print_endline (Printf.sprintf "check constraint %s(%s): %s" path (s_type_kind t') (s_type_kind t)); *)
+				check_constraint path (fun () -> unify_merge t t')
+			) m.tm_constraints;
+			do_bind m t;
+		end
+
+	let unbind m =
+		m.tm_type <- None
+
+	let become_single_constraint m =
+		assert(m.tm_type = None);
+		match m.tm_constraints with
+		| [t,_,_] ->
+			m.tm_type <- Some t;
+			m.tm_constraints <- [];
+			Some t;
+		| _ ->
+			None
+end
+
 let rec link e a b =
 	(* tell if setting a == b will create a type-loop *)
 	let rec loop t =
@@ -3226,34 +3234,7 @@ let s_class_path c =
 		| _ -> c.cl_path
 	in
 	s_type_path path
-
-let check_constraints map params tl =
-	List.iter2 (fun (_,t) tm ->
-		begin match follow t with
-		| TInst ({ cl_kind = KTypeParameter constr; cl_path = path },_) ->
-			if constr <> [] then begin match tm with
-			| TMono mono ->
-				List.iter (fun t ->
-					Monomorph.add_constraint mono (s_type_path path) (map t)
-				) constr
-			| _ ->
-				let tm = map tm in
-				check_constraint (s_type_path path) (fun () ->
-					List.iter (fun t ->
-						unify tm (map t)
-					) constr
-				)
-			end
-		| _ ->
-			assert false
-		end;
-	) params tl
-
-let spawn_constrained_monos map params =
-	let monos = List.map (fun _ -> mk_mono()) params in
-	let map t = map (apply_params params monos t) in
-	check_constraints map params monos;
-	monos
-
 ;;
-unify_ref := unify
+unify_ref := unify;;
+monomorph_bind_ref := Monomorph.bind;;
+monomorph_create_ref := Monomorph.create;;

src/typing/calls.ml

@@ -343,7 +343,7 @@ let type_generic_function ctx (e,fa) el ?(using_param=None) with_type p =
 	in
 	if cf.cf_params = [] then error "Function has no type parameters and cannot be generic" p;
 	let map = if stat then (fun t -> t) else apply_params c.cl_params tl in
-	let monos = spawn_constrained_monos map cf.cf_params in
+	let monos = spawn_constrained_monos ctx map cf.cf_params in
 	let map_monos t = apply_params cf.cf_params monos t in
 	let map t = if stat then map_monos t else apply_params c.cl_params tl (map_monos t) in
 	let t = map cf.cf_type in

src/typing/fields.ml

@@ -58,21 +58,21 @@ let remove_constant_flag t callb =
 		raise e
 
 let enum_field_type ctx en ef p =
-	let tl_en = spawn_constrained_monos (fun t -> t) en.e_params in
+	let tl_en = spawn_constrained_monos ctx (fun t -> t) en.e_params in
 	let map = apply_params en.e_params tl_en in
-	let tl_ef = spawn_constrained_monos map ef.ef_params in
+	let tl_ef = spawn_constrained_monos ctx map ef.ef_params in
 	let map t = map (apply_params ef.ef_params tl_ef t) in
 	map ef.ef_type
 
-let field_type' map cf =
-	let monos = spawn_constrained_monos map cf.cf_params in
+let field_type' ctx map cf =
+	let monos = spawn_constrained_monos ctx map cf.cf_params in
 	apply_params cf.cf_params monos cf.cf_type
 
 let field_type ctx c pl f p =
 	match f.cf_params with
 	| [] -> f.cf_type
 	| l ->
-		let monos = spawn_constrained_monos (if pl = [] then (fun t -> t) else apply_params c.cl_params pl) f.cf_params in
+		let monos = spawn_constrained_monos ctx (if pl = [] then (fun t -> t) else apply_params c.cl_params pl) f.cf_params in
 		apply_params l monos f.cf_type
 
 let fast_enum_field e ef p =
@@ -441,14 +441,14 @@ let rec type_field cfg ctx e i p mode =
 			end;
 			let fmode, ft = (match !(a.a_status) with
 				| Statics c -> FStatic (c,f), field_type ctx c [] f p
-				| EnumStatics e -> FEnum (e,try PMap.find f.cf_name e.e_constrs with Not_found -> assert false), field_type' (fun t -> t) f
+				| EnumStatics e -> FEnum (e,try PMap.find f.cf_name e.e_constrs with Not_found -> assert false), field_type' ctx (fun t -> t) f
 				| _ ->
 					match f.cf_params with
 					| [] ->
 						FAnon f, Type.field_type f
 					| l ->
 						(* handle possible constraints *)
-						let monos = spawn_constrained_monos (fun t -> t) f.cf_params in
+						let monos = spawn_constrained_monos ctx (fun t -> t) f.cf_params in
 						let t = apply_params f.cf_params monos f.cf_type in
 						FAnon f, t
 			) in

src/typing/typeload.ml

@@ -235,7 +235,7 @@ let rec load_instance' ctx (t,p) allow_no_params =
 		let types , path , f = ctx.g.do_build_instance ctx mt p in
 		let is_rest = is_generic_build && (match types with ["Rest",_] -> true | _ -> false) in
 		if allow_no_params && t.tparams = [] && not is_rest then begin
-			let monos = spawn_constrained_monos (fun t -> t) types in
+			let monos = spawn_constrained_monos ctx (fun t -> t) types in
 			f (monos)
 		end else if path = ([],"Dynamic") then
 			match t.tparams with

src/typing/typer.ml

@@ -954,7 +954,7 @@ and type_binop2 ?(abstract_overload_only=false) ctx op (e1 : texpr) (e2 : Ast.ex
 					| TFun([(_,_,t1);(_,_,t2)],tret) ->
 						let check e1 e2 swapped =
 							let map_arguments () =
-								let monos = spawn_constrained_monos (fun t -> t) cf.cf_params in
+								let monos = spawn_constrained_monos ctx (fun t -> t) cf.cf_params in
 								let map t = map (apply_params cf.cf_params monos t) in
 								let t1 = map t1 in
 								let t2 = map t2 in
@@ -1785,7 +1785,7 @@ and type_new ctx path el with_type force_inline p =
 		(* Try to infer generic parameters from the argument list (issue #2044) *)
 		begin match resolve_typedef (Typeload.load_type_def ctx p (fst path)) with
 		| TClassDecl ({cl_constructor = Some cf} as c) ->
-			let monos = spawn_constrained_monos (fun t -> t) c.cl_params in
+			let monos = spawn_constrained_monos ctx (fun t -> t) c.cl_params in
 			let ct, f = get_constructor ctx c monos p in
 			ignore (unify_constructor_call c monos f ct);
 			begin try

src/typing/typerBase.ml

@@ -115,7 +115,7 @@ let rec type_module_type ctx t tparams p =
 		let t_tmp = class_module_type c in
 		mk (TTypeExpr (TClassDecl c)) (TType (t_tmp,[])) p
 	| TEnumDecl e ->
-		let types = (match tparams with None -> spawn_constrained_monos (fun t -> t) e.e_params | Some l -> l) in
+		let types = (match tparams with None -> spawn_constrained_monos ctx (fun t -> t) e.e_params | Some l -> l) in
 		mk (TTypeExpr (TEnumDecl e)) (TType (e.e_type,types)) p
 	| TTypeDecl s ->
 		let t = apply_params s.t_params (List.map (fun _ -> mk_mono()) s.t_params) s.t_type in