Source file ContextC.ml

(** The core components of the reference implementation build engine.

    {3 Implementors of build engine}

    You will want to first read
    {{:https://discuss.ocaml.org/t/ocaml-version-of-the-build-systems-a-la-carte-paper/17042}OCaml
     version of the “Build systems à la carte” paper} first. For thunks we use
    the term "build engine", but it is interchangeable with the term "build
    system" used in the paper.

    The reference build engine uses the same components as
    ["tests/MlFront_Thunk/alacarte_6_4_test.ml"] to aid in understanding. We use
    comments to say where we diverge and also use comments to say what your own
    implementation should be doing for efficiency (etc.).

    {3 Basic Design}

    The ["*.values.json"] build files are input files. Each build file will have
    a input {!Alacarte_3_2_apparatus.SourceFormKind} key, and more keys of
    {!Alacarte_3_2_apparatus.SourceAssetKind} or
    {!Alacarte_3_2_apparatus.SourceAssetKind} are made if the build file has
    assets and bundle files. These build files are part of the
    {!Alacarte_3_2_apparatus.StoreInfo}, so the build files must be scanned
    before a store is initialized. These input keys are {i not} selected by the
    user on the command line or inside a form.

    Tasks for keys {!Alacarte_3_2_apparatus.UserObjectKind},
    {!Alacarte_3_2_apparatus.UserAssetKind} and
    {!Alacarte_3_2_apparatus.UserAssetKind} are created from the build files
    when the set of tasks are initially assembled. These keys are selectable by
    the user on the command line or inside a form. The task assembly happens
    after the store is initialized so the tasks can "depend" on the input keys
    (ex. {!Alacarte_3_2_apparatus.UserObjectKind} depends on a
    {!Alacarte_3_2_apparatus.SourceFormKind} key). And even though the initial
    task assembly happens before the build system is given a target key, the
    tasks are mutable and can be added on-demand (ie. when a form creates a
    dynamic task). *)

let dk_prog = "dk"

(** Any change to the specification of [".values.json"] or change to reference
    implementation that would result in an invalid value store requires a change
    to the values version. *)
let values_version = "0.1.1"

let (_ :
      [ `DeadbadChecksumForZipEntryButNeedBetter of Fmlib_parse.Position.range ])
    =
  DkZero_Base.BuildToDo
  .asset_range_download_of_zip_entry_from_zip_index_needs_a_secure_checksum
    Fmlib_parse.Position.(start, start)

open struct
  let alwaystrace = false
end

module MakeInitObserver =
  MlFront_Thunk.ThunkParsers.Results.MakeObserverWithDiagnoseErrors
    (MlFront_Thunk.Diagnose.Diagnose.ConsolePlainStyle)

module Impl = struct
  type install_params = { program : string }

  module Promise = MlFront_Thunk.Promises.PromiseMinimal

  module Log = struct
    let src = Logs.Src.create "dk0.runtimec" ~doc:"logs dk0 events"

    module L = (val Logs.src_log src : Logs.LOG)

    type 'a t = ('a, unit Promise.t) Logs.msgf -> unit Promise.t

    (*---------------------------------------------------------------------------
      Copyright (c) 2015 The logs programmers. All rights reserved.
      SPDX-License-Identifier: ISC
      ---------------------------------------------------------------------------*)
    (* https://github.com/dbuenzli/logs/blob/350985691e41c4be23b3aadd0e875af669dfc702/src/lwt/logs_lwt.ml *)
    (* Changes: Use [Promise] not [Lwt] *)

    (* Changes: Use [src = src] not [src = Logs.default] *)
    let kmsg k ?(src = src) level msgf =
      begin
        match level with
        | Logs.Error -> Logs.incr_err_count ()
        | Logs.Warning -> Logs.incr_warn_count ()
        | _ -> ()
      end;
      match Logs.Src.level src with
      | None -> k ()
      | Some current_level when level > current_level -> k ()
      | Some _ ->
          let over () = () in
          Logs.report src level ~over k msgf

    let kunit _ = Promise.return ()
    let msg ?src level msgf = kmsg kunit ?src level msgf
    let app ?src msgf = kmsg kunit ?src Logs.App msgf
    let err ?src msgf = kmsg kunit ?src Logs.Error msgf
    let warn ?src msgf = kmsg kunit ?src Logs.Warning msgf
    let info ?src msgf = kmsg kunit ?src Logs.Info msgf
    let debug ?src msgf = kmsg kunit ?src Logs.Debug msgf

    let on_error ?src ?(level = Logs.Error) ?header ?tags ~pp ~use t =
      Promise.bind t @@ function
      | Ok v -> Promise.return v
      | Error e ->
          kmsg (fun () -> use e) ?src level @@ fun m ->
          m ?header ?tags "@[%a@]" pp e

    let on_error_msg ?src ?(level = Logs.Error) ?header ?tags ~use t =
      Promise.bind t @@ function
      | Ok v -> Promise.return v
      | Error (`Msg e) ->
          kmsg use ?src level @@ fun m ->
          m ?header ?tags "@[%a@]" Format.pp_print_text e
  end

  open struct
    let logtrace =
      let with_info msgf = Log.info ?src:None msgf in
      fun ?trace f ->
        if alwaystrace || trace = Some true then with_info f
        else Promise.return ()
  end

  module Spawner = BuildSpawner.MakeSpawner (Promise)
  module MakeIo = MlFront_Thunk_IoDisk.ThunkIoDisk.Make (Promise)
  module Io = MakeIo (Spawner)
  module SyncSpawner = BuildSpawner.MakeSpawner (Promise)
  module SyncIo = MlFront_Thunk_IoDisk.ThunkIoDisk.Make (Promise) (SyncSpawner)

  module SyncReadDirectory =
    MlFront_Thunk.ThunkIo.MakeSyncDirectoryReader (Promise) (SyncIo) (SyncIo)

  module SyncReadChannel =
    MlFront_Thunk.ThunkIo.MakeSyncChannelReader (Promise) (SyncIo) (SyncIo)

  module SyncWriteChannel =
    MlFront_Thunk.ThunkIo.MakeSyncChannelWriter (Promise) (SyncIo) (SyncIo)

  module FileObject = struct
    type t = Io.file_object

    let file_origin = Io.file_origin
  end

  let disk_file = Io.disk_file
  let disk_dir = Io.disk_dir

  module BuildBuiltins' = DkZero_Base.BuildBuiltins.Make (Io)

  include DkZero_Base.DataModel.Make (FileObject)
  (** Make [K], [O] and [V]. *)

  module KMap = Map.Make (K)

  module StoreMessages = struct
    type k = K.t
    type v = V.t

    type MlFront_Thunk.BuildConstraints.StateMessage.obj +=
      | PostBuildKeyValue of (k * v)

    type MlFront_Thunk.BuildConstraints.StateMessage.obj +=
      | PostBuildKeyValueAndExecuteThunkAfter of k * v * (unit -> unit)
  end

  (** We added command-line configuration flags and promoted [store_info] into a
      module. *)
  module StoreInfo : sig
    type t = private { explain : bool; warnings_during_parsing : bool }

    val create : explain:bool -> warnings_during_parsing:bool -> t
    val explain : t -> bool
    val warnings_during_parsing : t -> bool
  end = struct
    type t = { explain : bool; warnings_during_parsing : bool }

    let create ~explain ~warnings_during_parsing =
      { explain; warnings_during_parsing }

    let explain { explain; _ } = explain

    let warnings_during_parsing { warnings_during_parsing; _ } =
      warnings_during_parsing
  end

  (** https://www.cambridge.org/core/services/aop-cambridge-core/content/view/097CE52C750E69BD16B78C318754C7A4/S0956796820000088a.pdf/build-systems-a-la-carte-theory-and-practice.pdf
      Section 3.3

      These are {b input keys} ... essentially source files (including
      user-supplied build files) found on disk.

      But we create dynamic tasks during the initial scan of sourcefiles, so we
      have no input keys. *)
  let f_store (_info : StoreInfo.t) (key : K.t) : V.t = V.Input_not_found key

  module MutableStore =
    MlFront_Thunk.BuildSystems.MutableFunctionStoreBuilder
      (struct
        type i = StoreInfo.t (* WAS: store_info *)
        type k = K.t
        type v = V.t

        let compare = K.compare
        let f = f_store
      end)
      (StoreMessages)

  module StateAsync = struct
    type state = MutableStore.t
    type 'a promise = 'a Promise.t

    let mutate_state (store : state)
        (msg : MlFront_Thunk.BuildConstraints.StateMessage.t) =
      match MutableStore.mutate_store store msg with
      | `Handled -> ()
      | _ ->
          raise
            (Invalid_argument
               (Printf.sprintf "[e84a3aed] Unsupported state message: %s"
               @@ MlFront_Thunk.BuildConstraints.StateMessage.show msg))

    let update (state : state) msgs = List.iter (mutate_state state) msgs
    let flush _state = Promise.return ()
  end

  (** Renamed from [MockStandardBackend] to [EngineBackend]. *)
  module EngineBackend = struct
    type 'a promise = 'a Promise.t

    (** Unlike [MockStandardBackend] we always print journal entries
        immediately. This is the reference implementation. Your build system may
        choose to buffer journal entries instead and then write them to a
        journal file. *)
    let flush json_list =
      let ( let* ) = Promise.bind in
      List.fold_left
        (fun i j ->
          let* () = i in
          Log.app (fun m -> m "[journal] %s" j))
        (Promise.return ()) json_list

    (** Unlike the original in ["tests/MlFront_Thunk/alacarte_xtraces_test.ml"]
        we do not serialize the trace to a string yet, so it can be
        pretty-printed where it is caught in [Shell.ml]. *)
    let journal_shutdown_in_error ~trace ~exitcode_posix ~exitcode_windows () =
      raise
        (DkZero_Base.Exceptions.EngineShutdown
           { trace; exitcode_posix; exitcode_windows })

    let process_journal_entry_value _ = `Standard

    let persist_journal_entry_value _ =
      (* Error on any field! We don't have any additions to the [journal_entry_value]
         extensible type. *)
      Error
        "There should be no additions to the journal_entry_value extensible \
         type"
  end

  module ThunkWriterAsync =
    MlFront_Thunk.BuildWriters.Standard.MutableWriterAsync
      (Promise)
      (EngineBackend)
  (** We used [StandardWriterAsync] from
      ["tests/MlFront_Thunk/alacarte_xtraces_test.ml"] rather than
      [SpreadsheetCellWriterAsync], and renamed to [ThunkWriterAsync] *)

  module State =
    DkZero_Base.State.Make (Promise) (FileObject) (K) (V) (MutableStore)

  module StateAccess = struct
    open State

    let make_from_store = create
    let store = store
    let is_done = is_done
    let set_done = set_done
    let create_with_precompiled_traces = create_with_precompiled_traces
  end

  module Unused = struct
    module CAsync =
      MlFront_Thunk.BuildConstraints.MonadStateWriterPromiseWithPureSeq
        (Promise)
        (StateAsync)
        (ThunkWriterAsync)

    (** We used [EventsAsync] from
        ["tests/MlFront_Thunk/alacarte_xtraces_test.ml"]. *)
    module EventsAsync = struct
      let on_fetch_entry (k : K.t) : CAsync.journal_entry_value option =
        let open MlFront_Thunk.BuildWriters.Standard in
        let f () =
          {
            info_code = "on-fetch-entry";
            message = Format.asprintf "%a" K.pp k;
            info_locations = [];
          }
        in
        Some (InfoBacktraceItem f)
    end

    module BusyAsync =
      MlFront_Thunk.BuildSystems.BusyWritingAsyncBuild (MutableStore) (O)
        (StoreMessages)
        (Promise)
        (CAsync)
        (EventsAsync)

    module TasksAsync =
      MlFront_Thunk.BuildSystems.MutableTasksBuilder (CAsync) (K) (V) (O)
  end

  module type THUNK_INTERPRETER = sig
    module C : sig
      include
        MlFront_Thunk.BuildConstraints.MONAD
          with type 'a t =
            (State.t * ThunkWriterAsync.journal ->
            ('a
            * MlFront_Thunk.BuildConstraints.StateMessage.t list
            * (ThunkWriterAsync.journal_entry_id
              * ThunkWriterAsync.journal_entry_value)
              MlFront_Thunk.UniqueInsertionList.t)
            Promise.t)
            Promise.t

      val post_entry :
        MlFront_Thunk.BuildWriters.Standard.journal_entry_value -> unit t
    end

    val task_create :
      (K.t * ((O.t -> K.t -> V.t C.t) -> V.t C.t)) list ->
      (module MlFront_Thunk.BuildSystems.DYNAMIC_TASKS
         with type k = K.t
          and type vc = V.t C.t
          and type lifted_vc = V.t C.t
          and type o = O.t
          and type up = unit Promise.t)
  end

  module CSuspending =
    MlFront_Thunk.BuildConstraints.MonadStateWriterPromiseWithPureSeq
      (Promise)
      (struct
        include State

        type state = t
      end)
      (ThunkWriterAsync)

  module TasksSuspending =
    MlFront_Thunk.BuildSystems.MutableTasksBuilder (CSuspending) (K) (V) (O)

  (** Based on [backtrace_item_info] and [shutdown] in
      ["tests/MlFront_Thunk/alacarte_xtraces_test.ml"] *)
  module Backtraces (I : THUNK_INTERPRETER) = struct
    open MlFront_Thunk.BuildWriters.Standard

    let backtrace_item_info code =
      I.C.post_entry
        (InfoBacktraceItem
           (fun () -> { info_code = code; message = ""; info_locations = [] }))

    let fail ~error_code ?(cant_do = "") ?(because = "") ?(error_locations = [])
        ?(recommendations = []) ?(exitcode_posix = 1) ?(exitcode_windows = 1) ()
        =
      I.C.post_entry
        (ShutdownableError
           {
             error =
               {
                 error_code;
                 cant_do;
                 because;
                 error_locations;
                 recommendations;
               };
             exitcode_posix;
             exitcode_windows;
           })
  end

  (** This is much simpler compared to original [StoreTrackingInterpreter] in
      ["tests/MlFront_Thunk/alacarte_3_7_test.ml"] since can we just delegate to
      TasksSuspending. We also rename to [ThunkTrackingInterpreter]. *)
  module ThunkTrackingInterpreter : THUNK_INTERPRETER = struct
    module C = CSuspending
    module KeyMap = Map.Make (K)

    let task_create :
        (K.t * ((O.t -> K.t -> V.t C.t) -> V.t C.t)) list ->
        (module MlFront_Thunk.BuildSystems.DYNAMIC_TASKS
           with type k = K.t
            and type vc = V.t C.t
            and type lifted_vc = V.t C.t
            and type o = O.t
            and type up = unit Promise.t) =
      TasksSuspending.create
  end

  type 'a cont = 'a CSuspending.t

  module Cfg = struct
    type t = {
      mutable does_enter_shell_before_function : unit KMap.t;
      threaddir : MlFront_Core.FilePath.t;
      absbasepath : MlFront_Core.FilePath.t;
      download :
        on_fail:
          (location_if_checksum_error:Fmlib_parse.Position.range option ->
          error_code:string ->
          because:string ->
          recommendations:string list ->
          unit ->
          unit cont) ->
        file_origin:string ->
        file_path:string ->
        file_checksum:DkZero_Base.BuildContext.weak_capable_asset_checksum ->
        file_offset:int64 option ->
        file_sz:(Fmlib_parse.Position.range * int64) option ->
        file_trailer:string option ->
        origin_mirrors:string * string list ->
        MlFront_Progress.Progress.nodeobj ->
        MlFront_Core.FilePath.t ->
        [ `Downloaded of [ `SHA256 of string * int64 ] | `Failed ] cont;
      verbosity : int;
      explain : bool;
      parsetrace : bool;
      rootprogressnode : MlFront_Progress.Progress.nodeobj;
      intermediate : bool;
      buildlogtrace : bool;
      debug_task : bool;
      importtrace : bool;
      importtrace2 : bool;
      sysincludedirs : string list;
      workspaceincludedirs : string list;
      userincludedirs : string list;
      cells : DkZero_Base.Config.cells;
      local_packages : MlFront_Core.PackageId.t list;
      build_number : string;
      long_ids : bool;
      integrity : [ `None | `Existence | `Checksum ];
      workspacedir : MlFront_Core.FilePath.t;
      workspace : DkZero_Base.Config.workspace option;
      valuestore : MlFront_Core.FilePath.t;
      tracestore : MlFront_Core.FilePath.t;
      tracefile : string;
      selfassetdir : MlFront_Core.FilePath.t;
      install_home : MlFront_Core.FilePath.t;
      install_cache : MlFront_Core.FilePath.t;
      install_data : MlFront_Core.FilePath.t;
      install_config : MlFront_Core.FilePath.t;
      install_state : MlFront_Core.FilePath.t;
      install_runtime : MlFront_Core.FilePath.t;
      rng : Mirage_crypto_rng.g;
      build_pubkey : [ `PublicKey of string ];
      build_seckey : [ `SecretKey of string ];
      metadb : MlFront_Cache.MetaDb.t;
      meta_conn : MlFront_Cache.MetaDb.connection;
      observer_result :
        (module MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT);
      nobuiltininc : bool;
      nosysinc : bool;
      builtin_valuesjson : Io.file_object list;
      builtin_valueslua : Io.file_object list;
      deny_deprecated_function_args : bool;
      import : [ `Eager | `Lazy ];
    }

    let fatal_return ~error_code = function
      | `Created | `Deleted -> ()
      | `Error s ->
          Promise.run_promise
          @@ Log.err (fun m -> m "[fatal] [error %s] %s" error_code s);
          exit 1

    let build_key_pipes_to_newlines s =
      DkZero_Base.Assumptions.build_keys_have_no_pipes_and_store_pipe_separated
        ();
      let s = String.trim s in
      let s = String.concat "\n" (String.split_on_char '|' s) in
      (* Format is COMMENT NEWLINE KEY NEWLINE *)
      s ^ "\n"

    let load_pubkeysource ~keys_env ~build_public_keyfile () =
      match keys_env with
      | Some prefix -> (
          let pubkey_env = prefix ^ "_PUBKEY" in
          match Sys.getenv_opt pubkey_env with
          | Some pubkey ->
              Ok
                (`KeysFromEnvironmentPrefix
                   {
                     DkZero_Base.Config.keys_env_prefix = prefix;
                     keys_env_pubkey =
                       `PublicKey (build_key_pipes_to_newlines pubkey);
                   })
          | None ->
              Error
                (Printf.sprintf "Environment variable %s not set." pubkey_env))
      | None ->
          let pubkeyfile_s = MlFront_Core.FilePath.show build_public_keyfile in
          if Sys.file_exists pubkeyfile_s then
            let pubkey =
              In_channel.with_open_bin pubkeyfile_s (fun ic ->
                  In_channel.input_all ic)
            in
            Ok (`KeysFromFiles (`PublicKey pubkey))
          else
            (* No key available. The keys may need to be generated. *)
            Ok (`KeysFromFiles (`MissingPublicKey build_public_keyfile))

    let load_public_key_from_source = function
      | `KeysFromEnvironmentPrefix { DkZero_Base.Config.keys_env_pubkey; _ } ->
          Ok keys_env_pubkey
      | `KeysFromFiles (`PublicKey pk) -> Ok (`PublicKey pk)
      | `KeysFromFiles (`MissingPublicKey pkfile) ->
          Error
            (Printf.sprintf "No public key found at `%s`."
               (MlFront_Core.FilePath.show pkfile))

    let load_or_generate_keys ~rng ~build_pubkeysource ~build_public_keyfile
        ~build_secret_keyfile () =
      (* Check for secret key (not the public key since that is theoretically
     recoverable). If secret key doesn't exist, create a new key pair. *)
      match build_pubkeysource with
      | `KeysFromEnvironmentPrefix
          {
            DkZero_Base.Config.keys_env_prefix = prefix;
            DkZero_Base.Config.keys_env_pubkey = pubkey;
          } -> (
          let seckey_env = prefix ^ "_SECKEY" in
          match Sys.getenv_opt seckey_env with
          | Some seckey ->
              (pubkey, `SecretKey (build_key_pipes_to_newlines seckey))
          | None ->
              Promise.run_promise
              @@ Log.err (fun m ->
                     m "[signify] FATAL: Environment variable %s not set."
                       seckey_env);
              exit 1)
      | `KeysFromFiles (`PublicKey build_pubkey) ->
          if Sys.file_exists (MlFront_Core.FilePath.show build_secret_keyfile)
          then begin
            let seckey =
              In_channel.with_open_bin
                (MlFront_Core.FilePath.show build_secret_keyfile) (fun ic ->
                  In_channel.input_all ic)
            in
            (`PublicKey build_pubkey, `SecretKey seckey)
          end
          else begin
            Promise.run_promise
            @@ Log.err (fun m ->
                   m "[signify] FATAL: Secret key file %s not found."
                     (MlFront_Core.FilePath.show build_secret_keyfile));
            exit 1
          end
      | `KeysFromFiles (`MissingPublicKey _build_public_keyfile) ->
          if Sys.file_exists (MlFront_Core.FilePath.show build_secret_keyfile)
          then begin
            Promise.run_promise
            @@ Log.err (fun m ->
                   m
                     "[signify] FATAL: Secret key file %s exists but no \
                      corresponding public key file. Will not overwrite the \
                      secret key."
                     (MlFront_Core.FilePath.show build_secret_keyfile));
            exit 1
          end
          else begin
            (* Create keys *)
            let ((`PublicKey pubkey, `SecretKey seckey) as keypair) =
              Sec.generate_build_keypair ~rng ()
            in
            Sec.save_build_keypair ~build_public_keyfile ~build_secret_keyfile
              ~fatal_return keypair;
            (* Save keys ... secret key last for idempotency with secret key check above. *)
            MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
              ~return:(fatal_return ~error_code:"5696c586")
              (MlFront_Core.FilePath.parent build_public_keyfile);
            MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
              ~return:(fatal_return ~error_code:"b1f3c9e2")
              (MlFront_Core.FilePath.parent build_secret_keyfile);
            Out_channel.with_open_bin
              (MlFront_Core.FilePath.show build_public_keyfile) (fun ic ->
                Out_channel.output_string ic pubkey);
            Out_channel.with_open_bin
              (MlFront_Core.FilePath.show build_secret_keyfile) (fun ic ->
                Out_channel.output_string ic seckey);
            (* Log *)
            Promise.run_promise
            @@ Log.app (fun m ->
                   m
                     "[signify] New build key pair in %s and %s ...\n\
                      [signify] Distribute key pair among trusted coworkers \
                      only!"
                     (MlFront_Core.FilePath.show build_public_keyfile)
                     (MlFront_Core.FilePath.show build_secret_keyfile));
            (`PublicKey pubkey, `SecretKey seckey)
          end

    let setup_cachedirs ~rng ~data_dir ~cache_dir () =
      match
        MlFront_Cache.MetaDb.create ~rng ~name:"build"
          ~datadir:(MlFront_Core.FilePath.append_exn data_dir "b.1")
          ~cachedir:(MlFront_Core.FilePath.append_exn cache_dir "b.1")
          ()
      with
      | Ok metadb -> metadb
      | Error (`WrappableMsg defer) ->
          Fmt.epr
            "@[<v 2>FATAL: Could not create the metadata database.@ %a@]@."
            defer ();
          exit 2

    let get_keys_dir ~xdg ~global ~workspacedir =
      let open MlFront_Core.FilePath in
      function
      | None ->
          if global then append_exn (of_string_exn (Xdg.config_dir xdg)) dk_prog
          else append_exn workspacedir "t/k"
      | Some dir -> dir

    let public_keyfile_name = "build.pub"
    let secret_keyfile_name = "build.sec"

    let baseconfigure ?data_dir ?cache_dir ?keys_dir ?valuestore ?tracestore
        ~absbasepath ~global ~entry_unified_script ~keys_env ~integrity
        debugmodes =
      let xdg = Xdg.create ~env:Sys.getenv_opt () in
      let buildlogtrace =
        if List.mem `BuildLog debugmodes then Some () else None
      in
      let parsetrace =
        if List.mem `ParseTrace debugmodes then Some () else None
      in
      let debug_task = if List.mem `Task debugmodes then Some () else None in

      (* Workspace *)
      let workspacedir_maybe_relto_basedir, workspace =
        let entry_opt =
          match entry_unified_script with
          | None -> None
          | Some fp ->
          match UnifiedScriptC.load ~absbasepath fp with
          | Error msg ->
              failwith
                (Printf.sprintf "Failed to load unified script: %s\n" msg)
          | Ok scriptc -> Some scriptc
        in
        match
          WorkspaceC.get_workspace_relto_basedir ~absbasepath
            ~entry_unified_script:entry_opt ()
        with
        | None -> (MlFront_Core.FilePath.empty, None)
        | Some (workspace_file, workspace_config) ->
            ( MlFront_Core.FilePath.parent workspace_file,
              Some { DkZero_Base.Config.workspace_file; workspace_config } )
      in

      (* Data and cache directories. Defaults are short to mitigate Win32 260 MAX_PATH limits *)
      let data_dir =
        let data_dir_default =
          if global then
            MlFront_Core.FilePath.(
              append_exn (of_string_exn (Xdg.data_dir xdg)) dk_prog |> to_string)
          else
            MlFront_Core.FilePath.(
              append_exn workspacedir_maybe_relto_basedir "t/d" |> to_string)
        in
        let data_dir_opt =
          Option.map MlFront_Core.FilePath.to_string data_dir
        in
        let s = Option.value ~default:data_dir_default data_dir_opt in
        match MlFront_Core.FilePath.of_string s with
        | Error msg ->
            failwith (Printf.sprintf "Failed to understand data dir: %s" msg)
        | Ok dir -> dir
      in
      let cache_dir =
        let cache_dir_default =
          if global then
            (* On Windows the Xdg.cache_dir is [C:\Users\USER\AppData\Local\Microsoft\Windows\INetCache].
            It wastes a lot of characters, and for a general purpose build tool we are very sensitive
            to MAX_PATH. The .NET SDK, for example, has very long paths, and is likely only tested
            with LOCALAPPDATA.

            So, use LOCALAPPDATA (ex. Xdg.state_dir) rather than Xdg.cache_dir. *)
            let root_dir = if Sys.win32 then Xdg.state_dir else Xdg.cache_dir in
            MlFront_Core.FilePath.(
              append_exn (of_string_exn (root_dir xdg)) dk_prog |> to_string)
          else
            MlFront_Core.FilePath.(
              append_exn workspacedir_maybe_relto_basedir "t/c" |> to_string)
        in
        let cache_dir_opt =
          Option.map MlFront_Core.FilePath.to_string cache_dir
        in
        let s = Option.value ~default:cache_dir_default cache_dir_opt in
        match MlFront_Core.FilePath.of_string s with
        | Error msg ->
            failwith (Printf.sprintf "Failed to understand cache dir: %s" msg)
        | Ok dir -> dir
      in

      (* Stores *)
      let valuestore =
        (* default:
         "val.1" = value store. layout version 1 *)
        Option.value
          ~default:(MlFront_Core.FilePath.append_exn data_dir "val.1")
          valuestore
      in
      let tracestore =
        (* default:
         "cts.1" = constructive trace store. layout version 1 *)
        Option.value
          ~default:(MlFront_Core.FilePath.append_exn data_dir "cts.1")
          tracestore
      in
      (* Choose location for signify keys *)
      let build_public_keyfile =
        let keys_dir =
          get_keys_dir ~xdg ~global
            ~workspacedir:workspacedir_maybe_relto_basedir keys_dir
        in
        let open MlFront_Core.FilePath in
        append_exn keys_dir public_keyfile_name
      in
      (* Create signify key if secret key not present *)
      let build_pubkeysource =
        match load_pubkeysource ~keys_env ~build_public_keyfile () with
        | Ok pk -> pk
        | Error msg ->
            failwith (Printf.sprintf "Failed to load public key: %s" msg)
      in
      (* Done baseconfigure *)
      DkZero_Base.Config.
        {
          baseconfig_global = global;
          baseconfig_absbasepath = absbasepath;
          baseconfig_workspacedir = workspacedir_maybe_relto_basedir;
          baseconfig_workspace = workspace;
          baseconfig_tracestore = tracestore;
          baseconfig_tracefile = "trace";
          baseconfig_buildlogtrace = buildlogtrace = Some ();
          baseconfig_parsetrace = parsetrace = Some ();
          baseconfig_debug_task = debug_task = Some ();
          baseconfig_valuestore = valuestore;
          baseconfig_build_pubkeysource = build_pubkeysource;
          baseconfig_integrity = integrity;
          baseconfig_datadir = data_dir;
          baseconfig_cachedir = cache_dir;
          baseconfig_keysdir = keys_dir;
        }

    let preconfigure ~baseconfig ~cells ~install ~random_seed () =
      let xdg = Xdg.create ~env:Sys.getenv_opt () in
      let DkZero_Base.Config.
            {
              baseconfig_build_pubkeysource;
              baseconfig_global = global;
              baseconfig_absbasepath;
              baseconfig_workspacedir = workspacedir;
              baseconfig_datadir = data_dir;
              baseconfig_cachedir = cache_dir;
              baseconfig_keysdir = keys_dir;
              _;
            } =
        baseconfig
      in
      (* Data and cache directories *)

      (* Choose location for signify keys *)
      let build_public_keyfile, build_secret_keyfile =
        let keys_dir = get_keys_dir ~xdg ~global ~workspacedir keys_dir in
        let open MlFront_Core.FilePath in
        ( append_exn keys_dir public_keyfile_name,
          append_exn keys_dir secret_keyfile_name )
      in
      (* Choose location for various variables *)
      let ( install_home,
            install_cache,
            install_data,
            install_config,
            install_state,
            install_runtime ) =
        let open MlFront_Core.FilePath in
        let x = of_string_exn in
        match install with
        | Some { program } -> (
            let y f = append_exn (of_string_exn (f xdg)) program in
            let z f = append_exn f program in
            ( x (Xdg.home_dir xdg),
              z cache_dir,
              z data_dir,
              y Xdg.config_dir,
              y Xdg.state_dir,
              match Xdg.runtime_dir xdg with
              | None -> y Xdg.state_dir
              | Some r -> x r ))
        | None ->
            (* short to mitigate Win32 260 MAX_PATH limits *)
            (x "t/xh", x "t/xc", x "t/xd", x "t/xg", x "t/xs", x "t/xr")
      in
      let pid = Unix.getpid () in
      let selfassetdir =
        (* short to mitigate Win32 260 MAX_PATH limits *)
        MlFront_Core.FilePath.of_string_exn (Printf.sprintf "t/x0/%d" pid)
      in
      (* Create random number generator *)
      let rng = Sec.get_rng ~random_seed () in
      (* Ugly bit of static initialization ... *)
      MlFront_Thunk_IoDisk.ThunkIoDisk.set_io_rng (fun () ->
          let bs = Bytes.create 8 in
          Mirage_crypto_rng.generate_into ~g:rng bs 8;
          Bytes.get_int64_le bs 0);
      (* Create signify key if secret key not present *)
      let build_pubkey, build_seckey =
        load_or_generate_keys ~rng
          ~build_pubkeysource:baseconfig_build_pubkeysource
          ~build_public_keyfile ~build_secret_keyfile ()
      in
      (* metadb *)
      let metadb = setup_cachedirs ~rng ~data_dir ~cache_dir () in
      (* Calculate cells; earlier cells are overwritten by later ones. Default "root" is the base directory. *)
      let cells =
        List.fold_left
          (fun acc (cellname, fp) ->
            DkZero_Base.Config.CellMap.add cellname fp acc)
          (DkZero_Base.Config.CellMap.singleton "root" baseconfig_absbasepath)
          cells
      in
      (* Done preconfigure *)
      DkZero_Base.Config.
        {
          baseconfig;
          preconfig_install_home = install_home;
          preconfig_install_cache = install_cache;
          preconfig_install_data = install_data;
          preconfig_install_config = install_config;
          preconfig_install_state = install_state;
          preconfig_install_runtime = install_runtime;
          preconfig_build_pubkey = build_pubkey;
          preconfig_build_seckey = build_seckey;
          preconfig_metadb = metadb;
          preconfig_rng = rng;
          preconfig_cells = cells;
          preconfig_selfassetdir = selfassetdir;
        }

    (** [create ?verbose ~threaddir ~download ()].

        [threaddir] is a directory exclusive to the
        {b running process and thread}. It is used for temporary directories. *)
    let create ?(verbosity = 0) ?explain ?intermediate ?importtrace
        ?importtrace2 ?nobuiltininc ?nosysinc ?noworkspaceinc ~preconfig
        ~sysincludedirs ~workspaceincludedirs ~userincludedirs ~local_packages
        ~build_number ~long_ids ~threaddir ~download ~observer_result
        ~rootprogressnode ~import () =
      let DkZero_Base.Config.
            {
              baseconfig =
                {
                  baseconfig_global = _;
                  baseconfig_absbasepath = absbasepath;
                  baseconfig_workspacedir = workspacedir;
                  baseconfig_workspace = workspace;
                  baseconfig_tracestore = tracestore;
                  baseconfig_tracefile = tracefile;
                  baseconfig_valuestore = valuestore;
                  baseconfig_integrity = integrity;
                  baseconfig_buildlogtrace = buildlogtrace;
                  baseconfig_debug_task = debug_task;
                  baseconfig_parsetrace = parsetrace;
                  baseconfig_build_pubkeysource = _;
                  baseconfig_datadir = _;
                  baseconfig_cachedir = _;
                  baseconfig_keysdir = _;
                };
              preconfig_selfassetdir = selfassetdir;
              preconfig_install_home = install_home;
              preconfig_install_cache = install_cache;
              preconfig_install_data = install_data;
              preconfig_install_config = install_config;
              preconfig_install_state = install_state;
              preconfig_install_runtime = install_runtime;
              preconfig_build_pubkey = build_pubkey;
              preconfig_build_seckey = build_seckey;
              preconfig_metadb = metadb;
              preconfig_rng = rng;
              preconfig_cells = cells;
            } =
        preconfig
      in
      (* Start metadata connection *)
      let meta_conn =
        match MlFront_Cache.MetaDb.start_connection metadb with
        | Error (`WrappableMsg defer) ->
            Fmt.epr
              "@[<v 2>FATAL: Could not start connection to the metadata \
               database.@;\
               %a@]@."
              defer ();
            exit 1
        | Ok conn -> conn
      in
      (* Return *)
      {
        builtin_valuesjson =
          (if nobuiltininc = Some () then []
           else BuildBuiltins'.builtin_valuesjson ());
        builtin_valueslua =
          (if nobuiltininc = Some () then []
           else BuildBuiltins'.builtin_valueslua ());
        rng;
        absbasepath;
        sysincludedirs = (if nosysinc = Some () then [] else sysincludedirs);
        workspaceincludedirs =
          (if noworkspaceinc = Some () then [] else workspaceincludedirs);
        userincludedirs;
        cells;
        local_packages;
        build_number;
        long_ids;
        integrity;
        threaddir;
        tracestore;
        tracefile;
        download;
        nobuiltininc = nobuiltininc = Some ();
        nosysinc = nosysinc = Some ();
        verbosity;
        rootprogressnode;
        explain = explain = Some ();
        intermediate = intermediate = Some ();
        debug_task;
        buildlogtrace;
        importtrace = importtrace = Some ();
        importtrace2 = importtrace2 = Some ();
        parsetrace;
        workspacedir;
        workspace;
        valuestore;
        selfassetdir;
        install_home;
        install_cache;
        install_data;
        install_config;
        install_state;
        install_runtime;
        build_pubkey;
        build_seckey;
        metadb;
        meta_conn;
        observer_result;
        does_enter_shell_before_function = KMap.empty;
        deny_deprecated_function_args = false;
        import;
      }

    let builtin_valuesjson { builtin_valuesjson; _ } = builtin_valuesjson
    let builtin_valueslua { builtin_valueslua; _ } = builtin_valueslua
    let absbasepath { absbasepath; _ } = absbasepath
    let threaddir { threaddir; _ } = threaddir
    let download { download; _ } = download
    let verbosity { verbosity; _ } = verbosity
    let verbose { verbosity; _ } = verbosity > 0
    let rootprogressnode { rootprogressnode; _ } = rootprogressnode
    let explain { explain; _ } = explain
    let parsetrace { parsetrace; _ } = parsetrace
    let intermediate { intermediate; _ } = intermediate
    let importtrace { importtrace; _ } = importtrace
    let importtrace2 { importtrace2; _ } = importtrace2
    let debug_task { debug_task; _ } = debug_task
    let buildlogtrace { buildlogtrace; _ } = buildlogtrace
    let sysincludedirs { sysincludedirs; _ } = sysincludedirs
    let workspaceincludedirs { workspaceincludedirs; _ } = workspaceincludedirs
    let userincludedirs { userincludedirs; _ } = userincludedirs
    let local_packages { local_packages; _ } = local_packages
    let integrity { integrity; _ } = integrity
    let tracefile { tracefile; _ } = tracefile
    let workspacedir_maybe_relto_basedir { workspacedir; _ } = workspacedir

    let workspacefile_maybe_relto_basedir { workspace; _ } =
      Option.map
        (fun { DkZero_Base.Config.workspace_file; _ } -> workspace_file)
        workspace

    let workspaceconfig { workspace; _ } =
      Option.map
        (fun { DkZero_Base.Config.workspace_config; _ } -> workspace_config)
        workspace

    let availablecells { cells; _ } =
      DkZero_Base.Config.CellMap.bindings cells |> List.map fst

    let selfassetdir { selfassetdir; _ } = selfassetdir
    let install_home { install_home; _ } = install_home
    let install_cache { install_cache; _ } = install_cache
    let install_data { install_data; _ } = install_data
    let install_config { install_config; _ } = install_config
    let install_state { install_state; _ } = install_state
    let install_runtime { install_runtime; _ } = install_runtime
    let rng { rng; _ } = rng
    let build_pubkey { build_pubkey; _ } = build_pubkey
    let build_seckey { build_seckey; _ } = build_seckey
    let build_number { build_number; _ } = build_number
    let long_ids { long_ids; _ } = long_ids
    let metadb { metadb; _ } = metadb
    let meta_conn { meta_conn; _ } = meta_conn
    let observer_result { observer_result; _ } = observer_result
    let nobuiltininc { nobuiltininc; _ } = nobuiltininc
    let nosysinc { nosysinc; _ } = nosysinc
    let valuestore_maybe_relto_basedir { valuestore; _ } = valuestore
    let tracestore_maybe_relto_basedir { tracestore; _ } = tracestore

    let deny_deprecated_function_args { deny_deprecated_function_args; _ } =
      deny_deprecated_function_args

    let does_enter_shell_before_function { does_enter_shell_before_function; _ }
        k =
      KMap.mem k does_enter_shell_before_function

    (** [set_enter_shell_breakpoint_before_function config key] will trigger the
        interactive shell to launch before the next function call(s) of the key
        [key], if any. *)
    let set_enter_shell_breakpoint_before_function
        ({ does_enter_shell_before_function; _ } as config) k =
      config.does_enter_shell_before_function <-
        KMap.add k () does_enter_shell_before_function

    let import { import; _ } = import
    let threaddir_path_hash_len (_ : t) = 4
  end

  include Cfg
  module BuildPaths' = DkZero_Base.BuildPaths.Make (Cfg)

  module Syntax = struct
    include Backtraces (ThunkTrackingInterpreter)

    let ( let* ) = CSuspending.bind
    let lift_promise = CSuspending.lift_promise
    let return = CSuspending.return
    let get = CSuspending.get
    let parallel = CSuspending.parallel
    let map = CSuspending.map

    type nonrec 'a cont = 'a cont
  end

  let run_isolated_promise (type a) (p : a CSuspending.promise) : a =
    (* TODO: Why is this not just [Promise.run_promise p]? *)
    let c = CSuspending.lift_promise p in
    let i = StoreInfo.create ~explain:false ~warnings_during_parsing:false in
    let store = MutableStore.initialise i in
    let ir = StateAccess.make_from_store store in
    let p : (a * CSuspending.state) CSuspending.promise =
      CSuspending.run_state_async c ir
    in
    let a, state = Promise.run_promise p in
    ignore state;
    a

  let run_continuation (type a) (kont : a CSuspending.t) (state : State.t) :
      a * State.t =
    let p : (a * CSuspending.state) CSuspending.promise =
      CSuspending.run_state_async kont state
    in
    Promise.run_promise p

  module type THUNK_TASKS =
    MlFront_Thunk.BuildSystems.DYNAMIC_TASKS
      with type k = K.t
       and type lifted_vc = V.t cont
       and type vc = V.t cont
       and type o = O.t
       and type up = unit Promise.t

  (** Based on [Spreadsheet2] in
      ["tests/MlFront_Thunk/alacarte_3_2_apparatus.ml"] *)
  module UserBuildProgram (I : THUNK_INTERPRETER) = struct
    open Backtraces (I)

    let cloudshake_predetermined_tasks =
      let open MlFront_Thunk.BuildConstraints.MonadLetSyntax (I.C) in
      I.task_create
        [
          ( K.reserved_version_key,
            fun _fetch ->
              let* () = backtrace_item_info "MlFront_Std.Version" in
              I.C.pure (V.create_constant values_version) );
          ( K.reserved_pingpong_key,
            fun _fetch ->
              let* () = backtrace_item_info "MlFront_Std.Sample.Ping" in
              I.C.pure (V.create_constant "pong") );
          ( K.reserved_pongping_key,
            fun _fetch ->
              let* () = backtrace_item_info "MlFront_Std.Sample.Pong" in
              I.C.pure (V.create_constant "ping") );
          ( K.reserved_abc_key,
            fun _fetch ->
              let* () = backtrace_item_info "MlFront_Std.Sample.Abc" in
              I.C.pure (V.create_constant DkZero_Base.Strings.sampleabc_zip) );
          ( K.reserved_fail_key,
            fun _fetch ->
              let* () =
                fail ~error_code:"4988a923" ~cant_do:"build"
                  ~because:"the Fail task is designed to always fail" ()
              in
              (* Confer [V] *)
              I.C.pure V.Failure_is_pending );
        ]
  end

  let tasks_module =
    let module Expr = UserBuildProgram (ThunkTrackingInterpreter) in
    Expr.cloudshake_predetermined_tasks

  module CPHash = struct
    type k = K.t
    type v = V.t
    type ('k, 'v) key_dependent_hash = (k, v) V.key_dependent_hash

    let maybe_cloud_persistent_hash = V.maybe_cloud_persistent_hash
    let strong_hash_equal = V.strong_hash_equal
    let strong_hash_show = V.strong_hash_show
  end

  module Trace = struct
    type k = K.t
    type v = V.t

    let k_show = K.show
    let v_show = V.show

    module C = CSuspending
  end

  module IR = struct
    type t = State.t

    let post_record_trace ir k depends result =
      let (_ : State.t) = State.post_record_trace ir k depends result in
      CSuspending.pure ()

    let get_traces_for_key ir k = State.get_traces_for_key ir k
  end

  module CTAsync =
    MlFront_Thunk.BuildTraces.ConstructiveTraceStoreAsyncMinimal
      (Trace)
      (CPHash)
      (IR)

  module Events = struct
    type k = K.t
    type v = V.t
    type uc = unit CSuspending.t
    type o = O.t

    let schedule_key _k = CSuspending.pure ()

    open struct
      let lead ~first_c depth c =
        List.init depth (fun i ->
            if i = 0 then first_c ^ " "
            else if i = depth - 1 then c ^ " "
            else "  ")
        |> String.concat ""
    end

    let before_rebuild_key ~candidate_values ~origin k =
      let ( let* ) = CSuspending.bind in
      let* state = CSuspending.get in
      let depth = O.depth origin in
      let promise =
        if StoreInfo.explain (MutableStore.get_info (State.store state)) then
          let first_c =
            match O.first origin with
            | O.OutsideTaskTrace -> "N|"
            | O.User -> "U|"
            | O.IncludeFile -> "I|"
            | O.Distribution -> "D|"
            | O.Values_file _ -> "V|"
            | O.Key _ -> "K|"
            | O.Rule -> "R|"
          in
          let lead c = lead ~first_c depth c in
          (* We flush so that cause and effect can be ordered correctly. *)
          match candidate_values with
          | [] ->
              Log.debug (fun m ->
                  m "[explain] %snever built `%s`" (lead "x") (K.show k))
          | [ single ] ->
              Log.debug (fun m ->
                  m
                    "[explain] %sonce built `%s`, but build `%s` does not \
                     match the authoritative trace"
                    (lead "!") (K.show k) (V.show single))
          | last :: previous ->
              Log.debug (fun m ->
                  m
                    "[explain] %s%dx built `%s`, but build `%s` and the others \
                     do not match the authoritative trace"
                    (lead "!")
                    (1 + List.length previous)
                    (K.show k) (V.show last))
        else Promise.return ()
      in
      CSuspending.lift_promise promise

    let on_dependency_discovered ~depth ~key ~depends_upon_key =
      let ( let* ) = CSuspending.bind in
      let* state = CSuspending.get in
      let promise =
        if StoreInfo.explain (MutableStore.get_info (State.store state)) then
          let lead c = lead ~first_c:" |" (depth + 1) c in
          Log.debug (fun m ->
              m "[explain] %s%s depends on %s" (lead "^") (K.show key)
                (K.show depends_upon_key))
        else Promise.return ()
      in
      CSuspending.lift_promise promise
  end

  module CtRebuilderOfTasks =
    MlFront_Thunk.BuildRebuilders.CtRebuilderAsync (IR) (K) (O) (V) (Promise)
      (CSuspending)
      (Events)
      (CTAsync)

  module I = struct
    type t = StoreInfo.t (* WAS: store_info *)
  end

  module KSet = Set.Make (K)

  module SuspendingSchedulerOfRebuilderAndTasks =
    MlFront_Thunk.BuildSchedulers.SuspendingSchedulerAsync (IR) (K) (KSet) (V)
      (O)
      (I)
      (MutableStore)
      (StoreMessages)
      (Promise)
      (CSuspending)
      (Events)
      (StateAccess)

  let do_run_exn : type a.
      t ->
      tasks:(module THUNK_TASKS) ->
      mk_tasks:
        (t ->
        tasks:(module THUNK_TASKS) ->
        state:State.t ->
        (module MlFront_Thunk.ThunkResults.OBSERVER_RESULT) ->
        O.t ->
        K.t ->
        K.t * ((O.t -> K.t -> V.t cont) -> V.t cont)) ->
      init:a ->
      should_continue:(a -> [< `Continue | `Stop of a ]) ->
      fetched:(K.t -> V.t -> a -> a) ->
      not_found:
        (target:K.t ->
        inputkey:K.t ->
        (K.t -> V.t cont) ->
        State.t ->
        a ->
        a cont) ->
      target_fold:((a cont -> K.t -> a cont) -> a cont -> a cont) ->
      O.t ->
      a cont =
   fun ({ observer_result; _ } as t) ~tasks ~mk_tasks ~init ~should_continue
       ~fetched ~not_found ~target_fold origin ->
    (* let open Ctx in
    let open Alacarte_3_7_test_last in
    let open Alacarte_6_4_test in
    let open Alacarte_xasync_apparatus in *)
    let module I = ThunkTrackingInterpreter in
    let module Expr = UserBuildProgram (I) in
    let module Tasks = (val tasks : THUNK_TASKS) in
    (* Continue on configuring the build system ... *)
    let module CtRebuilder = CtRebuilderOfTasks (Tasks) in
    let module SuspendingScheduler =
      SuspendingSchedulerOfRebuilderAndTasks (CtRebuilder) (Tasks)
    in
    let open Syntax in
    let* state = get in
    let previous_rootprogressnode = State.current_rootprogressnode state in
    State.set_current_rootprogressnode state (Some (rootprogressnode t));
    let build_async =
      SuspendingScheduler.schedule state CtRebuilder.rebuilder
    in
    let tasks = mk_tasks t ~tasks ~state observer_result in
    (* The fetch delegates to the rebuilder *)
    let toplevel_user_fetch o k : V.t cont =
      let open Syntax in
      let* state = get in
      let* store = lift_promise @@ build_async o tasks k (State.store state) in
      return (MutableStore.get_value k store)
    in
    (* Run the tasks for the targets that are derived (ie. non-input keys).
  
    Form a promise to build each of the targets sequentially.
  
    RECOMMENDATION: Non-reference implementations should build the targets
    in parallel! Your system should have the conceptual equivalent of Promise.all:
    https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Promise/all *)
    let open Syntax in
    let* result =
      target_fold
        (fun acc (target : K.t) ->
          let* acc = acc in
          match should_continue acc with
          | `Continue -> begin
              let fetch = toplevel_user_fetch origin in
              let* v = fetch target in
              match v with
              | ValuesJsonFile _ | ValuesLuaFile _ | Values _ | ScriptModule _
              | Distribution _ | Form _ | Bundle _ | Asset _ | AssetIndex _
              | Object _ | Constant _ | Ephemeral_ui_response ->
                  return (fetched target v acc)
              | Input_not_found inputkey ->
                  let* state = get in
                  not_found ~target ~inputkey fetch state acc
              | Failure_is_pending ->
                  failwith
                    "Illegal state. Failure_is_pending should have been \
                     handled."
            end
          | `Stop stopvalue -> return stopvalue)
        (return init)
    in
    State.set_current_rootprogressnode state previous_rootprogressnode;
    return result

  module type SUSPENDING_RESOLVER =
    MlFront_Thunk.ThunkAst.RESOLVER with type 'a t = 'a cont

  let range_into_problem_location ~(source : Io.file_object) range :
      MlFront_Thunk.BuildWriters.Standard.problem_location list cont =
    let open Syntax in
    let* read_result = lift_promise @@ Io.read_all source in
    match read_result with
    | `Error _ | `ExceededSizeLimit _ -> return []
    | `Content source_code ->
        return
          [
            MlFront_Thunk.BuildWriters.Standard.
              {
                origin = Some (Io.file_origin source);
                source = source_code;
                range;
              };
          ]

  let mk_resolver ~values_file : (module SUSPENDING_RESOLVER) =
    let module M = struct
      include CSuspending

      let fail range msg =
        let open Syntax in
        let* error_locations =
          range_into_problem_location ~source:values_file range
        in
        let* () =
          fail ~error_code:"72a56622" ~cant_do:"resolve expressions in form"
            ~because:msg ~error_locations ()
        in
        (* should never get here *)
        failwith
          "error [72a56622] should have been raised gracefully. file a issue."
    end in
    let module R = MlFront_Thunk.ThunkAst.MakeResolver (M) in
    (module R : SUSPENDING_RESOLVER)

  (** {2 Printing} *)

  let print_config config =
    let open Format in
    let p = fprintf in
    let f = std_formatter in
    let pp_opt_bool fmt = function
      | true -> fprintf fmt "Some ()"
      | false -> fprintf fmt "None"
    in
    let lines s =
      let lines = String.split_on_char '\n' s in
      List.map MlFront_Thunk.ThunkStrings.trim_right lines
    in
    let pp_lines fmt s =
      List.iteri
        (fun i line ->
          if i > 0 then fprintf fmt "@;";
          fprintf fmt "%s" line)
        (lines s)
    in
    let pp_list =
      pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ";@ ") pp_lines
    in
    let pp_relfp =
      let absfp = absbasepath config in
      fun fmt fp ->
        match
          MlFront_Core.FilePath.relative ~base:absfp ~from:absfp ~to_:fp ()
        with
        | Ok relfp -> fprintf fmt "./%s" (MlFront_Core.FilePath.to_string relfp)
        | Error _ -> MlFront_Core.FilePath.pp fmt fp
    in
    let just_items ({ items } : DkZero_Base.WorkspaceConfig.t) = items in
    let just_declaration
        ({ declaration; sections = _ } : DkZero_Base.WorkspaceConfig.item) =
      declaration
    in
    p f "@[<v>";
    p f "threaddir: %a@;" MlFront_Core.FilePath.pp (threaddir config);
    p f "verbose: %a@;" pp_opt_bool (verbose config);
    p f "explain: %a@;" pp_opt_bool (explain config);
    p f "parsetrace: %a@;" pp_opt_bool (parsetrace config);
    p f "intermediate: %a@;" pp_opt_bool (intermediate config);
    p f "buildlogtrace: %a@;" pp_opt_bool (buildlogtrace config);
    p f "debug_task: %a@;" pp_opt_bool (debug_task config);
    p f "importtrace: %a@;" pp_opt_bool (importtrace config);
    p f "importtrace2: %a@;" pp_opt_bool (importtrace2 config);
    p f "nobuiltininc: %a@;" pp_opt_bool (nobuiltininc config);
    p f "nosysinc: %a@;" pp_opt_bool (nosysinc config);
    p f "sysincludedirs: [%a]@;" pp_list (sysincludedirs config);
    p f "workspaceincludedirs: [@[<hov>%a@]]@;" pp_list
      (workspaceincludedirs config);
    p f "userincludedirs: [@[<hov>%a@]]@;" pp_list (userincludedirs config);
    p f "local_packages: [@[<hov>%a@]]@;" pp_list
      (List.map MlFront_Core.PackageId.full_name (local_packages config));
    p f "build_number: %s@;" (build_number config);
    p f "long_ids: %b@;" (long_ids config);
    p f "integrity: %s@;"
      (match integrity config with
      | `None -> "None"
      | `Existence -> "Existence"
      | `Checksum -> "Checksum");
    p f "workspacedir: %a@;" pp_relfp (workspacedir_maybe_relto_basedir config);
    p f "workspacefile: %a@;" (pp_print_option pp_relfp)
      (workspacefile_maybe_relto_basedir config);
    p f "@[<hov 2>workspaceconfig:@ @[<v>%a@]@]@;"
      (pp_print_option
         (pp_print_list
            ~pp_sep:(fun fmt () -> fprintf fmt " ;;@ ")
            (fun ppf declaration -> pp_lines ppf (just_declaration declaration))))
      (Option.map just_items (workspaceconfig config));
    p f "valuestore: %a@;" MlFront_Core.FilePath.pp
      (valuestore_maybe_relto_basedir config);
    p f "tracestore: %a@;" MlFront_Core.FilePath.pp
      (tracestore_maybe_relto_basedir config);
    p f "tracefile: %s@;" (tracefile config);
    p f "cells: [@[<hov>%a@]]@;"
      (pp_print_list
         ~pp_sep:(fun fmt () -> fprintf fmt ";@ ")
         (fun ppf (cellname, fp) ->
           (* The cells should be relative paths since they are
            conventionally subdirectories of the basepath *)
           fprintf ppf "%s=%a" cellname pp_relfp fp))
      (DkZero_Base.Config.CellMap.bindings config.cells);
    p f "install_home: %a@;" MlFront_Core.FilePath.pp (install_home config);
    p f "install_cache: %a@;" MlFront_Core.FilePath.pp (install_cache config);
    p f "install_data: %a@;" MlFront_Core.FilePath.pp (install_data config);
    p f "install_config: %a@;" MlFront_Core.FilePath.pp (install_config config);
    p f "install_state: %a@;" MlFront_Core.FilePath.pp (install_state config);
    p f "install_runtime: %a@;" MlFront_Core.FilePath.pp
      (install_runtime config);
    p f "build_pubkey: @[%a@]@;"
      (pp_print_list ~pp_sep:pp_print_cut (fun ppf v -> fprintf ppf "%s" v))
      (match build_pubkey config with `PublicKey s -> lines s);
    p f "build_seckey: %s@;"
      (match build_seckey config with `SecretKey _ -> "<secret key>");
    p f "metadb: %a@;" MlFront_Cache.MetaDb.pp (metadb config);
    p f "builtin_valuesjson: [%a]@;"
      (pp_print_list
         ~pp_sep:(fun fmt () -> fprintf fmt ";@ ")
         (fun ppf v -> fprintf ppf "%s" (Io.file_origin v)))
      (builtin_valuesjson config);
    p f "deny_deprecated_function_args: %b@;"
      (deny_deprecated_function_args config);
    p f "import: %s@;"
      (match import config with `Eager -> "Eager" | `Lazy -> "Lazy");
    p f "@]"

  (** An identifier within the source of a build file and the context for
      running a shell command. *)
  module ValueContext = struct
    type nonrec t = {
      id : MlFront_Thunk.ThunkCommand.module_version;
      id_range : Fmlib_parse.Position.range;
      source : Io.file_object;
      source_sha256 : string;
      ctx : t;
      build_request : DkZero_Base.BuildRequest.t;
    }

    let create ~id ~source ~source_sha256 ctx ~build_request =
      {
        id = snd id;
        id_range = fst id;
        source;
        source_sha256;
        ctx;
        build_request;
      }

    let debug_reference
        { source; source_sha256; id = _; id_range; ctx = _; build_request = _ }
        : K.reference option =
      Some
        {
          reference_range = id_range;
          reference_file_sha256 = source_sha256;
          reference_transient = Some { reference_file = source };
        }

    let module_id { id; _ } = id.id
    let module_semver { id; _ } = id.version
    let ctx { ctx; _ } = ctx
    let build_request { build_request; _ } = build_request
    let source { source; _ } = source
  end

  type value_context = ValueContext.t

  let of_value_context (vc : ValueContext.t) : t = vc.ctx
  let vc_debug_reference vc = ValueContext.debug_reference vc
  let vc_module_id vc = ValueContext.module_id vc
  let vc_module_semver vc = ValueContext.module_semver vc
  let vc_build_request vc = ValueContext.build_request vc
  let vc_source vc = ValueContext.source vc
  let interactive_spawn = BuildSpawner.interactive_spawn
  let with_rootprogressnode ctx rootprogressnode = { ctx with rootprogressnode }

  module FileMod' = FileMod.Make (Promise) (Io)

  module OutputRequest = struct
    type nonrec t = {
      ctx : t;
      build_request : DkZero_Base.BuildRequest.t;
      may_clear_outputdir_if_needed : bool;
    }

    let create ctx ~build_request ~may_clear_outputdir_if_needed () =
      { ctx; build_request; may_clear_outputdir_if_needed }

    let ctx { ctx; _ } = ctx
    let build_request { build_request; _ } = build_request

    let may_clear_outputdir_if_needed { may_clear_outputdir_if_needed; _ } =
      may_clear_outputdir_if_needed
  end

  module G = MlFront_Thunk.ThunkGlob.Make (Promise) (Io) (Io)

  type err = { error_code : string; cant_do : string; because : string }

  let fail_if_error =
    let open Syntax in
    function
    | Ok v -> return v
    | Error { error_code; cant_do; because } ->
        fail ~error_code ~cant_do ~because ()

  let is_file_executable ~executables file =
    let normalizedentry =
      MlFront_Core.FilePath.(of_string_exn (basename file))
    in
    G.glob_file (List.map snd executables) normalizedentry

  let output_progress_label ~action dest =
    DkZero_Base.BuildProgress.abbreviate_label
      (Printf.sprintf "out: %s %s" action
         (MlFront_Core.FilePath.to_string dest))

  let output_progress_extract_label ~archive_member () =
    DkZero_Base.BuildProgress.abbreviate_label
      (Printf.sprintf "out: extract %s" archive_member)

  let output_transfer_progress_label ~have_done =
    DkZero_Base.BuildProgress.abbreviate_label have_done

  let set_output_progress_step ?estimated_total output_progress ~label =
    MlFront_Progress.Progress.set_name output_progress label;
    MlFront_Progress.Progress.set_completed_items output_progress 0;
    match estimated_total with
    | Some total ->
        MlFront_Progress.Progress.set_estimated_total_items output_progress
          total
    | None ->
        MlFront_Progress.Progress.set_estimated_total_items output_progress 1

  let get_value_file ~valuestore ~value_id () =
    let return = Promise.return in
    match MlFront_Core.FilePath.append valuestore value_id with
    | Error _ -> return None
    | Ok value_fp ->
        if Sys.file_exists (MlFront_Core.FilePath.to_string value_fp) then
          return (Some value_fp)
        else return None

  let rec unzip_and_cache_value ctx ~source range value :
      MlFront_Core.FilePath.t option cont =
    let open Syntax in
    let g ~value_id ~category () =
      let* object_archive_opt =
        read_value_or_fail ctx ~value_id ~source range ()
      in
      let metadb = metadb ctx in
      match object_archive_opt with
      | None -> return None
      | Some object_archive -> (
          (* if the source or destination is an absolute path,
                     we can use [longpath_capable_filepath] *)
          MlFront_Thunk.Assumptions
          .mlfront_zipfile_accepts_long_paths_on_windows ();
          let srczip =
            MlFront_Thunk_IoDisk.ThunkIoDisk.longpath_capable_filepath
              ~absbasepath:(absbasepath ctx) ~functions:`MlFront_ZipFile
              object_archive
          in
          let dbresult : ((MlFront_Core.FilePath.t, _) result, _) result =
            MlFront_Cache.MetaDb.with_sync ~supercategory:"val" metadb
              (fun
                ~data_ops:(module DataOps : MlFront_Cache.MetaOps.S)
                ~cache_ops:(module CacheOps : MlFront_Cache.MetaOps.S)
              ->
                CacheOps.cache_dir ~category ~key:value_id
                  ~cache_hit:(fun ~dir_for_upsert:_ _cdir -> Ok `Keep)
                  ~cache_miss:(fun ~dir_for_upsert ->
                    (* if the source or destination is an absolute path,
                     we can use [longpath_capable_filepath] *)
                    MlFront_Thunk.Assumptions
                    .mlfront_zipfile_accepts_long_paths_on_windows ();
                    let destdir_s =
                      MlFront_Thunk_IoDisk.ThunkIoDisk.longpath_capable_filepath
                        ~absbasepath:(absbasepath ctx)
                        ~functions:`MlFront_ZipFile dir_for_upsert
                    in
                    (* unzip *)
                    try
                      MlFront_ZipFile.ZipFile.unzip_exn ~srczip
                        ~destdir:destdir_s ();
                      Ok `Upsert
                    with MlFront_ZipFile.ZipFile.ZipError (_zipfile, msg) ->
                      let defer ppf () =
                        Format.fprintf ppf
                          "Unsuccessful unzip of `%s` into `%a`: %s"
                          (MlFront_Core.FilePath.show object_archive)
                          MlFront_Core.FilePath.pp dir_for_upsert msg
                      in
                      Error (`WrappableMsg defer))
                  ())
          in
          match dbresult with
          | Ok (Ok dir) -> return (Some dir)
          | Ok (Error (`WrappableMsg defer)) | Error (`WrappableMsg defer) ->
              let* () =
                let msg = Format.asprintf "%a" defer () in
                fail_cant_unzip_to_dir ~error_code:"128f875b" ~source ~msg
                  ~srczip range
              in
              return None)
    in
    match (value : V.t) with
    | Object { value_id; value_sha256 = _; value = Some _ } ->
        g ~value_id ~category:"object" ()
    | Bundle { value_id; value_sha256 = _; value = Some _ } ->
        g ~value_id ~category:"bundle" ()
    | Asset { value_id; value_sha256 = _; value = Some _ } ->
        g ~value_id ~category:"asset" ()
    | ScriptModule _ | Distribution _ | Object _ | Constant _ | ValuesJsonFile _
    | ValuesLuaFile _ | Values _ | Form _ | Bundle _ | Asset _ | AssetIndex _ ->
        (* Should never happen. *)
        let* () =
          fail ~error_code:"a5b528dd" ~cant_do:"get value"
            ~because:
              (Format.asprintf "the value is not outputable: %a" V.pp value)
            ~recommendations:[ "This is a bug. Please file an issue." ]
            ()
        in
        return None
    | Input_not_found _ | Ephemeral_ui_response | Failure_is_pending ->
        (* Should never happen. *)
        let* () =
          fail ~error_code:"c04e9687" ~cant_do:"get value"
            ~because:
              (Format.asprintf "the value is not fully specified: %a" V.pp value)
            ~recommendations:[ "This is a bug. Please file an issue." ]
            ()
        in
        return None

  and output_value ~output_request ~source ~command_output ~archive_member key
      value : unit cont =
    let open Syntax in
    let output_progress =
      MlFront_Progress.Progress.start ~estimated_total:1 ~no_rollup:true
        (rootprogressnode (OutputRequest.ctx output_request))
        "output"
    in
    let g ~value_id ~typ () =
      (* Printf.eprintf "[debug] outputting %s `%s`\n%!" typ value_id; *)
      let* value_fp_opt =
        read_value_or_fail
          (OutputRequest.ctx output_request)
          ~value_id ~source (fst command_output) ()
      in
      match value_fp_opt with
      | None -> return ()
      | Some value_fp ->
          (* Printf.eprintf "[debug] got %s value at `%s`\n%!" typ
          (MlFront_Core.FilePath.to_string fp); *)
          output_object_bundle_or_asset ~output_progress ~output_request ~source
            ~command_output
            ~cant_do:(Printf.sprintf "use value store %s `%s`" typ value_id)
            ~archive_member value_fp
    in
    let* () =
      match (value : V.t) with
      | Object
          {
            value_id;
            value_sha256 = _;
            value =
              Some
                {
                  object_id = _;
                  object_slot = _;
                  object_range = _;
                  object_origin = _;
                };
          } ->
          g ~value_id ~typ:"object" ()
      | Bundle { value_id; value_sha256 = _; value = Some _ } ->
          g ~value_id ~typ:"bundle" ()
      | Asset
          {
            value_id;
            value_sha256 = _;
            value =
              Some
                {
                  asset_values_canonical_id = _;
                  asset_values_file_type = _;
                  asset_values_file_sha256 = _;
                  asset_id = _;
                  asset_path = _;
                  asset_range = _;
                  asset_origin_name = _;
                  asset_mirrors = _;
                  asset_checksum = _;
                };
          } ->
          g ~value_id ~typ:"asset" ()
      | Constant
          {
            value_id;
            value_sha256 = _;
            value = Some { constant_transient = Some { constant_value } };
          } ->
          output_constant ~output_progress ~key ~output_request ~source
            ~command_output ~archive_member ~constantid:value_id constant_value
      | ScriptModule _ | Distribution _ | Object _ | Constant _
      | ValuesJsonFile _ | ValuesLuaFile _ | Values _ | Form _ | Bundle _
      | Asset _ | AssetIndex _ ->
          (* Should never happen. *)
          fail ~error_code:"92f60570" ~cant_do:"output value"
            ~because:
              (Format.asprintf "the value is not outputable: %a" V.pp value)
            ~recommendations:[ "This is a bug. Please file an issue." ]
            ()
      | Input_not_found _ | Ephemeral_ui_response | Failure_is_pending ->
          (* Should never happen. *)
          fail ~error_code:"6d73e0d1" ~cant_do:"output value"
            ~because:
              (Format.asprintf "the value is not fully specified: %a" V.pp value)
            ~recommendations:[ "This is a bug. Please file an issue." ]
            ()
    in
    MlFront_Progress.Progress.end_ output_progress;
    return ()

  and mkdir ~source ~what range fp =
    let open Syntax in
    match MlFront_Core.FilePath.rootless_segments fp with
    | [] -> return ()
    | _ :: _ -> (
        let fp_dir = disk_dir fp in
        let* createdir_result = lift_promise @@ Io.create_directory fp_dir in
        match createdir_result with
        | `Error e ->
            let* error_locations = range_into_problem_location ~source range in
            fail ~error_code:"14019995"
              ~cant_do:(Printf.sprintf "create %s" what)
              ~because:e ~error_locations ()
        | `Created -> return ())

  and rmdir ~source ~what range fp =
    let open Syntax in
    let fp_dir = disk_dir fp in
    let* removedir_result = lift_promise @@ Io.delete_directory fp_dir in
    match removedir_result with
    | `Error e ->
        let* error_locations = range_into_problem_location ~source range in
        fail ~error_code:"fb3e2c3e"
          ~cant_do:(Printf.sprintf "remove %s" what)
          ~because:e ~error_locations ()
    | `Deleted -> return ()

  (** Use a value that has just been placed in the value store. The sha256 of
      that value is computed on the fly, and depending on the integrity
      configuration the value may be validated on the flay. *)
  and read_value_or_fail ctx ~value_id ~source range () =
    let open Syntax in
    let* fp_opt =
      lift_promise
      @@ get_value_file
           ~valuestore:(valuestore_maybe_relto_basedir ctx)
           ~value_id ()
    in
    begin
      let* error_locations = range_into_problem_location ~source range in
      match fp_opt with
      | None ->
          let* () =
            fail ~error_code:"98ca2699"
              ~cant_do:(Printf.sprintf "find cached value `%s`" value_id)
              ~because:
                (Printf.sprintf "it is not present in the value store `%s`"
                   (MlFront_Core.FilePath.to_string
                      (valuestore_maybe_relto_basedir ctx)))
              ~error_locations
              ~recommendations:
                [
                  "The value may have been evicted from the value store. Try \
                   rerunning with the `--integrity existence` or the \
                   `--integrity checksum` option.";
                ]
              ()
          in
          return None
      | Some fp ->
          (* let* sha256_result =
          lift_promise @@ Io.sha256_file (disk_file fp)
        in
        match sha256_result with
        | `Error e ->
            let* () =
              fail ~error_code:"502ef6b2"
                ~cant_do:
                  (Printf.sprintf
                     "compute the checksum of the cached value `%s`" value_id)
                ~because:e ~error_locations ()
            in
            return None
        | `Sha256 sha256 -> return (Some (fp, `Sha256 sha256))
         *)
          return (Some fp)
    end

  and output_constant ~output_progress ~key ~output_request ~source
      ~command_output ~archive_member ~constantid constantvalue =
    let open Syntax in
    let output_range, shell_output =
      (command_output
        : Fmlib_parse.Position.range
          * MlFront_Thunk.ThunkCommand.resolved_shell_output)
    in
    let write_constantfile ~what fp =
      let () =
        set_output_progress_step output_progress
          ~label:(output_progress_label ~action:"write" fp)
      in
      let* () =
        mkdir ~source ~what output_range (MlFront_Core.FilePath.parent fp)
      in
      (* Write the constant value to the file. *)
      let* replace_result =
        lift_promise
        @@ Io.replace_all_string (disk_file fp) constantvalue 0
             (String.length constantvalue)
      in
      match replace_result with
      | `Error e ->
          let* error_locations =
            range_into_problem_location ~source output_range
          in
          fail ~error_code:"1f193cdd" ~cant_do:"write constant to file"
            ~because:e ~error_locations ()
      | `IsDirectory _ ->
          let* error_locations =
            range_into_problem_location ~source output_range
          in
          fail ~error_code:"d644796b" ~cant_do:"write constant to file"
            ~because:"the file is a directory" ~error_locations ()
      | `WroteBytes -> return ()
    in

    (* In MlFront_ZipFile we do not (yet) support in-memory zip archives, so
     we stage the in-memory zip archives to a file when we have to do zip
     operations. *)
    let stage_constantfile () =
      let fp =
        MlFront_Core.FilePath.append_exn
          (BuildPaths'.resolve_labeled_path
             (OutputRequest.ctx output_request)
             ~build_request:(OutputRequest.build_request output_request)
             `StagedConstant)
          constantid
      in
      let* () = write_constantfile ~what:"staging directory for constants" fp in
      return fp
    in
    (* When an archive member is requested, stage the object into an intermediate
     zipfile and then extract the file/directory from that intermediate
     zipfile. *)
    match archive_member with
    | Some archive_member ->
        if MlFront_ZipFile.ZipFile.is_string_zip constantvalue then
          let* constantfile = stage_constantfile () in
          output_from_unindexed_archive_member ~output_progress ~output_request
            ~source ~command_output
            ~cant_do:
              (Printf.sprintf
                 "copy the archive member `%s` of the zipped value `%s to the \
                  output directory"
                 archive_member
                 (MlFront_Core.FilePath.to_string constantfile))
            ~srczip:constantfile archive_member
        else
          fail_no_archive_member_without_zip ~source ~archive_member
            output_range key
    | None ->
    match shell_output with
    | ROutputFile { file; executables } -> begin
        match
          BuildPaths'.resolved_as_filepath_for_build_request
            (OutputRequest.ctx output_request)
            ~build_request:(OutputRequest.build_request output_request)
            file
        with
        | Ok destination ->
            let* () =
              write_constantfile ~what:"directory for output file" destination
            in
            let* mkexec_result =
              let is_executable = is_file_executable ~executables destination in
              if is_executable then
                lift_promise
                @@ FileMod'.make_executable
                     ~basedir:(absbasepath (OutputRequest.ctx output_request))
                     ~codesign_tmp:
                       (BuildPaths'.resolve_user_codesign_path
                          (OutputRequest.ctx output_request))
                     ~on_error:(fun ~error_code ~cant_do ~because () ->
                       Promise.return { error_code; cant_do; because })
                     destination
              else return (Ok ())
            in
            fail_if_error mkexec_result
        | Error e -> fail_bad_expression ~source ~because:e output_range
      end
    | ROutputDir { dir; strip; excludes = _; executables = _ } ->
        if MlFront_ZipFile.ZipFile.is_string_zip constantvalue then
          let* constantfile = stage_constantfile () in
          output_from_filepath ~output_progress ~output_request ~source
            ~command_output
            ~cant_do:
              (Printf.sprintf
                 "copy the zipped value to the output directory `%s`"
                 (MlFront_Core.FilePath.to_string constantfile))
            constantfile
        else begin
          let* () =
            if strip <> 0 then
              fail_no_strip_without_zip ~strip ~source
                (fun ppf () -> Format.fprintf ppf "the constant value")
                () output_range key
            else return ()
          in
          match
            BuildPaths'.resolved_as_filepath_for_build_request
              (OutputRequest.ctx output_request)
              ~build_request:(OutputRequest.build_request output_request)
              dir
          with
          | Error e -> fail_bad_expression ~source ~because:e output_range
          | Ok destination ->
              let* () =
                write_constantfile ~what:"output directory"
                  (MlFront_Core.FilePath.append_exn destination "OBJECT")
              in
              return ()
        end

  and output_object_bundle_or_asset ~output_progress ~output_request ~source
      ~command_output ~cant_do ~archive_member sourcevalue =
    (* When an archive member is requested, stage the object into an intermediate
     zipfile and then extract the file/directory from that intermediate
     zipfile. *)
    match archive_member with
    | None ->
        output_from_filepath ~output_progress ~output_request ~source
          ~command_output ~cant_do sourcevalue
    | Some archive_member ->
        (* right now we do not care about the index for local files; it won't
         improve performance *)
        output_from_unindexed_archive_member ~output_progress ~output_request
          ~source ~command_output ~cant_do ~srczip:sourcevalue archive_member

  (** Stage the object into an intermediate zipfile and then extract the
      file/directory from that intermediate zipfile. *)
  and output_from_unindexed_archive_member ~output_progress ~output_request
      ~source ~command_output ~cant_do ~srczip archive_member =
    let open Syntax in
    let srczip_s = MlFront_Core.FilePath.to_string srczip in
    let destfile =
      BuildPaths'.resolve_labeled_path
        (OutputRequest.ctx output_request)
        ~build_request:(OutputRequest.build_request output_request)
        (`StagedArchiveMember archive_member)
    in
    let destfile_s = MlFront_Core.FilePath.to_string destfile in
    let* () =
      let () =
        set_output_progress_step output_progress
          ~label:(output_progress_extract_label ~archive_member ())
      in
      try
        MlFront_ZipFile.ZipFile.unzip_entry_exn ~srczip:srczip_s
          ~destfile:(MlFront_Core.FilePath.to_string destfile)
          archive_member;
        MlFront_Progress.Progress.set_completed_items output_progress 1;
        return ()
      with MlFront_ZipFile.ZipFile.ZipError (_zipfile, msg) ->
        fail_cant_unzip_file ~source ~msg ~srczip:srczip_s ~destfile:destfile_s
          ~path:archive_member (fst command_output)
    in
    if Sys.file_exists (MlFront_Core.FilePath.to_string destfile) then
      output_from_filepath ~output_progress ~output_request ~source
        ~command_output ~cant_do destfile
    else
      fail_archive_member_not_found ~source ~srczip ~cant_do ~archive_member
        (fst command_output)

  and output_from_filepath ~output_progress ~output_request ~source
      ~command_output ~cant_do fp =
    let open Syntax in
    match
      (command_output
        : Fmlib_parse.Position.range
          * MlFront_Thunk.ThunkCommand.resolved_shell_output)
    with
    | output_range, ROutputFile { file; executables } -> begin
        match
          BuildPaths'.resolved_as_filepath_for_build_request
            (OutputRequest.ctx output_request)
            ~build_request:(OutputRequest.build_request output_request)
            file
        with
        | Error e -> fail_bad_expression ~source ~because:e output_range
        | Ok file ->
            let () =
              set_output_progress_step output_progress
                ~label:(output_progress_label ~action:"copy" file)
            in
            let copy_progress =
              MlFront_Progress.Progress.start ~estimated_total:1 ~no_rollup:true
                output_progress
                (output_transfer_progress_label ~have_done:"MiB copied")
            in
            (* Printf.eprintf "[debug] copying `%s` to `%s`\n%!"
            (MlFront_Core.FilePath.to_string fp)
            (MlFront_Core.FilePath.to_string file); *)
            let* () =
              mkdir ~source ~what:"directory of output file" output_range
                (MlFront_Core.FilePath.parent file)
            in
            let mib = 1_048_576L in
            let copy_total_bytes = ref 0L in
            let copy_completed_mib = ref 0 in
            let on_write_total write_total =
              copy_total_bytes := write_total;
              let completed_mib = Int64.(to_int (div write_total mib)) in
              if completed_mib > !copy_completed_mib then begin
                copy_completed_mib := completed_mib;
                MlFront_Progress.Progress.set_estimated_total_items
                  copy_progress (completed_mib + 1);
                MlFront_Progress.Progress.set_completed_items copy_progress
                  completed_mib
              end;
              Promise.return ()
            in
            let* () =
              copy_file_or_fail ~source ~src:fp ~dest:file ~cant_do
                ~on_write_total output_range
            in
            let copy_total_mib =
              if !copy_total_bytes = 0L then 1
              else Int64.(to_int (div (add !copy_total_bytes (sub mib 1L)) mib))
            in
            let () =
              MlFront_Progress.Progress.set_estimated_total_items copy_progress
                copy_total_mib;
              MlFront_Progress.Progress.set_completed_items copy_progress
                copy_total_mib
            in
            MlFront_Progress.Progress.end_ copy_progress;
            let () =
              MlFront_Progress.Progress.set_completed_items output_progress 1
            in
            let* mkexec_result =
              let is_executable = is_file_executable ~executables file in
              if is_executable then
                lift_promise
                @@ FileMod'.make_executable
                     ~basedir:(absbasepath (OutputRequest.ctx output_request))
                     ~codesign_tmp:
                       (BuildPaths'.resolve_user_codesign_path
                          (OutputRequest.ctx output_request))
                     ~on_error:(fun ~error_code ~cant_do ~because () ->
                       Promise.return { error_code; cant_do; because })
                     file
              else return (Ok ())
            in
            fail_if_error mkexec_result
      end
    | output_range, ROutputDir { dir; strip; excludes; executables } -> begin
        match
          BuildPaths'.resolved_as_filepath_for_build_request
            (OutputRequest.ctx output_request)
            ~build_request:(OutputRequest.build_request output_request)
            dir
        with
        | Error e -> fail_bad_expression ~source ~because:e output_range
        | Ok destdir ->
            let () =
              set_output_progress_step output_progress
                ~label:(output_progress_label ~action:"unzip" destdir)
            in
            let unzip_progress =
              MlFront_Progress.Progress.start ~estimated_total:1 ~no_rollup:true
                output_progress
                (output_transfer_progress_label ~have_done:"entries unzipped")
            in
            (* if the source or destination is an absolute path,
             we can use [longpath_capable_filepath] *)
            MlFront_Thunk.Assumptions
            .mlfront_zipfile_accepts_long_paths_on_windows ();
            let destdir_s =
              MlFront_Thunk_IoDisk.ThunkIoDisk.longpath_capable_filepath
                ~absbasepath:(absbasepath (OutputRequest.ctx output_request))
                ~functions:`MlFront_ZipFile destdir
            in
            let sourcevalue_s =
              MlFront_Thunk_IoDisk.ThunkIoDisk.longpath_capable_filepath
                ~absbasepath:(absbasepath (OutputRequest.ctx output_request))
                ~functions:`MlFront_ZipFile fp
            in
            (* check if zipfile *)
            if MlFront_ZipFile.ZipFile.is_file_zip sourcevalue_s then
              (* On macOS especially, where macOS can mark files within a .app or
              .bundle directory as read-only (xattr com.apple.macl) due to code
              signature verification, we must delete the directory first. *)
              let* () =
                if OutputRequest.may_clear_outputdir_if_needed output_request
                then
                  let* () =
                    rmdir ~source ~what:"output directory" output_range destdir
                  in

                  mkdir ~source ~what:"output directory" output_range destdir
                else return ()
              in
              let exclude_globs = List.map snd excludes in
              let executable_globs = List.map snd executables in
              let last_entry = ref None in
              let unzip_total_entries = ref 1 in
              let pending_executable_files = ref [] in
              (* do unzip *)
              try
                MlFront_ZipFile.ZipFile.unzip_exn
                  ~on_entry:(fun s isdir _i _n ->
                    unzip_total_entries := max 1 _n;
                    let () =
                      MlFront_Progress.Progress.set_estimated_total_items
                        unzip_progress _n
                    in
                    let () =
                      MlFront_Progress.Progress.set_completed_items
                        unzip_progress _i
                    in
                    match (isdir, MlFront_Core.FilePath.of_string s) with
                    | _, Error _ ->
                        (* skip if entry is not a valid path *)
                        false
                    | true, Ok _fp ->
                        (* always include directories *)
                        true
                    | false, Ok fp ->
                        let fp = MlFront_Core.FilePath.normalize fp in
                        (* check excludes, whether files or directories *)
                        if G.glob_file exclude_globs fp then
                          (* excluded *)
                          false
                        else begin
                          (* not excluded *)
                          last_entry := Some s;
                          (* track executable files *)
                          if G.glob_file executable_globs fp then
                            pending_executable_files :=
                              s :: !pending_executable_files;
                          (* include the entry *)
                          true
                        end)
                  ~strip ~srczip:sourcevalue_s ~destdir:destdir_s ();
                MlFront_Progress.Progress.set_completed_items unzip_progress
                  !unzip_total_entries;
                MlFront_Progress.Progress.end_ unzip_progress;
                let () =
                  MlFront_Progress.Progress.set_completed_items output_progress
                    1
                in
                (* make executable files *)
                let* mkexec_all_result : (unit, err) result list =
                  let basedir =
                    absbasepath (OutputRequest.ctx output_request)
                  in
                  let codesign_tmp =
                    BuildPaths'.resolve_user_codesign_path
                      (OutputRequest.ctx output_request)
                  in
                  lift_promise
                  @@ Promise.parallel
                       (List.map
                          (fun s ->
                            let fp =
                              MlFront_Core.FilePath.append_exn destdir s
                            in
                            FileMod'.make_executable ~basedir ~codesign_tmp
                              ~on_error:(fun ~error_code ~cant_do ~because () ->
                                Promise.return { error_code; cant_do; because })
                              fp)
                          !pending_executable_files)
                in
                let (mkexec_firsterror_result : (unit, err) result) =
                  List.fold_left
                    (fun acc r ->
                      match (acc, r) with
                      | Ok (), Ok () -> Ok ()
                      | Error e, _ -> Error e
                      | _, Error e -> Error e)
                    (Ok ()) mkexec_all_result
                in
                let* () = fail_if_error mkexec_firsterror_result in
                (* done *)
                return ()
              with MlFront_ZipFile.ZipFile.ZipError (_zipfile, msg) ->
                let recommendations =
                  match DkZero_Base.Execution.os_v3 () with
                  (* When the file entry is too large to open on Win32 ...
                
                   [file open failed] is miniz.h MZ_ZIP_FILE_OPEN_FAILED error.
                   [file not found] is zip.h (kubazip) error.

                   We removed kubazip but still check if revert back. *)
                  | Ok (Windows, _slot)
                    when String.equal msg "file open failed"
                         || String.equal msg "file not found" -> (
                      let common_max_path =
                        [
                          "Windows power users may consider turning on long \
                           path support: \
                           https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation?tabs=powershell#registry-setting-to-enable-long-paths";
                        ]
                      in
                      match !last_entry with
                      | None ->
                          [
                            Printf.sprintf
                              "Look inside the zip file and see if any entries \
                               would exceed 260 (MAX_PATH) characters if \
                               extracted to the directory `%s`. Shorten the \
                               directory if needed."
                              destdir_s;
                          ]
                          @ common_max_path
                      | Some last_entry ->
                          [
                            Printf.sprintf
                              "Look inside the zip file and see if the entry \
                               `%s` would exceed 260 (MAX_PATH) characters if \
                               extracted to the directory `%s`. Shorten the \
                               directory if needed."
                              last_entry destdir_s;
                          ]
                          @ common_max_path)
                  | Ok ((OSX | IOS), _slot) -> (
                      (* On macOS any app or bundle (ex. CMake.app) which has
                       any executable run inside it (ie. trigger code signature
                       verification) will have a 'com.apple.macl'
                       xattr placed on it, causing the app or bundle to be
                       read-only. *)
                      match !last_entry with
                      | None ->
                          [
                            Printf.sprintf
                              "On macOS, if the zip file generates any .app or \
                               .bundle directories inside `%s`, they may be \
                               marked read-only due to macOS code signature \
                               verification. After unzipping, you may need to \
                               remove the 'com.apple.macl' extended attribute \
                               using the 'xattr' command-line tool."
                              destdir_s;
                          ]
                      | Some last_entry ->
                          [
                            Printf.sprintf
                              "On macOS, if the zip file generates a file `%s` \
                               within a .app or .bundle directory inside `%s`, \
                               it may be marked read-only due to macOS code \
                               signature verification. After unzipping, you \
                               may need to remove the 'com.apple.macl' \
                               extended attribute using the 'xattr' \
                               command-line tool."
                              last_entry destdir_s;
                          ])
                  | _ -> []
                in
                fail_cant_unzip_to_dir ~recommendations ~error_code:"95c53c91"
                  ~source ~msg ~srczip:sourcevalue_s ~destdir:destdir_s
                  output_range
            else
              fail_dest_is_dir_but_source_not_zip ~source ~cant_do output_range
      end

  and fail_cant_unzip_to_dir ?destdir ?recommendations ~error_code ~source ~msg
      ~srczip range =
    let open Syntax in
    let* error_locations = range_into_problem_location ~source range in
    fail ?recommendations ~error_code
      ~cant_do:
        (match destdir with
        | Some destdir -> Printf.sprintf "unzip `%s` into `%s`" srczip destdir
        | None -> Printf.sprintf "unzip `%s`" srczip)
      ~because:msg ~error_locations ()

  and fail_cant_unzip_file ?destfile ~source ~msg ~srczip ~path range =
    let open Syntax in
    let* error_locations = range_into_problem_location ~source range in
    fail ~error_code:"ee3b4e89"
      ~cant_do:
        (match destfile with
        | Some destfile ->
            Printf.sprintf "unzip `%s` in `%s` to `%s` from `%s`" path srczip
              destfile (Sys.getcwd ())
        | None ->
            Printf.sprintf "unzip `%s` in `%s` from `%s`" path srczip
              (Sys.getcwd ()))
      ~because:msg ~error_locations ()

  and fail_no_archive_member_without_zip ~source ~archive_member range key =
    let open Syntax in
    let* error_locations = range_into_problem_location ~source range in
    fail ~error_code:"88de79d8"
      ~cant_do:
        (Format.asprintf "get archive member `%s` from %a" archive_member K.pp
           key)
      ~because:"the constant value is not a zipfile" ~error_locations ()

  and fail_no_strip_without_zip ~source ~strip pp_target target range key =
    let open Syntax in
    let* error_locations = range_into_problem_location ~source range in
    fail ~error_code:"6a51c6c0"
      ~cant_do:(Format.asprintf "strip `%d` levels from %a" strip K.pp key)
      ~because:(Format.asprintf "%a is not a zipfile" pp_target target)
      ~error_locations ()

  and fail_dest_is_dir_but_source_not_zip ~source ~cant_do range =
    let open Syntax in
    let* error_locations = range_into_problem_location ~source range in
    fail ~error_code:"d105a5c5" ~cant_do
      ~because:"directories can't be an output if the source is not a zipfile"
      ~error_locations
      ~recommendations:
        [
          "Use `-d DIR` only when the source is a zipfile. Try `-f FILE` \
           instead.";
        ]
      ()

  and fail_archive_member_not_found ~source ~srczip ~cant_do ~archive_member
      range =
    let open Syntax in
    let* error_locations = range_into_problem_location ~source range in
    fail ~error_code:"73b4560b" ~cant_do
      ~because:
        (Printf.sprintf "the archive member `%s` was not found" archive_member)
      ~error_locations
      ~recommendations:
        [
          Printf.sprintf
            "Use `unzip -l` on Unix or your favorite zip tool (ex. WinZip, \
             7zip) on Windows to list the archive members of `%s`. Make sure \
             you use the exact name listed, including any `./` prefix."
            (MlFront_Core.FilePath.to_string srczip);
        ]
      ()

  and fail_bad_expression ~source ~because range =
    let open Syntax in
    let* error_locations = range_into_problem_location ~source range in
    fail ~error_code:"42a341f3" ~cant_do:"evaluate the expression" ~because
      ~error_locations ()

  and range_into_problem_location ~source range :
      MlFront_Thunk.BuildWriters.Standard.problem_location list cont =
    let open Syntax in
    let* read_result = lift_promise @@ Io.read_all source in
    match read_result with
    | `Error _ | `ExceededSizeLimit _ -> return []
    | `Content source_code ->
        return
          [
            MlFront_Thunk.BuildWriters.Standard.
              {
                origin = Some (Io.file_origin source);
                source = source_code;
                range;
              };
          ]

  and copy_file_or_fail ?on_write_total ~source ~src ~dest ~cant_do range =
    let open Syntax in
    let had_error_because = ref None in
    let* () =
      lift_promise
      @@ Io.copy_or_fail ?on_write_total ~src:(disk_file src)
           ~dest:(disk_file dest)
           ~on_error:(fun because ->
             had_error_because := Some because;
             Promise.return ())
           (Promise.return ())
    in
    match !had_error_because with
    | Some because ->
        let* error_locations = range_into_problem_location ~source range in
        fail ~error_code:"57d1803c" ~cant_do ~because ~error_locations ()
    | None -> return ()

  let memoize_output ctx ~key ~description ~max_wait_seconds f_populate :
      (MlFront_Core.FilePath.t, string) result cont =
    let open Syntax in
    let trace, pp_trace_descr =
      if verbosity ctx >= 3 then
        ( true,
          fun ~dir_for_upsert ppf () ->
            Format.fprintf ppf "for `%s` in %a" description
              MlFront_Core.FilePath.pp dir_for_upsert )
      else if verbosity ctx >= 2 then
        ( true,
          fun ~dir_for_upsert:_ ppf () ->
            Format.fprintf ppf "for `%s`" description )
      else (false, fun ~dir_for_upsert:_ _ppf () -> ())
    in
    let {
      data_ops = (module DataOps : MlFront_Cache.MetaOps.S_ASYNC);
      cache_ops = (module CacheOps : MlFront_Cache.MetaOps.S_ASYNC);
      close_db = _;
    } : MlFront_Cache.MetaDb.connection =
      meta_conn ctx
    in
    let async_kont_result =
      let rec until_not_pending acc_elapsed_seconds =
        let firstresult = CacheOps.cache_dir_async ~category:"sub" ~key () in
        match firstresult with
        | Error e -> return (Error e)
        | Ok MlFront_Cache.MetaOps.Pending ->
            let* { advised_throttle_sec; elapsed_sec } =
              lift_promise @@ Promise.yield ()
            in
            if acc_elapsed_seconds +. elapsed_sec > max_wait_seconds then
              return
                (Error
                   (`WrappableMsg
                      (fun ppf () ->
                        Format.fprintf ppf
                          "Timed-out waiting `%.2f` seconds on cache directory \
                           lock for `%s`"
                          max_wait_seconds description)))
            else
              let* () =
                lift_promise
                @@ logtrace ~trace (fun l ->
                       l
                         "[DkZero_RuntimeC.ContextC] Cache directory for `%s` \
                          is locked; waiting %.2f seconds"
                         description advised_throttle_sec)
              in
              Thread.delay advised_throttle_sec;
              until_not_pending (acc_elapsed_seconds +. advised_throttle_sec)
        | Ok (MlFront_Cache.MetaOps.Hit { cache_dir }) -> return (Ok cache_dir)
        | Ok (MlFront_Cache.MetaOps.Miss { dir_for_upsert; complete }) -> (
            let* () =
              lift_promise
              @@ logtrace ~trace (fun l ->
                     l "[DkZero_RuntimeC.ContextC] Populating output cache %a"
                       (pp_trace_descr ~dir_for_upsert)
                       ())
            in
            let success = ref false in
            try
              let* () = f_populate dir_for_upsert in
              (* trigger completion *)
              let* () =
                lift_promise
                @@ logtrace ~trace (fun l ->
                       l
                         "[DkZero_RuntimeC.ContextC] Marking output cache %a \
                          complete"
                         (pp_trace_descr ~dir_for_upsert)
                         ())
              in
              success := true;
              match complete `Upsert with
              | Ok () -> return (Ok dir_for_upsert)
              | Error (`WrappableMsg defer) ->
                  let* () =
                    let msg = Format.asprintf "%a" defer () in
                    fail ~error_code:"b0de817c"
                      ~cant_do:"populate cache directory" ~because:msg ()
                  in
                  return (Ok dir_for_upsert)
            with DkZero_Base.Exceptions.EngineShutdown _ as exn ->
              let og = Printexc.get_raw_backtrace () in
              (if not !success then
                 (* mark as failed, but ignore the result since shutting down *)
                 run_isolated_promise
                 @@ logtrace ~trace (fun l ->
                        l
                          "[DkZero_RuntimeC.ContextC] Marking output cache %a \
                           failed because engine is shutting down: %s"
                          (pp_trace_descr ~dir_for_upsert)
                          () (Printexc.to_string exn));
               let (_ : _ result) = complete `Fail in
               ());
              (* reraise *)
              Printexc.raise_with_backtrace exn og)
      in
      until_not_pending 0.0
    in
    let* async_result = async_kont_result in
    match async_result with
    | Ok dir_for_upsert -> return (Ok dir_for_upsert)
    | Error (`WrappableMsg defer) ->
        let msg = Format.asprintf "%a" defer () in
        return (Error msg)

  let output_get_object ctx ~build_request =
    output_value
      ~output_request:
        (OutputRequest.create ctx ~build_request
           ~may_clear_outputdir_if_needed:true ())

  (** The implementation of ["install-object"] mostly the same as
      ["get-object"].

      The real differences are:

      + the output directory is not cleared because
        ["install-object -d OUTPUTDIR"] needs to accumulate files into the same
        directories.
      + how overlapping paths are treated, but that is the responsibility of
        {!BuildPaths'.verify_nonoverlapping_subpaths_for_getobject} *)
  let output_install_object ctx ~build_request =
    output_value
      ~output_request:
        (OutputRequest.create ctx ~build_request
           ~may_clear_outputdir_if_needed:false ())

  let output_post_object ctx ~build_request =
    output_value
      ~output_request:
        (OutputRequest.create ctx ~build_request
           ~may_clear_outputdir_if_needed:true ())

  let output_get_bundle ctx ~build_request =
    output_value ~archive_member:None
      ~output_request:
        (OutputRequest.create ctx ~build_request
           ~may_clear_outputdir_if_needed:true ())

  let output_get_asset ctx ~build_request =
    output_value
      ~output_request:
        (OutputRequest.create ctx ~build_request
           ~may_clear_outputdir_if_needed:true ())
end

module _ : DkZero_Base.BuildContext.S = Impl