From 60c7f6fde41ef0ef8a69c68ba4fab099d6bfa8ee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Tue, 15 May 2018 09:46:07 +0100 Subject: [PATCH] Collect projects in the file tree directly (#774) --- src/dune_project.ml | 76 +++++++++++++++++++++++++++++++++++----- src/dune_project.mli | 17 +++++++-- src/file_tree.ml | 15 +++++--- src/file_tree.mli | 3 ++ src/jbuild.ml | 25 +++++--------- src/jbuild.mli | 3 +- src/jbuild_load.ml | 82 +++++++++++--------------------------------- 7 files changed, 126 insertions(+), 95 deletions(-) diff --git a/src/dune_project.ml b/src/dune_project.ml index 2fc34596..151e7917 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -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 - ; version : string option + { 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 diff --git a/src/dune_project.mli b/src/dune_project.mli index e7e6e853..0768b405 100644 --- a/src/dune_project.mli +++ b/src/dune_project.mli @@ -2,12 +2,23 @@ open Import +module Lang : sig + type t = + | Jbuilder + | Dune of Syntax.Version.t +end + type t = - { name : string - ; version : string option + { 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 diff --git a/src/file_tree.ml b/src/file_tree.ml index f5a41857..58844479 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -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 } diff --git a/src/file_tree.mli b/src/file_tree.mli index 7d93310d..192e048f 100644 --- a/src/file_tree.mli +++ b/src/file_tree.mli @@ -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 diff --git a/src/jbuild.ml b/src/jbuild.ml index f139ff31..02f4cc34 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -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,24 +118,16 @@ 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 = let longest_pkg = diff --git a/src/jbuild.mli b/src/jbuild.mli index 7c1f843b..e76763fa 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -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 [.opam] diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index b8ebca07..e9631aca 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -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 =