[macro] Add back some module check policies through CompilationServer…

….setModuleFileSystemCheckPolicy

src/compiler/server.ml

@@ -229,18 +229,18 @@ let get_changed_directories sctx com =
 (* 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 com m_path m_extra p =
-	(* let cc = CommonCache.get_cache com in *)
-	(* let content_changed m_path file = *)
-	(* 	let fkey = com.file_keys#get file in *)
-	(* 	try *)
-	(* 		let cfile = cc#find_file fkey in *)
-	(* 		(1* We must use the module path here because the file path is absolute and would cause *)
-	(* 			positions in the parsed declarations to differ. *1) *)
-	(* 		let new_data = TypeloadParse.parse_module com m_path p in *)
-	(* 		cfile.c_decls <> snd new_data *)
-	(* 	with Not_found -> *)
-	(* 		true *)
-	(* in *)
+	let cc = CommonCache.get_cache com in
+	let content_changed m_path file =
+		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 com m_path p in
+			cfile.c_decls <> snd new_data
+		with Not_found ->
+			true
+	in
 	let check_module_shadowing paths m_path m_extra =
 		List.iter (fun dir ->
 			let file = (dir.c_path ^ (snd m_path)) ^ ".hx" in
@@ -290,17 +290,20 @@ let check_module sctx com m_path m_extra p =
 						check_module_shadowing (get_changed_directories sctx mcom) m_path m_extra
 				end
 		in
+		let has_policy policy = List.mem policy m_extra.m_fs_check_policy || match policy with
+			| NoFileSystemCheck when !ServerConfig.do_not_check_modules && !Parser.display_mode <> DMNone -> true
+			| _ -> false
+		in
 		let check_file () =
 			let file = Path.UniqueKey.lazy_path m_extra.m_file in
 			if file_time file <> m_extra.m_time then begin
-				(* TODO that one might be useful? *)
-				(* if has_policy CheckFileContentModification && not (content_changed m_path file) then begin *)
-				(* 	ServerMessage.unchanged_content com "" file; *)
-				(* end else begin *)
+				if has_policy CheckFileContentModification && not (content_changed m_path file) then begin
+					ServerMessage.unchanged_content com "" file;
+				end else begin
 					ServerMessage.not_cached com "" m_path;
 					if m_extra.m_kind = MFake then Hashtbl.remove com.fake_modules (Path.UniqueKey.lazy_key m_extra.m_file);
 					raise (Dirty (FileChanged file))
-				(* end *)
+				end
 			end
 		in
 		let find_module_extra sign mpath =
@@ -323,7 +326,7 @@ let check_module sctx com m_path m_extra p =
 		let check () =
 			try
 				check_module_path();
-				if Path.file_extension (Path.UniqueKey.lazy_path m_extra.m_file) <> "hx" then check_file();
+				if not (has_policy NoFileSystemCheck) || Path.file_extension (Path.UniqueKey.lazy_path m_extra.m_file) <> "hx" then check_file();
 				check_dependencies();
 				None
 			with

src/compiler/serverMessage.ml

@@ -15,7 +15,7 @@ type server_message_options = {
 	mutable print_reusing : bool;
 	mutable print_retyping : bool;
 	mutable print_skipping_dep : bool;
-	(* mutable print_unchanged_content : bool; *)
+	mutable print_unchanged_content : bool;
 	mutable print_cached_modules : bool;
 	mutable print_class_paths_changed : bool;
 	mutable print_arguments : bool;
@@ -42,7 +42,7 @@ let config = {
 	print_reusing = false;
 	print_retyping = false;
 	print_skipping_dep = false;
-	(* print_unchanged_content = false; *)
+	print_unchanged_content = false;
 	print_cached_modules = false;
 	print_class_paths_changed = false;
 	print_arguments = false;
@@ -103,8 +103,8 @@ let retyper_fail com tabs m reason =
 let skipping_dep com tabs (mpath,reason) =
 	if config.print_skipping_dep then print_endline (Printf.sprintf "%sskipping %s (%s)" (sign_string com) (s_type_path mpath) reason)
 
-(* let unchanged_content com tabs file = *)
-(* 	if config.print_unchanged_content then print_endline (Printf.sprintf "%s%s changed time not but content, reusing" (sign_string com) file) *)
+let unchanged_content com tabs file =
+	if config.print_unchanged_content then print_endline (Printf.sprintf "%s%s changed time not but content, reusing" (sign_string com) file)
 
 let cached_modules com tabs i =
 	if config.print_cached_modules then print_endline (Printf.sprintf "%sCached %i modules" (sign_string com) i)
@@ -172,7 +172,7 @@ let enable_all () =
 	config.print_reusing <- true;
 	config.print_retyping <- true;
 	config.print_skipping_dep <- true;
-	(* config.print_unchanged_content <- true; *)
+	config.print_unchanged_content <- true;
 	config.print_cached_modules <- true;
 	config.print_arguments <- true;
 	config.print_completion <- true;
@@ -197,7 +197,7 @@ let set_by_name name value = match name with
 	| "reusing" -> config.print_reusing <- value;
 	| "retyping" -> config.print_retyping <- value;
 	| "skippingDep" -> config.print_skipping_dep <- value;
-	(* | "unchangedContent" -> config.print_unchanged_content <- value; *)
+	| "unchangedContent" -> config.print_unchanged_content <- value;
 	| "cachedModules" -> config.print_cached_modules <- value;
 	| "arguments" -> config.print_arguments <- value;
 	| "completion" -> config.print_completion <- value;

src/context/typecore.ml

@@ -113,6 +113,7 @@ type typer_globals = {
 	mutable core_api : typer option;
 	mutable macros : ((unit -> unit) * typer) option;
 	mutable std_types : module_def;
+	mutable module_fs_check_policies : (string list * filesystem_check_policy list * bool) list;
 	mutable global_using : (tclass * pos) list;
 	(* Indicates that Typer.create() finished building this instance *)
 	mutable complete : bool;

src/core/tFunctions.ml

@@ -156,7 +156,7 @@ let mk_class m path pos name_pos =
 	c.cl_type <- TType(class_module_type c,[]);
 	c
 
-let module_extra file sign time kind added =
+let module_extra file sign time kind added policy =
 	{
 		m_file = Path.UniqueKey.create_lazy file;
 		m_sign = sign;
@@ -174,6 +174,7 @@ let module_extra file sign time kind added =
 		m_kind = kind;
 		m_cache_bound_objects = DynArray.create ();
 		m_features = Hashtbl.create 0;
+		m_fs_check_policy = policy;
 	}
 
 let mk_class_field_ref (c : tclass) (cf : tclass_field) (kind : class_field_ref_kind) (is_macro : bool) = {
@@ -218,7 +219,7 @@ let null_module = {
 	m_path = [] , "";
 	m_types = [];
 	m_statics = None;
-	m_extra = module_extra "" (Digest.string "") 0. MFake 0;
+	m_extra = module_extra "" (Digest.string "") 0. MFake 0 [];
 }
 
 let null_class =

src/core/tType.ml

@@ -25,6 +25,11 @@ and method_kind =
 	| MethDynamic
 	| MethMacro
 
+type filesystem_check_policy =
+	| NoFileSystemCheck
+	| CheckFileModificationTime
+	| CheckFileContentModification
+
 type module_tainting_reason =
 	| CheckDisplayFile
 	| ServerInvalidate
@@ -405,6 +410,7 @@ and module_def_extra = {
 	m_file : Path.UniqueKey.lazy_t;
 	m_sign : Digest.t;
 	m_display : module_def_display;
+	mutable m_fs_check_policy : filesystem_check_policy list;
 	mutable m_time : float;
 	mutable m_cache_state : module_cache_state;
 	mutable m_added : int;

src/macro/macroApi.ml

@@ -56,6 +56,7 @@ type 'value compiler_api = {
 	add_global_metadata : string -> string -> (bool * bool * bool) -> pos -> unit;
 	register_define : string -> Define.user_define -> unit;
 	register_metadata : string -> Meta.user_meta -> unit;
+	add_module_fs_check_policy : string list -> int list -> bool -> unit;
 	decode_expr : 'value -> Ast.expr;
 	encode_expr : Ast.expr -> 'value;
 	encode_ctype : Ast.type_hint -> 'value;
@@ -2291,6 +2292,12 @@ let macro_api ccom get_api =
 			vnull
 		);
 		(* Compilation server *)
+		"server_add_module_fs_check_policy", vfun3 (fun filter policy recursive ->
+			let filter = List.map decode_string (decode_array filter) in
+			let policy = List.map decode_int (decode_array policy) in
+			(get_api()).add_module_fs_check_policy filter policy (decode_bool recursive);
+			vnull
+		);
 		"server_invalidate_files", vfun1 (fun a ->
 			let com = ccom() in
 			let cs = com.cs in

src/typing/generic.ml

@@ -182,7 +182,7 @@ let static_method_container gctx c cf p =
 			m_path = (pack,name);
 			m_types = [];
 			m_statics = None;
-			m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake gctx.ctx.com.compilation_step;
+			m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake gctx.ctx.com.compilation_step m.m_extra.m_fs_check_policy;
 		} in
 		gctx.mg <- Some mg;
 		let cg = mk_class mg (pack,name) c.cl_pos c.cl_name_pos in
@@ -297,7 +297,7 @@ let build_generic_class ctx c p tl =
 			m_path = (pack,name);
 			m_types = [];
 			m_statics = None;
-			m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake gctx.ctx.com.compilation_step;
+			m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake gctx.ctx.com.compilation_step m.m_extra.m_fs_check_policy;
 		} in
 		let ctx = TyperManager.clone_for_module ctx.g.root_typer (TypeloadModule.make_curmod ctx.com ctx.g mg) in
 		gctx.mg <- Some mg;

src/typing/macroContext.ml

@@ -257,6 +257,9 @@ let make_macro_com_api com mcom p =
 				com.global_metadata <- (ExtString.String.nsplit s1 ".",m,config) :: com.global_metadata;
 			) meta;
 		);
+		add_module_fs_check_policy = (fun sl il b ->
+			Interp.exc_string "unsupported"
+		);
 		register_define = (fun s data -> Define.register_user_define com.user_defines s data);
 		register_metadata = (fun s data -> Meta.register_user_meta com.user_metas s data);
 		decode_expr = Interp.decode_expr;
@@ -523,6 +526,16 @@ let make_macro_api ctx mctx p =
 				ctx.com.global_metadata <- (ExtString.String.nsplit s1 ".",m,config) :: ctx.com.global_metadata;
 			) meta;
 		);
+		MacroApi.add_module_fs_check_policy = (fun sl il b ->
+			let add ctx =
+				ctx.g.module_fs_check_policies <- (List.fold_left (fun acc s -> (ExtString.String.nsplit s ".",List.map Obj.magic il,b) :: acc) ctx.g.module_fs_check_policies sl);
+				ctx.com.module_lut#iter (fun _ m -> m.m_extra.m_fs_check_policy <- TypeloadModule.get_policy ctx.g m.m_path);
+			in
+			add ctx;
+			match ctx.g.macros with
+				| None -> ()
+				| Some(_,mctx) -> add mctx
+		);
 		MacroApi.with_imports = (fun imports usings f ->
 			let restore_resolution = ctx.m.import_resolution#save in
 			let old_using = ctx.m.module_using in

src/typing/typeloadCacheHook.ml

@@ -22,10 +22,10 @@ let create_fake_module com file =
 			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;
+			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
+	mdep

src/typing/typeloadModule.ml

@@ -29,6 +29,10 @@ open Typeload
 open Error
 open Resolution
 
+let get_policy g mpath =
+	let sl1 = full_dot_path2 mpath mpath in
+	List.fold_left (fun acc (sl2,policy,recursive) -> if match_path recursive sl1 sl2 then policy @ acc else acc) [] g.module_fs_check_policies
+
 let field_of_static_definition d p =
 	{
 		cff_name = d.d_name;
@@ -46,7 +50,7 @@ module ModuleLevel = struct
 			m_path = mpath;
 			m_types = [];
 			m_statics = None;
-			m_extra = module_extra (Path.get_full_path file) (Define.get_signature com.defines) (file_time file) (if com.is_macro_context then MMacro else MCode) com.compilation_step;
+			m_extra = module_extra (Path.get_full_path file) (Define.get_signature com.defines) (file_time file) (if com.is_macro_context then MMacro else MCode) com.compilation_step (get_policy g mpath);
 		} in
 		m
 

src/typing/typerEntry.ml

@@ -13,6 +13,7 @@ let create com macros =
 		g = {
 			core_api = None;
 			macros = macros;
+			module_fs_check_policies = [];
 			delayed = Array.init all_typer_passes_length (fun _ -> { tasks = []});
 			delayed_min_index = 0;
 			debug_delayed = [];

std/haxe/macro/CompilationServer.hx

@@ -24,12 +24,51 @@ package haxe.macro;
 
 import haxe.macro.Compiler;
 
+enum abstract FileCheckPolicy(Int) {
+	/**
+		Disables file modification checks, avoiding some filesystem operations.
+	**/
+	var NoFileSystemCheck = 0;
+
+	/**
+		Default behavior: check last modification time.
+	**/
+	var CheckFileModificationTime = 1;
+
+	/**
+		If a file is modified, also checks if its content changed. This check
+		is not free, but useful when .hx files are auto-generated.
+	**/
+	var CheckFileContentModification = 2;
+}
+
 /**
 	This class provides some methods which can be invoked from command line using
 	`--macro server.field(args)`.
 **/
 class CompilationServer {
 	#if macro
+	/**
+		Sets the `FileCheckPolicy` of all files whose dot-path matches an
+		element of `pathFilters`.
+
+		If `recursive` is true, a dot-path is considered matched if it starts
+		with the path filter. This automatically applies to path filters of
+		packages. Otherwise an exact match is required.
+
+		If an element in `pathFilters` is the empty String `""` it matches
+		everything (if `recursive = true`) or only top-level types (if
+		`recursive = false`).
+
+		If a call to this function is added to the compilation parameters, the
+		compilation server should be restarted to ensure it takes effect.
+	**/
+	static public function setModuleFileSystemCheckPolicy(pathFilters:Array<String>, policy:Array<FileCheckPolicy>, ?recursive = true) {
+		Context.onAfterInitMacros(() -> {
+			@:privateAccess Compiler.load("server_add_module_fs_check_policy", 4)(pathFilters, policy, recursive);
+		});
+	}
+
 	/**
 		Invalidates all files given in `filePaths`, removing them from the cache.
 	**/