From 86bed0492f54e392301a7b17c49f6a7efcbe5cce Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sat, 5 Sep 2026 23:19:37 +0100 Subject: [PATCH] feat(action-plugin): restore dynamic actions from the shared cache Replay recorded file and glob dependency requests before restoring outputs in a fresh workspace. Key each next request by the facts observed so far, so changed inputs stop replay before obsolete requests are evaluated. Store discovery manifests using ordinary cache entries. Missing or corrupt metadata is a miss. Keep sandboxed dynamic actions excluded and leave the extended observation APIs and package-inference integration for follow-up. Signed-off-by: Rudi Grinberg --- .../action-plugin/one-dependency/bin/foo.ml | 8 + .../test/action-plugin/one-dependency/cache.t | 171 +++++++++++++++++- src/dune_cache/local.ml | 15 +- src/dune_cache/local.mli | 2 + src/dune_cache/shared.ml | 48 +++++ src/dune_cache/shared.mli | 8 + src/dune_digest/digest.mli | 2 + src/dune_engine/build_system.ml | 52 +++--- src/dune_engine/rule_cache.ml | 152 ++++++++++++++++ src/dune_engine/rule_cache.mli | 12 ++ src/predicate_lang/predicate_lang.ml | 38 ++++ src/predicate_lang/predicate_lang.mli | 4 + test/expect-tests/dep_tests.ml | 44 +++++ test/expect-tests/dep_tests.mli | 0 test/expect-tests/digest/digest_tests.ml | 25 +++ test/expect-tests/dune | 1 + 16 files changed, 550 insertions(+), 32 deletions(-) create mode 100644 test/expect-tests/dep_tests.ml create mode 100644 test/expect-tests/dep_tests.mli diff --git a/otherlibs/dune-rpc-lwt/test/action-plugin/one-dependency/bin/foo.ml b/otherlibs/dune-rpc-lwt/test/action-plugin/one-dependency/bin/foo.ml index af4f1d47bb8..d68aa41e75b 100644 --- a/otherlibs/dune-rpc-lwt/test/action-plugin/one-dependency/bin/foo.ml +++ b/otherlibs/dune-rpc-lwt/test/action-plugin/one-dependency/bin/foo.ml @@ -145,6 +145,14 @@ let action dap = | _ -> failwith "helper failed") | [| _ |] -> ordinary_action dap ~path:"some_dependency" | [| _; "read"; path |] -> ordinary_action dap ~path + | [| _; "choose" |] -> + let open Lwt.Syntax in + let* path = read_file dap ~path:"choice" in + ordinary_action dap ~path:(String.trim path) + | [| _; "glob"; path; pattern |] -> + let open Lwt.Syntax in + let* files = read_directory_with_glob dap ~path ~glob:(Glob.of_string pattern) in + Lwt_list.iter_s Lwt_io.printl files | [| _; "sandbox" |] -> sandbox_action dap | [| _; "detached"; state |] -> detached_action dap state | [| _; "hold"; connection; release |] -> held_action dap ~connection ~release diff --git a/otherlibs/dune-rpc-lwt/test/action-plugin/one-dependency/cache.t b/otherlibs/dune-rpc-lwt/test/action-plugin/one-dependency/cache.t index dfe6ab34d1a..cc6cccf539f 100644 --- a/otherlibs/dune-rpc-lwt/test/action-plugin/one-dependency/cache.t +++ b/otherlibs/dune-rpc-lwt/test/action-plugin/one-dependency/cache.t @@ -1,7 +1,9 @@ -Dynamic actions currently rerun in a fresh workspace even with a shared cache. +A fresh workspace replays dependency discovery before restoring dynamic outputs. +The cache trace reports discovery misses as well as artifact misses. $ export DUNE_CACHE_ROOT="$PWD/.cache" $ export DUNE_CACHE=enabled + $ export DUNE_TRACE=+cache $ mkdir template $ cp bin/foo.exe template/ $ cat > template/dune-project <<'EOF' @@ -21,11 +23,176 @@ Dynamic actions currently rerun in a fresh workspace even with a shared cache. > | select(.args.prog | endswith("foo.exe")) > | .args | {prog: (.prog | split("/") | last), process_args, exit}' > } + $ show_misses () { + > dune trace cat | jq -c ' + > select(.cat == "cache" and .name == "miss") + > | select(.args.head | endswith("/output")) + > | {name, reason: .args.reason}' + > } $ cp -R template first $ (cd first && dune build --root . output && show_runs) {"prog":"foo.exe","process_args":["read","input"],"exit":0} + $ (cd first && show_misses) + {"name":"miss","reason":"dynamic dependency manifest unavailable"} $ cp -R template second $ (cd second && dune build --root . output && show_runs) - {"prog":"foo.exe","process_args":["read","input"],"exit":0} + $ (cd second && show_misses) $ cat second/_build/default/output first + +Changed inputs select a new branch; old branches remain reusable. + + $ printf changed > template/source + $ cp -R template changed + $ (cd changed && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["read","input"],"exit":0} + $ cat changed/_build/default/output + changed + $ (cd changed && show_misses) + {"name":"miss","reason":"dynamic dependency manifest unavailable"} + $ cp -R template changed-again + $ (cd changed-again && dune build --root . output && show_runs) + $ printf first > template/source + $ cp -R template old-branch + $ (cd old-branch && dune build --root . output && show_runs) + +A shared hit also populates the workspace cache with the dynamic dependencies. + + $ (cd second && dune build --root . output && show_runs) + $ printf local-change > second/source + $ (cd second && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["read","input"],"exit":0} + $ cat second/_build/default/output + local-change + +Copy-mode storage works too. + + $ export DUNE_CACHE_STORAGE_MODE=copy + $ printf copy-mode > template/source + $ cp -R template copy-first + $ (cd copy-first && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["read","input"],"exit":0} + $ cp -R template copy-again + $ (cd copy-again && dune build --root . output && show_runs) + $ cat copy-again/_build/default/output + copy-mode + +Artifact lookup already reports misses for reproducibility checks. + + $ cp -R template check + $ (cd check && dune build --root . output --cache-check-probability=1.0 && show_misses) + {"name":"miss","reason":"rerunning for reproducibility check"} + +An earlier request can select a different dependency. Replay must stop before +trying to build the now-absent input from the old branch. + + $ cat > template/dune <<'EOF' + > (rule + > (target output) + > (action (with-stdout-to output (dynamic-run ./foo.exe choose)))) + > EOF + $ printf left > template/choice + $ printf left-value > template/left + $ cp -R template choose-left + $ (cd choose-left && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["choose"],"exit":0} + $ printf right > template/choice + $ rm template/left + $ printf right-value > template/right + $ cp -R template choose-right + $ (cd choose-right && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["choose"],"exit":0} + $ cat choose-right/_build/default/output + right-value + $ cp -R template choose-again + $ (cd choose-again && dune build --root . output && show_runs) + +Glob requests are replayed, including changes to matching files and names. + + $ cat > template/dune <<'EOF' + > (rule (target listed-generated) (action (write-file listed-generated generated))) + > (rule + > (target output) + > (action (with-stdout-to output (dynamic-run ./foo.exe glob . listed*)))) + > EOF + $ printf one > template/listed-source + $ cp -R template glob-first + $ (cd glob-first && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["glob",".","listed*"],"exit":0} + $ cp -R template glob-again + $ (cd glob-again && dune build --root . output && show_runs) + $ cat glob-again/_build/default/output + listed-generated + listed-source + $ printf two > template/listed-source + $ cp -R template glob-changed + $ (cd glob-changed && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["glob",".","listed*"],"exit":0} + $ printf extra > template/listed-added + $ cp -R template glob-added + $ (cd glob-added && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["glob",".","listed*"],"exit":0} + $ cat glob-added/_build/default/output + listed-added + listed-generated + listed-source + +A syntactically valid payload with an invalid manifest shape is also a miss. + + $ grep -rl '^[(]4:deps' "$DUNE_CACHE_ROOT/db/files" | while read entry; do + > chmod u+w "$entry" + > printf '(7:unknown())' > "$entry" + > done + $ cp -R template invalid-manifest + $ (cd invalid-manifest && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["glob",".","listed*"],"exit":0} + $ (cd invalid-manifest && show_misses) + {"name":"miss","reason":"dynamic dependency manifest unavailable"} + $ cat invalid-manifest/_build/default/output + listed-added + listed-generated + listed-source + +Ordinary trimming reclaims both manifest payloads and their metadata. + + $ grep -rl '.dap-manifest' "$DUNE_CACHE_ROOT/db/meta" > /dev/null + $ dune cache trim --size 0B > /dev/null + $ grep -rl '.dap-manifest' "$DUNE_CACHE_ROOT/db/meta" + [1] + $ cp -R template trimmed + $ (cd trimmed && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["glob",".","listed*"],"exit":0} + $ (cd trimmed && show_misses) + {"name":"miss","reason":"dynamic dependency manifest unavailable"} + +Corrupt discovery metadata is a miss, even when its artifacts remain cached. + + $ grep -rl '.dap-manifest' "$DUNE_CACHE_ROOT/db/meta" | while read entry; do + > chmod u+w "$entry" + > printf broken > "$entry" + > done + $ cp -R template corrupt + $ (cd corrupt && dune build --root . output && show_runs) + {"prog":"foo.exe","process_args":["glob",".","listed*"],"exit":0} + $ cat corrupt/_build/default/output + listed-added + listed-generated + listed-source + $ (cd corrupt && show_misses) + {"name":"miss","reason":"dynamic dependency manifest unavailable"} + +Disabled caching and sandbox exclusion also report why no shared hit is possible. + + $ cp -R template disabled + $ (cd disabled && DUNE_CACHE=disabled dune build --root . output && show_misses) + {"name":"miss","reason":"can't go in shared cache"} + $ cat > template/dune <<'EOF' + > (rule (target listed-generated) (action (write-file listed-generated generated))) + > (rule + > (target output) + > (deps (sandbox always)) + > (action (with-stdout-to output (dynamic-run ./foo.exe glob . listed*)))) + > EOF + $ cp -R template sandboxed + $ (cd sandboxed && dune build --root . output --sandbox=hardlink && show_misses) + {"name":"miss","reason":"can't go in shared cache"} diff --git a/src/dune_cache/local.ml b/src/dune_cache/local.ml index 4d76030afc9..f7f94d7aced 100644 --- a/src/dune_cache/local.ml +++ b/src/dune_cache/local.ml @@ -57,15 +57,20 @@ let restore_file_content path : string Restore_result.t = Error e ;; -let restore_metadata_file file ~of_sexp : _ Restore_result.t = +let restore_sexp file = restore_file_content file |> Restore_result.bind ~f:(fun content -> match Csexp.parse_string content with | Error (_offset, msg) -> Error (Failure msg) - | Ok sexp -> - (match of_sexp sexp with - | Ok content -> Restored content - | Error e -> Error e)) + | Ok sexp -> Restored sexp) +;; + +let restore_metadata_file file ~of_sexp : _ Restore_result.t = + restore_sexp file + |> Restore_result.bind ~f:(fun sexp -> + match of_sexp sexp with + | Ok content -> Restored content + | Error e -> Error e) ;; module Artifacts = struct diff --git a/src/dune_cache/local.mli b/src/dune_cache/local.mli index 94341af564a..95f78eb369b 100644 --- a/src/dune_cache/local.mli +++ b/src/dune_cache/local.mli @@ -41,6 +41,8 @@ module Restore_result : sig val bind : 'a t -> f:('a -> 'b t) -> 'b t end +val restore_sexp : Path.t -> Sexp.t Restore_result.t + (** An [Artifacts] entry corresponds to the targets produced by an action. *) module Artifacts : sig module Metadata_entry : sig diff --git a/src/dune_cache/shared.ml b/src/dune_cache/shared.ml index f83413838d4..631660d4a3d 100644 --- a/src/dune_cache/shared.ml +++ b/src/dune_cache/shared.ml @@ -9,6 +9,54 @@ let config = ref Config.Disabled open Import +module Dynamic_deps = struct + let manifest_path = Path.Local.of_string ".dap-manifest" + + let load ~rule_digest = + match !config with + | Disabled -> None + | Enabled _ -> + (match Artifacts.list ~rule_digest with + | Restored [ { Artifacts.Metadata_entry.path; digest = Some digest } ] + when Path.Local.equal path manifest_path -> + (match + Local.restore_sexp (Lazy.force (Layout.file_path ~file_digest:digest)) + with + | Restored value -> Some value + | Not_found_in_cache | Error _ -> None) + | Restored _ | Not_found_in_cache | Error _ -> None) + ;; + + let store ~rule_digest manifest = + match !config with + | Disabled -> () + | Enabled { storage_mode = mode; _ } -> + let content = Csexp.to_string manifest in + let digest = + Digest.path_with_executable_bit + ~executable:false + ~content_digest:(Digest.string content) + in + (match + match + let dst = Lazy.force (Layout.file_path ~file_digest:digest) in + Util.write_atomically ~mode ~content dst + with + | Error exn -> Store_result.Error exn + | Ok | Already_present -> + Artifacts.Metadata_file.store + [ { Artifacts.Metadata_entry.path = manifest_path; digest = Some digest } ] + ~mode + ~rule_digest + with + | Stored | Already_present | Will_not_store_due_to_non_determinism _ -> () + | Error exn -> + Log.info + "Unable to store dynamic dependency manifest" + [ "error", Dyn.string (Printexc.to_string exn) ]) + ;; +end + module Store_artifacts_result = struct type t = | Stored of Digest.t Targets.Produced.t diff --git a/src/dune_cache/shared.mli b/src/dune_cache/shared.mli index 5d49016fdbf..5d2e3413252 100644 --- a/src/dune_cache/shared.mli +++ b/src/dune_cache/shared.mli @@ -6,6 +6,14 @@ open Import artifacts produced in different workspaces. To restore results from the shared cache, Dune copes or hardlinks them into the build directory. *) +module Dynamic_deps : sig + (** Dependency manifests use ordinary cache entries so that trimming and + concurrent writes follow the same rules as build artifacts. *) + val load : rule_digest:Digest.t -> Sexp.t option + + val store : rule_digest:Digest.t -> Sexp.t -> unit +end + (** Check if the shared cache contains results for a rule and decide whether to use these results or rerun the rule for a reproducibility check. *) val lookup diff --git a/src/dune_digest/digest.mli b/src/dune_digest/digest.mli index 8a3eacb364e..0386b41a0b8 100644 --- a/src/dune_digest/digest.mli +++ b/src/dune_digest/digest.mli @@ -117,3 +117,5 @@ val path_with_stats_async number of concurrent calls capped by a global throttle so that we do not exceed the process's open file descriptor limit. *) val file_with_executable_bit : executable:bool -> Path.t -> t Fiber.t + +val path_with_executable_bit : executable:bool -> content_digest:t -> t diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index 5d9c59e7b67..c6ca2ed8cb8 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -644,10 +644,8 @@ module Internal = struct in let can_go_in_shared_cache = props.can_go_in_shared_cache - && (not - (always_rerun - || is_action_dynamic - || Action.is_useful_to_memoize action_ast = Clearly_not)) + && (not (always_rerun || Action.is_useful_to_memoize action_ast = Clearly_not)) + && ((not is_action_dynamic) || Option.is_none sandbox_mode) && match sandbox_mode with | Some Patch_back_source_tree -> @@ -694,17 +692,16 @@ module Internal = struct in let* produced_targets, dynamic_deps_stages = (* Step III. Try to restore artifacts from the shared cache. *) - Dune_cache.Shared.lookup ~can_go_in_shared_cache ~rule_digest ~targets - >>= function - | Some produced_targets -> - (* Rules with dynamic deps can't be stored to the shared cache - (see the [is_action_dynamic] check above), so we know this is - not a dynamic action, so returning an empty list is correct. - The lack of information to fill in [dynamic_deps_stages] here - is precisely the reason why we don't store dynamic actions in - the shared cache. *) - let dynamic_deps_stages = [] in - Fiber.return (produced_targets, dynamic_deps_stages) + let* restored = + if is_action_dynamic && can_go_in_shared_cache + then + Rule_cache.Dynamic.lookup ~rule_digest ~targets ~env:props.env ~build_deps + else + Dune_cache.Shared.lookup ~can_go_in_shared_cache ~rule_digest ~targets + >>| Option.map ~f:(fun targets -> targets, []) + in + match restored with + | Some restored -> Fiber.return restored | None -> (* Step IV. Execute the build action. *) let loc = Rule.loc rule in @@ -719,15 +716,6 @@ module Internal = struct ~sandbox_mode ~targets in - (* Step V. Examine produced targets and store them to the shared - cache if needed. *) - let* produced_targets = - Dune_cache.Shared.examine_targets_and_store - ~can_go_in_shared_cache - ~loc - ~rule_digest - ~produced_targets:exec_result.produced_targets - in let dynamic_deps_stages = List.map exec_result.action_exec_result.dynamic_deps_stages @@ -737,7 +725,21 @@ module Internal = struct Dep.Facts.digest fact_map d ~env:props.env; Digest.Manual.get d )) in - Fiber.return (produced_targets, dynamic_deps_stages) + let+ produced_targets = + (* Step V. Examine produced targets and store them to the shared + cache if needed. *) + let cache_key = + if is_action_dynamic && can_go_in_shared_cache + then Rule_cache.Dynamic.store ~rule_digest ~stages:dynamic_deps_stages + else rule_digest + in + Dune_cache.Shared.examine_targets_and_store + ~can_go_in_shared_cache + ~loc + ~rule_digest:cache_key + ~produced_targets:exec_result.produced_targets + in + produced_targets, dynamic_deps_stages in (* We do not include target names into [targets_digest] because they are already included into the rule digest. *) diff --git a/src/dune_engine/rule_cache.ml b/src/dune_engine/rule_cache.ml index adbb9dd4502..d6894659090 100644 --- a/src/dune_engine/rule_cache.ml +++ b/src/dune_engine/rule_cache.ml @@ -1,6 +1,158 @@ open Import open Dune_cache.Hit_or_miss +module Dynamic = struct + open Fiber.O + + let conv = + let open Conv in + let build_path = + iso + string + (fun path -> Path.Build.of_local (Path.Local.of_string path)) + (fun path -> Path.Local.to_string (Path.Build.local path)) + in + let path = + let build = constr "build" build_path Path.build in + let source = + constr + "source" + (iso string Path.Source.of_string Path.Source.to_string) + Path.source + in + let external_ = + constr + "external" + (iso string Path.External.of_string Path.External.to_string) + Path.external_ + in + sum + [ econstr build; econstr source; econstr external_ ] + (function + | Path.In_build_dir path -> case path build + | In_source_tree path -> case path source + | External path -> case path external_) + in + let selector = + iso + (triple path (enum [ "true", true; "false", false ]) Predicate_lang.Glob.conv) + (fun (dir, only_generated_files, predicate) -> + File_selector.of_predicate_lang ~dir ~only_generated_files predicate) + (fun selector -> + ( File_selector.dir selector + , File_selector.only_generated_files selector + , File_selector.predicate selector )) + in + let dep = + let file = constr "file" path Dep.file in + let env = constr "env" string (fun var -> Dep.env (Env.Var.of_string var)) in + let alias = + constr "alias" (pair build_path string) (fun (dir, name) -> + Dep.alias (Alias.make (Alias.Name.of_string name) ~dir)) + in + let glob = constr "glob" selector Dep.file_selector in + sum + [ econstr file; econstr env; econstr alias; econstr glob ] + (function + | Dep.File path -> case path file + | Env var -> case (Env.Var.to_string var) env + | Alias value -> + case (Alias.dir value, Alias.Name.to_string (Alias.name value)) alias + | File_selector selector -> case selector glob + | Universe -> Code_error.raise "Cannot serialize a universe dependency" []) + in + let deps = + constr + "deps" + (iso (list dep) Dep.Set.of_list Dep.Set.to_list) + (fun deps -> `Deps deps) + in + let done_ = constr "done" unit (fun () -> `Done) in + sum + [ econstr deps; econstr done_ ] + (function + | `Deps values -> case values deps + | `Done -> case () done_) + ;; + + let initial rule_digest = + Digest.Feed.compute_digest + (Digest.Feed.tuple2 Digest.Feed.string Digest.Feed.digest) + ("dynamic-dependency-manifest-v2", rule_digest) + ;; + + let artifact_key key = + Digest.Feed.compute_digest + (Digest.Feed.tuple2 Digest.Feed.string Digest.Feed.digest) + ("dynamic-artifacts-v1", key) + ;; + + let advance key deps digest = + let d = Digest.Manual.create () in + Digest.Manual.string d "dynamic-dependency-step-v1"; + Digest.Manual.digest d key; + Dep.Set.digest deps d; + Digest.Manual.digest d digest; + Digest.Manual.get d + ;; + + let facts_digest facts ~env = + let d = Digest.Manual.create () in + Dep.Facts.digest facts d ~env; + Digest.Manual.get d + ;; + + (* Each node describes the next request. Its observed facts select the next + node, so a changed observation never evaluates obsolete later requests. + Missing nodes (including partially trimmed traces) are ordinary misses. *) + let lookup ~rule_digest ~targets ~env ~build_deps = + let rec loop key stages = + match + Dune_cache.Shared.Dynamic_deps.load ~rule_digest:key + |> Option.bind ~f:(fun sexp -> + Conv.of_sexp conv ~version:(0, 0) sexp |> Result.to_option) + with + | None -> + Dune_trace.emit ~buffered:true Cache (fun () -> + let reason = + match !Dune_cache.Shared.config with + | Disabled -> "cache disabled" + | Enabled _ -> "dynamic dependency manifest unavailable" + in + Dune_trace.Event.Cache.shared + (`Miss reason) + ~rule_digest:(Digest.to_string key) + ~head:(Targets.Validated.head targets)); + Fiber.return None + | Some `Done -> + Dune_cache.Shared.lookup + ~can_go_in_shared_cache:true + ~rule_digest:(artifact_key key) + ~targets + >>| Option.map ~f:(fun targets -> targets, List.rev stages) + | Some (`Deps deps) -> + let* digest = build_deps deps |> Memo.run >>| facts_digest ~env in + loop (advance key deps digest) ((deps, digest) :: stages) + in + loop (initial rule_digest) [] + ;; + + let store ~rule_digest ~stages = + let rec loop key = function + | [] -> + Dune_cache.Shared.Dynamic_deps.store ~rule_digest:key (Conv.to_sexp conv `Done); + artifact_key key + | (deps, digest) :: rest -> + let manifest = Conv.to_sexp conv (`Deps deps) in + Dune_cache.Shared.Dynamic_deps.store ~rule_digest:key manifest; + loop (advance key deps digest) rest + in + match !Dune_cache.Shared.config with + | Disabled -> rule_digest + | Enabled _ -> loop (initial rule_digest) stages + ;; +end + module Workspace_local = struct (* Stores information for deciding if a rule needs to be re-executed. *) module Database = struct diff --git a/src/dune_engine/rule_cache.mli b/src/dune_engine/rule_cache.mli index cd42bf5cded..20f69c81805 100644 --- a/src/dune_engine/rule_cache.mli +++ b/src/dune_engine/rule_cache.mli @@ -2,6 +2,18 @@ open Import +module Dynamic : sig + val lookup + : rule_digest:Digest.t + -> targets:Targets.Validated.t + -> env:Env.t + -> build_deps:(Dep.Set.t -> Dep.Facts.t Memo.t) + -> (Digest.t Targets.Produced.t * (Dep.Set.t * Digest.t) list) option Fiber.t + + (** Store the discovery trace and return its artifact key. *) + val store : rule_digest:Digest.t -> stages:(Dep.Set.t * Digest.t) list -> Digest.t +end + (** The workspace-local cache consists of two components: - Build artifacts currently available in the build directory. diff --git a/src/predicate_lang/predicate_lang.ml b/src/predicate_lang/predicate_lang.ml index c48277ef508..5e8a5d2c093 100644 --- a/src/predicate_lang/predicate_lang.ml +++ b/src/predicate_lang/predicate_lang.ml @@ -294,6 +294,44 @@ module Glob = struct let compare x y = compare Element.compare x y let equal x y = Ordering.is_eq (compare x y) let hash t = Poly.hash t + + let conv = + let open Stdune.Conv in + fixpoint (fun predicate -> + let true_ = constr "true" unit (fun () -> True) in + let false_ = constr "false" unit (fun () -> False) in + let standard = constr "standard" unit (fun () -> Standard) in + let literal = constr "literal" string (fun s -> Element (Element.Literal s)) in + let glob = + constr "glob" string (fun s -> + let glob = Element.Proxy.of_string s in + let (_ : Glob.t) = Element.unproxy glob in + Element (Element.Glob glob)) + in + let not = constr "not" predicate (fun predicate -> Not predicate) in + let or_ = constr "or" (list predicate) (fun predicates -> Or predicates) in + let and_ = constr "and" (list predicate) (fun predicates -> And predicates) in + sum + [ econstr true_ + ; econstr false_ + ; econstr standard + ; econstr literal + ; econstr glob + ; econstr not + ; econstr or_ + ; econstr and_ + ] + (function + | True -> case () true_ + | False -> case () false_ + | Standard -> case () standard + | Element (Literal s) -> case s literal + | Element (Glob { repr; _ }) -> case repr glob + | Not predicate -> case predicate not + | Or predicates -> case predicates or_ + | And predicates -> case predicates and_)) + ;; + let decode = decode Element.decode let encode t = encode Element.encode t let digest t = Dune_digest.repr repr t diff --git a/src/predicate_lang/predicate_lang.mli b/src/predicate_lang/predicate_lang.mli index 4946e043816..eb59a6207a6 100644 --- a/src/predicate_lang/predicate_lang.mli +++ b/src/predicate_lang/predicate_lang.mli @@ -45,6 +45,10 @@ module Glob : sig val compare : t -> t -> Ordering.t val equal : t -> t -> bool val hash : t -> int + + (** Lossless encoding, preserving literal names versus glob patterns. *) + val conv : t Stdune.Conv.value + val decode : t Dune_sexp.Decoder.t val encode : t -> Dune_sexp.t val digest : t -> Dune_digest.t diff --git a/test/expect-tests/dep_tests.ml b/test/expect-tests/dep_tests.ml new file mode 100644 index 00000000000..2bb249e3f28 --- /dev/null +++ b/test/expect-tests/dep_tests.ml @@ -0,0 +1,44 @@ +open Stdune + +let%expect_test "predicate manifests preserve their exact representation" = + let open Predicate_lang in + let literal = Glob.of_string_list [ "a[*]"; "a\nb" ] in + let predicates = + [ true_ + ; false_ + ; standard + ; literal + ; Glob.of_glob (Dune_lang.Glob.of_string "a*") + ; not literal + ; and_ [ literal; standard ] + ; or_ [ literal; standard ] + ; of_list [] + ; not (or_ [ and_ [ literal; standard ]; not literal ]) + ] + in + let roundtrips = + List.for_all predicates ~f:(fun original -> + match Conv.of_sexp Glob.conv ~version:(0, 0) (Conv.to_sexp Glob.conv original) with + | Error _ -> false + | Ok restored -> Glob.equal original restored) + in + Printf.printf "roundtrips: %b\n" roundtrips; + let invalid = + let open Sexp in + [ Atom "invalid" + ; List [ Atom "true"; Atom "extra" ] + ; List [ Atom "not"; Atom "invalid" ] + ; List [ Atom "or"; List [ Atom "invalid" ] ] + ; List [ Atom "literal"; List [] ] + ] + in + Printf.printf + "invalid: %b\n" + (List.for_all invalid ~f:(fun sexp -> + Result.is_error (Conv.of_sexp Glob.conv ~version:(0, 0) sexp))); + [%expect + {| + roundtrips: true + invalid: true + |}] +;; diff --git a/test/expect-tests/dep_tests.mli b/test/expect-tests/dep_tests.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/test/expect-tests/digest/digest_tests.ml b/test/expect-tests/digest/digest_tests.ml index 0a69d4b238b..be47f61a803 100644 --- a/test/expect-tests/digest/digest_tests.ml +++ b/test/expect-tests/digest/digest_tests.ml @@ -38,6 +38,31 @@ let%expect_test "directories with symlinks" = [%expect {| [PASS] |}] ;; +let%expect_test "file digest from in-memory contents" = + let path = Temp.create File ~prefix:"digest-tests" ~suffix:"" in + List.iter [ ""; "(4:done())"; "\000\255\r\n" ] ~f:(fun content -> + Io.write_file ~binary:true path content; + List.iter [ false; true ] ~f:(fun executable -> + let expected = + Digest.path_with_executable_bit + ~executable + ~content_digest:(Digest.string content) + in + let stats = { Digest.Stats_for_digest.st_kind = S_REG; executable } in + match Digest.path_with_stats ~allow_dirs:false path stats with + | Ok actual -> print_endline (Bool.to_string (Digest.equal expected actual)) + | Error _ -> print_endline "unable to digest file")); + [%expect + {| + true + true + true + true + true + true + |}] +;; + let encode_int i = let i = Int64.of_int i in String.init 8 ~f:(fun byte -> diff --git a/test/expect-tests/dune b/test/expect-tests/dune index 51791d0868c..5280da99269 100644 --- a/test/expect-tests/dune +++ b/test/expect-tests/dune @@ -20,6 +20,7 @@ source fiber dune_lang + predicate_lang ocaml memo unix