From 2de51367f4e05dd512891d045223f36f0492f1d3 Mon Sep 17 00:00:00 2001 From: Emilio Jesus Gallego Arias Date: Tue, 26 Mar 2019 17:25:19 +0100 Subject: [PATCH] [dir_contents] Allow qualified traversal of directories. This is a cherry-pick of the directory traversal parts from the Dune PR (#1968). I was uncomfortable with the misnaming done there, so this PR enables the `(include_subdirs qualified)` syntax and provides a `local` part to the traversal so clients [such as the Coq mode] can use it. Note that this does introduce a bit of overhead in the tree traversal, especially in deep trees, it should be possible to optimize if we deem it necessary. Signed-off-by: Emilio Jesus Gallego Arias --- src/dir_contents.ml | 31 +++++++++++++++++++------------ src/dir_status.ml | 5 +++-- src/dir_status.mli | 1 + src/dune_file.ml | 7 +++++-- src/dune_file.mli | 3 ++- 5 files changed, 30 insertions(+), 17 deletions(-) diff --git a/src/dir_contents.ml b/src/dir_contents.ml index 01d804d7258a..f496d872e0f7 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -346,6 +346,10 @@ let clear_cache () = let () = Hooks.End_of_build.always clear_cache +let check_no_qualified loc qualif_mode = + if qualif_mode = Include_subdirs.Qualified then + Errors.fail loc "(include_subdirs qualified) is not supported yet" + let rec get sctx ~dir = match Hashtbl.find cache dir with | Some t -> t @@ -389,8 +393,8 @@ let rec get sctx ~dir = (* Filled while scanning the group root *) Hashtbl.find_exn cache dir end - | Group_root (ft_dir, d) -> - let rec walk ft_dir ~dir acc = + | Group_root (ft_dir, qualif_mode, d) -> + let rec walk ft_dir ~dir ~local acc = match Dir_status.DB.get dir_status_db ~dir with @@ -400,20 +404,22 @@ let rec get sctx ~dir = | None -> File_tree.Dir.files ft_dir | Some d -> load_text_files sctx ft_dir d in - walk_children ft_dir ~dir ((dir, files) :: acc) + walk_children ft_dir ~dir ~local ((dir, local, files) :: acc) | _ -> acc - and walk_children ft_dir ~dir acc = + and walk_children ft_dir ~dir ~local acc = String.Map.foldi (File_tree.Dir.sub_dirs ft_dir) ~init:acc ~f:(fun name ft_dir acc -> let dir = Path.relative dir name in - walk ft_dir ~dir acc) + let local = if qualif_mode = Qualified then local @ [name] else local in + walk ft_dir ~dir ~local acc) in let files = load_text_files sctx ft_dir d in - let subdirs = walk_children ft_dir ~dir [] in + let subdirs = walk_children ft_dir ~dir ~local:[] [] in let modules = lazy ( + check_no_qualified Loc.none qualif_mode; let modules = - List.fold_left ((dir, files) :: subdirs) ~init:Module.Name.Map.empty - ~f:(fun acc (dir, files) -> + List.fold_left ((dir, [], files) :: subdirs) ~init:Module.Name.Map.empty + ~f:(fun acc (dir, _local, files) -> let modules = modules_of_files ~dir ~files in Module.Name.Map.union acc modules ~f:(fun name x y -> Errors.fail (Loc.in_file @@ -432,11 +438,12 @@ let rec get sctx ~dir = Modules.make d ~modules) in let c_sources = lazy ( + check_no_qualified Loc.none qualif_mode; let dune_version = d.dune_version in let init = C.Kind.Dict.make String.Map.empty in let c_sources = - List.fold_left ((dir, files) :: subdirs) ~init - ~f:(fun acc (dir, files) -> + List.fold_left ((dir, [], files) :: subdirs) ~init + ~f:(fun acc (dir, _local, files) -> let sources = C_sources.load_sources ~dir ~dune_version ~files in let f acc sources = String.Map.union acc sources ~f:(fun name x y -> @@ -461,7 +468,7 @@ let rec get sctx ~dir = ) in let t = { kind = Group_root - (lazy (List.map subdirs ~f:(fun (dir, _) -> get sctx ~dir))) + (lazy (List.map subdirs ~f:(fun (dir, _, _) -> get sctx ~dir))) ; dir ; text_files = files ; modules @@ -470,7 +477,7 @@ let rec get sctx ~dir = } in Hashtbl.add cache dir t; - List.iter subdirs ~f:(fun (dir, files) -> + List.iter subdirs ~f:(fun (dir, _, files) -> Hashtbl.add cache dir { kind = Group_part t ; dir diff --git a/src/dir_status.ml b/src/dir_status.ml index 965bbf46d70a..724631ed918f 100644 --- a/src/dir_status.ml +++ b/src/dir_status.ml @@ -10,6 +10,7 @@ module T = struct generated ones. *) | Group_root of File_tree.Dir.t + * Include_subdirs.qualification * Stanza.t list Dir_with_dune.t (* Directory with [(include_subdirs x)] where [x] is not [no] *) @@ -86,8 +87,8 @@ module DB = struct Is_component_of_a_group_but_not_the_root None | Some d -> match get_include_subdirs d.data with - | Some Unqualified -> - Group_root (ft_dir, d) + | Some (Include mode) -> + Group_root (ft_dir, mode, d) | Some No -> Standalone (Some (ft_dir, Some d)) | None -> diff --git a/src/dir_status.mli b/src/dir_status.mli index ee2566e01603..ec4c29ff91bd 100644 --- a/src/dir_status.mli +++ b/src/dir_status.mli @@ -8,6 +8,7 @@ type t = generated ones. *) | Group_root of File_tree.Dir.t + * Dune_file.Include_subdirs.qualification * Stanza.t list Dir_with_dune.t (* Directory with [(include_subdirs x)] where [x] is not [no] *) diff --git a/src/dune_file.ml b/src/dune_file.ml index 97f4e5176b4b..2ce002011342 100644 --- a/src/dune_file.ml +++ b/src/dune_file.ml @@ -1960,12 +1960,15 @@ module Documentation = struct end module Include_subdirs = struct - type t = No | Unqualified + + type qualification = Unqualified | Qualified + type t = No | Include of qualification let decode = enum [ "no", No - ; "unqualified", Unqualified + ; "unqualified", Include Unqualified + ; "qualified", Include Qualified ] end diff --git a/src/dune_file.mli b/src/dune_file.mli index 86df0d8c41e3..7a73b2cf1295 100644 --- a/src/dune_file.mli +++ b/src/dune_file.mli @@ -405,7 +405,8 @@ module Toplevel : sig end module Include_subdirs : sig - type t = No | Unqualified + type qualification = Unqualified | Qualified + type t = No | Include of qualification end type Stanza.t +=