feature: allow installing source trees

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

<!-- ps-id: 7566b2e4-deeb-457c-81c6-2ca51652a09b -->

doc/changes/8349.md

@@ -0,0 +1,2 @@
+- Introduce `(source_trees ..)` to the install stanza to allow installing
+  entire source trees. (#8349, @rgrinberg)

src/dune_rules/dune_file.ml

@@ -1114,6 +1114,7 @@ module Install_conf = struct
     { section : Section_with_site.t
     ; files : Install_entry.File.t list
     ; dirs : Install_entry.Dir.t list
+    ; source_trees : Install_entry.Dir.t list
     ; package : Package.t
     ; enabled_if : Blang.t
     }
@@ -1128,17 +1129,26 @@ module Install_conf = struct
            "dirs"
            (Dune_lang.Syntax.since Stanza.syntax (3, 5)
             >>> repeat Install_entry.Dir.decode)
+       and+ source_trees =
+         field_o
+           "source_trees"
+           (Dune_lang.Syntax.since Stanza.syntax (3, 11)
+            >>> repeat Install_entry.Dir.decode)
        and+ package = Stanza_common.Pkg.field ~stanza:"install"
        and+ enabled_if =
          let allowed_vars = Enabled_if.common_vars ~since:(2, 6) in
          Enabled_if.decode ~allowed_vars ~since:(Some (2, 6)) ()
        in
-       let files, dirs =
-         match files, dirs with
-         | None, None -> User_error.raise ~loc [ Pp.textf "dirs or files must be set" ]
-         | _, _ -> Option.value files ~default:[], Option.value dirs ~default:[]
+       let files, dirs, source_trees =
+         match files, dirs, source_trees with
+         | None, None, None ->
+           User_error.raise ~loc [ Pp.textf "dirs, files, or source_trees must be set" ]
+         | _, _, _ ->
+           ( Option.value files ~default:[]
+           , Option.value dirs ~default:[]
+           , Option.value source_trees ~default:[] )
        in
-       { section; dirs; files; package; enabled_if })
+       { section; dirs; files; source_trees; package; enabled_if })
   ;;
 end
 
@@ -1321,7 +1331,13 @@ module Executables = struct
                 (File_binding.Unexpanded.make ~src:(locn, name ^ ext) ~dst:(locp, pub))))
           |> List.filter_opt
         in
-        { Install_conf.section = Section Bin; files; dirs = []; package; enabled_if })
+        { Install_conf.section = Section Bin
+        ; files
+        ; dirs = []
+        ; package
+        ; enabled_if
+        ; source_trees = []
+        })
     ;;
   end
 

src/dune_rules/dune_file.mli

@@ -228,6 +228,7 @@ module Install_conf : sig
     { section : Section_with_site.t
     ; files : Install_entry.File.t list
     ; dirs : Install_entry.Dir.t list
+    ; source_trees : Install_entry.Dir.t list
     ; package : Package.t
     ; enabled_if : Blang.t
     }

src/dune_rules/install_entry_with_site.mli

@@ -6,7 +6,7 @@ val make_with_site
   :  Section_with_site.t
   -> ?dst:string
   -> (loc:Loc.t -> pkg:Package.Name.t -> site:Site.t -> Section.t Memo.t)
-  -> kind:[ `File | `Directory ]
+  -> kind:Install.Entry.kind
   -> Path.Build.t
   -> Path.Build.t Install.Entry.t Memo.t
 

src/dune_rules/install_rules.ml

@@ -410,7 +410,7 @@ end = struct
           let* dirs_expanded =
             Install_entry.Dir.to_file_bindings_expanded i.dirs ~expand_str ~dir
           in
-          let+ files_from_dirs =
+          let* files_from_dirs =
             Memo.List.map dirs_expanded ~f:(fun fb ->
               let loc = File_binding.Expanded.src_loc fb in
               let src = File_binding.Expanded.src fb in
@@ -425,7 +425,23 @@ end = struct
               in
               Install.Entry.Sourced.create ~loc entry)
           in
-          files @ files_from_dirs
+          let+ source_trees =
+            Install_entry.Dir.to_file_bindings_expanded i.source_trees ~expand_str ~dir
+            >>= Memo.List.map ~f:(fun fb ->
+              let loc = File_binding.Expanded.src_loc fb in
+              let src = File_binding.Expanded.src fb in
+              let dst = File_binding.Expanded.dst fb in
+              let+ entry =
+                Install_entry_with_site.make_with_site
+                  section
+                  ~kind:`Source_tree
+                  (Sites.section_of_site sites)
+                  src
+                  ?dst
+              in
+              Install.Entry.Sourced.create ~loc entry)
+          in
+          List.concat [ files; files_from_dirs; source_trees ]
         | Library lib ->
           let sub_dir = Dune_file.Library.sub_dir lib in
           let* dir_contents = Dir_contents.get sctx ~dir in
@@ -845,14 +861,22 @@ end
 
 include Meta_and_dune_package
 
+let symlink_source_dir ~dir ~dst =
+  let+ _, files = Source_deps.files dir in
+  Path.Set.to_list_map files ~f:(fun src ->
+    let suffix = Path.drop_prefix_exn ~prefix:dir src in
+    let dst = Path.Build.append_local dst suffix in
+    suffix, dst, Action_builder.symlink ~src ~dst)
+;;
+
 let symlink_installed_artifacts_to_build_install
   sctx
   (entries : Install.Entry.Sourced.t list)
   ~install_paths
   =
   let ctx = Super_context.context sctx |> Context.build_context in
   let install_dir = Install.Context.dir ~context:ctx.name in
-  List.map entries ~f:(fun (s : Install.Entry.Sourced.t) ->
+  Memo.parallel_map entries ~f:(fun (s : Install.Entry.Sourced.t) ->
     let entry = s.entry in
     let dst =
       let relative =
@@ -866,17 +890,37 @@ let symlink_installed_artifacts_to_build_install
       | User l -> l
       | Dune -> Loc.in_file (Path.build entry.src)
     in
-    let rule =
-      let { Action_builder.With_targets.targets; build } =
-        (match entry.kind with
+    let src = Path.build entry.src in
+    let rule { Action_builder.With_targets.targets; build } =
+      Rule.make ~info:(From_dune_file loc) ~context:(Some ctx) ~targets build
+    in
+    match entry.kind with
+    | `Source_tree ->
+      symlink_source_dir ~dir:src ~dst
+      >>| List.map ~f:(fun (suffix, dst, build) ->
+        let rule = rule build in
+        let entry =
+          let entry =
+            Install.Entry.map_dst entry ~f:(fun dst ->
+              Install.Entry.Dst.add_suffix dst (Path.Local.to_string suffix))
+          in
+          let entry = Install.Entry.set_src entry dst in
+          Install.Entry.set_kind entry `File
+        in
+        { s with entry }, rule)
+    | (`File | `Directory) as kind ->
+      let entry =
+        let entry = Install.Entry.set_src entry dst in
+        { s with entry }
+      in
+      let action =
+        (match kind with
          | `File -> Action_builder.symlink
          | `Directory -> Action_builder.symlink_dir)
-          ~src:(Path.build entry.src)
+          ~src
           ~dst
       in
-      Rule.make ~info:(Rule.Info.of_loc_opt (Some loc)) ~context:(Some ctx) ~targets build
-    in
-    { s with entry = Install.Entry.set_src entry dst }, rule)
+      Memo.return [ entry, rule action ])
 ;;
 
 let promote_install_file (ctx : Context.t) =
@@ -935,8 +979,11 @@ let symlinked_entries sctx package =
   let package_name = Package.name package in
   let roots = Install.Roots.opam_from_prefix Path.root in
   let install_paths = Install.Paths.make ~package:package_name ~roots in
-  let+ entries = install_entries sctx package in
-  symlink_installed_artifacts_to_build_install sctx ~install_paths entries |> List.split
+  let* entries = install_entries sctx package in
+  let+ entries =
+    symlink_installed_artifacts_to_build_install sctx ~install_paths entries
+  in
+  List.concat entries |> List.split
 ;;
 
 let symlinked_entries =
@@ -1002,15 +1049,18 @@ include (
         List [ Dune_lang.atom_or_quoted_string name; target dst ]
       ;;
 
+      let make_entry entry path comps =
+        Install.Entry.set_src entry path
+        |> Install.Entry.map_dst ~f:(fun dst -> Install.Entry.Dst.concat_all dst comps)
+      ;;
+
       let read_dir_recursively (entry : _ Install.Entry.t) =
         let rec loop acc dirs =
           match dirs with
           | [] ->
             List.rev_map acc ~f:(fun (path, comps) ->
               let comps = List.rev comps in
-              Install.Entry.set_src entry path
-              |> Install.Entry.map_dst ~f:(fun dst ->
-                Install.Entry.Dst.concat_all dst comps))
+              make_entry entry path comps)
             |> List.sort ~compare:(fun (x : _ Install.Entry.t) (y : _ Install.Entry.t) ->
               Path.compare x.src y.src)
           | (dir, comps) :: dirs ->
@@ -1033,15 +1083,21 @@ include (
       ;;
 
       let action (entries, dst) ~ectx:_ ~eenv:_ =
-        let entries =
-          List.concat_map entries ~f:(fun (entry : _ Install.Entry.t) ->
-            match entry.kind with
-            | `File -> [ entry ]
-            | `Directory -> read_dir_recursively entry)
-          |> Install.Entry.gen_install_file
+        let open Fiber.O in
+        let+ entries =
+          let+ entries =
+            Fiber.parallel_map entries ~f:(fun (entry : _ Install.Entry.t) ->
+              match entry.kind with
+              | `File -> Fiber.return [ entry ]
+              | `Directory -> Fiber.return (read_dir_recursively entry)
+              | `Source_tree ->
+                Code_error.raise
+                  "This entry should have been expanded into `File"
+                  [ "entry", Install.Entry.to_dyn Path.to_dyn entry ])
+          in
+          List.concat entries |> Install.Entry.gen_install_file
         in
-        Io.write_file (Path.build dst) entries;
-        Fiber.return ()
+        Io.write_file (Path.build dst) entries
       ;;
     end
 

src/install/entry.ml

@@ -9,6 +9,7 @@ module Dst : sig
   val to_string : t -> string
   val concat_all : t -> string list -> t
   val add_prefix : string -> t -> t
+  val add_suffix : t -> string -> t
   val to_install_file : t -> src_basename:string -> section:Section.t -> string option
   val of_install_file : string option -> src_basename:string -> section:Section.t -> t
   val explicit : string -> t
@@ -25,6 +26,7 @@ end = struct
   let to_string t = t
   let concat_all t suffixes = List.fold_left suffixes ~init:t ~f:Filename.concat
   let add_prefix p t = Filename.concat p t
+  let add_suffix t p = Filename.concat t p
   let explicit t = t
   let compare = String.compare
 
@@ -71,9 +73,15 @@ end = struct
   let install_path t section p = Path.relative (Paths.get t section) (to_string p)
 end
 
+type kind =
+  [ `File
+  | `Directory
+  | `Source_tree
+  ]
+
 type 'src t =
   { src : 'src
-  ; kind : [ `File | `Directory ]
+  ; kind : kind
   ; dst : Dst.t
   ; section : Section.t
   ; optional : bool
@@ -86,6 +94,7 @@ let to_dyn { src; kind; dst; section; optional } =
   let dyn_of_kind = function
     | `File -> String "file"
     | `Directory -> String "directory"
+    | `Source_tree -> String "source_tree"
   in
   record
     [ "src", Path.Build.to_dyn src
@@ -196,6 +205,7 @@ let make section ?dst ~kind src =
 
 let make_with_dst section dst ~kind ~src = { optional = false; src; dst; section; kind }
 let set_src t src = { t with src }
+let set_kind t kind = { t with kind }
 let relative_installed_path t ~paths = Dst.install_path paths t.section t.dst
 
 let add_install_prefix t ~paths ~prefix =
@@ -225,6 +235,7 @@ let dyn_of_kind =
   function
   | `File -> variant "File" []
   | `Directory -> variant "Directory" []
+  | `Source_tree -> variant "Source_tree" []
 ;;
 
 let to_dyn f { optional; src; kind; dst; section } =

src/install/entry.mli

@@ -7,6 +7,7 @@ module Dst : sig
 
   val to_string : t -> string
   val add_prefix : string -> t -> t
+  val add_suffix : t -> string -> t
   val concat_all : t -> string list -> t
 
   include Dune_lang.Conv.S with type t := t
@@ -15,9 +16,15 @@ module Dst : sig
   val install_path : Paths.t -> Section.t -> t -> Path.t
 end
 
+type kind =
+  [ `File
+  | `Directory
+  | `Source_tree
+  ]
+
 type 'src t = private
   { src : 'src
-  ; kind : [ `File | `Directory ]
+  ; kind : kind
   ; dst : Dst.t
   ; section : Section.t
   ; optional : bool
@@ -45,22 +52,10 @@ val adjust_dst
   -> section:Section.t
   -> Dst.t
 
+val set_kind : 'src t -> kind -> 'src t
 val adjust_dst' : src:Path.Build.t -> dst:string option -> section:Section.t -> Dst.t
-
-val make
-  :  Section.t
-  -> ?dst:string
-  -> kind:[ `File | `Directory ]
-  -> Path.Build.t
-  -> Path.Build.t t
-
-val make_with_dst
-  :  Section.t
-  -> Dst.t
-  -> kind:[ `File | `Directory ]
-  -> src:Path.Build.t
-  -> Path.Build.t t
-
+val make : Section.t -> ?dst:string -> kind:kind -> Path.Build.t -> Path.Build.t t
+val make_with_dst : Section.t -> Dst.t -> kind:kind -> src:Path.Build.t -> Path.Build.t t
 val set_src : _ t -> 'src -> 'src t
 val map_dst : 'a t -> f:(Dst.t -> Dst.t) -> 'a t
 val relative_installed_path : _ t -> paths:Paths.t -> Path.t

test/blackbox-tests/test-cases/install/install-source-tree.t

@@ -0,0 +1,43 @@
+Testing the source_trees field which is used to entire source_trees
+
+  $ cat >dune-project <<EOF
+  > (lang dune 3.11)
+  > (package
+  >  (allow_empty)
+  >  (name mypkg))
+  > EOF
+
+  $ cat >dune <<EOF
+  > (install
+  >  (section doc)
+  >  (source_trees mydocs))
+  > EOF
+
+  $ test() {
+  >   dune build mypkg.install
+  >   cat _build/default/mypkg.install
+  > }
+
+Try to build a source directory that doesn't exist:
+
+  $ test
+  lib: [
+    "_build/install/default/lib/mypkg/META"
+    "_build/install/default/lib/mypkg/dune-package"
+  ]
+
+Create the source directory and fill it up with some dummy stuff for the test:
+
+  $ mkdir -p mydocs/foo
+  $ touch mydocs/foo.md mydocs/baz.md mydocs/foo/bar.md
+
+  $ test
+  lib: [
+    "_build/install/default/lib/mypkg/META"
+    "_build/install/default/lib/mypkg/dune-package"
+  ]
+  doc: [
+    "_build/install/default/doc/mypkg/mydocs/baz.md" {"mydocs/baz.md"}
+    "_build/install/default/doc/mypkg/mydocs/foo.md" {"mydocs/foo.md"}
+    "_build/install/default/doc/mypkg/mydocs/foo/bar.md" {"mydocs/foo/bar.md"}
+  ]