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;
+		),"<directory>", "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/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

@@ -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 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/hxbWriterConfig.ml

@@ -0,0 +1,114 @@
+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;
+}
+
+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;
+}
+
+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
+			| 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;
+		]
+
+	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

@@ -418,6 +418,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 =
@@ -879,6 +880,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/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

src/core/data/dataWriterApi.ml

@@ -0,0 +1,15 @@
+module type DataWriterApi = sig
+	type data
+
+	val write_optional : data option -> data
+
+	val write_object : (string * data) list -> data
+
+	val write_array : data list -> data
+
+	val write_string : string -> data
+
+	val write_bool : bool -> data
+
+	val write_int : int -> data
+end

src/core/data/jsonDataApi.ml

@@ -0,0 +1,48 @@
+open Json
+
+let error s =
+	(* TODO: should this raise something else? *)
+	Error.raise_typing_error s Globals.null_pos
+
+module JsonReaderApi = struct
+	type data = Json.t
+
+	let read_optional json f = match json with
+		| JNull ->
+			()
+		| _ ->
+			f json
+
+	let read_object json = match json with
+		| JObject fl ->
+			fl
+		| _ ->
+			error (Printf.sprintf "Expected JObject, found %s" (string_of_json json))
+
+	let read_array json = match json with
+		| JArray l ->
+			l
+		| _ ->
+			error (Printf.sprintf "Expected JArray, found %s" (string_of_json json))
+
+	let read_string json = match json with
+		| JString s ->
+			s
+		| _ ->
+			error (Printf.sprintf "Expected JString, found %s" (string_of_json json))
+
+	let read_int json = match json with
+		| JInt i ->
+			i
+		| _ ->
+			error (Printf.sprintf "Expected JInt, found %s" (string_of_json json))
+
+	let read_bool json = match json with
+		| JBool b ->
+			b
+		| _ ->
+			error (Printf.sprintf "Expected JBool, found %s" (string_of_json json))
+
+	let data_to_string json =
+		string_of_json json
+end

src/macro/eval/evalDataApi.ml

@@ -0,0 +1,61 @@
+open EvalValue
+open EvalContext
+
+module EvalReaderApi = struct
+	open EvalDecode
+
+	type data = value
+
+	let read_optional v f = match v with
+		| VNull ->
+			()
+		| _ ->
+			f v
+
+	let read_object v =
+		List.map (fun (i,v) ->
+			EvalHash.rev_hash i,v
+		) (object_fields (decode_object v))
+
+	let read_array v =
+		EvalArray.to_list (decode_varray v)
+
+	let read_string v =
+		decode_string v
+
+	let read_int v =
+		decode_int v
+
+	let read_bool v =
+		decode_bool v
+
+	let data_to_string v =
+		(EvalPrinting.s_value 0 v).sstring
+end
+
+module EvalWriterApi = struct
+	open EvalEncode
+
+	type data = value
+
+	let write_optional vo = match vo with
+		| None -> vnull
+		| Some v -> v
+
+	let write_object fl =
+		encode_obj (List.map (fun (s,v) ->
+			EvalHash.hash s,v
+		) fl)
+
+	let write_array vl =
+		encode_array vl
+
+	let write_string s =
+		encode_string s
+
+	let write_bool b =
+		vbool b
+
+	let write_int i =
+		vint i
+end