haxe.PosInfos rework

src-json/meta.json

@@ -487,6 +487,13 @@
 		"platforms": ["python"],
 		"targets": ["TClass"]
 	},
+	{
+		"name": "ImplicitArgResolver",
+		"metadata": ":implicitArgResolver",
+		"doc": "Marks an abstract whose values auto-fill an omitted optional argument of that type. The named static function (macro or not) resolves the value at each call site.",
+		"params": ["Resolver function name"],
+		"targets": ["TAbstract"]
+	},
 	{
 		"name": "ImplicitCast",
 		"metadata": ":implicitCast",
@@ -864,6 +871,12 @@
 		"targets": ["TExpr"],
 		"links": ["https://haxe.org/manual/macro-reification.html"]
 	},
+	{
+		"name": "PosInfos",
+		"metadata": ":posInfos",
+		"doc": "Explicitly designates a call argument as the value for an implicit `haxe.PosInfos` parameter, overriding the auto-filled position.",
+		"targets": ["TExpr"]
+	},
 	{
 		"name": "Public",
 		"metadata": ":public",

src/context/abstractCast.ml

@@ -153,7 +153,7 @@ let find_array_read_access_raise ctx a pl e1 p =
 		| cf :: cfl ->
 			let map,check_constraints,get_ta = prepare_array_access_field ctx a pl cf p in
 			match follow (map cf.cf_type) with
-			| TFun((_,_,tab) :: (_,_,ta1) :: args,r) as tf when is_empty_or_pos_infos args ->
+			| TFun((_,_,tab) :: (_,_,ta1) :: args,r) as tf when has_only_implicit_args args ->
 				begin try
 					Type.unify tab (get_ta());
 					let e1 = cast_or_unify_raise ctx ta1 e1 p in
@@ -173,7 +173,7 @@ let find_array_write_access_raise ctx a pl e1 e2  p =
 		| cf :: cfl ->
 			let map,check_constraints,get_ta = prepare_array_access_field ctx a pl cf p in
 			match follow (map cf.cf_type) with
-			| TFun((_,_,tab) :: (_,_,ta1) :: (_,_,ta2) :: args,r) as tf when is_empty_or_pos_infos args ->
+			| TFun((_,_,tab) :: (_,_,ta1) :: (_,_,ta2) :: args,r) as tf when has_only_implicit_args args ->
 				begin try
 					Type.unify tab (get_ta());
 					let e1 = cast_or_unify_raise ctx ta1 e1 p in

src/context/typecore.ml

@@ -759,11 +759,18 @@ let rec is_pos_infos = function
 	| _ ->
 		false
 
-let is_empty_or_pos_infos args =
-	match args with
-	| [_,true,t] -> is_pos_infos t
-	| [] -> true
-	| _ -> false
+let is_implicit_arg (_,opt,t) = opt && is_pos_infos t
+
+let split_implicit_trailing_args args =
+	let rec loop implicit = function
+		| x :: rest when is_implicit_arg x -> loop (x :: implicit) rest
+		| rest -> (List.rev rest, implicit)
+	in
+	loop [] (List.rev args)
+
+let strip_implicit_trailing_args args = fst (split_implicit_trailing_args args)
+
+let has_only_implicit_args args = strip_implicit_trailing_args args = []
 
 let get_next_stored_typed_expr_id =
 	let uid = ref 0 in

src/generators/cpp/gen/cppGenClassImplementation.ml

@@ -318,6 +318,27 @@ let generate_native_class base_ctx tcpp_class =
 
   cpp_file#close
 
+let implicit_accessor_arg_count class_def accessor_name base_arity =
+  let field =
+    try Some (PMap.find accessor_name class_def.cl_fields)
+    with Not_found ->
+      (try Some (PMap.find accessor_name class_def.cl_statics) with Not_found -> None)
+  in
+  match field with
+  | Some cf ->
+    (match follow cf.cf_type with
+    | TFun (args, _) -> max 0 (List.length args - base_arity)
+    | _ -> 0)
+  | None -> 0
+
+let implicit_getter_args class_def field =
+  let n = implicit_accessor_arg_count class_def ("get_" ^ field.cf_name) 0 in
+  String.concat ", " (List.init n (fun _ -> "null()"))
+
+let implicit_setter_args class_def field =
+  let n = implicit_accessor_arg_count class_def ("set_" ^ field.cf_name) 1 in
+  String.concat "" (List.init n (fun _ -> ", null()"))
+
 let generate_managed_class base_ctx tcpp_class =
   let common_ctx = base_ctx.ctx_common in
   let class_def = tcpp_class.tcl_class in
@@ -638,7 +659,7 @@ let generate_managed_class base_ctx tcpp_class =
 
       if var.tcv_has_getter then
         let prop_check = checkPropCall var.tcv_field in
-        let getter     = Printf.sprintf "get_%s()" var.tcv_field.cf_name |> get_wrapper var.tcv_field in
+        let getter     = Printf.sprintf "get_%s(%s)" var.tcv_field.cf_name (implicit_getter_args class_def var.tcv_field) |> get_wrapper var.tcv_field in
 
         (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, get_printer prop_check getter variable) :: acc
       else
@@ -660,7 +681,7 @@ let generate_managed_class base_ctx tcpp_class =
   let print_property printer var acc =
     if var.tcv_has_getter && var.tcv_is_reflective && not (is_abstract_impl class_def) then (
       let prop_check = checkPropCall var.tcv_field in
-      let getter     = Printf.sprintf "get_%s()" var.tcv_field.cf_name |> get_wrapper var.tcv_field in
+      let getter     = Printf.sprintf "get_%s(%s)" var.tcv_field.cf_name (implicit_getter_args class_def var.tcv_field) |> get_wrapper var.tcv_field in
       (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, printer prop_check getter) :: acc)
     else
       acc
@@ -726,7 +747,7 @@ let generate_managed_class base_ctx tcpp_class =
         | Var { v_write = AccCall | AccPrivateCall } ->
           let prop_call = checkPropCall var.tcv_field in
           let setter    = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in
-          let call      = Printf.sprintf "if (%s) { return ::hx::Val( %s(inValue.Cast< %s >()) ); } else { %s }" prop_call setter casted default in
+          let call      = Printf.sprintf "if (%s) { return ::hx::Val( %s(inValue.Cast< %s >()%s) ); } else { %s }" prop_call setter casted (implicit_setter_args class_def var.tcv_field) default in
 
           (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, call) :: acc
         | Var { v_write = AccNormal | AccNo | AccNever } ->
@@ -745,7 +766,7 @@ let generate_managed_class base_ctx tcpp_class =
         | Var { v_write = AccCall | AccPrivateCall } ->
           let prop_call = checkPropCall var.tcv_field in
           let setter    = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in
-          let call      = Printf.sprintf "if (%s) { return ::hx::Val( %s(inValue.Cast< %s >()) ); }" prop_call setter casted in
+          let call      = Printf.sprintf "if (%s) { return ::hx::Val( %s(inValue.Cast< %s >()%s) ); }" prop_call setter casted (implicit_setter_args class_def var.tcv_field) in
 
           (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, call) :: acc
         | _ ->
@@ -772,7 +793,7 @@ let generate_managed_class base_ctx tcpp_class =
         | Var { v_write = AccCall | AccPrivateCall } ->
           let prop_call = checkPropCall var.tcv_field in
           let setter    = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in
-          let call      = Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()); } else { %s = ioValue.Cast< %s >(); } return true;" prop_call setter casted var.tcv_name casted in
+          let call      = Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()%s); } else { %s = ioValue.Cast< %s >(); } return true;" prop_call setter casted (implicit_setter_args class_def var.tcv_field) var.tcv_name casted in
 
           (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, call) :: acc
         | Var { v_write = AccNormal | AccNo } ->
@@ -791,7 +812,7 @@ let generate_managed_class base_ctx tcpp_class =
           let setter    = Printf.sprintf "set_%s" var.tcv_field.cf_name |> get_wrapper var.tcv_field in
           let casted    = castable var in
 
-          (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()); }" prop_call setter casted) :: acc
+          (var.tcv_field.cf_name, String.length var.tcv_field.cf_name, Printf.sprintf "if (%s) { ioValue = %s(ioValue.Cast< %s >()%s); }" prop_call setter casted (implicit_setter_args class_def var.tcv_field)) :: acc
         | _ ->
           acc
       else

src/typing/callUnification.ml

@@ -7,6 +7,11 @@ open Error
 open FieldAccess
 open FieldCallCandidate
 
+let implicit_resolver_stack = new_rec_stack()
+
+let mk_implicit_resolver_value_ref : (typer -> tclass -> tclass_field -> t list -> t -> pos -> texpr) ref =
+	ref (fun _ _ _ _ _ _ -> assert false)
+
 let unify_call_args ctx el args r callp ?(call_field_p=callp) inline force_inline in_overload =
 	let call_error err p = raise_error_msg (Call_error err) p in
 
@@ -19,23 +24,6 @@ let unify_call_args ctx el args r callp ?(call_field_p=callp) inline force_inlin
 		raise_error { e with err_message = (Call_error (Could_not_unify e.err_message)) }
 	in
 
-	let mk_pos_infos t =
-		mk_infos_t ctx callp [] t
-	in
-	let default_value name t =
-		if is_pos_infos t then
-			mk_pos_infos t
-		else
-			null (ctx.t.tnull t) callp
-	in
-	let skipped = ref [] in
-	let invalid_skips = ref [] in
-	let skip name ul t =
-		if not ctx.com.config.pf_can_skip_non_nullable_argument && not (is_nullable t) then
-			invalid_skips := name :: !invalid_skips;
-		skipped := (name,ul) :: !skipped;
-		default_value name t
-	in
 	let handle_errors fn =
 		try
 			fn()
@@ -49,13 +37,67 @@ let unify_call_args ctx el args r callp ?(call_field_p=callp) inline force_inlin
 			!cast_or_unify_raise_ref ctx t e e.epos
 		)
 	in
+	let pos_override = ref None in
+	let el = List.filter (fun e -> match e with
+		| (EMeta((Meta.PosInfos,_,p),e1),_) ->
+			(match !pos_override with
+			| Some _ -> raise_typing_error "Multiple @:posInfos arguments are not allowed" p
+			| None -> pos_override := Some e1);
+			false
+		| _ ->
+			true
+	) el in
+	let pos_override_used = ref false in
+	let implicit_resolver t =
+		match follow t with
+		| TAbstract(a,pl) when Meta.has Meta.ImplicitArgResolver a.a_meta ->
+			(match Meta.get Meta.ImplicitArgResolver a.a_meta, a.a_impl with
+			| (_,[(EConst(Ident name),_)],_), Some c ->
+				(try Some(a,c,pl,PMap.find name c.cl_statics) with Not_found -> None)
+			| _ -> None)
+		| _ ->
+			None
+	in
+	let is_implicit_value t = is_pos_infos t || implicit_resolver t <> None in
+	let mk_implicit_value t =
+		match !pos_override with
+		| Some e when is_pos_infos t ->
+			pos_override_used := true;
+			(try type_against "pos" t e
+			with WithTypeError err -> arg_error err "pos" true)
+		| _ ->
+			match implicit_resolver t with
+			| Some(a,c,pl,cf) ->
+				if rec_stack_memq c implicit_resolver_stack then
+					raise_typing_error ("Cyclic @:implicitArgResolver for " ^ s_type_path a.a_path) callp;
+				rec_stack_loop implicit_resolver_stack c
+					(fun () -> !mk_implicit_resolver_value_ref ctx c cf pl t callp) ()
+			| None ->
+				mk_infos_t ctx callp [] t
+	in
+	let default_value name t =
+		if is_implicit_value t then
+			mk_implicit_value t
+		else
+			null (ctx.t.tnull t) callp
+	in
+	let skipped = ref [] in
+	let invalid_skips = ref [] in
+	let skip name ul t =
+		if not ctx.com.config.pf_can_skip_non_nullable_argument && not (is_nullable t) then
+			invalid_skips := name :: !invalid_skips;
+		skipped := (name,ul) :: !skipped;
+		default_value name t
+	in
 	let rec loop el args = match el,args with
 		| [],[] ->
 			begin match List.rev !invalid_skips with
 				| [] -> ()
 				| name :: _ -> call_error (Cannot_skip_non_nullable name) callp;
 			end;
 			[]
+		| _,(_,true,t) :: ((_,false,tr) :: _ as args) when is_pos_infos t && ExtType.is_rest (follow tr) ->
+			mk_implicit_value t :: loop el args
 		| _,[name,false,TAbstract({ a_path = ["cpp"],"Rest" },[t])] ->
 			(try List.map (fun e -> type_against name t e) el
 			with WithTypeError e -> arg_error e name false)
@@ -134,7 +176,7 @@ let unify_call_args ctx el args r callp ?(call_field_p=callp) inline force_inlin
 				[]
 			end else begin match loop [] args with
 				| [] when not (inline && (ctx.com.doinline || force_inline)) && not ctx.com.config.pf_pad_nulls ->
-					if is_pos_infos t then [mk_pos_infos t]
+					if is_implicit_value t then [mk_implicit_value t]
 					else []
 				| args ->
 					let e_def = default_value name t in
@@ -151,7 +193,6 @@ let unify_call_args ctx el args r callp ?(call_field_p=callp) inline force_inlin
 				| (s,ul) :: _ -> arg_error ul s true
 			end
 		| e :: el,(name,opt,t) :: args ->
-			let might_skip = List.length el < List.length args in
 			let body_capture = reset_call_arg_body_capture ctx in
 			let restore_monos = monomorph_transaction ctx in
 			let committed = ref false in
@@ -162,22 +203,28 @@ let unify_call_args ctx el args r callp ?(call_field_p=callp) inline force_inlin
 					let e = type_against name t e in
 					commit ();
 					e :: loop el args
-				with
-					| WithTypeError ul when opt && might_skip ->
-							drop ();
-							restore_monos();
-							let e_def = skip name ul t in
-							e_def :: loop (e :: el) args
-					| WithTypeError _ when !body_capture <> [] && (match follow t with TFun _ -> false | _ -> true) ->
-							commit ();
-							restore_monos();
-							let e_def = default_value name t in
-							e_def :: loop el args
-					| WithTypeError ul ->
-							commit ();
-							match List.rev !skipped with
-							| [] -> arg_error ul name opt
-							| (s,ul) :: _ -> arg_error ul s true
+				with WithTypeError ul ->
+					let might_skip = opt && List.length el < List.length args in
+					let opt_followed_by_rest = opt && match args with
+						| [(_,_,t)] -> ExtType.is_rest (follow t)
+						| _ -> false
+					in
+					if might_skip || opt_followed_by_rest then begin
+						drop ();
+						restore_monos();
+						let e_def = skip name ul t in
+						e_def :: loop (e :: el) args
+					end else if !body_capture <> [] && (match follow t with TFun _ -> false | _ -> true) then begin
+						commit ();
+						restore_monos();
+						let e_def = default_value name t in
+						e_def :: loop el args
+					end else begin
+						commit ();
+						match List.rev !skipped with
+						| [] -> arg_error ul name opt
+						| (s,ul) :: _ -> arg_error ul s true
+					end
 				end
 			with exc ->
 				commit ();
@@ -187,6 +234,10 @@ let unify_call_args ctx el args r callp ?(call_field_p=callp) inline force_inlin
 	let restore = enter_call_args ctx ~in_overload in
 	let el = try loop el args with exc -> restore(); raise exc; in
 	restore();
+	(match !pos_override with
+	| Some e when not !pos_override_used ->
+		raise_typing_error "@:posInfos argument has no matching haxe.PosInfos parameter" (snd e)
+	| _ -> ());
 	el
 
 type overload_kind =
@@ -728,3 +779,18 @@ let make_static_call_better ctx c cf tl el t p =
 	let fa = FieldAccess.create e1 cf fh false p in
 	let fcc = unify_field_call ctx fa el [] p false in
 	fcc.fc_data()
+
+let () = mk_implicit_resolver_value_ref := (fun ctx c cf tl t p ->
+	if cf.cf_kind = Method MethMacro then
+		let _ = ctx.e.with_type_stack <- (WithType.with_type t) :: ctx.e.with_type_stack in
+		let r = ctx.g.do_macro ctx MExpr c.cl_path cf.cf_name [] p in
+		ctx.e.with_type_stack <- List.tl ctx.e.with_type_stack;
+		match r with
+		| MSuccess e ->
+			let e = type_expr ctx e (WithType.with_type t) in
+			!cast_or_unify_raise_ref ctx t e p
+		| _ ->
+			type_expr ctx (EConst (Ident "null"),p) WithType.value
+	else
+		make_static_call_better ctx c cf tl [] t p
+)