[dir_contents] Allow qualified traversal of directories.

This is a cherry-pick of the directory traversal parts from the Dune
PR (ocaml#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 <e+git@x80.org>

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,10 @@ 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) ->
+      (* [local] contains the list of directories from the root, as a
+         reversed prefix. *)
+      let rec walk ft_dir ~dir ~local acc =
         match
           Dir_status.DB.get dir_status_db ~dir
         with
@@ -400,20 +406,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, List.rev 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 name :: local 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 +440,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 +470,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 +479,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

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 ->

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] *)
 

src/dune_file.ml

@@ -1960,13 +1960,17 @@ module Documentation = struct
 end
 
 module Include_subdirs = struct
-  type t = No | Unqualified
 
-  let decode =
-    enum
+  type qualification = Unqualified | Qualified
+  type t = No | Include of qualification
+
+  let decode ~enable_qualified =
+    let opts_list =
       [ "no", No
-      ; "unqualified", Unqualified
-      ]
+      ; "unqualified", Include Unqualified
+      ] @ if enable_qualified then ["qualified", Include Qualified] else []
+    in
+    enum opts_list
 end
 
 type Stanza.t +=
@@ -2053,7 +2057,7 @@ module Stanzas = struct
        [Dune_env.T x])
     ; "include_subdirs",
       (let+ () = Syntax.since Stanza.syntax (1, 1)
-       and+ t = Include_subdirs.decode
+       and+ t = Include_subdirs.decode ~enable_qualified:false
        and+ loc = loc in
        [Include_subdirs (loc, t)])
     ; "toplevel",

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 +=