added haxe.macro.Error (allow better compiler errors handling in macros)

interp.ml

@@ -115,6 +115,7 @@ type context = {
 	prototypes : (string list, vobject) Hashtbl.t;
 	fields_cache : (int,string) Hashtbl.t;
 	mutable error : bool;
+	mutable error_proto : vobject;
 	mutable enums : (value * string) array array;
 	mutable do_call : value -> value -> value list -> pos -> value;
 	mutable do_string : value -> string;
@@ -197,21 +198,6 @@ let pop_ret ctx f n =
 let push ctx v =
 	DynArray.add ctx.stack v
 
-let catch_errors ctx ?(final=(fun() -> ())) f =
-	let n = DynArray.length ctx.stack in
-	try
-		let v = f() in
-		final();
-		Some v
-	with Runtime v ->
-		pop ctx (DynArray.length ctx.stack - n);
-		final();
-		raise (Error (ctx.do_string v,List.map (fun s -> make_pos s.cpos) ctx.callstack))
-	| Abort ->
-		pop ctx (DynArray.length ctx.stack - n);
-		final();
-		None
-
 let hash f =
 	let h = ref 0 in
 	for i = 0 to String.length f - 1 do
@@ -388,6 +374,33 @@ let rec get_field_opt o fid =
 	in
 	loop 0 (Array.length o.ofields)
 
+let catch_errors ctx ?(final=(fun() -> ())) f =
+	let n = DynArray.length ctx.stack in
+	try
+		let v = f() in
+		final();
+		Some v
+	with Runtime v ->
+		pop ctx (DynArray.length ctx.stack - n);
+		final();
+		let rec loop o =
+			if o == ctx.error_proto then true else match o.oproto with None -> false | Some p -> loop p
+		in
+		(match v with
+		| VObject o when loop o ->
+			(match get_field o (hash "message"), get_field o (hash "pos") with
+			| VObject msg, VAbstract (APos pos) ->
+				(match get_field msg h_s with
+				| VString msg -> raise (Typecore.Error (Typecore.Custom msg,pos))
+				| _ -> ());
+			| _ -> ());
+		| _ -> ());
+		raise (Error (ctx.do_string v,List.map (fun s -> make_pos s.cpos) ctx.callstack))
+	| Abort ->
+		pop ctx (DynArray.length ctx.stack - n);
+		final();
+		None
+
 let make_library fl =
 	let h = Hashtbl.create 0 in
 	List.iter (fun (n,f) -> Hashtbl.add h n f) fl;
@@ -2705,6 +2718,7 @@ let create com api =
 		gen = Genneko.new_context com true;
 		types = Hashtbl.create 0;
 		error = false;
+		error_proto = { ofields = [||]; oproto = None };
 		prototypes = Hashtbl.create 0;
 		enums = [||];
 		(* eval *)
@@ -2835,7 +2849,8 @@ let init ctx =
 			| _ -> assert false)
 		| _ -> failwith ("haxe.macro." ^ enum_name e ^ " does not exists")
 	in
-	ctx.enums <- Array.of_list (List.map get_enum_proto enums)
+	ctx.enums <- Array.of_list (List.map get_enum_proto enums);
+	ctx.error_proto <- (match get_path ctx ["haxe";"macro";"Error";"prototype"] null_pos with VObject p -> p | _ -> failwith ("haxe.macro.Error does not exists"))
 
 open Ast
 
@@ -2850,7 +2865,7 @@ let enc_inst path fields =
 	let ctx = get_ctx() in
 	let p = (try Hashtbl.find ctx.prototypes path with Not_found -> try
 		(match get_path ctx (path@["prototype"]) Nast.null_pos with
-		| VObject o -> o
+		| VObject o -> Hashtbl.add ctx.prototypes path o; o
 		| _ -> raise (Runtime VNull))
 	with Runtime _ ->
 		failwith ("Prototype not found " ^ String.concat "." path)
@@ -2891,6 +2906,9 @@ let enc_enum (i:enum_index) index pl =
 			"args", VArray (Array.of_list pl);
 		]
 
+let compiler_error msg pos =
+	exc (enc_inst ["haxe";"macro";"Error"] [("message",enc_string msg);("pos",encode_pos pos)])
+
 let encode_const c =
 	let tag, pl = match c with
 	| Int s -> 0, [enc_string s]

std/haxe/macro/Context.hx

@@ -32,7 +32,7 @@ class Context {
 
 #if neko
 	/**
-		Display a compilation error at the given position in code
+		Display a compilation error at the given position in code and abort the current macro call
 	**/
 	public static function error( msg : String, pos : Position ) : Dynamic {
 		return load("error",2)(untyped msg.__s, pos);

std/haxe/macro/Expr.hx

@@ -176,3 +176,14 @@ enum FieldType {
 	FProp( get : String, set : String, t : ComplexType );
 }
 
+/**
+	This error can be used to handle or produce compilation errors in macros.
+**/
+class Error {
+	public var message : String;
+	public var pos : Expr.Position;
+	public function new(m,p) {
+		this.message = m;
+		this.pos = p;
+	}
+}

std/haxe/web/Dispatch.hx

@@ -290,7 +290,7 @@ class Dispatch {
 
 	static function makeConfig( obj : Expr ) {
 		var p = obj.pos;
-		var t = try Context.typeof(obj) catch( e : Dynamic ) return { expr : EObjectDecl([ { field : "obj", expr : obj }, { field : "rules", expr : { expr : EConst(CIdent("null")), pos : p } } ]), pos : p };
+		var t = Context.typeof(obj);
 		switch( Context.follow(t) ) {
 		case TAnonymous(fl):
 			var fields = [];

typer.ml

@@ -457,7 +457,7 @@ let using_field ctx mode e i p =
 
 let get_this ctx p =
 	match ctx.curfun with
-	| FStatic -> 
+	| FStatic ->
 		error "Cannot access this from a static function" p
 	| FMemberLocal ->
 		if ctx.untyped then display_error ctx "Cannot access this in 'untyped' mode : use either '__this__' or var 'me = this' (transitional)" p;
@@ -467,7 +467,7 @@ let get_this ctx p =
 				ctx.vthis <- Some v;
 				v
 			| Some v -> v
-		) in		
+		) in
 		mk (TLocal v) ctx.tthis p
 	| FConstructor | FMember ->
 		mk (TConst TThis) ctx.tthis p
@@ -2006,12 +2006,12 @@ let parse_string ctx s p =
 	Lexer.init p.pfile;
 	let _, decls = try
 		Parser.parse ctx.com (Lexing.from_string s)
-	with Parser.Error (e,_) ->
+	with Parser.Error (e,p) ->
 		restore();
-		failwith (Parser.error_msg e)
-	| Lexer.Error (e,_) ->
+		error (Parser.error_msg e) p
+	| Lexer.Error (e,p) ->
 		restore();
-		failwith (Lexer.error_msg e)
+		error (Lexer.error_msg e) p
 	in
 	restore();
 	match decls with
@@ -2021,15 +2021,22 @@ let parse_string ctx s p =
 let macro_timer ctx path =
 	Common.timer (if Common.defined ctx.com "macrotimes" then "macro " ^ path else "macro execution")
 
-let typing_timer f =
+let typing_timer ctx f =
 	let t = Common.timer "typing" in
+	let old = ctx.com.error in
+	ctx.com.error <- (fun e p -> raise (Error(Custom e,p)));
 	try
 		let r = f() in
 		t();
 		r
-	with e ->
-		t();
-		raise e
+	with Error (ekind,p) ->
+			ctx.com.error <- old;
+			t();
+			Interp.compiler_error (Typecore.error_msg ekind) p
+		| e ->
+			ctx.com.error <- old;
+			t();
+			raise e
 
 let make_macro_api ctx p =
 	let make_instance = function
@@ -2042,7 +2049,7 @@ let make_macro_api ctx p =
 		Interp.defined = Common.defined ctx.com;
 		Interp.define = Common.define ctx.com;
 		Interp.get_type = (fun s ->
-			typing_timer (fun() ->
+			typing_timer ctx (fun() ->
 				let path = parse_path s in
 				try
 					Some (Typeload.load_instance ctx { tpackage = fst path; tname = snd path; tparams = []; tsub = None } p true)
@@ -2051,7 +2058,7 @@ let make_macro_api ctx p =
 			)
 		);
 		Interp.get_module = (fun s ->
-			typing_timer (fun() ->
+			typing_timer ctx (fun() ->
 				let path = parse_path s in
 				List.map make_instance (Typeload.load_module ctx path p).mtypes
 			)
@@ -2064,23 +2071,19 @@ let make_macro_api ctx p =
 			)
 		);
 		Interp.parse_string = (fun s p ->
-			let head = "class X{static function main() " in
-			let head = (if p.pmin > String.length head then head ^ String.make (p.pmin - String.length head) ' ' else head) in
-			match parse_string ctx (head ^ s ^ "}") p with
-			| EClass { d_data = [{ cff_name = "main"; cff_kind = FFun { f_expr = Some e } }]} -> e
-			| _ -> assert false
+			typing_timer ctx (fun() ->
+				let head = "class X{static function main() " in
+				let head = (if p.pmin > String.length head then head ^ String.make (p.pmin - String.length head) ' ' else head) in
+				match parse_string ctx (head ^ s ^ "}") p with
+				| EClass { d_data = [{ cff_name = "main"; cff_kind = FFun { f_expr = Some e } }]} -> e
+				| _ -> assert false
+			)
 		);
 		Interp.typeof = (fun e ->
-			typing_timer (fun() ->
-				let old_err = ctx.com.error in
-				ctx.com.error <- (fun e p -> raise (Error(Custom e,p)));
-				let e = (try type_expr ctx ~need_val:true e with Error (msg,_) -> ctx.com.error <- old_err; failwith (error_msg msg)) in
-				ctx.com.error <- old_err;
-				e.etype
-			)
+			typing_timer ctx (fun() -> (type_expr ctx ~need_val:true e).etype)
 		);
 		Interp.type_patch = (fun t f s v ->
-			typing_timer (fun() ->
+			typing_timer ctx (fun() ->
 				let v = (match v with None -> None | Some s ->
 					match parse_string ctx ("typedef T = " ^ s) null_pos with
 					| ETypedef { d_data = ct } -> Some ct