Collect projects in the file tree directly (#774)
This commit is contained in:
parent
d444aeefea
commit
60c7f6fde4
|
@ -1,9 +1,18 @@
|
|||
open Import
|
||||
open Sexp.Of_sexp
|
||||
|
||||
module Lang = struct
|
||||
type t =
|
||||
| Jbuilder
|
||||
| Dune of Syntax.Version.t
|
||||
end
|
||||
|
||||
type t =
|
||||
{ name : string
|
||||
{ lang : Lang.t
|
||||
; name : string
|
||||
; root : Path.t
|
||||
; version : string option
|
||||
; packages : Package.t Package.Name.Map.t
|
||||
}
|
||||
|
||||
let filename = "dune-project"
|
||||
|
@ -24,19 +33,68 @@ let lang =
|
|||
in
|
||||
field_multi "lang" (name @> version @> nil) (fun () v -> v)
|
||||
|
||||
let name ~dir =
|
||||
let default_name ~dir ~packages =
|
||||
match Package.Name.Map.choose packages with
|
||||
| None ->
|
||||
"_" ^ String.concat ~sep:"_" (Path.explode_exn dir)
|
||||
| Some (name, _) ->
|
||||
Package.Name.to_string
|
||||
(Package.Name.Map.fold packages ~init:name ~f:(fun pkg acc ->
|
||||
min acc pkg.Package.name))
|
||||
|
||||
let name ~dir ~packages =
|
||||
field_o "name" string >>= function
|
||||
| Some s -> return s
|
||||
| None -> return ("_" ^ String.concat ~sep:"_" (Path.explode_exn dir))
|
||||
| None -> return (default_name ~dir ~packages)
|
||||
|
||||
let parse ~dir =
|
||||
let parse ~dir packages =
|
||||
record
|
||||
(lang >>= fun Dune_0_1 ->
|
||||
name ~dir >>= fun name ->
|
||||
name ~dir ~packages >>= fun name ->
|
||||
field_o "version" string >>= fun version ->
|
||||
return { name; version })
|
||||
return { lang = Dune (0, 1)
|
||||
; name
|
||||
; root = dir
|
||||
; version
|
||||
; packages
|
||||
})
|
||||
|
||||
let load ~dir =
|
||||
let load_dune_project ~dir packages =
|
||||
let fname = Path.relative dir filename in
|
||||
let sexp = Io.Sexp.load_many_as_one fname in
|
||||
parse ~dir sexp
|
||||
parse ~dir packages sexp
|
||||
|
||||
let make_jbuilder_project ~dir packages =
|
||||
{ lang = Jbuilder
|
||||
; name = default_name ~dir ~packages
|
||||
; root = dir
|
||||
; version = None
|
||||
; packages
|
||||
}
|
||||
|
||||
let load ~dir ~files =
|
||||
let packages =
|
||||
String.Set.fold files ~init:[] ~f:(fun fn acc ->
|
||||
match Filename.split_extension fn with
|
||||
| (pkg, ".opam") when pkg <> "" ->
|
||||
let version_from_opam_file =
|
||||
let opam = Opam_file.load (Path.relative dir fn) in
|
||||
match Opam_file.get_field opam "version" with
|
||||
| Some (String (_, s)) -> Some s
|
||||
| _ -> None
|
||||
in
|
||||
let name = Package.Name.of_string pkg in
|
||||
(name,
|
||||
{ Package. name
|
||||
; path = dir
|
||||
; version_from_opam_file
|
||||
}) :: acc
|
||||
| _ -> acc)
|
||||
|> Package.Name.Map.of_list_exn
|
||||
in
|
||||
if String.Set.mem files filename then
|
||||
Some (load_dune_project ~dir packages)
|
||||
else if not (Package.Name.Map.is_empty packages) then
|
||||
Some (make_jbuilder_project ~dir packages)
|
||||
else
|
||||
None
|
||||
|
|
|
@ -2,12 +2,23 @@
|
|||
|
||||
open Import
|
||||
|
||||
module Lang : sig
|
||||
type t =
|
||||
| Jbuilder
|
||||
| Dune of Syntax.Version.t
|
||||
end
|
||||
|
||||
type t =
|
||||
{ name : string
|
||||
{ lang : Lang.t
|
||||
; name : string
|
||||
; root : Path.t
|
||||
; version : string option
|
||||
; packages : Package.t Package.Name.Map.t
|
||||
}
|
||||
|
||||
val load : dir:Path.t -> t
|
||||
(** Load a project description from the following directory. [files]
|
||||
is the set of files in this directory. *)
|
||||
val load : dir:Path.t -> files:String.Set.t -> t option
|
||||
|
||||
(** "dune-project" *)
|
||||
val filename : string
|
||||
|
|
|
@ -110,6 +110,7 @@ module Dir = struct
|
|||
{ files : String.Set.t
|
||||
; sub_dirs : t String.Map.t
|
||||
; dune_file : Dune_file.t option
|
||||
; project : Dune_project.t option
|
||||
}
|
||||
|
||||
let contents t = Lazy.force t.contents
|
||||
|
@ -120,6 +121,7 @@ module Dir = struct
|
|||
let files t = (contents t).files
|
||||
let sub_dirs t = (contents t).sub_dirs
|
||||
let dune_file t = (contents t).dune_file
|
||||
let project t = (contents t).project
|
||||
|
||||
let file_paths t =
|
||||
Path.Set.of_string_set (files t) ~f:(Path.relative t.path)
|
||||
|
@ -154,7 +156,7 @@ let ignore_file fn ~is_directory =
|
|||
(fn.[0] = '.' && fn.[1] = '#')
|
||||
|
||||
let load ?(extra_ignored_subtrees=Path.Set.empty) path =
|
||||
let rec walk path ~ignored : Dir.t =
|
||||
let rec walk path ~project ~ignored : Dir.t =
|
||||
let contents = lazy (
|
||||
let files, sub_dirs =
|
||||
Path.readdir path
|
||||
|
@ -169,6 +171,11 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path =
|
|||
Left fn)
|
||||
in
|
||||
let files = String.Set.of_list files in
|
||||
let project =
|
||||
match Dune_project.load ~dir:path ~files with
|
||||
| Some _ as x -> x
|
||||
| None -> project
|
||||
in
|
||||
let dune_file, ignored_subdirs =
|
||||
if ignored then
|
||||
(None, String.Set.empty)
|
||||
|
@ -202,16 +209,16 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path =
|
|||
|| String.Set.mem ignored_subdirs fn
|
||||
|| Path.Set.mem extra_ignored_subtrees path
|
||||
in
|
||||
String.Map.add acc fn (walk path ~ignored))
|
||||
String.Map.add acc fn (walk path ~project ~ignored))
|
||||
in
|
||||
{ Dir. files; sub_dirs; dune_file })
|
||||
{ Dir. files; sub_dirs; dune_file; project })
|
||||
in
|
||||
{ path
|
||||
; contents
|
||||
; ignored
|
||||
}
|
||||
in
|
||||
let root = walk path ~ignored:false in
|
||||
let root = walk path ~ignored:false ~project:None in
|
||||
let dirs = Hashtbl.create 1024 in
|
||||
Hashtbl.add dirs Path.root root;
|
||||
{ root; dirs }
|
||||
|
|
|
@ -43,6 +43,9 @@ module Dir : sig
|
|||
|
||||
(** Return the contents of the dune (or jbuild) file in this directory *)
|
||||
val dune_file : t -> Dune_file.t option
|
||||
|
||||
(** Return the project this directory is part of *)
|
||||
val project : t -> Dune_project.t option
|
||||
end
|
||||
|
||||
(** A [t] value represent a view of the source tree. It is lazily
|
||||
|
|
|
@ -110,6 +110,7 @@ module Scope_info = struct
|
|||
; packages : Package.t Package.Name.Map.t
|
||||
; root : Path.t
|
||||
; version : string option
|
||||
; project : Dune_project.t option
|
||||
}
|
||||
|
||||
let anonymous =
|
||||
|
@ -117,23 +118,15 @@ module Scope_info = struct
|
|||
; packages = Package.Name.Map.empty
|
||||
; root = Path.root
|
||||
; version = None
|
||||
; project = None
|
||||
}
|
||||
|
||||
let make ?version = function
|
||||
| [] -> anonymous
|
||||
| pkg :: rest as pkgs ->
|
||||
let name =
|
||||
List.fold_left rest ~init:pkg.Package.name ~f:(fun acc pkg ->
|
||||
min acc pkg.Package.name)
|
||||
in
|
||||
let root = pkg.path in
|
||||
List.iter rest ~f:(fun pkg -> assert (pkg.Package.path = root));
|
||||
{ name = Some (Package.Name.to_string name)
|
||||
; packages =
|
||||
Package.Name.Map.of_list_exn (List.map pkgs ~f:(fun pkg ->
|
||||
pkg.Package.name, pkg))
|
||||
; root
|
||||
; version
|
||||
let make (project : Dune_project.t) =
|
||||
{ name = Some project.name
|
||||
; packages = project.packages
|
||||
; root = project.root
|
||||
; version = project.version
|
||||
; project = Some project
|
||||
}
|
||||
|
||||
let package_listing packages =
|
||||
|
|
|
@ -29,9 +29,10 @@ module Scope_info : sig
|
|||
; packages : Package.t Package.Name.Map.t
|
||||
; root : Path.t
|
||||
; version : string option
|
||||
; project : Dune_project.t option
|
||||
}
|
||||
|
||||
val make : ?version:string -> Package.t list -> t
|
||||
val make : Dune_project.t -> t
|
||||
|
||||
(** The anonymous represent the scope at the root of the workspace
|
||||
when the root of the workspace contains no [<package>.opam]
|
||||
|
|
|
@ -184,73 +184,31 @@ let interpret ~dir ~scope ~ignore_promoted_rules
|
|||
|
||||
let load ?extra_ignored_subtrees ?(ignore_promoted_rules=false) () =
|
||||
let ftree = File_tree.load Path.root ?extra_ignored_subtrees in
|
||||
let packages =
|
||||
File_tree.fold ftree ~traverse_ignored_dirs:false ~init:[] ~f:(fun dir pkgs ->
|
||||
let path = File_tree.Dir.path dir in
|
||||
let files = File_tree.Dir.files dir in
|
||||
String.Set.fold files ~init:pkgs ~f:(fun fn acc ->
|
||||
match Filename.split_extension fn with
|
||||
| (pkg, ".opam") when pkg <> "" ->
|
||||
let version_from_opam_file =
|
||||
let opam = Opam_file.load (Path.relative path fn) in
|
||||
match Opam_file.get_field opam "version" with
|
||||
| Some (String (_, s)) -> Some s
|
||||
| _ -> None
|
||||
in
|
||||
let name = Package.Name.of_string pkg in
|
||||
(name,
|
||||
{ Package. name
|
||||
; path
|
||||
; version_from_opam_file
|
||||
}) :: acc
|
||||
| _ -> acc))
|
||||
in
|
||||
let packages =
|
||||
Package.Name.Map.of_list_multi packages
|
||||
|> Package.Name.Map.mapi ~f:(fun name pkgs ->
|
||||
match pkgs with
|
||||
| [pkg] -> pkg
|
||||
| _ ->
|
||||
die "Too many opam files for package %S:\n%s"
|
||||
(Package.Name.to_string name)
|
||||
(String.concat ~sep:"\n"
|
||||
(List.map pkgs ~f:(fun pkg ->
|
||||
sprintf "- %s" (Path.to_string (Package.opam_file pkg))))))
|
||||
in
|
||||
let scopes =
|
||||
Package.Name.Map.values packages
|
||||
|> List.map ~f:(fun pkg -> (pkg.Package.path, pkg))
|
||||
|> Path.Map.of_list_multi
|
||||
|> Path.Map.map ~f:Scope_info.make
|
||||
in
|
||||
|
||||
let projects =
|
||||
File_tree.fold ftree ~traverse_ignored_dirs:false ~init:[]
|
||||
~f:(fun dir acc ->
|
||||
let path = File_tree.Dir.path dir in
|
||||
let files = File_tree.Dir.files dir in
|
||||
if String.Set.mem files Dune_project.filename then begin
|
||||
(path, Dune_project.load ~dir:path) :: acc
|
||||
end else
|
||||
acc)
|
||||
|> Path.Map.of_list_exn
|
||||
match File_tree.Dir.project dir with
|
||||
| Some p when p.root = File_tree.Dir.path dir -> p :: acc
|
||||
| _ -> acc)
|
||||
in
|
||||
let packages =
|
||||
List.fold_left projects ~init:Package.Name.Map.empty
|
||||
~f:(fun acc (p : Dune_project.t) ->
|
||||
Package.Name.Map.merge acc p.packages ~f:(fun name a b ->
|
||||
match a, b with
|
||||
| None, None -> None
|
||||
| None, Some _ -> b
|
||||
| Some _, None -> a
|
||||
| Some a, Some b ->
|
||||
die "Too many opam files for package %S:\n- %s\n- %s"
|
||||
(Package.Name.to_string name)
|
||||
(Path.to_string_maybe_quoted (Package.opam_file a))
|
||||
(Path.to_string_maybe_quoted (Package.opam_file b))))
|
||||
in
|
||||
let scopes =
|
||||
Path.Map.merge scopes projects ~f:(fun path scope project ->
|
||||
match scope, project with
|
||||
| None, None -> assert false
|
||||
| Some _, None -> scope
|
||||
| None, Some { name; version } ->
|
||||
Some { name = Some name
|
||||
; packages = Package.Name.Map.empty
|
||||
; root = path
|
||||
; version
|
||||
}
|
||||
| Some scope, Some { name; version } ->
|
||||
Some { scope with
|
||||
name = Some name
|
||||
; version
|
||||
})
|
||||
List.map projects ~f:(fun (p : Dune_project.t) ->
|
||||
(p.root, Scope_info.make p))
|
||||
|> Path.Map.of_list_exn
|
||||
in
|
||||
|
||||
let scopes =
|
||||
|
|
Loading…
Reference in New Issue