From e0a8e776145672fdb46c57e3b71424d798834f94 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Tue, 28 Feb 2017 07:32:15 +0000 Subject: [PATCH] Implement root lookup --- CHANGES.org | 3 ++ Makefile | 2 +- ROADMAP.org | 4 ++- bin/main.ml | 90 ++++++++++++++++++++++++++++++++++++++++++++++++----- 4 files changed, 89 insertions(+), 10 deletions(-) diff --git a/CHANGES.org b/CHANGES.org index 6c418e97..b2cd75bf 100644 --- a/CHANGES.org +++ b/CHANGES.org @@ -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 diff --git a/Makefile b/Makefile index 218e414a..4cbad8a9 100644 --- a/Makefile +++ b/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 diff --git a/ROADMAP.org b/ROADMAP.org index 641767c4..c18d4c13 100644 --- a/ROADMAP.org +++ b/ROADMAP.org @@ -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]]) diff --git a/bin/main.ml b/bin/main.ml index 602a86b7..fd2ee356 100644 --- a/bin/main.ml +++ b/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