Use FieldAccess for constructors too (#9756)

* [typer] start porting constructors to FieldAccess

* [typer] use FieldAccess for all constructor handling

* [typer] remove concrete types from `get_constructor`

* [typer] clean up a bit

src/codegen/codegen.ml

@@ -487,8 +487,6 @@ let default_cast ?(vtmp="$t") com e texpr t p =
 	mk (TBlock [var;check;vexpr]) t p
 
 module UnificationCallback = struct
-	let tf_stack = new_rec_stack()
-
 	let check_call_params f el tl =
 		let rec loop acc el tl = match el,tl with
 			| e :: el, (n,_,t) :: tl ->
@@ -507,66 +505,6 @@ module UnificationCallback = struct
 			check_call_params f el args
 		| _ ->
 			List.map (fun e -> f e t_dynamic) el
-
-	let rec run ff e =
-		let f e t =
-			if not (type_iseq e.etype t) then
-				ff e t
-			else
-				e
-		in
-		let check e = match e.eexpr with
-			| TBinop((OpAssign | OpAssignOp _),e1,e2) ->
-				die "" __LOC__; (* this trigger #4347, to be fixed before enabling
-				let e2 = f e2 e1.etype in
-				{e with eexpr = TBinop(op,e1,e2)} *)
-			| TVar(v,Some ev) ->
-				let eo = Some (f ev v.v_type) in
-				{ e with eexpr = TVar(v,eo) }
-			| TCall(e1,el) ->
-				let el = check_call f el e1.etype in
-				{e with eexpr = TCall(e1,el)}
-			| TNew(c,tl,el) ->
-				begin try
-					let tcf,_ = get_constructor (fun cf -> apply_params c.cl_params tl cf.cf_type) c in
-					let el = check_call f el tcf in
-					{e with eexpr = TNew(c,tl,el)}
-				with Not_found ->
-					e
-				end
-			| TArrayDecl el ->
-				begin match follow e.etype with
-					| TInst({cl_path=[],"Array"},[t]) -> {e with eexpr = TArrayDecl(List.map (fun e -> f e t) el)}
-					| _ -> e
-				end
-			| TObjectDecl fl ->
-				begin match follow e.etype with
-					| TAnon an ->
-						let fl = List.map (fun ((n,p,qs),e) ->
-							let e = try
-								let t = (PMap.find n an.a_fields).cf_type in
-								f e t
-							with Not_found ->
-								e
-							in
-							(n,p,qs),e
-						) fl in
-						{ e with eexpr = TObjectDecl fl }
-					| _ -> e
-				end
-			| TReturn (Some e1) ->
-				begin match tf_stack.rec_stack with
-					| tf :: _ -> { e with eexpr = TReturn (Some (f e1 tf.tf_type))}
-					| _ -> e
-				end
-			| _ ->
-				e
-		in
-		match e.eexpr with
-			| TFunction tf ->
-				rec_stack_loop tf_stack tf (fun() -> {e with eexpr = TFunction({tf with tf_expr = run f tf.tf_expr})}) ()
-			| _ ->
-				check (Type.map_expr (run ff) e)
 end;;
 
 let interpolate_code com code tl f_string f_expr p =

src/core/display/completionItem.ml

@@ -188,7 +188,7 @@ module CompletionModuleType = struct
 		let ctor c =
 			try
 				if has_class_flag c CAbstract then raise Not_found;
-				let _,cf = get_constructor (fun cf -> cf.cf_type) c in
+				let cf = get_constructor c in
 				if (has_class_flag c CExtern) || (has_class_field_flag cf CfPublic) then Yes else YesButPrivate
 			with Not_found ->
 				No

src/core/tFunctions.ml

@@ -737,17 +737,15 @@ let quick_field_dynamic t s =
 	try quick_field t s
 	with Not_found -> FDynamic s
 
-let rec get_constructor build_type c =
+let rec get_constructor c =
 	match c.cl_constructor, c.cl_super with
-	| Some c, _ -> build_type c, c
+	| Some c, _ -> c
 	| None, None -> raise Not_found
-	| None, Some (csup,cparams) ->
-		let t, c = get_constructor build_type csup in
-		apply_params csup.cl_params cparams t, c
+	| None, Some (csup,_) -> get_constructor csup
 
 let has_constructor c =
 	try
-		ignore(get_constructor (fun cf -> cf.cf_type) c);
+		ignore(get_constructor c);
 		true
 	with Not_found -> false
 

src/generators/genjvm.ml

@@ -1881,8 +1881,8 @@ class texpr_to_jvm gctx (jc : JvmClass.builder) (jm : JvmMethod.builder) (return
 				[jf#get_jsig]
 			)
 		| TNew(c,tl,el) ->
-			begin match get_constructor (fun cf -> cf.cf_type) c with
-			|_,cf ->
+			begin match get_constructor c with
+			| cf ->
 				begin match OverloadResolution.maybe_resolve_instance_overload true (apply_params c.cl_params tl) c cf el with
 				| None -> Error.error "Could not find overload" e.epos
 				| Some (c',cf,_) ->

src/generators/genpy.ml

@@ -1717,11 +1717,9 @@ module Generator = struct
 	(* Transformer interface *)
 
 	let transform_expr e =
-		(* let e = Codegen.UnificationCallback.run Transformer.check_unification e in *)
 		Transformer.transform e
 
 	let transform_to_value e =
-		(* let e = Codegen.UnificationCallback.run Transformer.check_unification e in *)
 		Transformer.transform_to_value e
 
 	(* Printer interface *)

src/typing/fields.ml

@@ -74,16 +74,6 @@ let field_type ctx c pl f p =
 let no_abstract_constructor c p =
 	if has_class_flag c CAbstract then raise_error (Abstract_class (TClassDecl c)) p
 
-let get_constructor ctx c params p =
-	match c.cl_kind with
-	| KAbstractImpl a ->
-		let f = (try PMap.find "_new" c.cl_statics with Not_found -> raise_error (No_constructor (TAbstractDecl a)) p) in
-		let ct = field_type ctx c params f p in
-		apply_params a.a_params params ct, f
-	| _ ->
-		let ct, f = (try Type.get_constructor (fun f -> field_type ctx c params f p) c with Not_found -> raise_error (No_constructor (TClassDecl c)) p) in
-		apply_params c.cl_params params ct, f
-
 let check_constructor_access ctx c f p =
 	if (Meta.has Meta.CompilerGenerated f.cf_meta) then display_error ctx (error_msg (No_constructor (TClassDecl c))) p;
 	if not (can_access ctx c f true || extends ctx.curclass c) && not ctx.untyped then display_error ctx (Printf.sprintf "Cannot access private constructor of %s" (s_class_path c)) p

src/typing/nullSafety.ml

@@ -1391,19 +1391,20 @@ class expr_checker mode immediate_execution report =
 				| TNew (cls, params, args) ->
 					let ctor =
 						try
-							Some (get_constructor (fun ctor -> apply_params cls.cl_params params ctor.cf_type) cls)
+							Some (get_constructor cls)
 						with
 							| Not_found -> None
 					in
 					(match ctor with
 						| None ->
 							List.iter self#check_expr args
-						| Some (ctor_type, _) ->
+						| Some cf ->
 							let rec traverse t =
 								match follow t with
 									| TFun (types, _) -> self#check_args e_new args types
 									| _ -> fail ~msg:"Unexpected constructor type." e_new.epos __POS__
 							in
+							let ctor_type = apply_params cls.cl_params params cf.cf_type in
 							traverse ctor_type
 					)
 				| _ -> fail ~msg:"TNew expected" e_new.epos __POS__

src/typing/typeloadFunction.ml

@@ -176,7 +176,7 @@ let type_function ctx args fargs ret fmode e do_display p =
 			None
 		| Some (csup,tl) ->
 			try
-				let _,cf = get_constructor (fun f->f.cf_type) csup in
+				let cf = get_constructor csup in
 				Some (Meta.has Meta.CompilerGenerated cf.cf_meta,TInst(csup,tl))
 			with Not_found ->
 				None
@@ -246,7 +246,7 @@ let add_constructor ctx c force_constructor p =
 			Some(cfsup,csup,cparams)
 		| Some (csup,cparams) ->
 			try
-				let _,cfsup = Type.get_constructor (fun ctor -> apply_params csup.cl_params cparams ctor.cf_type) csup in
+				let cfsup = Type.get_constructor csup in
 				Some(cfsup,csup,cparams)
 			with Not_found ->
 				None

src/typing/typer.ml

@@ -558,19 +558,18 @@ and type_access ctx e p mode with_type =
 				| MGet -> ()
 				end;
 				let monos = Monomorph.spawn_constrained_monos (fun t -> t) (match c.cl_kind with KAbstractImpl a -> a.a_params | _ -> c.cl_params) in
-				let ct, cf = get_constructor ctx c monos p in
+				let fa = FieldAccess.get_constructor_access c monos p in
+				let cf = fa.fa_field in
 				no_abstract_constructor c p;
 				check_constructor_access ctx c cf p;
-				let args = match follow ct with TFun(args,ret) -> args | _ -> die "" __LOC__ in
+				let args = match follow (FieldAccess.get_map_function fa cf.cf_type) with TFun(args,ret) -> args | _ -> die "" __LOC__ in
 				let vl = List.map (fun (n,_,t) -> alloc_var VGenerated n t c.cl_pos) args in
 				let vexpr v = mk (TLocal v) v.v_type p in
 				let el = List.map vexpr vl in
 				let ec,t = match c.cl_kind with
 					| KAbstractImpl a ->
-						let e = type_module_type ctx (TClassDecl c) None p in
-						let e = mk (TField (e,(FStatic (c,cf)))) ct p in
 						let t = TAbstract(a,monos) in
-						make_call ctx e el t p,t
+						(new call_dispatcher ctx (MCall []) WithType.value p)#field_call fa el [],t
 					| _ ->
 						let t = TInst(c,monos) in
 						mk (TNew(c,monos,el)) t p,t
@@ -858,8 +857,9 @@ and type_object_decl ctx fl with_type p =
 		let t, fl = type_fields a.a_fields in
 		mk (TObjectDecl fl) t p
 	| ODKWithClass (c,tl) ->
-		let t,ctor = get_constructor ctx c tl p in
-		let args = match follow t with
+		let fa = FieldAccess.get_constructor_access c tl p in
+		let ctor = fa.fa_field in
+		let args = match follow (FieldAccess.get_map_function fa ctor.cf_type) with
 			| TFun(args,_) -> args
 			| _ -> die "" __LOC__
 		in
@@ -925,13 +925,12 @@ and type_new ctx path el with_type force_inline p =
 		end
 	in
 	let unify_constructor_call c fa =
-		(try
-			let fcc = unify_field_call ctx fa [] el p false in
+		try
+			let fcc = unify_field_call ctx fa [] el p fa.fa_inline in
 			check_constructor_access ctx c fcc.fc_field p;
-			List.map fst fcc.fc_args
+			fcc
 		with Error (e,p) ->
-			display_error ctx (error_msg e) p;
-			[])
+			error (error_msg e) p;
 	in
 	let t = if (fst path).tparams <> [] then begin
 		try
@@ -956,9 +955,8 @@ and type_new ctx path el with_type force_inline p =
 		begin match resolve_typedef (Typeload.load_type_def ctx p (fst path)) with
 		| TClassDecl ({cl_constructor = Some cf} as c) ->
 			let monos = Monomorph.spawn_constrained_monos (fun t -> t) c.cl_params in
-			let ct, f = get_constructor ctx c monos p in
+			let fa = FieldAccess.get_constructor_access c monos p in
 			no_abstract_constructor c p;
-			let fa = FieldAccess.create (Builder.make_static_this c p) f (FHInstance(c,monos)) false p in
 			ignore (unify_constructor_call c fa);
 			begin try
 				Generic.build_generic ctx c p monos
@@ -984,18 +982,15 @@ and type_new ctx path el with_type force_inline p =
 	DisplayEmitter.check_display_type ctx t path;
 	let t = follow t in
 	let build_constructor_call ao c tl =
-		let ct, f = get_constructor ctx c tl p in
+		let fa = FieldAccess.get_constructor_access c tl p in
+		let fa = if force_inline then {fa with fa_inline = true} else fa in
+		let cf = fa.fa_field in
 		no_abstract_constructor c p;
-		(match f.cf_kind with
-		| Var { v_read = AccRequire (r,msg) } -> (match msg with Some msg -> error msg p | None -> error_require r p)
-		| _ -> ());
-		let fa = match ao with
-			| None -> FHInstance(c,tl)
-			| Some a -> FHAbstract(a,tl,c)
-		in
-		let fa = FieldAccess.create (Builder.make_static_this c p) f fa false p in
-		let el = unify_constructor_call c fa in
-		el,f,ct
+		begin match cf.cf_kind with
+			| Var { v_read = AccRequire (r,msg) } -> (match msg with Some msg -> error msg p | None -> error_require r p)
+			| _ -> ()
+		end;
+		unify_constructor_call c fa
 	in
 	try begin match t with
 	| TInst ({cl_kind = KTypeParameter tl} as c,params) ->
@@ -1008,13 +1003,11 @@ and type_new ctx path el with_type force_inline p =
 			mk (TNew (c,params,el)) t p
 		end
 	| TAbstract({a_impl = Some c} as a,tl) when not (Meta.has Meta.MultiType a.a_meta) ->
-		let el,cf,ct = build_constructor_call (Some a) c tl in
-		let ta = mk_anon ~fields:c.cl_statics (ref (Statics c)) in
-		let e = mk (TTypeExpr (TClassDecl c)) ta p in
-		let e = mk (TField (e,(FStatic (c,cf)))) ct p in
-		make_call ctx e el t ~force_inline p
+		let fcc = build_constructor_call (Some a) c tl in
+		fcc.fc_data ();
 	| TInst (c,params) | TAbstract({a_impl = Some c},params) ->
-		let el,_,_ = build_constructor_call None c params in
+		let fcc = build_constructor_call None c params in
+		let el = List.map fst fcc.fc_args in
 		mk (TNew (c,params,el)) t p
 	| _ ->
 		error (s_type (print_context()) t ^ " cannot be constructed") p
@@ -1640,11 +1633,12 @@ and type_call ?(mode=MGet) ctx e el (with_type:WithType.t) inline p =
 		let el, t = (match ctx.curclass.cl_super with
 		| None -> error "Current class does not have a super" p
 		| Some (c,params) ->
-			let ct, f = get_constructor ctx c params p in
+			let fa = FieldAccess.get_constructor_access c params p in
+			let cf = fa.fa_field in
 			let t = TInst (c,params) in
 			let e = mk (TConst TSuper) t sp in
-			if (Meta.has Meta.CompilerGenerated f.cf_meta) then display_error ctx (error_msg (No_constructor (TClassDecl c))) p;
-			let fa = FieldAccess.create e f (FHInstance(c,params)) false p in
+			if (Meta.has Meta.CompilerGenerated cf.cf_meta) then display_error ctx (error_msg (No_constructor (TClassDecl c))) p;
+			let fa = FieldAccess.create e cf (FHInstance(c,params)) false p in
 			let fcc = unify_field_call ctx fa [] el p false in
 			let el = List.map fst fcc.fc_args in
 			el,t

src/typing/typerBase.ml

@@ -395,6 +395,15 @@ module FieldAccess = struct
 			end
 		| _ ->
 			AccessorInvalid
+
+	let get_constructor_access c params p =
+		match c.cl_kind with
+		| KAbstractImpl a ->
+			let cf = (try PMap.find "_new" c.cl_statics with Not_found -> raise_error (No_constructor (TAbstractDecl a)) p) in
+			create (Builder.make_static_this c p) cf (FHAbstract(a,params,c)) false p
+		| _ ->
+			let cf = (try Type.get_constructor c with Not_found -> raise_error (No_constructor (TClassDecl c)) p) in
+			create (Builder.make_static_this c p) cf (FHInstance(c,params)) false p
 end
 
 let make_static_extension_access c cf e_this inline p =

src/typing/typerDisplay.ml

@@ -17,6 +17,7 @@ open TyperBase
 open Fields
 open Calls
 open Error
+open FieldAccess
 
 let convert_function_signature ctx values (args,ret) = match CompletionType.from_type (get_import_status ctx) ~values (TFun(args,ret)) with
 	| CompletionType.CTFunction ctf -> ((args,ret),ctf)
@@ -99,7 +100,7 @@ let completion_item_of_expr ctx e =
 				| TAnon an -> make_ci_anon an (tpair e.etype)
 				| _ -> itexpr e
 			end
-		| TNew(c,tl,_) ->
+		| TNew(c,tl,el) ->
 			Display.merge_core_doc ctx (TClassDecl c);
 			(* begin match fst e_ast with
 			| EConst (Regexp (r,opt)) ->
@@ -119,10 +120,12 @@ let completion_item_of_expr ctx e =
 				let absent = match absent with [] -> [] | _ -> "\n\nInactive flags:\n\n" :: absent in
 				(TInst(c,tl)),Some ("Regular expression\n\n" ^ (String.concat "\n" (present @ absent)))
 			| _ -> *)
-				let t,cf = get_constructor ctx c tl e.epos in
-				let t = match follow t with
+				let fa = get_constructor_access c tl e.epos in
+				let fcc = unify_field_call ctx fa el [] e.epos false in
+				let cf = fcc.fc_field in
+				let t = match follow (FieldAccess.get_map_function fa cf.cf_type) with
 					| TFun(args,_) -> TFun(args,TInst(c,tl))
-					| _ -> t
+					| t -> t
 				in
 				make_ci_class_field (CompletionClassField.make cf CFSConstructor (Self (decl_of_class c)) true) (tpair ~values:(get_value_meta cf.cf_meta) t)
 			(* end *)
@@ -218,9 +221,15 @@ let rec handle_signature_display ctx e_ast with_type =
 			[loop tl,None,PMap.empty]
 		| TInst (c,tl) | TAbstract({a_impl = Some c},tl) ->
 			Display.merge_core_doc ctx (TClassDecl c);
-			let ct,cf = get_constructor ctx c tl p in
-			let tl = (ct,cf.cf_doc,get_value_meta cf.cf_meta) :: List.rev_map (fun cf' -> cf'.cf_type,cf.cf_doc,get_value_meta cf'.cf_meta) cf.cf_overloads in
-			tl
+			let fa = get_constructor_access c tl p in
+			let is_wacky_overload = not (has_class_field_flag fa.fa_field CfOverload) in
+			let map = FieldAccess.get_map_function fa in
+			let map_cf cf =
+				(* Ghetto overloads have their documentation on the main field. *)
+				let doc = if is_wacky_overload then fa.fa_field.cf_doc else cf.cf_doc in
+				map cf.cf_type,doc,get_value_meta cf.cf_meta
+			in
+			List.map map_cf (fa.fa_field :: fa.fa_field.cf_overloads)
 		| _ ->
 			[]
 	in
@@ -295,8 +304,8 @@ and display_expr ctx e_ast e dk with_type p =
 	let get_super_constructor () = match ctx.curclass.cl_super with
 		| None -> error "Current class does not have a super" p
 		| Some (c,params) ->
-			let _, f = get_constructor ctx c params p in
-			f,c
+			let fa = get_constructor_access c params p in
+			fa.fa_field,c
 	in
 	match ctx.com.display.dms_kind with
 	| DMResolve _ | DMPackage ->
@@ -321,7 +330,8 @@ and display_expr ctx e_ast e dk with_type p =
 			Display.ReferencePosition.set (snd ti.mt_path,ti.mt_name_pos,symbol_of_module_type mt);
 		| TNew(c,tl,_) ->
 			begin try
-				let _,cf = get_constructor ctx c tl p in
+				let fa = get_constructor_access c tl p in
+				let cf = fa.fa_field in
 				Display.ReferencePosition.set (snd c.cl_path,cf.cf_name_pos,SKConstructor cf);
 			with Not_found ->
 				()
@@ -368,7 +378,8 @@ and display_expr ctx e_ast e dk with_type p =
 		| TTypeExpr mt -> [(t_infos mt).mt_name_pos]
 		| TNew(c,tl,_) ->
 			begin try
-				let _,cf = get_constructor ctx c tl p in
+				let fa = get_constructor_access c tl p in
+				let cf = fa.fa_field in
 				if Meta.has Meta.CoreApi c.cl_meta then begin
 					let c' = ctx.g.do_load_core_class ctx c in
 					begin match c'.cl_constructor with

tests/misc/projects/Issue4775/compile1-fail.hxml.stderr

@@ -1,4 +1,3 @@
 Main1.hx:7: characters 15-26 : Constraint check failure for Contain.T
 Main1.hx:7: characters 15-26 : ... Main1 should be String
-Main1.hx:7: characters 15-26 : ... For function argument 't'
-Main1.hx:7: characters 3-27 : Could not determine type for parameter T
+Main1.hx:7: characters 15-26 : ... For function argument 't'