diff --git a/src/compiler/args.ml b/src/compiler/args.ml index b106e3a7a75..5669f16fb1b 100644 --- a/src/compiler/args.ml +++ b/src/compiler/args.ml @@ -126,7 +126,10 @@ let parse_args com = raise (Arg.Bad "--run requires an argument: a Haxe module name") ), " [args...]","interpret a Haxe module with command line arguments"); ("Compilation",["-p";"--class-path"],["-cp"],Arg.String (fun path -> - com.class_path <- Path.add_trailing_slash path :: com.class_path + com.class_paths#add (new ClassPath.directory_class_path (Path.add_trailing_slash path) User); + ),"","add a directory to find source files"); + ("Compilation",[],["-libcp"],Arg.String (fun path -> + com.class_paths#add (new ClassPath.directory_class_path (Path.add_trailing_slash path) Lib); ),"","add a directory to find source files"); ("Compilation",["-m";"--main"],["-main"],Arg.String (fun cl -> if com.main_class <> None then raise (Arg.Bad "Multiple --main classes specified"); diff --git a/src/compiler/compilationCache.ml b/src/compiler/compilationCache.ml index 77ca6b1f42c..fe465fecbb2 100644 --- a/src/compiler/compilationCache.ml +++ b/src/compiler/compilationCache.ml @@ -1,11 +1,12 @@ open Globals open Ast +open Path open Json open Type open Define type cached_file = { - c_file_path : string; + c_file_path : ClassPaths.resolved_file; c_time : float; c_package : string list; c_decls : type_decl list; @@ -120,13 +121,13 @@ class cache = object(self) Hashtbl.add contexts sign cache; cache - method add_info sign desc platform class_path defines = + method add_info sign desc platform (class_paths : ClassPaths.class_paths) defines = let cc = self#get_context sign in let jo = JObject [ "index",JInt cc#get_index; "desc",JString desc; "platform",JString (platform_name platform); - "classPaths",JArray (List.map (fun s -> JString s) class_path); + "classPaths",JArray (List.map (fun s -> JString s) class_paths#as_string_list); "signature",JString (Digest.to_hex sign); "defines",JArray (PMap.foldi (fun k v acc -> JObject [ "key",JString k; diff --git a/src/compiler/compiler.ml b/src/compiler/compiler.ml index 6e66c594a24..cc7e49dd8cc 100644 --- a/src/compiler/compiler.ml +++ b/src/compiler/compiler.ml @@ -78,8 +78,15 @@ let run_command ctx cmd = module Setup = struct let initialize_target ctx com actx = init_platform com; + com.class_paths#lock_context (platform_name com.platform) false; 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 + com.class_paths#modify_inplace (fun cp -> match cp#scope with + | Std -> + let cp' = new ClassPath.directory_class_path (cp#path ^ dir ^ "/_std/") StdTarget in + cp :: [cp'] + | _ -> + [cp] + ); in match com.platform with | Cross -> @@ -170,7 +177,6 @@ module Setup = struct let create_typer_context ctx macros = let com = ctx.com in - Common.log com ("Classpath: " ^ (String.concat ";" com.class_path)); let buffer = Buffer.create 64 in Buffer.add_string buffer "Defines: "; PMap.iter (fun k v -> match v with @@ -185,6 +191,8 @@ module Setup = struct let executable_path() = Extc.executable_path() + open ClassPath + let get_std_class_paths () = try let p = Sys.getenv "HAXE_STD_PATH" in @@ -198,7 +206,7 @@ module Setup = struct l in let parts = Str.split_delim (Str.regexp "[;:]") p in - "" :: List.map Path.add_trailing_slash (loop parts) + List.map (fun s -> Path.add_trailing_slash s,Std) (loop parts) with Not_found -> let base_path = Path.get_real_path (try executable_path() with _ -> "./") in if Sys.os_type = "Unix" then @@ -206,17 +214,22 @@ module Setup = struct let lib_path = Filename.concat prefix_path "lib" in let share_path = Filename.concat prefix_path "share" in [ - ""; - Path.add_trailing_slash (Filename.concat share_path "haxe/std"); - Path.add_trailing_slash (Filename.concat lib_path "haxe/std"); - Path.add_trailing_slash (Filename.concat base_path "std"); + (Path.add_trailing_slash (Filename.concat share_path "haxe/std"),Std); + (Path.add_trailing_slash (Filename.concat lib_path "haxe/std"),Std); + (Path.add_trailing_slash (Filename.concat base_path "std"),Std); ] else [ - ""; - Path.add_trailing_slash (Filename.concat base_path "std"); + (Path.add_trailing_slash (Filename.concat base_path "std"),Std); ] + let init_std_class_paths com = + com.class_paths#add com.empty_class_path; + List.iter (fun (s,scope) -> + let cp = new ClassPath.directory_class_path s scope in + com.class_paths#add cp + ) (List.rev (get_std_class_paths ())) + let setup_common_context ctx = let com = ctx.com in ctx.com.print <- ctx.comm.write_out; @@ -256,8 +269,7 @@ module Setup = struct ) (filter_messages false (fun _ -> true)))); com.filter_messages <- (fun predicate -> (ctx.messages <- (List.rev (filter_messages true predicate)))); com.run_command <- run_command ctx; - com.class_path <- get_std_class_paths (); - com.std_path <- List.filter (fun p -> ExtString.String.ends_with p "std/" || ExtString.String.ends_with p "std\\") com.class_path + init_std_class_paths com end @@ -530,7 +542,7 @@ module HighLevel = struct if l = "" then acc else if l.[0] <> '-' then - "-cp" :: l :: acc + "-libcp" :: l :: acc else match (try ExtString.String.split l " " with _ -> l, "") with | ("-L",dir) -> "--neko-lib-path" :: (String.sub l 3 (String.length l - 3)) :: acc diff --git a/src/compiler/displayProcessing.ml b/src/compiler/displayProcessing.ml index aa25ae6008c..29e1fccbf46 100644 --- a/src/compiler/displayProcessing.ml +++ b/src/compiler/displayProcessing.ml @@ -121,6 +121,7 @@ let process_display_file com actx = let rec loop = function | [] -> None | cp :: l -> + let cp = cp#path in let cp = (if cp = "" then "./" else cp) in let c = Path.add_trailing_slash (Path.get_real_path cp) in let clen = String.length c in @@ -135,7 +136,7 @@ let process_display_file com actx = end else loop l in - loop com.class_path + loop com.class_paths#as_list in match com.display.dms_display_file_policy with | DFPNo -> @@ -223,7 +224,7 @@ let load_display_module_in_macro tctx display_file_dot_path clear = match displa let load_display_file_standalone (ctx : Typecore.typer) file = let com = ctx.com in - let pack,decls = TypeloadParse.parse_module_file com file null_pos in + let pack,decls = TypeloadParse.parse_module_file com (ClassPaths.create_resolved_file file ctx.com.empty_class_path) null_pos in let path = Path.FilePath.parse file in let name = match path.file_name with | None -> "?DISPLAY" @@ -236,7 +237,7 @@ let load_display_file_standalone (ctx : Typecore.typer) file = let parts = ExtString.String.nsplit dir (if path.backslash then "\\" else "/") in let parts = List.rev (ExtList.List.drop (List.length pack) (List.rev parts)) in let dir = ExtString.String.join (if path.backslash then "\\" else "/") parts in - com.class_path <- dir :: com.class_path + com.class_paths#add (new ClassPath.directory_class_path dir User) end; ignore(TypeloadModule.type_module ctx (pack,name) file ~dont_check_path:true decls null_pos) @@ -318,7 +319,7 @@ let process_global_display_mode com tctx = let symbols = let l = cs#get_context_files ((Define.get_signature com.defines) :: (match com.get_macros() with None -> [] | Some com -> [Define.get_signature com.defines])) in List.fold_left (fun acc (file_key,cfile) -> - let file = cfile.c_file_path in + let file = cfile.c_file_path.file in if (filter <> None || DisplayPosition.display_position#is_in_file (com.file_keys#get file)) then (file,DocumentSymbols.collect_module_symbols (Some (file,get_module_name_of_cfile file cfile)) (filter = None) (cfile.c_package,cfile.c_decls)) :: acc else diff --git a/src/compiler/messageReporting.ml b/src/compiler/messageReporting.ml index 8bd6e986367..df09beae28b 100644 --- a/src/compiler/messageReporting.ml +++ b/src/compiler/messageReporting.ml @@ -54,13 +54,13 @@ let resolve_source file l1 p1 l2 p2 = List.rev !lines let resolve_file ctx f = - let ext = Common.extension f in - let second_ext = Common.extension (Common.remove_extension f) in - let platform_ext = "." ^ (platform_name_macro ctx) in - if platform_ext = second_ext then - (Common.remove_extension (Common.remove_extension f)) ^ ext - else - f + let ext = StringHelper.extension f in + let second_ext = StringHelper.extension (StringHelper.remove_extension f) in + let platform_ext = "." ^ (platform_name_macro ctx) in + if platform_ext = second_ext then + (StringHelper.remove_extension (StringHelper.remove_extension f)) ^ ext + else + f let error_printer file line = Printf.sprintf "%s:%d:" file line diff --git a/src/compiler/server.ml b/src/compiler/server.ml index 9160a7d71b9..ac5f0526f74 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -41,9 +41,10 @@ let check_display_flush ctx f_otherwise = match ctx.com.json_out with let current_stdin = ref None -let parse_file cs com file p = +let parse_file cs com (rfile : ClassPaths.resolved_file) p = let cc = CommonCache.get_cache com in - let ffile = Path.get_full_path file + let file = rfile.file in + let ffile = Path.get_full_path rfile.file and fkey = com.file_keys#get file in let is_display_file = DisplayPosition.display_position#is_in_file (com.file_keys#get ffile) in match is_display_file, !current_stdin with @@ -57,7 +58,7 @@ let parse_file cs com file p = if cfile.c_time <> ftime then raise Not_found; Parser.ParseSuccess((cfile.c_package,cfile.c_decls),false,cfile.c_pdi) with Not_found -> - let parse_result = TypeloadParse.parse_file com file p in + let parse_result = TypeloadParse.parse_file com rfile p in let info,is_unusual = match parse_result with | ParseError(_,_,_) -> "not cached, has parse error",true | ParseSuccess(data,is_display_file,pdi) -> @@ -65,7 +66,7 @@ let parse_file cs com file p = if pdi.pd_errors <> [] then "not cached, is display file with parse errors",true else if com.display.dms_per_file then begin - cc#cache_file fkey ffile ftime data pdi; + cc#cache_file fkey rfile ftime data pdi; "cached, is intact display file",true end else "not cached, is display file",true @@ -76,7 +77,7 @@ let parse_file cs com file p = let ident = Hashtbl.find Parser.special_identifier_files fkey in Printf.sprintf "not cached, using \"%s\" define" ident,true with Not_found -> - cc#cache_file fkey ffile ftime data pdi; + cc#cache_file fkey rfile ftime data pdi; "cached",false end in @@ -208,8 +209,9 @@ let get_changed_directories sctx (ctx : Typecore.typer) = with Unix.Unix_error _ -> () in - List.iter add_dir com.class_path; - List.iter add_dir (Path.find_directories (platform_name com.platform) true com.class_path); + let class_path_strings = com.class_paths#as_string_list in + List.iter add_dir class_path_strings; + List.iter add_dir (Path.find_directories (platform_name com.platform) true class_path_strings); ServerMessage.found_directories com "" !dirs; cs#add_directories sign !dirs ) :: sctx.delays; @@ -461,15 +463,16 @@ let after_target_init sctx ctx = ServerMessage.defines com ""; ServerMessage.signature com "" sign; ServerMessage.display_position com "" (DisplayPosition.display_position#get); + let class_path_strings = com.class_paths#as_string_list in try - if (Hashtbl.find sctx.class_paths sign) <> com.class_path then begin + if (Hashtbl.find sctx.class_paths sign) <> class_path_strings then begin ServerMessage.class_paths_changed com ""; - Hashtbl.replace sctx.class_paths sign com.class_path; + Hashtbl.replace sctx.class_paths sign class_path_strings; cs#clear_directories sign; (cs#get_context sign)#set_initialized false; end; with Not_found -> - Hashtbl.add sctx.class_paths sign com.class_path; + Hashtbl.add sctx.class_paths sign class_path_strings; () let after_compilation sctx ctx = diff --git a/src/context/common.ml b/src/context/common.ml index d468f494772..adeb921624b 100644 --- a/src/context/common.ml +++ b/src/context/common.ml @@ -350,8 +350,8 @@ type context = { mutable foptimize : bool; mutable platform : platform; mutable config : platform_config; - mutable std_path : string list; - mutable class_path : string list; + empty_class_path : ClassPath.class_path; + class_paths : ClassPaths.class_paths; mutable main_class : path option; mutable package_rules : (string,package_rule) PMap.t; mutable report_mode : report_mode; @@ -378,12 +378,10 @@ type context = { mutable global_metadata : (string list * metadata_entry * (bool * bool * bool)) list; shared : shared_context; display_information : display_information; - file_lookup_cache : (string,string option) lookup; file_keys : file_keys; mutable file_contents : (Path.UniqueKey.t * string option) list; - readdir_cache : (string * string,(string array) option) lookup; parser_cache : (string,(type_def * pos) list) lookup; - module_to_file : (path,string) lookup; + module_to_file : (path,ClassPaths.resolved_file) lookup; cached_macros : (path * string,(((string * bool * t) list * t * tclass * Type.tclass_field) * module_def)) lookup; stored_typed_exprs : (int, texpr) lookup; overload_cache : ((path * string),(Type.t * tclass_field) list) lookup; @@ -809,8 +807,8 @@ let create compilation_step cs version args display_mode = print = (fun s -> print_string s; flush stdout); run_command = Sys.command; run_command_args = (fun s args -> com.run_command (Printf.sprintf "%s %s" s (String.concat " " args))); - std_path = []; - class_path = []; + empty_class_path = new ClassPath.directory_class_path "" User; + class_paths = new ClassPaths.class_paths; main_class = None; package_rules = PMap.empty; file = ""; @@ -856,10 +854,8 @@ let create compilation_step cs version args display_mode = tarray = (fun _ -> die "Could not locate class Array (was it redefined?)" __LOC__); }; std = null_class; - file_lookup_cache = new hashtbl_lookup; file_keys = new file_keys; file_contents = []; - readdir_cache = new hashtbl_lookup; module_to_file = new hashtbl_lookup; stored_typed_exprs = new hashtbl_lookup; cached_macros = new hashtbl_lookup; @@ -910,13 +906,13 @@ let clone com is_macro_context = }; native_libs = create_native_libs(); is_macro_context = is_macro_context; - file_lookup_cache = new hashtbl_lookup; - readdir_cache = new hashtbl_lookup; parser_cache = new hashtbl_lookup; module_to_file = new hashtbl_lookup; overload_cache = new hashtbl_lookup; module_lut = new module_lut; std = null_class; + empty_class_path = new ClassPath.directory_class_path "" User; + class_paths = new ClassPaths.class_paths; } let file_time file = Extc.filetime file @@ -1062,104 +1058,8 @@ let platform_name_macro com = if defined com Define.Macro then "macro" else platform_name com.platform -let remove_extension file = - try String.sub file 0 (String.rindex file '.') - with Not_found -> file - -let extension file = - try - let dot_pos = String.rindex file '.' in - String.sub file dot_pos (String.length file - dot_pos) - with Not_found -> file - -let cache_directory ctx class_path dir f_dir = - let platform_ext = "." ^ (platform_name_macro ctx) - and is_loading_core_api = defined ctx Define.CoreApi in - let dir_listing = - try Some (Sys.readdir dir); - with Sys_error _ -> None - in - ctx.readdir_cache#add (class_path,dir) dir_listing; - (* - This function is invoked for each file in the `dir`. - Each file is checked if it's specific for current platform - (e.g. ends with `.js.hx` while compiling for JS). - If it's not platform-specific: - Check the lookup cache and if the file is not there store full file path in the cache. - If the file is platform-specific: - Store the full file path in the lookup cache probably replacing the cached path to a - non-platform-specific file. - *) - let prepare_file file_own_name = - let relative_to_classpath = if f_dir = "." then file_own_name else f_dir ^ "/" ^ file_own_name in - (* `representation` is how the file is referenced to. E.g. when it's deduced from a module path. *) - let is_platform_specific,representation = - (* Platform specific file extensions are not allowed for loading @:coreApi types. *) - if is_loading_core_api then - false,relative_to_classpath - else begin - let ext = extension relative_to_classpath in - let second_ext = extension (remove_extension relative_to_classpath) in - (* The file contains double extension and the secondary one matches current platform *) - if platform_ext = second_ext then - true,(remove_extension (remove_extension relative_to_classpath)) ^ ext - else - false,relative_to_classpath - end - in - (* - Store current full path for `representation` if - - we're loading @:coreApi - - or this is a platform-specific file for `representation` - - this `representation` was never found before - *) - if is_loading_core_api || is_platform_specific || not (ctx.file_lookup_cache#mem representation) then begin - let full_path = if dir = "." then file_own_name else dir ^ "/" ^ file_own_name in - ctx.file_lookup_cache#add representation (Some full_path); - end - in - Option.may (Array.iter prepare_file) dir_listing - -let find_file ctx ?(class_path=ctx.class_path) f = - try - match ctx.file_lookup_cache#find f with - | None -> raise Exit - | Some f -> f - with - | Exit -> - raise Not_found - | Not_found when Path.is_absolute_path f -> - ctx.file_lookup_cache#add f (Some f); - f - | Not_found -> - let f_dir = Filename.dirname f in - let rec loop had_empty = function - | [] when had_empty -> raise Not_found - | [] -> loop true [""] - | p :: l -> - let file = p ^ f in - let dir = Filename.dirname file in - (* If we have seen the directory before, we can assume that the file isn't in there because the else case - below would have added it to `file_lookup_cache`, which we check before we get here. *) - if ctx.readdir_cache#mem (p,dir) then - loop (had_empty || p = "") l - else begin - cache_directory ctx p dir f_dir; - (* Caching might have located the file we're looking for, so check the lookup cache again. *) - try - begin match ctx.file_lookup_cache#find f with - | Some f -> f - | None -> raise Not_found - end - with Not_found -> - loop (had_empty || p = "") l - end - in - let r = try Some (loop false class_path) with Not_found -> None in - ctx.file_lookup_cache#add f r; - match r with - | None -> raise Not_found - | Some f -> f +let find_file ctx f = + (ctx.class_paths#find_file f).file (* let find_file ctx f = let timer = Timer.timer ["find_file"] in diff --git a/src/context/commonCache.ml b/src/context/commonCache.ml index 08be299978b..dba70b7ec74 100644 --- a/src/context/commonCache.ml +++ b/src/context/commonCache.ml @@ -84,7 +84,7 @@ let rec cache_context cs com = let maybe_add_context_sign cs com desc = let sign = Define.get_signature com.defines in - ignore(cs#add_info sign desc com.platform com.class_path com.defines) + ignore(cs#add_info sign desc com.platform com.class_paths com.defines) let lock_signature com name = let cs = com.cs in diff --git a/src/context/display/diagnostics.ml b/src/context/display/diagnostics.ml index 5a01397dda9..ceae6d3ffe1 100644 --- a/src/context/display/diagnostics.ml +++ b/src/context/display/diagnostics.ml @@ -121,7 +121,7 @@ let collect_diagnostics dctx com = ParserEntry.is_true (ParserEntry.eval defines e) in Hashtbl.iter (fun file_key cfile -> - if DisplayPosition.display_position#is_in_file (com.file_keys#get cfile.c_file_path) then begin + if DisplayPosition.display_position#is_in_file (com.file_keys#get cfile.c_file_path.file) then begin let dead_blocks = cfile.c_pdi.pd_dead_blocks in let dead_blocks = List.filter (fun (_,e) -> not (is_true display_defines e)) dead_blocks in try diff --git a/src/context/display/displayJson.ml b/src/context/display/displayJson.ml index 772fb15662b..cf49c512267 100644 --- a/src/context/display/displayJson.ml +++ b/src/context/display/displayJson.ml @@ -355,7 +355,7 @@ let handler = let key = hctx.com.file_keys#get file in let cs = hctx.display#get_cs in List.iter (fun cc -> - Hashtbl.replace cc#get_removed_files key file + Hashtbl.replace cc#get_removed_files key (ClassPaths.create_resolved_file file hctx.com.empty_class_path) ) cs#get_contexts; hctx.send_result (jstring file); ); @@ -366,7 +366,7 @@ let handler = let files = List.sort (fun (file1,_) (file2,_) -> compare file1 file2) files in let files = List.map (fun (fkey,cfile) -> jobject [ - "file",jstring cfile.c_file_path; + "file",jstring cfile.c_file_path.file; "time",jfloat cfile.c_time; "pack",jstring (String.concat "." cfile.c_package); "moduleName",jopt jstring cfile.c_module_name; diff --git a/src/context/display/displayPath.ml b/src/context/display/displayPath.ml index 6b233825fe5..a10ab00bf7d 100644 --- a/src/context/display/displayPath.ml +++ b/src/context/display/displayPath.ml @@ -32,7 +32,8 @@ module TypePathHandler = struct Not_found -> p) | _ -> p ) in - List.iter (fun path -> + com.class_paths#iter (fun path -> + let path = path#path in let dir = path ^ String.concat "/" p in let r = (try Sys.readdir dir with _ -> [||]) in Array.iter (fun f -> @@ -59,7 +60,7 @@ module TypePathHandler = struct if String.length c < 2 || String.sub c (String.length c - 2) 2 <> "__" then classes := c :: !classes; end; ) r; - ) com.class_path; + ); let process_lib lib = List.iter (fun (path,name) -> if path = p then classes := name :: !classes else diff --git a/src/context/display/displayToplevel.ml b/src/context/display/displayToplevel.ml index f5959f19e3e..ea1f31a7446 100644 --- a/src/context/display/displayToplevel.ml +++ b/src/context/display/displayToplevel.ml @@ -111,8 +111,12 @@ let explore_class_paths com timer class_paths recursive f_pack f_module = let cs = com.cs in let t = Timer.timer (timer @ ["class path exploration"]) in let checked = Hashtbl.create 0 in - let tasks = List.map (fun dir -> - new explore_class_path_task com checked recursive f_pack f_module dir [] + let tasks = ExtList.List.filter_map (fun path -> + match path#get_directory_path with + | Some path -> + Some (new explore_class_path_task com checked recursive f_pack f_module path []) + | None -> + None ) class_paths in let task = new arbitrary_task ["explore"] 50 (fun () -> List.iter (fun task -> task#run) tasks @@ -121,10 +125,10 @@ let explore_class_paths com timer class_paths recursive f_pack f_module = t() let read_class_paths com timer = - explore_class_paths com timer (List.filter ((<>) "") com.class_path) true (fun _ -> ()) (fun file path -> + explore_class_paths com timer (com.class_paths#filter (fun cp -> cp#path <> "")) true (fun _ -> ()) (fun file path -> (* Don't parse the display file as that would maybe overwrite the content from stdin with the file contents. *) if not (DisplayPosition.display_position#is_in_file (com.file_keys#get file)) then begin - let file,_,pack,_ = Display.parse_module' com path Globals.null_pos in + let rfile,_,pack,_ = Display.parse_module' com path Globals.null_pos in if pack <> fst path then begin let file_key = com.file_keys#get file in (CommonCache.get_cache com)#remove_file_for_real file_key @@ -475,7 +479,7 @@ let collect ctx tk with_type sort = | s :: sl -> add_package (List.rev sl,s) in List.iter (fun ((file_key,cfile),_) -> - let module_name = CompilationCache.get_module_name_of_cfile cfile.c_file_path cfile in + let module_name = CompilationCache.get_module_name_of_cfile cfile.c_file_path.file cfile in let dot_path = s_type_path (cfile.c_package,module_name) in (* In legacy mode we only show toplevel types. *) if is_legacy_completion && cfile.c_package <> [] then begin diff --git a/src/context/display/syntaxExplorer.ml b/src/context/display/syntaxExplorer.ml index 471f65101a0..bc6c1328cc3 100644 --- a/src/context/display/syntaxExplorer.ml +++ b/src/context/display/syntaxExplorer.ml @@ -167,7 +167,7 @@ let explore_uncached_modules tctx cs symbols = let modules = cc#get_modules in let t = Timer.timer ["display";"references";"candidates"] in let acc = Hashtbl.fold (fun file_key cfile acc -> - let module_name = get_module_name_of_cfile cfile.c_file_path cfile in + let module_name = get_module_name_of_cfile cfile.c_file_path.file cfile in if Hashtbl.mem modules (cfile.c_package,module_name) then acc else try diff --git a/src/context/typecore.ml b/src/context/typecore.ml index ea3ce9ee2e7..18d00bf6bea 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -324,7 +324,7 @@ let add_local ctx k n t p = begin try let v' = PMap.find n ctx.locals in (* ignore std lib *) - if not (List.exists (ExtLib.String.starts_with p.pfile) ctx.com.std_path) then begin + if not (List.exists (fun path -> ExtLib.String.starts_with p.pfile (path#path)) ctx.com.class_paths#get_std_paths) then begin warning ctx WVarShadow "This variable shadows a previously declared variable" p; warning ~depth:1 ctx WVarShadow (compl_msg "Previous variable was here") v'.v_pos end @@ -692,18 +692,7 @@ let safe_mono_close ctx m p = raise_or_display ctx l p let relative_path ctx file = - let slashes path = String.concat "/" (ExtString.String.nsplit path "\\") in - let fpath = slashes (Path.get_full_path file) in - let fpath_lower = String.lowercase_ascii fpath in - let flen = String.length fpath_lower in - let rec loop = function - | [] -> file - | path :: l -> - let spath = String.lowercase_ascii (slashes path) in - let slen = String.length spath in - if slen > 0 && slen < flen && String.sub fpath_lower 0 slen = spath then String.sub fpath slen (flen - slen) else loop l - in - loop ctx.com.Common.class_path + ctx.com.class_paths#relative_path file let mk_infos ctx p params = let file = if ctx.com.is_macro_context then p.pfile else if Common.defined ctx.com Define.AbsolutePath then Path.get_full_path p.pfile else relative_path ctx p.pfile in diff --git a/src/core/classPath.ml b/src/core/classPath.ml new file mode 100644 index 00000000000..2ad8ebb88b4 --- /dev/null +++ b/src/core/classPath.ml @@ -0,0 +1,62 @@ +type class_path_scope = + | Std + | StdTarget + | Lib + | User + +type file_kind = + | FFile + +class virtual class_path (path : string) (scope : class_path_scope) (file_kind : file_kind) = object(self) + method path = path; + method scope = scope; + method file_kind = file_kind; + + method virtual clone : class_path + method virtual clear_cache : unit + method virtual get_directory_path : string option + method virtual get_uncached_dir_listing : string -> (string * string array) option + method virtual dump : unit + + method is_std_path = match scope with + | Std -> true + | _ -> false + + method scope_string = match scope with + | Std -> "Std" + | StdTarget -> "StdTarget" + | Lib -> "Lib" + | User -> "User" +end + +class directory_class_path (path : string) (scope : class_path_scope) = object(self) + inherit class_path path scope FFile + + val readdir_cache = new Lookup.hashtbl_lookup + + method clear_cache = + readdir_cache#clear + + method get_directory_path = + Some path + + method clone = + new directory_class_path path scope + + method get_uncached_dir_listing (f : string) = + let file = path ^ f in + let dir = Filename.dirname file in + if readdir_cache#mem dir then + None + else begin + let dir_listing = + try Some (dir,Sys.readdir dir); + with Sys_error _ -> None + in + readdir_cache#add dir dir_listing; + dir_listing + end + + method dump = + print_endline (Printf.sprintf " dir %-9s: %s" (self#scope_string) path) +end \ No newline at end of file diff --git a/src/core/classPaths.ml b/src/core/classPaths.ml new file mode 100644 index 00000000000..d07238a7bc3 --- /dev/null +++ b/src/core/classPaths.ml @@ -0,0 +1,169 @@ +open StringHelper +open ClassPath + +type resolved_file = { + file : string; + class_path : class_path; +} + +let create_resolved_file file class_path = { + file; + class_path; +} + +class class_paths = object(self) + val mutable l = [] + val file_lookup_cache = new Lookup.hashtbl_lookup; + val mutable platform_ext = "" + val mutable is_loading_core_api = false + + method lock_context (platform_name : string) (core_api : bool) : unit = + platform_ext <- "." ^ platform_name; + is_loading_core_api <- core_api; + self#clear_cache + + method as_string_list = + List.map (fun cp -> cp#path) l + + method add (cp : class_path) = + l <- cp :: l; + file_lookup_cache#clear + + method push (cp : class_path) = + l <- l @ [cp]; + file_lookup_cache#clear + + method find (f : class_path -> bool) = + List.find f l + + method iter (f : class_path -> unit) = + List.iter f l + + method exists (f : class_path -> bool) = + List.exists f l + + method filter (f : class_path -> bool) = + List.filter f l + + method modify (f : class_path -> class_path list) (cpl : class_path list) = + let rec loop acc l = match l with + | [] -> + List.rev acc + | cp :: l -> + let cpl = f cp in + loop (cpl @ acc) l + in + l <- loop [] cpl; + file_lookup_cache#clear + + method modify_inplace (f : class_path -> class_path list) = + self#modify f l + + method get_std_paths = + self#filter (fun cp -> cp#is_std_path) + + method as_list = + l + + method clear_cache = + file_lookup_cache#clear; + List.iter (fun cp -> cp#clear_cache) l + + method cache_directory (cp : class_path) (dir : string) (f_search : string) (dir_listing : string array) = + (* + This function is invoked for each file in the `dir`. + Each file is checked if it's specific for current platform + (e.g. ends with `.js.hx` while compiling for JS). + If it's not platform-specific: + Check the lookup cache and if the file is not there store full file path in the cache. + If the file is platform-specific: + Store the full file path in the lookup cache probably replacing the cached path to a + non-platform-specific file. + *) + let found = ref None in + let f_dir = Filename.dirname f_search in + let prepare_file file_own_name = + let relative_to_classpath = if f_dir = "." then file_own_name else f_dir ^ "/" ^ file_own_name in + (* `representation` is how the file is referenced to. E.g. when it's deduced from a module path. *) + let is_platform_specific,representation = + (* Platform specific file extensions are not allowed for loading @:coreApi types. *) + if is_loading_core_api then + false,relative_to_classpath + else begin + let ext = extension relative_to_classpath in + let second_ext = extension (remove_extension relative_to_classpath) in + (* The file contains double extension and the secondary one matches current platform *) + if platform_ext = second_ext then + true,(remove_extension (remove_extension relative_to_classpath)) ^ ext + else + false,relative_to_classpath + end + in + (* + Store current full path for `representation` if + - we're loading @:coreApi + - or this is a platform-specific file for `representation` + - this `representation` was never found before + *) + if is_loading_core_api || is_platform_specific || not (file_lookup_cache#mem representation) then begin + let full_path = if dir = "." then file_own_name else dir ^ "/" ^ file_own_name in + let full_path = Some(create_resolved_file full_path cp) in + file_lookup_cache#add representation full_path; + if representation = f_search then found := full_path + end + in + Array.iter prepare_file dir_listing; + !found + + method find_file_noraise (f : string) = + try + match file_lookup_cache#find f with + | None -> + None + | Some f -> + Some f + with Not_found -> + let rec loop = function + | [] -> + None + | cp :: l -> + begin match cp#get_uncached_dir_listing f with + | None -> + loop l + | Some(dir,dir_listing) -> + match self#cache_directory cp dir f dir_listing with + | Some f -> + Some f + | None -> + loop l + end + in + let r = loop l in + file_lookup_cache#add f r; + r + + method find_file (f : string) = + match self#find_file_noraise f with + | None -> raise Not_found + | Some f -> f + + method relative_path file = + let slashes path = String.concat "/" (ExtString.String.nsplit path "\\") in + let fpath = slashes (Path.get_full_path file) in + let fpath_lower = String.lowercase_ascii fpath in + let flen = String.length fpath_lower in + let rec loop = function + | [] -> + file + | path :: l -> + let path = path#path in + let spath = String.lowercase_ascii (slashes path) in + let slen = String.length spath in + if slen > 0 && slen < flen && String.sub fpath_lower 0 slen = spath then String.sub fpath slen (flen - slen) else loop l + in + loop l + + method dump = + print_endline (Printf.sprintf "Class paths for %s%s:" platform_ext (if is_loading_core_api then " (coreApi)" else "")); + List.iter (fun cp -> cp#dump) l +end diff --git a/src/core/stringHelper.ml b/src/core/stringHelper.ml index ab6c57df5cd..824e8e1aa99 100644 --- a/src/core/stringHelper.ml +++ b/src/core/stringHelper.ml @@ -57,4 +57,15 @@ let escape_res_name name allowed = else if List.mem chr allowed then Char.escaped chr else - "-x" ^ (string_of_int (Char.code chr))) name \ No newline at end of file + "-x" ^ (string_of_int (Char.code chr))) name + +let remove_extension file = + try String.sub file 0 (String.rindex file '.') + with Not_found -> file + +let extension file = + try + let dot_pos = String.rindex file '.' in + String.sub file dot_pos (String.length file - dot_pos) + with Not_found -> + file \ No newline at end of file diff --git a/src/generators/gencpp.ml b/src/generators/gencpp.ml index 4d034be9ad0..a06b1a77963 100644 --- a/src/generators/gencpp.ml +++ b/src/generators/gencpp.ml @@ -1322,17 +1322,7 @@ exception PathFound of string;; let strip_file ctx file = (match Common.defined ctx Common.Define.AbsolutePath with | true -> file - | false -> let flen = String.length file in - (* Not quite right - should probably test is file exists *) - try - List.iter (fun path -> - let plen = String.length path in - if (flen>plen && path=(String.sub file 0 plen )) - then raise (PathFound (String.sub file plen (flen-plen)) ) ) - (ctx.class_path @ ctx.std_path); - file; - with PathFound tail -> - tail) + | false -> ctx.class_paths#relative_path file) ;; let with_debug ctx metadata run = @@ -8679,7 +8669,10 @@ let generate_source ctx = | "true" | "sys" | "dce" | "cpp" | "debug" -> (); | _ -> cmd := !cmd @ [Printf.sprintf "-D%s=\"%s\"" name (escape_command value)]; ) common_ctx.defines.values; - List.iter (fun path -> cmd := !cmd @ [Printf.sprintf "-I%s" (escape_command path)]) common_ctx.class_path; + common_ctx.class_paths#iter (fun path -> + let path = path#path in + cmd := !cmd @ [Printf.sprintf "-I%s" (escape_command path)] + ); common_ctx.print ("haxelib " ^ (String.concat " " !cmd) ^ "\n"); if common_ctx.run_command_args "haxelib" !cmd <> 0 then failwith "Build failed"; Sys.chdir old_dir; diff --git a/src/generators/genhl.ml b/src/generators/genhl.ml index b00adbdf181..1e53ac3ab32 100644 --- a/src/generators/genhl.ml +++ b/src/generators/genhl.ml @@ -329,11 +329,12 @@ let make_debug ctx arr = | false -> try (* lookup relative path *) let len = String.length p.pfile in - let base = List.find (fun path -> + let base = ctx.com.class_paths#find (fun path -> + let path = path#path in let l = String.length path in len > l && String.sub p.pfile 0 l = path - ) ctx.com.Common.class_path in - let l = String.length base in + ) in + let l = String.length base#path in String.sub p.pfile l (len - l) with Not_found -> p.pfile diff --git a/src/generators/genneko.ml b/src/generators/genneko.ml index 3830fc0ac3e..016771f42bc 100644 --- a/src/generators/genneko.ml +++ b/src/generators/genneko.ml @@ -57,11 +57,12 @@ let pos ctx p = | false -> try (* lookup relative path *) let len = String.length p.pfile in - let base = List.find (fun path -> + let base = ctx.com.class_paths#find (fun path -> + let path = path#path in let l = String.length path in len > l && String.sub p.pfile 0 l = path - ) ctx.com.Common.class_path in - let l = String.length base in + ) in + let l = String.length base#path in String.sub p.pfile l (len - l) with Not_found -> p.pfile diff --git a/src/macro/macroApi.ml b/src/macro/macroApi.ml index 6b2f796ce20..60617365931 100644 --- a/src/macro/macroApi.ml +++ b/src/macro/macroApi.ml @@ -1845,7 +1845,7 @@ let macro_api ccom get_api = vnull ); "class_path", vfun0 (fun() -> - encode_array (List.map encode_string (ccom()).class_path); + encode_array (List.map encode_string (ccom()).class_paths#as_string_list); ); "resolve_path", vfun1 (fun file -> let file = decode_string file in @@ -2068,8 +2068,7 @@ let macro_api ccom get_api = ); "flush_disk_cache", vfun0 (fun () -> let com = (get_api()).get_com() in - com.file_lookup_cache#clear; - com.readdir_cache#clear; + com.class_paths#clear_cache; vnull ); "get_pos_infos", vfun1 (fun p -> @@ -2168,15 +2167,15 @@ let macro_api ccom get_api = "add_class_path", vfun1 (fun cp -> let com = ccom() in let cp = decode_string cp in - let cp = Path.add_trailing_slash cp in - com.class_path <- cp :: com.class_path; + let path = Path.add_trailing_slash cp in + let cp = new ClassPath.directory_class_path path User in + com.class_paths#add cp; (match com.get_macros() with | Some(mcom) -> - mcom.class_path <- cp :: mcom.class_path; + mcom.class_paths#add cp#clone; | None -> ()); - com.file_lookup_cache#clear; - com.readdir_cache#clear; + com.class_paths#clear_cache; vnull ); "add_native_lib", vfun1 (fun file -> @@ -2253,7 +2252,7 @@ let macro_api ccom get_api = "foptimize", vbool com.foptimize; "platform", encode_platform com.platform; "platformConfig", encode_platform_config com.config; - "stdPath", encode_array (List.map encode_string com.std_path); + "stdPath", encode_array (List.map (fun path -> encode_string path#path) com.class_paths#get_std_paths); "mainClass", (match com.main_class with None -> vnull | Some path -> encode_path path); "packageRules", encode_string_map encode_package_rule com.package_rules; ] diff --git a/src/optimization/dce.ml b/src/optimization/dce.ml index 03d3ba6a4c9..d9a0b410116 100644 --- a/src/optimization/dce.ml +++ b/src/optimization/dce.ml @@ -868,7 +868,7 @@ let run com main mode = com = com; full = full; dependent_types = Hashtbl.create 0; - std_dirs = if full then [] else List.map Path.get_full_path com.std_path; + std_dirs = if full then [] else List.map (fun path -> Path.get_full_path path#path) com.class_paths#get_std_paths; debug = Common.defined com Define.DceDebug; added_fields = []; follow_expr = expr; diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index 2a34d2f5977..a9b0252c67d 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -705,9 +705,20 @@ let create_macro_context com = com2.main_class <- None; (* Inherit most display settings, but require normal typing. *) com2.display <- {com.display with dms_kind = DMNone; dms_full_typing = true; dms_force_macro_typing = true; dms_inline = true; }; - com2.class_path <- List.filter (fun s -> not (ExtString.String.exists s "/_std/")) com2.class_path; + com2.class_paths#lock_context "macro" false; let name = platform_name Eval in - com2.class_path <- List.map (fun p -> p ^ name ^ "/_std/") com2.std_path @ com2.class_path; + let eval_std = ref None in + com2.class_paths#modify (fun cp -> match cp#scope with + | StdTarget -> + [] + | Std -> + eval_std := Some (new ClassPath.directory_class_path (cp#path ^ name ^ "/_std/") StdTarget); + [cp#clone] + | _ -> + [cp#clone] + ) com.class_paths#as_list; + (* Eval _std must be in front so we don't look into hxnodejs or something. *) + com2.class_paths#add (Option.get !eval_std); let defines = adapt_defines_to_macro_context com2.defines; in com2.defines.values <- defines.values; com2.defines.defines_signature <- None; diff --git a/src/typing/typeload.ml b/src/typing/typeload.ml index 80e4ace23be..135f988ca60 100644 --- a/src/typing/typeload.ml +++ b/src/typing/typeload.ml @@ -804,7 +804,13 @@ let load_core_class ctx c = Common.define com2 Define.Sys; Define.raw_define_value com2.defines "target.threaded" "true"; (* hack because we check this in sys.thread classes *) if ctx.com.is_macro_context then Common.define com2 Define.Macro; - com2.class_path <- ctx.com.std_path; + com2.class_paths#lock_context (platform_name_macro ctx.com) true; + com2.class_paths#modify (fun cp -> match cp#scope with + | Std -> + [cp#clone] + | _ -> + [] + ) ctx.com.class_paths#as_list; if com2.display.dms_check_core_api then com2.display <- {com2.display with dms_check_core_api = false}; CommonCache.lock_signature com2 "load_core_class"; let ctx2 = !create_context_ref com2 ctx.g.macros in diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index 7fedaf63dcc..c51c7d7980f 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -295,7 +295,7 @@ module ModuleLevel = struct r with Not_found -> if Sys.file_exists path then begin - let _,r = match !TypeloadParse.parse_hook com path p with + let _,r = match !TypeloadParse.parse_hook com (ClassPaths.create_resolved_file path ctx.com.empty_class_path) p with | ParseSuccess(data,_,_) -> data | ParseError(_,(msg,p),_) -> Parser.error msg p in @@ -790,7 +790,8 @@ let load_module' ctx g m p = let is_extern = ref false in let file, decls = try (* Try parsing *) - TypeloadParse.parse_module ctx m p + let rfile,decls = TypeloadParse.parse_module ctx m p in + rfile.file,decls with Not_found -> (* Nothing to parse, try loading extern type *) let rec loop = function diff --git a/src/typing/typeloadParse.ml b/src/typing/typeloadParse.ml index 29f99f48f5a..eef20a8e975 100644 --- a/src/typing/typeloadParse.ml +++ b/src/typing/typeloadParse.ml @@ -58,8 +58,8 @@ let parse_file_from_lexbuf com file p lexbuf = let parse_file_from_string com file p string = parse_file_from_lexbuf com file p (Sedlexing.Utf8.from_string string) -let parse_file com file p = - let file_key = com.file_keys#get file in +let parse_file com rfile p = + let file_key = com.file_keys#get rfile.ClassPaths.file in let contents = match com.file_contents with | [] when (Common.defined com Define.DisplayStdin) && DisplayPosition.display_position#is_in_file file_key -> let s = Std.input_all stdin in @@ -73,10 +73,13 @@ let parse_file com file p = match contents with | Some s -> - parse_file_from_string com file p s + parse_file_from_string com rfile.file p s | _ -> - let ch = try open_in_bin file with _ -> raise_typing_error ("Could not open " ^ file) p in - Std.finally (fun() -> close_in ch) (parse_file_from_lexbuf com file p) (Sedlexing.Utf8.from_channel ch) + match rfile.class_path#file_kind with + | FFile -> + let file = rfile.file in + let ch = try open_in_bin file with _ -> raise_typing_error ("Could not open " ^ file) p in + Std.finally (fun() -> close_in ch) (parse_file_from_lexbuf com file p) (Sedlexing.Utf8.from_channel ch) let parse_hook = ref parse_file @@ -95,21 +98,23 @@ let resolve_module_file com m remap p = String.concat "/" (x :: l) ^ "/" ^ name ) ^ ".hx" in - let file = Common.find_file com compose_path in - let file = (match ExtString.String.lowercase (snd m) with - | "con" | "aux" | "prn" | "nul" | "com1" | "com2" | "com3" | "lpt1" | "lpt2" | "lpt3" when Sys.os_type = "Win32" -> - (* these names are reserved by the OS - old DOS legacy, such files cannot be easily created but are reported as visible *) - if (try (Unix.stat file).Unix.st_size with _ -> 0) > 0 then file else raise Not_found - | _ -> file - ) in + let rfile = com.class_paths#find_file compose_path in + begin match rfile.class_path#file_kind with + | FFile -> (match ExtString.String.lowercase (snd m) with + | "con" | "aux" | "prn" | "nul" | "com1" | "com2" | "com3" | "lpt1" | "lpt2" | "lpt3" when Sys.os_type = "Win32" -> + (* these names are reserved by the OS - old DOS legacy, such files cannot be easily created but are reported as visible *) + if (try (Unix.stat rfile.file).Unix.st_size with _ -> 0) > 0 then () else raise Not_found + | _ -> + ()) + end; (* if we try to load a std.xxxx class and resolve a real std file, the package name is not valid, ignore *) (match fst m with | "std" :: _ -> - let file_key = com.file_keys#get file in - if List.exists (fun path -> Path.UniqueKey.starts_with file_key (com.file_keys#get path)) com.std_path then raise Not_found; + let file_key = com.file_keys#get rfile.file in + if List.exists (fun path -> Path.UniqueKey.starts_with file_key (com.file_keys#get path#path)) com.class_paths#get_std_paths then raise Not_found; | _ -> ()); if !forbid then begin - let parse_result = (!parse_hook) com file p in + let parse_result = (!parse_hook) com rfile p in let rec loop decls = match decls with | ((EImport _,_) | (EUsing _,_)) :: decls -> loop decls | (EClass d,_) :: _ -> d.d_meta @@ -128,15 +133,15 @@ let resolve_module_file com m remap p = raise (Forbid_package ((x,m,p),[],platform_name_macro com)); end; end; - file + rfile let resolve_module_file com m remap p = try com.module_to_file#find m with Not_found -> - let file = resolve_module_file com m remap p in - com.module_to_file#add m file; - file + let rfile = resolve_module_file com m remap p in + com.module_to_file#add m rfile; + rfile (* let resolve_module_file com m remap p = let timer = Timer.timer ["typing";"resolve_module_file"] in @@ -287,20 +292,20 @@ let parse_module_file com file p = let parse_module' com m p = let remap = ref (fst m) in - let file = resolve_module_file com m remap p in - let pack,decls = parse_module_file com file p in - file,remap,pack,decls + let rfile = resolve_module_file com m remap p in + let pack,decls = parse_module_file com rfile p in + rfile,remap,pack,decls let parse_module ctx m p = - let file,remap,pack,decls = parse_module' ctx.com m p in + let rfile,remap,pack,decls = parse_module' ctx.com m p in if pack <> !remap then begin let spack m = if m = [] then "`package;`" else "`package " ^ (String.concat "." m) ^ ";`" in if p == null_pos then display_error ctx.com ("Invalid commandline class : " ^ s_type_path m ^ " should be " ^ s_type_path (pack,snd m)) p else - display_error ctx.com (spack pack ^ " in " ^ file ^ " should be " ^ spack (fst m)) {p with pmax = p.pmin} + display_error ctx.com (spack pack ^ " in " ^ rfile.file ^ " should be " ^ spack (fst m)) {p with pmax = p.pmin} end; - file, if !remap <> fst m then + rfile, if !remap <> fst m then (* build typedefs to redirect to real package *) List.rev (List.fold_left (fun acc (t,p) -> let build f d =