[jvm] abstract typedefs away in anon handling

src/generators/genjvm.ml

@@ -565,12 +565,9 @@ class texpr_to_jvm gctx (jc : JvmClass.builder) (jm : JvmMethod.builder) (return
 			cast();
 		in
 		match gctx.anon_identification#identify true t with
-		| Some td ->
-			let cf = match follow td.t_type with
-				| TAnon an -> PMap.find cf.cf_name an.a_fields
-				| _ -> assert false
-			in
-			let path = td.t_path in
+		| Some pfm ->
+			let cf = PMap.find cf.cf_name pfm.pfm_fields in
+			let path = pfm.pfm_path in
 			code#dup;
 			code#instanceof path;
 			jm#if_then_else
@@ -703,12 +700,9 @@ class texpr_to_jvm gctx (jc : JvmClass.builder) (jm : JvmMethod.builder) (return
 		| TField(e1,FAnon cf) ->
 			self#texpr rvalue_any e1;
 			begin match gctx.anon_identification#identify true e1.etype with
-			| Some td ->
-				let cf = match follow td.t_type with
-					| TAnon an -> PMap.find cf.cf_name an.a_fields
-					| _ -> assert false
-				in
-				let path = td.t_path in
+			| Some pfm ->
+				let cf = PMap.find cf.cf_name pfm.pfm_fields in
+				let path = pfm.pfm_path in
 				code#dup;
 				code#instanceof path;
 				let jsig_cf = self#vtype cf.cf_type in
@@ -1530,7 +1524,7 @@ class texpr_to_jvm gctx (jc : JvmClass.builder) (jm : JvmMethod.builder) (return
 			Some tr
 		| TField(e11,FAnon cf) ->
 			begin match gctx.anon_identification#identify false e11.etype with
-			| Some {t_path=path_anon} ->
+			| Some {pfm_path=path_anon} ->
 				begin match gctx.typedef_interfaces#get_interface_class path_anon with
 				| Some c ->
 					let c,_,cf = raw_class_field (fun cf -> cf.cf_type) c [] cf.cf_name in
@@ -2076,12 +2070,9 @@ class texpr_to_jvm gctx (jc : JvmClass.builder) (jm : JvmMethod.builder) (return
 			begin match follow e.etype,td with
 			(* The guard is here because in the case of quoted fields like `"a-b"`, the field is not part of the
 			   type. In this case we have to do full dynamic construction. *)
-			| TAnon an,Some td when List.for_all (fun ((name,_,_),_) -> PMap.mem name an.a_fields) fl ->
-				let fl' = match follow td.t_type with
-					| TAnon an -> convert_fields gctx an.a_fields
-					| _ -> assert false
-				in
-				jm#construct ConstructInit td.t_path (fun () ->
+			| TAnon an,Some pfm when List.for_all (fun ((name,_,_),_) -> PMap.mem name an.a_fields) fl ->
+				let fl' = convert_fields gctx pfm.pfm_fields in
+				jm#construct ConstructInit pfm.pfm_path (fun () ->
 					(* We have to respect declaration order, so let's temp var where necessary *)
 					let rec loop fl fl' ok acc = match fl,fl' with
 						| ((name,_,_),e) :: fl,(name',jsig) :: fl' ->
@@ -2780,12 +2771,8 @@ let generate_module_type ctx mt =
 	)
 
 let generate_anons gctx =
-	Hashtbl.iter (fun path td ->
-		let fields = match follow td.t_type with
-			| TAnon an -> an.a_fields
-			| _ -> assert false
-		in
-		let fields = convert_fields gctx fields in
+	Hashtbl.iter (fun path pfm ->
+		let fields = convert_fields gctx pfm.pfm_fields in
 		let jc = new JvmClass.builder path haxe_dynamic_object_path in
 		jc#add_access_flag 0x1;
 		begin

src/generators/genshared.ml

@@ -117,7 +117,22 @@ let find_overload_rec is_ctor map_type c cf el =
 		| Some (_,_,(c,cf,tl)) -> Some (c,cf,tl)
 		| None -> Some(c,cf,List.map snd cf.cf_params)
 
-exception Typedef_result of tdef
+type path_field_mapping = {
+	pfm_path : path;
+	pfm_params : type_params;
+	pfm_fields : (string,tclass_field) PMap.t;
+}
+
+let pfm_of_typedef td = match follow td.t_type with
+	| TAnon an -> {
+		pfm_path = td.t_path;
+		pfm_params = td.t_params;
+		pfm_fields = an.a_fields;
+	}
+	| _ ->
+		assert false
+
+exception Typedef_result of path_field_mapping
 
 class ['a] tanon_identification (empty_path : string list * string) =
 	let is_normal_anon an = match !(an.a_status) with
@@ -131,24 +146,41 @@ object(self)
 
 	method get_anons = td_anons
 
-	method unify (tc : Type.t) (td : tdef) =
-		let monos = List.map (fun _ -> mk_mono()) td.t_params in
-		let ta = apply_params td.t_params monos td.t_type in
-		begin match follow tc,follow ta with
-		| TInst(c,tl) as t1,(TAnon an as t2) ->
-			Type.unify t1 t2
-		| TAnon an1,TAnon an2 ->
-			Type.type_eq EqDoNotFollowNull tc ta;
-		| _ ->
+	method unify (tc : Type.t) (pfm : path_field_mapping) =
+		let check () =
+			let monos = List.map (fun _ -> mk_mono()) pfm.pfm_params in
+			let map = apply_params pfm.pfm_params monos in
+			begin match follow tc with
+			| TInst(c,tl) ->
+				PMap.iter (fun _ cf ->
+					let cf' = PMap.find cf.cf_name c.cl_fields in
+					if not (unify_kind cf'.cf_kind cf.cf_kind) then raise (Unify_error [Unify_custom "kind mismatch"]);
+					Type.unify (apply_params c.cl_params tl (monomorphs cf'.cf_params cf'.cf_type)) (map (monomorphs cf.cf_params cf.cf_type))
+				) pfm.pfm_fields
+			| TAnon an1 ->
+				let fields = ref an1.a_fields in
+				PMap.iter (fun _ cf ->
+					let cf' = PMap.find cf.cf_name an1.a_fields in
+					if not (unify_kind cf'.cf_kind cf.cf_kind) then raise (Unify_error [Unify_custom "kind mismatch"]);
+					fields := PMap.remove cf.cf_name !fields;
+					Type.type_eq EqDoNotFollowNull cf'.cf_type (map (monomorphs cf.cf_params cf.cf_type))
+				) pfm.pfm_fields;
+				if not (PMap.is_empty !fields) then raise (Unify_error [Unify_custom "not enough fields"])
+			| _ ->
+				raise (Unify_error [Unify_custom "bad type"])
+			end;
+			(* Check if we applied Void to a return type parameter... (#3463) *)
+			List.iter (fun t -> match follow t with
+				| TMono r ->
+					Monomorph.bind r t_dynamic
+				| t ->
+					if Type.ExtType.is_void t then raise(Unify_error [Unify_custom "return mono"])
+			) monos
+		in
+		try
+			check()
+		with Not_found ->
 			raise (Unify_error [])
-		end;
-		(* Check if we applied Void to a return type parameter... (#3463) *)
-		List.iter (fun t -> match follow t with
-			| TMono r ->
-				Monomorph.bind r t_dynamic
-			| t ->
-				if Type.ExtType.is_void t then raise(Unify_error [])
-		) monos;
 
 	method find_compatible (tc : Type.t) =
 		try
@@ -166,7 +198,7 @@ object(self)
 	method identify_typedef (td : tdef) =
 		let rec loop t = match t with
 			| TAnon an when is_normal_anon an && not (PMap.is_empty an.a_fields) ->
-				Hashtbl.replace td_anons td.t_path td;
+				Hashtbl.replace td_anons td.t_path (pfm_of_typedef td);
 			| TMono {tm_type = Some t} ->
 				loop t
 			| TLazy f ->
@@ -192,7 +224,7 @@ object(self)
 			self#identify accept_anons t
 		| TLazy f ->
 			self#identify accept_anons (lazy_type f)
-		| TAnon an when accept_anons ->
+		| TAnon an when accept_anons && not (PMap.is_empty an.a_fields) ->
 			PMap.iter (fun _ cf ->
 				Gencommon.replace_mono cf.cf_type
 			) an.a_fields;
@@ -202,20 +234,13 @@ object(self)
 				let id = num in
 				num <- num + 1;
 				let path = (["haxe";"generated"],Printf.sprintf "Anon%i" id) in
-				let td = {
-					t_path = path;
-					t_module = null_module;
-					t_pos = null_pos;
-					t_name_pos = null_pos;
-					t_doc = None;
-					t_private = false;
-					t_params = [];
-					t_using = [];
-					t_type = t;
-					t_meta = [];
+				let pfm = {
+					pfm_path = path;
+					pfm_params = [];
+					pfm_fields = an.a_fields;
 				} in
-				Hashtbl.replace td_anons td.t_path td;
-				Some td
+				Hashtbl.replace td_anons path pfm;
+				Some pfm
 			end;
 		| _ ->
 			None
@@ -463,28 +488,23 @@ class ['a] typedef_interfaces (anon_identification : 'a tanon_identification) =
 			| Some (c,_) -> self#implements_recursively c path
 			| None -> false
 
-	method private make_interface_class (td : tdef) =
-		let path_inner = (fst td.t_path,snd td.t_path ^ "$Interface") in
+	method private make_interface_class (pfm : path_field_mapping) =
+		let path_inner = (fst pfm.pfm_path,snd pfm.pfm_path ^ "$Interface") in
 		try
 			Hashtbl.find interfaces path_inner
 		with Not_found ->
-			let fields = match follow td.t_type with
-				| TAnon an ->
-					PMap.foldi (fun name cf acc -> match cf.cf_kind with
-						| Method (MethNormal | MethInline) ->
-							PMap.add name cf acc
-						| _ ->
-							acc
-					) an.a_fields PMap.empty
+			let fields = PMap.foldi (fun name cf acc -> match cf.cf_kind with
+				| Method (MethNormal | MethInline) ->
+					PMap.add name cf acc
 				| _ ->
-					assert false
-			in
-			if PMap.is_empty fields then raise (Unify_error []);
+					acc
+			) pfm.pfm_fields PMap.empty in
+			if PMap.is_empty fields then raise (Unify_error [Unify_custom "no fields"]);
 			let c = mk_class null_module path_inner null_pos null_pos in
 			c.cl_interface <- true;
 			c.cl_fields <- fields;
 			c.cl_ordered_fields <- PMap.fold (fun cf acc -> cf :: acc) fields [];
-			Hashtbl.replace interfaces td.t_path c;
+			Hashtbl.replace interfaces pfm.pfm_path c;
 			c
 
 	method private do_process_class (c : tclass) =
@@ -493,13 +513,13 @@ class ['a] typedef_interfaces (anon_identification : 'a tanon_identification) =
 			| None -> ()
 		end;
 		let tc = TInst(c,List.map snd c.cl_params) in
-		let l = Hashtbl.fold (fun _ td acc ->
-			let path = td.t_path in
+		let l = Hashtbl.fold (fun _ pfm acc ->
+			let path = pfm.pfm_path in
 			let path_inner = (fst path,snd path ^ "$Interface") in
 			try
-				if self#implements_recursively c path_inner then raise (Unify_error []);
-				anon_identification#unify tc td;
-				let ci = self#make_interface_class td in
+				if self#implements_recursively c path_inner then raise (Unify_error [Unify_custom "already implemented"]);
+				anon_identification#unify tc pfm;
+				let ci = self#make_interface_class pfm in
 				c.cl_implements <- (ci,[]) :: c.cl_implements;
 				(* print_endline (Printf.sprintf "%s IMPLEMENTS %s" (s_type_path c.cl_path) (s_type_path path_inner)); *)
 				(ci :: acc)