126 lines
3.5 KiB
OCaml
126 lines
3.5 KiB
OCaml
open Stdune
|
|
|
|
module Kind = struct
|
|
type t =
|
|
| Explicit
|
|
| Dune_workspace
|
|
| Dune_project
|
|
| Cwd
|
|
|
|
let priority = function
|
|
| Explicit -> 0
|
|
| Dune_workspace -> 1
|
|
| Dune_project -> 2
|
|
| Cwd -> 3
|
|
;;
|
|
|
|
let lowest_priority = max_int
|
|
|
|
let of_dir_contents files =
|
|
if String.Set.mem files Source.Workspace.filename
|
|
then Some Dune_workspace
|
|
else if Filename.Set.mem files Dune_lang.Dune_project.filename
|
|
then Some Dune_project
|
|
else None
|
|
;;
|
|
end
|
|
|
|
type t =
|
|
{ dir : string
|
|
; to_cwd : string list
|
|
; reach_from_root_prefix : string
|
|
; kind : Kind.t
|
|
}
|
|
|
|
module Candidate = struct
|
|
type t =
|
|
{ dir : string
|
|
; to_cwd : string list
|
|
; kind : Kind.t
|
|
}
|
|
end
|
|
|
|
let find () =
|
|
let cwd = Sys.getcwd () in
|
|
let rec loop counter ~(candidate : Candidate.t option) ~to_cwd dir : Candidate.t option =
|
|
match Sys.readdir dir with
|
|
| exception Sys_error msg ->
|
|
User_warning.emit
|
|
[ Pp.textf
|
|
"Unable to read directory %s. Will not look for root in parent directories."
|
|
dir
|
|
; Pp.textf "Reason: %s" msg
|
|
; Pp.text "To remove this warning, set your root explicitly using --root."
|
|
];
|
|
candidate
|
|
| files ->
|
|
let files = String.Set.of_list (Array.to_list files) in
|
|
let candidate =
|
|
let candidate_priority =
|
|
match candidate with
|
|
| Some c -> Kind.priority c.kind
|
|
| None -> Kind.lowest_priority
|
|
in
|
|
match Kind.of_dir_contents files with
|
|
| Some kind when Kind.priority kind <= candidate_priority ->
|
|
Some { Candidate.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:None
|
|
;;
|
|
|
|
let create ~default_is_cwd ~specified_by_user =
|
|
match
|
|
match specified_by_user with
|
|
| Some dn -> Some { Candidate.kind = Explicit; dir = dn; to_cwd = [] }
|
|
| None ->
|
|
let cwd = { Candidate.kind = Cwd; dir = "."; to_cwd = [] } in
|
|
if Execution_env.inside_dune
|
|
then Some cwd
|
|
else (
|
|
match find () with
|
|
| Some s -> Some s
|
|
| None -> if default_is_cwd then Some cwd else None)
|
|
with
|
|
| Some { Candidate.dir; to_cwd; kind } ->
|
|
Ok
|
|
{ kind
|
|
; dir
|
|
; to_cwd
|
|
; reach_from_root_prefix =
|
|
String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/"))
|
|
}
|
|
| None ->
|
|
Error
|
|
User_error.(
|
|
make
|
|
[ Pp.text "I cannot find the root of the current workspace/project."
|
|
; Pp.text "If you would like to create a new dune project, you can type:"
|
|
; Pp.nop
|
|
; Pp.verbatim " dune init project NAME"
|
|
; Pp.nop
|
|
; Pp.text
|
|
"Otherwise, please make sure to run dune inside an existing project or \
|
|
workspace. For more information about how dune identifies the root of the \
|
|
current workspace/project, please refer to \
|
|
https://dune.readthedocs.io/en/stable/usage.html#finding-the-root"
|
|
])
|
|
;;
|
|
|
|
let create_exn ~default_is_cwd ~specified_by_user =
|
|
match create ~default_is_cwd ~specified_by_user with
|
|
| Ok x -> x
|
|
| Error e -> raise (User_error.E e)
|
|
;;
|