better detection of multitype specialization

in Abstract.get_underlying_type (fixes #9712)

src/context/abstractCast.ml

@@ -166,54 +166,28 @@ let find_array_access ctx a tl e1 e2o p =
 let find_multitype_specialization com a pl p =
 	let uctx = default_unification_context in
 	let m = mk_mono() in
-	let tl,definitive_types = match Meta.get Meta.MultiType a.a_meta with
-		| _,[],_ -> pl,pl
-		| _,el,_ ->
-			let relevant = Hashtbl.create 0 in
-			List.iter (fun e ->
-				let rec loop f e = match fst e with
-					| EConst(Ident s) ->
-						Hashtbl.replace relevant s f
-					| EMeta((Meta.Custom ":followWithAbstracts",_,_),e1) ->
-						loop Abstract.follow_with_abstracts e1;
-					| _ ->
-						error "Type parameter expected" (pos e)
-				in
-				loop (fun t -> t) e
-			) el;
-			let definitive_types = ref [] in
-			let tl = List.map2 (fun (n,_) t ->
-				try
-					let t = (Hashtbl.find relevant n) t in
-					definitive_types := t :: !definitive_types;
+	let tl,definitive_types = Abstract.find_multitype_params a pl in
+	if com.platform = Globals.Js && a.a_path = (["haxe";"ds"],"Map") then begin match tl with
+		| t1 :: _ ->
+			let stack = ref [] in
+			let rec loop t =
+				if List.exists (fun t2 -> fast_eq t t2) !stack then
 					t
-				with Not_found ->
-					if not (has_mono t) then t
-					else t_dynamic
-			) a.a_params pl in
-			if com.platform = Globals.Js && a.a_path = (["haxe";"ds"],"Map") then begin match tl with
-				| t1 :: _ ->
-					let stack = ref [] in
-					let rec loop t =
-						if List.exists (fun t2 -> fast_eq t t2) !stack then
-							t
-						else begin
-							stack := t :: !stack;
-							match follow t with
-							| TAbstract ({ a_path = [],"Class" },_) ->
-								error (Printf.sprintf "Cannot use %s as key type to Map because Class<T> is not comparable on JavaScript" (s_type (print_context()) t1)) p;
-							| TEnum(en,tl) ->
-								PMap.iter (fun _ ef -> ignore(loop ef.ef_type)) en.e_constrs;
-								Type.map loop t
-							| t ->
-								Type.map loop t
-						end
-					in
-					ignore(loop t1)
-				| _ -> die "" __LOC__
-			end;
-			tl,!definitive_types
-	in
+				else begin
+					stack := t :: !stack;
+					match follow t with
+					| TAbstract ({ a_path = [],"Class" },_) ->
+						error (Printf.sprintf "Cannot use %s as key type to Map because Class<T> is not comparable on JavaScript" (s_type (print_context()) t1)) p;
+					| TEnum(en,tl) ->
+						PMap.iter (fun _ ef -> ignore(loop ef.ef_type)) en.e_constrs;
+						Type.map loop t
+					| t ->
+						Type.map loop t
+				end
+			in
+			ignore(loop t1)
+		| _ -> die "" __LOC__
+	end;
 	let _,cf =
 		try
 			let t = Abstract.find_to uctx m a tl in

src/core/abstract.ml

@@ -1,3 +1,5 @@
+open Globals
+open Ast
 open Meta
 open TType
 open TFunctions
@@ -65,7 +67,47 @@ let find_to uctx b ab tl =
 
 let underlying_type_stack = new_rec_stack()
 
-let rec get_underlying_type ?(return_first=false) a pl =
+(**
+	Returns type parameters and the list of types, which should be known at compile time
+	to be able to choose multitype specialization.
+*)
+let rec find_multitype_params a pl =
+	match Meta.get Meta.MultiType a.a_meta with
+	| _,[],_ -> pl,pl
+	| _,el,_ ->
+		let relevant = Hashtbl.create 0 in
+		List.iter (fun e ->
+			let rec loop f e = match fst e with
+				| EConst(Ident s) ->
+					Hashtbl.replace relevant s f
+				| EMeta((Meta.Custom ":followWithAbstracts",_,_),e1) ->
+					loop follow_with_abstracts e1;
+				| _ ->
+					error "Type parameter expected" (pos e)
+			in
+			loop (fun t -> t) e
+		) el;
+		let definitive_types = ref [] in
+		let tl = List.map2 (fun (n,_) t ->
+			try
+				let t = (Hashtbl.find relevant n) t in
+				definitive_types := t :: !definitive_types;
+				t
+			with Not_found ->
+				if not (has_mono t) then t
+				else t_dynamic
+		) a.a_params pl in
+		tl,!definitive_types
+
+and find_multitype_specialization_type a pl =
+	let uctx = default_unification_context in
+	let m = mk_mono() in
+	let tl,definitive_types = find_multitype_params a pl in
+	ignore(find_to uctx m a tl);
+	if List.exists (fun t -> has_mono t) definitive_types then raise Not_found;
+	follow m
+
+and get_underlying_type ?(return_first=false) a pl =
 	let maybe_recurse t =
 		let rec loop t = match t with
 			| TMono r ->
@@ -98,19 +140,19 @@ let rec get_underlying_type ?(return_first=false) a pl =
 	in
 	try
 		if not (Meta.has Meta.MultiType a.a_meta) then raise Not_found;
-		(* TODO:
-			Look into replacing `mk_mono` & `find_to` with `build_abstract a` & `TAbstract(a, pl)`.
-			`find_to` is probably needed for `@:multiType`
-		*)
-		let m = mk_mono() in
-		let _ = find_to default_unification_context m a pl in
-		maybe_recurse (follow m)
+		find_multitype_specialization_type a pl
 	with Not_found ->
 		if Meta.has Meta.CoreType a.a_meta then
 			t_dynamic
 		else
 			maybe_recurse (apply_params a.a_params pl a.a_this)
 
+and follow_with_abstracts t = match follow t with
+	| TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
+		follow_with_abstracts (get_underlying_type a tl)
+	| t ->
+		t
+
 let rec follow_with_forward_ctor ?(build=false) t = match follow t with
 	| TAbstract(a,tl) as t ->
 		if build then build_abstract a;
@@ -124,12 +166,6 @@ let rec follow_with_forward_ctor ?(build=false) t = match follow t with
 	| t ->
 		t
 
-let rec follow_with_abstracts t = match follow t with
-	| TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
-		follow_with_abstracts (get_underlying_type a tl)
-	| t ->
-		t
-
 let rec follow_with_abstracts_without_null t = match follow_without_null t with
 	| TAbstract({a_path = [],"Null"},_) ->
 		t

tests/misc/projects/Issue9712/Main.hx

@@ -0,0 +1,8 @@
+class Main {
+	static function main() {
+		var map = (['a' => 10]:Map<AbstractString, Int>);
+		for (key => val in map) trace(key, val);
+	}
+}
+
+abstract AbstractString(String) from String { }

tests/misc/projects/Issue9712/compile.hxml

@@ -0,0 +1,2 @@
+--main Main
+--interp