experiment with type parameters

src/core/type.ml

@@ -64,6 +64,7 @@ type t =
 
 and tmono = {
 	mutable tm_type : t option;
+	mutable tm_constraints : (t * string) list;
 }
 
 and tlazy =
@@ -389,16 +390,87 @@ type flag_tclass_field =
 	| CfFinal
 	| 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 bind m t =
-		m.tm_type <- Some t
+	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
 
 (* Flags *)
@@ -1127,7 +1199,11 @@ let rec s_type_kind t =
 	match t with
 	| TMono r ->
 		begin match r.tm_type with
-			| None -> "TMono (None)"
+			| 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))
+				end
 			| Some t -> "TMono (Some (" ^ (s_type_kind t) ^ "))"
 		end
 	| TEnum(en,tl) -> Printf.sprintf "TEnum(%s, [%s])" (s_type_path en.e_path) (map tl)
@@ -1149,7 +1225,21 @@ let rec s_type ctx t =
 	match t with
 	| TMono r ->
 		(match r.tm_type with
-		| None -> Printf.sprintf "Unknown<%d>" (try List.assq t (!ctx) with Not_found -> let n = List.length !ctx in ctx := (t,n) :: !ctx; n)
+		| None ->
+			begin try
+				let id = List.assq t (!ctx) in
+				Printf.sprintf "Unknown<%d>" id
+			with Not_found ->
+				let id = List.length !ctx in
+				ctx := (t,id) :: !ctx;
+				begin match r.tm_constraints with
+				| [] ->
+					Printf.sprintf "Unknown<%d>" id
+				| _ ->
+					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
 		| Some t -> s_type ctx t)
 	| TEnum (e,tl) ->
 		s_type_path e.e_path ^ s_type_params ctx tl
@@ -1878,26 +1968,6 @@ let rec shallow_eq a b =
    it's also the one that is pointed by the position.
    It's actually a typecheck of  A :> B where some mutations can happen *)
 
-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 cannot_unify a b = Cannot_unify (a,b)
 let invalid_field n = Invalid_field_type n
 let invalid_kind n a b = Invalid_kind (n,a,b)
@@ -3156,3 +3226,34 @@ 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

src/typing/calls.ml

@@ -342,7 +342,8 @@ let type_generic_function ctx (e,fa) el ?(using_param=None) with_type p =
 		| _ -> assert false
 	in
 	if cf.cf_params = [] then error "Function has no type parameters and cannot be generic" p;
-	let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
+	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 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
@@ -362,11 +363,6 @@ let type_generic_function ctx (e,fa) el ?(using_param=None) with_type p =
 		| _ -> ()
 	end;
 	let el,_ = unify_call_args ctx el args ret p false false in
-	begin try
-		check_constraints ctx cf.cf_name cf.cf_params monos map false p
-	with Unify_error l ->
-		display_error ctx (error_msg (Unify l)) p
-	end;
 	let el = match using_param with None -> el | Some e -> e :: el in
 	(try
 		let gctx = Generic.make_generic ctx cf.cf_params monos p in

src/typing/fields.ml

@@ -57,65 +57,22 @@ let remove_constant_flag t callb =
 		restore();
 		raise e
 
-let check_constraints ctx tname tpl tl map delayed p =
-	List.iter2 (fun m (name,t) ->
-		match follow t with
-		| TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
-			let f = (fun() ->
-				List.iter (fun ct ->
-					try
-						Type.unify (map m) (map ct)
-					with Unify_error l ->
-						let l = Constraint_failure (tname ^ "." ^ name) :: l in
-						raise (Unify_error l)
-				) constr
-			) in
-			if delayed then
-				delay ctx PCheckConstraint (fun () -> try f() with Unify_error l -> display_error ctx (error_msg (Unify l)) p)
-			else
-				f()
-		| _ ->
-			()
-	) tl tpl
-
-let enum_field_type ctx en ef tl_en tl_ef p =
-	let map t = apply_params en.e_params tl_en (apply_params ef.ef_params tl_ef t) in
-	begin try
-		check_constraints ctx (s_type_path en.e_path) en.e_params tl_en map true p;
-		check_constraints ctx ef.ef_name ef.ef_params tl_ef map true p;
-	with Unify_error l ->
-		display_error ctx (error_msg (Unify l)) p
-	end;
+let enum_field_type ctx en ef p =
+	let tl_en = spawn_constrained_monos (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 map t = map (apply_params ef.ef_params tl_ef t) in
 	map ef.ef_type
 
-let add_constraint_checks ctx ctypes pl f tl p =
-	List.iter2 (fun m (name,t) ->
-		match follow t with
-		| TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
-			let constr = List.map (fun t ->
-				let t = apply_params f.cf_params tl t in
-				(* only apply params if not static : in that case no param is passed *)
-				let t = (if pl = [] then t else apply_params ctypes pl t) in
-				t
-			) constr in
-			delay ctx PCheckConstraint (fun() ->
-				List.iter (fun ct ->
-					try
-						(* if has_mono m then raise (Unify_error [Unify_custom "Could not resolve full type for constraint checks"; Unify_custom ("Type was " ^ (s_type (print_context()) m))]); *)
-						Type.unify m ct
-					with Unify_error l ->
-						display_error ctx (error_msg (Unify (Constraint_failure (f.cf_name ^ "." ^ name) :: l))) p;
-				) constr
-			);
-		| _ -> ()
-	) tl f.cf_params
+let field_type' map cf =
+	let monos = spawn_constrained_monos 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 = List.map (fun _ -> mk_mono()) l in
-		if not (Meta.has Meta.Generic f.cf_meta) then add_constraint_checks ctx c.cl_params pl f monos p;
+		let monos = spawn_constrained_monos (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 =
@@ -484,16 +441,15 @@ 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), Type.field_type f
+				| EnumStatics e -> FEnum (e,try PMap.find f.cf_name e.e_constrs with Not_found -> assert false), field_type' (fun t -> t) f
 				| _ ->
 					match f.cf_params with
 					| [] ->
 						FAnon f, Type.field_type f
 					| l ->
 						(* handle possible constraints *)
-						let monos = List.map (fun _ -> mk_mono()) l in
+						let monos = spawn_constrained_monos (fun t -> t) f.cf_params in
 						let t = apply_params f.cf_params monos f.cf_type in
-						add_constraint_checks ctx [] [] f monos p;
 						FAnon f, t
 			) in
 			field_access ctx mode f fmode ft e p
@@ -526,7 +482,11 @@ let rec type_field cfg ctx e i p mode =
 		let x = ref Opened in
 		let t = TAnon { a_fields = PMap.add i f PMap.empty; a_status = x } in
 		ctx.opened <- x :: ctx.opened;
-		Monomorph.bind r t;
+		begin try
+			Monomorph.bind r t;
+		with Unify_error l ->
+			raise (Error (Unify l,p))
+		end;
 		field_access ctx mode f (FAnon f) (Type.field_type f) e p
 	| TAbstract (a,pl) ->
 		let static_abstract_access_through_instance = ref false in

src/typing/generic.ml

@@ -49,7 +49,11 @@ let make_generic ctx ps pt p =
 				| TAbstract(a,tl) -> (s_type_path_underscore a.a_path) ^ (loop_tl top tl)
 				| _ when not top ->
 					follow_or t top (fun() -> "_") (* allow unknown/incompatible types as type parameters to retain old behavior *)
-				| TMono { tm_type = None } -> raise (Generic_Exception (("Could not determine type for parameter " ^ s), p))
+				| TMono ({ tm_type = None } as mono) ->
+					begin match Monomorph.become_single_constraint mono with
+					| Some t -> loop top t
+					| None -> raise (Generic_Exception (("Could not determine type for parameter " ^ s), p))
+					end
 				| TDynamic _ -> "Dynamic"
 				| t ->
 					follow_or t top (fun() -> raise (Generic_Exception (("Unsupported type parameter: " ^ (s_type (print_context()) t) ^ ")"), p)))

src/typing/typeload.ml

@@ -172,36 +172,6 @@ let resolve_position_by_path ctx path p =
 	let p = (t_infos mt).mt_pos in
 	raise_positions [p]
 
-let check_param_constraints ctx types t pl c p =
-	match follow t with
-	| TMono _ -> ()
-	| _ ->
-		let ctl = (match c.cl_kind with KTypeParameter l -> l | _ -> []) in
-		List.iter (fun ti ->
-			let ti = apply_params types pl ti in
-			let ti = (match follow ti with
-				| TInst ({ cl_kind = KGeneric } as c,pl) ->
-					(* if we solve a generic contraint, let's substitute with the actual generic instance before unifying *)
-					let _,_, f = ctx.g.do_build_instance ctx (TClassDecl c) p in
-					f pl
-				| _ -> ti
-			) in
-			try
-				unify_raise ctx t ti p
-			with Error(Unify l,p) ->
-				let fail() =
-					if not ctx.untyped then display_error ctx (error_msg (Unify (Constraint_failure (s_type_path c.cl_path) :: l))) p;
-				in
-				match follow t with
-				| TInst({cl_kind = KExpr e},_) ->
-					let e = type_expr {ctx with locals = PMap.empty} e (WithType.with_type ti) in
-					begin try unify_raise ctx e.etype ti p
-					with Error (Unify _,_) -> fail() end
-				| _ ->
-					fail()
-
-		) ctl
-
 let generate_value_meta com co fadd args =
 	let values = List.fold_left (fun acc ((name,p),_,_,_,eo) -> match eo with Some e -> ((name,p,NoQuotes),e) :: acc | _ -> acc) [] args in
 	match values with
@@ -265,16 +235,8 @@ 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 pl = ref [] in
-			pl := List.map (fun (name,t) ->
-				match follow t with
-				| TInst (c,_) ->
-					let t = mk_mono() in
-					if c.cl_kind <> KTypeParameter [] || is_generic then delay ctx PCheckConstraint (fun() -> check_param_constraints ctx types t (!pl) c p);
-					t;
-				| _ -> assert false
-			) types;
-			f (!pl)
+			let monos = spawn_constrained_monos (fun t -> t) types in
+			f (monos)
 		end else if path = ([],"Dynamic") then
 			match t.tparams with
 			| [] -> t_dynamic
@@ -318,12 +280,24 @@ let rec load_instance' ctx (t,p) allow_no_params =
 							t
 						| TInst (c,[]) ->
 							check_const c;
-							let r = exc_protect ctx (fun r ->
-								r := lazy_available t;
-								delay ctx PCheckConstraint (fun() -> check_param_constraints ctx types t tparams c p);
+							let map t =
+								let t = apply_params types tparams t in
+								let t = (match follow t with
+									| TInst ({ cl_kind = KGeneric } as c,pl) ->
+										(* if we solve a generic contraint, let's substitute with the actual generic instance before unifying *)
+										let _,_, f = ctx.g.do_build_instance ctx (TClassDecl c) p in
+										f pl
+									| _ -> t
+								) in
 								t
-							) "constraint" in
-							TLazy r
+							in
+							delay ctx PCheckConstraint (fun () ->
+								try
+									check_constraints map types tparams;
+								with Unify_error l ->
+									raise_error (Unify l) p
+							);
+							t
 						| _ -> assert false
 					in
 					t :: loop tl1 tl2 is_rest

src/typing/typer.ml

@@ -411,10 +411,8 @@ let rec type_ident_raise ctx i p mode =
 					try
 						let ef = PMap.find i e.e_constrs in
 						let et = type_module_type ctx t None p in
-						let monos = List.map (fun _ -> mk_mono()) e.e_params in
-						let monos2 = List.map (fun _ -> mk_mono()) ef.ef_params in
 						ImportHandling.maybe_mark_import_position ctx pt;
-						wrap (mk (TField (et,FEnum (e,ef))) (enum_field_type ctx e ef monos monos2 p) p)
+						wrap (mk (TField (et,FEnum (e,ef))) (enum_field_type ctx e ef p) p)
 					with
 						Not_found -> loop l
 		in
@@ -956,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 = List.map (fun _ -> mk_mono()) cf.cf_params in
+								let monos = spawn_constrained_monos (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
@@ -973,7 +971,6 @@ and type_binop2 ?(abstract_overload_only=false) ctx op (e1 : texpr) (e2 : Ast.ex
 								Type.type_eq EqStrict e2.etype t2;
 								AbstractCast.cast_or_unify_raise ctx t1 e1 p,e2
 							end in
-							check_constraints ctx "" cf.cf_params monos (apply_params a.a_params tl) false cf.cf_pos;
 							let check_null e t = if is_eq_op then match e.eexpr with
 								| TConst TNull when not (is_explicit_null t) -> raise (Unify_error [])
 								| _ -> ()
@@ -1788,14 +1785,11 @@ 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 = List.map (fun _ -> mk_mono()) c.cl_params in
+			let monos = spawn_constrained_monos (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
-				let t = Generic.build_generic ctx c p monos in
-				let map = apply_params c.cl_params monos in
-				check_constraints ctx (s_type_path c.cl_path) c.cl_params monos map true p;
-				t
+				Generic.build_generic ctx c p monos
 			with Generic.Generic_Exception _ as exc ->
 				(* If we have an expected type, just use that (issue #3804) *)
 				begin match with_type with

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 -> List.map (fun _ -> mk_mono()) e.e_params | Some l -> l) in
+		let types = (match tparams with None -> spawn_constrained_monos (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

tests/misc/projects/Issue3781/compile-fail.hxml.stderr

@@ -1,2 +1,3 @@
-Main.hx:12: characters 9-11 : Constraint check failure for E1.T
-Main.hx:12: characters 9-11 : Main.T should be String
+Main.hx:12: characters 12-13 : Constraint check failure for E1.T
+Main.hx:12: characters 12-13 : Main.T should be String
+Main.hx:12: characters 12-13 : For function argument 'v'

tests/misc/projects/Issue4775/compile1-fail.hxml.stderr

@@ -1,2 +1,2 @@
-Main1.hx:7: characters 3-27 : Constraint check failure for Contain.T
-Main1.hx:7: characters 3-27 : Main1 should be String
+Main1.hx:7: characters 15-26 : Main1 should be String
+Main1.hx:7: characters 15-26 : For function argument 't'

tests/misc/projects/Issue5946/compile-fail.hxml.stderr

@@ -1,4 +1,8 @@
-Main.hx:5: characters 3-15 : Constraint check failure for downcast.S
-Main.hx:5: characters 3-15 : ITwo should be IOne
-Main.hx:4: characters 3-15 : Constraint check failure for downcast.S
-Main.hx:4: characters 3-15 : Two should be One
+Main.hx:4: characters 28-31 : Class<Two> should be Class<(Unknown<0> : One)>
+Main.hx:4: characters 28-31 : Constraint check failure for downcast.S
+Main.hx:4: characters 28-31 : Two should be One
+Main.hx:4: characters 28-31 : For function argument 'c'
+Main.hx:5: characters 29-33 : Class<ITwo> should be Class<(Unknown<0> : IOne)>
+Main.hx:5: characters 29-33 : Constraint check failure for downcast.S
+Main.hx:5: characters 29-33 : ITwo should be IOne
+Main.hx:5: characters 29-33 : For function argument 'c'

tests/misc/projects/Issue6878/compile1-fail.hxml.stderr

@@ -1,2 +1,3 @@
-Main1.hx:4: characters 3-11 : Constraint check failure for test.T
-Main1.hx:4: characters 3-11 : Int should be String
+Main1.hx:4: characters 8-10 : Constraint check failure for test.T
+Main1.hx:4: characters 8-10 : Int should be String
+Main1.hx:4: characters 8-10 : For function argument 't'