diff --git a/src/dune_project.ml b/src/dune_project.ml index 1276e5e2..49158c5f 100644 --- a/src/dune_project.ml +++ b/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 diff --git a/src/dune_project.mli b/src/dune_project.mli index b413c268..c795c728 100644 --- a/src/dune_project.mli +++ b/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 diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index 231413cd..ffa61f23 100644 --- a/src/jbuild_load.ml +++ b/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 - 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); diff --git a/src/scope.ml b/src/scope.ml index d341e42d..35810346 100644 --- a/src/scope.ml +++ b/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 diff --git a/src/stdune/path.ml b/src/stdune/path.ml index e0c7681d..4c66fa34 100644 --- a/src/stdune/path.ml +++ b/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 -> - 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 diff --git a/src/stdune/path.mli b/src/stdune/path.mli index c7a691fe..c17ca474 100644 --- a/src/stdune/path.mli +++ b/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 diff --git a/src/super_context.ml b/src/super_context.ml index bf93fb09..b15240a8 100644 --- a/src/super_context.ml +++ b/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