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

37
bin/main.ml
View File

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

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

17
src/action.ml
View File

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

2
src/artifacts.ml
View File

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

2
src/bin.ml
View File

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

49
src/build_system.ml
View File

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

1
src/clflags.ml
View File

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

3
src/clflags.mli
View File

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

7
src/config.ml
View File

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

21
src/configurator/v1.ml
View File

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

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

4
src/dune_project.ml
View File

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

32
src/file_tree.ml
View File

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

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
Path.relative parent_dir pkg_dir
else
Path.absolute pkg_dir
Path.of_filename_relative_to_initial_cwd pkg_dir
in
let pkg =
{ Package.

22
src/install.ml
View File

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

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

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

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. *)
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

4
src/main.ml
View File

@ -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 () =

2
src/merlin.ml
View File

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

3
src/scheduler.ml
View File

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

2
src/scope.ml
View File

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

799
src/stdune/path.ml
View File

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

52
src/stdune/path.mli
View File

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

3
src/utop.ml
View File

@ -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 "@[<v 2>Clflags.include_dirs :=@ [ %a@ ]@];@."

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

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

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

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

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"
$ 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

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

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

@ -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 = <fun>
val infer : Dune.Action.t -> string list * string list = <fun>
|}]

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

@ -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 = <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 *)
@ -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 <abstr>.
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 <abstr>.
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 <abstr>.
|}]
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 ".")
|}]

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

@ -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 "<package:%s>" (Findlib.Package.name pkg)
;;
@ -17,7 +22,7 @@ val print_pkg : Format.formatter -> Dune.Findlib.Package.t -> unit = <fun>
|}]
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:"<context>"
Findlib.Config.load (Path.in_source "test/unit-tests/toolchain")
~toolchain:"tlc" ~context:"<context>"
[%%expect{|
val conf : Dune.Findlib.Config.t =