unikernel/duniverse/dune_/bin/workspace_root.ml

@@ -0,0 +1,126 @@
+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)
+;;