matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #846 from rgrinberg/sym-path-sane 

Implement --build-dir and change Path.t to use symbolic paths
This commit is contained in:
Rudi Grinberg 2018-06-02 18:51:34 +07:00 committed by GitHub
parent b012327f9e ffd5785e20
commit a0fc548eb6
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
35 changed files with 891 additions and 401 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
CHANGES.md
View File

@ -46,6 +46,9 @@ next
- Fix a bug where Dune ignored previous occurences of duplicated - Fix a bug where Dune ignored previous occurences of duplicated
fields (#779, @diml) 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) 1.0+beta20 (10/04/2018)
----------------------- -----------------------

37
bin/main.ml
View File

@ -22,6 +22,7 @@ type common =
; auto_promote : bool ; auto_promote : bool
; force : bool ; force : bool
; ignore_promoted_rules : bool ; ignore_promoted_rules : bool
; build_dir : string
; (* Original arguments for the external-lib-deps hint *) ; (* Original arguments for the external-lib-deps hint *)
orig_args : string list orig_args : string list
; config : Config.t ; config : Config.t
@ -29,14 +30,17 @@ type common =
let prefix_target common s = common.target_prefix ^ s 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_dep_path := c.debug_dep_path;
Clflags.debug_findlib := c.debug_findlib; Clflags.debug_findlib := c.debug_findlib;
Clflags.debug_backtraces := c.debug_backtraces; Clflags.debug_backtraces := c.debug_backtraces;
Clflags.capture_outputs := c.capture_outputs; 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.diff_command := c.diff_command;
Clflags.auto_promote := c.auto_promote; Clflags.auto_promote := c.auto_promote;
Clflags.force := c.force; Clflags.force := c.force;
@ -47,6 +51,10 @@ let set_common c ~targets =
; 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 restore_cwd_and_execve common prog argv env =
let env = Env.to_unix env in let env = Env.to_unix env in
let prog = let prog =
@ -224,7 +232,9 @@ let common =
orig) orig)
x x
display display
build_dir
= =
let build_dir = Option.value ~default:"_build" build_dir in
let root, to_cwd = let root, to_cwd =
match root with match root with
| Some dn -> (dn, []) | Some dn -> (dn, [])
@ -280,6 +290,7 @@ let common =
List.map ~f:Package.Name.of_string (String.split s ~on:','))) List.map ~f:Package.Name.of_string (String.split s ~on:',')))
; x ; x
; config ; config
; build_dir
} }
in in
let docs = copts_sect in let docs = copts_sect in
@ -518,6 +529,14 @@ let common =
& info ["x"] ~docs & info ["x"] ~docs
~doc:{|Cross-compile using this toolchain.|}) ~doc:{|Cross-compile using this toolchain.|})
in 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 = let diff_command =
Arg.(value Arg.(value
& opt (some string) None & opt (some string) None
@ -537,6 +556,7 @@ let common =
$ merged_options $ merged_options
$ x $ x
$ display $ display
$ build_dir
) )
let installed_libraries = let installed_libraries =
@ -593,7 +613,7 @@ let resolve_package_install setup pkg =
|> List.map ~f:Package.Name.to_string)) |> List.map ~f:Package.Name.to_string))
let target_hint (setup : Main.setup) path = 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 sub_dir = Option.value ~default:path (Path.parent path) in
let candidates = Build_system.all_targets setup.build_system in let candidates = Build_system.all_targets setup.build_system in
let candidates = let candidates =
@ -650,7 +670,7 @@ let resolve_targets ~log common (setup : Main.setup) user_targets =
check_path path; check_path path;
if Path.is_root path then if Path.is_root path then
die "@@ on the command line must be followed by a valid alias name" 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" die "@@ on the command line must be followed by a relative path"
else else
Ok [Alias_rec path] Ok [Alias_rec path]
@ -660,7 +680,7 @@ let resolve_targets ~log common (setup : Main.setup) user_targets =
let can't_build path = let can't_build path =
Error (path, target_hint setup path); Error (path, target_hint setup path);
in in
if not (Path.is_local path) then if not (Path.is_managed path) then
Ok [File path] Ok [File path]
else if Path.is_in_build_dir path then begin else if Path.is_in_build_dir path then begin
if Build_system.is_target setup.build_system path then if Build_system.is_target setup.build_system path then
@ -1269,8 +1289,9 @@ let utop =
; `Blocks help_secs ; `Blocks help_secs
] in ] in
let go common dir ctx_name args = let go common dir ctx_name args =
set_dirs common;
let utop_target = dir |> Path.of_string |> Utop.utop_exe |> Path.to_string in 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 log = Log.create common in
let (build_system, context, utop_path) = let (build_system, context, utop_path) =
(Main.setup ~log common >>= fun setup -> (Main.setup ~log common >>= fun setup ->

17
doc/usage.rst
View File

@ -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 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 substituted watermarks. If you which to do so, you need to configure
topkg and use it instead of ``jbuilder subst``. 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

17
src/action.ml
View File

@ -352,7 +352,7 @@ module Unexpanded = struct
| List _ -> t sexp | List _ -> t sexp
let check_mkdir loc path = let check_mkdir loc path =
if not (Path.is_local path) then if not (Path.is_managed path) then
Loc.fail loc Loc.fail loc
"(mkdir ...) is not supported for paths outside of the workspace:\n\ "(mkdir ...) is not supported for paths outside of the workspace:\n\
\ %a\n" \ %a\n"
@ -843,20 +843,13 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
Path.rm_rf path; Path.rm_rf path;
Fiber.return () Fiber.return ()
| Mkdir path -> | Mkdir path ->
(match Path.kind path with Path.mkdir_p path;
| 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);
Fiber.return () Fiber.return ()
| Digest_files paths -> | Digest_files paths ->
let s = let s =
let data = let data =
List.map paths ~f:(fun fn -> List.map paths ~f:(fun fn ->
(fn, Utils.Cached_digest.file fn)) (Path.to_string fn, Utils.Cached_digest.file fn))
in in
Digest.string Digest.string
(Marshal.to_string data []) (Marshal.to_string data [])
@ -930,7 +923,7 @@ let exec ~targets ~context t =
let sandbox t ~sandboxed ~deps ~targets = let sandbox t ~sandboxed ~deps ~targets =
Progn Progn
[ Progn (List.filter_map deps ~f:(fun path -> [ 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)) Some (Ast.Symlink (path, sandboxed path))
else else
None)) None))
@ -940,7 +933,7 @@ let sandbox t ~sandboxed ~deps ~targets =
~f_path:(fun ~dir:_ p -> sandboxed p) ~f_path:(fun ~dir:_ p -> sandboxed p)
~f_program:(fun ~dir:_ x -> Result.map x ~f:sandboxed) ~f_program:(fun ~dir:_ x -> Result.map x ~f:sandboxed)
; Progn (List.filter_map targets ~f:(fun path -> ; 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)) Some (Ast.Rename (sandboxed path, path))
else else
None)) None))

2
src/artifacts.ml
View File

@ -53,7 +53,7 @@ let create (context : Context.t) ~public_libs l ~f =
let binary t ?hint name = let binary t ?hint name =
if not (Filename.is_relative name) then if not (Filename.is_relative name) then
Ok (Path.absolute name) Ok (Path.of_filename_relative_to_initial_cwd name)
else else
match String.Map.find t.local_bins name with match String.Map.find t.local_bins name with
| Some path -> Ok path | Some path -> Ok path

2
src/bin.ml
View File

@ -7,7 +7,7 @@ let path_sep =
':' ':'
let parse_path ?(sep=path_sep) s = 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 = let path =
match Env.get Env.initial "PATH" with match Env.get Env.initial "PATH" with

49
src/build_system.ml
View File

@ -373,7 +373,7 @@ type t =
[(deps (filename + contents), targets (filename only), action)] *) [(deps (filename + contents), targets (filename only), action)] *)
trace : (Path.t, Digest.t) Hashtbl.t trace : (Path.t, Digest.t) Hashtbl.t
; file_tree : File_tree.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 dirs : (Path.t, Dir_status.t) Hashtbl.t
; mutable gen_rules : ; mutable gen_rules :
(dir:Path.t -> string list -> extra_sub_directories_to_keep) String.Map.t (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 else if dir = Path.build_dir then
(* Not allowed to look here *) (* Not allowed to look here *)
Dir_status.Loaded Path.Set.empty 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 Dir_status.Loaded
(match Path.readdir_unsorted dir with (match Path.readdir_unsorted dir with
| exception _ -> Path.Set.empty | exception _ -> Path.Set.empty
@ -601,24 +601,20 @@ let clear_targets_digests_after_rule_execution targets =
let make_local_dirs t paths = let make_local_dirs t paths =
Path.Set.iter paths ~f:(fun path -> Path.Set.iter paths ~f:(fun path ->
match Path.kind path with if Path.is_managed path && not (Path.Set.mem t.local_mkdirs path) then begin
| Local path -> Path.mkdir_p path;
if not (Path.Local.Set.mem t.local_mkdirs path) then begin t.local_mkdirs <- Path.Set.add t.local_mkdirs path
Path.Local.mkdir_p path; end)
t.local_mkdirs <- Path.Local.Set.add t.local_mkdirs path
end
| _ -> ())
let make_local_parent_dirs t paths ~map_path = let make_local_parent_dirs t paths ~map_path =
Path.Set.iter paths ~f:(fun path -> Path.Set.iter paths ~f:(fun path ->
match Path.kind (map_path path) with let path = map_path path in
| Local path when not (Path.Local.is_root path) -> if Path.is_managed path then (
let parent = Path.Local.parent path in Option.iter (Path.parent path) ~f:(fun parent ->
if not (Path.Local.Set.mem t.local_mkdirs parent) then begin if not (Path.Set.mem t.local_mkdirs parent) then begin
Path.Local.mkdir_p parent; Path.mkdir_p parent;
t.local_mkdirs <- Path.Local.Set.add t.local_mkdirs parent t.local_mkdirs <- Path.Set.add t.local_mkdirs parent
end end)))
| _ -> ())
let sandbox_dir = Path.relative Path.build_dir ".sandbox" 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 targets_as_list = Path.Set.to_list targets in
let hash = let hash =
let trace = let trace =
(List.map all_deps_as_list ~f:(fun fn -> ( all_deps_as_list
(fn, Utils.Cached_digest.file fn)), |> List.map ~f:(fun fn ->
targets_as_list, (Path.to_string fn, Utils.Cached_digest.file fn)),
Option.map context ~f:(fun c -> c.name), List.map targets_as_list ~f:Path.to_string,
action) Option.map context ~f:(fun c -> c.name),
Action.for_shell action)
in in
Digest.string (Marshal.to_string trace []) Digest.string (Marshal.to_string trace [])
in in
@ -760,7 +757,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
| Some sandbox_dir -> | Some sandbox_dir ->
Path.rm_rf sandbox_dir; Path.rm_rf sandbox_dir;
let sandboxed path = let sandboxed path =
if Path.is_local path then if Path.is_managed path then
Path.append sandbox_dir path Path.append sandbox_dir path
else else
path path
@ -1061,7 +1058,7 @@ and wait_for_file t fn =
| Some file -> wait_for_file_found fn file | Some file -> wait_for_file_found fn file
| None -> | None ->
let dir = Path.parent_exn fn in 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; load_dir t ~dir;
match Hashtbl.find t.files fn with match Hashtbl.find t.files fn with
| Some file -> wait_for_file_found fn file | Some file -> wait_for_file_found fn file
@ -1179,7 +1176,7 @@ let create ~contexts ~file_tree ~hook =
; files = Hashtbl.create 1024 ; files = Hashtbl.create 1024
; packages = Hashtbl.create 1024 ; packages = Hashtbl.create 1024
; trace = Trace.load () ; trace = Trace.load ()
; local_mkdirs = Path.Local.Set.empty ; local_mkdirs = Path.Set.empty
; dirs = Hashtbl.create 1024 ; dirs = Hashtbl.create 1024
; load_dir_stack = [] ; load_dir_stack = []
; file_tree ; file_tree
@ -1473,7 +1470,7 @@ let get_collector t ~dir =
"Build_system.get_collector called on source directory" "Build_system.get_collector called on source directory"
else if dir = Path.build_dir then else if dir = Path.build_dir then
"Build_system.get_collector called on build_dir" "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" "Build_system.get_collector called on external directory"
else else
"Build_system.get_collector called on closed directory") "Build_system.get_collector called on closed directory")

1
src/clflags.ml
View File

@ -3,7 +3,6 @@ let g = ref true
let debug_findlib = ref false let debug_findlib = ref false
let warnings = ref "-40" let warnings = ref "-40"
let debug_dep_path = ref false let debug_dep_path = ref false
let workspace_root = ref "."
let external_lib_deps_hint = ref [] let external_lib_deps_hint = ref []
let capture_outputs = ref true let capture_outputs = ref true
let debug_backtraces = ref false let debug_backtraces = ref false

3
src/clflags.mli
View File

@ -15,9 +15,6 @@ val debug_findlib : bool ref
(** Compiler warnings *) (** Compiler warnings *)
val warnings : string ref 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 ..." *) (** The command line for "Hint: try: jbuilder external-lib-deps ..." *)
val external_lib_deps_hint : string list ref val external_lib_deps_hint : string list ref

7
src/config.ml
View File

@ -15,7 +15,9 @@ let local_install_lib_dir ~context ~package =
(Path.relative (local_install_dir ~context) "lib") (Path.relative (local_install_dir ~context) "lib")
package 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" let jbuilder_keep_fname = ".jbuilder-keep"
@ -108,7 +110,8 @@ let t =
}) })
let user_config_file = 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 = let load_config_file p =
t (Io.Sexp.load p ~mode:Many_as_one) t (Io.Sexp.load p ~mode:Many_as_one)

21
src/configurator/v1.ml
View File

@ -142,8 +142,12 @@ let run t ~dir cmd =
(Filename.quote stdout_fn) (Filename.quote stdout_fn)
(Filename.quote stderr_fn) (Filename.quote stderr_fn)
in in
let stdout = Io.read_file (Path.of_string stdout_fn) in let stdout =
let stderr = Io.read_file (Path.of_string stderr_fn) in 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 "-> process exited with code %d" exit_code;
logf t "-> stdout:"; logf t "-> stdout:";
List.iter (String.split_lines stdout) ~f:(logf t " | %s"); 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 c_fname = base ^ ".c" in
let obj_fname = base ^ t.ext_obj in let obj_fname = base ^ t.ext_obj in
let exe_fname = base ^ ".exe" 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:"; logf t "compiling c program:";
List.iter (String.split_lines code) ~f:(logf t " | %s"); List.iter (String.split_lines code) ~f:(logf t " | %s");
let run_ok args = let run_ok args =
@ -267,7 +271,7 @@ let compile_c_prog t ?(c_flags=[]) code =
let base = dir ^/ "test" in let base = dir ^/ "test" in
let c_fname = base ^ ".c" in let c_fname = base ^ ".c" in
let obj_fname = base ^ t.ext_obj 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:"; logf t "compiling c program:";
List.iter (String.split_lines code) ~f:(logf t " | %s"); List.iter (String.split_lines code) ~f:(logf t " | %s");
let run_ok args = let run_ok args =
@ -284,7 +288,10 @@ let compile_c_prog t ?(c_flags=[]) code =
] ]
]) ])
in 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 = let c_test t ?c_flags ?link_flags code =
match compile_and_link_c_prog t ?c_flags ?link_flags code with 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; logf t "writing header file %s" fname;
List.iter lines ~f:(logf t " | %s"); List.iter lines ~f:(logf t " | %s");
let tmp_fname = fname ^ ".tmp" in 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 Sys.rename tmp_fname fname
end end
@ -479,7 +486,7 @@ module Pkg_config = struct
end end
let write_flags fname s = 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 let sexp = Usexp.List(List.map ~f:Usexp.atom_or_quoted_string s) in
Io.write_file path (Usexp.to_string sexp) Io.write_file path (Usexp.to_string sexp)

20
src/context.ml
View File

@ -152,7 +152,7 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets ~profile () =
(match Env.get env "OCAMLFIND_CONF" with (match Env.get env "OCAMLFIND_CONF" with
| Some s -> Fiber.return s | Some s -> Fiber.return s
| None -> Process.run_capture_line ~env Strict fn ["printconf"; "conf"]) | None -> Process.run_capture_line ~env Strict fn ["printconf"; "conf"])
>>| Path.absolute) >>| Path.of_filename_relative_to_initial_cwd)
in in
let create_one ~name ~implicit ?findlib_toolchain ?host ~merlin () = 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 -> | Some s ->
match Filename.analyze_program_name s with match Filename.analyze_program_name s with
| In_path | Relative_to_current_dir -> which s | In_path | Relative_to_current_dir -> which s
| Absolute -> Some (Path.absolute s)) | Absolute -> Some (Path.of_filename_relative_to_initial_cwd s))
in in
let ocamlc = let ocamlc =
@ -221,7 +221,8 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets ~profile () =
let findlib_path () = let findlib_path () =
match kind, findlib_toolchain, Setup.library_path with match kind, findlib_toolchain, Setup.library_path with
| Default, None, Some l -> | 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. *) (* If ocamlfind is present, it has precedence over everything else. *)
match which "ocamlfind" with match which "ocamlfind" with
@ -236,13 +237,13 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets ~profile () =
>>| fun l -> >>| fun l ->
(* Don't prepend the contents of [OCAMLPATH] since findlib (* Don't prepend the contents of [OCAMLPATH] since findlib
does it already *) does it already *)
List.map l ~f:Path.absolute List.map l ~f:Path.of_filename_relative_to_initial_cwd
| None -> | None ->
(* If there no ocamlfind in the PATH, check if we have opam (* If there no ocamlfind in the PATH, check if we have opam
and assume a standard opam setup *) and assume a standard opam setup *)
opam_config_var ~env ~cache:opam_var_cache "lib" opam_config_var ~env ~cache:opam_var_cache "lib"
>>| function >>| function
| Some s -> ocamlpath @ [Path.absolute s] | Some s -> ocamlpath @ [Path.of_filename_relative_to_initial_cwd s]
| None -> | None ->
(* If neither opam neither ocamlfind are present, assume (* If neither opam neither ocamlfind are present, assume
that libraries are [dir ^ "/../lib"] *) that libraries are [dir ^ "/../lib"] *)
@ -335,7 +336,8 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin ~targets ~profile () =
; build_dir ; build_dir
; path ; path
; toplevel_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_bin = dir
; ocaml = (match which "ocaml" with Some p -> p | None -> prog_not_found_in_path "ocaml") ; 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 = let install_prefix t =
opam_config_var t "prefix" >>| function 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 | None -> Path.parent_exn t.ocaml_bin
let install_ocaml_libdir t = let install_ocaml_libdir t =
match t.kind, t.findlib_toolchain, Setup.library_destdir with match t.kind, t.findlib_toolchain, Setup.library_destdir with
| Default, None, Some d -> | 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. *) (* If ocamlfind is present, it has precedence over everything else. *)
match which t "ocamlfind" with match which t "ocamlfind" with
| Some fn -> | Some fn ->
(Process.run_capture_line ~env:t.env Strict fn ["printconf"; "destdir"] (Process.run_capture_line ~env:t.env Strict fn ["printconf"; "destdir"]
>>| fun s -> >>| fun s ->
Some (Path.absolute s)) Some (Path.of_filename_relative_to_initial_cwd s))
| None -> | None ->
Fiber.return None Fiber.return None

4
src/dune_project.ml
View File

@ -67,7 +67,7 @@ end = struct
None None
let anonymous path = let anonymous path =
if Path.is_local path then if Path.is_managed path then
Some (Anonymous path) Some (Anonymous path)
else else
None None
@ -107,7 +107,7 @@ end = struct
|> List.tl |> List.tl
|> String.concat ~sep:"/") |> String.concat ~sep:"/")
in in
if not (Path.is_local p) then invalid s; if not (Path.is_managed p) then invalid s;
Anonymous p Anonymous p
| _ when validate s -> Named s | _ when validate s -> Named s
| _ -> invalid s | _ -> invalid s

32
src/file_tree.ml
View File

@ -155,20 +155,24 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path =
Path.readdir_unsorted path Path.readdir_unsorted path
|> List.filter_partition_map ~f:(fun fn -> |> List.filter_partition_map ~f:(fun fn ->
let path = Path.relative path fn in let path = Path.relative path fn in
let is_directory, file = if Path.is_in_build_dir path then
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 Skip
else if is_directory then else begin
Right (fn, path, file) let is_directory, file =
else match Unix.stat (Path.to_string path) with
Left fn) | 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 in
let files = String.Set.of_list files in let files = String.Set.of_list files in
let sub_dirs = let sub_dirs =
@ -253,7 +257,7 @@ let fold t ~traverse_ignored_dirs ~init ~f =
Dir.fold t.root ~traverse_ignored_dirs ~init ~f Dir.fold t.root ~traverse_ignored_dirs ~init ~f
let rec find_dir t path = let rec find_dir t path =
if not (Path.is_local path) then if not (Path.is_managed path) then
None None
else else
match Hashtbl.find t.dirs path with match Hashtbl.find t.dirs path with

2
src/findlib.ml
View File

@ -227,7 +227,7 @@ let parse_package t ~meta_file ~name ~parent_dir ~vars =
else if Filename.is_relative pkg_dir then else if Filename.is_relative pkg_dir then
Path.relative parent_dir pkg_dir Path.relative parent_dir pkg_dir
else else
Path.absolute pkg_dir Path.of_filename_relative_to_initial_cwd pkg_dir
in in
let pkg = let pkg =
{ Package. { Package.

22
src/install.ml
View File

@ -49,17 +49,17 @@ module Section = struct
] ]
module Paths = struct module Paths = struct
let lib = Path.(relative root) "lib" let lib = Path.in_source "lib"
let libexec = Path.(relative root) "lib" let libexec = Path.in_source "lib"
let bin = Path.(relative root) "bin" let bin = Path.in_source "bin"
let sbin = Path.(relative root) "sbin" let sbin = Path.in_source "sbin"
let toplevel = Path.(relative root) "lib/toplevel" let toplevel = Path.in_source "lib/toplevel"
let share = Path.(relative root) "share" let share = Path.in_source "share"
let share_root = Path.(relative root) "share_root" let share_root = Path.in_source "share_root"
let etc = Path.(relative root) "etc" let etc = Path.in_source "etc"
let doc = Path.(relative root) "doc" let doc = Path.in_source "doc"
let stublibs = Path.(relative root) "lib/stublibs" let stublibs = Path.in_source "lib/stublibs"
let man = Path.(relative root) "man" let man = Path.in_source "man"
end end
let install_dir t ~(package : Package.Name.t) = let install_dir t ~(package : Package.Name.t) =

7
src/jbuild_load.ml
View File

@ -28,9 +28,8 @@ module Jbuilds = struct
let generated_jbuilds_dir = Path.relative Path.build_dir ".jbuilds" let generated_jbuilds_dir = Path.relative Path.build_dir ".jbuilds"
let ensure_parent_dir_exists path = let ensure_parent_dir_exists path =
match Path.kind path with if Path.is_in_build_dir path then
| Local path -> Path.Local.ensure_parent_directory_exists path Option.iter (Path.parent path) ~f:Path.mkdir_p
| External _ -> ()
type requires = No_requires | Unix type requires = No_requires | Unix
@ -135,7 +134,7 @@ end
List.concat List.concat
[ [ "-I"; "+compiler-libs" ] [ [ "-I"; "+compiler-libs" ]
; cmas ; cmas
; [ Path.to_absolute_filename wrapper ~root:!Clflags.workspace_root ] ; [ Path.to_absolute_filename wrapper ]
] ]
in in
(* CR-someday jdimino: if we want to allow plugins to use findlib: (* CR-someday jdimino: if we want to allow plugins to use findlib:

2
src/lib.ml
View File

@ -346,7 +346,7 @@ let unique_id t = t.unique_id
let src_dir t = t.src_dir let src_dir t = t.src_dir
let obj_dir t = t.obj_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 let status t = t.status

2
src/lib.mli
View File

@ -17,7 +17,7 @@ val src_dir : t -> Path.t
(** Directory where the object files for the library are located. *) (** Directory where the object files for the library are located. *)
val obj_dir : t -> Path.t 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 is_local : t -> bool
val synopsis : t -> string option val synopsis : t -> string option

4
src/main.ml
View File

@ -147,7 +147,7 @@ let external_lib_deps ?log ~packages () =
let ignored_during_bootstrap = let ignored_during_bootstrap =
Path.Set.of_list Path.Set.of_list
(List.map ~f:Path.of_string (List.map ~f:Path.in_source
[ "test" [ "test"
; "example" ; "example"
]) ])
@ -205,6 +205,8 @@ let set_concurrency ?log (config : Config.t) =
(* Called by the script generated by ../build.ml *) (* Called by the script generated by ../build.ml *)
let bootstrap () = let bootstrap () =
Colors.setup_err_formatter_colors (); Colors.setup_err_formatter_colors ();
Path.set_root Path.External.initial_cwd;
Path.set_build_dir (Path.Kind.of_string "_build");
let main () = let main () =
let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
let subst () = let subst () =

2
src/merlin.ml
View File

@ -100,7 +100,7 @@ let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } =
match preprocess with match preprocess with
| Pps { pps; flags } -> | Pps { pps; flags } ->
let exe = Preprocessing.get_ppx_driver sctx ~scope pps in 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" :: "--as-ppx"
:: Preprocessing.cookie_library_name libname :: Preprocessing.cookie_library_name libname
@ flags) @ flags)

3
src/scheduler.ml
View File

@ -157,7 +157,8 @@ let rec go_rec t =
let go ?(log=Log.no_log) ?(config=Config.default) let go ?(log=Log.no_log) ?(config=Config.default)
?(gen_status_line=fun () -> None) fiber = ?(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 let cwd = Sys.getcwd () in
if cwd <> initial_cwd then if cwd <> initial_cwd then
Printf.eprintf "Entering directory '%s'\n%!" cwd; Printf.eprintf "Entering directory '%s'\n%!" cwd;

2
src/scope.ml
View File

@ -26,7 +26,7 @@ module DB = struct
match Hashtbl.find t.by_dir d with match Hashtbl.find t.by_dir d with
| Some scope -> scope | Some scope -> scope
| None -> | 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" Exn.code_error "Scope.DB.find_by_dir got an invalid path"
[ "dir" , Path.sexp_of_t dir [ "dir" , Path.sexp_of_t dir
; "context", Sexp.To_sexp.string t.context ; "context", Sexp.To_sexp.string t.context

799
src/stdune/path.ml
View File

@ -31,10 +31,50 @@ let explode_path =
| "." :: xs -> xs | "." :: xs -> xs
| xs -> xs | xs -> xs
module External = struct module External : sig
type t = string 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 = let rec cd_dot_dot t =
match Unix.readlink t with match Unix.readlink t with
@ -54,31 +94,76 @@ module External = struct
loop initial_t (explode_path path) 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 end
let is_root = function module Local : sig
| "" -> true type t
| _ -> false
module Local = struct val t : t Sexp.Of_sexp.t
(* either "" for root, either a '/' separated list of components other that ".", ".." val sexp_of_t : t Sexp.To_sexp.t
and not containing '/'. *) val root : t
type t = string 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 val make : local -> t
| "" -> true val drop : t -> local -> local option
| _ -> false
let to_string = function (* for all local path p, drop (invalid p = None) *)
| "" -> "." val invalid : t
| t -> 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 to_list =
let rec loop t acc i j = 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 (String.sub t ~pos:i ~len:(j - i) :: acc) (i - 1) (i - 1)
| _ -> loop t acc (i - 1) j | _ -> loop t acc (i - 1) j
in in
function fun t ->
| "" -> [] if is_root t then
| t -> []
let len = String.length t in else
loop t [] len len 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" [] 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 match String.rindex_from t (String.length t - 1) '/' with
| exception Not_found -> "" | exception Not_found -> root
| i -> String.sub t ~pos:0 ~len:i | 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" [] Exn.code_error "Path.Local.basename called on the root" []
| t -> else
let t = to_string t in
let len = String.length t in let len = String.length t in
match String.rindex_from t (len - 1) '/' with match String.rindex_from t (len - 1) '/' with
| exception Not_found -> t | exception Not_found -> t
| i -> String.sub t ~pos:(i + 1) ~len:(len - i - 1) | 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 = let relative ?error_loc t path =
if not (Filename.is_relative path) then ( if not (Filename.is_relative path) then (
Exn.code_error "Local.relative: received absolute path" 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 ; "path", Usexp.atom_or_quoted_string path
] ]
); );
@ -124,20 +215,21 @@ module Local = struct
| [] -> Result.Ok t | [] -> Result.Ok t
| "." :: rest -> loop t rest | "." :: rest -> loop t rest
| ".." :: rest -> | ".." :: rest ->
begin match t with if is_root t then
| "" -> Result.Error () Result.Error ()
| t -> loop (parent t) rest else
end loop (parent t) rest
| fn :: rest -> | fn :: rest ->
match t with if is_root t then
| "" -> loop fn rest loop (make fn) rest
| _ -> loop (t ^ "/" ^ fn) rest else
loop (make (to_string t ^ "/" ^ fn)) rest
in in
match loop t (explode_path path) with match loop t (explode_path path) with
| Result.Ok t -> t | Result.Ok t -> t
| Error () -> | Error () ->
Exn.fatalf ?loc:error_loc "path outside the workspace: %s from %s" path Exn.fatalf ?loc:error_loc "path outside the workspace: %s from %s" path
(to_string t) (to_string t)
let is_canonicalized = let is_canonicalized =
let rec before_slash s i = let rec before_slash s i =
@ -173,61 +265,68 @@ module Local = struct
in in
fun s -> fun s ->
let len = String.length s in let len = String.length s in
if len = 0 then len = 0 || before_slash s (len - 1)
true
else
before_slash s (len - 1)
let of_string ?error_loc s = let of_string ?error_loc s =
if is_canonicalized s then match s with
s | "" | "." -> root
else | _ when is_canonicalized s -> make s
relative "" s ?error_loc | _ ->
relative root s ?error_loc
let rec mkdir_p = function let t sexp =
| "" -> () of_string (Sexp.Of_sexp.string sexp)
| t -> ~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 try
Unix.mkdir t 0o777 Unix.mkdir t_s 0o777
with with
| Unix.Unix_error (EEXIST, _, _) -> () | Unix.Unix_error (EEXIST, _, _) -> ()
| Unix.Unix_error (ENOENT, _, _) as e -> | Unix.Unix_error (ENOENT, _, _) as e ->
match parent t with let parent = parent t in
| "" -> raise e if is_root parent then
| p -> raise e
mkdir_p p; else begin
Unix.mkdir t 0o777 mkdir_p parent;
Unix.mkdir t_s 0o777
let ensure_parent_directory_exists = function end
| "" -> ()
| t -> mkdir_p (parent t)
let append a b = let append a b =
match a, b with match is_root a, is_root b with
| "", x | x, "" -> x | true, _ -> b
| _ -> a ^ "/" ^ b | _, true -> a
| _, _ -> make ((to_string a) ^ "/" ^ (to_string b))
let descendant t ~of_ = let descendant t ~of_ =
match of_ with if is_root of_ then
| "" -> Some t 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 of_len = String.length of_ in
let t_len = String.length t in let t_len = String.length t in
if t_len = of_len then if (t_len > of_len && t.[of_len] = '/'
Option.some_if (t = of_) t && String.is_prefix t ~prefix:of_) then
else 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)))
Some (String.sub t ~pos:(of_len + 1) ~len:(t_len - of_len - 1))
else else
None None
let is_descendant t ~of_ = let is_descendant t ~of_ =
match of_ with is_root of_
| "" -> true || t = of_
| _ -> || (
let t = to_string t in
let of_ = to_string of_ in
let of_len = String.length of_ in let of_len = String.length of_ in
let t_len = String.length t 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 reach t ~from =
let rec loop 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 match List.fold_left from ~init:t ~f:(fun acc _ -> ".." :: acc) with
| [] -> "." | [] -> "."
| l -> String.concat l ~sep:"/" | l -> (String.concat l ~sep:"/")
in in
loop (to_list t) (to_list from) 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 end
type t = string let (abs_root, set_root) =
let compare = String.compare let root_dir = ref None in
let set_root new_root =
module Set = struct match !root_dir with
include String.Set | None -> root_dir := Some new_root
let sexp_of_t t = Sexp.To_sexp.(list string) (String.Set.to_list t) | Some root_dir ->
let of_string_set = map Exn.code_error "set_root: cannot set root_dir more than once"
end [ "root_dir", External.sexp_of_t root_dir
; "new_root_dir", External.sexp_of_t new_root
module Map = String.Map ]
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 module Kind = struct
type t = type t =
| External of External.t | External of External.t
| Local of Local.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 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>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 = module T : sig
if is_local t then type t = private
Local t | External of External.t
else | In_source_tree of Local.t
External t | In_build_dir of Local.t
let to_string = function val compare : t -> t -> Ordering.t
| "" -> "."
| t -> 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 = let to_string_maybe_quoted t =
String.maybe_quoted (to_string 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 = let relative ?error_loc t fn =
if fn = "" then match fn with
| "" | "." ->
t t
else | _ when not (Filename.is_relative fn) ->
match is_local t, is_local fn with external_ (External.of_string fn)
| true, true -> Local.relative t fn ?error_loc |_ ->
| _ , false -> fn match t with
| false, true -> External.relative t fn | 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 = let of_string ?error_loc s =
match s with match s with
| "" -> "" | "" | "." -> in_source_tree Local.root
| s -> | s ->
if Filename.is_relative s then if not (Filename.is_relative s) then
Local.of_string s ?error_loc external_ (External.of_string s)
else 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 t = function
let sexp_of_t t = Sexp.atom_or_quoted_string (to_string t) (* 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 = let of_filename_relative_to_initial_cwd fn =
if is_local fn then external_ (
Filename.concat initial_cwd fn if Filename.is_relative fn then
else External.relative External.initial_cwd fn
fn else
External.of_string fn
)
let to_absolute_filename t ~root = let to_absolute_filename t = Kind.to_absolute_filename (kind t)
match kind t with
| Local t -> let external_of_local x ~root =
assert (not (Filename.is_relative root)); External.to_string (External.relative root (Local.to_string x))
Filename.concat root (Local.to_string t)
| External t -> t let external_of_in_source_tree x =
external_of_local x ~root:(Lazy.force abs_root)
let reach t ~from = let reach t ~from =
match kind t, kind from with match t, from with
| External _, _ -> t | External t, _ -> External.to_string t
| Local _, External _ -> | In_source_tree t, In_source_tree from
Exn.code_error "Path.reach called with invalid combination" | In_build_dir t, In_build_dir from -> Local.reach t ~from
[ "t" , sexp_of_t t | In_source_tree t, In_build_dir from -> begin
; "from", sexp_of_t from match Lazy.force build_dir_kind with
] | Local b -> Local.reach t ~from:(Local.append b from)
| Local t, Local from -> | External _ -> external_of_in_source_tree t
Local.reach t ~from 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 = let reach_for_running ?(from=root) t =
match kind t, kind from with let fn = reach t ~from in
| External _, _ -> t match Filename.analyze_program_name fn with
| Local _, External _ -> | In_path -> "./" ^ fn
Exn.code_error "Path.reach_for_running called with invalid combination" | _ -> fn
[ "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 descendant t ~of_ = let descendant t ~of_ =
match kind t, kind of_ with 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 | _, _ -> None
let is_descendant t ~of_ = let is_descendant t ~of_ =
@ -356,74 +659,87 @@ let append a b =
; "b", sexp_of_t b ; "b", sexp_of_t b
] ]
| Local b -> | Local b ->
begin match kind a with begin match a with
| Local a -> Local.append a b | In_source_tree a -> in_source_tree (Local.append a b)
| External a -> Filename.concat a b | In_build_dir a -> in_build_dir (Local.append a b)
| External a -> external_ (External.relative a (Local.to_string b))
end end
let basename t = let basename t =
match kind t with match kind t with
| Local t -> Local.basename t | Local t -> Local.basename t
| External t -> Filename.basename t | External t -> External.basename t
let parent t = let parent = function
match kind t with | External s ->
| Local "" -> None let parent = External.parent s in
| Local t -> Some (Local.parent t) if parent = s then
| External t ->
let parent = Filename.dirname t in
if parent = t then
None None
else 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 = let parent_exn t =
match parent t with match parent t with
| Some p -> p | 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] ["t", sexp_of_t t]
let build_prefix = "_build/" let is_strict_descendant_of_build_dir = function
| In_build_dir p -> not (Local.is_root p)
let build_dir = "_build" | In_source_tree _
let is_in_build_dir t =
match kind t with
| Local t -> String.is_prefix t ~prefix:build_prefix
| External _ -> false | 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 = let is_in_source_tree = function
String.is_prefix t ~prefix:"_build/.aliases/" | In_source_tree _ -> true
| In_build_dir _
| External _ -> false
let extract_build_context t = let is_alias_stamp_file = function
if String.is_prefix t ~prefix:build_prefix then | In_build_dir s -> String.is_prefix (Local.to_string s) ~prefix:".aliases/"
let i = String.length build_prefix in | In_source_tree _
match String.index_from t i '/' with | External _ -> false
| 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 extract_build_context_dir t = let extract_build_context = function
if String.is_prefix t ~prefix:build_prefix then | In_source_tree _
let i = String.length build_prefix in | External _ -> None
match String.index_from t i '/' with | In_build_dir p when Local.is_root p -> None
| exception _ -> | In_build_dir t ->
Some (t, "") let t = Local.to_string t in
| j -> 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 Some
(String.sub t ~pos:0 ~len:j, ( String.sub t ~pos:0 ~len:j
String.sub t ~pos:(j + 1) ~len:(String.length t - j - 1)) , String.sub t ~pos:(j + 1) ~len:(String.length t - j - 1)
else |> Local.of_string
None |> 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 = let drop_build_context t =
Option.map (extract_build_context t) ~f:snd Option.map (extract_build_context t) ~f:snd
@ -441,26 +757,29 @@ let drop_optional_build_context t =
let split_first_component t = let split_first_component t =
match kind t, is_root t with match kind t, is_root t with
| Local t, false -> | Local t, false ->
let t = Local.to_string t in
begin match String.index t '/' with begin match String.index t '/' with
| None -> Some (t, root) | None -> Some (t, root)
| Some i -> | Some i ->
Some Some
(String.sub t ~pos:0 ~len:i, ( String.sub t ~pos:0 ~len:i
String.sub t ~pos:(i + 1) ~len:(String.length t - i - 1)) , String.sub t ~pos:(i + 1) ~len:(String.length t - i - 1)
|> Local.of_string
|> in_source_tree )
end end
| _, _ -> None | _, _ -> None
let explode t = let explode t =
match kind t with match kind t with
| Local "" -> Some [] | Local p when Local.is_root p -> Some []
| Local s -> Some (String.split s ~on:'/') | Local s -> Some (String.split (Local.to_string s) ~on:'/')
| External _ -> None | External _ -> None
let explode_exn t = let explode_exn t =
match explode t with match explode t with
| Some s -> s | Some s -> s
| None -> Exn.code_error "Path.explode_exn" | None -> Exn.code_error "Path.explode_exn"
["path", Sexp.atom_or_quoted_string t] ["path", sexp_of_t t]
let exists t = let exists t =
try Sys.file_exists (to_string 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 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 insert_after_build_dir_exn =
let error a b = let error a b =
Exn.code_error Exn.code_error
"Path.insert_after_build_dir_exn" "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 ; "insert", Sexp.unsafe_atom_of_string b
] ]
in in
fun a b -> fun a b ->
if not (is_local a) then match a with
error a b | In_build_dir a -> in_build_dir (Local.append (Local.of_string b) a)
else if a = build_dir then | In_source_tree _
relative build_dir b | External _ -> error a 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
let rm_rf = let rm_rf =
let rec loop dir = let rec loop dir =
@ -525,7 +854,7 @@ let rm_rf =
Unix.rmdir dir Unix.rmdir dir
in in
fun t -> fun t ->
if not (is_local t) then ( if not (is_managed t) then (
Exn.code_error "Path.rm_rf called on external dir" Exn.code_error "Path.rm_rf called on external dir"
["t", sexp_of_t t] ["t", sexp_of_t t]
); );
@ -534,10 +863,44 @@ let rm_rf =
| exception Unix.Unix_error(ENOENT, _, _) -> () | exception Unix.Unix_error(ENOENT, _, _) -> ()
| _ -> loop fn | _ -> loop fn
let change_extension ~ext t = let mkdir_p = function
let t = try Filename.chop_extension t with Not_found -> t in | External s ->
t ^ ext 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 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)

52
src/stdune/path.mli
View File

@ -1,19 +1,6 @@
(** In the current workspace (anything under the current project root) *) (** In the current workspace (anything under the current project root) *)
module Local : sig module Local : sig
type t 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 end
(** In the outside world *) (** In the outside world *)
@ -21,12 +8,18 @@ module External : sig
type t type t
val to_string : t -> string val to_string : t -> string
val of_string : string -> t
val initial_cwd : t
val cwd : unit -> t
end end
module Kind : sig module Kind : sig
type t = type t = private
| External of External.t | External of External.t
| Local of Local.t | Local of Local.t
val of_string : string -> t
end end
type t type t
@ -45,9 +38,6 @@ end
module Map : Map.S with type key = t module Map : Map.S with type key = t
val kind : t -> Kind.t
val of_string : ?error_loc:Usexp.Loc.t -> string -> t val of_string : ?error_loc:Usexp.Loc.t -> string -> t
val to_string : t -> string val to_string : t -> string
@ -57,17 +47,17 @@ val to_string_maybe_quoted : t -> string
val root : t val root : t
val is_root : t -> bool 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 val relative : ?error_loc:Usexp.Loc.t -> t -> string -> t
(** Create an external path. If the argument is relative, assume it is (** Create an external path. If the argument is relative, assume it is
relative to the initial directory jbuilder was launched in. *) 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 (** 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 *) 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 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] *) (** [is_in_build_dir t = is_descendant t ~of:build_dir] *)
val is_in_build_dir : t -> bool 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_in_source_tree : t -> bool
val is_alias_stamp_file : 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 *) (** Split after the first component if [t] is local *)
val split_first_component : t -> (string * t) option val split_first_component : t -> (string * t) option
@ -134,14 +128,24 @@ val rmdir : t -> unit
val unlink : t -> unit val unlink : t -> unit
val unlink_no_err : t -> unit val unlink_no_err : t -> unit
val rm_rf : t -> unit val rm_rf : t -> unit
val mkdir_p : t -> unit
(** Changes the extension of the filename (or adds an extension if there was none) *)
val change_extension : ext:string -> t -> t
val extension : t -> string val extension : t -> string
val pp : Format.formatter -> t -> unit val pp : Format.formatter -> t -> unit
val pp_debug : Format.formatter -> t -> unit
val build_dir_exists : unit -> bool val build_dir_exists : unit -> bool
val ensure_build_dir_exists : unit -> unit 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

3
src/utop.ml
View File

@ -11,8 +11,7 @@ let pp_ml fmt include_dirs =
let pp_include fmt = let pp_include fmt =
let pp_sep fmt () = Format.fprintf fmt "@ ; " in let pp_sep fmt () = Format.fprintf fmt "@ ; " in
Format.pp_print_list ~pp_sep (fun fmt p -> Format.pp_print_list ~pp_sep (fun fmt p ->
Format.fprintf fmt "%S" (Path.to_absolute_filename p Format.fprintf fmt "%S" (Path.to_absolute_filename p)
~root:!Clflags.workspace_root)
) fmt ) fmt
in in
Format.fprintf fmt "@[<v 2>Clflags.include_dirs :=@ [ %a@ ]@];@." Format.fprintf fmt "@[<v 2>Clflags.include_dirs :=@ [ %a@ ]@];@."

2
test/blackbox-tests/cram.mll
View File

@ -151,7 +151,7 @@ and postprocess tbl b = parse
| _ -> 255 | _ -> 255
in in
let ext_replace = make_ext_replace configurator 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 |> Io.lines_of_file
|> List.iter ~f:(fun line -> |> List.iter ~f:(fun line ->
Printf.bprintf buf " %s\n" Printf.bprintf buf " %s\n"

10
test/blackbox-tests/dune.inc
View File

@ -56,6 +56,14 @@
test-cases/cross-compilation test-cases/cross-compilation
(progn (run ${exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))) (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 (alias
((name depend-on-the-universe) ((name depend-on-the-universe)
(deps (deps
@ -518,6 +526,7 @@
(alias configurator) (alias configurator)
(alias copy_files) (alias copy_files)
(alias cross-compilation) (alias cross-compilation)
(alias custom-build-dir)
(alias depend-on-the-universe) (alias depend-on-the-universe)
(alias env) (alias env)
(alias exclude-missing-module) (alias exclude-missing-module)
@ -579,6 +588,7 @@
(alias configurator) (alias configurator)
(alias copy_files) (alias copy_files)
(alias cross-compilation) (alias cross-compilation)
(alias custom-build-dir)
(alias depend-on-the-universe) (alias depend-on-the-universe)
(alias env) (alias env)
(alias exclude-missing-module) (alias exclude-missing-module)

2
test/blackbox-tests/test-cases/bad-alias-error/run.t
View File

@ -4,4 +4,4 @@
Tried to reference path outside build dir: "/foo/bar" Tried to reference path outside build dir: "/foo/bar"
$ dune runtest --root outside-workspace 2>&1 | grep -v Entering $ dune runtest --root outside-workspace 2>&1 | grep -v Entering
File "jbuild", line 4, characters 16-39: File "jbuild", line 4, characters 16-39:
Error: path outside the workspace: ./../../../foobar from _build/default Error: path outside the workspace: ./../../../foobar from default

3
test/blackbox-tests/test-cases/custom-build-dir/jbuild Normal file
View File

@ -0,0 +1,3 @@
(jbuild_version 1)
(rule (with-stdout-to foo (echo "foobar")))

43
test/blackbox-tests/test-cases/custom-build-dir/run.t Normal file
View File

@ -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

2
test/blackbox-tests/test-cases/inline_tests/run.t
View File

@ -1,6 +1,6 @@
$ env -u OCAMLRUNPARAM jbuilder runtest simple $ env -u OCAMLRUNPARAM jbuilder runtest simple
run alias simple/runtest (exit 2) 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 Fatal error: exception File "simple/.foo_simple.inline-tests/run.ml", line 1, characters 10-16: Assertion failed
[1] [1]

2
test/unit-tests/action.mlt
View File

@ -5,6 +5,7 @@
open Dune;; open Dune;;
open Import;; open Import;;
open Action.Infer.Outcome;; open Action.Infer.Outcome;;
Stdune.Path.set_build_dir (Path.Kind.of_string "_build");;
let p = Path.of_string;; let p = Path.of_string;;
let infer (a : Action.t) = 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.deps) ~f:Path.to_string,
List.map (Path.Set.to_list x.targets) ~f:Path.to_string) List.map (Path.Set.to_list x.targets) ~f:Path.to_string)
[%%expect{| [%%expect{|
- : unit = ()
val p : ?error_loc:Usexp.Loc.t -> string -> Dune.Import.Path.t = <fun> val p : ?error_loc:Usexp.Loc.t -> string -> Dune.Import.Path.t = <fun>
val infer : Dune.Action.t -> string list * string list = <fun> val infer : Dune.Action.t -> string list * string list = <fun>
|}] |}]

100
test/unit-tests/path.mlt
View File

@ -1,17 +1,21 @@
(* -*- tuareg -*- *) (* -*- tuareg -*- *)
open Stdune;; open Stdune;;
Path.set_root (Path.External.cwd ());
Path.set_build_dir (Path.Kind.of_string "_build");
Printexc.record_backtrace false;; Printexc.record_backtrace false;;
let r = Path.(relative root);; 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) Path.(let p = relative root "foo" in descendant p ~of_:p)
[%%expect{| [%%expect{|
- : unit = () - : unit = ()
val r : string -> Stdune.Path.t = <fun> val r : string -> Stdune.Path.t = <fun>
- : Stdune.Path.t option = Some foo val e : string -> Stdune.Path.t = <fun>
- : Stdune.Path.t option = Some (In_source_tree ".")
|}] |}]
(* different strings but same length *) (* different strings but same length *)
@ -60,44 +64,44 @@ Path.(is_descendant (r "glob/foo") ~of_:(r "glob/"))
- : bool = true - : bool = true
|}] |}]
Path.(is_descendant (Path.absolute "/foo/bar") ~of_:(Path.absolute "/foo")) Path.(is_descendant (e "/foo/bar") ~of_:(e "/foo"))
[%%expect{| [%%expect{|
- : bool = false - : 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{| [%%expect{|
- : bool = false - : 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{| [%%expect{|
- : bool = false - : 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{| [%%expect{|
- : bool = false - : bool = false
|}] |}]
Path.(is_descendant (Path.absolute "/foo/bar") ~of_:(Path.absolute "/")) Path.(is_descendant (e "/foo/bar") ~of_:(e "/"))
[%%expect{| [%%expect{|
- : bool = false - : bool = false
|}] |}]
Path.(descendant (r "foo") ~of_:(r "foo/")) Path.(descendant (r "foo") ~of_:(r "foo/"))
[%%expect{| [%%expect{|
- : Stdune.Path.t option = Some foo - : Stdune.Path.t option = Some (In_source_tree ".")
|}] |}]
Path.(descendant (r "foo/") ~of_:(r "foo")) Path.(descendant (r "foo/") ~of_:(r "foo"))
[%%expect{| [%%expect{|
- : Stdune.Path.t option = Some foo - : Stdune.Path.t option = Some (In_source_tree ".")
|}] |}]
Path.(descendant (r "foo/bar") ~of_:(r "foo")) Path.(descendant (r "foo/bar") ~of_:(r "foo"))
[%%expect{| [%%expect{|
- : Stdune.Path.t option = Some bar - : Stdune.Path.t option = Some (In_source_tree "bar")
|}] |}]
Path.(descendant Path.root ~of_:(r "foo")) 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) Path.(descendant Path.root ~of_:Path.root)
[%%expect{| [%%expect{|
- : Stdune.Path.t option = Some . - : Stdune.Path.t option = Some (In_source_tree ".")
|}] |}]
Path.(descendant (r "foo") ~of_:Path.root) Path.(descendant (r "foo") ~of_:Path.root)
[%%expect{| [%%expect{|
- : Stdune.Path.t option = Some foo - : Stdune.Path.t option = Some (In_source_tree "foo")
|}] |}]
Path.(descendant (relative build_dir "foo") ~of_:root) Path.(descendant (relative build_dir "foo") ~of_:root)
[%%expect{| [%%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")) Path.(descendant (relative build_dir "foo") ~of_:(absolute "/foo/bar"))
[%%expect{| [%%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) Path.(descendant (relative build_dir "foo/bar") ~of_:build_dir)
[%%expect{| [%%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")) Path.(descendant (relative build_dir "foo/bar") ~of_:(relative build_dir "foo"))
[%%expect{| [%%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")) Path.(descendant (relative build_dir "foo/bar") ~of_:(relative build_dir "foo"))
[%%expect{| [%%expect{|
- : Stdune.Path.t option = Some bar - : Stdune.Path.t option = Some (In_source_tree "bar")
|}] |}]
Path.(descendant (absolute "/foo/bar") ~of_:(absolute "/foo")) Path.(descendant (absolute "/foo/bar") ~of_:(absolute "/foo"))
[%%expect{| [%%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"); 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" Path.relative (Path.of_string "relative") "/absolute/path"
[%%expect{| [%%expect{|
- : Stdune.Path.t = /absolute/path - : Stdune.Path.t = (External "/absolute/path")
|}] |}]
Path.relative (Path.of_string "/abs1") "/abs2" Path.relative (Path.of_string "/abs1") "/abs2"
[%%expect{| [%%expect{|
- : Stdune.Path.t = /abs2 - : Stdune.Path.t = (External "/abs2")
|}] |}]
Path.relative (Path.of_string "/abs1") "" Path.relative (Path.of_string "/abs1") ""
[%%expect{| [%%expect{|
- : Stdune.Path.t = /abs1 - : Stdune.Path.t = (External "/abs1")
|}] |}]
Path.relative Path.root "/absolute/path" Path.relative Path.root "/absolute/path"
[%%expect{| [%%expect{|
- : Stdune.Path.t = /absolute/path - : Stdune.Path.t = (External "/absolute/path")
|}] |}]
Path.absolute "/absolute/path" e "/absolute/path"
[%%expect{| [%%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{| [%%expect{|
- : bool = false - : bool = false
|}] |}]
@ -217,42 +223,42 @@ Exception: Stdune__Exn.Code_error <abstr>.
Path.insert_after_build_dir_exn Path.build_dir "foobar" Path.insert_after_build_dir_exn Path.build_dir "foobar"
[%%expect{| [%%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" Path.insert_after_build_dir_exn (Path.relative Path.build_dir "qux") "foobar"
[%%expect{| [%%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") Path.append Path.build_dir (Path.relative Path.root "foo")
[%%expect{| [%%expect{|
- : Stdune.Path.t = _build/foo - : Stdune.Path.t = (In_build_dir "foo")
|}] |}]
Path.append Path.build_dir (Path.relative Path.build_dir "foo") Path.append Path.build_dir (Path.relative Path.build_dir "foo")
[%%expect{| [%%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") Path.append Path.root (Path.relative Path.build_dir "foo")
[%%expect{| [%%expect{|
- : Stdune.Path.t = _build/foo - : Stdune.Path.t = (In_source_tree "_build/foo")
|}] |}]
Path.append Path.root (Path.relative Path.root "foo") Path.append Path.root (Path.relative Path.root "foo")
[%%expect{| [%%expect{|
- : Stdune.Path.t = foo - : Stdune.Path.t = (In_source_tree "foo")
|}] |}]
Path.append (Path.of_string "/root") (Path.relative Path.root "foo") Path.append (Path.of_string "/root") (Path.relative Path.root "foo")
[%%expect{| [%%expect{|
- : Stdune.Path.t = /root/foo - : Stdune.Path.t = (External "/root/foo")
|}] |}]
Path.append (Path.of_string "/root") (Path.relative Path.build_dir "foo") Path.append (Path.of_string "/root") (Path.relative Path.build_dir "foo")
[%%expect{| [%%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") Path.rm_rf (Path.of_string "/does/not/exist/foo/bar/baz")
@ -262,7 +268,7 @@ Exception: Stdune__Exn.Code_error <abstr>.
Path.drop_build_context (Path.relative Path.build_dir "foo/bar") Path.drop_build_context (Path.relative Path.build_dir "foo/bar")
[%%expect{| [%%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") 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 - : Stdune.Path.t option = None
|}] |}]
Path.drop_build_context (Path.absolute "/foo/bar") Path.drop_build_context (e "/foo/bar")
[%%expect{| [%%expect{|
- : Stdune.Path.t option = None - : Stdune.Path.t option = None
|}] |}]
@ -282,6 +288,11 @@ Path.drop_build_context Path.build_dir
Path.is_in_build_dir Path.build_dir Path.is_in_build_dir Path.build_dir
[%%expect{| [%%expect{|
- : bool = true
|}]
Path.is_strict_descendant_of_build_dir Path.build_dir
[%%expect{|
- : bool = false - : bool = false
|}] |}]
@ -296,19 +307,24 @@ Path.(reach_for_running (relative build_dir "foo/baz")
- : string = "../../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")) ~from:(relative build_dir "foo/bar/baz"))
[%%expect{| [%%expect{|
- : string = "/fake/path" - : string = "/fake/path"
|}] |}]
Path.(reach_for_running (relative build_dir "foo/baz")
~from:(Path.absolute "/fake/path"))
[%%expect{|
Exception: Stdune__Exn.Code_error <abstr>.
|}]
Path.(reach_for_running (relative root "foo") ~from:(Path.relative root "foo")) Path.(reach_for_running (relative root "foo") ~from:(Path.relative root "foo"))
[%%expect{| [%%expect{|
- : string = "./." - : 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 ".")
|}]

13
test/unit-tests/tests.mlt
View File

@ -5,6 +5,11 @@
open Dune open Dune
open Import open Import
let () =
Path.set_root (Path.External.cwd ());
Path.set_build_dir (Path.Kind.of_string "_build")
;;
let print_pkg ppf pkg = let print_pkg ppf pkg =
Format.fprintf ppf "<package:%s>" (Findlib.Package.name pkg) Format.fprintf ppf "<package:%s>" (Findlib.Package.name pkg)
;; ;;
@ -17,7 +22,7 @@ val print_pkg : Format.formatter -> Dune.Findlib.Package.t -> unit = <fun>
|}] |}]
let findlib = let findlib =
let cwd = Path.absolute (Sys.getcwd ()) in let cwd = Path.of_filename_relative_to_initial_cwd (Sys.getcwd ()) in
Findlib.create Findlib.create
~stdlib_dir:cwd ~stdlib_dir:cwd
~path:[Path.relative cwd "test/unit-tests/findlib-db"] ~path:[Path.relative cwd "test/unit-tests/findlib-db"]
@ -51,7 +56,7 @@ open Meta
#install_printer Simplified.pp;; #install_printer Simplified.pp;;
let meta = 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" |> Meta.load ~name:"foo"
[%%expect{| [%%expect{|
@ -80,8 +85,8 @@ val meta : Dune.Meta.Simplified.t =
#install_printer Findlib.Config.pp;; #install_printer Findlib.Config.pp;;
let conf = let conf =
Findlib.Config.load (Path.of_string "test/unit-tests/toolchain") Findlib.Config.load (Path.in_source "test/unit-tests/toolchain")
~toolchain:"tlc" ~context:"<context>" ~toolchain:"tlc" ~context:"<context>"
[%%expect{| [%%expect{|
val conf : Dune.Findlib.Config.t = val conf : Dune.Findlib.Config.t =