From 400c79d4c944f626c1f34ddba1bff348388c5978 Mon Sep 17 00:00:00 2001
From: Simon Krajewski <simon@haxe.org>
Date: Tue, 17 Dec 2024 14:20:56 +0100
Subject: [PATCH] add @:debug.mono and clean up printing

---
 src/core/error.ml              |  7 ++--
 src/core/tPrinting.ml          | 60 +++++++++++++++++++---------------
 src/typing/typeloadFunction.ml | 30 ++++++++++++++++-
 3 files changed, 64 insertions(+), 33 deletions(-)

diff --git a/src/core/error.ml b/src/core/error.ml
index 4639e179a83..3c822d0aa0f 100644
--- a/src/core/error.ml
+++ b/src/core/error.ml
@@ -185,11 +185,8 @@ module BetterErrors = struct
 		| TMono r ->
 			(match r.tm_type with
 			| None ->
-				let name = Printf.sprintf "Unknown<%d>" (try List.assq t (!ctx) with Not_found -> let n = List.length !ctx in ctx := (t,n) :: !ctx; n) in
-				List.fold_left (fun s modi -> match modi with
-					| MNullable _ -> Printf.sprintf "Null<%s>" s
-					| MOpenStructure | MDynamic -> s
-				) name r.tm_modifiers
+				let name = Printf.sprintf "Unknown<%d>" (try List.assq r (!ctx) with Not_found -> let n = List.length !ctx in ctx := (r,n) :: !ctx; n) in
+				s_mono_modifiers name r;
 			| Some t ->
 				s_type ctx t)
 		| TEnum (e,tl) ->
diff --git a/src/core/tPrinting.ml b/src/core/tPrinting.ml
index f0bcf451889..4b1567c4142 100644
--- a/src/core/tPrinting.ml
+++ b/src/core/tPrinting.ml
@@ -39,36 +39,42 @@ let rec s_mono_constraint_kind s_type constr =
 	in
 	loop constr
 
+and s_mono_modifiers s m =
+	List.fold_left (fun s modi -> match modi with
+		| MNullable _ -> Printf.sprintf "Null<%s>" s
+		| MOpenStructure | MDynamic -> s
+	) s m.tm_modifiers
+
+and s_mono ctx m =
+	match m.tm_type with
+	| None ->
+		let print_name id extra =
+			let s = if show_mono_ids then
+				Printf.sprintf "Unknown<%d>" id
+			else
+				"Unknown"
+			in
+			let s = s ^ extra in
+			s_mono_modifiers s m
+		in
+		begin try
+			let id = List.assq m (!ctx) in
+			print_name id ""
+		with Not_found ->
+			let id = List.length !ctx in
+			ctx := (m,id) :: !ctx;
+			let s_const =
+				let s = s_mono_constraint_kind (s_type ctx) (!monomorph_classify_constraints_ref m) in
+				if s = "" then s else " : " ^ s
+			in
+			print_name id s_const
+		end
+	| Some t -> s_type ctx t
+
 and s_type ctx t =
 	match t with
 	| TMono r ->
-		(match r.tm_type with
-		| None ->
-			let print_name id extra =
-				let s = if show_mono_ids then
-					Printf.sprintf "Unknown<%d>" id
-				else
-					"Unknown"
-				in
-				let s = s ^ extra in
-				List.fold_left (fun s modi -> match modi with
-					| MNullable _ -> Printf.sprintf "Null<%s>" s
-					| MOpenStructure | MDynamic -> s
-				) s r.tm_modifiers
-			in
-			begin try
-				let id = List.assq t (!ctx) in
-				print_name id ""
-			with Not_found ->
-				let id = List.length !ctx in
-				ctx := (t,id) :: !ctx;
-				let s_const =
-					let s = s_mono_constraint_kind (s_type ctx) (!monomorph_classify_constraints_ref r) in
-					if s = "" then s else " : " ^ s
-				in
-				print_name id s_const
-			end
-		| Some t -> s_type ctx t)
+		s_mono ctx r
 	| TEnum (e,tl) ->
 		s_type_path e.e_path ^ s_type_params ctx tl
 	| TInst (c,tl) ->
diff --git a/src/typing/typeloadFunction.ml b/src/typing/typeloadFunction.ml
index ab207b394e0..17e54a04386 100644
--- a/src/typing/typeloadFunction.ml
+++ b/src/typing/typeloadFunction.ml
@@ -157,7 +157,35 @@ let type_function ctx (args : function_arguments) ret e do_display p =
 		| _ -> e
 	in
 	List.iter (fun r -> r := Closed) ctx.e.opened;
-	List.iter (fun (m,p) -> safe_mono_close ctx m p) ctx.e.monomorphs.perfunction;
+	let close () = List.iter (fun (m,p) -> safe_mono_close ctx m p) ctx.e.monomorphs.perfunction; in
+	let mono_debug = Meta.has (Meta.Custom ":debug.mono") ctx.f.curfield.cf_meta in
+	if mono_debug then begin
+		let pctx = print_context () in
+		let print_mono i m =
+			Printf.sprintf "%4i: %s" i (s_mono pctx m)
+		in
+		print_endline "BEFORE:";
+		let monos = List.mapi (fun i (m,p) ->
+			let s = print_mono i m in
+			let spos = if p.pmin = -1 then
+				"unknown"
+			else begin
+				let l1,p1,_,_ = Lexer.get_pos_coords p in
+				Printf.sprintf "%i:%i" l1 p1
+			end in
+			print_endline (Printf.sprintf "%s (%s)" s spos);
+			(i,m,p,s)
+		) ctx.e.monomorphs.perfunction in
+		close();
+		print_endline "CHANGED:";
+		List.iter (fun (i,m,p,s) ->
+			let s' = print_mono i m in
+			if s <> s' then begin
+				print_endline s'
+			end
+		) monos
+	end else
+		close();
 	if is_position_debug then print_endline ("typing:\n" ^ (Texpr.dump_with_pos "" e));
 	e