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>
This commit is contained in:
parent
ef77f83cec
commit
f24cf5d110
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
p :: acc
|
||||
else
|
||||
acc)
|
||||
match Path.kind (File_tree.Dir.path dir) with
|
||||
| Local d when d = p.root -> p :: 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);
|
||||
|
|
11
src/scope.ml
11
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
|
||||
|
|
|
@ -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 ->
|
||||
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
|
||||
| Local b -> append_local a b
|
||||
|
||||
let basename t =
|
||||
match kind t with
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue