diff --git a/CHANGES.md b/CHANGES.md index bbb87043..6c024c22 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -46,6 +46,9 @@ next - Fix a bug where Dune ignored previous occurences of duplicated fields (#779, @diml) +- Allow setting custom build directories using the `--build-dir` flag or + `DUNE_BUILD_DIR` environment variable (#846, fix #291, @diml @rgrinberg) + 1.0+beta20 (10/04/2018) ----------------------- diff --git a/bin/main.ml b/bin/main.ml index 60a0a046..a76e7ccb 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -22,6 +22,7 @@ type common = ; auto_promote : bool ; force : bool ; ignore_promoted_rules : bool + ; build_dir : string ; (* Original arguments for the external-lib-deps hint *) orig_args : string list ; config : Config.t @@ -29,14 +30,17 @@ type common = let prefix_target common s = common.target_prefix ^ s -let set_common c ~targets = +let set_dirs c = + if c.root <> Filename.current_dir_name then + Sys.chdir c.root; + Path.set_root (Path.External.cwd ()); + Path.set_build_dir (Path.Kind.of_string c.build_dir) + +let set_common_other c ~targets = Clflags.debug_dep_path := c.debug_dep_path; Clflags.debug_findlib := c.debug_findlib; Clflags.debug_backtraces := c.debug_backtraces; Clflags.capture_outputs := c.capture_outputs; - if c.root <> Filename.current_dir_name then - Sys.chdir c.root; - Clflags.workspace_root := Sys.getcwd (); Clflags.diff_command := c.diff_command; Clflags.auto_promote := c.auto_promote; Clflags.force := c.force; @@ -47,6 +51,10 @@ let set_common c ~targets = ; targets ] +let set_common c ~targets = + set_dirs c; + set_common_other c ~targets + let restore_cwd_and_execve common prog argv env = let env = Env.to_unix env in let prog = @@ -224,7 +232,9 @@ let common = orig) x display + build_dir = + let build_dir = Option.value ~default:"_build" build_dir in let root, to_cwd = match root with | Some dn -> (dn, []) @@ -280,6 +290,7 @@ let common = List.map ~f:Package.Name.of_string (String.split s ~on:','))) ; x ; config + ; build_dir } in let docs = copts_sect in @@ -518,6 +529,14 @@ let common = & info ["x"] ~docs ~doc:{|Cross-compile using this toolchain.|}) in + let build_dir = + let doc = "Specified build directory. _build if unspecified" in + Arg.(value + & opt (some string) None + & info ["build-dir"] ~docs ~docv:"FILE" + ~env:(Arg.env_var ~doc "DUNE_BUILD_DIR") + ~doc) + in let diff_command = Arg.(value & opt (some string) None @@ -537,6 +556,7 @@ let common = $ merged_options $ x $ display + $ build_dir ) let installed_libraries = @@ -593,7 +613,7 @@ let resolve_package_install setup pkg = |> List.map ~f:Package.Name.to_string)) let target_hint (setup : Main.setup) path = - assert (Path.is_local path); + assert (Path.is_managed path); let sub_dir = Option.value ~default:path (Path.parent path) in let candidates = Build_system.all_targets setup.build_system in let candidates = @@ -650,7 +670,7 @@ let resolve_targets ~log common (setup : Main.setup) user_targets = check_path path; if Path.is_root path then die "@@ on the command line must be followed by a valid alias name" - else if not (Path.is_local path) then + else if not (Path.is_managed path) then die "@@ on the command line must be followed by a relative path" else Ok [Alias_rec path] @@ -660,7 +680,7 @@ let resolve_targets ~log common (setup : Main.setup) user_targets = let can't_build path = Error (path, target_hint setup path); in - if not (Path.is_local path) then + if not (Path.is_managed path) then Ok [File path] else if Path.is_in_build_dir path then begin if Build_system.is_target setup.build_system path then @@ -1269,8 +1289,9 @@ let utop = ; `Blocks help_secs ] in let go common dir ctx_name args = + set_dirs common; let utop_target = dir |> Path.of_string |> Utop.utop_exe |> Path.to_string in - set_common common ~targets:[utop_target]; + set_common_other common ~targets:[utop_target]; let log = Log.create common in let (build_system, context, utop_path) = (Main.setup ~log common >>= fun setup -> diff --git a/doc/usage.rst b/doc/usage.rst index 49dd92d6..f62605a6 100644 --- a/doc/usage.rst +++ b/doc/usage.rst @@ -533,3 +533,20 @@ you need to specify the name explicitly via the ``-n`` flag: Finally, note that jbuilder doesn't allow you to customize the list of substituted watermarks. If you which to do so, you need to configure topkg and use it instead of ``jbuilder subst``. + +Custom Build Directory +====================== + +By default dune places all build artifacts in the ``_build`` directory relative +to the user's workspace. However, one can customize this directory by using the +``--build-dir`` flag or the ``DUNE_BUILD_DIR`` environment variable. + +.. code:: bash + + $ dune build --build-dir _build-foo + + # this is equivalent to: + $ DUNE_BUILD_DIR=_build-foo dune build + + # Absolute paths are also allowed + $ dune build --build-dir /tmp/build foo.exe diff --git a/src/action.ml b/src/action.ml index d112621c..e21fcb30 100644 --- a/src/action.ml +++ b/src/action.ml @@ -352,7 +352,7 @@ module Unexpanded = struct | List _ -> t sexp let check_mkdir loc path = - if not (Path.is_local path) then + if not (Path.is_managed path) then Loc.fail loc "(mkdir ...) is not supported for paths outside of the workspace:\n\ \ %a\n" @@ -843,20 +843,13 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to = Path.rm_rf path; Fiber.return () | Mkdir path -> - (match Path.kind path with - | External _ -> - (* Internally we make sure never to do that, and [Unexpanded.*expand] check that *) - Exn.code_error - "(mkdir ...) is not supported for paths outside of the workspace" - [ "mkdir", Path.sexp_of_t path ] - | Local path -> - Path.Local.mkdir_p path); + Path.mkdir_p path; Fiber.return () | Digest_files paths -> let s = let data = List.map paths ~f:(fun fn -> - (fn, Utils.Cached_digest.file fn)) + (Path.to_string fn, Utils.Cached_digest.file fn)) in Digest.string (Marshal.to_string data []) @@ -930,7 +923,7 @@ let exec ~targets ~context t = let sandbox t ~sandboxed ~deps ~targets = Progn [ Progn (List.filter_map deps ~f:(fun path -> - if Path.is_local path then + if Path.is_managed path then Some (Ast.Symlink (path, sandboxed path)) else None)) @@ -940,7 +933,7 @@ let sandbox t ~sandboxed ~deps ~targets = ~f_path:(fun ~dir:_ p -> sandboxed p) ~f_program:(fun ~dir:_ x -> Result.map x ~f:sandboxed) ; Progn (List.filter_map targets ~f:(fun path -> - if Path.is_local path then + if Path.is_managed path then Some (Ast.Rename (sandboxed path, path)) else None)) diff --git a/src/artifacts.ml b/src/artifacts.ml index d614d0bc..f9520e73 100644 --- a/src/artifacts.ml +++ b/src/artifacts.ml @@ -53,7 +53,7 @@ let create (context : Context.t) ~public_libs l ~f = let binary t ?hint name = if not (Filename.is_relative name) then - Ok (Path.absolute name) + Ok (Path.of_filename_relative_to_initial_cwd name) else match String.Map.find t.local_bins name with | Some path -> Ok path diff --git a/src/bin.ml b/src/bin.ml index 0af2d307..1a1301b7 100644 --- a/src/bin.ml +++ b/src/bin.ml @@ -7,7 +7,7 @@ let path_sep = ':' let parse_path ?(sep=path_sep) s = - List.map (String.split s ~on:sep) ~f:Path.absolute + List.map (String.split s ~on:sep) ~f:Path.of_filename_relative_to_initial_cwd let path = match Env.get Env.initial "PATH" with diff --git a/src/build_system.ml b/src/build_system.ml index b239f5c8..0e9ed2b5 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -373,7 +373,7 @@ type t = [(deps (filename + contents), targets (filename only), action)] *) trace : (Path.t, Digest.t) Hashtbl.t ; file_tree : File_tree.t - ; mutable local_mkdirs : Path.Local.Set.t + ; mutable local_mkdirs : Path.Set.t ; mutable dirs : (Path.t, Dir_status.t) Hashtbl.t ; mutable gen_rules : (dir:Path.t -> string list -> extra_sub_directories_to_keep) String.Map.t @@ -406,7 +406,7 @@ let get_dir_status t ~dir = else if dir = Path.build_dir then (* Not allowed to look here *) Dir_status.Loaded Path.Set.empty - else if not (Path.is_local dir) then + else if not (Path.is_managed dir) then Dir_status.Loaded (match Path.readdir_unsorted dir with | exception _ -> Path.Set.empty @@ -601,24 +601,20 @@ let clear_targets_digests_after_rule_execution targets = let make_local_dirs t paths = Path.Set.iter paths ~f:(fun path -> - match Path.kind path with - | Local path -> - if not (Path.Local.Set.mem t.local_mkdirs path) then begin - Path.Local.mkdir_p path; - t.local_mkdirs <- Path.Local.Set.add t.local_mkdirs path - end - | _ -> ()) + if Path.is_managed path && not (Path.Set.mem t.local_mkdirs path) then begin + Path.mkdir_p path; + t.local_mkdirs <- Path.Set.add t.local_mkdirs path + end) let make_local_parent_dirs t paths ~map_path = Path.Set.iter paths ~f:(fun path -> - match Path.kind (map_path path) with - | Local path when not (Path.Local.is_root path) -> - let parent = Path.Local.parent path in - if not (Path.Local.Set.mem t.local_mkdirs parent) then begin - Path.Local.mkdir_p parent; - t.local_mkdirs <- Path.Local.Set.add t.local_mkdirs parent - end - | _ -> ()) + let path = map_path path in + if Path.is_managed path then ( + Option.iter (Path.parent path) ~f:(fun parent -> + if not (Path.Set.mem t.local_mkdirs parent) then begin + Path.mkdir_p parent; + t.local_mkdirs <- Path.Set.add t.local_mkdirs parent + end))) let sandbox_dir = Path.relative Path.build_dir ".sandbox" @@ -717,11 +713,12 @@ let rec compile_rule t ?(copy_source=false) pre_rule = let targets_as_list = Path.Set.to_list targets in let hash = let trace = - (List.map all_deps_as_list ~f:(fun fn -> - (fn, Utils.Cached_digest.file fn)), - targets_as_list, - Option.map context ~f:(fun c -> c.name), - action) + ( all_deps_as_list + |> List.map ~f:(fun fn -> + (Path.to_string fn, Utils.Cached_digest.file fn)), + List.map targets_as_list ~f:Path.to_string, + Option.map context ~f:(fun c -> c.name), + Action.for_shell action) in Digest.string (Marshal.to_string trace []) in @@ -760,7 +757,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule = | Some sandbox_dir -> Path.rm_rf sandbox_dir; let sandboxed path = - if Path.is_local path then + if Path.is_managed path then Path.append sandbox_dir path else path @@ -1061,7 +1058,7 @@ and wait_for_file t fn = | Some file -> wait_for_file_found fn file | None -> let dir = Path.parent_exn fn in - if Path.is_in_build_dir dir then begin + if Path.is_strict_descendant_of_build_dir dir then begin load_dir t ~dir; match Hashtbl.find t.files fn with | Some file -> wait_for_file_found fn file @@ -1179,7 +1176,7 @@ let create ~contexts ~file_tree ~hook = ; files = Hashtbl.create 1024 ; packages = Hashtbl.create 1024 ; trace = Trace.load () - ; local_mkdirs = Path.Local.Set.empty + ; local_mkdirs = Path.Set.empty ; dirs = Hashtbl.create 1024 ; load_dir_stack = [] ; file_tree @@ -1473,7 +1470,7 @@ let get_collector t ~dir = "Build_system.get_collector called on source directory" else if dir = Path.build_dir then "Build_system.get_collector called on build_dir" - else if not (Path.is_local dir) then + else if not (Path.is_managed dir) then "Build_system.get_collector called on external directory" else "Build_system.get_collector called on closed directory") diff --git a/src/clflags.ml b/src/clflags.ml index d10df6e7..375bceb6 100644 --- a/src/clflags.ml +++ b/src/clflags.ml @@ -3,7 +3,6 @@ let g = ref true let debug_findlib = ref false let warnings = ref "-40" let debug_dep_path = ref false -let workspace_root = ref "." let external_lib_deps_hint = ref [] let capture_outputs = ref true let debug_backtraces = ref false diff --git a/src/clflags.mli b/src/clflags.mli index e40cac0d..ba160617 100644 --- a/src/clflags.mli +++ b/src/clflags.mli @@ -15,9 +15,6 @@ val debug_findlib : bool ref (** Compiler warnings *) val warnings : string ref -(** The path to the workspace root *) -val workspace_root : string ref - (** The command line for "Hint: try: jbuilder external-lib-deps ..." *) val external_lib_deps_hint : string list ref diff --git a/src/config.ml b/src/config.ml index 2dbaad76..cf4640e7 100644 --- a/src/config.ml +++ b/src/config.ml @@ -15,7 +15,9 @@ let local_install_lib_dir ~context ~package = (Path.relative (local_install_dir ~context) "lib") package -let dev_null = Path.of_string (if Sys.win32 then "nul" else "/dev/null") +let dev_null = + Path.of_filename_relative_to_initial_cwd + (if Sys.win32 then "nul" else "/dev/null") let jbuilder_keep_fname = ".jbuilder-keep" @@ -108,7 +110,8 @@ let t = }) let user_config_file = - Path.relative (Path.of_string Xdg.config_dir) "dune/config" + Path.relative (Path.of_filename_relative_to_initial_cwd Xdg.config_dir) + "dune/config" let load_config_file p = t (Io.Sexp.load p ~mode:Many_as_one) diff --git a/src/configurator/v1.ml b/src/configurator/v1.ml index 0f38eee2..a084c4b8 100644 --- a/src/configurator/v1.ml +++ b/src/configurator/v1.ml @@ -142,8 +142,12 @@ let run t ~dir cmd = (Filename.quote stdout_fn) (Filename.quote stderr_fn) in - let stdout = Io.read_file (Path.of_string stdout_fn) in - let stderr = Io.read_file (Path.of_string stderr_fn) in + let stdout = + Io.read_file (Path.of_filename_relative_to_initial_cwd stdout_fn) + in + let stderr = + Io.read_file (Path.of_filename_relative_to_initial_cwd stderr_fn) + in logf t "-> process exited with code %d" exit_code; logf t "-> stdout:"; List.iter (String.split_lines stdout) ~f:(logf t " | %s"); @@ -237,7 +241,7 @@ let compile_and_link_c_prog t ?(c_flags=[]) ?(link_flags=[]) code = let c_fname = base ^ ".c" in let obj_fname = base ^ t.ext_obj in let exe_fname = base ^ ".exe" in - Io.write_file (Path.of_string c_fname) code; + Io.write_file (Path.of_filename_relative_to_initial_cwd c_fname) code; logf t "compiling c program:"; List.iter (String.split_lines code) ~f:(logf t " | %s"); let run_ok args = @@ -267,7 +271,7 @@ let compile_c_prog t ?(c_flags=[]) code = let base = dir ^/ "test" in let c_fname = base ^ ".c" in let obj_fname = base ^ t.ext_obj in - Io.write_file (Path.of_string c_fname) code; + Io.write_file (Path.of_filename_relative_to_initial_cwd c_fname) code; logf t "compiling c program:"; List.iter (String.split_lines code) ~f:(logf t " | %s"); let run_ok args = @@ -284,7 +288,10 @@ let compile_c_prog t ?(c_flags=[]) code = ] ]) in - if ok then Ok (Path.of_string obj_fname) else Error () + if ok then + Ok (Path.of_filename_relative_to_initial_cwd obj_fname) + else + Error () let c_test t ?c_flags ?link_flags code = match compile_and_link_c_prog t ?c_flags ?link_flags code with @@ -413,7 +420,7 @@ const char *s%i = "BEGIN-%i-false-END"; logf t "writing header file %s" fname; List.iter lines ~f:(logf t " | %s"); let tmp_fname = fname ^ ".tmp" in - Io.write_lines (Path.of_string tmp_fname) lines; + Io.write_lines (Path.of_filename_relative_to_initial_cwd tmp_fname) lines; Sys.rename tmp_fname fname end @@ -479,7 +486,7 @@ module Pkg_config = struct end let write_flags fname s = - let path = Path.of_string fname in + let path = Path.in_source fname in let sexp = Usexp.List(List.map ~f:Usexp.atom_or_quoted_string s) in Io.write_file path (Usexp.to_string sexp) diff --git a/src/context.ml b/src/context.ml index 351a312e..b3359627 100644 --- a/src/context.ml +++ b/src/context.ml @@ -152,7 +152,7 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets ~profile () = (match Env.get env "OCAMLFIND_CONF" with | Some s -> Fiber.return s | None -> Process.run_capture_line ~env Strict fn ["printconf"; "conf"]) - >>| Path.absolute) + >>| Path.of_filename_relative_to_initial_cwd) in let create_one ~name ~implicit ?findlib_toolchain ?host ~merlin () = @@ -170,7 +170,7 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets ~profile () = | Some s -> match Filename.analyze_program_name s with | In_path | Relative_to_current_dir -> which s - | Absolute -> Some (Path.absolute s)) + | Absolute -> Some (Path.of_filename_relative_to_initial_cwd s)) in let ocamlc = @@ -221,7 +221,8 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets ~profile () = let findlib_path () = match kind, findlib_toolchain, Setup.library_path with | Default, None, Some l -> - Fiber.return (ocamlpath @ List.map l ~f:Path.absolute) + Fiber.return + (ocamlpath @ List.map l ~f:Path.of_filename_relative_to_initial_cwd) | _ -> (* If ocamlfind is present, it has precedence over everything else. *) match which "ocamlfind" with @@ -236,13 +237,13 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets ~profile () = >>| fun l -> (* Don't prepend the contents of [OCAMLPATH] since findlib does it already *) - List.map l ~f:Path.absolute + List.map l ~f:Path.of_filename_relative_to_initial_cwd | None -> (* If there no ocamlfind in the PATH, check if we have opam and assume a standard opam setup *) opam_config_var ~env ~cache:opam_var_cache "lib" >>| function - | Some s -> ocamlpath @ [Path.absolute s] + | Some s -> ocamlpath @ [Path.of_filename_relative_to_initial_cwd s] | None -> (* If neither opam neither ocamlfind are present, assume that libraries are [dir ^ "/../lib"] *) @@ -335,7 +336,8 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets ~profile () = ; build_dir ; path ; toplevel_path = - Option.map (Env.get env "OCAML_TOPLEVEL_PATH") ~f:Path.absolute + Option.map (Env.get env "OCAML_TOPLEVEL_PATH") + ~f:Path.of_filename_relative_to_initial_cwd ; ocaml_bin = dir ; ocaml = (match which "ocaml" with Some p -> p | None -> prog_not_found_in_path "ocaml") @@ -459,20 +461,20 @@ let which t s = which ~cache:t.which_cache ~path:t.path s let install_prefix t = opam_config_var t "prefix" >>| function - | Some x -> Path.absolute x + | Some x -> Path.of_filename_relative_to_initial_cwd x | None -> Path.parent_exn t.ocaml_bin let install_ocaml_libdir t = match t.kind, t.findlib_toolchain, Setup.library_destdir with | Default, None, Some d -> - Fiber.return (Some (Path.absolute d)) + Fiber.return (Some (Path.of_filename_relative_to_initial_cwd d)) | _ -> (* If ocamlfind is present, it has precedence over everything else. *) match which t "ocamlfind" with | Some fn -> (Process.run_capture_line ~env:t.env Strict fn ["printconf"; "destdir"] >>| fun s -> - Some (Path.absolute s)) + Some (Path.of_filename_relative_to_initial_cwd s)) | None -> Fiber.return None diff --git a/src/dune_project.ml b/src/dune_project.ml index dc6114eb..d9bcc71e 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -67,7 +67,7 @@ end = struct None let anonymous path = - if Path.is_local path then + if Path.is_managed path then Some (Anonymous path) else None @@ -107,7 +107,7 @@ end = struct |> List.tl |> String.concat ~sep:"/") in - if not (Path.is_local p) then invalid s; + if not (Path.is_managed p) then invalid s; Anonymous p | _ when validate s -> Named s | _ -> invalid s diff --git a/src/file_tree.ml b/src/file_tree.ml index 8487a83b..aee91070 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -155,20 +155,24 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path = Path.readdir_unsorted path |> List.filter_partition_map ~f:(fun fn -> let path = Path.relative path fn in - let is_directory, file = - match Unix.stat (Path.to_string path) with - | exception _ -> (false, File.dummy) - | { st_kind = S_DIR; _ } as st -> - (true, File.of_stats st) - | _ -> - (false, File.dummy) - in - if ignore_file fn ~is_directory then + if Path.is_in_build_dir path then Skip - else if is_directory then - Right (fn, path, file) - else - Left fn) + else begin + let is_directory, file = + match Unix.stat (Path.to_string path) with + | exception _ -> (false, File.dummy) + | { st_kind = S_DIR; _ } as st -> + (true, File.of_stats st) + | _ -> + (false, File.dummy) + in + if ignore_file fn ~is_directory then + Skip + else if is_directory then + Right (fn, path, file) + else + Left fn + end) in let files = String.Set.of_list files in let sub_dirs = @@ -253,7 +257,7 @@ let fold t ~traverse_ignored_dirs ~init ~f = Dir.fold t.root ~traverse_ignored_dirs ~init ~f let rec find_dir t path = - if not (Path.is_local path) then + if not (Path.is_managed path) then None else match Hashtbl.find t.dirs path with diff --git a/src/findlib.ml b/src/findlib.ml index 3229a46c..30e8c3a1 100644 --- a/src/findlib.ml +++ b/src/findlib.ml @@ -227,7 +227,7 @@ let parse_package t ~meta_file ~name ~parent_dir ~vars = else if Filename.is_relative pkg_dir then Path.relative parent_dir pkg_dir else - Path.absolute pkg_dir + Path.of_filename_relative_to_initial_cwd pkg_dir in let pkg = { Package. diff --git a/src/install.ml b/src/install.ml index 8f213595..ccccae6d 100644 --- a/src/install.ml +++ b/src/install.ml @@ -49,17 +49,17 @@ module Section = struct ] module Paths = struct - let lib = Path.(relative root) "lib" - let libexec = Path.(relative root) "lib" - let bin = Path.(relative root) "bin" - let sbin = Path.(relative root) "sbin" - let toplevel = Path.(relative root) "lib/toplevel" - let share = Path.(relative root) "share" - let share_root = Path.(relative root) "share_root" - let etc = Path.(relative root) "etc" - let doc = Path.(relative root) "doc" - let stublibs = Path.(relative root) "lib/stublibs" - let man = Path.(relative root) "man" + let lib = Path.in_source "lib" + let libexec = Path.in_source "lib" + let bin = Path.in_source "bin" + let sbin = Path.in_source "sbin" + let toplevel = Path.in_source "lib/toplevel" + let share = Path.in_source "share" + let share_root = Path.in_source "share_root" + let etc = Path.in_source "etc" + let doc = Path.in_source "doc" + let stublibs = Path.in_source "lib/stublibs" + let man = Path.in_source "man" end let install_dir t ~(package : Package.Name.t) = diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index 5c390f7b..b7e26206 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -28,9 +28,8 @@ module Jbuilds = struct let generated_jbuilds_dir = Path.relative Path.build_dir ".jbuilds" let ensure_parent_dir_exists path = - match Path.kind path with - | Local path -> Path.Local.ensure_parent_directory_exists path - | External _ -> () + if Path.is_in_build_dir path then + Option.iter (Path.parent path) ~f:Path.mkdir_p type requires = No_requires | Unix @@ -135,7 +134,7 @@ end List.concat [ [ "-I"; "+compiler-libs" ] ; cmas - ; [ Path.to_absolute_filename wrapper ~root:!Clflags.workspace_root ] + ; [ Path.to_absolute_filename wrapper ] ] in (* CR-someday jdimino: if we want to allow plugins to use findlib: diff --git a/src/lib.ml b/src/lib.ml index 18ce8b8b..a29b25d8 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -346,7 +346,7 @@ let unique_id t = t.unique_id let src_dir t = t.src_dir let obj_dir t = t.obj_dir -let is_local t = Path.is_local t.obj_dir +let is_local t = Path.is_managed t.obj_dir let status t = t.status diff --git a/src/lib.mli b/src/lib.mli index 8a561ee8..682a1be4 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -17,7 +17,7 @@ val src_dir : t -> Path.t (** Directory where the object files for the library are located. *) val obj_dir : t -> Path.t -(** Same as [Path.is_local (obj_dir t)] *) +(** Same as [Path.is_managed (obj_dir t)] *) val is_local : t -> bool val synopsis : t -> string option diff --git a/src/main.ml b/src/main.ml index 5c357072..2c70393d 100644 --- a/src/main.ml +++ b/src/main.ml @@ -147,7 +147,7 @@ let external_lib_deps ?log ~packages () = let ignored_during_bootstrap = Path.Set.of_list - (List.map ~f:Path.of_string + (List.map ~f:Path.in_source [ "test" ; "example" ]) @@ -205,6 +205,8 @@ let set_concurrency ?log (config : Config.t) = (* Called by the script generated by ../build.ml *) let bootstrap () = Colors.setup_err_formatter_colors (); + Path.set_root Path.External.initial_cwd; + Path.set_build_dir (Path.Kind.of_string "_build"); let main () = let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in let subst () = diff --git a/src/merlin.ml b/src/merlin.ml index f3d52427..e779e2b8 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -100,7 +100,7 @@ let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } = match preprocess with | Pps { pps; flags } -> let exe = Preprocessing.get_ppx_driver sctx ~scope pps in - (Path.to_absolute_filename exe ~root:!Clflags.workspace_root + (Path.to_absolute_filename exe :: "--as-ppx" :: Preprocessing.cookie_library_name libname @ flags) diff --git a/src/scheduler.ml b/src/scheduler.ml index 7ec35f6d..9847d7ae 100644 --- a/src/scheduler.ml +++ b/src/scheduler.ml @@ -157,7 +157,8 @@ let rec go_rec t = let go ?(log=Log.no_log) ?(config=Config.default) ?(gen_status_line=fun () -> None) fiber = - Log.info log ("Workspace root: " ^ !Clflags.workspace_root); + Log.infof log "Workspace root: %s" + (Path.to_absolute_filename Path.root |> String.maybe_quoted); let cwd = Sys.getcwd () in if cwd <> initial_cwd then Printf.eprintf "Entering directory '%s'\n%!" cwd; diff --git a/src/scope.ml b/src/scope.ml index 31478fda..d341e42d 100644 --- a/src/scope.ml +++ b/src/scope.ml @@ -26,7 +26,7 @@ module DB = struct match Hashtbl.find t.by_dir d with | Some scope -> scope | None -> - if Path.is_root d || not (Path.is_local d) then + if Path.is_root d || not (Path.is_managed d) then Exn.code_error "Scope.DB.find_by_dir got an invalid path" [ "dir" , Path.sexp_of_t dir ; "context", Sexp.To_sexp.string t.context diff --git a/src/stdune/path.ml b/src/stdune/path.ml index d4934334..70124ffa 100644 --- a/src/stdune/path.ml +++ b/src/stdune/path.ml @@ -31,10 +31,50 @@ let explode_path = | "." :: xs -> xs | xs -> xs -module External = struct - type t = string +module External : sig + type t + + val compare : t -> t -> Ordering.t + val compare_val : t -> t -> Ordering.t + val t : t Sexp.Of_sexp.t + val sexp_of_t : t Sexp.To_sexp.t + val to_string : t -> string + val of_string : string -> t + val relative : t -> string -> t + val mkdir_p : t -> unit + val basename : t -> string + val parent : t -> t + val initial_cwd : t + val cwd : unit -> t + val extend_basename : t -> suffix:string -> t +end = struct + include Interned.No_interning(struct + let initial_size = 512 + let resize_policy = Interned.Greedy + end)() + + let compare_val x y = String.compare (to_string x) (to_string y) + + let as_string x ~f = + to_string x + |> f + |> make + + let extend_basename t ~suffix = as_string t ~f:(fun t -> t ^ suffix) + + let of_string t = + if Filename.is_relative t then + Exn.code_error "Path.External.of_string: relative path given" + [ "t", Sexp.To_sexp.string t ]; + make t + + let sexp_of_t t = Sexp.To_sexp.string (to_string t) + let t sexp = + let t = Sexp.Of_sexp.string sexp in + if Filename.is_relative t then + Sexp.Of_sexp.of_sexp_error sexp "Absolute path expected"; + of_string t - let to_string t = t (* let rec cd_dot_dot t = match Unix.readlink t with @@ -54,31 +94,76 @@ module External = struct loop initial_t (explode_path path) *) - let relative = Filename.concat + let relative x y = + match y with + | "." -> x + | _ -> make (Filename.concat (to_string x) y) + + let rec mkdir_p t = + let t_s = to_string t in + let p_s = Filename.dirname t_s in + let p = make p_s in + if p <> t then + try + Unix.mkdir t_s 0o777 + with + | Unix.Unix_error (EEXIST, _, _) -> () + | Unix.Unix_error (ENOENT, _, _) -> + mkdir_p p; + Unix.mkdir t_s 0o777 + + let basename t = Filename.basename (to_string t) + let parent t = as_string ~f:Filename.dirname t + + let cwd () = make (Sys.getcwd ()) + let initial_cwd = cwd () end -let is_root = function - | "" -> true - | _ -> false +module Local : sig + type t -module Local = struct - (* either "" for root, either a '/' separated list of components other that ".", ".." - and not containing '/'. *) - type t = string + val t : t Sexp.Of_sexp.t + val sexp_of_t : t Sexp.To_sexp.t + val root : t + val is_root : t -> bool + val compare : t -> t -> Ordering.t + val compare_val : t -> t -> Ordering.t + val of_string : ?error_loc:Usexp.Loc.t -> string -> t + val to_string : t -> string + val relative : ?error_loc:Usexp.Loc.t -> t -> string -> t + val append : t -> t -> t + val parent : t -> t + val mkdir_p : t -> unit + val descendant : t -> of_:t -> t option + val is_descendant : t -> of_:t -> bool + val reach : t -> from:t -> string + val basename : t -> string + val extend_basename : t -> suffix:string -> t + module Set : Set.S with type elt = t - let root = "" + module Prefix : sig + type local = t + type t - let is_root = function - | "" -> true - | _ -> false + val make : local -> t + val drop : t -> local -> local option - let to_string = function - | "" -> "." - | t -> t + (* for all local path p, drop (invalid p = None) *) + val invalid : t + end with type local := t +end = struct + (* either "." for root, either a '/' separated list of components + other that ".", ".." and not containing '/'. *) + include Interned.No_interning(struct + let initial_size = 512 + let resize_policy = Interned.Greedy + end)() - let compare = String.compare + let compare_val x y = String.compare (to_string x) (to_string y) - module Set = String.Set + let root = make "." + + let is_root t = t = root let to_list = let rec loop t acc i j = @@ -89,33 +174,39 @@ module Local = struct | '/' -> loop t (String.sub t ~pos:i ~len:(j - i) :: acc) (i - 1) (i - 1) | _ -> loop t acc (i - 1) j in - function - | "" -> [] - | t -> - let len = String.length t in - loop t [] len len + fun t -> + if is_root t then + [] + else + let t = to_string t in + let len = String.length t in + loop t [] len len - let parent = function - | "" -> + let parent t = + if is_root t then Exn.code_error "Path.Local.parent called on the root" [] - | t -> + else + let t = to_string t in match String.rindex_from t (String.length t - 1) '/' with - | exception Not_found -> "" - | i -> String.sub t ~pos:0 ~len:i + | exception Not_found -> root + | i -> make (String.sub t ~pos:0 ~len:i) - let basename = function - | "" -> + let basename t = + if is_root t then Exn.code_error "Path.Local.basename called on the root" [] - | t -> + else + let t = to_string t in let len = String.length t in match String.rindex_from t (len - 1) '/' with | exception Not_found -> t | i -> String.sub t ~pos:(i + 1) ~len:(len - i - 1) + let sexp_of_t t = Sexp.To_sexp.string (to_string t) + let relative ?error_loc t path = if not (Filename.is_relative path) then ( Exn.code_error "Local.relative: received absolute path" - [ "t", Usexp.atom_or_quoted_string t + [ "t", sexp_of_t t ; "path", Usexp.atom_or_quoted_string path ] ); @@ -124,20 +215,21 @@ module Local = struct | [] -> Result.Ok t | "." :: rest -> loop t rest | ".." :: rest -> - begin match t with - | "" -> Result.Error () - | t -> loop (parent t) rest - end + if is_root t then + Result.Error () + else + loop (parent t) rest | fn :: rest -> - match t with - | "" -> loop fn rest - | _ -> loop (t ^ "/" ^ fn) rest + if is_root t then + loop (make fn) rest + else + loop (make (to_string t ^ "/" ^ fn)) rest in match loop t (explode_path path) with | Result.Ok t -> t | Error () -> - Exn.fatalf ?loc:error_loc "path outside the workspace: %s from %s" path - (to_string t) + Exn.fatalf ?loc:error_loc "path outside the workspace: %s from %s" path + (to_string t) let is_canonicalized = let rec before_slash s i = @@ -173,61 +265,68 @@ module Local = struct in fun s -> let len = String.length s in - if len = 0 then - true - else - before_slash s (len - 1) + len = 0 || before_slash s (len - 1) let of_string ?error_loc s = - if is_canonicalized s then - s - else - relative "" s ?error_loc + match s with + | "" | "." -> root + | _ when is_canonicalized s -> make s + | _ -> + relative root s ?error_loc - let rec mkdir_p = function - | "" -> () - | t -> + let t sexp = + of_string (Sexp.Of_sexp.string sexp) + ~error_loc:(Sexp.Ast.loc sexp) + + let rec mkdir_p t = + if is_root t then + () + else + let t_s = to_string t in try - Unix.mkdir t 0o777 + Unix.mkdir t_s 0o777 with | Unix.Unix_error (EEXIST, _, _) -> () | Unix.Unix_error (ENOENT, _, _) as e -> - match parent t with - | "" -> raise e - | p -> - mkdir_p p; - Unix.mkdir t 0o777 - - let ensure_parent_directory_exists = function - | "" -> () - | t -> mkdir_p (parent t) + let parent = parent t in + if is_root parent then + raise e + else begin + mkdir_p parent; + Unix.mkdir t_s 0o777 + end let append a b = - match a, b with - | "", x | x, "" -> x - | _ -> a ^ "/" ^ b + match is_root a, is_root b with + | true, _ -> b + | _, true -> a + | _, _ -> make ((to_string a) ^ "/" ^ (to_string b)) let descendant t ~of_ = - match of_ with - | "" -> Some t - | _ -> + if is_root of_ then + Some t + else if t = of_ then + Some root + else + let t = to_string t in + let of_ = to_string of_ in let of_len = String.length of_ in let t_len = String.length t in - if t_len = of_len then - Option.some_if (t = of_) t - else if (t_len >= of_len && t.[of_len] = '/' && String.is_prefix t ~prefix:of_) then - Some (String.sub t ~pos:(of_len + 1) ~len:(t_len - of_len - 1)) + if (t_len > of_len && t.[of_len] = '/' + && String.is_prefix t ~prefix:of_) then + Some (make (String.sub t ~pos:(of_len + 1) ~len:(t_len - of_len - 1))) else None let is_descendant t ~of_ = - match of_ with - | "" -> true - | _ -> + is_root of_ + || t = of_ + || ( + let t = to_string t in + let of_ = to_string of_ in let of_len = String.length of_ in let t_len = String.length t in - (t_len = of_len && t = of_) || - (t_len > of_len && t.[of_len] = '/' && String.is_prefix t ~prefix:of_) + (t_len > of_len && t.[of_len] = '/' && String.is_prefix t ~prefix:of_)) let reach t ~from = let rec loop t from = @@ -237,110 +336,314 @@ module Local = struct | _ -> match List.fold_left from ~init:t ~f:(fun acc _ -> ".." :: acc) with | [] -> "." - | l -> String.concat l ~sep:"/" + | l -> (String.concat l ~sep:"/") in loop (to_list t) (to_list from) + + let extend_basename t ~suffix = make (to_string t ^ suffix) + + module Prefix = struct + let make_path = make + + type t = + { len : int + ; path : string + ; path_slash : string + } + + let make p = + if is_root p then + Exn.code_error "Path.Local.Prefix.make" + [ "path", sexp_of_t p ]; + let p = to_string p in + { len = String.length p + ; path = p + ; path_slash = p ^ "/" + } + + let drop t p = + let p = to_string p in + let len = String.length p in + if len = t.len && p = t.path then + Some root + else + String.drop_prefix p ~prefix:t.path_slash + |> Option.map ~f:make_path + + let invalid = + { len = -1 + ; path = "/" + ; path_slash = "/" + } + end end -type t = string -let compare = String.compare - -module Set = struct - include String.Set - let sexp_of_t t = Sexp.To_sexp.(list string) (String.Set.to_list t) - let of_string_set = map -end - -module Map = String.Map +let (abs_root, set_root) = + let root_dir = ref None in + let set_root new_root = + match !root_dir with + | None -> root_dir := Some new_root + | Some root_dir -> + Exn.code_error "set_root: cannot set root_dir more than once" + [ "root_dir", External.sexp_of_t root_dir + ; "new_root_dir", External.sexp_of_t new_root + ] + in + let abs_root = lazy ( + match !root_dir with + | None -> + Exn.code_error "root_dir: cannot use root dir before it's set" [] + | Some root_dir -> root_dir) + in + (abs_root, set_root) module Kind = struct type t = | External of External.t | Local of Local.t + + let to_absolute_filename t = + match t with + | External s -> External.to_string s + | Local l -> + External.to_string + (External.relative (Lazy.force abs_root) + (Local.to_string l)) + + let to_string = function + | Local t -> Local.to_string t + | External t -> External.to_string t + + let sexp_of_t t = Sexp.atom_or_quoted_string (to_string t) + + let of_string s = + if Filename.is_relative s then + Local (Local.of_string s) + else + External (External.of_string s) + + let _ = + let root = Local Local.root in + assert (of_string "" = root); + assert (of_string "." = root) + + let _relative ?error_loc t fn = + match t with + | Local t -> Local (Local.relative ?error_loc t fn) + | External t -> External (External.relative t fn) + + let mkdir_p = function + | Local t -> Local.mkdir_p t + | External t -> External.mkdir_p t + + let append_local x y = + match x with + | Local x -> Local (Local.append x y) + | External x -> External (External.relative x (Local.to_string y)) + end -let is_local t = is_root t || Filename.is_relative t +let (build_dir_kind, build_dir_prefix, set_build_dir) = + let build_dir = ref None in + let build_dir_prefix = ref None in + let set_build_dir (new_build_dir : Kind.t) = + match !build_dir with + | None -> + (match new_build_dir with + | External _ -> () + | Local p -> + if Local.is_root p || Local.parent p <> Local.root then + Exn.fatalf + "@{Error@}: Invalid build directory: %s\n\ + The build directory must be an absolute path or \ + a sub-directory of the root of the workspace." + (Local.to_string p |> String.maybe_quoted)); + build_dir := Some new_build_dir; + build_dir_prefix := + Some (match new_build_dir with + | Local p -> Local.Prefix.make p + | External _ -> Local.Prefix.invalid) + | Some build_dir -> + Exn.code_error "set_build_dir: cannot set build_dir more than once" + [ "build_dir", Kind.sexp_of_t build_dir + ; "new_build_dir", Kind.sexp_of_t new_build_dir ] + in + let build_dir = lazy ( + match !build_dir with + | None -> + Exn.code_error "build_dir: cannot use build dir before it's set" [] + | Some build_dir -> build_dir) + in + let build_dir_prefix = lazy ( + match !build_dir_prefix with + | None -> + Exn.code_error "build_dir: cannot use build dir before it's set" [] + | Some prefix -> prefix) + in + (build_dir, build_dir_prefix, set_build_dir) -let kind t : Kind.t = - if is_local t then - Local t - else - External t +module T : sig + type t = private + | External of External.t + | In_source_tree of Local.t + | In_build_dir of Local.t -let to_string = function - | "" -> "." - | t -> t + val compare : t -> t -> Ordering.t + + val in_build_dir : Local.t -> t + val in_source_tree : Local.t -> t + val external_ : External.t -> t +end = struct + type t = + | External of External.t + | In_source_tree of Local.t + | In_build_dir of Local.t + + let compare x y = + match x, y with + | External x , External y -> External.compare x y + | External _ , _ -> Lt + | _ , External _ -> Gt + | In_source_tree x, In_source_tree y -> Local.compare x y + | In_source_tree _, _ -> Lt + | _ , In_source_tree _ -> Gt + | In_build_dir x , In_build_dir y -> Local.compare x y + + let in_build_dir s = In_build_dir s + let in_source_tree s = In_source_tree s + let external_ e = External e +end + +include T + +let build_dir = in_build_dir Local.root + +let is_root = function + | In_source_tree s -> Local.is_root s + | In_build_dir _ + | External _ -> false + +module Map = Map.Make(T) + +let kind = function + | In_build_dir p -> Kind.append_local (Lazy.force build_dir_kind) p + | In_source_tree s -> Kind.Local s + | External s -> Kind.External s + +let is_managed = function + | In_build_dir _ + | In_source_tree _ -> true + | External _ -> false + +let to_string t = + match t with + | In_source_tree p -> Local.to_string p + | External p -> External.to_string p + | In_build_dir p -> + match Lazy.force build_dir_kind with + | Local b -> Local.to_string (Local.append b p) + | External b -> + if Local.is_root p then + External.to_string b + else + Filename.concat (External.to_string b) (Local.to_string p) let to_string_maybe_quoted t = String.maybe_quoted (to_string t) -let root = "" +let root = in_source_tree Local.root + +let make_local_path p = + match Local.Prefix.drop (Lazy.force build_dir_prefix) p with + | None -> in_source_tree p + | Some p -> in_build_dir p let relative ?error_loc t fn = - if fn = "" then + match fn with + | "" | "." -> t - else - match is_local t, is_local fn with - | true, true -> Local.relative t fn ?error_loc - | _ , false -> fn - | false, true -> External.relative t fn + | _ when not (Filename.is_relative fn) -> + external_ (External.of_string fn) + |_ -> + match t with + | In_source_tree p -> make_local_path (Local.relative p fn ?error_loc) + | In_build_dir p -> in_build_dir (Local.relative p fn ?error_loc) + | External s -> external_ (External.relative s fn) let of_string ?error_loc s = match s with - | "" -> "" + | "" | "." -> in_source_tree Local.root | s -> - if Filename.is_relative s then - Local.of_string s ?error_loc + if not (Filename.is_relative s) then + external_ (External.of_string s) else - s + make_local_path (Local.of_string s ?error_loc) -let t sexp = of_string (Sexp.Of_sexp.string sexp) ~error_loc:(Sexp.Ast.loc sexp) -let sexp_of_t t = Sexp.atom_or_quoted_string (to_string t) +let t = function + (* the first 2 cases are necessary for old build dirs *) + | Sexp.Ast.Atom (_, A s) + | Quoted_string (_, s) -> of_string s + | s -> + let open Sexp.Of_sexp in + sum + [ cstr "In_build_dir" (Local.t @> nil) in_build_dir + ; cstr "In_source_tree" (Local.t @> nil) in_source_tree + ; cstr "External" (External.t @> nil) external_ + ] s -let initial_cwd = Sys.getcwd () +let sexp_of_t t = + let constr f x y = Sexp.To_sexp.(pair string f) (x, y) in + match t with + | In_build_dir s -> constr Local.sexp_of_t "In_build_dir" s + | In_source_tree s -> constr Local.sexp_of_t "In_source_tree" s + | External s -> constr External.sexp_of_t "External" s -let absolute fn = - if is_local fn then - Filename.concat initial_cwd fn - else - fn +let of_filename_relative_to_initial_cwd fn = + external_ ( + if Filename.is_relative fn then + External.relative External.initial_cwd fn + else + External.of_string fn + ) -let to_absolute_filename t ~root = - match kind t with - | Local t -> - assert (not (Filename.is_relative root)); - Filename.concat root (Local.to_string t) - | External t -> t +let to_absolute_filename t = Kind.to_absolute_filename (kind t) + +let external_of_local x ~root = + External.to_string (External.relative root (Local.to_string x)) + +let external_of_in_source_tree x = + external_of_local x ~root:(Lazy.force abs_root) let reach t ~from = - match kind t, kind from with - | External _, _ -> t - | Local _, External _ -> - Exn.code_error "Path.reach called with invalid combination" - [ "t" , sexp_of_t t - ; "from", sexp_of_t from - ] - | Local t, Local from -> - Local.reach t ~from + match t, from with + | External t, _ -> External.to_string t + | In_source_tree t, In_source_tree from + | In_build_dir t, In_build_dir from -> Local.reach t ~from + | In_source_tree t, In_build_dir from -> begin + match Lazy.force build_dir_kind with + | Local b -> Local.reach t ~from:(Local.append b from) + | External _ -> external_of_in_source_tree t + end + | In_build_dir t, In_source_tree from -> begin + match Lazy.force build_dir_kind with + | Local b -> Local.reach (Local.append b t) ~from + | External b -> external_of_local t ~root:b + end + | In_source_tree t, External _ -> external_of_in_source_tree t + | In_build_dir t, External _ -> + match Lazy.force build_dir_kind with + | Local b -> external_of_in_source_tree (Local.append b t) + | External b -> external_of_local t ~root:b let reach_for_running ?(from=root) t = - match kind t, kind from with - | External _, _ -> t - | Local _, External _ -> - Exn.code_error "Path.reach_for_running called with invalid combination" - [ "t" , sexp_of_t t - ; "from", sexp_of_t from - ] - | Local t, Local from -> - let s = Local.reach t ~from in - if String.is_prefix s ~prefix:"../" then - s - else - "./" ^ s + let fn = reach t ~from in + match Filename.analyze_program_name fn with + | In_path -> "./" ^ fn + | _ -> fn let descendant t ~of_ = match kind t, kind of_ with - | Local t, Local of_ -> Local.descendant t ~of_ + | Local t, Local of_ -> Option.map ~f:in_source_tree (Local.descendant t ~of_) | _, _ -> None let is_descendant t ~of_ = @@ -356,74 +659,87 @@ let append a b = ; "b", sexp_of_t b ] | Local b -> - begin match kind a with - | Local a -> Local.append a b - | External a -> Filename.concat a b + begin match a with + | In_source_tree a -> in_source_tree (Local.append a b) + | In_build_dir a -> in_build_dir (Local.append a b) + | External a -> external_ (External.relative a (Local.to_string b)) end let basename t = match kind t with | Local t -> Local.basename t - | External t -> Filename.basename t + | External t -> External.basename t -let parent t = - match kind t with - | Local "" -> None - | Local t -> Some (Local.parent t) - | External t -> - let parent = Filename.dirname t in - if parent = t then +let parent = function + | External s -> + let parent = External.parent s in + if parent = s then None else - Some parent + Some (external_ parent) + | In_source_tree p | In_build_dir p when Local.is_root p -> None + | In_source_tree l -> Some (in_source_tree (Local.parent l)) + | In_build_dir l -> Some (in_build_dir (Local.parent l)) let parent_exn t = match parent t with | Some p -> p - | None -> Exn.code_error "Path.parent_exn: t is root" + | None -> Exn.code_error "Path.parent:exn t is root" ["t", sexp_of_t t] -let build_prefix = "_build/" - -let build_dir = "_build" - -let is_in_build_dir t = - match kind t with - | Local t -> String.is_prefix t ~prefix:build_prefix +let is_strict_descendant_of_build_dir = function + | In_build_dir p -> not (Local.is_root p) + | In_source_tree _ | External _ -> false -let is_in_source_tree t = is_local t && not (is_in_build_dir t) +let is_in_build_dir = function + | In_build_dir _ -> true + | In_source_tree _ + | External _ -> false -let is_alias_stamp_file t = - String.is_prefix t ~prefix:"_build/.aliases/" +let is_in_source_tree = function + | In_source_tree _ -> true + | In_build_dir _ + | External _ -> false -let extract_build_context t = - if String.is_prefix t ~prefix:build_prefix then - let i = String.length build_prefix in - match String.index_from t i '/' with - | exception _ -> - Some - (String.sub t ~pos:i ~len:(String.length t - i), - "") - | j -> - Some - (String.sub t ~pos:i ~len:(j - i), - String.sub t ~pos:(j + 1) ~len:(String.length t - j - 1)) - else - None +let is_alias_stamp_file = function + | In_build_dir s -> String.is_prefix (Local.to_string s) ~prefix:".aliases/" + | In_source_tree _ + | External _ -> false -let extract_build_context_dir t = - if String.is_prefix t ~prefix:build_prefix then - let i = String.length build_prefix in - match String.index_from t i '/' with - | exception _ -> - Some (t, "") - | j -> +let extract_build_context = function + | In_source_tree _ + | External _ -> None + | In_build_dir p when Local.is_root p -> None + | In_build_dir t -> + let t = Local.to_string t in + begin match String.index t '/' with + | None -> + Some ( String.sub t ~pos:0 ~len:(String.length t) + , in_source_tree Local.root ) + | Some j -> Some - (String.sub t ~pos:0 ~len:j, - String.sub t ~pos:(j + 1) ~len:(String.length t - j - 1)) - else - None + ( String.sub t ~pos:0 ~len:j + , String.sub t ~pos:(j + 1) ~len:(String.length t - j - 1) + |> Local.of_string + |> in_source_tree ) + end + +let extract_build_context_dir = function + | In_source_tree _ + | External _ -> None + | In_build_dir t -> + let t_str = Local.to_string t in + begin match String.index t_str '/' with + | None -> Some (in_build_dir t, in_source_tree Local.root) + | Some j -> + Some + ( in_build_dir (Local.of_string (String.sub t_str ~pos:0 ~len:j)) + , (String.sub t_str ~pos:(j + 1) ~len:(String.length t_str - j - 1)) + |> Local.of_string + |> in_source_tree + ) + end let drop_build_context t = Option.map (extract_build_context t) ~f:snd @@ -441,26 +757,29 @@ let drop_optional_build_context t = let split_first_component t = match kind t, is_root t with | Local t, false -> + let t = Local.to_string t in begin match String.index t '/' with | None -> Some (t, root) | Some i -> Some - (String.sub t ~pos:0 ~len:i, - String.sub t ~pos:(i + 1) ~len:(String.length t - i - 1)) + ( String.sub t ~pos:0 ~len:i + , String.sub t ~pos:(i + 1) ~len:(String.length t - i - 1) + |> Local.of_string + |> in_source_tree ) end | _, _ -> None let explode t = match kind t with - | Local "" -> Some [] - | Local s -> Some (String.split s ~on:'/') + | Local p when Local.is_root p -> Some [] + | Local s -> Some (String.split (Local.to_string s) ~on:'/') | External _ -> None let explode_exn t = match explode t with | Some s -> s | None -> Exn.code_error "Path.explode_exn" - ["path", Sexp.atom_or_quoted_string t] + ["path", sexp_of_t t] let exists t = try Sys.file_exists (to_string t) @@ -491,29 +810,39 @@ let unlink_no_err t = try unlink t with _ -> () let build_dir_exists () = is_directory build_dir -let ensure_build_dir_exists () = Local.mkdir_p build_dir +let ensure_build_dir_exists () = + match kind build_dir with + | Local p -> Local.mkdir_p p + | External p -> + let p = External.to_string p in + try + Unix.mkdir p 0o777 + with + | Unix.Unix_error (EEXIST, _, _) -> () + | Unix.Unix_error (ENOENT, _, _) -> + Exn.fatalf "Cannot create external build directory %s. \ + Make sure that the parent dir %s exists." + p (Filename.dirname p) -let extend_basename t ~suffix = t ^ suffix +let extend_basename t ~suffix = + match t with + | In_source_tree t -> in_source_tree (Local.extend_basename t ~suffix) + | In_build_dir t -> in_build_dir (Local.extend_basename t ~suffix) + | External t -> external_ (External.extend_basename t ~suffix) let insert_after_build_dir_exn = let error a b = Exn.code_error "Path.insert_after_build_dir_exn" - [ "path" , Sexp.unsafe_atom_of_string a + [ "path" , sexp_of_t a ; "insert", Sexp.unsafe_atom_of_string b ] in fun a b -> - if not (is_local a) then - error a b - else if a = build_dir then - relative build_dir b - else - match String.lsplit2 a ~on:'/' with - | Some (build_dir', rest) when build_dir = build_dir' -> - Local.append (relative build_dir b) rest - | _ -> - error a b + match a with + | In_build_dir a -> in_build_dir (Local.append (Local.of_string b) a) + | In_source_tree _ + | External _ -> error a b let rm_rf = let rec loop dir = @@ -525,7 +854,7 @@ let rm_rf = Unix.rmdir dir in fun t -> - if not (is_local t) then ( + if not (is_managed t) then ( Exn.code_error "Path.rm_rf called on external dir" ["t", sexp_of_t t] ); @@ -534,10 +863,44 @@ let rm_rf = | exception Unix.Unix_error(ENOENT, _, _) -> () | _ -> loop fn -let change_extension ~ext t = - let t = try Filename.chop_extension t with Not_found -> t in - t ^ ext +let mkdir_p = function + | External s -> + Exn.code_error "Path.mkdir_p cannot create external path" + ["s", External.sexp_of_t s] + | In_source_tree s -> + Exn.code_error "Path.mkdir_p cannot dir in source" + ["s", Local.sexp_of_t s] + | In_build_dir k -> + Kind.mkdir_p (Kind.append_local (Lazy.force build_dir_kind) k) -let extension = Filename.extension +let compare x y = + match x, y with + | External x , External y -> External.compare_val x y + | External _ , _ -> Lt + | _ , External _ -> Gt + | In_source_tree x, In_source_tree y -> Local.compare_val x y + | In_source_tree _, _ -> Lt + | _ , In_source_tree _ -> Gt + | In_build_dir x , In_build_dir y -> Local.compare_val x y + +let extension t = Filename.extension (to_string t) let pp ppf t = Format.pp_print_string ppf (to_string t) + +let pp_debug ppf = function + | In_source_tree s -> + Format.fprintf ppf "(In_source_tree %S)" (Local.to_string s) + | In_build_dir s -> + Format.fprintf ppf "(In_build_dir %S)" (Local.to_string s) + | External s -> Format.fprintf ppf "(External %S)" (External.to_string s) + +module Set = struct + include Set.Make(T) + let sexp_of_t t = Sexp.To_sexp.(list sexp_of_t) (to_list t) + let of_string_set ss ~f = + String.Set.to_list ss + |> List.map ~f + |> of_list +end + +let in_source s = in_source_tree (Local.of_string s) diff --git a/src/stdune/path.mli b/src/stdune/path.mli index dc7e0fb3..0820b2fc 100644 --- a/src/stdune/path.mli +++ b/src/stdune/path.mli @@ -1,19 +1,6 @@ (** In the current workspace (anything under the current project root) *) module Local : sig type t - - val compare : t -> t -> Ordering.t - - module Set : Set.S with type elt = t - - val root : t - val is_root : t -> bool - val to_string : t -> string - val mkdir_p : t -> unit - val ensure_parent_directory_exists : t -> unit - val append : t -> t -> t - val descendant : t -> of_:t -> t option - val parent : t -> t end (** In the outside world *) @@ -21,12 +8,18 @@ module External : sig type t val to_string : t -> string + val of_string : string -> t + val initial_cwd : t + + val cwd : unit -> t end module Kind : sig - type t = + type t = private | External of External.t | Local of Local.t + + val of_string : string -> t end type t @@ -45,9 +38,6 @@ end module Map : Map.S with type key = t - -val kind : t -> Kind.t - val of_string : ?error_loc:Usexp.Loc.t -> string -> t val to_string : t -> string @@ -57,17 +47,17 @@ val to_string_maybe_quoted : t -> string val root : t val is_root : t -> bool -val is_local : t -> bool +val is_managed : t -> bool val relative : ?error_loc:Usexp.Loc.t -> t -> string -> t (** Create an external path. If the argument is relative, assume it is relative to the initial directory jbuilder was launched in. *) -val absolute : string -> t +val of_filename_relative_to_initial_cwd : string -> t (** Convert a path to an absolute filename. Must be called after the workspace root has been set. [root] is the root directory of local paths *) -val to_absolute_filename : t -> root:string -> string +val to_absolute_filename : t -> string val reach : t -> from:t -> string @@ -117,11 +107,15 @@ val build_dir : t (** [is_in_build_dir t = is_descendant t ~of:build_dir] *) val is_in_build_dir : t -> bool -(** [is_in_build_dir t = is_local t && not (is_in_build_dir t)] *) +(** [is_in_build_dir t = is_managed t && not (is_in_build_dir t)] *) val is_in_source_tree : t -> bool val is_alias_stamp_file : t -> bool +(** [is_strict_descendant_of_build_dir t = is_in_build_dir t && t <> + build_dir] *) +val is_strict_descendant_of_build_dir : t -> bool + (** Split after the first component if [t] is local *) val split_first_component : t -> (string * t) option @@ -134,14 +128,24 @@ val rmdir : t -> unit val unlink : t -> unit val unlink_no_err : t -> unit val rm_rf : t -> unit - -(** Changes the extension of the filename (or adds an extension if there was none) *) -val change_extension : ext:string -> t -> t +val mkdir_p : t -> unit val extension : t -> string val pp : Format.formatter -> t -> unit +val pp_debug : Format.formatter -> t -> unit val build_dir_exists : unit -> bool val ensure_build_dir_exists : unit -> unit + +(** set the build directory. Can only be called once and must be done before + paths are converted to strings elsewhere. *) +val set_build_dir : Kind.t -> unit + +(** paths guaranteed to be in the source directory *) +val in_source : string -> t + +(** Set the workspace root. Can onyl be called once and the path must be + absolute *) +val set_root : External.t -> unit diff --git a/src/utop.ml b/src/utop.ml index 82a17d02..cd0907fc 100644 --- a/src/utop.ml +++ b/src/utop.ml @@ -11,8 +11,7 @@ let pp_ml fmt include_dirs = let pp_include fmt = let pp_sep fmt () = Format.fprintf fmt "@ ; " in Format.pp_print_list ~pp_sep (fun fmt p -> - Format.fprintf fmt "%S" (Path.to_absolute_filename p - ~root:!Clflags.workspace_root) + Format.fprintf fmt "%S" (Path.to_absolute_filename p) ) fmt in Format.fprintf fmt "@[Clflags.include_dirs :=@ [ %a@ ]@];@." diff --git a/test/blackbox-tests/cram.mll b/test/blackbox-tests/cram.mll index 124bf06b..ddc953bf 100644 --- a/test/blackbox-tests/cram.mll +++ b/test/blackbox-tests/cram.mll @@ -151,7 +151,7 @@ and postprocess tbl b = parse | _ -> 255 in let ext_replace = make_ext_replace configurator in - Path.of_string temp_file + Path.of_filename_relative_to_initial_cwd temp_file |> Io.lines_of_file |> List.iter ~f:(fun line -> Printf.bprintf buf " %s\n" diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index 8dcdd19a..c569397a 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -56,6 +56,14 @@ test-cases/cross-compilation (progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))) +(alias + ((name custom-build-dir) + (deps ((package dune) (files_recursively_in test-cases/custom-build-dir))) + (action + (chdir + test-cases/custom-build-dir + (progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))) + (alias ((name depend-on-the-universe) (deps @@ -518,6 +526,7 @@ (alias configurator) (alias copy_files) (alias cross-compilation) + (alias custom-build-dir) (alias depend-on-the-universe) (alias env) (alias exclude-missing-module) @@ -579,6 +588,7 @@ (alias configurator) (alias copy_files) (alias cross-compilation) + (alias custom-build-dir) (alias depend-on-the-universe) (alias env) (alias exclude-missing-module) diff --git a/test/blackbox-tests/test-cases/bad-alias-error/run.t b/test/blackbox-tests/test-cases/bad-alias-error/run.t index 67f63b48..b614b185 100644 --- a/test/blackbox-tests/test-cases/bad-alias-error/run.t +++ b/test/blackbox-tests/test-cases/bad-alias-error/run.t @@ -4,4 +4,4 @@ Tried to reference path outside build dir: "/foo/bar" $ dune runtest --root outside-workspace 2>&1 | grep -v Entering File "jbuild", line 4, characters 16-39: - Error: path outside the workspace: ./../../../foobar from _build/default + Error: path outside the workspace: ./../../../foobar from default diff --git a/test/blackbox-tests/test-cases/custom-build-dir/jbuild b/test/blackbox-tests/test-cases/custom-build-dir/jbuild new file mode 100644 index 00000000..11200798 --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-build-dir/jbuild @@ -0,0 +1,3 @@ +(jbuild_version 1) + +(rule (with-stdout-to foo (echo "foobar"))) diff --git a/test/blackbox-tests/test-cases/custom-build-dir/run.t b/test/blackbox-tests/test-cases/custom-build-dir/run.t new file mode 100644 index 00000000..c2fef77e --- /dev/null +++ b/test/blackbox-tests/test-cases/custom-build-dir/run.t @@ -0,0 +1,43 @@ + $ jbuilder build foo --build-dir _foobar/ && find _foobar | grep -v '/[.]' | LANG=C sort + _foobar + _foobar/default + _foobar/default/foo + _foobar/log + + $ rm -rf _foobar + + $ jbuilder build foo --build-dir . + Error: Invalid build directory: . + The build directory must be an absolute path or a sub-directory of the root of the workspace. + [1] + + $ jbuilder build foo --build-dir src/foo + Error: Invalid build directory: src/foo + The build directory must be an absolute path or a sub-directory of the root of the workspace. + [1] + + $ mkdir project + $ cp jbuild project/jbuild + +Maybe this case should be supported? + + $ cd project && jbuilder build foo --build-dir ../build + Path outside the workspace: ../build from . + [1] + +Test with build directory being an absolute path + + $ X=$PWD/build; cd project && jbuilder build foo --build-dir $X + $ find build | grep -v '/[.]' | LANG=C sort + build + build/default + build/default/foo + build/log + + $ rm -rf build + +Test with a build directory that doesn't start with _ + + $ touch pkg.opam + $ dune build --build-dir build pkg.opam + $ dune build --build-dir build diff --git a/test/blackbox-tests/test-cases/inline_tests/run.t b/test/blackbox-tests/test-cases/inline_tests/run.t index cc478036..e3620e0b 100644 --- a/test/blackbox-tests/test-cases/inline_tests/run.t +++ b/test/blackbox-tests/test-cases/inline_tests/run.t @@ -1,6 +1,6 @@ $ env -u OCAMLRUNPARAM jbuilder runtest simple run alias simple/runtest (exit 2) - (cd _build/default/simple && ./.foo_simple.inline-tests/run.exe) + (cd _build/default/simple && .foo_simple.inline-tests/run.exe) Fatal error: exception File "simple/.foo_simple.inline-tests/run.ml", line 1, characters 10-16: Assertion failed [1] diff --git a/test/unit-tests/action.mlt b/test/unit-tests/action.mlt index 45ba02a7..909b3866 100644 --- a/test/unit-tests/action.mlt +++ b/test/unit-tests/action.mlt @@ -5,6 +5,7 @@ open Dune;; open Import;; open Action.Infer.Outcome;; +Stdune.Path.set_build_dir (Path.Kind.of_string "_build");; let p = Path.of_string;; let infer (a : Action.t) = @@ -12,6 +13,7 @@ let infer (a : Action.t) = (List.map (Path.Set.to_list x.deps) ~f:Path.to_string, List.map (Path.Set.to_list x.targets) ~f:Path.to_string) [%%expect{| +- : unit = () val p : ?error_loc:Usexp.Loc.t -> string -> Dune.Import.Path.t = val infer : Dune.Action.t -> string list * string list = |}] diff --git a/test/unit-tests/path.mlt b/test/unit-tests/path.mlt index dfcb4fed..d7c207cd 100644 --- a/test/unit-tests/path.mlt +++ b/test/unit-tests/path.mlt @@ -1,17 +1,21 @@ (* -*- tuareg -*- *) open Stdune;; +Path.set_root (Path.External.cwd ()); +Path.set_build_dir (Path.Kind.of_string "_build"); Printexc.record_backtrace false;; let r = Path.(relative root);; +let e = Path.of_filename_relative_to_initial_cwd;; -#install_printer Path.pp;; +#install_printer Path.pp_debug;; Path.(let p = relative root "foo" in descendant p ~of_:p) [%%expect{| - : unit = () val r : string -> Stdune.Path.t = -- : Stdune.Path.t option = Some foo +val e : string -> Stdune.Path.t = +- : Stdune.Path.t option = Some (In_source_tree ".") |}] (* different strings but same length *) @@ -60,44 +64,44 @@ Path.(is_descendant (r "glob/foo") ~of_:(r "glob/")) - : bool = true |}] -Path.(is_descendant (Path.absolute "/foo/bar") ~of_:(Path.absolute "/foo")) +Path.(is_descendant (e "/foo/bar") ~of_:(e "/foo")) [%%expect{| - : bool = false |}] -Path.(is_descendant (Path.absolute "/foo/bar") ~of_:(Path.absolute "/foo/bar")) +Path.(is_descendant (e "/foo/bar") ~of_:(e "/foo/bar")) [%%expect{| - : bool = false |}] -Path.(is_descendant (Path.absolute "/foo/bar") ~of_:(Path.absolute "/foo/bar/")) +Path.(is_descendant (e "/foo/bar") ~of_:(e "/foo/bar/")) [%%expect{| - : bool = false |}] -Path.(is_descendant (Path.absolute "/foo/bar/") ~of_:(Path.absolute "/foo/bar")) +Path.(is_descendant (e "/foo/bar/") ~of_:(e "/foo/bar")) [%%expect{| - : bool = false |}] -Path.(is_descendant (Path.absolute "/foo/bar") ~of_:(Path.absolute "/")) +Path.(is_descendant (e "/foo/bar") ~of_:(e "/")) [%%expect{| - : bool = false |}] Path.(descendant (r "foo") ~of_:(r "foo/")) [%%expect{| -- : Stdune.Path.t option = Some foo +- : Stdune.Path.t option = Some (In_source_tree ".") |}] Path.(descendant (r "foo/") ~of_:(r "foo")) [%%expect{| -- : Stdune.Path.t option = Some foo +- : Stdune.Path.t option = Some (In_source_tree ".") |}] Path.(descendant (r "foo/bar") ~of_:(r "foo")) [%%expect{| -- : Stdune.Path.t option = Some bar +- : Stdune.Path.t option = Some (In_source_tree "bar") |}] Path.(descendant Path.root ~of_:(r "foo")) @@ -107,42 +111,44 @@ Path.(descendant Path.root ~of_:(r "foo")) Path.(descendant Path.root ~of_:Path.root) [%%expect{| -- : Stdune.Path.t option = Some . +- : Stdune.Path.t option = Some (In_source_tree ".") |}] Path.(descendant (r "foo") ~of_:Path.root) [%%expect{| -- : Stdune.Path.t option = Some foo +- : Stdune.Path.t option = Some (In_source_tree "foo") |}] Path.(descendant (relative build_dir "foo") ~of_:root) [%%expect{| -- : Stdune.Path.t option = Some _build/foo +- : Stdune.Path.t option = Some (In_source_tree "_build/foo") |}] Path.(descendant (relative build_dir "foo") ~of_:(absolute "/foo/bar")) [%%expect{| -- : Stdune.Path.t option = None +File "test/unit-tests/path.mlt", line 127, characters 50-58: +Error: Unbound value absolute |}] Path.(descendant (relative build_dir "foo/bar") ~of_:build_dir) [%%expect{| -- : Stdune.Path.t option = Some foo/bar +- : Stdune.Path.t option = Some (In_source_tree "foo/bar") |}] Path.(descendant (relative build_dir "foo/bar") ~of_:(relative build_dir "foo")) [%%expect{| -- : Stdune.Path.t option = Some bar +- : Stdune.Path.t option = Some (In_source_tree "bar") |}] Path.(descendant (relative build_dir "foo/bar") ~of_:(relative build_dir "foo")) [%%expect{| -- : Stdune.Path.t option = Some bar +- : Stdune.Path.t option = Some (In_source_tree "bar") |}] Path.(descendant (absolute "/foo/bar") ~of_:(absolute "/foo")) [%%expect{| -- : Stdune.Path.t option = None +File "test/unit-tests/path.mlt", line 148, characters 18-26: +Error: Unbound value absolute |}] Path.explode (Path.of_string "a/b/c"); @@ -182,30 +188,30 @@ Path.reach (Path.of_string "bar/foo") ~from:(Path.of_string "bar/baz/y") Path.relative (Path.of_string "relative") "/absolute/path" [%%expect{| -- : Stdune.Path.t = /absolute/path +- : Stdune.Path.t = (External "/absolute/path") |}] Path.relative (Path.of_string "/abs1") "/abs2" [%%expect{| -- : Stdune.Path.t = /abs2 +- : Stdune.Path.t = (External "/abs2") |}] Path.relative (Path.of_string "/abs1") "" [%%expect{| -- : Stdune.Path.t = /abs1 +- : Stdune.Path.t = (External "/abs1") |}] Path.relative Path.root "/absolute/path" [%%expect{| -- : Stdune.Path.t = /absolute/path +- : Stdune.Path.t = (External "/absolute/path") |}] -Path.absolute "/absolute/path" +e "/absolute/path" [%%expect{| -- : Stdune.Path.t = /absolute/path +- : Stdune.Path.t = (External "/absolute/path") |}] -Path.is_local (Path.absolute "relative/path") +Path.is_managed (e "relative/path") [%%expect{| - : bool = false |}] @@ -217,42 +223,42 @@ Exception: Stdune__Exn.Code_error . Path.insert_after_build_dir_exn Path.build_dir "foobar" [%%expect{| -- : Stdune.Path.t = _build/foobar +- : Stdune.Path.t = (In_build_dir "foobar") |}] Path.insert_after_build_dir_exn (Path.relative Path.build_dir "qux") "foobar" [%%expect{| -- : Stdune.Path.t = _build/foobar/qux +- : Stdune.Path.t = (In_build_dir "foobar/qux") |}] Path.append Path.build_dir (Path.relative Path.root "foo") [%%expect{| -- : Stdune.Path.t = _build/foo +- : Stdune.Path.t = (In_build_dir "foo") |}] Path.append Path.build_dir (Path.relative Path.build_dir "foo") [%%expect{| -- : Stdune.Path.t = _build/_build/foo +- : Stdune.Path.t = (In_build_dir "_build/foo") |}] Path.append Path.root (Path.relative Path.build_dir "foo") [%%expect{| -- : Stdune.Path.t = _build/foo +- : Stdune.Path.t = (In_source_tree "_build/foo") |}] Path.append Path.root (Path.relative Path.root "foo") [%%expect{| -- : Stdune.Path.t = foo +- : Stdune.Path.t = (In_source_tree "foo") |}] Path.append (Path.of_string "/root") (Path.relative Path.root "foo") [%%expect{| -- : Stdune.Path.t = /root/foo +- : Stdune.Path.t = (External "/root/foo") |}] Path.append (Path.of_string "/root") (Path.relative Path.build_dir "foo") [%%expect{| -- : Stdune.Path.t = /root/_build/foo +- : Stdune.Path.t = (External "/root/_build/foo") |}] Path.rm_rf (Path.of_string "/does/not/exist/foo/bar/baz") @@ -262,7 +268,7 @@ Exception: Stdune__Exn.Code_error . Path.drop_build_context (Path.relative Path.build_dir "foo/bar") [%%expect{| -- : Stdune.Path.t option = Some bar +- : Stdune.Path.t option = Some (In_source_tree "bar") |}] Path.drop_build_context (Path.of_string "foo/bar") @@ -270,7 +276,7 @@ Path.drop_build_context (Path.of_string "foo/bar") - : Stdune.Path.t option = None |}] -Path.drop_build_context (Path.absolute "/foo/bar") +Path.drop_build_context (e "/foo/bar") [%%expect{| - : Stdune.Path.t option = None |}] @@ -282,6 +288,11 @@ Path.drop_build_context Path.build_dir Path.is_in_build_dir Path.build_dir [%%expect{| +- : bool = true +|}] + +Path.is_strict_descendant_of_build_dir Path.build_dir +[%%expect{| - : bool = false |}] @@ -296,19 +307,24 @@ Path.(reach_for_running (relative build_dir "foo/baz") - : string = "../../baz" |}] -Path.(reach_for_running (Path.absolute "/fake/path") +Path.(reach_for_running (e "/fake/path") ~from:(relative build_dir "foo/bar/baz")) [%%expect{| - : string = "/fake/path" |}] -Path.(reach_for_running (relative build_dir "foo/baz") - ~from:(Path.absolute "/fake/path")) -[%%expect{| -Exception: Stdune__Exn.Code_error . -|}] - Path.(reach_for_running (relative root "foo") ~from:(Path.relative root "foo")) [%%expect{| - : string = "./." |}] + +Path.relative Path.root "_build" +[%%expect{| +- : Stdune.Path.t = (In_build_dir ".") +|}] + +(* This is not right, but kind of annoying to fix :/ *) +Path.relative (r "foo") "../_build" +[%%expect{| +- : Stdune.Path.t = (In_build_dir ".") +|}] diff --git a/test/unit-tests/tests.mlt b/test/unit-tests/tests.mlt index af422c8b..2323e6a7 100644 --- a/test/unit-tests/tests.mlt +++ b/test/unit-tests/tests.mlt @@ -5,6 +5,11 @@ open Dune open Import +let () = + Path.set_root (Path.External.cwd ()); + Path.set_build_dir (Path.Kind.of_string "_build") +;; + let print_pkg ppf pkg = Format.fprintf ppf "" (Findlib.Package.name pkg) ;; @@ -17,7 +22,7 @@ val print_pkg : Format.formatter -> Dune.Findlib.Package.t -> unit = |}] let findlib = - let cwd = Path.absolute (Sys.getcwd ()) in + let cwd = Path.of_filename_relative_to_initial_cwd (Sys.getcwd ()) in Findlib.create ~stdlib_dir:cwd ~path:[Path.relative cwd "test/unit-tests/findlib-db"] @@ -51,7 +56,7 @@ open Meta #install_printer Simplified.pp;; let meta = - Path.of_string "test/unit-tests/findlib-db/foo/META" + Path.in_source "test/unit-tests/findlib-db/foo/META" |> Meta.load ~name:"foo" [%%expect{| @@ -80,8 +85,8 @@ val meta : Dune.Meta.Simplified.t = #install_printer Findlib.Config.pp;; let conf = - Findlib.Config.load (Path.of_string "test/unit-tests/toolchain") - ~toolchain:"tlc" ~context:"" + Findlib.Config.load (Path.in_source "test/unit-tests/toolchain") + ~toolchain:"tlc" ~context:"" [%%expect{| val conf : Dune.Findlib.Config.t =