Basic implementation of upper bound constraints (#10233)

* wip

* cleanup

* changed to up/down constraints

src/context/display/displayFields.ml

@@ -139,7 +139,7 @@ let collect ctx e_ast e dk with_type p =
 		in
 		match follow t with
 		| TMono m ->
-			begin match Monomorph.classify_constraints m with
+			begin match Monomorph.classify_down_constraints m with
 			| CStructural(fields,is_open) ->
 				if not is_open then begin
 					Monomorph.close m;

src/core/tType.ml

@@ -44,7 +44,15 @@ type t =
 
 and tmono = {
 	mutable tm_type : t option;
-	mutable tm_constraints : tmono_constraint list;
+	(*
+		```
+		function fn<A,B:A>() {}
+		```
+		`A` is a down-constraint for `B`
+		`B` is an up-constraint for `A`
+	*)
+	mutable tm_down_constraints : tmono_constraint list;
+	mutable tm_up_constraints : (t * string option) list;
 }
 
 and tmono_constraint =

src/core/tUnification.ml

@@ -64,13 +64,23 @@ let default_unification_context = {
 module Monomorph = struct
 	let create () = {
 		tm_type = None;
-		tm_constraints = [];
+		tm_down_constraints = [];
+		tm_up_constraints = []
 	}
 
 	(* constraining *)
 
-	let add_constraint m constr =
-		m.tm_constraints <- constr :: m.tm_constraints
+	let add_up_constraint m ((t,name) as constr) =
+		m.tm_up_constraints <- constr :: m.tm_up_constraints;
+		match t with
+		| TMono m2 -> m2.tm_down_constraints <- MMono (m2,name) :: m2.tm_down_constraints
+		| _ -> ()
+
+	let add_down_constraint m constr =
+		m.tm_down_constraints <- constr :: m.tm_down_constraints;
+		match constr with
+		| MMono (m2,s) -> m2.tm_up_constraints <- (TMono m,s) :: m.tm_up_constraints
+		| _ -> ()
 
 	let constraint_of_type name t = match follow t with
 		| TMono m2 ->
@@ -85,11 +95,11 @@ module Monomorph = struct
 			[MType(t,name)]
 
 	let constrain_to_type m name t =
-		List.iter (add_constraint m) (constraint_of_type name t)
+		List.iter (add_down_constraint m) (constraint_of_type name t)
 
 	(* Note: This function is called by printing and others and should thus not modify state. *)
 
-	let rec classify_constraints' m =
+	let rec classify_down_constraints' m =
 		let types = DynArray.create () in
 		let fields = ref PMap.empty in
 		let is_open = ref false in
@@ -98,7 +108,7 @@ module Monomorph = struct
 			| MMono(m2,name) ->
 				begin match m2.tm_type with
 				| None ->
-					let more_monos,kind = classify_constraints' m2 in
+					let more_monos,kind = classify_down_constraints' m2 in
 					monos := !monos @ more_monos;
 					begin match kind with
 					| CUnknown ->
@@ -106,7 +116,7 @@ module Monomorph = struct
 						monos := m2 :: !monos;
 					| _ ->
 						(* Recursively inherit constraints. *)
-						List.iter check m2.tm_constraints
+						List.iter check m2.tm_down_constraints
 					end
 				| Some t ->
 					List.iter (fun constr -> check constr) (constraint_of_type name t)
@@ -119,7 +129,7 @@ module Monomorph = struct
 			| MEmptyStructure ->
 				is_open := true
 		in
-		List.iter check m.tm_constraints;
+		List.iter check m.tm_down_constraints;
 		let kind =
 			if DynArray.length types > 0 then
 				CTypes (DynArray.to_list types)
@@ -130,9 +140,9 @@ module Monomorph = struct
 		in
 		!monos,kind
 
-	let classify_constraints m = snd (classify_constraints' m)
+	let classify_down_constraints m = snd (classify_down_constraints' m)
 
-	let check_constraints constr t =
+	let check_down_constraints constr t =
 		match constr with
 		| CUnknown ->
 			()
@@ -147,16 +157,44 @@ module Monomorph = struct
 			let t2 = mk_anon ~fields (ref Closed) in
 			(!unify_ref) default_unification_context t t2
 
+	let rec collect_up_constraints m =
+		let rec collect m acc =
+			List.fold_left (fun acc (t,name) ->
+				match t with
+				| TMono m2 ->
+					(match m2.tm_type with
+					| Some t ->
+						(match follow t with
+						| TMono _ -> acc
+						| _ -> (t,name) :: acc)
+					| None -> collect m2 acc
+					)
+				| _ -> (t,name) :: acc
+			) acc m.tm_up_constraints
+		in
+		collect m []
+
+	let check_up_constraints m t =
+		List.iter (fun (t2,constraint_name) ->
+			let check() =
+				(!unify_ref) default_unification_context t2 t
+			in
+			match constraint_name with
+			| Some name -> check_constraint name check
+			| None -> check()
+		) (collect_up_constraints m)
+
 	(* binding *)
 
 	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;
-		m.tm_constraints <- []
+		m.tm_down_constraints <- [];
+		m.tm_up_constraints <- []
 
 	let rec bind m t =
 		begin match t with
-		| TAnon _ when List.mem MOpenStructure m.tm_constraints ->
+		| TAnon _ when List.mem MOpenStructure m.tm_down_constraints ->
 			(* If we assign an open structure monomorph to another structure, the semantics want us to merge the
 			   fields. This is kinda weird, but that's how it has always worked. *)
 			constrain_to_type m None t;
@@ -164,28 +202,26 @@ module Monomorph = struct
 		| TMono m2 ->
 			if m != m2 then begin match m2.tm_type with
 			| None ->
-				List.iter (fun constr -> m2.tm_constraints <- constr :: m2.tm_constraints) m.tm_constraints;
+				List.iter (add_down_constraint m2) m.tm_down_constraints;
+				List.iter (add_up_constraint m2) m.tm_up_constraints;
 				do_bind m t;
 			| Some t ->
 				bind m t
 			end
 		| _ ->
+			check_up_constraints m t;
 			(* Due to recursive constraints like in #9603, we tentatively bind the monomorph to the type we're checking
 			   against before checking the constraints. *)
 			m.tm_type <- Some t;
-			let monos,kind = classify_constraints' m in
-			Std.finally (fun () -> m.tm_type <- None) (fun () -> check_constraints kind t) ();
-			(* If the monomorph we're binding to has other yet unbound monomorphs, bind them to our target type (issue #9640) .*)
-			List.iter (fun m2 ->
-				bind m2 t
-			) monos;
+			let monos,kind = classify_down_constraints' m in
+			Std.finally (fun () -> m.tm_type <- None) (fun () -> check_down_constraints kind t) ();
 			do_bind m t
 		end
 
 	and close m = match m.tm_type with
 		| Some _ ->
 			()
-		| None -> match classify_constraints m with
+		| None -> match classify_down_constraints m with
 			| CUnknown ->
 				()
 			| CTypes [(t,_)] ->
@@ -216,7 +252,7 @@ module Monomorph = struct
 	let spawn_constrained_monos map params =
 		let checks = DynArray.create () in
 		let monos = List.map (fun (s,t) ->
-			let mono = create() in
+			let mono = create () in
 			begin match follow t with
 				| TInst ({ cl_kind = KTypeParameter constr; cl_path = path },_) when constr <> [] ->
 					DynArray.add checks (mono,constr,s_type_path path)
@@ -1142,4 +1178,4 @@ end
 ;;
 unify_ref := unify_custom;;
 unify_min_ref := UnifyMinT.unify_min;;
-monomorph_classify_constraints_ref := Monomorph.classify_constraints
+monomorph_classify_constraints_ref := Monomorph.classify_down_constraints

src/typing/callUnification.ml

@@ -318,7 +318,7 @@ let unify_field_call ctx fa el_typed el p inline =
 			| [] -> [],[]
 			| cf :: candidates ->
 				let known_monos = List.map (fun (m,_) ->
-					m,m.tm_type,m.tm_constraints
+					m,m.tm_type,m.tm_down_constraints
 				) ctx.monomorphs.perfunction in
 				let current_monos = ctx.monomorphs.perfunction in
 				begin try
@@ -332,7 +332,7 @@ let unify_field_call ctx fa el_typed el p inline =
 				with Error ((Call_error cerr as err),p) ->
 					List.iter (fun (m,t,constr) ->
 						if t != m.tm_type then m.tm_type <- t;
-						if constr != m.tm_constraints then m.tm_constraints <- constr;
+						if constr != m.tm_down_constraints then m.tm_down_constraints <- constr;
 					) known_monos;
 					ctx.monomorphs.perfunction <- current_monos;
 					maybe_raise_unknown_ident cerr p;

src/typing/fields.ml

@@ -354,7 +354,7 @@ let type_field cfg ctx e i p mode (with_type : WithType.t) =
 				(mk_field i (mk_mono()) p null_pos) with
 				cf_kind = Var { v_read = AccNormal; v_write = if is_set then AccNormal else AccNo }
 			} in
-			(match Monomorph.classify_constraints r with
+			(match Monomorph.classify_down_constraints r with
 			| CStructural (fields,is_open) ->
 				(try
 					let f = PMap.find i fields in
@@ -365,7 +365,7 @@ let type_field cfg ctx e i p mode (with_type : WithType.t) =
 					field_access f FHAnon
 				with Not_found when is_open ->
 					let f = mk_field() in
-					Monomorph.add_constraint r (MField f);
+					Monomorph.add_down_constraint r (MField f);
 					field_access f FHAnon
 				)
 			| CTypes tl ->
@@ -374,8 +374,8 @@ let type_field cfg ctx e i p mode (with_type : WithType.t) =
 				if not (List.exists (fun (m,_) -> m == r) ctx.monomorphs.perfunction) && not (ctx.untyped && ctx.com.platform = Neko) then
 					ctx.monomorphs.perfunction <- (r,p) :: ctx.monomorphs.perfunction;
 				let f = mk_field() in
-				Monomorph.add_constraint r (MField f);
-				Monomorph.add_constraint r MOpenStructure;
+				Monomorph.add_down_constraint r (MField f);
+				Monomorph.add_down_constraint r MOpenStructure;
 				field_access f FHAnon
 			)
 		| TAbstract (a,tl) ->
@@ -477,7 +477,7 @@ let type_field cfg ctx e i p mode (with_type : WithType.t) =
 		match t with
 		| TType (td,tl) -> type_field_by_typedef type_field_by_module_extension e td tl
 		| TMono r ->
-			(match Monomorph.classify_constraints r with
+			(match Monomorph.classify_down_constraints r with
 			| CStructural (_,is_open) when not is_open -> type_field_by_extension()
 			| _ -> raise Not_found
 			)

src/typing/operators.ml

@@ -191,7 +191,7 @@ let unify_int ctx e k =
 		| TAnon a ->
 			(try is_dynamic (PMap.find f a.a_fields).cf_type with Not_found -> false)
 		| TMono m ->
-			begin match Monomorph.classify_constraints m with
+			begin match Monomorph.classify_down_constraints m with
 			| CStructural(fields,_) ->
 				(try is_dynamic (PMap.find f fields).cf_type with Not_found -> false)
 			| _ ->

tests/misc/projects/Issue10198/Main4.hx

@@ -0,0 +1,9 @@
+class Main4 {
+	static function main() {
+		var n = null;
+		fn1(1, n);
+		n = 1.2;
+	}
+
+	static function fn1<T, R:T>(r:R, t:Null<T>) {}
+}

tests/misc/projects/Issue10198/Main5.hx

@@ -0,0 +1,15 @@
+class Main5 {
+	static function fn2<T, R:T>(r:R, fn:()->T):T
+		return null;
+
+	static function main() {
+		var a:Parent = fn2((null:Child), () -> new Parent());
+		var a:GrandParent = fn2((null:Child), () -> new GrandParent());
+	}
+}
+
+private class GrandParent {
+	public function new() {}
+}
+private class Parent extends GrandParent {}
+private class Child extends Parent {}

tests/misc/projects/Issue10198/Main6.hx

@@ -0,0 +1,15 @@
+class Main6 {
+	static function fn2<T, R:T>(r:R, fn:()->T):T
+		return null;
+
+	static function test() {
+		var a:Parent = fn2((null:Child), () -> new GrandParent());
+	}
+
+}
+
+private class GrandParent {
+	public function new() {}
+}
+private class Parent extends GrandParent {}
+private class Child extends Parent {}

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

@@ -1 +1,2 @@
-Main.hx:3: characters 3-6 : String should be Int
+Main.hx:3: characters 3-6 : Constraint check failure for fn.R
+Main.hx:3: characters 3-6 : ... String should be Int

tests/misc/projects/Issue10198/compile2-fail.hxml.stderr

@@ -1,3 +1,3 @@
-Main2.hx:4: characters 3-50 : error: { id : String, createDate : Date } has no field project
+Main2.hx:4: characters 3-50 : error: { ?project : Null<String>, id : String } has no field createDate
 Main2.hx:4: characters 3-50 : ... have: Vector<Foo>
 Main2.hx:4: characters 3-50 : ... want: Vector<Bar>

tests/misc/projects/Issue10198/compile4.hxml

@@ -0,0 +1 @@
+--main Main4

tests/misc/projects/Issue10198/compile5.hxml

@@ -0,0 +1 @@
+--main Main5

tests/misc/projects/Issue10198/compile6-fail.hxml

@@ -0,0 +1 @@
+--main Main6

tests/misc/projects/Issue10198/compile6-fail.hxml.stderr

@@ -0,0 +1 @@
+Main6.hx:6: characters 3-61 : _Main6.GrandParent should be _Main6.Parent

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

@@ -1,4 +1,6 @@
 Main.hx:21: characters 3-23 : String should be Int
-Main.hx:22: characters 3-32 : String should be Int
-Main.hx:23: characters 3-39 : Foo should be Bar
+Main.hx:22: characters 3-32 : Constraint check failure for constrained.R
+Main.hx:22: characters 3-32 : ... String should be Int
+Main.hx:23: characters 3-39 : Constraint check failure for constrained.R
+Main.hx:23: characters 3-39 : ... Foo should be Bar
 Main.hx:23: characters 3-39 : ... { ?project : Null<String>, id : String } has no field createDate

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

@@ -1,4 +1,5 @@
-Main.hx:5: characters 9-13 : Warning : Mono<Foo>
-Main.hx:8: characters 3-36 : Foo should be BarLike
+Main.hx:5: characters 9-13 : Warning : Mono<Unknown<0>>
+Main.hx:8: characters 3-36 : Constraint check failure for new.B
+Main.hx:8: characters 3-36 : ... Foo should be BarLike
 Main.hx:8: characters 3-36 : ... Foo has no field bar
-Main.hx:10: characters 9-13 : Warning : Mono<Foo>
+Main.hx:10: characters 9-13 : Warning : Mono<Unknown<0>>