let's get dangerous

src/context/typecore.ml

@@ -140,7 +140,7 @@ and typer = {
 
 and monomorphs = {
 	mutable percall : tmono list;
-	mutable perfunction : tmono list;
+	mutable perfunction : (tmono * pos) list;
 }
 
 exception Forbid_package of (string * path * pos) * pos list * string
@@ -543,7 +543,7 @@ let check_constraints map params tl p =
 let spawn_constrained_monos ctx p map params =
 	let monos = List.map (fun (s,_) ->
 		let mono = Monomorph.create() in
-		if Meta.has (Meta.Custom ":debug.monomorphs") ctx.curfield.cf_meta then Monomorph.add_constraint mono "debug" p (MDebug s);
+		(* if Meta.has (Meta.Custom ":debug.monomorphs") ctx.curfield.cf_meta then Monomorph.add_constraint mono "debug" p (MDebug s); *)
 		ctx.monomorphs.percall <- mono :: ctx.monomorphs.percall;
 		TMono mono
 	) params in
@@ -551,6 +551,14 @@ let spawn_constrained_monos ctx p map params =
 	check_constraints map params monos p;
 	monos
 
+let safe_mono_close ctx m p =
+	try
+		Monomorph.close m
+	with
+		Unify_error l ->
+			raise_or_display ctx l p;
+			false
+
 let with_contextual_monos ctx f =
 	let old_monos = ctx.monomorphs.percall in
 	ctx.monomorphs.percall <- [];

src/core/tPrinting.ml

@@ -28,6 +28,8 @@ let s_module_type_kind = function
 	| TAbstractDecl a -> "TAbstractDecl(" ^ (s_type_path a.a_path) ^ ")"
 	| TTypeDecl t -> "TTypeDecl(" ^ (s_type_path t.t_path) ^ ")"
 
+let is_simn = false
+
 let rec s_type ctx t =
 	match t with
 	| TMono r ->
@@ -35,7 +37,8 @@ let rec s_type ctx t =
 		| None ->
 			let s_const = match r.tm_constraints with
 				| [] -> ""
-				| l -> Printf.sprintf " : %s" (String.concat " & " (List.map (fun constr -> s_constraint constr.mc_kind) l))
+				| l when is_simn -> Printf.sprintf " : %s" (String.concat " & " (List.map (fun constr -> s_constraint constr.mc_kind) l))
+				| _ -> ""
 			in
 			begin try
 				let id = List.assq t (!ctx) in
@@ -117,6 +120,7 @@ and s_constraint = function
 	| MMono m -> Printf.sprintf "MMono %s" (extract_mono_name m)
 	| MField cf -> Printf.sprintf "MField %s" cf.cf_name
 	| MType t -> Printf.sprintf "MType %s" (s_type_kind t)
+	| MOpenStructure -> "MOpenStructure"
 	| MDebug _ -> "MDebug"
 
 let s_access is_read = function

src/core/tType.ml

@@ -52,6 +52,7 @@ and tmono_constraint_kind =
 	| MMono of tmono
 	| MField of tclass_field
 	| MType of t
+	| MOpenStructure
 	| MDebug of string
 
 and tmono_constraint = {

src/core/tUnification.ml

@@ -77,6 +77,17 @@ 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 check_constraints m t =
 		let fields = DynArray.create () in
 		let rec check constr = match constr.mc_kind with
@@ -91,6 +102,8 @@ module Monomorph = struct
 				DynArray.add fields cf
 			| MType t2 ->
 				check_constraint constr.mc_name (fun () -> (!unify_ref) default_unification_context t t2);
+			| MOpenStructure ->
+				()
 			| MDebug name ->
 				let s_constr = String.concat "" (List.map (fun constr -> Printf.sprintf "\n\t%s" (s_constraint constr.mc_kind)) m.tm_constraints) in
 				print_endline (Printf.sprintf "Checking constraints of %s against %s%s" name (s_type_kind t) s_constr);
@@ -110,6 +123,16 @@ module Monomorph = struct
 
 	let rec bind m t =
 		begin match t with
+		| TAnon _ | TMono _ when List.exists (fun constr -> constr.mc_kind = MOpenStructure) m.tm_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. *)
+			let fields = ExtList.List.filter_map (fun constr -> match constr.mc_kind with
+				| MField cf -> Some cf
+				| _ -> None
+			) m.tm_constraints in
+			let fields = List.fold_left (fun m cf -> PMap.add cf.cf_name cf m) PMap.empty fields in
+			let t2 = mk_anon ~fields (ref Opened) in
+			check_constraint "" (fun () -> (!unify_ref) default_unification_context t2 t);
 		| TMono m2 ->
 			begin match m2.tm_type with
 			| None ->
@@ -123,7 +146,7 @@ module Monomorph = struct
 			do_bind m t
 		end
 
-	let close m = match m.tm_type with
+	and close m = match m.tm_type with
 		| Some _ ->
 			false
 		| None ->
@@ -150,8 +173,22 @@ module Monomorph = struct
 				| [] ->
 					false
 				| fields ->
+					let check_recursion cf =
+						let rec loop t = match t with
+						| TMono m2 when m == m2 ->
+							let pctx = print_context() in
+							let s = Printf.sprintf "%s appears in { %s: %s }" (s_type pctx t) cf.cf_name (s_type pctx cf.cf_type) in
+							raise (Unify_error [Unify_custom "Recursive type";Unify_custom s]);
+						| _ ->
+							TFunctions.map loop t
+						in
+						ignore(loop cf.cf_type);
+					in
 					(* We found a bunch of fields but no type, create a merged structure type and bind to that *)
-					let fields = List.fold_left (fun m cf -> PMap.add cf.cf_name cf m) PMap.empty fields in
+					let fields = List.fold_left (fun map cf ->
+						check_recursion cf;
+						PMap.add cf.cf_name cf map
+					) PMap.empty fields in
 					do_bind m (mk_anon ~fields (ref Closed));
 					true
 				end;

src/typing/fields.ml

@@ -476,14 +476,27 @@ let rec type_field cfg ctx e i p mode =
 				field_access ctx mode f (FAnon f) (Type.field_type f) e p
 		)
 	| TMono r ->
-		let f = {
-			(mk_field i (mk_mono()) p null_pos) with
-			cf_kind = Var { v_read = AccNormal; v_write = (match mode with MSet -> AccNormal | MGet | MCall -> AccNo) };
-		} in
-		let x = ref Opened in
-		let t = mk_anon ~fields:(PMap.add i f PMap.empty) x in
-		ctx.opened <- x :: ctx.opened;
-		Monomorph.bind r t;
+		let f = match Monomorph.get_field_constraint r i with
+		| Some f ->
+			if mode = MSet then begin match f.cf_kind with
+			(* We previously inferred to read-only, but now we want to write. This can happen in cases like #8079. *)
+			| Var ({v_write = AccNo} as acc) -> f.cf_kind <- Var {acc with v_write = AccNormal}
+			| _ -> ()
+			end;
+			f
+		| None ->
+			let f = {
+				(mk_field i (mk_mono()) p null_pos) with
+				cf_kind = Var { v_read = AccNormal; v_write = (match mode with MSet -> AccNormal | MGet | MCall -> AccNo) };
+			} in
+			Monomorph.add_constraint r "FA" p (MField f);
+			if not (List.exists (fun (m,_) -> m == r) ctx.monomorphs.perfunction) && not (ctx.untyped && ctx.com.platform = Neko) then begin
+				ctx.monomorphs.perfunction <- (r,p) :: ctx.monomorphs.perfunction;
+				Monomorph.add_constraint r "FA" p MOpenStructure;
+				(* if Meta.has (Meta.Custom ":debug.monomorphs") ctx.curfield.cf_meta then Monomorph.add_constraint r "debug" p (MDebug "FA"); *)
+			end;
+			f
+		in
 		field_access ctx mode f (FAnon f) (Type.field_type f) e p
 	| TAbstract (a,pl) ->
 		let static_abstract_access_through_instance = ref false in

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 Monomorph.close m then loop top t
+					if safe_mono_close ctx m p then loop top t
 					else raise (Generic_Exception (("Could not determine type for parameter " ^ s), p))
 				| TDynamic _ -> "Dynamic"
 				| t ->

src/typing/typeload.ml

@@ -706,7 +706,11 @@ let t_iterator ctx =
 *)
 let load_type_hint ?(opt=false) ctx pcur t =
 	let t = match t with
-		| None -> mk_mono()
+		| 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)
 	in
 	if opt then ctx.t.tnull t else t

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 -> ignore(Monomorph.close m)) ctx.monomorphs.perfunction;
+	List.iter (fun (m,p) -> ignore(safe_mono_close ctx m p)) ctx.monomorphs.perfunction;
 	if is_position_debug then print_endline ("typing:\n" ^ (Texpr.dump_with_pos "" e));
 	e , fargs