ocaml · rgrinberg · Oct 29, 2022 · Oct 17, 2022
diff --git a/CHANGES.md b/CHANGES.md
@@ -30,6 +30,9 @@ Unreleased
 - Prevent crash if absolute paths are used in the install stanza and in
   recursive globs. These cases now result in a user error. (#6331, @gridbugs)
 
+- Add `(glob_files <glob>)` and `(glob_files_rec <glob>)` terms to the `files`
+  field of the `install` stanza (#6250, closes #6018, @gridbugs)
+
 3.5.0 (2022-10-19)
 ------------------
 

diff --git a/doc/dune-files.rst b/doc/dune-files.rst
@@ -1450,6 +1450,38 @@ generates a file by listing all the files in a subdirectory ``resources``:
       (with-stdout-to foo.sexp
       (system "echo '(' resources/* ')'"))))
 
+Globs in the Install Stanza
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+You can use globs to specify files to install by using the terms
+``(glob_files <glob>)`` and ``(glob_files_rec <glob>)`` inside the ``files``
+field of the install stanza (but not inside the ``dirs`` field).
+See the :ref:`glob <glob>` for details of the glob syntax.
+The ``(glob_files <glob>)`` term will expand its argument within a single
+directory, whereas the ``(glob_files_rec <glob>)`` term will recursively expand
+its argument within all subdirectories.
+
+For example:
+
+.. code:: scheme
+
+    (install
+     (files (glob_files style/*.css) (glob_files_rec content/*.html))
+     (section share))
+
+This example will install:
+
+- all files matching ``*.css`` in the ``style`` directory
+
+- all files matching ``*.html`` in the ``content`` directory, or any of its
+  descendant subdirectories
+
+Note that the paths to files are preserved after installation. Suppose the
+source directory contained the files ``style/foo.css`` and
+``content/bar/baz.html``. The example above will place these files in
+``share/<package>/style/foo.css`` and ``share/<package>/content/bar/baz.html``
+respectively.
+
 Handling of the .exe Extension on Windows
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 

diff --git a/src/dune_rules/artifacts_db.ml b/src/dune_rules/artifacts_db.ml
@@ -14,7 +14,7 @@ let get_installed_binaries ~(context : Context.t) stanzas =
       let dir = Path.Build.append_source context.build_dir d.dir in
       let binaries_from_install files =
         let* unexpanded_file_bindings =
-          Dune_file.Install_conf.File_entry.expand_include_multi files
+          Dune_file.Install_conf.File_entry.to_file_bindings_unexpanded files
             ~expand_str:(expand_str ~dir) ~dir
         in
         Memo.List.map unexpanded_file_bindings ~f:(fun fb ->

diff --git a/src/dune_rules/dep_conf.ml b/src/dune_rules/dep_conf.ml
@@ -5,10 +5,7 @@ type t =
   | File of String_with_vars.t
   | Alias of String_with_vars.t
   | Alias_rec of String_with_vars.t
-  | Glob_files of
-      { glob : String_with_vars.t
-      ; recursive : bool
-      }
+  | Glob_files of Glob_files.t
   | Source_tree of String_with_vars.t
   | Package of String_with_vars.t
   | Universe
@@ -51,11 +48,12 @@ let decode =
       ; ("alias", sw >>| fun x -> Alias x)
       ; ("alias_rec", sw >>| fun x -> Alias_rec x)
       ; ( "glob_files"
-        , sw >>| fun x -> Glob_files { glob = x; recursive = false } )
+        , sw >>| fun glob -> Glob_files { Glob_files.glob; recursive = false }
+        )
       ; ( "glob_files_rec"
         , let+ () = Dune_lang.Syntax.since Stanza.syntax (3, 0)
-          and+ x = sw in
-          Glob_files { glob = x; recursive = true } )
+          and+ glob = sw in
+          Glob_files { Glob_files.glob; recursive = true } )
       ; ("package", sw >>| fun x -> Package x)
       ; ("universe", return Universe)
       ; ( "files_recursively_in"

diff --git a/src/dune_rules/dep_conf.mli b/src/dune_rules/dep_conf.mli
@@ -4,10 +4,7 @@ type t =
   | File of String_with_vars.t
   | Alias of String_with_vars.t
   | Alias_rec of String_with_vars.t
-  | Glob_files of
-      { glob : String_with_vars.t
-      ; recursive : bool
-      }
+  | Glob_files of Glob_files.t
   | Source_tree of String_with_vars.t
   | Package of String_with_vars.t
   | Universe

diff --git a/src/dune_rules/dep_conf_eval.ml b/src/dune_rules/dep_conf_eval.ml
@@ -15,18 +15,6 @@ let package_install ~(context : Build_context.t) ~(pkg : Package.t) =
   sprintf ".%s-files" (Package.Name.to_string name)
   |> Alias.Name.of_string |> Alias.make ~dir
 
-module Source_tree_map_reduce =
-  Source_tree.Dir.Make_map_reduce (Action_builder) (Monoid.Union (Path.Set))
-
-let collect_source_files_recursively dir ~f =
-  let prefix_with, dir = Path.extract_build_context_dir_exn dir in
-  Action_builder.of_memo (Source_tree.find_dir dir) >>= function
-  | None -> Action_builder.return Path.Set.empty
-  | Some dir ->
-    Source_tree_map_reduce.map_reduce dir ~traverse:Sub_dirs.Status.Set.all
-      ~f:(fun dir ->
-        f (Path.append_source prefix_with (Source_tree.Dir.path dir)))
-
 type dep_evaluation_result =
   | Simple of Path.t list Memo.t
   | Other of Path.t list Action_builder.t
@@ -136,24 +124,15 @@ let rec dep expander = function
       (let* a = make_alias expander s in
        let+ () = dep_on_alias_rec ~loc:(String_with_vars.loc s) a in
        [])
-  | Glob_files { glob = s; recursive } ->
+  | Glob_files glob_files ->
     Other
-      (let loc = String_with_vars.loc s in
-       let* path = Expander.expand_path expander s in
-       if recursive && not (Path.is_managed path) then
-         User_error.raise ~loc
-           [ Pp.textf "Absolute paths in recursive globs are not supported." ];
-       let files_in =
-         let glob = Path.basename path |> Glob.of_string_exn loc in
-         fun dir ->
-           Action_builder.paths_matching ~loc (File_selector.of_glob ~dir glob)
-       in
-       let+ files =
-         let dir = Path.parent_exn path in
-         if recursive then collect_source_files_recursively dir ~f:files_in
-         else files_in dir
-       in
-       Path.Set.to_list files)
+      (Glob_files.Expand.action_builder glob_files
+         ~f:(Expander.expand_str expander)
+         ~base_dir:(Expander.dir expander)
+      >>| List.map ~f:(fun path ->
+              if Filename.is_relative path then
+                Path.Build.relative (Expander.dir expander) path |> Path.build
+              else Path.of_string path))
   | Source_tree s ->
     Other
       (let* path = Expander.expand_path expander s in

diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml
@@ -1087,9 +1087,59 @@ module Install_conf = struct
         str)
 
   module File_entry = struct
+    module Without_include = struct
+      type t =
+        | File_binding of File_binding.Unexpanded.t
+        | Glob_files of Glob_files.t
+
+      let decode =
+        let open Dune_lang.Decoder in
+        let file_binding_decode =
+          let+ file_binding = File_binding.Unexpanded.decode in
+          File_binding file_binding
+        in
+        let glob_files_decode =
+          let version_check = Dune_lang.Syntax.since Stanza.syntax (3, 6) in
+          let+ glob_files =
+            sum
+              [ ( "glob_files"
+                , let+ glob = version_check >>> String_with_vars.decode in
+                  { Glob_files.glob; recursive = false } )
+              ; ( "glob_files_rec"
+                , let+ glob = version_check >>> String_with_vars.decode in
+                  { Glob_files.glob; recursive = true } )
+              ]
+          in
+          Glob_files glob_files
+        in
+        file_binding_decode <|> glob_files_decode
+
+      let to_file_bindings_unexpanded t ~expand_str ~dir =
+        match t with
+        | File_binding file_binding -> Memo.return [ file_binding ]
+        | Glob_files glob_files ->
+          let open Memo.O in
+          let+ paths =
+            Glob_files.Expand.memo glob_files ~f:expand_str ~base_dir:dir
+          in
+          let glob_loc = String_with_vars.loc glob_files.glob in
+          List.map paths ~f:(fun path ->
+              let src = (glob_loc, path) in
+              File_binding.Unexpanded.make ~src ~dst:src)
+
+      let to_file_bindings_expanded t ~expand_str ~dir =
+        to_file_bindings_unexpanded t ~expand_str ~dir
+        |> Memo.bind
+             ~f:
+               (Memo.List.map
+                  ~f:
+                    (File_binding.Unexpanded.expand ~dir
+                       ~f:(expand_str_with_check_for_local_path ~expand_str)))
+    end
+
     include
       Recursive_include.Make
-        (File_binding.Unexpanded)
+        (Without_include)
         (struct
           let include_keyword = "include"
 
@@ -1101,24 +1151,51 @@ module Install_conf = struct
     let expand_include_multi ts ~expand_str ~dir =
       Memo.List.concat_map ts ~f:(expand_include ~expand_str ~dir)
 
-    let of_file_binding = of_base
+    let of_file_binding file_binding =
+      of_base (Without_include.File_binding file_binding)
+
+    let to_file_bindings_unexpanded ts ~expand_str ~dir =
+      expand_include_multi ts ~expand_str ~dir
+      |> Memo.bind
+           ~f:
+             (Memo.List.concat_map
+                ~f:
+                  (Without_include.to_file_bindings_unexpanded ~expand_str ~dir))
+
+    let to_file_bindings_expanded ts ~expand_str ~dir =
+      expand_include_multi ts ~expand_str ~dir
+      |> Memo.bind
+           ~f:
+             (Memo.List.concat_map
+                ~f:(Without_include.to_file_bindings_expanded ~expand_str ~dir))
+  end
 
-    let expand t ~expand_str ~dir =
-      let open Memo.O in
-      let* unexpanded = expand_include t ~expand_str ~dir in
-      Memo.List.map unexpanded
-        ~f:
-          (File_binding.Unexpanded.expand ~dir
-             ~f:(expand_str_with_check_for_local_path ~expand_str))
+  module Dir_entry = struct
+    include
+      Recursive_include.Make
+        (File_binding.Unexpanded)
+        (struct
+          let include_keyword = "include"
 
-    let expand_multi ts ~expand_str ~dir =
-      Memo.List.concat_map ts ~f:(expand ~expand_str ~dir)
+          let include_allowed_in_versions = `Since (3, 5)
+
+          let non_sexp_behaviour = `User_error
+        end)
+
+    let to_file_bindings_expanded ts ~expand_str ~dir =
+      Memo.List.concat_map ts ~f:(expand_include ~expand_str ~dir)
+      |> Memo.bind
+           ~f:
+             (Memo.List.map
+                ~f:
+                  (File_binding.Unexpanded.expand ~dir
+                     ~f:(expand_str_with_check_for_local_path ~expand_str)))
   end
 
   type t =
     { section : Install.Section_with_site.t
     ; files : File_entry.t list
-    ; dirs : File_entry.t list
+    ; dirs : Dir_entry.t list
     ; package : Package.t
     ; enabled_if : Blang.t
     }
@@ -1131,7 +1208,7 @@ module Install_conf = struct
        and+ dirs =
          field_o "dirs"
            (Dune_lang.Syntax.since Stanza.syntax (3, 5)
-           >>> repeat File_entry.decode)
+           >>> repeat Dir_entry.decode)
        and+ package = Stanza_common.Pkg.field ~stanza:"install"
        and+ enabled_if =
          let allowed_vars = Enabled_if.common_vars ~since:(2, 6) in
@@ -1147,9 +1224,9 @@ module Install_conf = struct
 
        { section; dirs; files; package; enabled_if })
 
-  let expand_files t = File_entry.expand_multi t.files
+  let expand_files t = File_entry.to_file_bindings_expanded t.files
 
-  let expand_dirs t = File_entry.expand_multi t.dirs
+  let expand_dirs t = Dir_entry.to_file_bindings_expanded t.dirs
 end
 
 module Executables = struct

diff --git a/src/dune_rules/dune_file.mli b/src/dune_rules/dune_file.mli
@@ -250,23 +250,21 @@ module Install_conf : sig
   module File_entry : sig
     type t
 
-    val expand_include_multi :
+    val to_file_bindings_unexpanded :
          t list
       -> expand_str:(String_with_vars.t -> string Memo.t)
       -> dir:Path.Build.t
       -> File_binding.Unexpanded.t list Memo.t
+  end
 
-    val expand_multi :
-         t list
-      -> expand_str:(String_with_vars.t -> string Memo.t)
-      -> dir:Path.Build.t
-      -> File_binding.Expanded.t list Memo.t
+  module Dir_entry : sig
+    type t
   end
 
   type t =
     { section : Install.Section_with_site.t
     ; files : File_entry.t list
-    ; dirs : File_entry.t list
+    ; dirs : Dir_entry.t list
     ; package : Package.t
     ; enabled_if : Blang.t
     }

diff --git a/src/dune_rules/file_binding.ml b/src/dune_rules/file_binding.ml
@@ -11,6 +11,13 @@ let equal f g { src; dst } t = f src t.src && Option.equal g dst t.dst
 module Expanded = struct
   type nonrec t = (Loc.t * Path.Build.t, Loc.t * string) t
 
+  let to_dyn { src; dst } =
+    let open Dyn in
+    record
+      [ ("src", pair Loc.to_dyn Path.Build.to_dyn src)
+      ; ("dst", option (pair Loc.to_dyn string) dst)
+      ]
+
   let src t = snd t.src
 
   let dst t = Option.map ~f:snd t.dst
@@ -31,6 +38,13 @@ end
 module Unexpanded = struct
   type nonrec t = (String_with_vars.t, String_with_vars.t) t
 
+  let to_dyn { src; dst } =
+    let open Dyn in
+    record
+      [ ("src", String_with_vars.to_dyn src)
+      ; ("dst", option String_with_vars.to_dyn dst)
+      ]
+
   let equal = equal String_with_vars.equal_no_loc String_with_vars.equal_no_loc
 
   let make ~src:(locs, src) ~dst:(locd, dst) =

diff --git a/src/dune_rules/file_binding.mli b/src/dune_rules/file_binding.mli
@@ -3,6 +3,8 @@ open Import
 module Expanded : sig
   type t
 
+  val to_dyn : t -> Dyn.t
+
   val src : t -> Path.Build.t
 
   val dst : t -> string option
@@ -15,6 +17,8 @@ end
 module Unexpanded : sig
   type t
 
+  val to_dyn : t -> Dyn.t
+
   val equal : t -> t -> bool
 
   val make : src:Loc.t * string -> dst:Loc.t * string -> t