Skip to content

Instantly share code, notes, and snippets.

@skial
Created June 16, 2011 19:59
Show Gist options
  • Save skial/1030122 to your computer and use it in GitHub Desktop.
Save skial/1030122 to your computer and use it in GitHub Desktop.
--prefix option for haxe - kind of works...
(*
* Haxe Compiler
* Copyright (c)2005-2008 Nicolas Cannasse
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
open Printf
open Genswf
open Common
let version = 207
let prompt = ref false
let measure_times = ref false
let start = get_time()
let executable_path() =
Extc.executable_path()
let normalize_path p =
let l = String.length p in
if l = 0 then
"./"
else match p.[l-1] with
| '\\' | '/' -> p
| _ -> p ^ "/"
let format msg p =
if p = Ast.null_pos then
msg
else begin
let error_printer file line = sprintf "%s:%d:" file line in
let epos = Lexer.get_error_pos error_printer p in
let msg = String.concat ("\n" ^ epos ^ " : ") (ExtString.String.nsplit msg "\n") in
sprintf "%s : %s" epos msg
end
let message msg p =
prerr_endline (format msg p)
let messages = ref []
let store_message msg p =
messages := format msg p :: !messages
let do_exit() =
List.iter prerr_endline (List.rev (!messages));
if !prompt then begin
print_endline "Press enter to exit...";
ignore(read_line());
end;
exit 1
let report msg p =
let inf = if !Common.display_default then Printf.sprintf " (display %s@%d)" (!Parser.resume_display).Ast.pfile (!Parser.resume_display).Ast.pmin else "" in
messages := format (msg ^ inf) p :: !messages;
do_exit()
let htmlescape s =
let s = String.concat "&lt;" (ExtString.String.nsplit s "<") in
let s = String.concat "&gt;" (ExtString.String.nsplit s ">") in
s
let report_list l =
prerr_endline "<list>";
List.iter (fun (n,t,d) ->
prerr_endline (Printf.sprintf "<i n=\"%s\"><t>%s</t><d>%s</d></i>" n (htmlescape t) (htmlescape d));
) (List.sort (fun (a,_,_) (b,_,_) -> compare a b) l);
prerr_endline "</list>"
let file_extension f =
let cl = ExtString.String.nsplit f "." in
match List.rev cl with
| [] -> ""
| x :: _ -> x
let make_path f =
let f = String.concat "/" (ExtString.String.nsplit f "\\") in
let cl = ExtString.String.nsplit f "." in
let cl = (match List.rev cl with
| ["hx";path] -> ExtString.String.nsplit path "/"
| _ -> cl
) in
let error() = failwith ("Invalid class name " ^ f) in
let invalid_char x =
for i = 1 to String.length x - 1 do
match x.[i] with
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> ()
| _ -> error()
done;
false
in
let rec loop = function
| [] -> error()
| [x] -> if String.length x = 0 || not (x.[0] = '_' || (x.[0] >= 'A' && x.[0] <= 'Z')) || invalid_char x then error() else [] , x
| x :: l ->
if String.length x = 0 || x.[0] < 'a' || x.[0] > 'z' || invalid_char x then error() else
let path , name = loop l in
x :: path , name
in
loop cl
let unique l =
let rec _unique = function
| [] -> []
| x1 :: x2 :: l when x1 = x2 -> _unique (x2 :: l)
| x :: l -> x :: _unique l
in
_unique (List.sort compare l)
let rec read_type_path com p =
let classes = ref [] in
let packages = ref [] in
let p = (match p with
| x :: l ->
(try
match PMap.find x com.package_rules with
| Directory d -> d :: l
| Remap s -> s :: l
| _ -> p
with
Not_found -> p)
| _ -> p
) in
List.iter (fun path ->
let dir = path ^ String.concat "/" p in
let r = (try Sys.readdir dir with _ -> [||]) in
Array.iter (fun f ->
if (try (Unix.stat (dir ^ "/" ^ f)).Unix.st_kind = Unix.S_DIR with _ -> false) then begin
if f.[0] >= 'a' && f.[0] <= 'z' then begin
if p = ["."] then
match read_type_path com [f] with
| [] , [] -> ()
| _ ->
try
match PMap.find f com.package_rules with
| Forbidden -> ()
| Remap f -> packages := f :: !packages
| Directory _ -> raise Not_found
with Not_found ->
packages := f :: !packages
else
packages := f :: !packages
end;
end else if file_extension f = "hx" then begin
let c = Filename.chop_extension f in
if String.length c < 2 || String.sub c (String.length c - 2) 2 <> "__" then classes := c :: !classes;
end;
) r;
) com.class_path;
List.iter (fun (_,_,extract) ->
Hashtbl.iter (fun (path,name) _ ->
if path = p then classes := name :: !classes else
let rec loop p1 p2 =
match p1, p2 with
| [], _ -> ()
| x :: _, [] -> packages := x :: !packages
| a :: p1, b :: p2 -> if a = b then loop p1 p2
in
loop path p
) (extract());
) com.swf_libs;
unique !packages, unique !classes
let delete_file f = try Sys.remove f with _ -> ()
let expand_env path =
let r = Str.regexp "%\\([^%]+\\)%" in
Str.global_substitute r (fun s -> try Sys.getenv (Str.matched_group 1 s) with Not_found -> "") path
let parse_hxml file =
let ch = IO.input_channel (try open_in_bin file with _ -> failwith ("File not found " ^ file)) in
let lines = Str.split (Str.regexp "[\r\n]+") (IO.read_all ch) in
IO.close_in ch;
List.concat (List.map (fun l ->
let l = ExtString.String.strip l in
let renv = Str.regexp "%\\([A-Za-z0-9_]+\\)%" in
let l = Str.global_substitute renv (fun _ ->
let e = Str.matched_group 1 l in
try Sys.getenv e with Not_found -> "%" ^ e ^ "%"
) l in
if l = "" || l.[0] = '#' then
[]
else if l.[0] = '-' then
try
let a, b = ExtString.String.split l " " in
[a; ExtString.String.strip b]
with
_ -> [l]
else
[l]
) lines)
let lookup_classes com fpath =
let spath = String.lowercase fpath in
let rec loop = function
| [] -> []
| cp :: l ->
let cp = (if cp = "" then "./" else cp) in
let c = normalize_path (try Common.get_full_path cp with _ -> cp) in
let clen = String.length c in
if clen < String.length fpath && String.sub spath 0 clen = String.lowercase c then begin
let path = String.sub fpath clen (String.length fpath - clen) in
(try [make_path path] with _ -> loop l)
end else
loop l
in
loop com.class_path
let add_swf_lib com file =
let swf_data = ref None in
let swf_classes = ref None in
let getSWF = (fun() ->
match !swf_data with
| None ->
let d = Genswf.parse_swf com file in
swf_data := Some d;
d
| Some d -> d
) in
let extract = (fun() ->
match !swf_classes with
| None ->
let d = Genswf.extract_data (getSWF()) in
swf_classes := Some d;
d
| Some d -> d
) in
let build cl p =
match (try Some (Hashtbl.find (extract()) cl) with Not_found -> None) with
| None -> None
| Some c -> Some (Genswf.build_class com c file)
in
com.load_extern_type <- com.load_extern_type @ [build];
com.swf_libs <- (file,getSWF,extract) :: com.swf_libs
let add_libs com l libs =
match l with
| [] -> ()
| l ->
let cmd = "haxelib path " ^ String.concat " " l in
let p = Unix.open_process_in cmd in
let lines = Std.input_list p in
let ret = Unix.close_process_in p in
let lines = List.fold_left (fun acc l ->
let p = String.length l - 1 in
let l = (if l.[p] = '\r' then String.sub l 0 p else l) in
match (if p > 3 then String.sub l 0 3 else "") with
| "-D " ->
Common.define com (String.sub l 3 (String.length l - 3));
acc
| "-L " ->
libs := String.sub l 3 (String.length l - 3) :: !libs;
acc
| _ ->
l :: acc
) [] lines in
if ret <> Unix.WEXITED 0 then failwith (String.concat "\n" lines);
com.class_path <- lines @ com.class_path
exception Hxml_found
let rec process_params acc = function
| [] ->
init (List.rev acc) false
| "--next" :: l ->
init (List.rev acc) true;
process_params [] l
| x :: l ->
process_params (x :: acc) l
and init params has_next =
let usage = Printf.sprintf
"haXe Compiler %d.%.2d - (c)2005-2011 Motion-Twin\n Usage : haxe%s -main <class> [-swf|-js|-neko|-php|-cpp|-as3] <output> [options]\n Options :"
(version / 100) (version mod 100) (if Sys.os_type = "Win32" then ".exe" else "")
in
let classes = ref [([],"Std")] in
let com = Common.create version in
try
let xml_out = ref None in
let swf_header = ref None in
let cmds = ref [] in
let config_macros = ref [] in
let neko_libs = ref [] in
let cp_libs = ref [] in
let has_error = ref false in
let gen_as3 = ref false in
let no_output = ref false in
let did_something = ref false in
let force_typing = ref false in
let pre_compilation = ref [] in
let interp = ref false in
Common.define com ("haxe_" ^ string_of_int version);
com.warning <- (fun msg p ->
message ("Warning : " ^ msg) p
);
com.error <- (fun msg p ->
message msg p;
has_error := true;
);
Parser.display_error := (fun e p ->
com.error (Parser.error_msg e) p;
);
Parser.use_doc := false;
(try
let p = Sys.getenv "HAXE_LIBRARY_PATH" in
let rec loop = function
| drive :: path :: l ->
if String.length drive = 1 && ((drive.[0] >= 'a' && drive.[0] <= 'z') || (drive.[0] >= 'A' && drive.[0] <= 'Z')) then
(drive ^ ":" ^ path) :: loop l
else
drive :: loop (path :: l)
| l ->
l
in
let parts = "" :: Str.split_delim (Str.regexp "[;:]") p in
com.class_path <- List.map normalize_path (loop parts)
with
Not_found ->
if Sys.os_type = "Unix" then
com.class_path <- ["/usr/lib/haxe/std/";"/usr/local/lib/haxe/std/";"";"/"]
else
let base_path = normalize_path (try executable_path() with _ -> "./") in
com.class_path <- [base_path ^ "std/";""]);
com.std_path <- List.filter (fun p -> ExtString.String.ends_with p "std/" || ExtString.String.ends_with p "std\\") com.class_path;
let set_platform pf file =
if com.platform <> Cross then failwith "Multiple targets";
Common.init_platform com pf;
com.file <- file;
Unix.putenv "__file__" file;
Unix.putenv "__platform__" file;
if (pf = Flash || pf = Flash9) && file_extension file = "swc" then Common.define com "swc";
in
let define f = Arg.Unit (fun () -> Common.define com f) in
let basic_args_spec = [
("-cp",Arg.String (fun path ->
add_libs com (!cp_libs) neko_libs;
cp_libs := [];
com.class_path <- normalize_path (expand_env path) :: com.class_path
),"<path> : add a directory to find source files");
("-js",Arg.String (set_platform Js),"<file> : compile code to JavaScript file");
("-swf",Arg.String (set_platform Flash),"<file> : compile code to Flash SWF file");
("-as3",Arg.String (fun dir ->
set_platform Flash dir;
if com.flash_version < 9. then com.flash_version <- 9.;
gen_as3 := true;
Common.define com "as3";
Common.define com "no_inline";
),"<directory> : generate AS3 code into target directory");
("-neko",Arg.String (set_platform Neko),"<file> : compile code to Neko Binary");
("-php",Arg.String (fun dir ->
classes := (["php"],"Boot") :: !classes;
set_platform Php dir;
),"<directory> : generate PHP code into target directory");
("-cpp",Arg.String (fun dir ->
set_platform Cpp dir;
),"<directory> : generate C++ code into target directory");
("-xml",Arg.String (fun file ->
Parser.use_doc := true;
xml_out := Some file
),"<file> : generate XML types description");
("-main",Arg.String (fun cl ->
if com.main_class <> None then raise (Arg.Bad "Multiple -main");
let cpath = make_path cl in
com.main_class <- Some cpath;
classes := cpath :: !classes
),"<class> : select startup class");
("-lib",Arg.String (fun l ->
cp_libs := l :: !cp_libs;
Common.define com l;
),"<library[:version]> : use a haxelib library");
("-D",Arg.String (fun var ->
(match var with
| "use_rtti_doc" -> Parser.use_doc := true
| "no_opt" -> com.foptimize <- false
| _ -> ());
Common.define com var
),"<var> : define a conditional compilation flag");
("-v",Arg.Unit (fun () ->
com.verbose <- true
),": turn on verbose mode");
("-debug", Arg.Unit (fun() ->
Common.define com "debug"; com.debug <- true
), ": add debug informations to the compiled code");
] in
let adv_args_spec = [
("-swf-version",Arg.Float (fun v ->
com.flash_version <- v;
),"<version> : change the SWF version (6 to 10)");
("-swf-header",Arg.String (fun h ->
try
swf_header := Some (match ExtString.String.nsplit h ":" with
| [width; height; fps] ->
(int_of_string width,int_of_string height,float_of_string fps,0xFFFFFF)
| [width; height; fps; color] ->
(int_of_string width, int_of_string height, float_of_string fps, int_of_string ("0x" ^ color))
| _ -> raise Exit)
with
_ -> raise (Arg.Bad "Invalid SWF header format")
),"<header> : define SWF header (width:height:fps:color)");
("-swf-lib",Arg.String (fun file ->
add_swf_lib com file
),"<file> : add the SWF library to the compiled SWF");
("-x", Arg.String (fun file ->
let neko_file = file ^ ".n" in
set_platform Neko neko_file;
if com.main_class = None then begin
let cpath = make_path file in
com.main_class <- Some cpath;
classes := cpath :: !classes
end;
cmds := ("neko " ^ neko_file) :: !cmds;
),"<file> : shortcut for compiling and executing a neko file");
("-resource",Arg.String (fun res ->
let file, name = (match ExtString.String.nsplit res "@" with
| [file; name] -> file, name
| [file] -> file, file
| _ -> raise (Arg.Bad "Invalid Resource format : should be file@name")
) in
let file = (try Common.find_file com file with Not_found -> file) in
let data = (try
let s = Std.input_file ~bin:true file in
if String.length s > 12000000 then raise Exit;
s;
with
| Sys_error _ -> failwith ("Resource file not found : " ^ file)
| _ -> failwith ("Resource '" ^ file ^ "' excess the maximum size of 12MB")
) in
if Hashtbl.mem com.resources name then failwith ("Duplicate resource name " ^ name);
Hashtbl.add com.resources name data
),"<file>[@name] : add a named resource file");
("-prompt", Arg.Unit (fun() -> prompt := true),": prompt on error");
("-cmd", Arg.String (fun cmd ->
let len = String.length cmd in
let cmd = (if len > 0 && cmd.[0] = '"' && cmd.[len - 1] = '"' then String.sub cmd 1 (len - 2) else cmd) in
cmds := expand_env cmd :: !cmds
),": run the specified command after successful compilation");
("--flash-strict", define "flash_strict", ": more type strict flash API");
("--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.Unit (fun() ->
force_typing := true;
pre_compilation := (fun() ->
List.iter (fun (_,_,extract) ->
Hashtbl.iter (fun n _ -> classes := n :: !classes) (extract())
) com.swf_libs;
) :: !pre_compilation;
xml_out := Some "hx"
),": generate hx headers for all input classes");
("--next", Arg.Unit (fun() -> assert false), ": separate several haxe compilations");
("--display", Arg.String (fun file_pos ->
match file_pos with
| "classes" ->
pre_compilation := (fun() -> raise (Parser.TypePath (["."],None))) :: !pre_compilation;
| "keywords" ->
report_list (Hashtbl.fold (fun k _ acc -> (k,"","") :: acc) Lexer.keywords []);
exit 0;
| _ ->
let file, pos = try ExtString.String.split file_pos "@" with _ -> failwith ("Invalid format : " ^ file_pos) in
let pos = try int_of_string pos with _ -> failwith ("Invalid format : " ^ pos) in
com.display <- true;
Common.display_default := true;
Common.define com "display";
Parser.resume_display := {
Ast.pfile = (try Common.get_full_path file with _ -> file);
Ast.pmin = pos;
Ast.pmax = pos;
};
),": display code tips");
("--no-output", Arg.Unit (fun() -> no_output := true),": compiles but does not generate any file");
("--times", Arg.Unit (fun() -> measure_times := true),": measure compilation times");
("--no-inline", define "no_inline", ": disable inlining");
("--no-opt", Arg.Unit (fun() ->
com.foptimize <- false;
Common.define com "no_opt";
), ": disable code optimizations");
("--php-front",Arg.String (fun f ->
if com.php_front <> None then raise (Arg.Bad "Multiple --php-front");
com.php_front <- Some f;
),"<filename> : select the name for the php front file");
("--php-lib",Arg.String (fun f ->
if com.php_lib <> None then raise (Arg.Bad "Multiple --php-lib");
com.php_lib <- Some f;
),"<filename> : select the name for the php lib folder");
("--js-namespace",Arg.String (fun f ->
if com.js_namespace <> None then raise (Arg.Bad "Multiple --js-namespace");
com.js_namespace <- Some f;
Common.define com "js_namespace";
),"<namespace> : create a namespace where root types are defined");
("--remap", Arg.String (fun s ->
let pack, target = (try ExtString.String.split s ":" with _ -> raise (Arg.Bad "Invalid format")) in
com.package_rules <- PMap.add pack (Remap target) com.package_rules;
),"<package:target> : remap a package to another one");
("--interp", Arg.Unit (fun() ->
Common.define com "macro";
set_platform Neko "";
no_output := true;
interp := true;
),": interpret the program using internal macro system");
("--macro", Arg.String (fun e ->
force_typing := true;
config_macros := e :: !config_macros
)," : call the given macro before typing anything else");
("--dead-code-elimination", Arg.Unit (fun () ->
com.dead_code_elimination <- true;
Common.add_filter com (fun() -> Optimizer.filter_dead_code com);
)," : remove unused methods");
("--prefix", Arg.String (fun p ->
Common.add_filter com (fun() -> Optimizer.prefix com p);
(*com.prefix = p;*)
),"<name> : prefix all classes and methods with name");
("-swf9",Arg.String (fun file ->
set_platform Flash file;
if com.flash_version < 9. then com.flash_version <- 9.;
),"<file> : [deprecated] compile code to Flash9 SWF file");
] in
let current = ref 0 in
let args = Array.of_list ("" :: params) in
let rec args_callback cl =
match List.rev (ExtString.String.nsplit cl ".") with
| x :: _ when String.lowercase x = "hxml" ->
let hxml_args = parse_hxml cl in
let p1 = Array.to_list (Array.sub args 1 (!current - 1)) in
let p2 = Array.to_list (Array.sub args (!current + 1) (Array.length args - !current - 1)) in
if com.verbose then print_endline ("Processing HXML : " ^ cl);
process_params [] (p1 @ hxml_args @ p2);
raise Hxml_found
| _ ->
classes := make_path cl :: !classes
in
Arg.parse_argv ~current args (basic_args_spec @ adv_args_spec) args_callback usage;
add_libs com (!cp_libs) neko_libs;
if com.display then begin
xml_out := None;
no_output := true;
com.warning <- store_message;
com.main_class <- None;
com.error <- (fun msg p ->
store_message msg p;
has_error := true;
);
classes := lookup_classes com (!Parser.resume_display).Ast.pfile;
end;
let add_std dir =
com.class_path <- List.filter (fun s -> not (List.mem s com.std_path)) com.class_path @ List.map (fun p -> p ^ dir ^ "/_std/") com.std_path @ com.std_path
in
let ext = (match com.platform with
| Cross ->
(* no platform selected *)
set_platform Cross "";
"?"
| Flash | Flash9 ->
if com.flash_version >= 9. then begin
let rec loop = function
| [] -> ()
| (v,_) :: _ when v > com.flash_version -> ()
| (v,def) :: l ->
Common.define com ("flash" ^ def);
loop l
in
loop Common.flash_versions;
com.package_rules <- PMap.add "flash" (Directory "flash9") com.package_rules;
com.package_rules <- PMap.add "flash9" Forbidden com.package_rules;
com.platform <- Flash9;
add_std "flash9";
end else begin
Common.define com ("flash" ^ string_of_int (int_of_float com.flash_version));
add_std "flash";
end;
"swf"
| Neko -> add_std "neko"; "n"
| Js -> add_std "js"; "js"
| Php -> add_std "php"; "php"
| Cpp -> add_std "cpp"; "cpp"
) in
(* if we are at the last compilation step, allow all packages accesses - in case of macros or opening another project file *)
if com.display && not has_next then com.package_rules <- PMap.foldi (fun p r acc -> match r with Forbidden -> acc | _ -> PMap.add p r acc) com.package_rules PMap.empty;
(* check file extension. In case of wrong commandline, we don't want
to accidentaly delete a source file. *)
if not !no_output && file_extension com.file = ext then delete_file com.file;
List.iter (fun f -> f()) (List.rev (!pre_compilation));
if !classes = [([],"Std")] && not !force_typing then begin
if !cmds = [] && not !did_something then Arg.usage basic_args_spec usage;
end else begin
if com.verbose then print_endline ("Classpath : " ^ (String.concat ";" com.class_path));
let t = Common.timer "typing" in
Typecore.type_expr_ref := (fun ctx e need_val -> Typer.type_expr ~need_val ctx e);
let ctx = Typer.create com in
List.iter (Typer.call_init_macro ctx) (List.rev !config_macros);
List.iter (fun cpath -> ignore(ctx.Typecore.g.Typecore.do_load_module ctx cpath Ast.null_pos)) (List.rev !classes);
Typer.finalize ctx;
t();
if !has_error then do_exit();
let main, types, modules = Typer.generate ctx com.main_class in
com.main <- main;
com.types <- types;
com.modules <- modules;
let filters = [
if com.foptimize then Optimizer.reduce_expression ctx else Optimizer.sanitize ctx;
Codegen.check_local_vars_init;
Codegen.block_vars com;
] in
Codegen.post_process com filters;
Common.add_filter com (fun() -> List.iter (Codegen.on_generate ctx) com.types);
List.iter (fun f -> f()) (List.rev com.filters);
(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);
if com.platform = Flash9 || com.platform = Cpp then List.iter (Codegen.fix_overrides com) com.types;
if Common.defined com "dump" then Codegen.dump_types com;
(match com.platform with
| _ when !no_output ->
if !interp then begin
let ctx = Interp.create com (Typer.make_macro_api ctx Ast.null_pos) in
Interp.add_types ctx com.types;
(match com.main with
| None -> ()
| Some e -> ignore(Interp.eval_expr ctx e));
end;
| Cross ->
()
| Flash | Flash9 when !gen_as3 ->
if com.verbose then print_endline ("Generating AS3 in : " ^ com.file);
Genas3.generate com;
| Flash | Flash9 ->
if com.verbose then print_endline ("Generating swf : " ^ com.file);
Genswf.generate com !swf_header;
| Neko ->
if com.verbose then print_endline ("Generating neko : " ^ com.file);
Genneko.generate com !neko_libs;
| Js ->
if com.verbose then print_endline ("Generating js : " ^ com.file);
Genjs.generate com
| Php ->
if com.verbose then print_endline ("Generating PHP in : " ^ com.file);
Genphp.generate com;
| Cpp ->
if com.verbose then print_endline ("Generating Cpp in : " ^ com.file);
Gencpp.generate com;
);
end;
if not !no_output then List.iter (fun cmd ->
let t = Common.timer "command" in
let len = String.length cmd in
if len > 3 && String.sub cmd 0 3 = "cd " then
Sys.chdir (String.sub cmd 3 (len - 3))
else
if Sys.command cmd <> 0 then failwith "Command failed";
t();
) (List.rev !cmds)
with
| Common.Abort (m,p) -> report m p
| Lexer.Error (m,p) -> report (Lexer.error_msg m) p
| Parser.Error (m,p) -> report (Parser.error_msg m) p
| Typecore.Error (Typecore.Forbid_package _,_) when !Common.display_default && has_next -> ()
| Typecore.Error (m,p) -> report (Typecore.error_msg m) p
| Interp.Error (msg,p :: l) ->
store_message msg p;
List.iter (store_message "Called from") l;
report "Aborted" Ast.null_pos;
| Failure msg | Arg.Bad msg -> report ("Error : " ^ msg) Ast.null_pos
| Arg.Help msg -> print_string msg
| Hxml_found -> ()
| Typer.Display t ->
(*
documentation is currently not output even when activated
because the parse 'eats' it when used in "resume" mode
*)
let ctx = Type.print_context() in
(match Type.follow t with
| Type.TAnon a ->
let fields = PMap.fold (fun f acc ->
if not f.Type.cf_public then
acc
else
(f.Type.cf_name,Type.s_type ctx f.Type.cf_type,match f.Type.cf_doc with None -> "" | Some d -> d) :: acc
) a.Type.a_fields [] in
let fields = if !measure_times then begin
close_time();
let tot = ref 0. in
Hashtbl.iter (fun _ t -> tot := !tot +. t.total) Common.htimers;
let fields = ("@TOTAL", Printf.sprintf "%.3fs" (get_time() -. start), "") :: fields in
Hashtbl.fold (fun _ t acc ->
("@TIME " ^ t.name, Printf.sprintf "%.3fs (%.0f%%)" t.total (t.total *. 100. /. !tot), "") :: acc
) Common.htimers fields;
end else
fields
in
report_list fields;
| _ ->
prerr_endline "<type>";
prerr_endline (htmlescape (Type.s_type ctx t));
prerr_endline "</type>");
exit 0;
| Parser.TypePath (p,c) ->
(match c with
| None ->
let packs, classes = read_type_path com p in
if packs = [] && classes = [] then report ("No classes found in " ^ String.concat "." p) Ast.null_pos;
report_list (List.map (fun f -> f,"","") (packs @ classes))
| Some c ->
try
let ctx = Typer.create com in
let m = Typeload.load_module ctx (p,c) Ast.null_pos in
report_list (List.map (fun t -> snd (Type.t_path t),"","") (List.filter (fun t -> not (Type.t_private t)) m.Type.mtypes))
with _ ->
report ("Could not load module " ^ (Ast.s_type_path (p,c))) Ast.null_pos
);
exit 0;
| e when (try Sys.getenv "OCAMLRUNPARAM" <> "b" with _ -> true) ->
report (Printexc.to_string e) Ast.null_pos
;;
let all = Common.timer "other" in
Sys.catch_break true;
process_params [] (List.tl (Array.to_list Sys.argv));
all();
if !measure_times then begin
let tot = ref 0. in
Hashtbl.iter (fun _ t -> tot := !tot +. t.total) Common.htimers;
Printf.eprintf "Total time : %.3fs\n" !tot;
Printf.eprintf "------------------------------------\n";
let timers = List.sort (fun t1 t2 -> compare t1.name t2.name) (Hashtbl.fold (fun _ t acc -> t :: acc) Common.htimers []) in
List.iter (fun t ->
Printf.eprintf " %s : %.3fs, %.0f%%\n" t.name t.total (t.total *. 100. /. !tot);
) timers;
end;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment