From 56e021741874e1e82fcd82e187a9e39433554e4e Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Wed, 27 Oct 2021 01:18:41 +0100 Subject: [PATCH] Add basic support for directory targets (#5025) This PR implements a basic version of the RFC from #3316. Basically, one can now write [(target (dir output))] in a rule to specify a directory target. This functionality is experimental and is therefore guarded by the [directory-targets] extension. We need directory targets internally at Jane Street and will polish the feature as it gets some further use before making it officially supported in Dune. See the test file for all the currently available features. For now, I only added a brief comment to the docs that this feature is now available for experimentation. Documentation will be expanded when we figure out the full story. Signed-off-by: Andrey Mokhov --- CHANGES.md | 3 + bin/exec.ml | 7 +- bin/print_rules.ml | 20 +- bin/target.ml | 8 + doc/dune-files.rst | 102 ++-- otherlibs/stdune-unstable/path.ml | 7 + otherlibs/stdune-unstable/path.mli | 2 + src/dune_engine/action_exec.ml | 10 +- src/dune_engine/build_system.ml | 484 +++++++++++++----- src/dune_engine/build_system.mli | 4 +- src/dune_engine/dep.ml | 72 ++- src/dune_engine/dep.mli | 21 +- src/dune_engine/file_selector.mli | 4 +- src/dune_engine/process.ml | 6 +- src/dune_engine/rule.ml | 36 +- src/dune_engine/rule.mli | 3 + src/dune_engine/sandbox.ml | 72 ++- src/dune_engine/sandbox.mli | 5 +- src/dune_engine/sandbox_mode.ml | 8 + src/dune_engine/sandbox_mode.mli | 8 +- src/dune_engine/targets.ml | 78 ++- src/dune_engine/targets.mli | 36 +- src/dune_rules/action_unexpanded.ml | 35 +- src/dune_rules/dir_contents.ml | 9 +- src/dune_rules/dune_file.ml | 22 +- src/dune_rules/simple_rules.ml | 39 +- src/dune_rules/targets_spec.ml | 43 +- src/dune_rules/targets_spec.mli | 18 +- .../test-cases/directory-targets.t/run.t | 429 ++++++++++++++++ .../test-cases/glob-deps.t/run.t | 8 + 30 files changed, 1286 insertions(+), 313 deletions(-) create mode 100644 test/blackbox-tests/test-cases/directory-targets.t/run.t diff --git a/CHANGES.md b/CHANGES.md index 2851fbbf134..f415da4073d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -241,6 +241,9 @@ Unreleased - Allow to cancel the initial scan via Control+C (#4460, fixes #4364 @jeremiedimino) +- Add experimental support for directory targets (#3316, #5025, Andrey Mokhov), + enabled via `(using directory-targets 0.1)` in `dune-project`. + 2.9.2 (unreleased) ------------------ diff --git a/bin/exec.ml b/bin/exec.ml index 0737e48a906..1e0f1fb400d 100644 --- a/bin/exec.ml +++ b/bin/exec.ml @@ -73,9 +73,12 @@ let term = let open Memo.Build.O in let+ hints = (* Good candidates for the "./x.exe" instead of "x.exe" error are - executables present in the current directory *) + executables present in the current directory. Note: we do not check + directory targets here; even if they do indeed include a matching + executable, they would be located in a subdirectory of [dir], so + it's unclear if that's what the user wanted. *) let+ candidates = - Build_system.targets_of ~dir:(Path.build dir) + Build_system.file_targets_of ~dir:(Path.build dir) >>| Path.Set.to_list >>| List.filter ~f:(fun p -> Path.extension p = ".exe") >>| List.map ~f:(fun p -> "./" ^ Path.basename p) diff --git a/bin/print_rules.ml b/bin/print_rules.ml index 9d3a60144d2..6e38377b5c4 100644 --- a/bin/print_rules.ml +++ b/bin/print_rules.ml @@ -34,11 +34,16 @@ let print_rule_makefile ppf (rule : Dune_engine.Reflection.Rule.t) = ; Action.for_shell rule.action ] in + (* Makefiles seem to allow directory targets, so we include them. *) + let targets = + Dune_engine.Targets.map rule.targets ~f:(fun ~files ~dirs -> + Path.Build.Set.union files dirs) + in Format.fprintf ppf "@[@{%a:%t@}@]@,@<0>\t@{%a@}@,@," (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf p -> Format.pp_print_string ppf (Path.to_string p))) - (Targets.to_list_map rule.targets ~file:Path.build) + (List.map ~f:Path.build (Path.Build.Set.to_list targets)) (fun ppf -> Path.Set.iter rule.expanded_deps ~f:(fun dep -> Format.fprintf ppf "@ %s" (Path.to_string dep))) @@ -49,13 +54,24 @@ let print_rule_sexp ppf (rule : Dune_engine.Reflection.Rule.t) = Action.for_shell action |> Action.For_shell.encode in let paths ps = Dune_lang.Encoder.list Dpath.encode (Path.Set.to_list ps) in + let file_targets = + Dune_engine.Targets.map rule.targets ~f:(fun ~files ~dirs -> + if not (Path.Build.Set.is_empty dirs) then + User_error.raise + [ Pp.text + "Printing rules with directory targets is currently not \ + supported" + ]; + + files) + in let sexp = Dune_lang.Encoder.record (List.concat [ [ ("deps", Dep.Set.encode rule.deps) ; ( "targets" , paths - (Targets.to_list_map rule.targets ~file:Fun.id + (Path.Build.Set.to_list file_targets |> Path.set_of_build_paths_list) ) ] ; (match rule.context with diff --git a/bin/target.ml b/bin/target.ml index 40c136ce5a8..957ec9e3c57 100644 --- a/bin/target.ml +++ b/bin/target.ml @@ -21,6 +21,14 @@ let target_hint (_setup : Dune_rules.Main.build_system) path = assert (Path.is_managed path); let open Memo.Build.O in let sub_dir = Option.value ~default:path (Path.parent path) in + (* CR-someday amokhov: There are two issues with the code below. + + (1) We first get *all* targets but then filter out only those that are + defined in the [sub_dir]. It would be better to just get the targets for + the [sub_dir] directly (the API supports this). + + (2) We currently provide the same hint for all targets. It would be nice to + indicate whether a hint corresponds to a file or to a directory target. *) let+ candidates = Build_system.all_targets () >>| Path.Build.Set.to_list in let candidates = if Path.is_in_build_dir path then diff --git a/doc/dune-files.rst b/doc/dune-files.rst index 7e779025d77..e1fa96e656f 100644 --- a/doc/dune-files.rst +++ b/doc/dune-files.rst @@ -32,7 +32,7 @@ adding a line in the ``dune-project`` file, such as: (using ) Here, ```` is the name of the plugin that -defines this stanza and ```` describes the configuration language's version. +defines this stanza and ```` describes the configuration language's version. Note that this version has nothing to do with the version of the associated tool or library. In particular, adding a ``using`` stanza will not result in a build dependency in the generated ``.opam`` file. See @@ -74,7 +74,7 @@ Where status is either ``enabled`` or ``disabled``. implicit_transitive_deps ------------------------ -By default, Dune allows transitive dependencies of dependencies used +By default, Dune allows transitive dependencies of dependencies used when compiling OCaml; however, this setting can be controlled per project: @@ -108,7 +108,7 @@ dependency on ``foo`` as re-exported: wrapped_executables ------------------- -Executables are made of compilation units whose names may collide with libraries' +Executables are made of compilation units whose names may collide with libraries' compilation units. To avoid this possibility, Dune prefixes these compilation unit names with ``Dune__exe__``. This is entirely transparent to users except when such executables are debugged. In which case, the mangled @@ -218,8 +218,8 @@ way to specify custom file extensions for OCaml code. ```` is the name of the dialect being defined. It must be unique in a given project. -For interfaces and implementations, ``(extension )`` specifies the file extension used for this dialect. -The extension string must not contain any dots +For interfaces and implementations, ``(extension )`` specifies the file extension used for this dialect. +The extension string must not contain any dots and be unique in a given project (so that a given extension can be mapped back to a corresponding dialect). @@ -386,7 +386,7 @@ accept_alternative_dune_file_name Since Dune 3.0, it's possible to use the alternative filename ``dune-file`` instead of ``dune`` to specify the build. This may be useful to avoid problems -with ``dune`` files that have the executable permission in a directory +with ``dune`` files that have the executable permission in a directory in the ``PATH``, which can unwittingly happen in Windows. The feature must be enabled explicitly by adding the following field to @@ -453,7 +453,7 @@ module name, but it doesn't need to start with an uppercase letter. For instance, the modules of a library named ``foo`` will be available as ``Foo.XXX``, outside of ``foo`` itself; however, it is -allowed to write an explicit ``Foo`` module, which will +allowed to write an explicit ``Foo`` module, which will be the library interface. You are free to expose only the modules you want. @@ -474,7 +474,7 @@ to use the :ref:`include_subdirs` stanza. - ``(package )`` installs a private library under the specified package. Such a library is now usable by public libraries defined in the same project. - + ======= The Findlib name for this library will be ``.__private__.``; however, the library's interface will be hidden from consumers outside the @@ -487,12 +487,12 @@ to use the :ref:`include_subdirs` stanza. default, Dune will use all the ``.ml/.re`` files in the same directory as the ``dune`` file. This includes ones present in the file system as well as ones generated by user rules. You can restrict this list by using a - ``(modules )`` field. ```` uses the :ref:`ordered-set-language`, + ``(modules )`` field. ```` uses the :ref:`ordered-set-language`, where elements are module names and don't need to start with an uppercase letter. For instance, to exclude module ``Foo``, use ``(modules (:standard \ foo))`` -- ``(libraries )`` specifies the library's dependencies. +- ``(libraries )`` specifies the library's dependencies. See the section about :ref:`library-deps` for more details. - ``(wrapped )`` specifies whether the library modules should be @@ -504,18 +504,18 @@ to use the :ref:`include_subdirs` stanza. only intended for libraries that manually prefix all their modules by the library name and to ease porting of existing projects to Dune. -- ``(wrapped (transition ))`` is the same as ``(wrapped true)``, except +- ``(wrapped (transition ))`` is the same as ``(wrapped true)``, except it will also generate unwrapped (not prefixed by the library name) modules to preserve compatibility. This is useful for libraries that would like to transition from ``(wrapped false)`` to ``(wrapped true)`` without - breaking compatibility for users. The deprecation notices for the unwrapped + breaking compatibility for users. The deprecation notices for the unwrapped modules will include ````. - ``(preprocess )`` specifies how to preprocess files when needed. The default is ``no_preprocessing``, and other options are described in the :ref:`preprocessing-spec` section. -- ``(preprocessor_deps ())`` specifies extra preprocessor dependencies +- ``(preprocessor_deps ())`` specifies extra preprocessor dependencies preprocessor, i.e., if the preprocessor reads a generated file. The specification of dependencies is described in the :ref:`deps-field` section. @@ -533,7 +533,7 @@ to use the :ref:`include_subdirs` stanza. - ``(foreign_archives )`` specifies archives of foreign object files to be packaged with the library. See the section - :ref:`foreign-archives` for more details. This field replaces the now-deleted + :ref:`foreign-archives` for more details. This field replaces the now-deleted field ``self_build_stubs_archive``. - ``(install_c_headers ())`` - if your library has public C header files @@ -576,7 +576,7 @@ to use the :ref:`include_subdirs` stanza. - For ``flags``, ``ocamlc_flags``, and ``ocamlopt_flags``, see the section about :ref:`ocaml-flags` -- ``(library_flags ())`` is a list of flags passed to +- ``(library_flags ())`` is a list of flags passed to ``ocamlc`` and ``ocamlopt`` when building the library archive files. You can use this to specify ``-linkall``, for instance. ```` is a list of strings supporting :ref:`variables`. @@ -593,7 +593,7 @@ to use the :ref:`include_subdirs` stanza. ``.re`` file. Such modules are usually referred as *mli only modules*. They are not officially supported by the OCaml compiler, however they are commonly used. Such modules must only define - types. Since it isn't reasonably possible for Dune to check + types. Since it isn't reasonably possible for Dune to check this is the case, Dune requires the user to explicitly list such modules to avoid surprises. Note that the ``modules_without_implementation`` field isn't merged in ``modules``, which @@ -698,7 +698,7 @@ that it's not necessary for the new name to exist at definition time, as it is only resolved at the point where the old name is used. The ``old_public_name`` can also be one of the names declared in the -``deprecated_package_names`` field of the package declaration in the +``deprecated_package_names`` field of the package declaration in the ``dune-project`` file. In this case, the "old" library is understood to be a library whose name is not prefixed by the package name. Such a library cannot be defined in Dune, but other build systems allow it. This feature is meant to @@ -718,13 +718,13 @@ format of executable stanzas is as follows: (name ) ) -```` is a module name that contains the executable's main entry point. +```` is a module name that contains the executable's main entry point. There can be additional modules in the current directory; you only need to specify the entry point. Given an ``executable`` stanza with ``(name )``, Dune will know how to build ``.exe``. If requested, it will also know how to build ``.bc`` and ``.bc.js`` (Dune 2.0 and up also need specific -configuration (see the ``modes`` optional field below). +configuration (see the ``modes`` optional field below). ``.exe`` is a native code executable, ``.bc`` is a bytecode executable which requires ``ocamlrun`` to run, and ``.bc.js`` is a JavaScript @@ -874,7 +874,7 @@ compilation isn't available. - ``plugin`` for producing a plugin (``.cmxs`` if native or ``.cma`` if bytecode). -For instance the following ``executables`` stanza will produce bytecode +For instance the following ``executables`` stanza will produce bytecode executables and native shared objects: .. code:: scheme @@ -929,14 +929,14 @@ js .bc.js =========================== ================= ``%{ext_obj}`` and ``%{ext_dll}`` are the extensions for object -and shared object files. Their value depends on the OS. For instance, +and shared object files. Their value depends on the OS. For instance, on Unix ``%{ext_obj}`` is usually ``.o`` and ``%{ext_dll}`` is usually ``.so``, while on Windows ``%{ext_obj}`` is ``.obj`` and ``%{ext_dll}`` is ``.dll``. Up to version 3.0 of the Dune language, when ``byte`` is specified but none of ``native``, ``exe``, or ``byte_complete`` are specified, Dune -implicitly adds a linking mode that's the same as ``byte_complete``, +implicitly adds a linking mode that's the same as ``byte_complete``, but it uses the extension ``.exe``. ``.bc`` files require addition al files at runtime that aren't currently tracked by Dune, so don't run ``.bc`` files during the build. Run the ``.bc.exe`` or @@ -948,20 +948,20 @@ executable contains C stubs you may want to use ``(modes exe)``. executables ----------- -There is a very subtle difference in the naming of these stanzas. One is -``executables``, plural, and the other is ``executable``, singular. +There is a very subtle difference in the naming of these stanzas. One is +``executables``, plural, and the other is ``executable``, singular. The ``executables`` stanza is the same as the ``executable`` stanza except that -it's used to describe several executables sharing the same configuration, so the +it's used to describe several executables sharing the same configuration, so the plura ``executables`` stanza is used to describe more than one executable. It shares the same fields as the ``executable`` stanza, except that instead of ``(name ...)`` and ``(public_name ...)`` you must use the plural versions as well: -- ``(names )`` where ```` is a list of entry point names. Compare with +- ``(names )`` where ```` is a list of entry point names. Compare with ``executable`` where you only need to specify the modules containing the entry point of each executable. -- ``(public_names )`` describes under what name to install each executable. +- ``(public_names )`` describes under what name to install each executable. The list of names must be of the same length as the list in the ``(names ...)`` field. Moreover, you can use ``-`` for executables that shouldn't be installed. @@ -982,9 +982,15 @@ The syntax is as follows: ) ```` is a list of filenames (if defined with ``targets``) -or exactly one filename (if defined with ``target``). Note that at this time, -Dune only supports user rules with targets in the current -directory. +or exactly one filename (if defined with ``target``). Note that at this time, +Dune officially only supports user rules with targets in the current directory. +However, starting from Dune 3.0, we provide an experimental support for +*directory targets*, where an action can produce a whole tree of build +artifacts. To specify a directory target, you can use the ``/*`` +syntax, i.e., a directory name followed by a forward slash and a star. To +enable this experimental feature, add ``(using directory-targets 0.1)`` to +your ``dune-project`` file. + ```` is what you run to produce the targets from the dependencies. See the :ref:`user-actions` section for more details. @@ -1019,15 +1025,15 @@ given ``%``. This might be supported in the future. modes ~~~~~ -By default, a rule's target must not exist in the source tree because -Dune will error out when this is the case; however, it's possible to change +By default, a rule's target must not exist in the source tree because +Dune will error out when this is the case; however, it's possible to change this behavior using the ``mode`` field. The following modes are available: - ``standard`` - the standard mode. - ``fallback`` - in this mode, when the targets are already present in the source tree, Dune will ignore the rule. It's an error if - only a subset of the targets are present in the tree. Fallback rules are + only a subset of the targets are present in the tree. Fallback rules are commonly used to generate default configuration files that may be generated by a configure script. @@ -1035,7 +1041,7 @@ this behavior using the ``mode`` field. The following modes are available: - ``promote`` or ``(promote )`` - in this mode, the files in the source tree will be ignored. Once the rule has been executed, - the targets will be copied back to the source tree. + the targets will be copied back to the source tree. The following options are available: - ``(until-clean)`` means that ``dune clean`` will remove the promoted files @@ -1044,7 +1050,7 @@ this behavior using the ``mode`` field. The following modes are available: the current directory. This feature has been available since Dune 1.8. - ``(only )`` means that only a subset of the targets should be promoted. The argument is similar to the argument of :ref:`(dirs ...) - `, specified using the :ref:`predicate-lang`. This feature + `, specified using the :ref:`predicate-lang`. This feature has been available since Dune 1.10. - ``promote-until-clean`` is the same as ``(promote (until-clean))``. @@ -1070,7 +1076,7 @@ a subset of their targets via ``(only ...)`` are never ignored. Inferred Rules ~~~~~~~~~~~~~~ -When using the action DSL (see :ref:`user-actions`), the dependencies +When using the action DSL (see :ref:`user-actions`), the dependencies and targets are usually obvious. For instance: @@ -1082,7 +1088,7 @@ For instance: (deps a) (action (copy %{deps} %{target}))) -In this example, the dependencies and targets are obvious by inspecting +In this example, the dependencies and targets are obvious by inspecting the action. When this is the case, you can use the following shorter syntax and have Dune infer dependencies and targets for you: @@ -1220,7 +1226,7 @@ Where ```` are: stanza. - ``(mld_files )``: the ```` field follows the - :ref:`ordered-set-language`. This is a set of extensionless MLD file basenames + :ref:`ordered-set-language`. This is a set of extensionless MLD file basenames attached to the package, where ``:standard`` refers to all the ``.mld`` files in the stanza's directory. @@ -1253,7 +1259,7 @@ The syntax is as follows: ```` are: - ````, an action for constructing the alias. See the - :ref:`user-actions` section for more details. Note that this is removed in Dune + :ref:`user-actions` section for more details. Note that this is removed in Dune 2.0, so users must port their code to use the ``rule`` stanza with the ``alias`` field instead. @@ -1359,7 +1365,7 @@ installed with this extension on Windows. More precisely, when installing a file via an ``(install ...)`` stanza, Dune implicitly adds the ``.exe`` extension to the destination, -if the source file has extension ``.exe`` or ``.bc`` and if it's not +if the source file has extension ``.exe`` or ``.bc`` and if it's not already present copy_files @@ -1572,7 +1578,7 @@ Examples: (dirs :standard \ ocaml) ;; include all directories except ocaml (dirs :standard \ test* foo*) ;; exclude all directories that start with test or foo -Dune will not scan a directory that isn't included in this stanza. +Dune will not scan a directory that isn't included in this stanza. Any contained Dune (or other special) files won't be interpreted either and will be treated as raw data. It is however possible to depend on files inside ignored subdirectories. @@ -1637,7 +1643,7 @@ Example: (vendored_dirs vendor) -Dune will not resolve aliases in vendored directories. By default, it won't +Dune will not resolve aliases in vendored directories. By default, it won't build all installable targets, run the tests, format, or lint the code located in such a directory while still building your project's dependencies. Libraries and executables in vendored directories will also be built with a ``-w @@ -1663,7 +1669,7 @@ Where ```` maybe be one of: When the ``include_subdirs`` stanza isn't present or ```` is ``no``, Dune considers subdirectories independent. When ```` -is ``unqualified``, Dune will assume that the current directory's +is ``unqualified``, Dune will assume that the current directory's subdirectories are part of the same group of directories. In particular, Dune will simultaneously scan all these directories when looking for OCaml/Reason files. This allows you to split a library between @@ -1820,8 +1826,8 @@ The stanza will build all ``.v`` files on the given directory. The semantics of ``-native-compiler on`` to Coq and install the corresponding object files under ``.coq-native``, when in ``release`` profile. The regular ``dev`` profile will skip native compilation to make the build - faster, available since Coq v0.3. - + faster, available since Coq v0.3. + Please note: support for native compute is **experimental**, and requires Coq >= 8.12.1; moreover, depending libraries *must* be built with ``(mode native)`` for this to work. Also, Coq must be configured to support native @@ -1963,7 +1969,7 @@ Upgrading from Version 0.1 - The 0.2 version of the stanza requires at least MDX 1.9.0. If you encounter an error such as, ``ocaml-mdx: unknown command `dune-gen'``, then you should - upgrade MDX. + upgrade MDX. - The field ``(packages )`` is deprecated in version 0.2. You can use package items in the generic ``deps`` field instead: @@ -2180,14 +2186,14 @@ context, or it can be the description of an Opam switch, as follows: automatically from the default name and ````, unless explicitly specified using the ``(name ...)`` field. For example, if ```` is *src/foo.exe* in a default context, then the - name of the context is *default-fdo-foo* and the filename + name of the context is *default-fdo-foo* and the filename that contains execution counters is *src/fdo.exe.fdo-profile*. This feature is **experimental** and no backwards compatibility is implied. - By default, Dune builds and installs dynamically-linked foreign archives (usually named ``dll*.so``). It's possible to disable - this by setting by including + this by setting by including ``(disable_dynamically_linked_foreign_archives true)`` in the workspace file, so bytecode executables will be built with all foreign archives statically linked into the runtime system. diff --git a/otherlibs/stdune-unstable/path.ml b/otherlibs/stdune-unstable/path.ml index e61b6f663dc..d905754ac1d 100644 --- a/otherlibs/stdune-unstable/path.ml +++ b/otherlibs/stdune-unstable/path.ml @@ -686,6 +686,13 @@ module Build = struct | None -> Code_error.raise "Path.Build.drop_build_context_exn" [ ("t", to_dyn t) ] + let drop_build_context_maybe_sandboxed_exn t = + match extract_build_context_dir_maybe_sandboxed t with + | Some (_, t) -> t + | None -> + Code_error.raise "Path.Build.drop_build_context_maybe_sandboxed_exn" + [ ("t", to_dyn t) ] + let build_dir = Fdecl.create Kind.to_dyn let build_dir_prefix = Fdecl.create Dyn.Encoder.opaque diff --git a/otherlibs/stdune-unstable/path.mli b/otherlibs/stdune-unstable/path.mli index 2346a557502..928ce3c40f8 100644 --- a/otherlibs/stdune-unstable/path.mli +++ b/otherlibs/stdune-unstable/path.mli @@ -156,6 +156,8 @@ module Build : sig val drop_build_context_exn : t -> Source.t + val drop_build_context_maybe_sandboxed_exn : t -> Source.t + (** [Source.t] here is a lie in some cases: consider when the context name happens to be ["install"] or [".alias"]. *) val extract_build_context : t -> (string * Source.t) option diff --git a/src/dune_engine/action_exec.ml b/src/dune_engine/action_exec.ml index 47a0ff02653..32c27eeb121 100644 --- a/src/dune_engine/action_exec.ml +++ b/src/dune_engine/action_exec.ml @@ -127,7 +127,15 @@ let exec_run_dynamic_client ~ectx ~eenv prog args = let to_relative path = path |> Stdune.Path.build |> Stdune.Path.reach ~from:eenv.working_dir in - Targets.to_list_map ectx.targets ~file:to_relative |> String.Set.of_list + let file_targets, (_dir_targets_not_allowed : Nothing.t list) = + Targets.partition_map ectx.targets ~file:to_relative + ~dir:(fun _dir_target -> + User_error.raise ~loc:ectx.rule_loc + [ Pp.text + "Directory targets are not compatible with dynamic actions" + ]) + in + String.Set.of_list file_targets in DAP.Run_arguments. { prepared_dependencies = eenv.prepared_dependencies; targets } diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 65a66c78223..32f8c9505e1 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -119,10 +119,20 @@ end let files_in_source_tree_to_delete () = Promoted_to_delete.get_db () module Loaded = struct + type rules_here = + { by_file_targets : Rule.t Path.Build.Map.t + ; by_directory_targets : Rule.t Path.Build.Map.t + } + + let no_rules_here = + { by_file_targets = Path.Build.Map.empty + ; by_directory_targets = Path.Build.Map.empty + } + type build = { allowed_subdirs : Path.Unspecified.w Dir_set.t ; rules_produced : Rules.t - ; rules_here : Rule.t Path.Build.Map.t + ; rules_here : rules_here ; aliases : (Loc.t * Rules.Dir_rules.Alias_spec.item) list Alias.Name.Map.t } @@ -134,7 +144,7 @@ module Loaded = struct Build { allowed_subdirs ; rules_produced = Rules.empty - ; rules_here = Path.Build.Map.empty + ; rules_here = no_rules_here ; aliases = Alias.Name.Map.empty } end @@ -507,6 +517,8 @@ let report_rule_conflict fn (rule' : Rule.t) (rule : Rule.t) = ] | _ -> []) +(* CR-someday amokhov: Clean up pending directory targets too? *) + (* This contains the targets of the actions that are being executed. On exit, we need to delete them as they might contain garbage. *) let pending_targets = ref Path.Build.Set.empty @@ -520,13 +532,15 @@ let () = Path.Build.Set.iter fns ~f:(fun p -> Path.unlink_no_err (Path.build p))) let compute_target_digests targets = - Option.List.traverse (Targets.to_list_map targets ~file:Fun.id) - ~f:(fun target -> + let file_targets, (_ignored_dir_targets : unit list) = + Targets.partition_map targets ~file:Fun.id ~dir:ignore + in + Option.List.traverse file_targets ~f:(fun target -> Cached_digest.build_file target |> Cached_digest.Digest_result.to_option |> Option.map ~f:(fun digest -> (target, digest))) -let compute_target_digests_or_raise_error exec_params ~loc targets = +let compute_target_digests_or_raise_error exec_params ~loc file_targets = let remove_write_permissions = (* Remove write permissions on targets. A first theoretical reason is that the build process should be a computational graph and targets should not @@ -536,57 +550,58 @@ let compute_target_digests_or_raise_error exec_params ~loc targets = (* FIXME: searching the dune version for each single target seems way suboptimal. This information could probably be stored in rules directly. *) - if Targets.is_empty targets then + if Path.Build.Set.is_empty file_targets then false else Execution_parameters.should_remove_write_permissions_on_generated_files exec_params in let good, missing, errors = - Targets.fold targets ~init:([], [], []) - ~file:(fun target (good, missing, errors) -> - let expected_syscall_path = Path.to_string (Path.build target) in - match Cached_digest.refresh ~remove_write_permissions target with - | Ok digest -> ((target, digest) :: good, missing, errors) - | No_such_file -> (good, target :: missing, errors) - | Broken_symlink -> - let error = [ Pp.verbatim "Broken symlink" ] in - (good, missing, (target, error) :: errors) - | Unexpected_kind file_kind -> - let error = + let process_target target (good, missing, errors) = + let expected_syscall_path = Path.to_string (Path.build target) in + match Cached_digest.refresh ~remove_write_permissions target with + | Ok digest -> ((target, digest) :: good, missing, errors) + | No_such_file -> (good, target :: missing, errors) + | Broken_symlink -> + let error = [ Pp.verbatim "Broken symlink" ] in + (good, missing, (target, error) :: errors) + | Unexpected_kind file_kind -> + let error = + [ Pp.verbatim + (sprintf "Unexpected file kind %S (%s)" + (File_kind.to_string file_kind) + (File_kind.to_string_hum file_kind)) + ] + in + (good, missing, (target, error) :: errors) + | Unix_error (error, syscall, path) -> + let error = + [ (if String.equal expected_syscall_path path then + Pp.verbatim syscall + else + Pp.concat + [ Pp.verbatim syscall + ; Pp.verbatim " " + ; Pp.verbatim (String.maybe_quoted path) + ]) + ; Pp.text (Unix.error_message error) + ] + in + (good, missing, (target, error) :: errors) + | Error exn -> + let error = + match exn with + | Sys_error msg -> [ Pp.verbatim - (sprintf "Unexpected file kind %S (%s)" - (File_kind.to_string file_kind) - (File_kind.to_string_hum file_kind)) + (String.drop_prefix_if_exists + ~prefix:(expected_syscall_path ^ ": ") + msg) ] - in - (good, missing, (target, error) :: errors) - | Unix_error (error, syscall, path) -> - let error = - [ (if String.equal expected_syscall_path path then - Pp.verbatim syscall - else - Pp.concat - [ Pp.verbatim syscall - ; Pp.verbatim " " - ; Pp.verbatim (String.maybe_quoted path) - ]) - ; Pp.text (Unix.error_message error) - ] - in - (good, missing, (target, error) :: errors) - | Error exn -> - let error = - match exn with - | Sys_error msg -> - [ Pp.verbatim - (String.drop_prefix_if_exists - ~prefix:(expected_syscall_path ^ ": ") - msg) - ] - | exn -> [ Pp.verbatim (Printexc.to_string exn) ] - in - (good, missing, (target, error) :: errors)) + | exn -> [ Pp.verbatim (Printexc.to_string exn) ] + in + (good, missing, (target, error) :: errors) + in + Path.Build.Set.fold file_targets ~init:([], [], []) ~f:process_target in match (missing, errors) with | [], [] -> List.rev good @@ -623,7 +638,10 @@ let remove_old_artifacts ~dir ~rules_here ~(subdirs_to_keep : Subdir_set.t) = | Ok files -> List.iter files ~f:(fun (fn, kind) -> let path = Path.Build.relative dir fn in - let path_is_a_target = Path.Build.Map.mem rules_here path in + let path_is_a_target = + (* CR-someday amokhov: Also check directory targets. *) + Path.Build.Map.mem rules_here.Loaded.by_file_targets path + in if not path_is_a_target then match kind with | Unix.S_DIR -> ( @@ -742,7 +760,9 @@ module rec Load_rules : sig val file_exists : Path.t -> bool Memo.Build.t - val targets_of : dir:Path.t -> Path.Set.t Memo.Build.t + val file_targets_of : dir:Path.t -> Path.Set.t Memo.Build.t + + val directory_targets_of : dir:Path.t -> Path.Set.t Memo.Build.t val lookup_alias : Alias.t @@ -778,14 +798,29 @@ end = struct build) let compile_rules ~dir ~source_dirs rules = - List.concat_map rules ~f:(fun rule -> - assert (Path.Build.( = ) dir rule.Rule.dir); - Targets.to_list_map rule.targets ~file:(fun target -> - if String.Set.mem source_dirs (Path.Build.basename target) then - report_rule_src_dir_conflict dir target rule - else - (target, rule))) - |> Path.Build.Map.of_list_reducei ~f:report_rule_conflict + let file_targets, directory_targets = + List.map rules ~f:(fun rule -> + assert (Path.Build.( = ) dir rule.Rule.dir); + Targets.partition_map rule.targets + ~file:(fun target -> + if String.Set.mem source_dirs (Path.Build.basename target) then + report_rule_src_dir_conflict dir target rule + else + (target, rule)) + ~dir:(fun target -> (target, rule))) + |> List.unzip + in + (* CR-someday amokhov: Report rule conflicts for all targets rather than + doing it separately for files and directories. *) + let by_file_targets = + List.concat file_targets + |> Path.Build.Map.of_list_reducei ~f:report_rule_conflict + in + let by_directory_targets = + List.concat directory_targets + |> Path.Build.Map.of_list_reducei ~f:report_rule_conflict + in + { Loaded.by_file_targets; by_directory_targets } (* Here we are doing a O(log |S|) lookup in a set S of files in the build directory [dir]. We could memoize these lookups, but it doesn't seem to be @@ -801,13 +836,28 @@ end = struct | Build { rules_here; _ } -> ( match Path.as_in_build_dir fn with | None -> false - | Some fn -> Path.Build.Map.mem rules_here fn) + | Some fn -> ( + match Path.Build.Map.mem rules_here.by_file_targets fn with + | true -> true + | false -> ( + match Path.Build.parent fn with + | None -> false + | Some dir -> Path.Build.Map.mem rules_here.by_directory_targets dir)) + ) - let targets_of ~dir = + let file_targets_of ~dir = load_dir ~dir >>| function - | Non_build targets -> targets + | Non_build file_targets -> file_targets | Build { rules_here; _ } -> - Path.Build.Map.keys rules_here |> Path.Set.of_list_map ~f:Path.build + Path.Build.Map.keys rules_here.by_file_targets + |> Path.Set.of_list_map ~f:Path.build + + let directory_targets_of ~dir = + load_dir ~dir >>| function + | Non_build _file_targets -> Path.Set.empty + | Build { rules_here; _ } -> + Path.Build.Map.keys rules_here.by_directory_targets + |> Path.Set.of_list_map ~f:Path.build let lookup_alias alias = load_dir ~dir:(Path.build (Alias.dir alias)) >>| function @@ -852,9 +902,14 @@ end = struct (* All targets are in [dir] and we know it correspond to a directory of a build context since there are source files to copy, so this call can't fail. *) - Targets.to_list_map rule.targets - ~file:Path.Build.drop_build_context_exn - |> Path.Source.Set.of_list + let file_targets, (_dir_targets_not_allowed : Nothing.t list) = + Targets.partition_map rule.targets + ~file:Path.Build.drop_build_context_exn ~dir:(fun dir -> + Code_error.raise + "Unexpected directory target in a Fallback rule" + [ ("dir", Dyn.String (Path.Build.to_string dir)) ]) + in + Path.Source.Set.of_list file_targets in if Path.Source.Set.is_subset source_files_for_targets ~of_:to_copy then @@ -970,6 +1025,7 @@ end = struct in source_files_to_ignore + (* Returns only [Loaded.Build] variant. *) let load_dir_step2_exn t ~dir = let context_name, sub_dir = match Dpath.analyse_path dir with @@ -1018,20 +1074,38 @@ end = struct copied *) let source_files_to_ignore = List.fold_left rules ~init:Path.Build.Set.empty - ~f:(fun acc_ignored { Rule.targets; mode; _ } -> + ~f:(fun acc_ignored { Rule.targets; mode; loc; _ } -> + (* CR-someday amokhov: Remove this limitation. *) + let directory_targets_not_supported ~dirs = + if not (Path.Build.Set.is_empty dirs) then + User_error.raise ~loc + [ Pp.text "Directory targets are not supported for this mode" ] + in match mode with | Promote { only = None; _ } | Ignore_source_files -> - Path.Build.Set.union (Targets.files targets) acc_ignored + let file_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + directory_targets_not_supported ~dirs; + files) + in + Path.Build.Set.union file_targets acc_ignored | Promote { only = Some pred; _ } -> + let file_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + directory_targets_not_supported ~dirs; + files) + in let to_ignore = - Path.Build.Set.filter (Targets.files targets) ~f:(fun target -> + Path.Build.Set.filter file_targets ~f:(fun target -> Predicate_lang.Glob.exec pred (Path.reach (Path.build target) ~from:(Path.build dir)) ~standard:Predicate_lang.any) in Path.Build.Set.union to_ignore acc_ignored - | _ -> acc_ignored) + | Standard + | Fallback -> + acc_ignored) in let source_files_to_ignore = Path.Build.Set.to_list source_files_to_ignore @@ -1159,32 +1233,52 @@ open Load_rules let load_dir_and_get_buildable_targets ~dir = load_dir ~dir >>| function - | Non_build _ -> Path.Build.Map.empty + | Non_build _ -> Loaded.no_rules_here | Build { rules_here; _ } -> rules_here -let get_rule fn = - match Path.as_in_build_dir fn with - | None -> Memo.Build.return None - | Some fn -> ( - let dir = Path.Build.parent_exn fn in - load_dir ~dir:(Path.build dir) >>| function - | Non_build _ -> assert false - | Build { rules_here; _ } -> Path.Build.Map.find rules_here fn) - type rule_or_source = | Source of Digest.t | Rule of Path.Build.t * Rule.t +let get_rule_for_directory_target path = + let rec loop dir = + match Path.Build.parent dir with + | None -> Memo.Build.return None + | Some parent_dir -> ( + let* rules = + load_dir_and_get_buildable_targets ~dir:(Path.build parent_dir) + in + match Path.Build.Map.find rules.by_directory_targets dir with + | None -> loop parent_dir + | Some _ as rule -> Memo.Build.return rule) + in + loop path + +let get_rule path = + match Path.as_in_build_dir path with + | None -> Memo.Build.return None + | Some path -> ( + let dir = Path.Build.parent_exn path in + load_dir ~dir:(Path.build dir) >>= function + | Non_build _ -> assert false + | Build { rules_here; _ } -> ( + match Path.Build.Map.find rules_here.by_file_targets path with + | Some _ as rule -> Memo.Build.return rule + | None -> get_rule_for_directory_target path)) + let get_rule_or_source t path = let dir = Path.parent_exn path in if Path.is_strict_descendant_of_build_dir dir then let* rules = load_dir_and_get_buildable_targets ~dir in let path = Path.as_in_build_dir_exn path in - match Path.Build.Map.find rules path with + match Path.Build.Map.find rules.by_file_targets path with | Some rule -> Memo.Build.return (Rule (path, rule)) - | None -> - let* loc = Rule_fn.loc () in - no_rule_found t ~loc path + | None -> ( + get_rule_for_directory_target path >>= function + | Some rule -> Memo.Build.return (Rule (path, rule)) + | None -> + let* loc = Rule_fn.loc () in + no_rule_found t ~loc path) else let+ d = source_file_digest path in Source d @@ -1206,7 +1300,9 @@ let all_targets t = >>| function | Non_build _ -> Path.Build.Set.empty | Build { rules_here; _ } -> - Path.Build.Set.of_list (Path.Build.Map.keys rules_here))) + Path.Build.Set.of_list + (Path.Build.Map.keys rules_here.by_file_targets + @ Path.Build.Map.keys rules_here.by_directory_targets))) >>| Path.Build.Set.union_all let get_alias_definition alias = @@ -1230,6 +1326,8 @@ module type Rec = sig val build_file : Path.t -> Digest.t Memo.Build.t + val build_dir : Path.t -> (Digest.t * Digest.t Path.Build.Map.t) Memo.Build.t + val build_deps : Dep.Set.t -> Dep.Facts.t Memo.Build.t val eval_deps : @@ -1252,6 +1350,26 @@ module type Rec = sig end end +let is_target file = + match Path.is_in_build_dir file with + | false -> Memo.Build.return false + | true -> ( + let parent_dir = Path.parent_exn file in + let* file_targets = file_targets_of ~dir:parent_dir in + match Path.Set.mem file_targets file with + | true -> Memo.Build.return true + | false -> + let rec loop dir = + match Path.parent dir with + | None -> Memo.Build.return false + | Some parent_dir -> ( + let* directory_targets = directory_targets_of ~dir:parent_dir in + match Path.Set.mem directory_targets dir with + | true -> Memo.Build.return true + | false -> loop parent_dir) + in + loop file) + (* Separation between [Used_recursively] and [Exported] is necessary because at least one module in the recursive module group must be pure (i.e. only expose functions). *) @@ -1265,7 +1383,9 @@ and Exported : sig (* The below two definitions are useless, but if we remove them we get an "Undefined_recursive_module" exception. *) - val build_file_memo : (Path.t, Digest.t) Memo.t [@@warning "-32"] + val build_file_memo : + (Path.t, Import.Digest.t * Import.Digest.t Path.Build.Map.t option) Memo.t + [@@warning "-32"] val build_alias_memo : (Alias.t, Dep.Fact.Files.t) Memo.t [@@warning "-32"] @@ -1279,8 +1399,7 @@ end = struct let build_dep : Dep.t -> Dep.Fact.t Memo.Build.t = function | Alias a -> let+ digests = build_alias a in - (* Fact: alias [a] expand to the set of files with their digest - [digests] *) + (* Fact: alias [a] expands to the set of file-digest pairs [digests] *) Dep.Fact.alias a digests | File f -> let+ digest = build_file f in @@ -1288,8 +1407,8 @@ end = struct Dep.Fact.file f digest | File_selector g -> let+ digests = Pred.build g in - (* Fact: file selector [g] expands to the set of files with their digest - [digests] *) + (* Fact: file selector [g] expands to the set of file- and (possibly) + dir-digest pairs [digests] *) Dep.Fact.file_selector g digests | Universe | Env _ @@ -1360,10 +1479,14 @@ end = struct let compute_rule_digest (rule : Rule.t) ~deps ~action ~sandbox_mode ~execution_parameters = let { Action.Full.action; env; locks; can_go_in_shared_cache } = action in + let file_targets, dir_targets = + Targets.partition_map rule.targets ~file:Path.Build.to_string + ~dir:Path.Build.to_string + in let trace = ( rule_digest_version (* Update when changing the rule digest scheme. *) , Dep.Facts.digest deps ~sandbox_mode ~env - , Targets.to_list_map rule.targets ~file:Path.Build.to_string + , file_targets @ dir_targets , Option.map rule.context ~f:(fun c -> Context_name.to_string c.name) , Action.for_shell action , can_go_in_shared_cache @@ -1425,14 +1548,24 @@ end = struct | Not_found_in_cache -> Miss Not_found_in_cache | Error exn -> Miss (Error (Printexc.to_string exn)) + module Exec_result = struct + type t = + { files_in_directory_targets : Path.Build.Set.t + ; action_exec_result : Action_exec.Exec_result.t + } + end + let execute_action_for_rule t ~rule_digest ~action ~deps ~loc ~(context : Build_context.t option) ~execution_parameters ~sandbox_mode ~dir ~targets = let open Fiber.O in + let file_targets, has_directory_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + (files, not (Path.Build.Set.is_empty dirs))) + in let { Action.Full.action; env; locks; can_go_in_shared_cache = _ } = action in - let file_targets = Targets.files targets in pending_targets := Path.Build.Set.union file_targets !pending_targets; let chdirs = Action.chdirs action in let sandbox = @@ -1444,7 +1577,15 @@ end = struct in let action = match sandbox with - | None -> action + | None -> + (* CR-someday amokhov: It may be possible to support directory targets + without sandboxing. We just need to make sure we clean up all stale + directory targets before running the rule and then we can discover + all created files right in the build directory. *) + if has_directory_targets then + User_error.raise ~loc + [ Pp.text "Rules with directory targets must be sandboxed." ]; + action | Some sandbox -> Action.sandbox action sandbox in let* () = @@ -1467,19 +1608,24 @@ end = struct in let+ exec_result = with_locks t locks ~f:(fun () -> - let+ exec_result = + let+ action_exec_result = Action_exec.exec ~root ~context ~env ~targets ~rule_loc:loc ~build_deps ~execution_parameters action in - Option.iter sandbox ~f:(Sandbox.move_targets_to_build_dir ~targets); - exec_result) + let files_in_directory_targets = + match sandbox with + | None -> Path.Build.Set.empty + | Some sandbox -> + Sandbox.move_targets_to_build_dir sandbox ~loc ~targets + in + { Exec_result.files_in_directory_targets; action_exec_result }) in Option.iter sandbox ~f:Sandbox.destroy; (* All went well, these targets are no longer pending *) pending_targets := Path.Build.Set.diff !pending_targets file_targets; exec_result - let try_to_store_to_shared_cache ~mode ~rule_digest ~action ~targets = + let try_to_store_to_shared_cache ~mode ~rule_digest ~action ~file_targets = let open Fiber.O in let hex = Digest.to_string rule_digest in let pp_error msg = @@ -1497,7 +1643,7 @@ end = struct Cached_digest.set target digest) in match - Targets.to_list_map targets ~file:Dune_cache.Local.Target.create + Path.Build.Set.to_list_map file_targets ~f:Dune_cache.Local.Target.create |> Option.List.all with | None -> Fiber.return None @@ -1624,7 +1770,6 @@ end = struct in wrap_fiber (fun () -> let open Fiber.O in - let build_deps deps = Memo.Build.run (build_deps deps) in report_evaluated_rule t; let* () = Memo.Build.run (Fs.mkdir_p dir) in let is_action_dynamic = Action.is_dynamic action.action in @@ -1729,7 +1874,7 @@ end = struct | [] -> Fiber.return (Cache_result.Hit targets_and_digests) | (deps, old_digest) :: rest -> let deps = Action_exec.Dynamic_dep.Set.to_dep_set deps in - let* deps = build_deps deps in + let* deps = Memo.Build.run (build_deps deps) in let new_digest = Dep.Facts.digest deps ~sandbox_mode ~env:action.env in @@ -1748,7 +1893,13 @@ end = struct ~cache_debug_flags:t.cache_debug_flags ~head_target miss_reason; (* Step I. Remove stale targets both from the digest table and from the build directory. *) - Targets.iter targets ~file:(fun target -> + let file_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + (* CR-someday amokhov: Don't ignore directory targets *) + ignore dirs; + files) + in + Path.Build.Set.iter file_targets ~f:(fun target -> Cached_digest.remove target; Path.Build.unlink_no_err target); (* Step II. Try to restore artifacts from the shared cache if the @@ -1815,25 +1966,35 @@ end = struct (* Step IV. Store results to the shared cache and if that step fails, post-process targets by removing write permissions and computing their digests. *) + let file_targets, dir_targets = + Targets.map targets ~f:(fun ~files ~dirs -> (files, dirs)) + in match t.cache_config with | Enabled { storage_mode = mode; reproducibility_check = _ } - when can_go_in_shared_cache -> ( + when can_go_in_shared_cache + (* CR-someday amokhov: Add support for caching rules + with directory targets. *) + && Path.Build.Set.is_empty dir_targets -> ( let+ targets_and_digests = - try_to_store_to_shared_cache ~mode ~rule_digest ~targets - ~action:action.action + try_to_store_to_shared_cache ~mode ~rule_digest + ~file_targets ~action:action.action in match targets_and_digests with | Some targets_and_digests -> targets_and_digests | None -> compute_target_digests_or_raise_error execution_parameters - ~loc targets) + ~loc file_targets) | _ -> + let targets = + Path.Build.Set.union file_targets + exec_result.files_in_directory_targets + in Fiber.return (compute_target_digests_or_raise_error execution_parameters ~loc targets) in let dynamic_deps_stages = - List.map exec_result.dynamic_deps_stages + List.map exec_result.action_exec_result.dynamic_deps_stages ~f:(fun (deps, fact_map) -> ( deps , Dep.Facts.digest fact_map ~sandbox_mode ~env:action.env @@ -1856,9 +2017,15 @@ end = struct | Promote _, Some Never -> Fiber.return () | Promote { lifetime; into; only }, (Some Automatically | None) -> + (* CR-someday amokhov: Don't ignore directory targets. *) + let file_targets = + Targets.map targets ~f:(fun ~files ~dirs -> + ignore dirs; + files) + in Fiber.parallel_iter_set (module Path.Build.Set) - (Targets.files targets) + file_targets ~f:(fun target -> let consider_for_promotion = match only with @@ -2126,15 +2293,54 @@ end = struct let build_file_impl path = let t = t () in get_rule_or_source t path >>= function - | Source digest -> Memo.Build.return digest - | Rule (path, rule) -> + | Source digest -> Memo.Build.return (digest, None) + | Rule (path, rule) -> ( let+ { deps = _; targets } = Memo.push_stack_frame (fun () -> execute_rule rule) ~human_readable_description:(fun () -> Pp.text (Path.to_string_maybe_quoted (Path.build path))) in - Path.Build.Map.find_exn targets path + match Path.Build.Map.find targets path with + | Some digest -> (digest, None) + | None -> ( + match Cached_digest.build_file path with + | Ok digest -> (digest, Some targets) (* Must be a directory target *) + | No_such_file + | Broken_symlink + | Unexpected_kind _ + | Unix_error _ + | Error _ -> + (* CR-someday amokhov: The most important reason we end up here is + [No_such_file]. I think some of the outcomes above are impossible + but some others will benefit from a better error. To be refined. *) + let target = + Path.Build.drop_build_context_exn path + |> Path.Source.to_string_maybe_quoted + in + let _matching_files, matching_dirs = + Targets.partition_map rule.targets ~file:ignore ~dir:(fun dir -> + match Path.Build.is_descendant path ~of_:dir with + | true -> [ dir ] + | false -> []) + in + let matching_target = + match List.concat matching_dirs with + | [ dir ] -> + Path.Build.drop_build_context_exn dir + |> Path.Source.to_string_maybe_quoted + | [] + | _ :: _ -> + Code_error.raise "Multiple matching directory targets" + [ ("targets", Targets.to_dyn rule.targets) ] + in + User_error.raise ~loc:rule.loc + ~annots:[ User_error.Annot.Needs_stack_trace.make () ] + [ Pp.textf + "This rule defines a directory target %S that matches the \ + requested path %S but the rule's action didn't produce it" + matching_target target + ])) let dep_on_anonymous_action (x : Rule.Anonymous_action.t Action_builder.t) : _ Action_builder.t = @@ -2169,13 +2375,31 @@ end = struct module Pred = struct let build_impl g = - let* paths = Pred.eval g in - let+ files = - Memo.Build.parallel_map (Path.Set.to_list paths) ~f:(fun p -> - let+ d = build_file p in - (p, d)) - in - Dep.Fact.Files.make (Path.Map.of_list_exn files) + let dir = File_selector.dir g in + is_target dir >>= function + | false -> + let* paths = Pred.eval g in + let+ files = + Memo.Build.parallel_map (Path.Set.to_list paths) ~f:(fun p -> + let+ d = build_file p in + (p, d)) + in + Dep.Fact.Files.make + ~files:(Path.Map.of_list_exn files) + ~dirs:Path.Map.empty + | true -> + let+ digest, path_map = build_dir dir in + let files = + Path.Build.Map.foldi path_map ~init:Path.Map.empty + ~f:(fun path digest acc -> + let parent = Path.Build.parent_exn path |> Path.build in + let path = Path.build path in + match Path.equal parent dir && File_selector.test g path with + | true -> Path.Map.add_exn acc path digest + | false -> acc) + in + let dirs = Path.Map.singleton dir digest in + Dep.Fact.Files.make ~files ~dirs let eval_impl g = let dir = File_selector.dir g in @@ -2183,7 +2407,9 @@ end = struct | Non_build targets -> Path.Set.filter targets ~f:(File_selector.test g) | Build { rules_here; _ } -> let only_generated_files = File_selector.only_generated_files g in - Path.Build.Map.foldi ~init:[] rules_here + (* We look only at [by_file_targets] because [File_selector] does not + match directories. *) + Path.Build.Map.foldi ~init:[] rules_here.by_file_targets ~f:(fun s { Rule.info; _ } acc -> match info with | Rule.Info.Source_file_copy _ when only_generated_files -> acc @@ -2210,11 +2436,21 @@ end = struct end let build_file_memo = - Memo.create "build-file" - ~input:(module Path) - ~cutoff:Digest.equal build_file_impl + let cutoff = + Tuple.T2.equal Digest.equal + (Option.equal (Path.Build.Map.equal ~equal:Digest.equal)) + in + Memo.create "build-file" ~input:(module Path) ~cutoff build_file_impl - let build_file = Memo.exec build_file_memo + let build_file path = Memo.exec build_file_memo path >>| fst + + let build_dir path = + let+ digest, path_map = Memo.exec build_file_memo path in + match path_map with + | Some path_map -> (digest, path_map) + | None -> + Code_error.raise "build_dir called on a file target" + [ ("path", Path.to_dyn path) ] let build_alias_memo = Memo.create "build-alias" @@ -2376,10 +2612,6 @@ let file_exists = file_exists let alias_exists = Load_rules.alias_exists -let is_target file = - let+ targets = targets_of ~dir:(Path.parent_exn file) in - Path.Set.mem targets file - let execute_action = execute_action let execute_action_stdout = execute_action_stdout @@ -2443,7 +2675,7 @@ let get_current_progress () = ; number_of_rules_discovered = t.rule_total } -let targets_of = targets_of +let file_targets_of = file_targets_of let all_targets () = all_targets (t ()) diff --git a/src/dune_engine/build_system.mli b/src/dune_engine/build_system.mli index 9703f3b06b8..ff9a11b93d8 100644 --- a/src/dune_engine/build_system.mli +++ b/src/dune_engine/build_system.mli @@ -135,8 +135,8 @@ val eval_pred : File_selector.t -> Path.Set.t Memo.Build.t (** Same as [eval_pred] but also build the resulting set of files. *) val build_pred : File_selector.t -> Dep.Fact.Files.t Memo.Build.t -(** Returns the set of targets in the given directory. *) -val targets_of : dir:Path.t -> Path.Set.t Memo.Build.t +(** Returns the set of file targets in the given directory. *) +val file_targets_of : dir:Path.t -> Path.Set.t Memo.Build.t (** Load the rules for this directory. *) val load_dir : dir:Path.t -> unit Memo.Build.t diff --git a/src/dune_engine/dep.ml b/src/dune_engine/dep.ml index 972d6527267..8a582f9e0ad 100644 --- a/src/dune_engine/dep.ml +++ b/src/dune_engine/dep.ml @@ -1,6 +1,8 @@ open Stdune open Memo.Build.O +(* CR-someday amokhov: We probably want to add a new variant [Dir] to provide + first-class support for depending on directory targets. *) module T = struct type t = | Env of Env.Var.t @@ -100,49 +102,61 @@ module Map = struct end module Fact = struct + (* CR-someday amokhov: Find a better name, perhaps, [Files_and_dirs]? *) module Files = struct type t = { files : Digest.t Path.Map.t - ; dirs : Path.Set.t + ; dirs : Digest.t Path.Map.t (* Only for file selectors for now *) + ; parent_dirs : Path.Set.t ; digest : Digest.t } - let to_dyn { files; dirs; digest } = + let to_dyn { files; dirs; parent_dirs; digest } = Dyn.Record [ ("files", Path.Map.to_dyn Digest.to_dyn files) - ; ("dirs", Path.Set.to_dyn dirs) + ; ("dirs", Path.Map.to_dyn Digest.to_dyn dirs) + ; ("parent_dirs", Path.Set.to_dyn parent_dirs) ; ("digest", Digest.to_dyn digest) ] + let is_empty t = Path.Map.is_empty t.files && Path.Map.is_empty t.dirs + let compare a b = Digest.compare a.digest b.digest let equal a b = Digest.equal a.digest b.digest let paths t = t.files - let make files = + let make ~files ~dirs = + let parent_dirs = + let f path (_ : Digest.t) acc = + Path.Set.add acc (Path.parent_exn path) + in + let init = Path.Map.foldi files ~init:Path.Set.empty ~f in + Path.Map.foldi files ~init ~f + in { files - ; dirs = - Path.Map.foldi files ~init:Path.Set.empty ~f:(fun fn _ acc -> - Path.Set.add acc (Path.parent_exn fn)) + ; dirs + ; parent_dirs ; digest = Digest.generic - (Path.Map.to_list_map files ~f:(fun p d -> (Path.to_string p, d))) + (Path.Map.to_list_map files ~f:(fun p d -> (Path.to_string p, d)) + @ Path.Map.to_list_map dirs ~f:(fun p d -> (Path.to_string p, d))) } - let empty = lazy (make Path.Map.empty) + let empty = lazy (make ~files:Path.Map.empty ~dirs:Path.Map.empty) let group ts files = let ts = if Path.Map.is_empty files then ts else - make files :: ts + make ~files ~dirs:Path.Map.empty :: ts in (* Sort and de-dup so that the result is resilient to code changes *) let ts = List.filter_map ts ~f:(fun t -> - if Path.Map.is_empty t.files then + if is_empty t then None else Some (t.digest, t)) @@ -160,7 +174,12 @@ module Fact = struct Some d1)) ; dirs = List.fold_left l ~init:t.dirs ~f:(fun acc t -> - Path.Set.union t.dirs acc) + Path.Map.union t.dirs acc ~f:(fun _ d1 d2 -> + assert (Digest.equal d1 d2); + Some d1)) + ; parent_dirs = + List.fold_left l ~init:t.parent_dirs ~f:(fun acc t -> + Path.Set.union t.parent_dirs acc) ; digest = Digest.generic (List.map ts ~f:(fun t -> t.digest)) } end @@ -171,6 +190,21 @@ module Fact = struct | File_selector of Dyn.t * Files.t | Alias of Files.t + let to_dyn = function + | Nothing -> Dyn.Variant ("Nothing", []) + | File (path, digest) -> + Dyn.Variant + ( "File" + , [ Dyn.Record + [ ("path", Path.to_dyn path); ("digest", Digest.to_dyn digest) ] + ] ) + | File_selector (dyn, files) -> + Dyn.Variant + ( "File_selector" + , [ Dyn.Record [ ("dyn", dyn); ("files", Files.to_dyn files) ] ] ) + | Alias files -> + Dyn.Variant ("Alias", [ Dyn.Record [ ("files", Files.to_dyn files) ] ]) + module Stable_for_digest = struct type file = string * Digest.t @@ -228,6 +262,8 @@ module Facts = struct let union_all xs = List.fold_left xs ~init:Map.empty ~f:union + let to_dyn = Map.to_dyn Fact.to_dyn + let paths t = Map.fold t ~init:Path.Map.empty ~f:(fun fact acc -> match (fact : Fact.t) with @@ -261,13 +297,23 @@ module Facts = struct Fact.Files.group fact_files paths let dirs t = + Map.fold t ~init:Path.Set.empty ~f:(fun fact acc -> + match (fact : Fact.t) with + | Nothing + | File _ -> + acc + | File_selector (_, ps) + | Alias ps -> + Path.Set.union acc (Path.Map.keys ps.dirs |> Path.Set.of_list)) + + let parent_dirs t = Map.fold t ~init:Path.Set.empty ~f:(fun fact acc -> match (fact : Fact.t) with | Nothing -> acc | File (p, _) -> Path.Set.add acc (Path.parent_exn p) | File_selector (_, ps) | Alias ps -> - Path.Set.union acc ps.dirs) + Path.Set.union acc ps.parent_dirs) let digest t ~sandbox_mode ~env = let facts = diff --git a/src/dune_engine/dep.mli b/src/dune_engine/dep.mli index c8d1ef3dfd5..44b9a9028ff 100644 --- a/src/dune_engine/dep.mli +++ b/src/dune_engine/dep.mli @@ -54,11 +54,13 @@ module Fact : sig val file : Path.t -> Digest.t -> t + val to_dyn : t -> Dyn.t + module Files : sig (** A group of files for which we cache the digest of the whole group. *) type t - val make : Digest.t Path.Map.t -> t + val make : files:Digest.t Path.Map.t -> dirs:Digest.t Path.Map.t -> t val to_dyn : t -> Dyn.t @@ -66,10 +68,10 @@ module Fact : sig val compare : t -> t -> Ordering.t - (** Return all the paths in this file group *) + (** Return all file paths in this file group. *) val paths : t -> Digest.t Path.Map.t - (** Create a new [t] from a list of [t] and a list of files *) + (** Create a new [t] from a list of [t] and a list of files. *) val group : t list -> Digest.t Path.Map.t -> t end @@ -81,9 +83,8 @@ module Fact : sig end module Facts : sig - (* There is an invariant that is not currently enforced: the value correspond - to the key. For instance we can't have [Map.find (File f) = File_selector - _] *) + (* There is an invariant that is not currently enforced: values correspond to + keys. For example, we can't have [Map.find (File f) = File_selector _]. *) type t = Fact.t Map.t val empty : t @@ -92,7 +93,7 @@ module Facts : sig val union_all : t list -> t - (** Return all the paths, expanding aliases *) + (** Return all file paths, expanding aliases. *) val paths : t -> Digest.t Path.Map.t val paths_without_expanding_aliases : t -> Digest.t Path.Map.t @@ -102,9 +103,15 @@ module Facts : sig original [Files.t]. *) val group_paths_as_fact_files : t list -> Fact.Files.t + (** Dependencies on directory targets. *) val dirs : t -> Path.Set.t + (** Parent directories of all dependencies. *) + val parent_dirs : t -> Path.Set.t + val digest : t -> sandbox_mode:Sandbox_mode.t -> env:Env.t -> Digest.t + + val to_dyn : t -> Dyn.t end module Set : sig diff --git a/src/dune_engine/file_selector.mli b/src/dune_engine/file_selector.mli index b75fc577246..37c76e421d2 100644 --- a/src/dune_engine/file_selector.mli +++ b/src/dune_engine/file_selector.mli @@ -1,5 +1,5 @@ -(** A File_selector.t is a predicate that is to be evaluated in a particular - directory *) +(** A [File_selector.t] is a predicate evaluated on a set of file names in a + specified directory. *) open Stdune diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index d9c2919967a..fc4182d9ff5 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -318,9 +318,11 @@ module Fancy = struct ("(internal)" :: targets_acc) (add_ctx ctx ctxs_acc) rest) in - let file_targets = Targets.to_list_map targets ~file:Fun.id in let target_names, contexts = - split_paths [] Context_name.Set.empty file_targets + let file_targets, directory_targets = + Targets.partition_map targets ~file:Fun.id ~dir:Fun.id + in + split_paths [] Context_name.Set.empty (file_targets @ directory_targets) in let targets = List.map target_names ~f:Filename.split_extension_after_dot diff --git a/src/dune_engine/rule.ml b/src/dune_engine/rule.ml index 0217992cb93..c54af4f023f 100644 --- a/src/dune_engine/rule.ml +++ b/src/dune_engine/rule.ml @@ -90,8 +90,8 @@ let add_sandbox_config : let make ?(sandbox = Sandbox_config.default) ?(mode = Mode.Standard) ~context ?(info = Info.Internal) ~targets action = - let open Memo.Build.O in let action = + let open Memo.Build.O in Action_builder.memoize "Rule.make" (Action_builder.of_thunk { f = @@ -101,25 +101,27 @@ let make ?(sandbox = Sandbox_config.default) ?(mode = Mode.Standard) ~context (action, deps)) }) in + let report_error ?(extra_pp = []) message = + match info with + | From_dune_file loc -> + let pp = [ Pp.text message ] @ extra_pp in + User_error.raise ~loc pp + | Internal + | Source_file_copy _ -> + Code_error.raise message + [ ("info", Info.to_dyn info); ("targets", Targets.to_dyn targets) ] + in let dir = match Targets.validate targets with | Valid { parent_dir } -> parent_dir - | No_targets -> ( - match info with - | From_dune_file loc -> - User_error.raise ~loc [ Pp.text "Rule has no targets specified" ] - | _ -> Code_error.raise "Build_interpret.Rule.make: no targets" []) - | Inconsistent_parent_dir -> ( - match info with - | Internal - | Source_file_copy _ -> - Code_error.raise "rule has targets in different directories" - [ ("targets", Targets.to_dyn targets) ] - | From_dune_file loc -> - User_error.raise ~loc - [ Pp.text "Rule has targets in different directories.\nTargets:" - ; Targets.pp targets - ]) + | No_targets -> report_error "Rule has no targets specified" + | Inconsistent_parent_dir -> + report_error "Rule has targets in different directories." + ~extra_pp:[ Pp.text "Targets:"; Targets.pp targets ] + | File_and_directory_target_with_the_same_name path -> + report_error + (sprintf "%S is declared as both a file and a directory target." + (Dpath.describe_target path)) in let loc = match info with diff --git a/src/dune_engine/rule.mli b/src/dune_engine/rule.mli index 3e220f54a97..bc69cfbdbb8 100644 --- a/src/dune_engine/rule.mli +++ b/src/dune_engine/rule.mli @@ -4,6 +4,7 @@ open! Stdune open! Import module Action_builder := Action_builder0 +(** Information about the provenance of a build rule. *) module Info : sig type t = | From_dune_file of Loc.t @@ -75,6 +76,8 @@ val hash : t -> int val to_dyn : t -> Dyn.t +(** [make] raises an error if the set of [targets] is not well-formed. See the + [Targets.Validation_result] data type for the list of possible problems. *) val make : ?sandbox:Sandbox_config.t -> ?mode:Mode.t diff --git a/src/dune_engine/sandbox.ml b/src/dune_engine/sandbox.ml index 4c0f329c721..a5255e8d90a 100644 --- a/src/dune_engine/sandbox.ml +++ b/src/dune_engine/sandbox.ml @@ -30,7 +30,8 @@ let map_path t p = Path.Build.append t.dir p let create_dirs t ~deps ~chdirs ~rule_dir = Path.Set.iter (Path.Set.add - (Path.Set.union (Dep.Facts.dirs deps) chdirs) + (Path.Set.union_all + [ chdirs; Dep.Facts.parent_dirs deps; Dep.Facts.dirs deps ]) (Path.build rule_dir)) ~f:(fun path -> match Path.as_in_build_dir path with @@ -70,7 +71,7 @@ let link_function ~(mode : Sandbox_mode.some) = let link_deps t ~mode ~deps = let link = Staged.unstage (link_function ~mode) in - Path.Map.iteri deps ~f:(fun path _ -> + Path.Map.iteri deps ~f:(fun path (_ : Digest.t) -> match Path.as_in_build_dir path with | None -> (* This can actually raise if we try to sandbox the "copy from source @@ -78,7 +79,7 @@ let link_deps t ~mode ~deps = if Path.is_in_source_tree path then Code_error.raise "Action depends on source tree. All actions should depend on the \ - copies in build directory instead" + copies in the build directory instead." [ ("path", Path.to_dyn path) ] | Some p -> link path (Path.build (map_path t p))) @@ -112,8 +113,67 @@ let rename_optional_file ~src ~dst = | exception Unix.Unix_error (ENOENT, _, _) -> () | () -> ()) -let move_targets_to_build_dir t ~targets = - Targets.iter targets ~file:(fun target -> - rename_optional_file ~src:(map_path t target) ~dst:target) +(* Recursively move regular files from [src] to [dst] and return the set of + moved files. *) +let rename_dir_recursively ~loc ~src_dir ~dst_dir = + let rec loop ~src_dir ~dst_dir = + (match Fpath.mkdir (Path.Build.to_string dst_dir) with + | Created -> () + | Already_exists -> + User_error.raise ~loc + ~annots:[ User_error.Annot.Needs_stack_trace.make () ] + [ Pp.textf + "This rule defines a directory target %S whose name conflicts with \ + an internal directory used by Dune. Please use a different name." + (Path.Build.drop_build_context_exn dst_dir + |> Path.Source.to_string_maybe_quoted) + ] + | Missing_parent_directory -> assert false); + match + Dune_filesystem_stubs.read_directory_with_kinds + (Path.Build.to_string src_dir) + with + | Ok files -> + List.concat_map files ~f:(fun (file, kind) -> + match (kind : Dune_filesystem_stubs.File_kind.t) with + | S_REG -> + let src = Path.Build.relative src_dir file in + let dst = Path.Build.relative dst_dir file in + Unix.rename (Path.Build.to_string src) (Path.Build.to_string dst); + [ dst ] + | S_DIR -> + loop + ~src_dir:(Path.Build.relative src_dir file) + ~dst_dir:(Path.Build.relative dst_dir file) + | _ -> + User_error.raise ~loc + [ Pp.textf "Rule produced a file with unrecognised kind %S" + (Dune_filesystem_stubs.File_kind.to_string kind) + ]) + | Error (ENOENT, _, _) -> + User_error.raise ~loc + [ Pp.textf "Rule failed to produce directory %S" + (Path.Build.drop_build_context_maybe_sandboxed_exn src_dir + |> Path.Source.to_string_maybe_quoted) + ] + | Error (unix_error, _, _) -> + User_error.raise ~loc + [ Pp.textf "Rule produced unreadable directory %S" + (Path.Build.drop_build_context_maybe_sandboxed_exn src_dir + |> Path.Source.to_string_maybe_quoted) + ; Pp.verbatim (Unix.error_message unix_error) + ] + in + loop ~src_dir ~dst_dir |> Path.Build.Set.of_list + +let move_targets_to_build_dir t ~loc ~targets = + let (_file_targets_renamed : unit list), files_moved_in_directory_targets = + Targets.partition_map targets + ~file:(fun target -> + rename_optional_file ~src:(map_path t target) ~dst:target) + ~dir:(fun target -> + rename_dir_recursively ~loc ~src_dir:(map_path t target) ~dst_dir:target) + in + Path.Build.Set.union_all files_moved_in_directory_targets let destroy t = Path.rm_rf (Path.build t.dir) diff --git a/src/dune_engine/sandbox.mli b/src/dune_engine/sandbox.mli index ef41499601a..f8e9e6f4a8e 100644 --- a/src/dune_engine/sandbox.mli +++ b/src/dune_engine/sandbox.mli @@ -20,7 +20,8 @@ val create : -> t (** Move the targets created by the action from the sandbox to the build - directory. *) -val move_targets_to_build_dir : t -> targets:Targets.t -> unit + directory. Returns the set of files discovered in directory targets. *) +val move_targets_to_build_dir : + t -> loc:Loc.t -> targets:Targets.t -> Path.Build.Set.t val destroy : t -> unit diff --git a/src/dune_engine/sandbox_mode.ml b/src/dune_engine/sandbox_mode.ml index 1c4a544ee29..28d8ab51b3b 100644 --- a/src/dune_engine/sandbox_mode.ml +++ b/src/dune_engine/sandbox_mode.ml @@ -86,6 +86,14 @@ module Set = struct ; symlink = x.symlink && y.symlink ; hardlink = x.hardlink && y.hardlink } + + let to_dyn (t : t) = + Dyn.Record + [ ("none", Dyn.Bool t.none) + ; ("copy", Dyn.Bool t.copy) + ; ("symlink", Dyn.Bool t.symlink) + ; ("hardlink", Dyn.Bool t.hardlink) + ] end (* these should be listed in the default order of preference *) diff --git a/src/dune_engine/sandbox_mode.mli b/src/dune_engine/sandbox_mode.mli index fcd65e50e68..ffe9be19a8a 100644 --- a/src/dune_engine/sandbox_mode.mli +++ b/src/dune_engine/sandbox_mode.mli @@ -2,8 +2,10 @@ (** This module describes the method used to sandbox actions. Choices include: - - not sandboxing - sandboxing by symlinking dependencies - sandboxing by - copying dependencies *) + - not sandboxing + - sandboxing by symlinking dependencies + - sandboxing by copying dependencies + - sandboxing by hardlinking dependencies *) open! Stdune @@ -49,6 +51,8 @@ module Set : sig val mem : t -> key -> bool val inter : t -> t -> t + + val to_dyn : t -> Dyn.t end val all : t list diff --git a/src/dune_engine/targets.ml b/src/dune_engine/targets.ml index b6f336a13b1..d85b5996e46 100644 --- a/src/dune_engine/targets.ml +++ b/src/dune_engine/targets.ml @@ -1,23 +1,40 @@ open! Stdune open Import -type t = { files : Path.Build.Set.t } [@@unboxed] +(* CR-someday amokhov: Most of these records will have [dir = empty]. We might + want to somehow optimise for the common case, e.g. by switching to a sum type + with the [Files_only] constructor. It's best not to expose the current + representation so we can easily change it in future. *) +type t = + { files : Path.Build.Set.t + ; dirs : Path.Build.Set.t + } module File = struct - let create file = { files = Path.Build.Set.singleton file } + let create file = + { files = Path.Build.Set.singleton file; dirs = Path.Build.Set.empty } end module Files = struct - let create files = { files } + let create files = { files; dirs = Path.Build.Set.empty } end -let empty = { files = Path.Build.Set.empty } +let create ~files ~dirs = { files; dirs } -let combine x y = { files = Path.Build.Set.union x.files y.files } +let empty = { files = Path.Build.Set.empty; dirs = Path.Build.Set.empty } -let is_empty t = Path.Build.Set.is_empty t.files +let combine x y = + { files = Path.Build.Set.union x.files y.files + ; dirs = Path.Build.Set.union x.dirs y.dirs + } -let head { files } = Path.Build.Set.choose files +let is_empty { files; dirs } = + Path.Build.Set.is_empty files && Path.Build.Set.is_empty dirs + +let head { files; dirs } = + match Path.Build.Set.choose files with + | Some _ as target -> target + | None -> Path.Build.Set.choose dirs let head_exn t = match head t with @@ -25,37 +42,52 @@ let head_exn t = | None -> Code_error.raise "Targets.head_exn applied to empty set of targets" [] -let to_dyn { files } = Dyn.Record [ ("files", Path.Build.Set.to_dyn files) ] +let to_dyn { files; dirs } = + Dyn.Record + [ ("files", Path.Build.Set.to_dyn files) + ; ("dirs", Path.Build.Set.to_dyn dirs) + ] -let pp { files } = - Pp.enumerate (Path.Build.Set.to_list files) ~f:(fun target -> - Pp.text (Dpath.describe_target target)) +let pp { files; dirs } = + Pp.enumerate + (Path.Build.Set.to_list files @ Path.Build.Set.to_list dirs) + ~f:(fun target -> Pp.text (Dpath.describe_target target)) -let exists { files } ~file = Path.Build.Set.exists files ~f:file +let exists { files; dirs } ~f = + Path.Build.Set.exists files ~f || Path.Build.Set.exists dirs ~f -let to_list_map { files } ~file = Path.Build.Set.to_list_map files ~f:file +let partition_map { files; dirs } ~file ~dir = + ( Path.Build.Set.to_list_map files ~f:file + , Path.Build.Set.to_list_map dirs ~f:dir ) -let fold { files } ~init ~file = Path.Build.Set.fold files ~init ~f:file +let iter { files; dirs } ~file ~dir = + Path.Build.Set.iter files ~f:file; + Path.Build.Set.iter dirs ~f:dir -let iter { files } ~file = Path.Build.Set.iter files ~f:file +let map { files; dirs } ~f = f ~files ~dirs -let files t = t.files +let fold { files; dirs } ~init ~file ~dir = + let init = Path.Build.Set.fold files ~init ~f:file in + Path.Build.Set.fold dirs ~init ~f:dir module Validation_result = struct type t = | Valid of { parent_dir : Path.Build.t } | No_targets | Inconsistent_parent_dir + | File_and_directory_target_with_the_same_name of Path.Build.t end let validate t = match is_empty t with | true -> Validation_result.No_targets | false -> ( - let parent_dir = Path.Build.parent_exn (head_exn t) in - match - exists t ~file:(fun target -> - Path.Build.(parent_exn target <> parent_dir)) - with - | true -> Inconsistent_parent_dir - | false -> Valid { parent_dir }) + match Path.Build.Set.inter t.files t.dirs |> Path.Build.Set.choose with + | Some path -> File_and_directory_target_with_the_same_name path + | None -> ( + let parent_dir = Path.Build.parent_exn (head_exn t) in + match + exists t ~f:(fun path -> Path.Build.(parent_exn path <> parent_dir)) + with + | true -> Inconsistent_parent_dir + | false -> Valid { parent_dir })) diff --git a/src/dune_engine/targets.mli b/src/dune_engine/targets.mli index 460b73d50e0..709f93591c2 100644 --- a/src/dune_engine/targets.mli +++ b/src/dune_engine/targets.mli @@ -1,9 +1,10 @@ open! Stdune open! Import -(* CR-someday amokhov: Add directory targets. *) +(** A set of targets of a build rule. -(** A set of file targets of a build rule. *) + A rule can produce a set of files whose names are known upfront, as well as + a set of "opaque" directories whose contents is initially unknown. *) type t (** The empty set of targets. Note that rules are not allowed to have the empty @@ -26,31 +27,46 @@ module Files : sig val create : Path.Build.Set.t -> t end +(** A set of file and directory targets. *) +val create : files:Path.Build.Set.t -> dirs:Path.Build.Set.t -> t + module Validation_result : sig type t = | Valid of { parent_dir : Path.Build.t } | No_targets | Inconsistent_parent_dir + | File_and_directory_target_with_the_same_name of Path.Build.t end -(** Ensure that the set of targets is non-empty and that all targets have the - same parent dir. *) +(** Ensure that the set of targets is well-formed. *) val validate : t -> Validation_result.t -(** The "head" target, i.e. the lexicographically first target file if [t] is - non-empty. *) +(** The "head" target if [t] is non-empty. If [t] contains at least one file, + then it's the lexicographically first target file. Otherwise, it's the + lexicographically first target directory. *) val head : t -> Path.Build.t option (** Like [head] but raises a code error if the set of targets is empty. *) val head_exn : t -> Path.Build.t -val files : t -> Path.Build.Set.t +val partition_map : + t + -> file:(Path.Build.t -> 'a) + -> dir:(Path.Build.t -> 'b) + -> 'a list * 'b list -val to_list_map : t -> file:(Path.Build.t -> 'a) -> 'a list +val iter : + t -> file:(Path.Build.t -> unit) -> dir:(Path.Build.t -> unit) -> unit -val fold : t -> init:'a -> file:(Path.Build.t -> 'a -> 'a) -> 'a +val map : t -> f:(files:Path.Build.Set.t -> dirs:Path.Build.Set.t -> 'a) -> 'a -val iter : t -> file:(Path.Build.t -> unit) -> unit +(** File targets are traversed before directory targets. *) +val fold : + t + -> init:'a + -> file:(Path.Build.t -> 'a -> 'a) + -> dir:(Path.Build.t -> 'a -> 'a) + -> 'a val to_dyn : t -> Dyn.t diff --git a/src/dune_rules/action_unexpanded.ml b/src/dune_rules/action_unexpanded.ml index d73ad9b39df..a48c37e548f 100644 --- a/src/dune_rules/action_unexpanded.ml +++ b/src/dune_rules/action_unexpanded.ml @@ -152,8 +152,8 @@ end = struct >>> Action_builder.if_file_exists f ~then_:(Action_builder.path f) ~else_:(Action_builder.return ())) in - Action_builder.with_targets - ~targets:(Targets.Files.create file_targets) + let targets = Targets.Files.create file_targets in + Action_builder.with_targets ~targets (let+ () = deps >>= Action_builder.path_set and+ () = deps_if_exist >>= action_builder_path_set_if_exist and+ res = b in @@ -529,7 +529,10 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir | Multiple -> Targets)) (Expander.Deps.Without (Memo.Build.return - (Value.L.paths (List.map targets ~f:Path.build))))) + (Value.L.paths + (List.map targets + ~f:(fun (target, (_ : Targets_spec.Kind.t)) -> + Path.build target)))))) in let expander = Expander.set_expanding_what expander (User_action targets_written_by_user) @@ -541,17 +544,23 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir match (targets_written_by_user : _ Targets_spec.t) with | Infer -> targets | Static { targets = targets_written_by_user; multiplicity = _ } -> - Targets.combine targets - (Targets.Files.create (Path.Build.Set.of_list targets_written_by_user)) + let files, dirs = + List.partition_map targets_written_by_user ~f:(fun (path, kind) -> + if Path.Build.(parent_exn path <> targets_dir) then + User_error.raise ~loc + [ Pp.text + "This action has targets in a different directory than the \ + current one, this is not allowed by dune at the moment:" + ; Targets.pp targets + ]; + match kind with + | File -> Left path + | Directory -> Right path) + in + let files = Path.Build.Set.of_list files in + let dirs = Path.Build.Set.of_list dirs in + Targets.combine targets (Targets.create ~files ~dirs) in - Targets.iter targets ~file:(fun target -> - if Path.Build.( <> ) (Path.Build.parent_exn target) targets_dir then - User_error.raise ~loc - [ Pp.text - "This action has targets in a different directory than the \ - current one, this is not allowed by dune at the moment:" - ; Targets.pp targets - ]); let build = let+ () = deps_builder and+ action = build in diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index 795a8a3abe4..2a0b76c7982 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -143,8 +143,13 @@ end = struct Memo.Build.return (Coq_stanza.Extraction.ml_target_fnames s) | Menhir.T menhir -> Memo.Build.return (Menhir_rules.targets menhir) | Rule rule -> - Simple_rules.user_rule sctx rule ~dir ~expander - >>| Targets.to_list_map ~file:Path.Build.basename + let+ targets = Simple_rules.user_rule sctx rule ~dir ~expander in + (* CR-someday amokhov: Do not ignore directory targets. *) + let file_target_names, _ignored_dir_targets = + Targets.partition_map targets ~file:Path.Build.basename + ~dir:ignore + in + file_target_names | Copy_files def -> let+ ps = Simple_rules.copy_files sctx def ~src_dir ~dir ~expander diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml index c1b29edae3b..74a04535ade 100644 --- a/src/dune_rules/dune_file.ml +++ b/src/dune_rules/dune_file.ml @@ -1626,14 +1626,27 @@ module Rule = struct ; package = None } + let directory_targets_extension = + let syntax = + Dune_lang.Syntax.create ~name:"directory-targets" + ~desc:"experimental support for directory targets" + [ ((0, 1), `Since (3, 0)) ] + in + Dune_project.Extension.register syntax (return ((), [])) Dyn.Encoder.unit + let long_form = let* deps = field "deps" (Bindings.decode Dep_conf.decode) ~default:Bindings.empty in + let* project = Dune_project.get_exn () in + let allow_directory_targets = + Option.is_some + (Dune_project.find_extension_args project directory_targets_extension) + in String_with_vars.add_user_vars_to_decoding_env (Bindings.var_names deps) (let+ loc = loc and+ action = field "action" (located Action_dune_lang.decode) - and+ targets = Targets_spec.field + and+ targets = Targets_spec.field ~allow_directory_targets and+ locks = field "locks" (repeat String_with_vars.decode) ~default:[] and+ () = let+ fallback = @@ -1706,7 +1719,9 @@ module Rule = struct can't because this is might get parsed with old dune syntax where [multiplicity = One] is not supported. *) Static - { targets = [ S.make_text loc dst ]; multiplicity = Multiple } + { targets = [ (S.make_text loc dst, File) ] + ; multiplicity = Multiple + } ; deps = Bindings.singleton (Dep_conf.File (S.virt_text __POS__ src)) ; action = ( loc @@ -1734,7 +1749,8 @@ module Rule = struct { targets = Static { targets = - List.map ~f:(S.make_text loc) [ name ^ ".ml"; name ^ ".mli" ] + List.map [ name ^ ".ml"; name ^ ".mli" ] ~f:(fun target -> + (S.make_text loc target, Targets_spec.Kind.File)) ; multiplicity = Multiple } ; deps = Bindings.singleton (Dep_conf.File (S.virt_text __POS__ src)) diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index 0e63482fd6f..7adbdc7e788 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -18,27 +18,28 @@ end let interpret_locks ~expander = Memo.Build.List.map ~f:(Expander.No_deps.expand_path expander) -let check_filename = +let check_filename ~kind = let not_in_dir ~error_loc s = User_error.raise ~loc:error_loc - [ Pp.textf "%s does not denote a file in the current directory" s ] + [ (match kind with + | Targets_spec.Kind.File -> + Pp.textf "%S does not denote a file in the current directory." s + | Directory -> + Pp.textf "Directory targets must have exactly one path component.") + ] in - fun ~error_loc ~dir fn -> - match fn with + fun ~error_loc ~dir -> function | Value.String ("." | "..") -> User_error.raise ~loc:error_loc - [ Pp.text "'.' and '..' are not valid filenames" ] + [ Pp.text "'.' and '..' are not valid targets" ] | String s -> if Filename.dirname s <> Filename.current_dir_name then not_in_dir ~error_loc s; Path.Build.relative ~error_loc dir s - | Path p -> - if - Option.compare Path.compare (Path.parent p) (Some (Path.build dir)) - <> Eq - then - not_in_dir ~error_loc (Path.to_string p); - Path.as_in_build_dir_exn p + | Path p -> ( + match Option.equal Path.equal (Path.parent p) (Some (Path.build dir)) with + | true -> Path.as_in_build_dir_exn p + | false -> not_in_dir ~error_loc (Path.to_string p)) | Dir p -> not_in_dir ~error_loc (Path.to_string p) type rule_kind = @@ -51,7 +52,7 @@ let rule_kind ~(rule : Rule.t) match rule.alias with | None -> No_alias | Some alias -> ( - match action.targets |> Targets.head with + match Targets.head action.targets with | None -> Alias_only alias | Some target -> Alias_with_targets (alias, target)) @@ -80,14 +81,15 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = | Infer -> Memo.Build.return Targets_spec.Infer | Static { targets; multiplicity } -> let+ targets = - Memo.Build.List.concat_map targets ~f:(fun target -> + Memo.Build.List.concat_map targets ~f:(fun (target, kind) -> let error_loc = String_with_vars.loc target in (match multiplicity with | One -> let+ x = Expander.No_deps.expand expander ~mode:Single target in [ x ] | Multiple -> Expander.No_deps.expand expander ~mode:Many target) - >>| List.map ~f:(check_filename ~dir ~error_loc)) + >>| List.map ~f:(fun value -> + (check_filename ~kind ~dir ~error_loc value, kind))) in Targets_spec.Static { multiplicity; targets } in @@ -101,14 +103,17 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) = ~expander ~deps:rule.deps ~targets ~targets_dir:dir in match rule_kind ~rule ~action with - | No_alias -> add_user_rule sctx ~dir ~rule ~action ~expander + | No_alias -> + let+ targets = add_user_rule sctx ~dir ~rule ~action ~expander in + targets | Alias_with_targets (alias, alias_target) -> let* () = let alias = Alias.make alias ~dir in Rules.Produce.Alias.add_deps alias (Action_builder.path (Path.build alias_target)) in - add_user_rule sctx ~dir ~rule ~action ~expander + let+ targets = add_user_rule sctx ~dir ~rule ~action ~expander in + targets | Alias_only name -> let alias = Alias.make ~dir name in let* locks = interpret_locks ~expander rule.locks in diff --git a/src/dune_rules/targets_spec.ml b/src/dune_rules/targets_spec.ml index d1b2299f3e0..116a83f97fc 100644 --- a/src/dune_rules/targets_spec.ml +++ b/src/dune_rules/targets_spec.ml @@ -23,9 +23,17 @@ module Multiplicity = struct | Multiple, One -> error "targets" "target" end +(* CR-someday amokhov: Add more interesting kinds, for example, to allow the + user to specify file patterns like "*.ml" for directory targets. *) +module Kind = struct + type t = + | File + | Directory +end + module Static = struct type 'path t = - { targets : 'path list + { targets : ('path * Kind.t) list ; multiplicity : Multiplicity.t } end @@ -34,25 +42,44 @@ type 'a t = | Static of 'a Static.t | Infer -let decode_static = +let decode_target ~allow_directory_targets = + let open Dune_lang.Decoder in + let file = + let+ file = String_with_vars.decode in + (file, Kind.File) + in + let dir = + let+ dir = sum ~force_parens:true [ ("dir", String_with_vars.decode) ] in + if not allow_directory_targets then + User_error.raise ~loc:(String_with_vars.loc dir) + [ Pp.text "Directory targets require the 'directory-targets' extension" + ]; + + (dir, Kind.Directory) + in + file <|> dir + +let decode_static ~allow_directory_targets = let open Dune_lang.Decoder in let+ syntax_version = Dune_lang.Syntax.get_exn Stanza.syntax - and+ targets = repeat String_with_vars.decode in + and+ targets = repeat (decode_target ~allow_directory_targets) in if syntax_version < (1, 3) then - List.iter targets ~f:(fun target -> + List.iter targets ~f:(fun (target, (_ : Kind.t)) -> if String_with_vars.has_pforms target then Dune_lang.Syntax.Error.since (String_with_vars.loc target) Stanza.syntax (1, 3) ~what:"Using variables in the targets field"); Static { targets; multiplicity = Multiple } -let decode_one_static = +let decode_one_static ~allow_directory_targets = let open Dune_lang.Decoder in let+ () = Dune_lang.Syntax.since Stanza.syntax (1, 11) - and+ target = String_with_vars.decode in + and+ target = decode_target ~allow_directory_targets in Static { targets = [ target ]; multiplicity = One } -let field = +let field ~allow_directory_targets = let open Dune_lang.Decoder in fields_mutually_exclusive ~default:Infer - [ ("targets", decode_static); ("target", decode_one_static) ] + [ ("targets", decode_static ~allow_directory_targets) + ; ("target", decode_one_static ~allow_directory_targets) + ] diff --git a/src/dune_rules/targets_spec.mli b/src/dune_rules/targets_spec.mli index 5ed5cc258e4..84ccc4f9e97 100644 --- a/src/dune_rules/targets_spec.mli +++ b/src/dune_rules/targets_spec.mli @@ -11,19 +11,27 @@ module Multiplicity : sig val check_variable_matches_field : loc:Loc.t -> field:t -> variable:t -> unit end +module Kind : sig + type t = + | File + | Directory +end + module Static : sig type 'path t = - { targets : 'path list + { targets : ('path * Kind.t) list ; multiplicity : Multiplicity.t } end -(** Static targets are listed by the user while [Infer] denotes that dune must - discover all the targets. In the [Static] case, dune still implicitly adds - the list of inferred targets *) +(** [Static] targets are listed by the user while [Infer] denotes that Dune must + discover all the targets. In the [Static] case, Dune still implicitly adds + the list of inferred targets. *) type 'a t = | Static of 'a Static.t | Infer (** [target] or [targets] field with the correct multiplicity. *) -val field : String_with_vars.t t Dune_lang.Decoder.fields_parser +val field : + allow_directory_targets:bool + -> String_with_vars.t t Dune_lang.Decoder.fields_parser diff --git a/test/blackbox-tests/test-cases/directory-targets.t/run.t b/test/blackbox-tests/test-cases/directory-targets.t/run.t new file mode 100644 index 00000000000..c83f1bf5295 --- /dev/null +++ b/test/blackbox-tests/test-cases/directory-targets.t/run.t @@ -0,0 +1,429 @@ +Tests for directory targets. + + $ cat > dune-project < (lang dune 3.0) + > EOF + +Directory targets require an extension. + + $ cat > dune < (rule + > (targets (dir output)) + > (action (bash "true"))) + > EOF + + $ dune build output/x + File "dune", line 2, characters 16-22: + 2 | (targets (dir output)) + ^^^^^^ + Error: Directory targets require the 'directory-targets' extension + [1] + + $ cat > dune-project < (lang dune 3.0) + > (using directory-targets 0.1) + > EOF + +Directory targets are not allowed for non-sandboxed rules. + + $ dune build output/x + File "dune", line 1, characters 0-56: + 1 | (rule + 2 | (targets (dir output)) + 3 | (action (bash "true"))) + Error: Rules with directory targets must be sandboxed. + [1] + +Ensure directory targets are produced. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets (dir output)) + > (action (bash "true"))) + > EOF + + $ dune build output/x + File "dune", line 1, characters 0-82: + 1 | (rule + 2 | (deps (sandbox always)) + 3 | (targets (dir output)) + 4 | (action (bash "true"))) + Error: Rule failed to produce directory "output" + [1] + +Error message when the matching directory target doesn't contain a requested path. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets (dir output)) + > (action (bash "mkdir output"))) + > EOF + + $ dune build output/x + File "dune", line 1, characters 0-90: + 1 | (rule + 2 | (deps (sandbox always)) + 3 | (targets (dir output)) + 4 | (action (bash "mkdir output"))) + Error: This rule defines a directory target "output" that matches the + requested path "output/x" but the rule's action didn't produce it + [1] + +Build directory target from the command line. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets (dir output)) + > (action (bash "mkdir output; echo x > output/x; echo y > output/y"))) + > EOF + + $ dune build output/x + $ cat _build/default/output/x + x + $ cat _build/default/output/y + y + +Requesting the directory target directly works too. + + $ cat > dune < (rule + > (deps src_x (sandbox always)) + > (targets (dir output)) + > (action (bash "mkdir output; cat src_x > output/x; echo y > output/y"))) + > EOF + + $ rm -rf _build + $ echo x > src_x + $ dune build output + $ cat _build/default/output/x + x + $ cat _build/default/output/y + y + +Rebuilding works correctly. + + $ echo new-x > src_x + $ dune build output + $ cat _build/default/output/x + new-x + +Hints for directory targets. + + $ dune build outputs + Error: Don't know how to build outputs + Hint: did you mean output? + [1] + +Print rules: currently works only with Makefiles. + +# CR-someday amokhov: Add support for printing Dune rules. + + $ dune rules -m output | tr '\t' ' ' | head -n -1 + _build/default/output: _build/default/src_x + mkdir -p _build/default; \ + mkdir -p _build/default; \ + cd _build/default; \ + bash -e -u -o pipefail -c \ + 'mkdir output; cat src_x > output/x; echo y > output/y' + + $ dune rules output + Error: Printing rules with directory targets is currently not supported + [1] + +Error when requesting a missing subdirectory of a directory target. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets (dir output)) + > (action (bash "mkdir output; echo x > output/x; echo y > output/y"))) + > EOF + + $ dune build output/subdir + File "dune", line 1, characters 0-128: + 1 | (rule + 2 | (deps (sandbox always)) + 3 | (targets (dir output)) + 4 | (action (bash "mkdir output; echo x > output/x; echo y > output/y"))) + Error: This rule defines a directory target "output" that matches the + requested path "output/subdir" but the rule's action didn't produce it + [1] + +Error message when depending on a file that isn't produced by the matching +directory target. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets (dir output)) + > (action (bash "\| mkdir -p output/subdir; + > "\| echo a > output/a; + > "\| echo b > output/subdir/b + > ))) + > (rule + > (deps output/subdir/c) + > (target main) + > (action (bash "cat output/subdir/c > main"))) + > EOF + + $ dune build main + File "dune", line 1, characters 0-188: + 1 | (rule + 2 | (deps (sandbox always)) + 3 | (targets (dir output)) + 4 | (action (bash "\| mkdir -p output/subdir; + 5 | "\| echo a > output/a; + 6 | "\| echo b > output/subdir/b + 7 | ))) + Error: This rule defines a directory target "output" that matches the + requested path "output/subdir/c" but the rule's action didn't produce it + -> required by _build/default/main + [1] + +Depend on a file from a directory target. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets (dir output)) + > (action (bash "\| mkdir -p output/subdir; + > "\| echo a > output/a; + > "\| echo b > output/subdir/b + > ))) + > (rule + > (deps output/subdir/b) + > (target main) + > (action (bash "cat output/subdir/b > main; echo 2 >> main"))) + > EOF + + $ dune build main + $ cat _build/default/main + b + 2 + $ cat _build/default/output/a + a + $ cat _build/default/output/subdir/b + b + +Interaction of globs and directory targets. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets (dir output)) + > (action (bash "\| mkdir -p output/subdir; + > "\| echo a > output/a.txt; + > "\| echo b > output/b.txt; + > "\| echo c > output/c; + > "\| echo d > output/subdir/d.txt; + > "\| echo e > output/subdir/e + > ))) + > (rule + > (deps (glob_files output/*.txt)) + > (target level1) + > (action (bash "echo %{deps}; ls output > level1"))) + > (rule + > (deps (glob_files output/subdir/*)) + > (target level2) + > (action (bash "echo %{deps}; ls output/subdir > level2"))) + > EOF + +Note: %{deps} expands to the set of generated files that match the glob [*.txt], +however, the action currently has access to all of the paths, along with any of +the subdirectories included into the directory target. + +# CR-someday amokhov: Remove the files that action didn't depend on. + + $ dune build level1 + bash level1 + output/a.txt output/b.txt + + $ cat _build/default/level1 + a.txt + b.txt + c + subdir + +Depending on a glob in a subdirectory of a directory target works too. + + $ dune build level2 + bash level2 + output/subdir/d.txt output/subdir/e + $ cat _build/default/level2 + d.txt + e + +Depending on a directory target directly (rather than on individual files) works +too. Note that this can be achieved in two ways: + +(1) By depending on the recursively computed digest of the directory's contents; + +(2) By depending on the mtime of the directory. + +Currently Dune implements (2) but we'd like to switch to (1) because it supports +the early cutoff optimisation and is also more reliable. + +The [src_c] dependency is unused in the rule's action but we use it to force the +rule to rerun when needed. + +# CR-someday amokhov: Right now we accept simply "output" as a dependency +# specification, which is inconsistent with the target specification. This +# should be fixed, i.e. we should require "(dir output)" instead. + + $ cat > dune < (rule + > (deps src_a src_b src_c (sandbox always)) + > (targets (dir output)) + > (action (bash "\| echo running; + > "\| mkdir -p output/subdir; + > "\| cat src_a > output/a; + > "\| cat src_b > output/subdir/b + > ))) + > (rule + > (deps output) + > (target contents) + > (action (bash "echo running; echo 'a:' > contents; cat output/a >> contents; echo 'b:' >> contents; cat output/subdir/b >> contents"))) + > EOF + + $ echo a > src_a + $ echo b > src_b + $ echo c > src_c + $ dune build contents + bash output + running + bash contents + running + $ cat _build/default/contents + a: + a + b: + b + +We wait for the file system's clock to advance to make sure the directory's +mtime changes when the rule reruns. We can delete this when switching to (1). + + $ dune_cmd wait-for-fs-clock-to-advance + $ echo new-b > src_b + + $ dune build contents + bash output + running + bash contents + running + $ cat _build/default/contents + a: + a + b: + new-b + +There is no early cutoff on directory targets at the moment. Ideally, we should +skip the second action since the produced directory has the same contents. + + $ echo new-cc > src_c + $ dune build contents + bash output + running + bash contents + running + $ cat _build/default/contents + a: + a + b: + new-b + +There is no shared cache support for directory targets at the moment. Note that +we rerun both actions: the first one because there is no shared cache support +and the second one because of the lack of early cutoff. + + $ rm _build/default/output/a + $ dune build contents + bash output + running + bash contents + running + +Check that Dune clears stale files from directory targets. + + $ cat > dune < (rule + > (deps src_a src_b src_c (sandbox always)) + > (targets (dir output)) + > (action (bash "\| echo running; + > "\| mkdir -p output/subdir; + > "\| cat src_a > output/new-a; + > "\| cat src_b > output/subdir/b + > ))) + > (rule + > (deps output) + > (target contents) + > (action (bash "echo running; echo 'new-a:' > contents; cat output/new-a >> contents; echo 'b:' >> contents; cat output/subdir/b >> contents"))) + > EOF + + $ dune build contents + bash output + running + bash contents + running + +Note that the stale "output/a" file got removed. + + $ ls _build/default/output | sort + new-a + subdir + +Directory target whose name conflicts with an internal directory used by Dune. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets (dir .dune)) + > (action (bash "mkdir .dune; echo hello > .dune/hello"))) + > EOF + + $ dune build .dune/hello + File "dune", line 1, characters 0-114: + 1 | (rule + 2 | (deps (sandbox always)) + 3 | (targets (dir .dune)) + 4 | (action (bash "mkdir .dune; echo hello > .dune/hello"))) + Error: This rule defines a directory target ".dune" whose name conflicts with + an internal directory used by Dune. Please use a different name. + -> required by _build/default/.dune/hello + [1] + +Multi-component target directories are not allowed. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets (dir output/subdir)) + > (action (bash "mkdir output; echo x > output/x; echo y > output/y"))) + > EOF + + $ dune build output/x + File "dune", line 3, characters 16-29: + 3 | (targets (dir output/subdir)) + ^^^^^^^^^^^^^ + Error: Directory targets must have exactly one path component. + [1] + +File and directory target with the same name. + + $ cat > dune < (rule + > (deps (sandbox always)) + > (targets output (dir output)) + > (action (bash "mkdir output; echo x > output/x; echo y > output/y"))) + > EOF + + $ dune build output/x + File "dune", line 1, characters 0-135: + 1 | (rule + 2 | (deps (sandbox always)) + 3 | (targets output (dir output)) + 4 | (action (bash "mkdir output; echo x > output/x; echo y > output/y"))) + Error: "output" is declared as both a file and a directory target. + [1] diff --git a/test/blackbox-tests/test-cases/glob-deps.t/run.t b/test/blackbox-tests/test-cases/glob-deps.t/run.t index 8577438597b..c2de65af94c 100644 --- a/test/blackbox-tests/test-cases/glob-deps.t/run.t +++ b/test/blackbox-tests/test-cases/glob-deps.t/run.t @@ -1,2 +1,10 @@ $ dune build @glob | dune_cmd sanitize foo/dune foo/foo$ext_lib foo/foo.cma foo/foo.cmxa foo/foo.cmxs foo/foo.ml + +Globs do not match directories, so in the test below, [foo/new-file] is added +to the output but [foo/new-dir] is ignored. + + $ touch foo/new-file + $ mkdir foo/new-dir + $ dune build @glob | dune_cmd sanitize + foo/dune foo/foo$ext_lib foo/foo.cma foo/foo.cmxa foo/foo.cmxs foo/foo.ml foo/new-file