lose server dependency on typer

src/compiler/server.ml

@@ -3,13 +3,13 @@ open Common
 open CompilationCache
 open Timer
 open Type
-open Typecore
 open DisplayProcessingGlobals
 open Ipaddr
 open Json
 open CompilationContext
 open MessageReporting
 open HxbData
+open TypeloadCacheHook
 
 exception Dirty of module_skip_reason
 exception ServerError of string
@@ -162,10 +162,9 @@ let stat dir =
 	(Unix.stat (Path.remove_trailing_slash dir)).Unix.st_mtime
 
 (* Gets a list of changed directories for the current compilation. *)
-let get_changed_directories sctx (ctx : Typecore.typer) =
+let get_changed_directories sctx com =
 	let t = Timer.timer ["server";"module cache";"changed dirs"] in
 	let cs = sctx.cs in
-	let com = ctx.Typecore.com in
 	let sign = Define.get_signature com.defines in
 	let dirs = try
 		(* First, check if we already have determined changed directories for current compilation. *)
@@ -229,16 +228,15 @@ let get_changed_directories sctx (ctx : Typecore.typer) =
 
 (* Checks if module [m] can be reused from the cache and returns None in that case. Otherwise, returns
    [Some m'] where [m'] is the module responsible for [m] not being reusable. *)
-let check_module sctx ctx m_path m_extra p =
-	let com = ctx.Typecore.com in
+let check_module sctx com m_path m_extra p =
 	let cc = CommonCache.get_cache com in
 	let content_changed m_path file =
-		let fkey = ctx.com.file_keys#get file in
+		let fkey = com.file_keys#get file in
 		try
 			let cfile = cc#find_file fkey in
 			(* We must use the module path here because the file path is absolute and would cause
 				positions in the parsed declarations to differ. *)
-			let new_data = TypeloadParse.parse_module ctx m_path p in
+			let new_data = TypeloadParse.parse_module com m_path p in
 			cfile.c_decls <> snd new_data
 		with Not_found ->
 			true
@@ -259,7 +257,7 @@ let check_module sctx ctx m_path m_extra p =
 	let unknown_state_modules = ref [] in
 	let rec check m_path m_extra =
 		let check_module_path () =
-			let directories = get_changed_directories sctx ctx in
+			let directories = get_changed_directories sctx com in
 			match m_extra.m_kind with
 			| MFake | MImport -> () (* don't get classpath *)
 			| MExtern ->
@@ -285,18 +283,12 @@ let check_module sctx ctx m_path m_extra p =
 			| MMacro when com.is_macro_context ->
 				check_module_shadowing directories m_path m_extra
 			| MMacro ->
-				(*
-					Creating another context while the previous one is incomplete means we have an infinite loop in the compiler.
-					Most likely because of circular dependencies in base modules (e.g. `StdTypes` or `String`)
-					Prevents spending another 5 hours for debugging.
-					@see https://github.com/HaxeFoundation/haxe/issues/8174
-				*)
-				if not ctx.g.complete && ctx.com.is_macro_context then
-					raise (ServerError ("Infinite loop in Haxe server detected. "
-						^ "Probably caused by shadowing a module of the standard library. "
-						^ "Make sure shadowed module does not pull macro context."));
-				let mctx = MacroContext.get_macro_context ctx in
-				check_module_shadowing (get_changed_directories sctx mctx) m_path m_extra
+				begin match com.get_macros() with
+					| None ->
+						()
+					| Some mcom ->
+						check_module_shadowing (get_changed_directories sctx mcom) m_path m_extra
+				end
 		in
 		let has_policy policy = List.mem policy m_extra.m_check_policy || match policy with
 			| NoCheckShadowing | NoCheckFileTimeModification when !ServerConfig.do_not_check_modules && !Parser.display_mode <> DMNone -> true
@@ -309,7 +301,7 @@ let check_module sctx ctx m_path m_extra p =
 					ServerMessage.unchanged_content com "" file;
 				end else begin
 					ServerMessage.not_cached com "" m_path;
-					if m_extra.m_kind = MFake then Hashtbl.remove Typecore.fake_modules (Path.UniqueKey.lazy_key m_extra.m_file);
+					if m_extra.m_kind = MFake then Hashtbl.remove fake_modules (Path.UniqueKey.lazy_key m_extra.m_file);
 					raise (Dirty (FileChanged file))
 				end
 			end
@@ -395,7 +387,7 @@ let check_module sctx ctx m_path m_extra p =
 	state
 
 class hxb_reader_api_server
-	(ctx : Typecore.typer)
+	(com : Common.context)
 	(cc : context_cache)
 = object(self)
 
@@ -410,7 +402,7 @@ class hxb_reader_api_server
 		}
 
 	method add_module (m : module_def) =
-		ctx.com.module_lut#add m.m_path m
+		com.module_lut#add m.m_path m
 
 	method resolve_type (pack : string list) (mname : string) (tname : string) =
 		let path = (pack,mname) in
@@ -422,7 +414,7 @@ class hxb_reader_api_server
 		| GoodModule m ->
 			m
 		| BinaryModule mc ->
-			let reader = new HxbReader.hxb_reader path ctx.com.hxb_reader_stats in
+			let reader = new HxbReader.hxb_reader path com.hxb_reader_stats in
 			let f_next chunks until =
 				let t_hxb = Timer.timer ["server";"module cache";"hxb read"] in
 				let r = reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) chunks until in
@@ -434,7 +426,7 @@ class hxb_reader_api_server
 			(* We try to avoid reading expressions as much as possible, so we only do this for
 				 our current display file if we're in display mode. *)
 			let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m.m_extra.m_file) in
-			if is_display_file || ctx.com.display.dms_full_typing then ignore(f_next chunks EOM);
+			if is_display_file || com.display.dms_full_typing then ignore(f_next chunks EOM);
 			m
 		| BadModule reason ->
 			die (Printf.sprintf "Unexpected BadModule %s" (s_type_path path)) __LOC__
@@ -443,7 +435,7 @@ class hxb_reader_api_server
 
 	method find_module (m_path : path) =
 		try
-			GoodModule (ctx.com.module_lut#find m_path)
+			GoodModule (com.module_lut#find m_path)
 		with Not_found -> try
 			let mc = cc#get_hxb_module m_path in
 			begin match mc.mc_extra.m_cache_state with
@@ -454,13 +446,13 @@ class hxb_reader_api_server
 			NoModule
 
 	method basic_types =
-		ctx.com.basic
+		com.basic
 
 	method get_var_id (i : int) =
 		i
 
 	method read_expression_eagerly (cf : tclass_field) =
-		ctx.com.display.dms_full_typing
+		com.display.dms_full_typing
 end
 
 let handle_cache_bound_objects com cbol =
@@ -475,12 +467,11 @@ let handle_cache_bound_objects com cbol =
 
 (* Adds module [m] and all its dependencies (recursively) from the cache to the current compilation
    context. *)
-let rec add_modules sctx ctx (m : module_def) (from_binary : bool) (p : pos) =
-	let com = ctx.Typecore.com in
+let rec add_modules sctx com (m : module_def) (from_binary : bool) (p : pos) =
 	let own_sign = CommonCache.get_cache_sign com in
 	let rec add_modules tabs m0 m =
-		if m.m_extra.m_added < ctx.com.compilation_step then begin
-			m.m_extra.m_added <- ctx.com.compilation_step;
+		if m.m_extra.m_added < com.compilation_step then begin
+			m.m_extra.m_added <- com.compilation_step;
 			(match m0.m_extra.m_kind, m.m_extra.m_kind with
 			| MCode, MMacro | MMacro, MCode ->
 				(* this was just a dependency to check : do not add to the context *)
@@ -501,7 +492,7 @@ let rec add_modules sctx ctx (m : module_def) (from_binary : bool) (p : pos) =
 						let m2 = try
 							com.module_lut#find mpath
 						with Not_found ->
-							match type_module sctx ctx mpath p with
+							match type_module sctx com mpath p with
 							| GoodModule m ->
 								m
 							| BinaryModule mc ->
@@ -521,27 +512,26 @@ let rec add_modules sctx ctx (m : module_def) (from_binary : bool) (p : pos) =
 
 (* Looks up the module referred to by [mpath] in the cache. If it exists, a check is made to
    determine if it's still valid. If this function returns None, the module is re-typed. *)
-and type_module sctx (ctx:Typecore.typer) mpath p =
+and type_module sctx com mpath p =
 	let t = Timer.timer ["server";"module cache"] in
-	let com = ctx.Typecore.com in
 	let cc = CommonCache.get_cache com in
 	let skip m_path reason =
 		ServerMessage.skipping_dep com "" (m_path,(Printer.s_module_skip_reason reason));
 		BadModule reason
 	in
 	let add_modules from_binary m =
 		let tadd = Timer.timer ["server";"module cache";"add modules"] in
-		add_modules sctx ctx m from_binary p;
+		add_modules sctx com m from_binary p;
 		tadd();
 		GoodModule m
 	in
-	let check_module sctx ctx m_path m_extra p =
+	let check_module sctx m_path m_extra p =
 		let tcheck = Timer.timer ["server";"module cache";"check"] in
-		let r = check_module sctx ctx mpath m_extra p in
+		let r = check_module sctx com mpath m_extra p in
 		tcheck();
 		r
 	in
-	let find_module_in_cache ctx cc m_path p =
+	let find_module_in_cache cc m_path p =
 		try
 			let m = cc#find_module m_path in
 			begin match m.m_extra.m_cache_state with
@@ -558,11 +548,11 @@ and type_module sctx (ctx:Typecore.typer) mpath p =
 			NoModule
 	in
 	(* Should not raise anything! *)
-	let m = match find_module_in_cache ctx cc mpath p with
+	let m = match find_module_in_cache cc mpath p with
 		| GoodModule m ->
 			(* "Good" here is an assumption, it only means that the module wasn't explicitly invalidated
 			   in the cache. The true cache state will be known after check_module. *)
-			begin match check_module sctx ctx mpath m.m_extra p with
+			begin match check_module sctx mpath m.m_extra p with
 				| None ->
 					add_modules false m;
 				| Some reason ->
@@ -571,10 +561,10 @@ and type_module sctx (ctx:Typecore.typer) mpath p =
 		| BinaryModule mc ->
 			(* Similarly, we only know that a binary module wasn't explicitly tainted. Decode it only after
 			   checking dependencies. This means that the actual decoding never has any reason to fail. *)
-			begin match check_module sctx ctx mpath mc.mc_extra p with
+			begin match check_module sctx mpath mc.mc_extra p with
 				| None ->
 					let reader = new HxbReader.hxb_reader mpath com.hxb_reader_stats in
-					let api = (new hxb_reader_api_server ctx cc :> HxbReaderApi.hxb_reader_api) in
+					let api = (new hxb_reader_api_server com cc :> HxbReaderApi.hxb_reader_api) in
 					let f_next chunks until =
 						let t_hxb = Timer.timer ["server";"module cache";"hxb read"] in
 						let r = reader#read_chunks_until api chunks until in
@@ -585,7 +575,7 @@ and type_module sctx (ctx:Typecore.typer) mpath p =
 					(* We try to avoid reading expressions as much as possible, so we only do this for
 					   our current display file if we're in display mode. *)
 					let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m.m_extra.m_file) in
-					if is_display_file || ctx.com.display.dms_full_typing then ignore(f_next chunks EOM);
+					if is_display_file || com.display.dms_full_typing then ignore(f_next chunks EOM);
 					add_modules true m;
 				| Some reason ->
 					skip mpath reason
@@ -759,7 +749,7 @@ let do_connect ip port args =
 	if !has_error then exit 1
 
 let enable_cache_mode sctx =
-	TypeloadModule.type_module_hook := type_module sctx;
+	type_module_hook := type_module sctx;
 	ServerCompilationContext.ensure_macro_setup sctx;
 	TypeloadParse.parse_hook := parse_file sctx.cs
 

src/context/display/displayTexpr.ml

@@ -173,7 +173,7 @@ let check_display_file ctx cs =
 			let m = try
 				ctx.com.module_lut#find path
 			with Not_found ->
-				begin match !TypeloadModule.type_module_hook ctx path null_pos with
+				begin match !TypeloadCacheHook.type_module_hook ctx.com path null_pos with
 				| NoModule | BadModule _ -> raise Not_found
 				| BinaryModule mc ->
 					let api = (new TypeloadModule.hxb_reader_api_typeload ctx TypeloadModule.load_module' p :> HxbReaderApi.hxb_reader_api) in

src/context/typecore.ml

@@ -324,13 +324,6 @@ type dot_path_part = {
 	case : dot_path_part_case;
 	pos : pos
 }
-
-type find_module_result =
-	| GoodModule of module_def
-	| BadModule of module_skip_reason
-	| BinaryModule of HxbData.module_cache
-	| NoModule
-
 let make_build_info kind path params extern apply = {
 	build_kind = kind;
 	build_path = path;
@@ -582,24 +575,6 @@ let make_lazy ?(force=true) ctx t_proc f where =
 	if force then delay ctx PForce (fun () -> ignore(lazy_type r));
 	r
 
-let fake_modules = Hashtbl.create 0
-let create_fake_module ctx file =
-	let key = ctx.com.file_keys#get file in
-	let file = Path.get_full_path file in
-	let mdep = (try Hashtbl.find fake_modules key with Not_found ->
-		let mdep = {
-			m_id = alloc_mid();
-			m_path = (["$DEP"],file);
-			m_types = [];
-			m_statics = None;
-			m_extra = module_extra file (Define.get_signature ctx.com.defines) (file_time file) MFake ctx.com.compilation_step [];
-		} in
-		Hashtbl.add fake_modules key mdep;
-		mdep
-	) in
-	ctx.com.module_lut#add mdep.m_path mdep;
-	mdep
-
 let is_removable_field com f =
 	not (has_class_field_flag f CfOverride) && (
 		has_class_field_flag f CfExtern || has_class_field_flag f CfGeneric

src/typing/macroContext.ml

@@ -554,7 +554,7 @@ let make_macro_api ctx mctx p =
 				ctx.m.curmod.m_extra.m_deps <- old_deps;
 				m
 			) in
-			add_dependency m (create_fake_module ctx file);
+			add_dependency m (TypeloadCacheHook.create_fake_module ctx.com file);
 		);
 		MacroApi.current_module = (fun() ->
 			ctx.m.curmod

src/typing/typeloadCacheHook.ml

@@ -0,0 +1,31 @@
+open Globals
+open TType
+open Common
+open TFunctions
+
+type find_module_result =
+	| GoodModule of module_def
+	| BadModule of module_skip_reason
+	| BinaryModule of HxbData.module_cache
+	| NoModule
+
+let type_module_hook : (Common.context -> path -> pos -> find_module_result) ref = ref (fun _ _ _ -> NoModule)
+
+let fake_modules = Hashtbl.create 0
+
+let create_fake_module com file =
+	let key = com.file_keys#get file in
+	let file = Path.get_full_path file in
+	let mdep = (try Hashtbl.find fake_modules key with Not_found ->
+		let mdep = {
+			m_id = alloc_mid();
+			m_path = (["$DEP"],file);
+			m_types = [];
+			m_statics = None;
+			m_extra = module_extra file (Define.get_signature com.defines) (file_time file) MFake com.compilation_step [];
+		} in
+		Hashtbl.add fake_modules key mdep;
+		mdep
+	) in
+	com.module_lut#add mdep.m_path mdep;
+	mdep

src/typing/typeloadModule.ml

@@ -734,8 +734,6 @@ let type_module ctx_from mpath file ?(dont_check_path=false) ?(is_extern=false)
 	let timer = Timer.timer ["typing";"type_module"] in
 	Std.finally timer (type_module ctx mpath file ~is_extern tdecls) p *)
 
-let type_module_hook = ref (fun _ _ _ -> NoModule)
-
 class hxb_reader_api_typeload
 	(ctx : typer)
 	(load_module : typer -> path -> pos -> module_def)
@@ -811,7 +809,7 @@ and load_module' ctx m p =
 		ctx.com.module_lut#find m
 	with Not_found ->
 		(* Check cache *)
-		match !type_module_hook ctx m p with
+		match !TypeloadCacheHook.type_module_hook ctx.com m p with
 		| GoodModule m ->
 			m
 		| BinaryModule _ ->
@@ -825,7 +823,7 @@ and load_module' ctx m p =
 			let is_extern = ref false in
 			let file, decls = try
 				(* Try parsing *)
-				let rfile,decls = TypeloadParse.parse_module ctx m p in
+				let rfile,decls = TypeloadParse.parse_module ctx.com m p in
 				rfile.file,decls
 			with Not_found ->
 				(* Nothing to parse, try loading extern type *)

src/typing/typeloadParse.ml

@@ -296,14 +296,14 @@ let parse_module' com m p =
 	let pack,decls = parse_module_file com rfile p in
 	rfile,remap,pack,decls
 
-let parse_module ctx m p =
-	let rfile,remap,pack,decls = parse_module' ctx.com m p in
+let parse_module com m p =
+	let rfile,remap,pack,decls = parse_module' com m p in
 	if pack <> !remap then begin
 		let spack m = if m = [] then "`package;`" else "`package " ^ (String.concat "." m) ^ ";`" in
 		if p == null_pos then
-			display_error ctx.com ("Invalid commandline class : " ^ s_type_path m ^ " should be " ^ s_type_path (pack,snd m)) p
+			display_error com ("Invalid commandline class : " ^ s_type_path m ^ " should be " ^ s_type_path (pack,snd m)) p
 		else
-			display_error ctx.com (spack pack ^ " in " ^ rfile.file ^ " should be " ^ spack (fst m)) {p with pmax = p.pmin}
+			display_error com (spack pack ^ " in " ^ rfile.file ^ " should be " ^ spack (fst m)) {p with pmax = p.pmin}
 	end;
 	rfile, if !remap <> fst m then
 		(* build typedefs to redirect to real package *)