strict tanon identification (#11489)

* strict tanon identification

* Use named argument instead of optional

* cleanup a bit

* whoops

src/codegen/gencommon/castDetect.ml

@@ -193,7 +193,7 @@ let rec type_eq gen param a b =
 			PMap.iter (fun n f1 ->
 				try
 					let f2 = PMap.find n a2.a_fields in
-					if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || not (unify_kind f1.cf_kind f2.cf_kind)) then Type.error [invalid_kind n f1.cf_kind f2.cf_kind];
+					if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || not (unify_kind ~strict:false f1.cf_kind f2.cf_kind)) then Type.error [invalid_kind n f1.cf_kind f2.cf_kind];
 					try
 						type_eq gen param f1.cf_type f2.cf_type
 					with

src/core/tUnification.ml

@@ -29,13 +29,16 @@ type eq_kind =
 	| EqRightDynamic
 	| EqBothDynamic
 	| EqDoNotFollowNull (* like EqStrict, but does not follow Null<T> *)
+	| EqStricter
 
 type unification_context = {
-	allow_transitive_cast : bool;
-	allow_abstract_cast   : bool; (* allows a non-transitive abstract cast (from,to,@:from,@:to) *)
-	allow_dynamic_to_cast : bool; (* allows a cast from dynamic to non-dynamic *)
-	equality_kind         : eq_kind;
-	equality_underlying   : bool;
+	allow_transitive_cast   : bool;
+	allow_abstract_cast     : bool; (* allows a non-transitive abstract cast (from,to,@:from,@:to) *)
+	allow_dynamic_to_cast   : bool; (* allows a cast from dynamic to non-dynamic *)
+	allow_arg_name_mismatch : bool;
+	equality_kind           : eq_kind;
+	equality_underlying     : bool;
+	strict_field_kind       : bool;
 }
 
 type unify_min_result =
@@ -54,11 +57,13 @@ let unify_ref : (unification_context -> t -> t -> unit) ref = ref (fun _ _ _ ->
 let unify_min_ref : (unification_context -> t -> t list -> unify_min_result) ref = ref (fun _ _ _ -> assert false)
 
 let default_unification_context = {
-	allow_transitive_cast = true;
-	allow_abstract_cast   = true;
-	allow_dynamic_to_cast = true;
-	equality_kind         = EqStrict;
-	equality_underlying   = false;
+	allow_transitive_cast   = true;
+	allow_abstract_cast     = true;
+	allow_dynamic_to_cast   = true;
+	allow_arg_name_mismatch = true;
+	equality_kind           = EqStrict;
+	equality_underlying     = false;
+	strict_field_kind       = false;
 }
 
 module Monomorph = struct
@@ -427,15 +432,20 @@ let direct_access = function
 	| AccNo | AccNever | AccNormal | AccInline | AccRequire _ | AccCtor -> true
 	| AccCall -> false
 
-let unify_kind k1 k2 =
+let unify_kind ~(strict:bool) k1 k2 =
 	k1 = k2 || match k1, k2 with
 		| Var v1, Var v2 -> unify_access v1.v_read v2.v_read && unify_access v1.v_write v2.v_write
-		| Var v, Method m ->
+		| Method m1, Method m2 ->
+			(match m1,m2 with
+			| MethInline, MethNormal
+			| MethDynamic, MethNormal -> true
+			| _ -> false)
+		| Var v, Method m when not strict ->
 			(match v.v_read, v.v_write, m with
 			| AccNormal, _, MethNormal -> true
 			| AccNormal, AccNormal, MethDynamic -> true
 			| _ -> false)
-		| Method m, Var v ->
+		| Method m, Var v when not strict ->
 			(match m with
 			| MethDynamic -> direct_access v.v_read && direct_access v.v_write
 			| MethMacro -> false
@@ -443,11 +453,7 @@ let unify_kind k1 k2 =
 				match v.v_read,v.v_write with
 				| AccNormal,(AccNo | AccNever) -> true
 				| _ -> false)
-		| Method m1, Method m2 ->
-			match m1,m2 with
-			| MethInline, MethNormal
-			| MethDynamic, MethNormal -> true
-			| _ -> false
+		| _ -> false
 
 type 'a rec_stack = {
 	mutable rec_stack : 'a list;
@@ -489,7 +495,12 @@ let rec_stack_default stack value fcheck frun def =
 
 let rec type_eq uctx a b =
 	let param = uctx.equality_kind in
+	let can_follow_null = match param with
+		| EqStricter | EqDoNotFollowNull -> false
+		| _ -> true
+	in
 	let can_follow t = match param with
+		| EqStricter -> false
 		| EqCoreType -> false
 		| EqDoNotFollowNull -> not (is_explicit_null t)
 		| _ -> true
@@ -521,9 +532,9 @@ let rec type_eq uctx a b =
 		()
 	| TAbstract ({a_path=[],"Null"},[t1]),TAbstract ({a_path=[],"Null"},[t2]) ->
 		type_eq uctx t1 t2
-	| TAbstract ({a_path=[],"Null"},[t]),_ when param <> EqDoNotFollowNull ->
+	| TAbstract ({a_path=[],"Null"},[t]),_ when can_follow_null ->
 		type_eq uctx t b
-	| _,TAbstract ({a_path=[],"Null"},[t]) when param <> EqDoNotFollowNull ->
+	| _,TAbstract ({a_path=[],"Null"},[t]) when can_follow_null ->
 		type_eq uctx a t
 	| TType (t1,tl1), TType (t2,tl2) when (t1 == t2 || (param = EqCoreType && t1.t_path = t2.t_path)) && List.length tl1 = List.length tl2 ->
 		type_eq_params uctx a b tl1 tl2
@@ -545,9 +556,10 @@ let rec type_eq uctx a b =
 		let i = ref 0 in
 		(try
 			type_eq uctx r1 r2;
-			List.iter2 (fun (n,o1,t1) (_,o2,t2) ->
+			List.iter2 (fun (n1,o1,t1) (n2,o2,t2) ->
 				incr i;
-				if o1 <> o2 then error [Not_matching_optional n];
+				if not uctx.allow_arg_name_mismatch && n1 <> n2 then error [Unify_custom (Printf.sprintf "Arg name mismatch: %s should be %s" n2 n1)];
+				if o1 <> o2 then error [Not_matching_optional n1];
 				type_eq uctx t1 t2
 			) l1 l2
 		with
@@ -576,7 +588,11 @@ let rec type_eq uctx a b =
 			PMap.iter (fun n f1 ->
 				try
 					let f2 = PMap.find n a2.a_fields in
-					if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || not (unify_kind f1.cf_kind f2.cf_kind)) then error [invalid_kind n f1.cf_kind f2.cf_kind];
+					let kind_should_match = match param with
+						| EqStrict | EqCoreType | EqDoNotFollowNull | EqStricter -> true
+						| _ -> false
+					in
+					if f1.cf_kind <> f2.cf_kind && (kind_should_match || not (unify_kind ~strict:uctx.strict_field_kind f1.cf_kind f2.cf_kind)) then error [invalid_kind n f1.cf_kind f2.cf_kind];
 					let a = f1.cf_type and b = f2.cf_type in
 					(try type_eq uctx a b with Unify_error l -> error (invalid_field n :: l));
 					if (has_class_field_flag f1 CfPublic) != (has_class_field_flag f2 CfPublic) then error [invalid_visibility n];
@@ -753,7 +769,7 @@ let rec unify (uctx : unification_context) a b =
 				in
 				let _, ft, f1 = (try raw_class_field make_type c tl n with Not_found -> error [has_no_field a n]) in
 				let ft = apply_params c.cl_params tl ft in
-				if not (unify_kind f1.cf_kind f2.cf_kind) then error [invalid_kind n f1.cf_kind f2.cf_kind];
+				if not (unify_kind ~strict:uctx.strict_field_kind f1.cf_kind f2.cf_kind) then error [invalid_kind n f1.cf_kind f2.cf_kind];
 				if (has_class_field_flag f2 CfPublic) && not (has_class_field_flag f1 CfPublic) then error [invalid_visibility n];
 
 				(match f2.cf_kind with
@@ -907,7 +923,7 @@ and unify_anons uctx a b a1 a2 =
 	let unify_field a1_fields f2 =
 		let n = f2.cf_name in
 		let f1 = PMap.find n a1_fields in
-		if not (unify_kind f1.cf_kind f2.cf_kind) then
+		if not (unify_kind ~strict:uctx.strict_field_kind f1.cf_kind f2.cf_kind) then
 			error [invalid_kind n f1.cf_kind f2.cf_kind];
 		if (has_class_field_flag f2 CfPublic) && not (has_class_field_flag f1 CfPublic) then
 			error [invalid_visibility n];

src/generators/genjvm.ml

@@ -3036,7 +3036,7 @@ let generate jvm_flag com =
 		let jar_path = Printf.sprintf "%s%s.jar" jar_dir jar_name in
 		jar_dir,create_jar jar_path
 	end in
-	let anon_identification = new tanon_identification haxe_dynamic_object_path in
+	let anon_identification = new tanon_identification in
 	let dynamic_level = try
 		int_of_string (Define.defined_value com.defines Define.JvmDynamicLevel)
 	with _ ->

src/generators/genshared.ml

@@ -301,7 +301,7 @@ class ['a] typedef_interfaces (infos : 'a info_context) (anon_identification : '
 			try
 				let path_inner,is_extern = try Hashtbl.find interface_rewrites pfm.pfm_path with Not_found -> path_inner,false in
 				if self#implements_recursively c path_inner then raise (Unify_error [Unify_custom "already implemented"]);
-				anon_identification#unify tc pfm;
+				anon_identification#unify ~strict:false tc pfm;
 				let ci = self#make_interface_class pfm path_inner is_extern 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)); *)

src/typing/tanon_identification.ml

@@ -1,21 +1,22 @@
 open Globals
 open Type
 
-let rec replace_mono t =
-	match t with
-	| TMono t ->
-		(match t.tm_type with
-		| None -> Monomorph.bind t t_dynamic
-		| Some _ -> ())
-	| TEnum (_,p) | TInst (_,p) | TType (_,p) | TAbstract (_,p) ->
-		List.iter replace_mono p
-	| TFun (args,ret) ->
-		List.iter (fun (_,_,t) -> replace_mono t) args;
-		replace_mono ret
-	| TAnon _
-	| TDynamic _ -> ()
-	| TLazy f ->
-		replace_mono (lazy_type f)
+let replace_mono t =
+	let visited_anons = ref [] in
+	let rec loop t =
+		match t with
+		| TMono ({ tm_type = None }) ->
+			t_dynamic
+		| TAnon an ->
+			if not (List.memq an !visited_anons) then begin
+				visited_anons := an :: !visited_anons;
+				TFunctions.map loop t
+			end else
+				t
+		| _ ->
+			TFunctions.map loop t
+	in
+	loop t
 
 type 'a path_field_mapping = {
 	pfm_path : path;
@@ -39,7 +40,7 @@ let pfm_of_typedef td = match follow td.t_type with
 	| _ ->
 		die "" __LOC__
 
-class ['a] tanon_identification (empty_path : string list * string) =
+class ['a] tanon_identification =
 	let is_normal_anon an = match !(an.a_status) with
 		| Closed | Const -> true
 		| _ -> false
@@ -59,7 +60,17 @@ object(self)
 		DynArray.add (DynArray.get pfm_by_arity pfm.pfm_arity) pfm;
 		Hashtbl.replace pfms path pfm
 
-	method unify (tc : Type.t) (pfm : 'a path_field_mapping) =
+	method unify ~(strict:bool) (tc : Type.t) (pfm : 'a path_field_mapping) =
+		let uctx = if strict then {
+			allow_transitive_cast = false;
+			allow_abstract_cast = false;
+			allow_dynamic_to_cast = false;
+			allow_arg_name_mismatch = false;
+			equality_kind = EqStricter;
+			equality_underlying = false;
+			strict_field_kind = true;
+		} else {default_unification_context with equality_kind = EqDoNotFollowNull} in
+
 		let check () =
 			let pair_up fields =
 				PMap.fold (fun cf acc ->
@@ -73,7 +84,7 @@ object(self)
 					let monos = List.map (fun _ -> mk_mono()) pfm.pfm_params in
 					let map = apply_params pfm.pfm_params monos in
 					List.iter (fun (cf,cf') ->
-						if not (unify_kind cf'.cf_kind cf.cf_kind) then raise (Unify_error [Unify_custom "kind mismatch"]);
+						if not (unify_kind ~strict:uctx.strict_field_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))
 					) pairs;
 					monos
@@ -83,9 +94,10 @@ object(self)
 					let monos = List.map (fun _ -> mk_mono()) pfm.pfm_params in
 					let map = apply_params pfm.pfm_params monos in
 					List.iter (fun (cf,cf') ->
-						if not (unify_kind cf'.cf_kind cf.cf_kind) then raise (Unify_error [Unify_custom "kind mismatch"]);
+						if strict && (Meta.has Meta.Optional cf.cf_meta) != (Meta.has Meta.Optional cf'.cf_meta) then raise (Unify_error [Unify_custom "optional mismatch"]);
+						if not (unify_kind ~strict:uctx.strict_field_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))
+						type_eq_custom uctx cf'.cf_type (map (monomorphs cf.cf_params cf.cf_type))
 					) pairs;
 					if not (PMap.is_empty !fields) then raise (Unify_error [Unify_custom "not enough fields"]);
 					monos
@@ -105,17 +117,18 @@ object(self)
 		with Not_found ->
 			raise (Unify_error [])
 
-	method find_compatible (arity : int) (tc : Type.t) =
+	method find_compatible ~(strict : bool) (arity : int) (tc : Type.t) =
 		if arity >= DynArray.length pfm_by_arity then
 			raise Not_found;
 		let d = DynArray.get pfm_by_arity arity in
 		let l = DynArray.length d in
+
 		let rec loop i =
 			if i >= l then
 				raise Not_found;
 			let pfm = DynArray.unsafe_get d i in
 			try
-				self#unify tc pfm;
+				self#unify ~strict tc pfm;
 				pfm
 			with Unify_error _ ->
 				loop (i + 1)
@@ -135,7 +148,7 @@ object(self)
 		in
 		loop td.t_type
 
-	method identity_anon (an : tanon) =
+	method identify_anon ?(strict:bool = false) (an : tanon) =
 		let make_pfm path = {
 			pfm_path = path;
 			pfm_params = [];
@@ -146,19 +159,20 @@ object(self)
 		match !(an.a_status) with
 		| ClassStatics {cl_path = path} | EnumStatics {e_path = path} | AbstractStatics {a_path = path} ->
 			begin try
-				Some (Hashtbl.find pfms path)			
+				Some (Hashtbl.find pfms path)
 			with Not_found ->
 				let pfm = make_pfm path in
 				self#add_pfm path pfm;
 				Some pfm
 			end
 		| _ ->
-			let arity = PMap.fold (fun cf i ->
-				replace_mono cf.cf_type;
-				i + 1
-			) an.a_fields 0 in
-			begin try
-				Some (self#find_compatible arity (TAnon an))
+			let arity,fields = PMap.fold (fun cf (i,acc) ->
+				let t = replace_mono cf.cf_type in
+				(i + 1),(PMap.add cf.cf_name {cf with cf_type = t} acc)
+			) an.a_fields (0,PMap.empty) in
+			let an = { a_fields = fields; a_status = an.a_status; } in
+			try
+				Some (self#find_compatible ~strict arity (TAnon an))
 			with Not_found ->
 				let id = num in
 				num <- num + 1;
@@ -172,9 +186,8 @@ object(self)
 				} in
 				self#add_pfm path pfm;
 				Some pfm
-			end
 
-	method identify (accept_anons : bool) (t : Type.t) =
+	method identify ?(strict:bool = false) (accept_anons : bool) (t : Type.t) =
 		match t with
 		| TType(td,tl) ->
 			begin try
@@ -191,7 +204,7 @@ object(self)
 		| TLazy f ->
 			self#identify accept_anons (lazy_type f)
 		| TAnon an when accept_anons && not (PMap.is_empty an.a_fields) ->
-			self#identity_anon an
+			self#identify_anon ~strict an
 		| _ ->
 			None
-end
+end

src/typing/typeloadCheck.ml

@@ -394,7 +394,7 @@ module Inheritance = struct
 					in
 					if (has_class_field_flag f CfPublic) && not (has_class_field_flag f2 CfPublic) && not (Meta.has Meta.CompilerGenerated f.cf_meta) then
 						display_error ctx.com ("Field " ^ f.cf_name ^ " should be public as requested by " ^ s_type_path intf.cl_path) p
-					else if not (unify_kind f2.cf_kind f.cf_kind) || not (match f.cf_kind, f2.cf_kind with Var _ , Var _ -> true | Method m1, Method m2 -> mkind m1 = mkind m2 | _ -> false) then
+					else if not (unify_kind ~strict:false f2.cf_kind f.cf_kind) || not (match f.cf_kind, f2.cf_kind with Var _ , Var _ -> true | Method m1, Method m2 -> mkind m1 = mkind m2 | _ -> false) then
 						display_error ctx.com ("Field " ^ f.cf_name ^ " has different property access than in " ^ s_type_path intf.cl_path ^ " (" ^ s_kind f2.cf_kind ^ " should be " ^ s_kind f.cf_kind ^ ")") p
 					else try
 						let map1 = TClass.get_map_function  intf params in