clean up monomorph printing once more

src/core/error.ml

@@ -183,12 +183,7 @@ module BetterErrors = struct
 	let rec s_type ctx t =
 		match t with
 		| TMono r ->
-			(match r.tm_type with
-			| None ->
-				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)
+			MonomorphPrinting.s_mono s_type ctx false r
 		| TEnum (e,tl) ->
 			s_type_path e.e_path ^ s_type_params ctx tl
 		| TInst (c,tl) ->

src/core/tPrinting.ml

@@ -28,81 +28,58 @@ 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 show_mono_ids = true
-
-let rec s_mono_constraint_kind s_type constr =
-	let rec loop = function
-		| CUnknown -> ""
-		| CTypes tl -> String.concat " & " (List.map (fun (t,_) -> s_type t) tl)
-		| CStructural(fields,_) -> s_type (mk_anon ~fields (ref Closed))
-		| CMixed l -> String.concat " & " (List.map loop l)
-	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
+module MonomorphPrinting = struct
+	let show_mono_ids = true
 
-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
+	let s_mono_constraint_kind s_type constr =
+		let rec loop = function
+			| CUnknown -> ""
+			| CTypes tl -> String.concat " & " (List.map (fun (t,_) -> s_type t) tl)
+			| CStructural(fields,_) -> s_type (mk_anon ~fields (ref Closed))
+			| CMixed l -> String.concat " & " (List.map loop l)
 		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
+		loop constr
 
-(* TODO: refactor these two functions... *)
-and s_mono_explicit ctx m =
-	let print_name id extra =
+	let print_mono_name m 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;
+		List.fold_left (fun s modi -> match modi with
+			| MNullable _ -> Printf.sprintf "Null<%s>" s
+			| MOpenStructure | MDynamic -> s
+		) s m.tm_modifiers
+
+	let s_mono s_type ctx explicit m =
 		match m.tm_type with
-		| None ->
-			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
-		| Some t ->
-			print_name id (" := " ^ (s_type ctx) t)
-	end
+		| Some t when not explicit ->
+			s_type ctx t
+		| _ ->
+			begin try
+				let id = List.assq m (!ctx) in
+				print_mono_name m id ""
+			with Not_found ->
+				let id = List.length !ctx in
+				ctx := (m,id) :: !ctx;
+				match m.tm_type with
+				| Some t when explicit ->
+					print_mono_name m id (" := " ^ (s_type ctx) t)
+				| _ ->
+					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_mono_name m id s_const
+			end
+end
 
-and s_type ctx t =
+let rec s_type ctx t =
 	match t with
 	| TMono r ->
-		s_mono ctx r
+		MonomorphPrinting.s_mono s_type ctx false r
 	| TEnum (e,tl) ->
 		s_type_path e.e_path ^ s_type_params ctx tl
 	| TInst (c,tl) ->

src/typing/typeloadFunction.ml

@@ -161,7 +161,7 @@ let type_function ctx (args : function_arguments) ret e do_display p =
 	if mono_debug then begin
 		let pctx = print_context () in
 		let print_mono i m =
-			Printf.sprintf "%4i: %s" i (s_mono_explicit pctx m)
+			Printf.sprintf "%4i: %s" i (MonomorphPrinting.s_mono s_type pctx true m)
 		in
 		print_endline "BEFORE:";
 		let monos = List.mapi (fun i (m,p) ->