Implement root lookup
This commit is contained in:
parent
19dae96f1a
commit
e0a8e77614
|
@ -34,6 +34,9 @@
|
|||
- Added support for compiling against multiple opam switch
|
||||
simultaneously by writing a =jbuild-worspace= file
|
||||
|
||||
- Search the root according to the rules described in the manual
|
||||
instead of always using the current directory
|
||||
|
||||
* 0.1.alpha1 (04/12/2017)
|
||||
|
||||
First release
|
||||
|
|
2
Makefile
2
Makefile
|
@ -16,7 +16,7 @@ uninstall:
|
|||
reinstall: uninstall reinstall
|
||||
|
||||
all-supported-ocaml-versions:
|
||||
$(BIN) build @install --workspace jbuild-workspace.dev
|
||||
$(BIN) build @install --workspace jbuild-workspace.dev --root .
|
||||
|
||||
clean:
|
||||
rm -rf _build
|
||||
|
|
|
@ -28,7 +28,7 @@ work with future versions of jbuild.
|
|||
|
||||
- *24/02/2017*: implemented
|
||||
|
||||
** Finding the project/workspace root
|
||||
** +Finding the project/workspace root+
|
||||
|
||||
Currently =jbuilder= assumes that the root of the project/workspace is
|
||||
where it is started. Eventually this will be changed as follows:
|
||||
|
@ -38,6 +38,8 @@ where it is started. Eventually this will be changed as follows:
|
|||
- if not found, look for a =.git=, =.hg=, ... file in parent directories;
|
||||
- if not found, use the current directory as root.
|
||||
|
||||
- *28/02/2017*: Implemented
|
||||
|
||||
** +Generate .merlin files [[https://github.com/janestreet/jbuilder/issues/1][#1]]+
|
||||
|
||||
- *25/02/2017*: Implemented by Richard Davison ([[https://github.com/janestreet/jbuilder/pull/2][#2]])
|
||||
|
|
90
bin/main.ml
90
bin/main.ml
|
@ -15,14 +15,21 @@ type common =
|
|||
; debug_findlib : bool
|
||||
; dev_mode : bool
|
||||
; workspace_file : string option
|
||||
; root : string
|
||||
; target_prefix : string
|
||||
}
|
||||
|
||||
let prefix_target common s = common.target_prefix ^ s
|
||||
|
||||
let set_common c =
|
||||
Clflags.concurrency := c.concurrency;
|
||||
Clflags.debug_rules := c.debug_rules;
|
||||
Clflags.debug_dep_path := c.debug_dep_path;
|
||||
Clflags.debug_findlib := c.debug_findlib;
|
||||
Clflags.dev_mode := c.dev_mode
|
||||
Clflags.dev_mode := c.dev_mode;
|
||||
Printf.eprintf "Workspace root: %s\n" c.root;
|
||||
if c.root <> Filename.current_dir_name then
|
||||
Sys.chdir c.root
|
||||
|
||||
module Main = struct
|
||||
include Jbuilder.Main
|
||||
|
@ -33,6 +40,55 @@ end
|
|||
|
||||
let create_log = Main.create_log
|
||||
|
||||
type ('a, 'b) walk_result =
|
||||
| Cont of 'a
|
||||
| Stop of 'b
|
||||
|
||||
let rec walk_parents dir ~init ~f =
|
||||
match f init dir with
|
||||
| Stop x -> Stop x
|
||||
| Cont x ->
|
||||
let parent = Filename.dirname dir in
|
||||
if parent = dir then
|
||||
Cont x
|
||||
else
|
||||
walk_parents parent ~init:x ~f
|
||||
|
||||
let find_root () =
|
||||
let cwd = Sys.getcwd () in
|
||||
let rec loop counter ~candidates ~to_cwd dir =
|
||||
let files = Sys.readdir dir |> Array.to_list |> String_set.of_list in
|
||||
if String_set.mem "jbuild-workspace" files then
|
||||
cont counter ~candidates:((0, dir, to_cwd) :: candidates) dir ~to_cwd
|
||||
else if String_set.exists files ~f:(fun fn ->
|
||||
String.is_suffix fn ~suffix:".install") then
|
||||
cont counter ~candidates:((1, dir, to_cwd) :: candidates) dir ~to_cwd
|
||||
else if String_set.mem ".git" files || String_set.mem ".hg" files then
|
||||
cont counter ~candidates:((2, dir, to_cwd) :: candidates) dir ~to_cwd
|
||||
else
|
||||
cont counter ~candidates dir ~to_cwd
|
||||
and cont counter ~candidates ~to_cwd dir =
|
||||
if counter > String.length cwd then
|
||||
candidates
|
||||
else
|
||||
let parent = Filename.dirname dir in
|
||||
if parent = dir then
|
||||
candidates
|
||||
else
|
||||
let base = Filename.basename dir in
|
||||
loop (counter + 1) parent ~candidates ~to_cwd:(base :: to_cwd)
|
||||
in
|
||||
match loop 0 ~candidates:[] ~to_cwd:[] cwd with
|
||||
| [] -> (cwd, [])
|
||||
| l ->
|
||||
let lowest_priority =
|
||||
List.fold_left l ~init:max_int ~f:(fun acc (prio, _, _) ->
|
||||
min acc prio)
|
||||
in
|
||||
match List.find l ~f:(fun (prio, _, _) -> prio = lowest_priority) with
|
||||
| None -> assert false
|
||||
| Some (_, dir, to_cwd) -> (dir, to_cwd)
|
||||
|
||||
let copts_sect = "COMMON OPTIONS"
|
||||
let help_secs =
|
||||
[ `S copts_sect
|
||||
|
@ -44,13 +100,21 @@ let help_secs =
|
|||
]
|
||||
|
||||
let common =
|
||||
let make concurrency debug_rules debug_dep_path debug_findlib dev_mode workspace_file =
|
||||
let make concurrency debug_rules debug_dep_path debug_findlib dev_mode
|
||||
workspace_file root =
|
||||
let root, to_cwd =
|
||||
match root with
|
||||
| Some dn -> (dn, [])
|
||||
| None -> find_root ()
|
||||
in
|
||||
{ concurrency
|
||||
; debug_rules
|
||||
; debug_dep_path
|
||||
; debug_findlib
|
||||
; dev_mode
|
||||
; workspace_file
|
||||
; root
|
||||
; target_prefix = String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/"))
|
||||
}
|
||||
in
|
||||
let docs = copts_sect in
|
||||
|
@ -64,7 +128,16 @@ let common =
|
|||
Arg.(value
|
||||
& opt (some file) None
|
||||
& info ["workspace"] ~docs
|
||||
~doc:"Use this specific workspace file instead of looking it up")
|
||||
~doc:"Use this specific workspace file instead of looking it up.")
|
||||
in
|
||||
let root =
|
||||
Arg.(value
|
||||
& opt (some dir) None
|
||||
& info ["root"] ~docs
|
||||
~doc:"Use this directory as workspace root instead of guessing it.\n\
|
||||
Note that this option doesn't change the interpretation of \
|
||||
targets given on the command line.\n\
|
||||
It is only intended for scripts.")
|
||||
in
|
||||
Term.(const make
|
||||
$ concurrency
|
||||
|
@ -73,6 +146,7 @@ let common =
|
|||
$ dfindlib
|
||||
$ dev
|
||||
$ workspace_file
|
||||
$ root
|
||||
)
|
||||
|
||||
let installed_libraries =
|
||||
|
@ -149,7 +223,7 @@ type target =
|
|||
| File of Path.t
|
||||
| Alias of Path.t * Alias.t
|
||||
|
||||
let resolve_targets (setup : Main.setup) user_targets =
|
||||
let resolve_targets common (setup : Main.setup) user_targets =
|
||||
match user_targets with
|
||||
| [] -> []
|
||||
| _ ->
|
||||
|
@ -157,7 +231,7 @@ let resolve_targets (setup : Main.setup) user_targets =
|
|||
List.concat_map user_targets ~f:(fun s ->
|
||||
if String.is_prefix s ~prefix:"@" then
|
||||
let s = String.sub s ~pos:1 ~len:(String.length s - 1) in
|
||||
let path = Path.relative Path.root s in
|
||||
let path = Path.relative Path.root (prefix_target common s) in
|
||||
if Path.is_root path then
|
||||
die "@ on the command line must be followed by a valid alias name"
|
||||
else
|
||||
|
@ -165,7 +239,7 @@ let resolve_targets (setup : Main.setup) user_targets =
|
|||
let name = Path.basename path in
|
||||
[Alias (path, Alias.make ~dir name)]
|
||||
else
|
||||
let path = Path.relative Path.root s in
|
||||
let path = Path.relative Path.root (prefix_target common s) in
|
||||
let can't_build path =
|
||||
die "Don't know how to build %s" (Path.to_string path)
|
||||
in
|
||||
|
@ -214,7 +288,7 @@ let build_targets =
|
|||
set_common common;
|
||||
Future.Scheduler.go ~log:(create_log ())
|
||||
(Main.setup common >>= fun setup ->
|
||||
let targets = resolve_targets setup targets in
|
||||
let targets = resolve_targets common setup targets in
|
||||
Build_system.do_build_exn setup.build_system targets) in
|
||||
( Term.(const go
|
||||
$ common
|
||||
|
@ -230,7 +304,7 @@ let runtest =
|
|||
(Main.setup common >>= fun setup ->
|
||||
let targets =
|
||||
List.map dirs ~f:(fun dir ->
|
||||
let dir = Path.(relative root) dir in
|
||||
let dir = Path.(relative root) (prefix_target common dir) in
|
||||
Alias.file (Alias.runtest ~dir))
|
||||
in
|
||||
Build_system.do_build_exn setup.build_system targets) in
|
||||
|
|
Loading…
Reference in New Issue