Implement root lookup
This commit is contained in:
parent
19dae96f1a
commit
e0a8e77614
|
@ -34,6 +34,9 @@
|
||||||
- Added support for compiling against multiple opam switch
|
- Added support for compiling against multiple opam switch
|
||||||
simultaneously by writing a =jbuild-worspace= file
|
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)
|
* 0.1.alpha1 (04/12/2017)
|
||||||
|
|
||||||
First release
|
First release
|
||||||
|
|
2
Makefile
2
Makefile
|
@ -16,7 +16,7 @@ uninstall:
|
||||||
reinstall: uninstall reinstall
|
reinstall: uninstall reinstall
|
||||||
|
|
||||||
all-supported-ocaml-versions:
|
all-supported-ocaml-versions:
|
||||||
$(BIN) build @install --workspace jbuild-workspace.dev
|
$(BIN) build @install --workspace jbuild-workspace.dev --root .
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
rm -rf _build
|
rm -rf _build
|
||||||
|
|
|
@ -28,7 +28,7 @@ work with future versions of jbuild.
|
||||||
|
|
||||||
- *24/02/2017*: implemented
|
- *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
|
Currently =jbuilder= assumes that the root of the project/workspace is
|
||||||
where it is started. Eventually this will be changed as follows:
|
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, look for a =.git=, =.hg=, ... file in parent directories;
|
||||||
- if not found, use the current directory as root.
|
- if not found, use the current directory as root.
|
||||||
|
|
||||||
|
- *28/02/2017*: Implemented
|
||||||
|
|
||||||
** +Generate .merlin files [[https://github.com/janestreet/jbuilder/issues/1][#1]]+
|
** +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]])
|
- *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
|
; debug_findlib : bool
|
||||||
; dev_mode : bool
|
; dev_mode : bool
|
||||||
; workspace_file : string option
|
; workspace_file : string option
|
||||||
|
; root : string
|
||||||
|
; target_prefix : string
|
||||||
}
|
}
|
||||||
|
|
||||||
|
let prefix_target common s = common.target_prefix ^ s
|
||||||
|
|
||||||
let set_common c =
|
let set_common c =
|
||||||
Clflags.concurrency := c.concurrency;
|
Clflags.concurrency := c.concurrency;
|
||||||
Clflags.debug_rules := c.debug_rules;
|
Clflags.debug_rules := c.debug_rules;
|
||||||
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.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
|
module Main = struct
|
||||||
include Jbuilder.Main
|
include Jbuilder.Main
|
||||||
|
@ -33,6 +40,55 @@ end
|
||||||
|
|
||||||
let create_log = Main.create_log
|
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 copts_sect = "COMMON OPTIONS"
|
||||||
let help_secs =
|
let help_secs =
|
||||||
[ `S copts_sect
|
[ `S copts_sect
|
||||||
|
@ -44,13 +100,21 @@ let help_secs =
|
||||||
]
|
]
|
||||||
|
|
||||||
let common =
|
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
|
{ concurrency
|
||||||
; debug_rules
|
; debug_rules
|
||||||
; debug_dep_path
|
; debug_dep_path
|
||||||
; debug_findlib
|
; debug_findlib
|
||||||
; dev_mode
|
; dev_mode
|
||||||
; workspace_file
|
; workspace_file
|
||||||
|
; root
|
||||||
|
; target_prefix = String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/"))
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
let docs = copts_sect in
|
let docs = copts_sect in
|
||||||
|
@ -64,7 +128,16 @@ let common =
|
||||||
Arg.(value
|
Arg.(value
|
||||||
& opt (some file) None
|
& opt (some file) None
|
||||||
& info ["workspace"] ~docs
|
& 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
|
in
|
||||||
Term.(const make
|
Term.(const make
|
||||||
$ concurrency
|
$ concurrency
|
||||||
|
@ -73,6 +146,7 @@ let common =
|
||||||
$ dfindlib
|
$ dfindlib
|
||||||
$ dev
|
$ dev
|
||||||
$ workspace_file
|
$ workspace_file
|
||||||
|
$ root
|
||||||
)
|
)
|
||||||
|
|
||||||
let installed_libraries =
|
let installed_libraries =
|
||||||
|
@ -149,7 +223,7 @@ type target =
|
||||||
| File of Path.t
|
| File of Path.t
|
||||||
| Alias of Path.t * Alias.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
|
match user_targets with
|
||||||
| [] -> []
|
| [] -> []
|
||||||
| _ ->
|
| _ ->
|
||||||
|
@ -157,7 +231,7 @@ let resolve_targets (setup : Main.setup) user_targets =
|
||||||
List.concat_map user_targets ~f:(fun s ->
|
List.concat_map user_targets ~f:(fun s ->
|
||||||
if String.is_prefix s ~prefix:"@" then
|
if String.is_prefix s ~prefix:"@" then
|
||||||
let s = String.sub s ~pos:1 ~len:(String.length s - 1) in
|
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
|
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
|
else
|
||||||
|
@ -165,7 +239,7 @@ let resolve_targets (setup : Main.setup) user_targets =
|
||||||
let name = Path.basename path in
|
let name = Path.basename path in
|
||||||
[Alias (path, Alias.make ~dir name)]
|
[Alias (path, Alias.make ~dir name)]
|
||||||
else
|
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 =
|
let can't_build path =
|
||||||
die "Don't know how to build %s" (Path.to_string path)
|
die "Don't know how to build %s" (Path.to_string path)
|
||||||
in
|
in
|
||||||
|
@ -214,7 +288,7 @@ let build_targets =
|
||||||
set_common common;
|
set_common common;
|
||||||
Future.Scheduler.go ~log:(create_log ())
|
Future.Scheduler.go ~log:(create_log ())
|
||||||
(Main.setup common >>= fun setup ->
|
(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
|
Build_system.do_build_exn setup.build_system targets) in
|
||||||
( Term.(const go
|
( Term.(const go
|
||||||
$ common
|
$ common
|
||||||
|
@ -230,7 +304,7 @@ let runtest =
|
||||||
(Main.setup common >>= fun setup ->
|
(Main.setup common >>= fun setup ->
|
||||||
let targets =
|
let targets =
|
||||||
List.map dirs ~f:(fun dir ->
|
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))
|
Alias.file (Alias.runtest ~dir))
|
||||||
in
|
in
|
||||||
Build_system.do_build_exn setup.build_system targets) in
|
Build_system.do_build_exn setup.build_system targets) in
|
||||||
|
|
Loading…
Reference in New Issue