changed --gen-hx-classes implementation

genas3.ml

@@ -1106,309 +1106,3 @@ let generate com =
 		ctx.inits <- List.rev !inits;
 		generate_class ctx c;
 		close ctx
-
-(* ----------------------------------------------------------------------------------------
-
-	HX generation
-
-   ---------------------------------------------------------------------------------------- *)
-open As3
-
-type access =
-	| APublic
-	| AProtected
-	| APrivate
-
-let cur_package = ref []
-
-let s_type_path = Ast.s_type_path
-
-let ident ctx p =
-	As3code.iget ctx.as3_idents p
-
-let package ctx idx =
-	match As3code.iget ctx.as3_namespaces idx with
-	| A3NPrivate (Some id)
-	| A3NPublic (Some id)
-	| A3NInternal (Some id)
-	| A3NProtected id
-	| A3NExplicit id
-	| A3NStaticProtected (Some id) ->
-		let pack = ident ctx id in
-		ExtString.String.nsplit pack "."
-	| A3NNamespace id ->
-		["/* namespace " ^ ident ctx id ^ "*/"]
-	| A3NPrivate None | A3NPublic None | A3NInternal None | A3NStaticProtected None ->
-		[]
-
-let rec real_type_path ctx p =
-	let rec loop = function
-		| A3MName (id,pack) ->
-			let name = ident ctx id in
-			let pack = package ctx pack in
-			pack , name
-		| A3MMultiName (Some id,pack) ->
-			let name = ident ctx id in
-			let pack = package ctx (List.hd (As3code.iget ctx.as3_nsets pack)) in
-			pack , name
-		| A3MMultiName (None,_) ->
-			[] , "$MultiName"
-		| A3MMultiNameLate _ ->
-			[] , "$MultiNameLate"
-		| A3MRuntimeName _ ->
-			[] , "$RuntimeName"
-		| A3MRuntimeNameLate ->
-			[] , "$RuntimeNameLate"
-		| A3MAttrib n ->
-			let path, name = loop n in
-			"$Attrib" :: path, name
-		| A3MParams (n,pl) ->
-			let t = type_path ctx n in
-			let params = "<" ^ (String.concat "," (List.map (fun t -> s_type_path (type_path ctx t)) pl)) ^ ">" in
-			fst t, (snd t ^ params)
-	in
-	loop (As3code.iget ctx.as3_names p)
-
-and type_path ctx p =
-	match real_type_path ctx p with
-	| [] , "Object" -> [] , "Dynamic"
-	| [] , "Boolean" -> [] , "Bool"
-	| [] , "int" -> [] , "Int"
-	| [] , "uint" -> [] , "UInt"
-	| [] , "Number" -> [] , "Float"
-	| [] , "Array" -> [] , "Array<Dynamic>"
-	| [] , "void" -> [] , "Void"
-	| [] , "Function" -> [] , "Dynamic"
-	| [] , "Class" -> [] , "Class<Dynamic>"
-	| [] , "Error" -> ["flash";"errors"], "Error"
-	| [] , "XML" -> ["flash";"xml"], "XML"
-	| [] , "XMLList" -> ["flash";"xml"], "XMLList"
-	| [] , "QName" -> ["flash";"utils"], "QName"
-	| [] , "Namespace" -> ["flash";"utils"], "Namespace"
-	| ["__AS3__";"vec"] , "Vector" -> ["flash"], "Vector"
-	| pack, cl when pack = !cur_package -> [], cl
-	| path -> path
-
-let ident_rights ctx id =
-	match As3code.iget ctx.as3_names id with
-	| A3MName (id,r) ->
-		let name = ident ctx id in
-		(match As3code.iget ctx.as3_namespaces r with
-		| A3NNamespace i when As3code.iget ctx.as3_idents i = "http://www.adobe.com/2006/flex/mx/internal" -> APublic, "$" ^ name
-		| A3NPublic _ | A3NNamespace _ -> APublic, name
-		| A3NProtected _ -> AProtected, name
-		| _ -> APrivate, name)
-	| _ -> APublic, "???"
-
-let rec create_dir acc = function
-	| [] -> ()
-	| d :: l ->
-		let path = acc ^ "/" ^ d in
-		(try Unix.mkdir path 0o777 with _ -> ());
-		create_dir path l
-
-let value_type = function
-	| A3VNone
-	| A3VNull -> "Dynamic"
-	| A3VBool _ -> "Bool"
-	| A3VString _ -> "String"
-	| A3VInt _ -> "Int"
-	| A3VUInt _ -> "UInt"
-	| A3VFloat _ -> "Float"
-	| A3VNamespace _ -> "$Namespace"
-
-let type_val ctx t v =
-	match t with
-	| None ->
-		(match v with
-		| None -> "Dynamic"
-		| Some v -> value_type v)
-	| Some t ->
-		s_type_path (type_path ctx t)
-
-let has_getset ml f m =
-	List.exists (fun f2 ->
-		match f2.f3_kind with
-		| A3FMethod m2 when f.f3_name = f2.f3_name ->
-			(match m.m3_kind , m2.m3_kind with
-			| MK3Getter , MK3Setter | MK3Setter , MK3Getter -> true
-			| _ -> false)
-		| _ -> false
-	) ml
-
-let gen_method ctx ch name mt =
-	let m = As3code.iget ctx.as3_method_types (As3parse.no_nz mt) in
-	let ret = (match m.mt3_ret with
-		| None -> if name = "new" then "Void" else "Dynamic"
-		| Some t -> s_type_path (type_path ctx t)
-	) in
-	let p = ref 0 in
-	let params = List.map (fun a ->
-		let name = (match m.mt3_pnames with
-			| None -> "p" ^ string_of_int !p
-			| Some l ->
-				match List.nth l !p with
-				| None -> "p" ^ string_of_int !p
-				| Some i -> ident ctx i
-		) in
-		let opt_val = (match m.mt3_dparams with
-			| None -> None
-			| Some l ->
-				try
-					Some (List.nth l (!p - List.length m.mt3_args + List.length l))
-				with
-					_ -> None
-		) in
-		let t = type_val ctx a opt_val in
-		incr p;
-		(if opt_val <> None then "?" else "") ^ name ^ " : " ^ t
-	) m.mt3_args in
-	let vargs = if m.mt3_var_args then
-		(if m.mt3_args = [] then "" else ",") ^ " ?p1 : Dynamic, ?p2 : Dynamic, ?p3 : Dynamic, ?p4 : Dynamic, ?p5 : Dynamic "
-	else
-		""
-	in
-	IO.printf ch "function %s(%s%s) : %s;\n" name (String.concat ", " params) vargs ret
-
-let is_fun = function
-	| A3FMethod m -> m.m3_kind = MK3Normal
-	| _ -> false
-
-let sort_fields ctx f1 f2 =
-	let acc1, name1 = ident_rights ctx f1.f3_name in
-	let acc2, name2 = ident_rights ctx f2.f3_name in
-	let fun1 = is_fun f1.f3_kind in
-	let fun2 = is_fun f2.f3_kind in
-	compare (acc1,fun1,name1) (acc2,fun2,name2)
-
-let gen_fields ctx ch fields others construct =
-	let stat = others <> None in
-	let fields = List.sort (sort_fields ctx) (Array.to_list fields) in
-	let construct = ref construct in
-	let gen_construct() =
-		match !construct with
-		| None -> ()
-		| Some c ->
-			construct := None;
-			IO.printf ch "\t";
-			gen_method ctx ch "new" c;
-	in
-	List.iter (fun f ->
-		let acc, name = ident_rights ctx f.f3_name in
-		let rights = (match acc with APrivate -> "//private " | AProtected -> "private " | APublic -> "") ^ (if stat then "static " else "") in
-		let rights = (match others with
-			| Some l when List.exists (fun cf -> snd (ident_rights ctx cf.f3_name) = name) l -> 
-				"// -- ignored because a nonstatic field has the same name -- " ^ rights
-			| _ -> rights 
-		) in
-		if acc <> APublic || is_fun f.f3_kind then gen_construct();
-		if name.[0] = '$' || acc = APrivate then
-			()
-		else match f.f3_kind with
-		| A3FMethod m ->
-			if m.m3_override then
-				()
-			else
-			(match m.m3_kind with
-			| MK3Normal ->
-				IO.printf ch "\t%s" rights;
-				gen_method ctx ch name m.m3_type
-			| MK3Getter ->
-				let set = has_getset fields f m in
-				let set_str = if set then "" else "(default,null)" in
-				let m = As3code.iget ctx.as3_method_types (As3parse.no_nz m.m3_type) in
-				let t = (match m.mt3_ret with None -> "Dynamic" | Some t -> s_type_path (type_path ctx t)) in
-				IO.printf ch "\t%svar %s%s : %s;\n" rights name set_str t
-			| MK3Setter ->
-				let get = has_getset fields f m in
-				if not get then begin
-					let m = As3code.iget ctx.as3_method_types (As3parse.no_nz m.m3_type) in
-					let t = (match m.mt3_args with [Some t] -> s_type_path (type_path ctx t) | _ -> "Dynamic") in
-					IO.printf ch "\t%svar %s(null,default) : %s;\n" rights name t
-				end;
-			)
-		| A3FVar v ->
-			let t = type_val ctx v.v3_type (Some v.v3_value) in
-			IO.printf ch "\t%svar %s : %s;\n" rights name t
-		| A3FFunction _ ->
-			assert false
-		| A3FClass _ ->
-			IO.printf ch "\t// ????\n"
-	) fields;
-	gen_construct()
-
-let genhx_class ctx c s =
-	let base_path = "hxclasses" in
-	cur_package := [];
-	let pack , name = real_type_path ctx c.cl3_name in
-	cur_package := pack;
-	let skip = (match pack with
-		| [_;x] when String.length x > 3 && String.sub x 0 3 = "as$" -> true
-		| _ when name.[0] = '_' -> true
-		| _ -> false
-	) in
-	if skip then
-		prerr_endline ("// skip " ^ s_type_path (pack,name))
-	else
-	let () = prerr_string ("import " ^ s_type_path (pack,name)) in
-	create_dir "." (base_path :: pack);
-	let f = open_out (base_path ^ "/" ^ (match pack with [] -> "" | l -> String.concat "/" l ^ "/") ^ name ^ ".hx") in
-	let ch = IO.output_channel f in
-	if pack <> [] then IO.printf ch "package %s;\n\n" (String.concat "." pack);
-	let enum_fields, isenum = (try
-		if Array.length c.cl3_fields > 0 || c.cl3_interface || Array.length s.st3_fields = 0 then raise Exit;
-		(match c.cl3_super with None -> () | Some p -> if type_path ctx p <> ([],"Dynamic") then raise Exit);
-		let etype = ref None in
-		let fields = List.map (fun f ->
-			(match f.f3_kind with
-			| A3FVar v ->
-				let t = type_val ctx v.v3_type (Some v.v3_value) in
-				(match !etype with
-				| None -> etype := Some t
-				| Some t2 -> if t <> t2 then raise Exit);
-			| _ -> raise Exit);
-			let prot, name = ident_rights ctx f.f3_name in
-			if prot <> APublic then raise Exit;
-			name
-		) (Array.to_list s.st3_fields) in
-		fields, true
-	with Exit -> [], false) in
-	IO.printf ch "extern %s %s" (if isenum then "enum" else if c.cl3_interface then "interface" else "class") name;
-	let prev = ref (match c.cl3_super with
-	| None -> false
-	| Some p ->
-		match type_path ctx p with
-		| [] , "Dynamic" -> false
-		| path ->
-			IO.printf ch " extends %s" (s_type_path path);
-			true
-	) in
-	Array.iter (fun i ->
-		if !prev then IO.printf ch ",";
-		prev := true;
-		IO.printf ch " implements %s" (s_type_path (type_path ctx i));
-	) c.cl3_implements;
-	IO.printf ch " {\n";
-	if isenum then
-		List.iter (fun f -> IO.printf ch "\t%s;\n" f) (List.sort compare enum_fields)
-	else begin
-		let construct = (if not c.cl3_interface && Array.length c.cl3_fields > 0 then Some c.cl3_construct else None) in
-		gen_fields ctx ch c.cl3_fields None construct;
-		gen_fields ctx ch s.st3_fields (Some (Array.to_list c.cl3_fields)) None;
-	end;
-	IO.printf ch "}\n";
-	prerr_endline ";";
-	IO.close_out ch
-
-let genhx com =
-	let file = (try Common.find_file com com.file with Not_found -> failwith ("File not found : " ^ com.file)) in
-	let ch = IO.input_channel (open_in_bin file) in
-	SwfParser.full_parsing := true;
-	let _, swf = Swf.parse ch in
-	SwfParser.full_parsing := false;
-	IO.close_in ch;
-	List.iter (fun t ->
-		match t.Swf.tdata with
-		| Swf.TActionScript3 (_,t) -> Array.iteri (fun i c -> genhx_class t c t.as3_statics.(i)) t.as3_classes
-		| _ -> ()
-	) swf

genswf.ml

@@ -143,51 +143,50 @@ let zip_write_cdr z =
 (* ------------------------------- *)
 
 let rec make_tpath = function
-	| HMPath (pack,name) ->
-		let pdyn = ref false in
-		let pack, name = match pack, name with
-			| [], "void" -> [], "Void"
-			| [], "int" -> [], "Int"
-			| [], "uint" -> [], "UInt"
-			| [], "Number" -> [], "Float"
-			| [], "Boolean" -> [], "Bool"
-			| [], "Object" | [], "Function" -> [], "Dynamic"
-			| [],"Class" | [],"Array" -> pdyn := true; pack, name
-			| _ -> pack, name
-		in
-		{
-			tpackage = pack;
-			tname = name;
-			tparams = if !pdyn then [TPType (CTPath { tpackage = []; tname = "Dynamic"; tparams = []; tsub = None; })] else[];
-			tsub = None;
-		}
-	| HMName (id,_) ->
-		{
-			tpackage = [];
-			tname = id;
-			tparams = [];
-			tsub = None;
-		}
-	| HMMultiName (Some id,[HNPublic (Some ns)]) ->
-		{
-			tpackage = ExtString.String.nsplit ns ".";
-			tname = id;
-			tparams = [];
-			tsub = None;
-		}
-	| HMMultiName _ ->
-		assert false
-	| HMRuntimeName _ ->
-		assert false
-	| HMRuntimeNameLate ->
-		assert false
-	| HMMultiNameLate _ ->
-		assert false
-	| HMAttrib _ ->
-		assert false
-	| HMParams (t,params) ->
-		let params = List.map (fun t -> TPType (CTPath (make_tpath t))) params in
-		{ (make_tpath t) with tparams = params }
+	| HMPath (pack,name) ->
+		let pdyn = ref false in
+		let pack, name = match pack, name with
+			| [], "void" -> [], "Void"
+			| [], "int" -> [], "Int"
+			| [], "uint" -> [], "UInt"
+			| [], "Number" -> [], "Float"
+			| [], "Boolean" -> [], "Bool"
+			| [], "Object" | [], "Function" -> [], "Dynamic"
+			| [],"Class" | [],"Array" -> pdyn := true; pack, name
+			| [], "Error" -> ["flash";"errors"], "Error"
+			| [] , "XML" -> ["flash";"xml"], "XML"
+			| [] , "XMLList" -> ["flash";"xml"], "XMLList"
+			| [] , "QName" -> ["flash";"utils"], "QName"
+			| [] , "Namespace" -> ["flash";"utils"], "Namespace"
+			| ["__AS3__";"vec"] , "Vector" -> ["flash"], "Vector"
+			| _ -> pack, name
+		in
+		{
+			tpackage = pack;
+			tname = name;
+			tparams = if !pdyn then [TPType (CTPath { tpackage = []; tname = "Dynamic"; tparams = []; tsub = None; })] else[];
+			tsub = None;
+		}
+	| HMName (id,_) ->
+		{
+			tpackage = [];
+			tname = id;
+			tparams = [];
+			tsub = None;
+		}
+	| HMMultiName _ ->
+		assert false
+	| HMRuntimeName _ ->
+		assert false
+	| HMRuntimeNameLate ->
+		assert false
+	| HMMultiNameLate _ ->
+		assert false
+	| HMAttrib _ ->
+		assert false
+	| HMParams (t,params) ->
+		let params = List.map (fun t -> TPType (CTPath (make_tpath t))) params in
+		{ (make_tpath t) with tparams = params }
 
 let make_param cl p =
 	{ tpackage = fst cl; tname = snd cl; tparams = [TPType (CTPath { tpackage = fst p; tname = snd p; tparams = []; tsub = None })]; tsub = None }
@@ -212,7 +211,19 @@ let build_class com c file =
 		| None | Some (HMPath ([],"Object")) -> flags
 		| Some s -> HExtends (make_tpath s) :: flags
 	) in
-	let flags = List.map (fun i -> HImplements (make_tpath i)) (Array.to_list c.hlc_implements) @ flags in
+	let flags = List.map (fun i -> 
+		let i = (match i with
+			| HMMultiName (Some id,ns) -> 
+				let rec loop = function
+					| [] -> assert false
+					| HNPublic (Some ns) :: _ -> HMPath (ExtString.String.nsplit ns ".",id)
+					| _ :: l -> loop l
+				in
+				loop (List.rev ns)
+			| _ -> assert false
+		) in
+		HImplements (make_tpath i)
+	) (Array.to_list c.hlc_implements) @ flags in
 	let flags = if c.hlc_sealed || Common.defined com "flash_strict" then flags else HImplements (make_tpath (HMPath ([],"Dynamic"))) :: flags in
   (* make fields *)
 	let pos = { pfile = file ^ "@" ^ s_type_path (path.tpackage,path.tname); pmin = 0; pmax = 0 } in
@@ -343,7 +354,9 @@ let extract_data swf =
 				match f.hlf_kind with
 				| HFClass c ->
 					let path = make_tpath f.hlf_name in
-					Hashtbl.add h (path.tpackage,path.tname) c
+					(match path with
+					| { tpackage = []; tname = "Float" | "Bool" | "MethodClosure" | "Int" | "UInt" | "Dynamic" } -> ()
+					| _ -> Hashtbl.add h (path.tpackage,path.tname) c)
 				| _ -> ()
 			in
 			List.iter (fun t ->

genxml.ml

@@ -195,3 +195,123 @@ let gen_type_string ctx t =
 	write_xml ch "" x;
 	IO.close_out ch
 
+
+(* -------------------------------------------------------------------------- *)
+(* PRINT HX FROM TYPE *)
+
+let rec create_dir acc = function
+	| [] -> ()
+	| d :: l ->
+		let path = acc ^ "/" ^ d in
+		(try Unix.mkdir path 0o777 with _ -> ());
+		create_dir path l
+
+let generate_type com t =
+	let base_path = "hxclasses" in
+	let pack , name = t_path t in
+	create_dir "." (base_path :: pack);
+	let f = open_out_bin (base_path ^ "/" ^ (match pack with [] -> "" | l -> String.concat "/" l ^ "/") ^ name ^ ".hx") in
+	let ch = IO.output_channel f in
+	let p fmt = IO.printf ch fmt in
+	if pack <> [] then IO.printf ch "package %s;\n\n" (String.concat "." pack);
+	let rec notnull t =
+		match t with
+		| TMono r ->
+			(match !r with
+			| None -> t
+			| Some t -> notnull t)
+		| TLazy f ->
+			notnull ((!f)())
+		| TType ({ t_path = [],"Null" },[t]) ->
+			t
+		| _ ->
+			t
+	in
+	let rec path p tl =
+		(if fst p = pack then snd p else s_type_path p) ^ (match tl with [] -> "" | _ -> "<" ^ String.concat "," (List.map stype tl) ^ ">")
+	and stype t =
+		match t with
+		| TMono r ->
+			(match !r with
+			| None -> "Unknown"
+			| Some t -> stype t)
+		| TInst (c,tl) ->
+			path c.cl_path tl
+		| TEnum (e,tl) ->
+			path e.e_path tl
+		| TType (t,tl) ->
+			path t.t_path tl
+		| TAnon a ->
+			let fields = PMap.fold (fun f acc -> (f.cf_name ^ " : " ^ stype f.cf_type) :: acc) a.a_fields [] in
+			"{" ^ String.concat ", " fields ^ "}"
+		| TLazy f ->
+			stype ((!f)())
+		| TDynamic t2 ->
+			if t == t2 then "Dynamic" else "Dynamic<" ^ stype t2 ^ ">"
+		| TFun (args,ret) ->
+			String.concat " -> " (List.map (fun (_,_,t) -> ftype t) args) ^ " -> " ^ ftype ret
+	and ftype t = 
+		match t with
+		| TMono r ->
+			(match !r with
+			| None -> stype t
+			| Some t -> ftype t)
+		| TLazy f ->
+			ftype ((!f)())
+		| TFun _ ->
+			"(" ^ stype t ^ ")"
+		| _ ->
+			stype t
+	in
+	let print_field stat f =
+		p "\t";
+		if stat then p "static ";
+		(match f.cf_kind with
+		| Var v ->
+			p "var %s" f.cf_name;
+			if v.v_read <> AccNormal || v.v_write <> AccNormal then p "(%s,%s)" (s_access v.v_read) (s_access (if v.v_write = AccNever && (match pack with "flash" :: _ -> true | _ -> false) then AccNo else v.v_write));
+			p " : %s" (stype f.cf_type);
+		| Method m ->
+			let params, ret = (match follow f.cf_type with TFun (args,ret) -> args, ret | _ -> assert false) in
+			let params = List.map (fun (n,opt,t) -> (if opt then "?" else "") ^ n ^ " : " ^ stype (if opt then notnull t else t)) params in
+			p "function %s(%s) : %s" f.cf_name (String.concat ", " params) (stype ret);
+		);
+		p ";\n"
+	in
+	(match t with
+	| TClassDecl c ->
+		p "extern %s %s" (if c.cl_interface then "interface" else "class") (stype (TInst (c,List.map snd c.cl_types)));
+		let ext = (match c.cl_super with
+		| None -> []
+		| Some (c,pl) -> [" extends " ^ stype (TInst (c,pl))]
+		) in
+		let ext = List.fold_left (fun acc (i,pl) -> (" implements " ^ stype (TInst (i,pl))) :: acc) ext c.cl_implements in
+		p "%s" (String.concat "," (List.rev ext));
+		p " {\n";
+		let sort l =
+			let a = Array.of_list l in
+			let name = function "new" -> "" | n -> n in
+			Array.sort (fun f1 f2 ->
+				match f1.cf_kind, f2.cf_kind with
+				| Var _, Var _ | Method _ , Method _ -> compare (name f1.cf_name) (name f2.cf_name)
+				| Var _, _ -> -1
+				| _ -> 1
+			) a;
+			Array.to_list a
+		in
+		List.iter (print_field false) (sort (match c.cl_constructor with None -> c.cl_ordered_fields | Some f -> f :: c.cl_ordered_fields));
+		List.iter (print_field true) (sort c.cl_ordered_statics);
+		p "}\n";
+	| TEnumDecl e ->
+		p "extern enum %s {\n" (stype (TEnum(e,List.map snd e.e_types)));
+		p "}\n"
+	| TTypeDecl t ->
+		p "extern typedef %s = " (stype (TType (t,List.map snd t.t_types)));
+		p "%s" (stype t.t_type);
+		p "\n";
+	);
+	IO.close_out ch
+	
+let generate_hx com =
+	List.iter (generate_type com) com.types
+	

main.ml

@@ -407,10 +407,11 @@ try
 		("--no-traces", define "no_traces", ": don't compile trace calls in the program");
 		("--flash-use-stage", define "flash_use_stage", ": place objects found on the stage of the SWF lib");
 		("--neko-source", define "neko_source", ": keep generated neko source");
-		("--gen-hx-classes", Arg.String (fun file ->
-			com.file <- file;
-			Genas3.genhx com;
-			did_something := true;
+		("--gen-hx-classes", Arg.Unit (fun() ->
+			List.iter (fun (_,_,extract) ->
+				Hashtbl.iter (fun n _ -> classes := n :: !classes) (extract())				
+			) com.swf_libs;
+			xml_out := Some "hx"
 		),"<file> : generate hx headers from SWF9 file");
 		("--next", Arg.Unit (fun() -> assert false), ": separate several haxe compilations");
 		("--display", Arg.String (fun file_pos ->
@@ -600,6 +601,8 @@ try
 		);
 		(match !xml_out with
 		| None -> ()
+		| Some "hx" ->
+			Genxml.generate_hx com
 		| Some file ->
 			if com.verbose then print_endline ("Generating xml : " ^ com.file);
 			Genxml.generate com file);