Implement Context.withImports

src/context/display/importHandling.ml

@@ -2,6 +2,8 @@ open Globals
 open Ast
 open DisplayPosition
 open Common
+open Type
+open Error
 open Typecore
 
 type import_display_kind =
@@ -53,4 +55,198 @@ let mark_import_position ctx p =
 		let r = PMap.find p ctx.m.curmod.m_extra.m_display.m_import_positions in
 		r := true
 	with Not_found ->
-		()
+		()
+
+let commit_import ctx path mode p =
+	ctx.m.import_statements <- (path,mode) :: ctx.m.import_statements;
+	if Filename.basename p.pfile <> "import.hx" then add_import_position ctx p path
+
+let init_import ctx context_init path mode p =
+	let rec loop acc = function
+		| x :: l when is_lower_ident (fst x) -> loop (x::acc) l
+		| rest -> List.rev acc, rest
+	in
+	let pack, rest = loop [] path in
+	(match rest with
+	| [] ->
+		(match mode with
+		| IAll ->
+			ctx.m.wildcard_packages <- (List.map fst pack,p) :: ctx.m.wildcard_packages
+		| _ ->
+			(match List.rev path with
+			(* p spans `import |` (to the display position), so we take the pmax here *)
+			| [] -> DisplayException.raise_fields (DisplayToplevel.collect ctx TKType NoValue true) CRImport (DisplayTypes.make_subject None {p with pmin = p.pmax})
+			| (_,p) :: _ -> Error.typing_error "Module name must start with an uppercase letter" p))
+	| (tname,p2) :: rest ->
+		let p1 = (match pack with [] -> p2 | (_,p1) :: _ -> p1) in
+		let p_type = punion p1 p2 in
+		let md = ctx.g.do_load_module ctx (List.map fst pack,tname) p_type in
+		let types = md.m_types in
+		let no_private (t,_) = not (t_infos t).mt_private in
+		let error_private p = typing_error "Importing private declarations from a module is not allowed" p in
+		let chk_private t p = if ctx.m.curmod != (t_infos t).mt_module && (t_infos t).mt_private then error_private p in
+		let has_name name t = snd (t_infos t).mt_path = name in
+		let get_type tname =
+			let t = (try List.find (has_name tname) types with Not_found -> typing_error (StringError.string_error tname (List.map (fun mt -> snd (t_infos mt).mt_path) types) ("Module " ^ s_type_path md.m_path ^ " does not define type " ^ tname)) p_type) in
+			chk_private t p_type;
+			t
+		in
+		let rebind t name p =
+			if not (name.[0] >= 'A' && name.[0] <= 'Z') then
+				typing_error "Type aliases must start with an uppercase letter" p;
+			let _, _, f = ctx.g.do_build_instance ctx t p_type in
+			(* create a temp private typedef, does not register it in module *)
+			let t_path = (fst md.m_path @ ["_" ^ snd md.m_path],name) in
+			let t_type = f (extract_param_types (t_infos t).mt_params) in
+			let mt = TTypeDecl {(mk_typedef ctx.m.curmod t_path p p t_type) with
+				t_private = true;
+				t_params = (t_infos t).mt_params
+			} in
+			if ctx.is_display_file && DisplayPosition.display_position#enclosed_in p then
+				DisplayEmitter.display_module_type ctx mt p;
+			mt
+		in
+		let add_static_init t name s =
+			let name = (match name with None -> s | Some (n,_) -> n) in
+			match resolve_typedef t with
+			| TClassDecl c | TAbstractDecl {a_impl = Some c} ->
+				ignore(c.cl_build());
+				ignore(PMap.find s c.cl_statics);
+				ctx.m.module_globals <- PMap.add name (TClassDecl c,s,p) ctx.m.module_globals
+			| TEnumDecl e ->
+				ignore(PMap.find s e.e_constrs);
+				ctx.m.module_globals <- PMap.add name (TEnumDecl e,s,p) ctx.m.module_globals
+			| _ ->
+				raise Not_found
+		in
+		(match mode with
+		| INormal | IAsName _ ->
+			let name = (match mode with IAsName n -> Some n | _ -> None) in
+			(match rest with
+			| [] ->
+				(match name with
+				| None ->
+					ctx.m.module_imports <- List.filter no_private (List.map (fun t -> t,p) types) @ ctx.m.module_imports;
+					Option.may (fun c ->
+						context_init#add (fun () ->
+							ignore(c.cl_build());
+							List.iter (fun cf ->
+								if has_class_field_flag cf CfPublic then
+									ctx.m.module_globals <- PMap.add cf.cf_name (TClassDecl c,cf.cf_name,p) ctx.m.module_globals
+							) c.cl_ordered_statics
+						);
+					) md.m_statics
+				| Some(newname,pname) ->
+					ctx.m.module_imports <- (rebind (get_type tname) newname pname,p) :: ctx.m.module_imports);
+			| [tsub,p2] ->
+				let pu = punion p1 p2 in
+				(try
+					let tsub = List.find (has_name tsub) types in
+					chk_private tsub pu;
+					ctx.m.module_imports <- ((match name with None -> tsub | Some(n,pname) -> rebind tsub n pname),p) :: ctx.m.module_imports
+				with Not_found ->
+					(* this might be a static property, wait later to check *)
+					let find_main_type_static () =
+						let tmain = get_type tname in
+						try
+							add_static_init tmain name tsub
+						with Not_found ->
+							(* TODO: mention module-level declarations in the error message? *)
+							display_error ctx (s_type_path (t_infos tmain).mt_path ^ " has no field or subtype " ^ tsub) p
+					in
+					context_init#add (fun() ->
+						match md.m_statics with
+						| Some c ->
+							(try
+								ignore(c.cl_build());
+								let rec loop fl =
+									match fl with
+									| [] -> raise Not_found
+									| cf :: rest ->
+										if cf.cf_name = tsub then
+											if not (has_class_field_flag cf CfPublic) then
+												error_private p
+											else
+												let imported_name = match name with None -> tsub | Some (n,pname) -> n in
+												ctx.m.module_globals <- PMap.add imported_name (TClassDecl c,tsub,p) ctx.m.module_globals;
+										else
+											loop rest
+								in
+								loop c.cl_ordered_statics
+							with Not_found ->
+								find_main_type_static ())
+						| None ->
+							find_main_type_static ()
+					)
+				)
+			| (tsub,p2) :: (fname,p3) :: rest ->
+				(match rest with
+				| [] -> ()
+				| (n,p) :: _ -> typing_error ("Unexpected " ^ n) p);
+				let tsub = get_type tsub in
+				context_init#add (fun() ->
+					try
+						add_static_init tsub name fname
+					with Not_found ->
+						display_error ctx (s_type_path (t_infos tsub).mt_path ^ " has no field " ^ fname) (punion p p3)
+				);
+			)
+		| IAll ->
+			let t = (match rest with
+				| [] -> get_type tname
+				| [tsub,_] -> get_type tsub
+				| _ :: (n,p) :: _ -> typing_error ("Unexpected " ^ n) p
+			) in
+			context_init#add (fun() ->
+				match resolve_typedef t with
+				| TClassDecl c
+				| TAbstractDecl {a_impl = Some c} ->
+					ignore(c.cl_build());
+					PMap.iter (fun _ cf -> if not (has_meta Meta.NoImportGlobal cf.cf_meta) then ctx.m.module_globals <- PMap.add cf.cf_name (TClassDecl c,cf.cf_name,p) ctx.m.module_globals) c.cl_statics
+				| TEnumDecl e ->
+					PMap.iter (fun _ c -> if not (has_meta Meta.NoImportGlobal c.ef_meta) then ctx.m.module_globals <- PMap.add c.ef_name (TEnumDecl e,c.ef_name,p) ctx.m.module_globals) e.e_constrs
+				| _ ->
+					typing_error "No statics to import from this type" p
+			)
+		))
+
+let handle_using ctx path p =
+	let t = match List.rev path with
+		| (s1,_) :: (s2,_) :: sl ->
+			if is_lower_ident s2 then mk_type_path ((List.rev (s2 :: List.map fst sl)),s1)
+			else mk_type_path ~sub:s1 (List.rev (List.map fst sl),s2)
+		| (s1,_) :: sl ->
+			mk_type_path (List.rev (List.map fst sl),s1)
+		| [] ->
+			DisplayException.raise_fields (DisplayToplevel.collect ctx TKType NoValue true) CRUsing (DisplayTypes.make_subject None {p with pmin = p.pmax});
+	in
+	let types = (match t.tsub with
+		| None ->
+			let md = ctx.g.do_load_module ctx (t.tpackage,t.tname) p in
+			let types = List.filter (fun t -> not (t_infos t).mt_private) md.m_types in
+			Option.map_default (fun c -> (TClassDecl c) :: types) types md.m_statics
+		| Some _ ->
+			let t = ctx.g.do_load_type_def ctx p t in
+			[t]
+	) in
+	(* delay the using since we need to resolve typedefs *)
+	let filter_classes types =
+		let rec loop acc types = match types with
+			| td :: l ->
+				(match resolve_typedef td with
+				| TClassDecl c | TAbstractDecl({a_impl = Some c}) ->
+					loop ((c,p) :: acc) l
+				| td ->
+					loop acc l)
+			| [] ->
+				acc
+		in
+		loop [] types
+	in
+	types,filter_classes
+
+let init_using ctx context_init path p =
+	let types,filter_classes = handle_using ctx path p in
+	(* do the import first *)
+	ctx.m.module_imports <- (List.map (fun t -> t,p) types) @ ctx.m.module_imports;
+	context_init#add (fun() -> ctx.m.module_using <- filter_classes types @ ctx.m.module_using)

src/macro/macroApi.ml

@@ -19,6 +19,7 @@ type 'value compiler_api = {
 	after_generate : (unit -> unit) -> unit;
 	on_type_not_found : (string -> 'value) -> unit;
 	parse_string : string -> Globals.pos -> bool -> Ast.expr;
+	parse : 'a . ((Ast.token * Globals.pos) Stream.t -> 'a) -> string -> 'a;
 	type_expr : Ast.expr -> Type.texpr;
 	resolve_type  : Ast.complex_type -> Globals.pos -> t;
 	store_typed_expr : Type.texpr -> Ast.expr;
@@ -50,6 +51,7 @@ type 'value compiler_api = {
 	decode_type : 'value -> t;
 	flush_context : (unit -> t) -> t;
 	display_error : (string -> pos -> unit);
+	with_imports : 'a . import list -> placed_name list list -> (unit -> 'a) -> 'a;
 }
 
 
@@ -2030,8 +2032,14 @@ let macro_api ccom get_api =
 			match map (fun t -> decode_type (fn [encode_type t])) (TAnon a) with
 			| TAnon a -> encode_ref a encode_tanon (fun() -> "<anonymous>")
 			| _ -> Globals.die "" __LOC__
-		)
+		);
+		"with_imports", vfun3(fun imports usings f ->
+			let imports = List.map decode_string (decode_array imports) in
+			let imports = List.map ((get_api()).parse (fun s -> Grammar.parse_import' s Globals.null_pos)) imports in
+			let usings = List.map decode_string (decode_array usings) in
+			let usings = List.map ((get_api()).parse (fun s -> Grammar.parse_using' s Globals.null_pos)) usings in
+			let f = prepare_callback f 0 in
+			(get_api()).with_imports imports usings (fun () -> f [])
+		);
 	]
-
-
 end

src/syntax/grammar.mly

@@ -336,7 +336,7 @@ and parse_class doc meta cflags need_name s =
 			d_data = fl;
 		}, punion p1 p2)
 
-and parse_import s p1 =
+and parse_import' s p1 =
 	let rec loop pn acc =
 		match s with parser
 		| [< '(Dot,p) >] ->
@@ -353,32 +353,43 @@ and parse_import s p1 =
 				loop pn (("extern",p) :: acc)
 			| [< '(Kwd Function,p) >] ->
 				loop pn (("function",p) :: acc)
-			| [< '(Binop OpMult,_); '(Semicolon,p2) >] ->
-				p2, List.rev acc, IAll
+			| [< '(Binop OpMult,_) >] ->
+				List.rev acc, IAll
 			| [< >] ->
 				ignore(popt semicolon s);
-				syntax_error (Expected ["identifier"]) s (p,List.rev acc,INormal)
+				syntax_error (Expected ["identifier"]) s (List.rev acc,INormal)
 			end
-		| [< '(Semicolon,p2) >] ->
-			p2, List.rev acc, INormal
-		| [< '(Kwd In,_); '(Const (Ident name),pname); '(Semicolon,p2) >] ->
-			p2, List.rev acc, IAsName(name,pname)
-		| [< '(Const (Ident "as"),_); '(Const (Ident name),pname); '(Semicolon,p2) >] ->
-			p2, List.rev acc, IAsName(name,pname)
+		| [< '(Kwd In,_); '(Const (Ident name),pname) >] ->
+			List.rev acc, IAsName(name,pname)
+		| [< '(Const (Ident "as"),_); '(Const (Ident name),pname) >] ->
+			List.rev acc, IAsName(name,pname)
 		| [< >] ->
-			syntax_error (Expected [".";";";"as"]) s ((last_pos s),List.rev acc,INormal)
+			List.rev acc,INormal
 	in
-	let p2, path, mode = (match s with parser
+	let path, mode = (match s with parser
 		| [< '(Const (Ident name),p) >] -> loop p [name,p]
 		| [< >] ->
 			if would_skip_display_position p1 true s then
-				(display_position#with_pos p1,[],INormal)
+				([],INormal)
 			else
-				syntax_error (Expected ["identifier"]) s (p1,[],INormal)
+				syntax_error (Expected ["identifier"]) s ([],INormal)
 	) in
+	(path,mode)
+
+and parse_import s p1 =
+	let (path,mode) = parse_import' s p1 in
+	let p2 = match s with parser
+	| [< '(Semicolon,p2) >] ->
+		p2
+	| [< >] ->
+		if would_skip_display_position p1 true s then
+			display_position#with_pos p1
+		else
+			syntax_error (Expected [".";";";"as"]) s (last_pos s)
+	in
 	(EImport (path,mode),punion p1 p2)
 
-and parse_using s p1 =
+and parse_using' s p1 =
 	let rec loop pn acc =
 		match s with parser
 		| [< '(Dot,p) >] ->
@@ -393,21 +404,30 @@ and parse_using s p1 =
 			| [< '(Kwd Function,p) >] ->
 				loop pn (("function",p) :: acc)
 			| [< >] ->
-				syntax_error (Expected ["identifier"]) s (p,List.rev acc);
+				syntax_error (Expected ["identifier"]) s (List.rev acc);
 			end
-		| [< '(Semicolon,p2) >] ->
-			p2,List.rev acc
 		| [< >] ->
-			syntax_error (Expected [".";";"]) s ((last_pos s),List.rev acc)
+			List.rev acc
 	in
-	let p2, path = (match s with parser
+	match s with parser
 		| [< '(Const (Ident name),p) >] -> loop p [name,p]
 		| [< >] ->
 			if would_skip_display_position p1 true s then
-				(display_position#with_pos p1,[])
+				[]
 			else
-				syntax_error (Expected ["identifier"]) s (p1,[])
-	) in
+				syntax_error (Expected ["identifier"]) s []
+
+and parse_using s p1 =
+	let path = parse_using' s p1 in
+	let p2 = match s with parser
+	| [< '(Semicolon,p2) >] ->
+		p2
+	| [< >] ->
+		if would_skip_display_position p1 true s then
+			display_position#with_pos p1
+		else
+			syntax_error (Expected [".";";"]) s (last_pos s)
+	in
 	(EUsing path,punion p1 p2)
 
 and parse_abstract_relations s =

src/typing/macroContext.ml

@@ -200,6 +200,11 @@ let make_macro_api ctx p =
 			];
 		);
 		MacroApi.parse_string = parse_expr_string;
+		MacroApi.parse = (fun entry s ->
+			match ParserEntry.parse_string entry ctx.com.defines s null_pos typing_error false with
+			| ParseSuccess(r,_,_) -> r
+			| ParseError(_,(msg,p),_) -> Parser.error msg p
+		);
 		MacroApi.type_expr = (fun e ->
 			typing_timer ctx true (fun() -> type_expr ctx e WithType.value)
 		);
@@ -386,6 +391,28 @@ let make_macro_api ctx p =
 		MacroApi.encode_ctype = Interp.encode_ctype;
 		MacroApi.decode_type = Interp.decode_type;
 		MacroApi.display_error = Typecore.display_error ctx;
+		MacroApi.with_imports = (fun imports usings f ->
+			let old_globals = ctx.m.module_globals in
+			let old_imports = ctx.m.module_imports in
+			let old_using = ctx.m.module_using in
+			let run () =
+				let context_init = new TypeloadFields.context_init in
+				List.iter (fun (path,mode) ->
+					ImportHandling.init_import ctx context_init path mode null_pos
+				) imports;
+				List.iter (fun path ->
+					ImportHandling.init_using ctx context_init path null_pos
+				) usings;
+				context_init#run;
+				f()
+			in
+			let restore () =
+				ctx.m.module_globals <- old_globals;
+				ctx.m.module_imports <- old_imports;
+				ctx.m.module_using <- old_using;
+			in
+			Std.finally restore run ()
+		);
 	}
 
 let rec init_macro_interp ctx mctx mint =