133 lines
4.3 KiB
OCaml
133 lines
4.3 KiB
OCaml
open! Stdune
|
|
open Import
|
|
|
|
type t =
|
|
{ project : Dune_project.t
|
|
; db : Lib.DB.t
|
|
; root : Path.t (* Path inside the build directory *)
|
|
}
|
|
|
|
let root t = t.root
|
|
let name t = Dune_project.name t.project
|
|
let project t = t.project
|
|
let libs t = t.db
|
|
|
|
module DB = struct
|
|
type scope = t
|
|
|
|
module Project_name_map = Map.Make(Dune_project.Name)
|
|
|
|
type t =
|
|
{ by_dir : (Path.t, scope) Hashtbl.t
|
|
; by_name : scope Project_name_map.t
|
|
; context : string
|
|
}
|
|
|
|
let find_by_dir t dir =
|
|
let rec loop d =
|
|
match Hashtbl.find t.by_dir d with
|
|
| Some scope -> scope
|
|
| None ->
|
|
if Path.is_root d || not (Path.is_managed d) then
|
|
Exn.code_error "Scope.DB.find_by_dir got an invalid path"
|
|
[ "dir" , Path.to_sexp dir
|
|
; "context", Sexp.To_sexp.string t.context
|
|
];
|
|
let scope = loop (Path.parent_exn d) in
|
|
Hashtbl.add t.by_dir d scope;
|
|
scope
|
|
in
|
|
loop dir
|
|
|
|
let find_by_name t name =
|
|
match Project_name_map.find t.by_name name with
|
|
| Some x -> x
|
|
| None ->
|
|
Exn.code_error "Scope.DB.find_by_name"
|
|
[ "name" , Dune_project.Name.to_sexp name
|
|
; "context", Sexp.To_sexp.string t.context
|
|
; "names",
|
|
Sexp.To_sexp.(list Dune_project.Name.to_sexp)
|
|
(Project_name_map.keys t.by_name)
|
|
]
|
|
|
|
let create ~projects ~context ~installed_libs ~ext_lib internal_libs =
|
|
let projects_by_name =
|
|
List.map projects ~f:(fun (project : Dune_project.t) ->
|
|
(Dune_project.name project, project))
|
|
|> Project_name_map.of_list
|
|
|> function
|
|
| Ok x -> x
|
|
| Error (_name, project1, project2) ->
|
|
let to_sexp (project : Dune_project.t) =
|
|
Sexp.To_sexp.(pair Dune_project.Name.to_sexp Path.Local.to_sexp)
|
|
(Dune_project.name project, Dune_project.root project)
|
|
in
|
|
Exn.code_error "Scope.DB.create got two projects with the same name"
|
|
[ "project1", to_sexp project1
|
|
; "project2", to_sexp project2
|
|
]
|
|
in
|
|
let libs_by_project_name =
|
|
List.map internal_libs ~f:(fun (dir, (lib : Dune_file.Library.t)) ->
|
|
(Dune_project.name lib.project, (dir, lib)))
|
|
|> Project_name_map.of_list_multi
|
|
in
|
|
let by_name_cell = ref Project_name_map.empty in
|
|
let public_libs =
|
|
let public_libs =
|
|
List.filter_map internal_libs ~f:(fun (_dir, lib) ->
|
|
Option.map lib.public ~f:(fun p ->
|
|
(Dune_file.Public_lib.name p, lib.project)))
|
|
|> Lib_name.Map.of_list
|
|
|> function
|
|
| Ok x -> x
|
|
| Error (name, _, _) ->
|
|
match
|
|
List.filter_map internal_libs ~f:(fun (_dir, lib) ->
|
|
Option.bind lib.public ~f:(fun p ->
|
|
Option.some_if (name = Dune_file.Public_lib.name p)
|
|
lib.buildable.loc))
|
|
with
|
|
| [] | [_] -> assert false
|
|
| loc1 :: loc2 :: _ ->
|
|
die "Public library %a is defined twice:\n\
|
|
- %s\n\
|
|
- %s"
|
|
Lib_name.pp_quoted name
|
|
(Loc.to_file_colon_line loc1)
|
|
(Loc.to_file_colon_line loc2)
|
|
in
|
|
Lib.DB.create ()
|
|
~parent:installed_libs
|
|
~resolve:(fun name ->
|
|
match Lib_name.Map.find public_libs name with
|
|
| None -> Not_found
|
|
| Some project ->
|
|
let scope =
|
|
Option.value_exn
|
|
(Project_name_map.find !by_name_cell (Dune_project.name project))
|
|
in
|
|
Redirect (Some scope.db, name))
|
|
~all:(fun () -> Lib_name.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
|
|
let libs = Option.value libs ~default:[] in
|
|
let db =
|
|
Lib.DB.create_from_library_stanzas libs ~parent:public_libs ~ext_lib
|
|
in
|
|
let root =
|
|
Path.append_local build_context_dir (Dune_project.root project) 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.root scope);
|
|
({ by_name; by_dir; context }, public_libs)
|
|
end
|