Add initial compilation server tests (HaxeFoundation#6248)

* add some compilation server tests

* install hxnodejs and utest

* create directory before running haxe (because --cwd)

* actually print "reusing" messages

* typemize server messages

* do it properly

* use proper positions

* check if this is the problem

.gitignore

@@ -101,3 +101,5 @@ Makefile.modules
 /tests/unit/compiler_loops/All.n
 
 /tests/unit/compiler_loops/log.txt
+tests/server/test/cases/
+tests/server/test.js

src/compiler/server.ml

@@ -5,6 +5,7 @@ open Common
 open Common.DisplayMode
 open Type
 open DisplayOutput
+open Json
 
 exception Dirty of module_def
 
@@ -24,6 +25,16 @@ type context = {
 	mutable has_error : bool;
 }
 
+type server_message =
+	| AddedDirectory of string
+	| FoundDirectories of (string * float ref) list
+	| ModulePathChanged of (module_def * float * string)
+	| NotCached of module_def
+	| Parsed of (string * string)
+	| RemovedDirectory of string
+	| Reusing of module_def
+	| SkippingDep of (module_def * module_def)
+
 let s_version =
 	Printf.sprintf "%d.%d.%d%s" version_major version_minor version_revision (match Version.version_extra with None -> "" | Some v -> " " ^ v)
 
@@ -135,6 +146,7 @@ let ssend sock str =
 let rec wait_loop process_params verbose accept =
 	Sys.catch_break false;
 	let has_parse_error = ref false in
+	let test_server_messages = DynArray.create () in
 	let cs = CompilationServer.create () in
 	let sign_string com =
 		let sign = get_signature com in
@@ -148,6 +160,34 @@ let rec wait_loop process_params verbose accept =
 		in
 		Printf.sprintf "%2s,%3s: " sign_id (short_platform_name com.platform)
 	in
+	let process_server_message com tabs =
+		if true || Common.raw_defined com "compilation-server-test" then (fun message ->
+			let module_path m = JString (s_type_path m.m_path) in
+			let kind,data = match message with
+				| AddedDirectory dir -> "addedDirectory",JString dir
+				| FoundDirectories dirs -> "foundDirectories",JInt (List.length dirs)
+				| ModulePathChanged(m,time,file) -> "modulePathChanged",module_path m
+				| NotCached m -> "notCached",module_path m
+				| Parsed(ffile,_) -> "parsed",JString ffile
+				| RemovedDirectory dir -> "removedDirectory",JString dir
+				| Reusing m -> "reusing",module_path m
+				| SkippingDep(m,m') -> "skipping",JObject ["skipped",module_path m;"dependency",module_path m']
+			in
+			let js = JObject [("kind",JString kind);("data",data)] in
+			DynArray.add test_server_messages js;
+		) else (fun message -> match message with
+			| AddedDirectory dir -> print_endline (Printf.sprintf "%sadded directory %s" (sign_string com) dir)
+			| FoundDirectories dirs -> print_endline (Printf.sprintf "%sfound %i directories" (sign_string com) (List.length dirs));
+			| ModulePathChanged(m,time,file) ->
+				print_endline (Printf.sprintf "%smodule path might have changed: %s\n\twas: %2.0f %s\n\tnow: %2.0f %s"
+					(sign_string com) (s_type_path m.m_path) m.m_extra.m_time m.m_extra.m_file time file);
+			| NotCached m -> print_endline (Printf.sprintf "%s%s not cached (%s)" (sign_string com) (s_type_path m.m_path) (if m.m_extra.m_time = -1. then "macro-in-macro" else "modified"));
+			| Parsed(ffile,info) -> print_endline (Printf.sprintf "%sparsed %s (%s)" (sign_string com) ffile info)
+			| RemovedDirectory dir -> print_endline (Printf.sprintf "%sremoved directory %s" (sign_string com) dir);
+			| Reusing m -> print_endline (Printf.sprintf "%s%sreusing %s" (sign_string com) tabs (s_type_path m.m_path));
+			| SkippingDep(m,m') -> print_endline (Printf.sprintf "%sskipping %s%s" (sign_string com) (s_type_path m.m_path) (if m == m' then "" else Printf.sprintf "(%s)" (s_type_path m'.m_path)));
+		)
+	in
 	MacroContext.macro_enable_cache := true;
 	let current_stdin = ref None in
 	Typeload.parse_hook := (fun com2 file p ->
@@ -180,7 +220,7 @@ let rec wait_loop process_params verbose accept =
 						CompilationServer.cache_file cs fkey (ftime,data);
 						"cached",false
 				end in
-				if verbose && is_unusual then print_endline (Printf.sprintf "%sparsed %s (%s)" (sign_string com2) ffile info);
+				if verbose && is_unusual then process_server_message com2 "" (Parsed(ffile,info));
 				data
 	);
 	let check_module_shadowing com paths m =
@@ -189,8 +229,7 @@ let rec wait_loop process_params verbose accept =
 			if Sys.file_exists file then begin
 				let time = file_time file in
 				if time > m.m_extra.m_time then begin
-					if verbose then print_endline (Printf.sprintf "%smodule path might have changed: %s\n\twas: %2.0f %s\n\tnow: %2.0f %s"
-						(sign_string com) (s_type_path m.m_path) m.m_extra.m_time m.m_extra.m_file time file);
+					if verbose then process_server_message com "" (ModulePathChanged(m,time,file));
 					raise Not_found
 				end
 			end
@@ -222,7 +261,7 @@ let rec wait_loop process_params verbose accept =
 							List.iter (fun dir ->
 								if not (CompilationServer.has_directory cs sign dir) then begin
 									let time = stat dir in
-									if verbose then print_endline (Printf.sprintf "%sadded directory %s" (sign_string com) dir);
+									if verbose then process_server_message com "" (AddedDirectory dir);
 									CompilationServer.add_directory cs sign (dir,ref time)
 								end;
 							) sub_dirs;
@@ -231,7 +270,7 @@ let rec wait_loop process_params verbose accept =
 							acc
 					with Unix.Unix_error _ ->
 						CompilationServer.remove_directory cs sign dir;
-						if verbose then print_endline (Printf.sprintf "%sremoved directory %s" (sign_string com) dir);
+						if verbose then process_server_message com "" (RemovedDirectory dir);
 						acc
 				) [] all_dirs
 			with Not_found ->
@@ -250,7 +289,7 @@ let rec wait_loop process_params verbose accept =
 					in
 					List.iter add_dir com.class_path;
 					List.iter add_dir (Path.find_directories (platform_name com.platform) true com.class_path);
-					if verbose then print_endline (Printf.sprintf "%sfound %i directories" (sign_string com) (List.length !dirs));
+					if verbose then process_server_message com "" (FoundDirectories !dirs);
 					CompilationServer.add_directories cs sign !dirs
 				) :: !delays;
 				(* Returning [] should be fine here because it's a new context, so we won't do any
@@ -323,7 +362,7 @@ let rec wait_loop process_params verbose accept =
 					if has_policy CheckFileContentModification && not (content_changed m m.m_extra.m_file) then begin
 						if verbose then print_endline (Printf.sprintf "%s%s changed time not but content, reusing" (sign_string com2) m.m_extra.m_file)
 					end else begin
-						if verbose then print_endline (Printf.sprintf "%s%s not cached (%s)" (sign_string com2) (s_type_path m.m_path) (if m.m_extra.m_time = -1. then "macro-in-macro" else "modified"));
+						if verbose then process_server_message com2 "" (NotCached m);
 						if m.m_extra.m_kind = MFake then Hashtbl.remove Typecore.fake_modules m.m_extra.m_file;
 						raise Not_found;
 					end
@@ -365,7 +404,7 @@ let rec wait_loop process_params verbose accept =
 					(* this was just a dependency to check : do not add to the context *)
 					PMap.iter (Hashtbl.replace com2.resources) m.m_extra.m_binded_res;
 				| _ ->
-					(*if verbose then print_endline (Printf.sprintf "%s%sreusing %s" (sign_string com2) tabs (s_type_path m.m_path));*)
+					if verbose then process_server_message com2 tabs (Reusing m);
 					m.m_extra.m_added <- !compilation_step;
 					List.iter (fun t ->
 						match t with
@@ -397,7 +436,7 @@ let rec wait_loop process_params verbose accept =
 			begin match check m with
 			| None -> ()
 			| Some m' ->
-				if verbose then print_endline (Printf.sprintf "%sskipping %s%s" (sign_string com2) (s_type_path m.m_path) (if m == m' then "" else Printf.sprintf "(%s)" (s_type_path m'.m_path)));
+				if verbose then process_server_message com2 "" (SkippingDep(m,m'));
 				tcheck();
 				raise Not_found;
 			end;
@@ -481,6 +520,7 @@ let rec wait_loop process_params verbose accept =
 			let data = parse_hxml_data hxml in
 			if verbose then print_endline ("Processing Arguments [" ^ String.concat "," data ^ "]");
 			(try
+				DynArray.clear test_server_messages;
 				Hashtbl.clear changed_directories;
 				Common.display_default := DMNone;
 				Parser.resume_display := null_pos;
@@ -506,6 +546,11 @@ let rec wait_loop process_params verbose accept =
 			| Arg.Bad msg ->
 				prerr_endline ("Error: " ^ msg);
 			);
+			if DynArray.length test_server_messages > 0 then begin
+				let b = Buffer.create 0 in
+				write_json (Buffer.add_string b) (JArray (DynArray.to_list test_server_messages));
+				write (Buffer.contents b)
+			end;
 			let fl = !delays in
 			delays := [];
 			List.iter (fun f -> f()) fl;

tests/RunCi.hx

@@ -502,6 +502,7 @@ class RunCi {
 	static var optDir(default, never) = cwd + "optimization/";
 	static var miscDir(default, never) = cwd + "misc/";
 	static var displayDir(default, never) = cwd + "display/";
+	static var serverDir(default, never) = cwd + "server/";
 	static var gitInfo(get, null):{repo:String, branch:String, commit:String, timestamp:Float, date:String};
 	static var success(default, null) = true;
 	static function get_gitInfo() return if (gitInfo != null) gitInfo else gitInfo = {
@@ -840,6 +841,7 @@ class RunCi {
 							}
 						];
 
+						haxelibInstall("hxnodejs");
 						var env = Sys.environment();
 						if (
 							env.exists("SAUCE") &&
@@ -863,7 +865,6 @@ class RunCi {
 							// }
 
 							runCommand("npm", ["install", "wd", "q"], true);
-							haxelibInstall("hxnodejs");
 							runCommand("haxe", ["compile-saucelabs-runner.hxml"]);
 							var server = new Process("nekotools", ["server"]);
 							runCommand("node", ["bin/RunSauceLabs.js"].concat([for (js in jsOutputs) "unit-js.html?js=" + js.urlEncode()]));
@@ -875,6 +876,10 @@ class RunCi {
 						infoMsg("Test optimization:");
 						changeDirectory(optDir);
 						runCommand("haxe", ["run.hxml"]);
+						haxelibInstall("utest");
+						changeDirectory(serverDir);
+						runCommand("haxe", ["build.hxml"]);
+						runCommand("node", ["test.js"]);
 					case Java:
 						getSpodDependencies();
 						getJavaDependencies();

tests/server/build.hxml

@@ -0,0 +1,5 @@
+-cp src
+-main Main
+-js test.js
+-lib hxnodejs
+-lib utest

tests/server/src/AsyncMacro.hx

@@ -0,0 +1,27 @@
+import haxe.macro.Expr;
+import haxe.macro.Context;
+
+class AsyncMacro {
+	static public macro function async(e:Expr) {
+		var el = switch (e.expr) {
+			case EBlock(el): el;
+			case _: Context.error("Block expression expected", e.pos);
+		}
+		el.unshift(macro var _done = utest.Assert.createAsync(1000));
+		el.push(macro _done());
+		function loop(el:Array<Expr>) {
+			var e0 = el.shift();
+			return if (el.length == 0) {
+				e0;
+			} else switch (e0) {
+				case macro haxe($a{args}):
+					var e = loop(el);
+					args.push(macro () -> $e);
+					macro haxe($a{args});
+				case _:
+					macro { $e0; ${loop(el)}};
+			}
+		}
+		return loop(el);
+	}
+}