Add MNullable monomorph modifier (#11851)

* add MNullable

* move MOpenStructure to tm_modifiers too

* remove MEmptyStructure

* Revert "remove MEmptyStructure"

This reverts commit 47c1f5b.

* remove Alex' unused monomorph collection

* small cleanup

src/core/error.ml

@@ -184,8 +184,14 @@ module BetterErrors = struct
 		match t with
 		| TMono r ->
 			(match r.tm_type with
-			| None -> Printf.sprintf "Unknown<%d>" (try List.assq t (!ctx) with Not_found -> let n = List.length !ctx in ctx := (t,n) :: !ctx; n)
-			| Some t -> s_type ctx t)
+			| 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 -> s
+				) name r.tm_modifiers
+			| Some t ->
+				s_type ctx t)
 		| TEnum (e,tl) ->
 			s_type_path e.e_path ^ s_type_params ctx tl
 		| TInst (c,tl) ->

src/core/tFunctions.ml

@@ -646,9 +646,12 @@ let rec ambiguate_funs t =
 	| TFun _ -> TFun ([], t_dynamic)
 	| _ -> map ambiguate_funs t
 
+let is_nullable_mono m =
+	List.exists (function MNullable _ -> true | _ -> false) m.tm_modifiers
+
 let rec is_nullable ?(no_lazy=false) = function
 	| TMono r ->
-		(match r.tm_type with None -> false | Some t -> is_nullable ~no_lazy t)
+		(match r.tm_type with None -> is_nullable_mono r | Some t -> is_nullable ~no_lazy t)
 	| TAbstract ({ a_path = ([],"Null") },[_]) ->
 		true
 	| TLazy f ->
@@ -679,7 +682,7 @@ let rec is_nullable ?(no_lazy=false) = function
 
 let rec is_null ?(no_lazy=false) = function
 	| TMono r ->
-		(match r.tm_type with None -> false | Some t -> is_null ~no_lazy t)
+		(match r.tm_type with None -> is_nullable_mono r | Some t -> is_null ~no_lazy t)
 	| TAbstract ({ a_path = ([],"Null") },[t]) ->
 		not (is_nullable ~no_lazy (follow t))
 	| TLazy f ->
@@ -696,7 +699,7 @@ let rec is_null ?(no_lazy=false) = function
 (* Determines if we have a Null<T>. Unlike is_null, this returns true even if the wrapped type is nullable itself. *)
 let rec is_explicit_null = function
 	| TMono r ->
-		(match r.tm_type with None -> false | Some t -> is_explicit_null t)
+		(match r.tm_type with None -> is_nullable_mono r | Some t -> is_explicit_null t)
 	| TAbstract ({ a_path = ([],"Null") },[t]) ->
 		true
 	| TLazy f ->

src/core/tPrinting.ml

@@ -35,12 +35,21 @@ let rec s_type ctx t =
 	| TMono r ->
 		(match r.tm_type with
 		| None ->
-			begin try
-				let id = List.assq t (!ctx) in
-				if show_mono_ids then
+			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 -> 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;
@@ -54,10 +63,7 @@ let rec s_type ctx t =
 					let s = loop (!monomorph_classify_constraints_ref r) in
 					if s = "" then s else " : " ^ s
 				in
-				if show_mono_ids then
-					Printf.sprintf "Unknown<%d>%s" id s_const
-				else
-					Printf.sprintf "Unknown%s" s_const
+				print_name id s_const
 			end
 		| Some t -> s_type ctx t)
 	| TEnum (e,tl) ->
@@ -125,7 +131,6 @@ and s_constraint = function
 	| MMono(m,_) -> Printf.sprintf "MMono %s" (s_type_kind (TMono m))
 	| MField cf -> Printf.sprintf "MField %s" cf.cf_name
 	| MType(t,_) -> Printf.sprintf "MType %s" (s_type_kind t)
-	| MOpenStructure -> "MOpenStructure"
 	| MEmptyStructure -> "MEmptyStructure"
 
 let s_type_param s_type ttp =

src/core/tType.ml

@@ -83,13 +83,13 @@ and tmono = {
 	*)
 	mutable tm_down_constraints : tmono_constraint list;
 	mutable tm_up_constraints : (t * string option) list;
+	mutable tm_modifiers : tmono_modifier list;
 }
 
 and tmono_constraint =
 	| MMono of tmono * string option
 	| MField of tclass_field
 	| MType of t * string option
-	| MOpenStructure
 	| MEmptyStructure
 
 and tmono_constraint_kind =
@@ -98,6 +98,10 @@ and tmono_constraint_kind =
 	| CMixed of tmono_constraint_kind list
 	| CTypes of (t * string option) list
 
+and tmono_modifier =
+	| MNullable of (t -> t)
+	| MOpenStructure
+
 and tlazy =
 	| LAvailable of t
 	| LProcessing of t

src/core/tUnification.ml

@@ -93,9 +93,13 @@ module Monomorph = struct
 	let create () = {
 		tm_type = None;
 		tm_down_constraints = [];
-		tm_up_constraints = []
+		tm_up_constraints = [];
+		tm_modifiers = [];
 	}
 
+	let add_modifier m modi =
+		m.tm_modifiers <- modi :: m.tm_modifiers
+
 	(* constraining *)
 
 	let add_up_constraint m ((t,name) as constr) =
@@ -127,21 +131,18 @@ module Monomorph = struct
 
 	(* Note: This function is called by printing and others and should thus not modify state. *)
 
-	let rec classify_down_constraints' m =
+	let rec classify_down_constraints m =
 		let types = DynArray.create () in
 		let fields = ref PMap.empty in
 		let is_open = ref false in
-		let monos = ref [] in
 		let rec check constr = match constr with
 			| MMono(m2,name) ->
 				begin match m2.tm_type with
 				| None ->
-					let more_monos,kind = classify_down_constraints' m2 in
-					monos := !monos @ more_monos;
+					let kind = classify_down_constraints m2 in
 					begin match kind with
 					| CUnknown ->
-						(* Collect unconstrained monomorphs because we have to bind them. *)
-						monos := m2 :: !monos;
+						()
 					| _ ->
 						(* Recursively inherit constraints. *)
 						List.iter check m2.tm_down_constraints
@@ -153,11 +154,16 @@ module Monomorph = struct
 				fields := PMap.add cf.cf_name cf !fields;
 			| MType(t2,name) ->
 				DynArray.add types (t2,name)
-			| MOpenStructure
 			| MEmptyStructure ->
 				is_open := true
 		in
 		List.iter check m.tm_down_constraints;
+		List.iter (function
+			| MNullable _ ->
+				()
+			| MOpenStructure ->
+				is_open := true
+		) m.tm_modifiers;
 		let kind =
 			let k1 =
 				if DynArray.length types > 0 then
@@ -173,9 +179,7 @@ module Monomorph = struct
 			else
 				k1
 		in
-		!monos,kind
-
-	let classify_down_constraints m = snd (classify_down_constraints' m)
+		kind
 
 	let rec check_down_constraints constr t =
 		match constr with
@@ -225,13 +229,17 @@ module Monomorph = struct
 
 	let do_bind m t =
 		(* assert(m.tm_type = None); *) (* TODO: should be here, but matcher.ml does some weird bind handling at the moment. *)
+		let t = List.fold_left (fun t modi -> match modi with
+			| MNullable f -> f t
+			| MOpenStructure -> t
+		) t m.tm_modifiers in
 		m.tm_type <- Some t;
 		m.tm_down_constraints <- [];
 		m.tm_up_constraints <- []
 
 	let rec bind m t =
 		begin match t with
-		| TAnon _ when List.mem MOpenStructure m.tm_down_constraints ->
+		| TAnon _ when List.mem MOpenStructure m.tm_modifiers ->
 			(* 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. *)
 			constrain_to_type m None t;
@@ -272,8 +280,7 @@ module Monomorph = struct
 				with Type_exception t ->
 					Some t
 			in
-			(* TODO: we never do anything with monos, I think *)
-			let monos,constraints = classify_down_constraints' m in
+			let constraints = classify_down_constraints m in
 			match constraints with
 			| CUnknown ->
 				()

src/typing/fields.ml

@@ -386,7 +386,7 @@ let type_field cfg ctx e i p mode (with_type : WithType.t) =
 					ctx.e.monomorphs.perfunction <- (r,p) :: ctx.e.monomorphs.perfunction;
 				let f = mk_field() in
 				Monomorph.add_down_constraint r (MField f);
-				Monomorph.add_down_constraint r MOpenStructure;
+				Monomorph.add_modifier r MOpenStructure;
 				field_access f FHAnon
 			| CMixed l ->
 				let rec loop_constraints l =

src/typing/nullSafety.ml

@@ -72,7 +72,7 @@ let is_string_type t =
 *)
 let rec is_nullable_type ?(dynamic_is_nullable=false) = function
 	| TMono r ->
-		(match r.tm_type with None -> false | Some t -> is_nullable_type t)
+		(match r.tm_type with None -> is_nullable_mono r | Some t -> is_nullable_type t)
 	| TAbstract ({ a_path = ([],"Null") },[t]) ->
 		true
 	| TAbstract ({ a_path = ([],"Any") },[]) ->

src/typing/typer.ml

@@ -399,9 +399,7 @@ let rec type_ident_raise ctx i p mode with_type =
 				| WithType.WithType(t,_) ->
 					begin match follow t with
 					| TMono r when not (is_nullable t) ->
-						(* If our expected type is a monomorph, bind it to Null<?>. The is_nullable check is here because
-							the expected type could already be Null<?>, in which case we don't want to double-wrap (issue #11286). *)
-						Monomorph.do_bind r (tnull())
+						Monomorph.add_modifier r (MNullable ctx.t.tnull)
 					| _ ->
 						(* Otherwise there's no need to create a monomorph, we can just type the null literal
 						the way we expect it. *)

tests/misc/projects/Issue11624/compile-bar-fail.hxml.stderr

@@ -1,5 +1,5 @@
 MainBar.hx:6: characters 18-21 : Field bar has different type than in Foo
 MainBar.hx:2: characters 11-14 : ... Interface field is defined here
 MainBar.hx:6: characters 18-21 : ... error: Null<Unknown<0>> should be bar.T
-MainBar.hx:6: characters 18-21 : ... have: (...) -> Null<...>
+MainBar.hx:6: characters 18-21 : ... have: (...) -> Null<Unknown<0>>
 MainBar.hx:6: characters 18-21 : ... want: (...) -> bar.T

tests/misc/projects/Issue11624/compile-foo-fail.hxml.stderr

@@ -1,5 +1,5 @@
 MainFoo.hx:6: characters 18-21 : Field foo has different type than in Foo
 MainFoo.hx:2: characters 11-14 : ... Interface field is defined here
 MainFoo.hx:6: characters 18-21 : ... error: Null<Unknown<0>> should be foo.T
-MainFoo.hx:6: characters 18-21 : ... have: (...) -> Null<...>
+MainFoo.hx:6: characters 18-21 : ... have: (...) -> Null<Unknown<0>>
 MainFoo.hx:6: characters 18-21 : ... want: (...) -> foo.T

tests/misc/projects/Issue11753/Main.hx

@@ -0,0 +1,31 @@
+class Main {
+	static var doThings : Foo -> Void;
+
+	static function main() {
+		var foo = new Foo();
+		doThings = (foo -> doThingsImpl(foo));
+		doThings(foo);
+	}
+
+	static function doThingsImpl(foo) {
+		foo.doWithBar();
+		$type(foo);
+		$type(foo.doWithBar);
+
+		if (foo != null) trace(foo);
+		$type(foo);
+		$type(foo.doWithBar);
+	}
+}
+
+class Foo {
+	public function new() {}
+	public function doWithBar(?bar:Bar) {
+		trace(bar);
+	}
+}
+
+@:keep
+class Bar {
+	public function new() {}
+}

tests/misc/projects/Issue11753/Main2.hx

@@ -0,0 +1,28 @@
+class Foo {
+	public function new() {}
+
+	public function test() {}
+
+	public function doWithBar(?bar:Bar) {
+		trace(bar);
+	}
+}
+
+@:keep
+class Bar {
+	public function new() {}
+}
+
+function doThingsImpl(foo) {
+	$type(foo); // Unknown<0>
+	foo.doWithBar();
+	$type(foo); // Unknown<0> : { doWithBar : () -> Unknown<1> }
+	$type(foo.doWithBar); // () -> Unknown<0>
+	if (foo != null)
+		trace(foo);
+	$type(foo); // Null<{ doWithBar : () -> Unknown<0> }>
+	$type(foo.doWithBar); // () -> Unknown<0>
+	foo.test(); // Null<{ doWithBar : () -> Unknown<0> }> has no field test
+}
+
+function main() {}

tests/misc/projects/Issue11753/compile-fail.hxml

@@ -0,0 +1,4 @@
+-main Main
+--hl bin/main.hl
+-D message.reporting=pretty
+-D message.no-color

tests/misc/projects/Issue11753/compile-fail.hxml.stderr

@@ -0,0 +1,32 @@
+[WARNING] Main.hx:12: characters 9-12
+
+ 12 |   $type(foo);
+    |         ^^^
+    | Unknown<0> : { doWithBar : () -> Unknown<1> }
+
+[WARNING] Main.hx:13: characters 9-22
+
+ 13 |   $type(foo.doWithBar);
+    |         ^^^^^^^^^^^^^
+    | () -> Unknown<0>
+
+[WARNING] Main.hx:16: characters 9-12
+
+ 16 |   $type(foo);
+    |         ^^^
+    | Null<Unknown<0> : { doWithBar : () -> Unknown<1> }>
+
+[WARNING] Main.hx:17: characters 9-22
+
+ 17 |   $type(foo.doWithBar);
+    |         ^^^^^^^^^^^^^
+    | () -> Unknown<0>
+
+[ERROR] Main.hx:6: characters 35-38
+
+  6 |   doThings = (foo -> doThingsImpl(foo));
+    |                                   ^^^
+    | error: (?bar : Null<Bar>) -> Void should be () -> Unknown<0>
+    | have: { doWithBar: (?...) -> ... }
+    | want: { doWithBar: () -> ... }
+

tests/misc/projects/Issue11753/compile.hxml

@@ -0,0 +1,4 @@
+-main Main2
+--hl bin/main.hl
+-D message.reporting=pretty
+-D message.no-color

tests/misc/projects/Issue11753/compile.hxml.stderr

@@ -0,0 +1,29 @@
+[WARNING] Main2.hx:17: characters 8-11
+
+ 17 |  $type(foo); // Unknown<0>
+    |        ^^^
+    | Unknown<0>
+
+[WARNING] Main2.hx:19: characters 8-11
+
+ 19 |  $type(foo); // Unknown<0> : { doWithBar : () -> Unknown<1> }
+    |        ^^^
+    | Unknown<0> : { doWithBar : () -> Unknown<1> }
+
+[WARNING] Main2.hx:20: characters 8-21
+
+ 20 |  $type(foo.doWithBar); // () -> Unknown<0>
+    |        ^^^^^^^^^^^^^
+    | () -> Unknown<0>
+
+[WARNING] Main2.hx:23: characters 8-11
+
+ 23 |  $type(foo); // Null<{ doWithBar : () -> Unknown<0> }>
+    |        ^^^
+    | Null<Unknown<0> : { doWithBar : () -> Unknown<1> }>
+
+[WARNING] Main2.hx:24: characters 8-21
+
+ 24 |  $type(foo.doWithBar); // () -> Unknown<0>
+    |        ^^^^^^^^^^^^^
+    | () -> Unknown<0>