MacroApi cleanup for Haxe 5 (#11433)

* [macro] add pos and posPath to TypePath

see #11431

* minor cleanup

* [eval] embrace laziness

* remove context flushing from encoder

This should no longer be necessary. I'm adding the relevant tests to make sure.

* adjust test

* slightly change custom JS generator integration

src/macro/eval/evalContext.ml

@@ -406,10 +406,6 @@ let exc_string_p str p = throw (vstring (EvalString.create_ascii str)) p
 
 let error_message = exc_string
 
-let flush_core_context f =
-	let ctx = get_ctx() in
-	ctx.curapi.MacroApi.flush_context f
-
 (* Environment handling *)
 
 let no_timer = fun () -> ()

src/macro/eval/evalDebugSocket.ml

@@ -83,7 +83,7 @@ let var_to_json name value vio env =
 		| VInstance vi -> (rev_hash vi.iproto.ppath) ^ " {...}"
 		| VPrototype proto -> (s_proto_kind proto).sstring
 		| VFunction _ | VFieldClosure _ -> "<fun>"
-		| VLazy f -> level2_value_repr (!f())
+		| VLazy f -> level2_value_repr (Lazy.force f)
 		| VNativeString s -> string_repr s
 		| VHandle _ -> "<handle>"
 	in
@@ -148,7 +148,7 @@ let var_to_json name value vio env =
 			let fields = proto_fields proto in
 			jv "Anonymous" (s_proto_kind proto).sstring (List.length fields)
 		| VFunction _ | VFieldClosure _ -> jv "Function" "<fun>" 0
-		| VLazy f -> value_string (!f())
+		| VLazy f -> value_string (Lazy.force f)
 		| VNativeString s ->
 			jv "NativeString" (string_repr s) 0
 		| VHandle _ -> jv "Handle" "<handle>" 0
@@ -331,7 +331,7 @@ let output_inner_vars v env =
 				let n = rev_hash n in
 				n, v
 			) fields
-		| VLazy f -> loop (!f())
+		| VLazy f -> loop (Lazy.force f)
 	in
 	let children = loop v in
 	let vars = List.map (fun (n,v) -> var_to_json n v None env) children in
@@ -458,7 +458,7 @@ module ValueCompletion = struct
 				let fields = prototype_static_fields proto in
 				IntMap.fold (fun _ v acc -> v :: acc) fields []
 			| VLazy f ->
-				loop (!f())
+				loop (Lazy.force f)
 			| VEnumValue ve ->
 				begin match (get_static_prototype_raise (get_ctx()) ve.epath).pkind with
 					| PEnum names ->

src/macro/eval/evalEncode.ml

@@ -316,12 +316,7 @@ let encode_ref v convert tostr =
 		ikind = IRef (Obj.repr v);
 	}
 
-let encode_lazy f =
-	let rec r = ref (fun () ->
-		let v = f() in
-		r := (fun () -> v);
-		v
-	) in
+let encode_lazy r =
 	VLazy r
 
 let encode_option encode_value o =

src/macro/eval/evalMain.ml

@@ -361,7 +361,7 @@ let value_signature v =
 		| VHandle _ ->
 			custom_name 'H'
 		| VLazy f ->
-			loop (!f())
+			loop (Lazy.force f)
 	and loop_fields fields =
 		List.iter (fun (name,v) ->
 			adds (rev_hash name);

src/macro/eval/evalMisc.ml

@@ -155,9 +155,9 @@ let rec compare a b =
 		if f1 != f2 then CUndef
 		else compare v1 v2
 	| VLazy f1,_ ->
-		compare (!f1()) b
+		compare (Lazy.force f1) b
 	| _,VLazy f2 ->
-		compare a (!f2())
+		compare a (Lazy.force f2)
 	| _ -> CUndef
 
 let rec arrays_equal cmp a1 a2 =
@@ -184,8 +184,8 @@ and equals_structurally a b =
 	| VObject a,VObject b -> a == b || arrays_equal equals_structurally a.ofields b.ofields
 	| VEnumValue a,VEnumValue b -> a == b || a.eindex = b.eindex && arrays_equal equals_structurally a.eargs b.eargs && a.epath = b.epath
 	| VPrototype proto1,VPrototype proto2 -> proto1.ppath = proto2.ppath
-	| VLazy f1,_ -> equals_structurally (!f1()) b
-	| _,VLazy f2 -> equals_structurally a (!f2())
+	| VLazy f1,_ -> equals_structurally (Lazy.force f1) b
+	| _,VLazy f2 -> equals_structurally a (Lazy.force f2)
 	| _ -> a == b
 
 let is_true v = match v with

src/macro/eval/evalPrinting.ml

@@ -164,7 +164,7 @@ and s_value ?(indent_level=0) depth v =
 	| VInstance {ikind=IRegex r} -> r.r_rex_string
 	| VInstance i -> (try call_to_string () with Not_found -> s_hash i.iproto.ppath)
 	| VObject o -> (try call_to_string () with Not_found -> s_object (depth + 1) indent_level o)
-	| VLazy f -> s_value ~indent_level depth (!f())
+	| VLazy f -> s_value ~indent_level depth (Lazy.force f)
 	| VPrototype proto ->
 		try
 			call_to_string()

src/macro/eval/evalStdLib.ml

@@ -3011,7 +3011,7 @@ module StdType = struct
 			| VEnumValue ve ->
 				7,[|get_static_prototype_as_value ctx ve.epath null_pos|]
 			| VLazy f ->
-				loop (!f())
+				loop (Lazy.force f)
 			| VInt64 _ | VUInt64 _ | VNativeString _ | VHandle _ -> 8,[||]
 		in
 		let i,vl = loop v in

src/macro/eval/evalValue.ml

@@ -141,7 +141,7 @@ type value =
 	| VPrototype of vprototype
 	| VFunction of vfunc * bool
 	| VFieldClosure of value * vfunc
-	| VLazy of (unit -> value) ref
+	| VLazy of value Lazy.t
 	| VNativeString of string
 	| VHandle of vhandle
 	| VInt64 of Signed.Int64.t
@@ -323,8 +323,8 @@ let rec equals a b = match a,b with
 	| VFieldClosure(v1,f1),VFieldClosure(v2,f2) -> f1 == f2 && equals v1 v2
 	| VNativeString s1,VNativeString s2 -> s1 = s2
 	| VHandle h1,VHandle h2 -> same_handle h1 h2
-	| VLazy f1,_ -> equals (!f1()) b
-	| _,VLazy f2 -> equals a (!f2())
+	| VLazy f1,_ -> equals (Lazy.force f1) b
+	| _,VLazy f2 -> equals a (Lazy.force f2)
 	| _ -> a == b
 
 module ValueHashtbl = Hashtbl.Make(struct
@@ -354,5 +354,5 @@ let vnative_string s = VNativeString s
 let s_expr_pretty e = (Type.s_expr_pretty false "" false (Type.s_type (Type.print_context())) e)
 
 let rec vresolve v = match v with
-	| VLazy f -> vresolve (!f())
+	| VLazy f -> vresolve (Lazy.force f)
 	| _ -> v

src/macro/macroApi.ml

@@ -39,7 +39,6 @@ type 'value compiler_api = {
 	resolve_complex_type : Ast.type_hint -> Ast.type_hint;
 	store_typed_expr : Type.texpr -> Ast.expr;
 	allow_package : string -> unit;
-	set_js_generator : (Genjs.ctx -> unit) -> unit;
 	get_local_type : unit -> t option;
 	get_expected_type : unit -> t option;
 	get_call_arguments : unit -> Ast.expr list option;
@@ -62,7 +61,6 @@ type 'value compiler_api = {
 	encode_expr : Ast.expr -> 'value;
 	encode_ctype : Ast.type_hint -> 'value;
 	decode_type : 'value -> t;
-	flush_context : (unit -> t) -> t;
 	info : ?depth:int -> string -> pos -> unit;
 	warning : ?depth:int -> Warning.warning -> string -> pos -> unit;
 	display_error : ?depth:int -> (string -> pos -> unit);
@@ -123,7 +121,7 @@ module type InterpApi = sig
 	val encode_array : value list -> value
 	val encode_string  : string -> value
 	val encode_obj : (string * value) list -> value
-	val encode_lazy : (unit -> value) -> value
+	val encode_lazy : value Lazy.t -> value
 
 	val vfun0 : (unit -> value) -> value
 	val vfun1 : (value -> value) -> value
@@ -171,8 +169,6 @@ module type InterpApi = sig
 
 	val value_string : value -> string
 
-	val flush_core_context : (unit -> t) -> t
-
 	val handle_decoding_error : (string -> unit) -> value -> Type.t -> (string * int) list
 
 	val get_api_call_pos : unit -> pos
@@ -413,7 +409,7 @@ and encode_display_kind dk =
 	| DKMarked -> 3, []
 	| DKPattern outermost -> 4, [vbool outermost]
 	in
-	encode_enum ~pos:None IDisplayKind tag pl
+	encode_enum IDisplayKind tag pl
 
 and encode_display_mode dm =
 	let tag, pl = match dm with
@@ -429,7 +425,7 @@ and encode_display_mode dm =
 		| DMModuleSymbols (Some s) -> 9, [(encode_string s)]
 		| DMSignature -> 10, []
 	in
-	encode_enum ~pos:None IDisplayMode tag pl
+	encode_enum IDisplayMode tag pl
 
 and encode_platform p =
 	let tag, pl = match p with
@@ -446,7 +442,7 @@ and encode_platform p =
 		| Eval -> 10, []
 		| CustomTarget s -> 11, [(encode_string s)]
 	in
-	encode_enum ~pos:None IPlatform tag pl
+	encode_enum IPlatform tag pl
 
 and encode_platform_config pc =
 	encode_obj [
@@ -474,7 +470,7 @@ and encode_capture_policy cp =
 		| CPWrapRef -> 1
 		| CPLoopVars -> 2
 	in
-	encode_enum ~pos:None ICapturePolicy tag []
+	encode_enum ICapturePolicy tag []
 
 and encode_var_scoping_config vsc =
 	encode_obj [
@@ -487,7 +483,7 @@ and encode_var_scope vs =
 		| FunctionScope -> 0
 		| BlockScope -> 1
 	in
-	encode_enum ~pos:None IVarScope tag []
+	encode_enum IVarScope tag []
 
 and encode_var_scoping_flags vsf =
 	let tag, pl = match vsf with
@@ -500,7 +496,7 @@ and encode_var_scoping_flags vsf =
 		| ReserveNames (names) -> 6, [encode_array (List.map encode_string names)]
 		| SwitchCasesNoBlocks -> 7, []
 	in
-	encode_enum ~pos:None IVarScopingFlags tag pl
+	encode_enum IVarScopingFlags tag pl
 
 and encode_exceptions_config ec =
 	encode_obj [
@@ -517,15 +513,15 @@ and encode_package_rule pr =
 		| Forbidden -> 0, []
 		| Remap (path) -> 2, [encode_string path]
 	in
-	encode_enum ~pos:None IPackageRule tag pl
+	encode_enum IPackageRule tag pl
 
 and encode_message cm =
 	let tag, pl = match cm.cm_severity with
 		| Globals.MessageSeverity.Information -> 0, [(encode_string cm.cm_message); (encode_pos cm.cm_pos)]
 		| Warning | Hint -> 1, [(encode_string cm.cm_message); (encode_pos cm.cm_pos)]
 		| Error -> Globals.die "" __LOC__
 	in
-	encode_enum ~pos:None IMessage tag pl
+	encode_enum IMessage tag pl
 
 and encode_efield_kind efk =
 	let i = match efk with
@@ -631,7 +627,7 @@ and encode_expr e =
 			"expr", encode_enum IExpr tag pl;
 		]
 	in
-	encode_lazy (fun () -> loop e)
+	encode_lazy (lazy (loop e))
 
 and encode_null_expr e =
 	match e with
@@ -756,7 +752,7 @@ let rec decode_ast_path t =
 	let p_full = field t "pos" in
 	let p_full = if p_full = vnull then Globals.null_pos else decode_pos p_full in
 	let p_path = field t "posPath" in
-	let p_path = if p_path = vnull then Globals.null_pos else decode_pos p_path in
+	let p_path = if p_path = vnull then p_full else decode_pos p_path in
 	make_ptp (mk_type_path ~params ?sub (pack,name)) ~p_path p_full
 
 and decode_tparam v =
@@ -1097,7 +1093,7 @@ and encode_cfield f =
 		"params", encode_type_params f.cf_params;
 		"meta", encode_meta f.cf_meta (fun m -> f.cf_meta <- m);
 		"expr", vfun0 (fun() ->
-			ignore (flush_core_context (fun() -> follow f.cf_type));
+			ignore (follow f.cf_type);
 			(match f.cf_expr with None -> vnull | Some e -> encode_texpr e)
 		);
 		"kind", encode_field_kind f.cf_kind;
@@ -1264,8 +1260,7 @@ and encode_lazy_type t =
 					| LAvailable t ->
 						encode_type t
 					| LWait _ ->
-						(* we are doing some typing here, let's flush our context if it's not already *)
-						encode_type (flush_core_context (fun() -> lazy_type f))
+						encode_type (lazy_type f)
 					| LProcessing _ ->
 						(* our type in on the processing stack, error instead of returning most likely an unbound mono *)
 						error_message "Accessing a type while it's being typed");
@@ -2012,8 +2007,7 @@ let macro_api ccom get_api =
 		);
 		"set_custom_js_generator", vfun1 (fun f ->
 			let f = prepare_callback f 1 in
-			(get_api()).set_js_generator (fun js_ctx ->
-				let com = Common.to_gctx (ccom()) in
+			let gen com js_ctx =
 				Genjs.setup_kwds com;
 				let api = encode_obj [
 					"outputFile", encode_string com.file;
@@ -2060,6 +2054,12 @@ let macro_api ccom get_api =
 					);
 				] in
 				ignore(f [api]);
+			in
+			let com = ccom() in
+			com.js_gen <- Some (fun() ->
+				Path.mkdir_from_path com.file;
+				let js_ctx = Genjs.alloc_ctx (Common.to_gctx com) (Gctx.get_es_version com.defines) in
+				gen (Common.to_gctx com) js_ctx;
 			);
 			vnull
 		);

src/syntax/reification.ml

@@ -123,15 +123,20 @@ let reify in_macro =
 					("name", (efield(ei,"name"),p));
 					("sub", (efield(ei,"sub"),p));
 					("params", ea);
+					("pos", to_pos p);
+					("posPath", to_pos ptp.pos_path);
 				] in
 				to_obj fields p
 		end else begin
 			let fields = [
 				("pack", to_array to_string t.tpackage p);
 				("name", to_string t.tname p);
 				("params", to_array to_tparam t.tparams p);
+				("pos", to_pos p);
+				("posPath", to_pos ptp.pos_path);
 			] in
-			to_obj (match t.tsub with None -> fields | Some s -> fields @ ["sub",to_string s p]) p
+			let fields = match t.tsub with None -> fields | Some s -> fields @ ["sub",to_string s p] in
+			to_obj fields p
 		end
 	and to_ctype t p =
 		let ct n vl = mk_enum "ComplexType" n vl p in

src/typing/macroContext.ml

@@ -199,23 +199,11 @@ let make_macro_com_api com mcom p =
 		type_expr = (fun e ->
 			Interp.exc_string "unsupported"
 		);
-		flush_context = (fun f ->
-			Interp.exc_string "unsupported"
-		);
 		store_typed_expr = (fun te ->
 			let p = te.epos in
 			snd (Typecore.store_typed_expr com te p)
 		);
 		allow_package = (fun v -> Common.allow_package com v);
-		set_js_generator = (fun gen ->
-			com.js_gen <- Some (fun() ->
-				Path.mkdir_from_path com.file;
-				let js_ctx = Genjs.alloc_ctx (Common.to_gctx com) (Gctx.get_es_version com.defines) in
-				let t = macro_timer com ["jsGenerator"] in
-				gen js_ctx;
-				t()
-			);
-		);
 		get_local_type = (fun() ->
 			Interp.exc_string "unsupported"
 		);
@@ -416,9 +404,6 @@ let make_macro_api ctx mctx p =
 		MacroApi.type_expr = (fun e ->
 			typing_timer ctx true (fun ctx -> type_expr ctx e WithType.value)
 		);
-		MacroApi.flush_context = (fun f ->
-			typing_timer ctx true (fun _ -> f ())
-		);
 		MacroApi.get_local_type = (fun() ->
 			match ctx.c.get_build_infos() with
 			| Some (mt,tl,_) ->

src/typing/typeload.ml

@@ -402,7 +402,7 @@ and load_instance' ctx ptp get_params mode =
 		if t.tparams <> [] then raise_typing_error ("Class type parameter " ^ t.tname ^ " can't have parameters") ptp.pos_full;
 		pt
 	with Not_found ->
-		let mt = load_type_def ctx (if ptp.pos_path == null_pos then ptp.pos_full else ptp.pos_path) t in
+		let mt = load_type_def ctx ptp.pos_path t in
 		let info = ctx.g.get_build_info ctx mt ptp.pos_full in
 		if info.build_path = ([],"Dynamic") then match t.tparams with
 			| [] -> t_dynamic

std/haxe/macro/Expr.hx

@@ -670,6 +670,16 @@ typedef TypePath = {
 		`pack.Module.Type` has `name = "Module"`, `sub = "Type"`, if available.
 	**/
 	var ?sub:String;
+
+	/**
+		The full position of the type path, including type parameters.
+	**/
+	var ?pos:Position;
+
+	/**
+		The position of the dot-path itself, without type parameters.
+	**/
+	var ?posPath:Position;
 }
 
 /**

tests/misc/projects/Issue11431/Main.hx

@@ -0,0 +1,10 @@
+import haxe.macro.Expr;
+
+macro function makeCt() {
+	var ct = macro :NotExists<String>;
+	return macro(e : $ct);
+}
+
+function main() {
+	makeCt();
+}