Make Dune_project.t private

To ensure we can't mutate the mutable fields and that the value is
shared, which is important for the profile_file field for instance.

To make sure we don't confuse the root field for a path in the build
directory, change its type to Path.Local.t.

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

src/dune_project.ml

@@ -114,7 +114,7 @@ end
 type t =
   { kind                  : Kind.t
   ; name                  : Name.t
-  ; root                  : Path.t
+  ; root                  : Path.Local.t
   ; version               : string option
   ; packages              : Package.t Package.Name.Map.t
   ; mutable stanza_parser : Stanza.t list Sexp.Of_sexp.t
@@ -196,12 +196,17 @@ end
 
 let filename = "dune-project"
 
+let get_local_path p =
+  match Path.kind p with
+  | External _ -> assert false
+  | Local    p -> p
+
 let anonymous = lazy(
   let t =
     { kind          = Dune
     ; name          = Name.anonymous_root
     ; packages      = Package.Name.Map.empty
-    ; root          = Path.root
+    ; root          = get_local_path Path.root
     ; version       = None
     ; stanza_parser = (fun _ -> assert false)
     ; project_file  = None
@@ -248,7 +253,7 @@ let parse ~dir ~lang_stanzas ~packages ~file =
      let t =
        { kind = Dune
        ; name
-       ; root = dir
+       ; root = get_local_path dir
        ; version
        ; packages
        ; stanza_parser = (fun _ -> assert false)
@@ -270,7 +275,7 @@ let make_jbuilder_project ~dir packages =
   let t =
     { kind = Jbuilder
     ; name = default_name ~dir ~packages
-    ; root = dir
+    ; root = get_local_path dir
     ; version = None
     ; packages
     ; stanza_parser = (fun _ -> assert false)
@@ -314,7 +319,7 @@ let project_file t =
   match t.project_file with
   | Some file -> file
   | None ->
-    let file = Path.drop_optional_build_context (Path.relative t.root filename) in
+    let file = Path.relative (Path.of_local t.root) filename in
     let maj, min = fst (Lang.latest "dune") in
     let s = sprintf "(lang dune %d.%d)" maj min in
     notify_user

src/dune_project.mli

@@ -30,10 +30,10 @@ module Name : sig
 end
 
 (* CR-soon diml: make this abstract *)
-type t =
+type t = private
   { kind                  : Kind.t
   ; name                  : Name.t
-  ; root                  : Path.t
+  ; root                  : Path.Local.t
   ; version               : string option
   ; packages              : Package.t Package.Name.Map.t
   ; mutable stanza_parser : Stanza.t list Sexp.Of_sexp.t

src/jbuild_load.ml

@@ -214,10 +214,9 @@ let load ?extra_ignored_subtrees ?(ignore_promoted_rules=false) () =
     File_tree.fold ftree ~traverse_ignored_dirs:false ~init:[]
       ~f:(fun dir acc ->
         let p = File_tree.Dir.project dir in
-        if p.root = File_tree.Dir.path dir then
+        match Path.kind (File_tree.Dir.path dir) with
-          p :: acc
+        | Local d when d = p.root -> p :: acc
-        else
+        | _ -> acc)
-          acc)
   in
   let packages =
     List.fold_left projects ~init:Package.Name.Map.empty
@@ -235,7 +234,7 @@ let load ?extra_ignored_subtrees ?(ignore_promoted_rules=false) () =
   in
   let projects =
     List.map projects ~f:(fun (p : Dune_project.t) ->
-      (p.root, p))
+      (Path.of_local p.root, p))
     |> Path.Map.of_list_exn
   in
   assert (Path.Map.mem projects Path.root);

src/scope.ml

@@ -3,9 +3,10 @@ open Import
 type t =
   { project : Dune_project.t
   ; db      : Lib.DB.t
+  ; root    : Path.t (* Path inside the build directory *)
   }
 
-let root t = t.project.root
+let root t = t.root
 let name t = t.project.name
 let project t = t.project
 let libs t = t.db
@@ -58,7 +59,7 @@ module DB = struct
       | Ok x -> x
       | Error (_name, project1, project2) ->
         let to_sexp (project : Dune_project.t) =
-          Sexp.To_sexp.(pair Dune_project.Name.sexp_of_t Path.sexp_of_t)
+          Sexp.To_sexp.(pair Dune_project.Name.sexp_of_t Path.Local.sexp_of_t)
             (project.name, project.root)
         in
         Exn.code_error "Scope.DB.create got two projects with the same name"
@@ -110,6 +111,7 @@ module DB = struct
         ~all:(fun () -> String.Map.keys public_libs)
     in
     let by_name =
+      let build_context_dir = Path.relative Path.build_dir context in
       Project_name_map.merge projects_by_name libs_by_project_name
         ~f:(fun _name project libs ->
           let project = Option.value_exn project in
@@ -117,11 +119,12 @@ module DB = struct
           let db =
             Lib.DB.create_from_library_stanzas libs ~parent:public_libs
           in
-          Some { project; db })
+          let root = Path.append_local build_context_dir project.root in
+          Some { project; db; root })
     in
     by_name_cell := by_name;
     let by_dir = Hashtbl.create 1024 in
     Project_name_map.iter by_name ~f:(fun scope ->
-      Hashtbl.add by_dir scope.project.root scope);
+      Hashtbl.add by_dir scope.root scope);
     ({ by_name; by_dir; context }, public_libs)
 end

src/stdune/path.ml

@@ -564,6 +564,7 @@ let make_local_path p =
   match Local.Prefix.drop (Lazy.force build_dir_prefix) p with
   | None -> in_source_tree p
   | Some p -> in_build_dir p
+let of_local = make_local_path
 
 let relative ?error_loc t fn =
   match fn with
@@ -658,6 +659,12 @@ let is_descendant t ~of_ =
   | Local t, Local of_ -> Local.is_descendant t ~of_
   | _, _ -> false
 
+let append_local a b =
+  match a with
+  | In_source_tree a -> in_source_tree (Local.append a b)
+  | In_build_dir a -> in_build_dir (Local.append a b)
+  | External a -> external_ (External.relative a (Local.to_string b))
+
 let append a b =
   match kind b with
   | External _ ->
@@ -665,12 +672,7 @@ let append a b =
       [ "a", sexp_of_t a
       ; "b", sexp_of_t b
       ]
-  | Local b ->
+  | Local b -> append_local a b
-    begin match a with
-    | In_source_tree a -> in_source_tree (Local.append a b)
-    | In_build_dir a -> in_build_dir (Local.append a b)
-    | External a -> external_ (External.relative a (Local.to_string b))
-    end
 
 let basename t =
   match kind t with

src/stdune/path.mli

@@ -1,6 +1,7 @@
 (** In the current workspace (anything under the current project root) *)
 module Local : sig
   type t
+  val sexp_of_t : t -> Sexp.t
 end
 
 (** In the outside world *)
@@ -45,6 +46,8 @@ val to_string : t -> string
 (** [to_string_maybe_quoted t] is [maybe_quoted (to_string t)] *)
 val to_string_maybe_quoted : t -> string
 
+val kind : t -> Kind.t
+
 val root : t
 val is_root : t -> bool
 
@@ -69,6 +72,7 @@ val descendant : t -> of_:t -> t option
 val is_descendant : t -> of_:t -> bool
 
 val append : t -> t -> t
+val append_local : t -> Local.t -> t
 
 val basename : t -> string
 val parent : t -> t option
@@ -147,6 +151,8 @@ val set_build_dir : Kind.t -> unit
 (** paths guaranteed to be in the source directory *)
 val in_source : string -> t
 
+val of_local : Local.t -> t
+
 (** Set the workspace root. Can onyl be called once and the path must be
     absolute *)
 val set_root : External.t -> unit

src/super_context.ml

@@ -216,10 +216,6 @@ let create
         | _ -> None))
   in
   let scopes, public_libs =
-    let projects =
-      List.map projects ~f:(fun (project : Dune_project.t) ->
-        { project with root = Path.append context.build_dir project.root })
-    in
     Scope.DB.create
       ~projects
       ~context:context.name