Hxb writer config

src/compiler/args.ml

@@ -278,9 +278,9 @@ let parse_args com =
 		("Services",["--json"],[],Arg.String (fun file ->
 			actx.json_out <- Some file
 		),"<file>","generate JSON types description");
-		("Services",["--hxb"],[], Arg.String (fun dir ->
-			actx.hxb_out <- Some dir;
-		),"<directory>", "generate haxe binary representation in target directory");
+		("Services",["--hxb"],[], Arg.String (fun file ->
+			actx.hxb_out <- Some file;
+		),"<file>", "generate haxe binary representation to target archive");
 		("Optimization",["--no-output"],[], Arg.Unit (fun() -> actx.no_output <- true),"","compiles but does not generate any file");
 		("Debug",["--times"],[], Arg.Unit (fun() -> Timer.measure_times := true),"","measure compilation times");
 		("Optimization",["--no-inline"],[],Arg.Unit (fun () ->

src/compiler/compilationCache.ml

@@ -69,12 +69,12 @@ class context_cache (index : int) (sign : Digest.t) = object(self)
 	method find_module_extra path =
 		try (Hashtbl.find modules path).m_extra with Not_found -> (Hashtbl.find binary_cache path).mc_extra
 
-	method cache_module warn anon_identification hxb_writer_stats path m =
+	method cache_module config warn anon_identification hxb_writer_stats path m =
 		match m.m_extra.m_kind with
 		| MImport ->
 			Hashtbl.add modules m.m_path m
 		| _ ->
-			let writer = HxbWriter.create warn anon_identification hxb_writer_stats in
+			let writer = HxbWriter.create config warn anon_identification hxb_writer_stats in
 			HxbWriter.write_module writer m;
 			let chunks = HxbWriter.get_chunks writer in
 			Hashtbl.replace binary_cache path {

src/compiler/compiler.ml

@@ -369,6 +369,12 @@ let compile ctx actx callbacks =
 	callbacks.after_target_init ctx;
 	let t = Timer.timer ["init"] in
 	List.iter (fun f -> f()) (List.rev (actx.pre_compilation));
+	begin match actx.hxb_out with
+		| None ->
+			()
+		| Some file ->
+			com.hxb_writer_config <- HxbWriterConfig.process_argument file
+	end;
 	t();
 	enter_stage com CInitialized;
 	ServerMessage.compiler_stage com;
@@ -382,7 +388,11 @@ let compile ctx actx callbacks =
 		let is_compilation = is_compilation com in
 		com.callbacks#add_after_save (fun () ->
 			callbacks.after_save ctx;
-			if is_compilation then Generate.check_hxb_output ctx actx;
+			if is_compilation then match com.hxb_writer_config with
+				| Some config ->
+					Generate.check_hxb_output ctx config;
+				| None ->
+					()
 		);
 		if is_diagnostics com then
 			filter ctx tctx (fun () -> DisplayProcessing.handle_display_after_finalization ctx tctx display_file_dot_path)

src/compiler/generate.ml

@@ -21,7 +21,7 @@ let check_auxiliary_output com actx =
 			Genjson.generate com.types file
 	end
 
-let export_hxb com cc platform zip m =
+let export_hxb com config cc platform zip m =
 	let open HxbData in
 	match m.m_extra.m_kind with
 		| MCode | MMacro | MFake | MExtern -> begin
@@ -42,7 +42,7 @@ let export_hxb com cc platform zip m =
 			with Not_found ->
 				let anon_identification = new tanon_identification in
 				let warn w s p = com.Common.warning w com.warning_options s p in
-				let writer = HxbWriter.create warn anon_identification com.hxb_writer_stats in
+				let writer = HxbWriter.create config warn anon_identification com.hxb_writer_stats in
 				HxbWriter.write_module writer m;
 				let out = IO.output_string () in
 				HxbWriter.export writer out;
@@ -51,37 +51,46 @@ let export_hxb com cc platform zip m =
 	| _ ->
 		()
 
-let check_hxb_output ctx actx =
+let check_hxb_output ctx config =
+	let open HxbWriterConfig in
 	let com = ctx.com in
-	let try_write path =
+	let match_path_list l sl_path =
+		List.exists (fun sl -> Ast.match_path true sl_path sl) l
+	in
+	let try_write () =
+		let path = config.HxbWriterConfig.archive_path in
+		let path = Str.global_replace (Str.regexp "\\$target") (platform_name ctx.com.platform) path in
 		let t = Timer.timer ["generate";"hxb"] in
 		Path.mkdir_from_path path;
 		let zip = new Zip_output.zip_output path 6 in
-		let export com =
+		let export com config =
 			let cc = CommonCache.get_cache com in
 			let target = Common.platform_name_macro com in
 			List.iter (fun m ->
 				let t = Timer.timer ["generate";"hxb";s_type_path m.m_path] in
-				Std.finally t (export_hxb com cc target zip) m
+				let sl_path = fst m.m_path @ [snd m.m_path] in
+				if not (match_path_list config.exclude sl_path) || match_path_list config.include' sl_path then
+					Std.finally t (export_hxb com config cc target zip) m
 			) com.modules;
 		in
 		Std.finally (fun () ->
 			zip#close;
 			t()
 		) (fun () ->
-			export com;
-			Option.may export (com.get_macros());
+			if  config.target_config.generate then
+				export com config.target_config;
+			begin match com.get_macros() with
+				| Some mcom when config.macro_config.generate ->
+					export mcom config.macro_config
+				| _ ->
+					()
+			end;
 		) ()
 	in
-	begin match actx.hxb_out with
-		| None ->
-			()
-		| Some path ->
-			try
-				try_write path
-			with Sys_error s ->
-				error ctx (Printf.sprintf "Could not write to %s: %s" path s) null_pos
-	end
+	try
+		try_write ()
+	with Sys_error s ->
+		CompilationContext.error ctx (Printf.sprintf "Could not write to %s: %s" config.archive_path s) null_pos
 
 let parse_swf_header ctx h = match ExtString.String.nsplit h ":" with
 		| [width; height; fps] ->

src/compiler/hxb/hxbWriter.ml

@@ -511,6 +511,7 @@ let create_field_writer_context pos_writer = {
 }
 
 type hxb_writer = {
+	config : HxbWriterConfig.writer_target_config;
 	warn : Warning.warning -> string -> Globals.pos -> unit;
 	anon_id : Type.t Tanon_identification.tanon_identification;
 	stats : hxb_writer_stats;
@@ -601,13 +602,18 @@ module HxbWriter = struct
 		Chunk.write_string writer.chunk mname;
 		Chunk.write_string writer.chunk tname
 
-	let write_documentation writer (doc : doc_block) =
-		Chunk.write_option writer.chunk doc.doc_own (fun s ->
-			Chunk.write_uleb128 writer.chunk (StringPool.get_or_add writer.docs s)
-		);
-		Chunk.write_list writer.chunk doc.doc_inherited (fun s ->
-			Chunk.write_uleb128 writer.chunk (StringPool.get_or_add writer.docs s)
-		)
+	let maybe_write_documentation writer (doc : doc_block option) =
+		match doc with
+		| Some doc when writer.config.generate_docs ->
+			Chunk.write_u8 writer.chunk 1;
+			Chunk.write_option writer.chunk doc.doc_own (fun s ->
+				Chunk.write_uleb128 writer.chunk (StringPool.get_or_add writer.docs s)
+			);
+			Chunk.write_list writer.chunk doc.doc_inherited (fun s ->
+				Chunk.write_uleb128 writer.chunk (StringPool.get_or_add writer.docs s)
+			)
+		| _ ->
+			Chunk.write_u8 writer.chunk 0
 
 	let write_pos writer (p : pos) =
 		Chunk.write_string writer.chunk p.pfile;
@@ -753,7 +759,7 @@ module HxbWriter = struct
 
 	and write_cfield writer cff =
 		write_placed_name writer cff.cff_name;
-		Chunk.write_option writer.chunk cff.cff_doc (write_documentation writer);
+		maybe_write_documentation writer cff.cff_doc;
 		write_pos writer cff.cff_pos;
 		write_metadata writer cff.cff_meta;
 		Chunk.write_list writer.chunk cff.cff_access (write_placed_access writer);
@@ -1829,7 +1835,7 @@ module HxbWriter = struct
 		let restore = start_temporary_chunk writer 512 in
 		write_type_instance writer cf.cf_type;
 		Chunk.write_uleb128 writer.chunk cf.cf_flags;
-		Chunk.write_option writer.chunk cf.cf_doc (write_documentation writer);
+		maybe_write_documentation writer cf.cf_doc;
 		write_metadata writer cf.cf_meta;
 		write_field_kind writer cf.cf_kind;
 		let expr_chunk = match cf.cf_expr with
@@ -1876,7 +1882,7 @@ module HxbWriter = struct
 
 	let write_common_module_type writer (infos : tinfos) : unit =
 		Chunk.write_bool writer.chunk infos.mt_private;
-		Chunk.write_option writer.chunk infos.mt_doc (write_documentation writer);
+		maybe_write_documentation writer infos.mt_doc;
 		write_metadata writer infos.mt_meta;
 		write_type_parameters_data writer infos.mt_params;
 		Chunk.write_list writer.chunk infos.mt_using (fun (c,p) ->
@@ -2141,7 +2147,7 @@ module HxbWriter = struct
 					let t_bytes = restore (fun new_chunk -> Chunk.get_bytes new_chunk) in
 					commit_field_type_parameters writer ef.ef_params;
 					Chunk.write_bytes writer.chunk t_bytes;
-					Chunk.write_option writer.chunk ef.ef_doc (write_documentation writer);
+					maybe_write_documentation writer ef.ef_doc;
 					write_metadata writer ef.ef_meta;
 					close();
 				);
@@ -2281,9 +2287,10 @@ module HxbWriter = struct
 		l
 end
 
-let create warn anon_id stats =
+let create config warn anon_id stats =
 	let cp = StringPool.create () in
 	{
+		config;
 		warn;
 		anon_id;
 		stats;

src/compiler/hxb/hxbWriterConfig.ml

@@ -0,0 +1,119 @@
+open Globals
+open Json
+open Json.Reader
+
+type writer_target_config = {
+	mutable generate : bool;
+	mutable exclude : string list list;
+	mutable include' : string list list;
+	mutable hxb_version : int;
+	mutable generate_docs : bool;
+}
+
+type t = {
+	mutable archive_path : string;
+	target_config : writer_target_config;
+	macro_config : writer_target_config;
+}
+
+let create_target_config () = {
+	generate = true;
+	exclude = [];
+	include'= [];
+	hxb_version = HxbData.hxb_version;
+	generate_docs = true;
+}
+
+let create () = {
+	archive_path = "";
+	target_config = create_target_config ();
+	macro_config = create_target_config ()
+}
+let error s =
+	Error.raise_typing_error s null_pos
+
+module WriterConfigReader (API : DataReaderApi.DataReaderApi) = struct
+	let read_target_config config fl =
+		List.iter (fun (s,data) -> match s with
+			| "generate" ->
+				config.generate <- API.read_bool data;
+			| "exclude" ->
+				API.read_optional data (fun data ->
+					let l = API.read_array data in
+					config.exclude <- List.map (fun data -> ExtString.String.nsplit (API.read_string data) ".") l
+				)
+			| "include" ->
+				API.read_optional data (fun data ->
+					let l = API.read_array data in
+					config.include'<- List.map (fun data -> ExtString.String.nsplit (API.read_string data) ".") l
+				)
+			| "hxbVersion" ->
+				config.hxb_version <- API.read_int data
+			| "generateDocumentation" ->
+				config.generate_docs <- API.read_bool data
+			| s ->
+				error (Printf.sprintf "Unknown key for target config: %s" s)
+		) fl
+
+	let read_writer_config config data =
+		let read data =
+			let fl = API.read_object data in
+			List.iter (fun (s,data) ->
+				match s with
+				| "archivePath" ->
+					config.archive_path <- API.read_string data;
+				| "targetConfig" ->
+					API.read_optional data (fun data -> read_target_config config.target_config (API.read_object data))
+				| "macroConfig" ->
+					API.read_optional data (fun data -> read_target_config config.macro_config (API.read_object data))
+				| s ->
+					error (Printf.sprintf "Unknown key for writer config: %s" s)
+			) fl
+		in
+		API.read_optional data read
+end
+
+module WriterConfigReaderJson = WriterConfigReader(JsonDataApi.JsonReaderApi)
+
+module WriterConfigWriter (API : DataWriterApi.DataWriterApi) = struct
+	let write_target_config config =
+		API.write_object [
+			"generate",API.write_bool config.generate;
+			"exclude",API.write_array (List.map (fun sl -> API.write_string (String.concat "." sl)) config.exclude);
+			"include",API.write_array (List.map (fun sl -> API.write_string (String.concat "." sl)) config.include');
+			"hxbVersion",API.write_int config.hxb_version;
+			"generateDocumentation",API.write_bool config.generate_docs;
+		]
+
+	let write_writer_config config =
+		API.write_object [
+			"archivePath",API.write_string config.archive_path;
+			"targetConfig",write_target_config config.target_config;
+			"macroConfig",write_target_config config.macro_config;
+		]
+end
+
+let process_json config json =
+	WriterConfigReaderJson.read_writer_config config json
+
+let parse config input =
+	let lexbuf = Sedlexing.Utf8.from_string input in
+	let json = read_json lexbuf in
+	process_json config json
+
+let process_argument file =
+	let config = create () in
+	begin match Path.file_extension file with
+		| "json" ->
+			let file = try
+				open_in file
+			with exc ->
+				error (Printf.sprintf "Could not open file %s: %s" file (Printexc.to_string exc))
+			in
+			let data = Std.input_all file in
+			close_in file;
+			parse config data;
+		| _ ->
+			config.archive_path <- file;
+	end;
+	Some config

src/context/common.ml

@@ -421,6 +421,7 @@ type context = {
 	memory_marker : float array;
 	hxb_reader_stats : HxbReader.hxb_reader_stats;
 	hxb_writer_stats : HxbWriter.hxb_writer_stats;
+	mutable hxb_writer_config : HxbWriterConfig.t option;
 }
 
 let enter_stage com stage =
@@ -883,6 +884,7 @@ let create compilation_step cs version args display_mode =
 		is_macro_context = false;
 		hxb_reader_stats = HxbReader.create_hxb_reader_stats ();
 		hxb_writer_stats = HxbWriter.create_hxb_writer_stats ();
+		hxb_writer_config = None;
 	} in
 	com
 

src/context/commonCache.ml

@@ -85,11 +85,17 @@ let rec cache_context cs com =
 	let cc = get_cache com in
 	let sign = Define.get_signature com.defines in
 	let anon_identification = new Tanon_identification.tanon_identification in
+	let config = match com.hxb_writer_config with
+		| None ->
+			HxbWriterConfig.create_target_config ()
+		| Some config ->
+			if com.is_macro_context then config.macro_config else config.target_config
+	in
 	let cache_module m =
 		(* If we have a signature mismatch, look-up cache for module. Physical equality check is fine as a heueristic. *)
 		let cc = if m.m_extra.m_sign = sign then cc else cs#get_context m.m_extra.m_sign in
 		let warn w s p = com.warning w com.warning_options s p in
-		cc#cache_module warn anon_identification com.hxb_writer_stats m.m_path m;
+		cc#cache_module config warn anon_identification com.hxb_writer_stats m.m_path m;
 	in
 	List.iter cache_module com.modules;
 	begin match com.get_macros() with

src/core/data/dataReaderApi.ml

@@ -0,0 +1,17 @@
+module type DataReaderApi = sig
+	type data
+
+	val read_optional : data -> (data -> unit) -> unit
+
+	val read_object : data -> (string * data) list
+
+	val read_array : data -> data list
+
+	val read_string : data -> string
+
+	val read_bool : data -> bool
+
+	val read_int : data -> int
+
+	val data_to_string : data -> string
+end