Refactor root detection (#2109)

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>

bin/common.ml

@@ -21,7 +21,7 @@ type t =
   ; debug_backtraces      : bool
   ; profile               : string option
   ; workspace_file        : Arg.Path.t option
-  ; root                  : string
+  ; root                  : Workspace_root.t
   ; target_prefix         : string
   ; only_packages         : Dune.Package.Name.Set.t option
   ; capture_outputs       : bool
@@ -45,8 +45,8 @@ type t =
 let prefix_target common s = common.target_prefix ^ s
 
 let set_dirs c =
-  if c.root <> Filename.current_dir_name then
-    Sys.chdir c.root;
+  if c.root.dir <> Filename.current_dir_name then
+    Sys.chdir c.root.dir;
   Path.set_root (Path.External.cwd ());
   Path.set_build_dir (Path.Kind.of_string c.build_dir)
 
@@ -369,15 +369,7 @@ let term =
              ~doc)
   in
   let build_dir = Option.value ~default:default_build_dir build_dir in
-  let root, to_cwd =
-    match root with
-    | Some dn -> (dn, [])
-    | None ->
-      if Config.inside_dune then
-        (".", [])
-      else
-        Util.find_root ()
-  in
+  let root = Workspace_root.create ~specified_by_user:root in
   let config =
     match config_file with
     | No_config  -> Config.default
@@ -406,7 +398,8 @@ let term =
   ; workspace_file
   ; root
   ; orig_args = []
-  ; target_prefix = String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/"))
+  ; target_prefix =
+      String.concat ~sep:"" (List.map root.to_cwd ~f:(sprintf "%s/"))
   ; diff_command
   ; auto_promote
   ; force

bin/common.mli

@@ -4,7 +4,7 @@ type t =
   ; debug_backtraces      : bool
   ; profile               : string option
   ; workspace_file        : Arg.Path.t option
-  ; root                  : string
+  ; root                  : Workspace_root.t
   ; target_prefix         : string
   ; only_packages         : Dune.Package.Name.Set.t option
   ; capture_outputs       : bool

bin/import.ml

@@ -87,7 +87,7 @@ end
 let restore_cwd_and_execve (common : Common.t) prog argv env =
   let prog =
     if Filename.is_relative prog then
-      Filename.concat common.root prog
+      Filename.concat common.root.dir prog
     else
       prog
   in

bin/util.ml

@@ -6,7 +6,6 @@ module Dune_project = Dune.Dune_project
 
 let die = Dune.Import.die
 let hint = Dune.Import.hint
-let warn = Dune.Errors.warn
 
 type checked =
   | In_build_dir of (Context.t * Path.Source.t)
@@ -49,49 +48,3 @@ let check_path contexts =
               In_install_dir (context_exn ctx, Path.Source.of_relative src)
           )
           else (In_build_dir (context_exn name, src))
-
-let find_root () =
-  let cwd = Sys.getcwd () in
-  let rec loop counter ~candidates ~to_cwd dir =
-    match Sys.readdir dir with
-    | exception (Sys_error msg) ->
-      warn Loc.none
-        "Unable to read directory %s. \
-         Will not look for root in parent directories@.\
-         Reason: %s@.\
-         To remove this warning, set your root explicitly using --root.@."
-        dir msg;
-      candidates
-    | files ->
-      let files = String.Set.of_list (Array.to_list files) in
-      if String.Set.mem files Workspace.filename then
-        cont counter ~candidates:((0, dir, to_cwd) :: candidates) dir ~to_cwd
-      else if Wp.t = Jbuilder && String.Set.exists files ~f:(fun fn ->
-        String.is_prefix fn ~prefix:"jbuild-workspace") then
-        cont counter ~candidates:((1, dir, to_cwd) :: candidates) dir ~to_cwd
-      else if String.Set.mem files Dune_project.filename 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
-    let (_, dir, to_cwd) =
-      List.find_exn l ~f:(fun (prio, _, _) -> prio = lowest_priority)
-    in
-    (dir, to_cwd)

bin/util.mli

@@ -8,5 +8,3 @@ type checked =
   | External of Path.External.t
 
 val check_path : Context.t list -> Path.t -> checked
-
-val find_root : unit -> string * string list

bin/workspace_root.ml

@@ -0,0 +1,86 @@
+open Stdune
+open Dune
+
+module Kind = struct
+  type t =
+    | Explicit
+    | Dune_workspace
+    | Jbuild_workspace
+    | Dune_project
+    | Cwd
+
+  let priority = function
+    | Explicit -> 0
+    | Dune_workspace -> 1
+    | Jbuild_workspace -> 2
+    | Dune_project -> 3
+    | Cwd -> 4
+
+  let of_dir_contents files =
+    if String.Set.mem files Workspace.filename then
+      Some Dune_workspace
+    else if Wp.t = Jbuilder && String.Set.exists files ~f:(fun fn ->
+      String.is_prefix fn ~prefix:"jbuild-workspace") then
+      Some Jbuild_workspace
+    else if String.Set.mem files Dune_project.filename then
+      Some Dune_project
+    else
+      None
+end
+
+type t =
+  { dir : string
+  ; to_cwd : string list
+  ; kind : Kind.t
+  }
+
+let make kind dir =
+  { kind
+  ; dir
+  ; to_cwd = []
+  }
+
+let find () =
+  let cwd = Sys.getcwd () in
+  let rec loop counter ~candidate ~to_cwd dir =
+    match Sys.readdir dir with
+    | exception (Sys_error msg) ->
+      Errors.warn Loc.none
+        "Unable to read directory %s. \
+         Will not look for root in parent directories@.\
+         Reason: %s@.\
+         To remove this warning, set your root explicitly using --root.@."
+        dir msg;
+      candidate
+    | files ->
+      let files = String.Set.of_list (Array.to_list files) in
+      let candidate =
+        match Kind.of_dir_contents files with
+        | Some kind when Kind.priority kind <= Kind.priority candidate.kind ->
+          { kind; dir; to_cwd }
+        | _ ->
+          candidate
+      in
+      cont counter ~candidate dir ~to_cwd
+  and cont counter ~candidate ~to_cwd dir =
+    if counter > String.length cwd then
+      candidate
+    else
+      let parent = Filename.dirname dir in
+      if parent = dir then
+        candidate
+      else
+        let base = Filename.basename dir in
+        loop (counter + 1) parent ~candidate ~to_cwd:(base :: to_cwd)
+  in
+  loop 0 ~to_cwd:[] cwd
+    ~candidate:{ kind = Cwd; dir = cwd; to_cwd = [] }
+
+let create ~specified_by_user =
+  match specified_by_user with
+  | Some dn -> make Explicit dn
+  | None ->
+    if Config.inside_dune then
+      make Cwd "."
+    else
+      find ()

bin/workspace_root.mli

@@ -0,0 +1,18 @@
+(** Finding the root of the workspace *)
+
+module Kind : sig
+  type t =
+    | Explicit
+    | Dune_workspace
+    | Jbuild_workspace
+    | Dune_project
+    | Cwd
+end
+
+type t =
+  { dir : string
+  ; to_cwd : string list (** How to reach the cwd from the root *)
+  ; kind : Kind.t
+  }
+
+val create : specified_by_user:string option -> t