瀏覽代碼

bind contextual monomorphs to structures

Simon Krajewski 5 年之前
父節點
當前提交
9a5d8c5632

+ 3 - 3
src/context/typecore.ml

@@ -551,9 +551,9 @@ let spawn_constrained_monos ctx p map params =
 	check_constraints map params monos p;
 	monos
 
-let safe_mono_close ctx m p =
+let safe_mono_close ctx m mode p =
 	try
-		Monomorph.close m
+		Monomorph.close m mode
 	with
 		Unify_error l ->
 			raise_or_display ctx l p;
@@ -563,7 +563,7 @@ let with_contextual_monos ctx f =
 	let old_monos = ctx.monomorphs.percall in
 	ctx.monomorphs.percall <- [];
 	let r = f() in
-	(* List.iter (fun (m,p) -> ignore(safe_mono_close ctx m p)) ctx.monomorphs.percall; *)
+	List.iter (fun (m,p) -> ignore(safe_mono_close ctx m CContextual p)) ctx.monomorphs.percall;
 	ctx.monomorphs.percall <- old_monos;
 	r
 

+ 6 - 13
src/core/tUnification.ml

@@ -61,6 +61,10 @@ module Monomorph = struct
 		| CStructural of (string,tclass_field) PMap.t * bool
 		| CTypes of (string * pos * t) list
 
+	type closing_mode =
+		| CContextual
+		| CRequired
+
 	(* constraining *)
 
 	let make_constraint name p kind =
@@ -82,17 +86,6 @@ module Monomorph = struct
 	let constrain_to_type m name p t =
 		List.iter (add_constraint m name p) (constraint_of_type t)
 
-	let get_field_constraint m name =
-		let rec loop l = match l with
-			| {mc_kind = MField cf} :: _ when cf.cf_name = name ->
-				Some cf
-			| _ :: l ->
-				loop l
-			| [] ->
-				None
-		in
-		loop m.tm_constraints
-
 	let classify_constraints m =
 		let types = DynArray.create () in
 		let fields = ref PMap.empty in
@@ -163,13 +156,13 @@ module Monomorph = struct
 			do_bind m t
 		end
 
-	and close m = match m.tm_type with
+	and close m mode = match m.tm_type with
 		| Some _ ->
 			false
 		| None -> match classify_constraints m with
 			| CUnknown ->
 				false
-			| CTypes [(_,_,t)] ->
+			| CTypes [(_,_,t)] when mode = CRequired ->
 				do_bind m t;
 				true
 			| CTypes _ ->

+ 1 - 1
src/typing/generic.ml

@@ -50,7 +50,7 @@ let make_generic ctx ps pt p =
 				| _ when not top ->
 					follow_or t top (fun() -> "_") (* allow unknown/incompatible types as type parameters to retain old behavior *)
 				| TMono ({ tm_type = None } as m) ->
-					if safe_mono_close ctx m p then loop top t
+					if safe_mono_close ctx m CRequired p then loop top t
 					else raise (Generic_Exception (("Could not determine type for parameter " ^ s), p))
 				| TDynamic _ -> "Dynamic"
 				| t ->

+ 0 - 1
src/typing/typeload.ml

@@ -708,7 +708,6 @@ let load_type_hint ?(opt=false) ctx pcur t =
 	let t = match t with
 		| None ->
 			let mono = Monomorph.create () in
-			if Meta.has (Meta.Custom ":debug.monomorphs") ctx.curfield.cf_meta then Monomorph.add_constraint mono "debug" pcur (MDebug "type-hint");
 			ctx.monomorphs.perfunction <- (mono,pcur) :: ctx.monomorphs.perfunction;
 			TMono mono
 		| Some (t,p) ->	load_complex_type ctx true (t,p)

+ 1 - 1
src/typing/typeloadFunction.ml

@@ -224,7 +224,7 @@ let type_function ctx args ret fmode f do_display p =
 		| _ -> e
 	in
 	List.iter (fun r -> r := Closed) ctx.opened;
-	List.iter (fun (m,p) -> ignore(safe_mono_close ctx m p)) ctx.monomorphs.perfunction;
+	List.iter (fun (m,p) -> ignore(safe_mono_close ctx m CRequired p)) ctx.monomorphs.perfunction;
 	if is_position_debug then print_endline ("typing:\n" ^ (Texpr.dump_with_pos "" e));
 	e , fargs
 

+ 8 - 0
tests/unit/src/unit/TestConstrainedMonomorphs.hx

@@ -54,4 +54,12 @@ class TestConstrainedMonomorphs extends Test {
 		eq("nullfoo", DetectiveHaxeExtern.itWasYou(a, "foo"));
 	}
 	#end
+
+	static function merge<A:{}, B:{}, C:A & B>(a:A, b:B):C {
+		return null;
+	}
+	function testMergedConstraints() {
+		var a = merge({foo: 5}, {bar: "bar"});
+		HelperMacros.typedAs(a, (null : { foo: Int, bar: String }));
+	}
 }