Source file BuildCore.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.UserFormKind},
    {!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.UserFormKind} 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). *)

open BuildExceptions

let buildcore_cls =
  MlFront_Thunk.BuildConstraints.StateMessage.new_class_exn
    "MlFront_Exec.BuildCore.PROGRESS"

let pp_lines_of_text ppf (text : string) =
  let lines = String.split_on_char '\n' text in
  Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string) ppf lines

let if_init_error msg = function
  | Ok v -> v
  | Error _ ->
      Format.eprintf
        "@[<v 2>FATAL: The build engine could not be initialized.@;%a@]@."
        pp_lines_of_text msg;
      exit 1

(** The [compatibility_tag] is used to determine if stored {!Marshal} bytes like
    in the trace information or in the value store can be loaded. *)
let compatibility_tag () =
  let version = Sys.ocaml_version in
  let major, minor = Scanf.sscanf version "%u.%u" (fun maj min -> (maj, min)) in
  Printf.sprintf "oc%d%02d_wd%d" major minor Sys.word_size

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

(** Based on ["tests/MlFront_Thunk/Alacarte_xpromise_apparatus.ml"] *)
module Alacarte_xpromise_apparatus = struct
  module Promise = MlFront_Thunk.Promises.PromiseMinimal
end

(** Synchronous build I/O. See {!MlFront_Thunk.ThunkIo} for extending this to an
    asynchronous implementations. *)
module Io = struct
  include
    MlFront_Thunk_IoDisk.ThunkIoDisk.Make (Alacarte_xpromise_apparatus.Promise)
end

(** Based on ["tests/MlFront_Thunk/alacarte_3_2_apparatus.ml"], but diverges
    since the thunk execution does not model a spreadsheet in the store. *)
module Alacarte_3_2_apparatus = struct
  (** {{: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.2} *)

  (** The kinds of module keys. The [UserFormKind] kind are keys selected by the
      user from the ["get-object"], ["install-object"] and ["resume-object"]
      commands. The [UserAssetKind] kind and [UserAssetKind] are keys that
      selected by the user from the ["get-bundle"] and ["get-asset"] commands,
      respectively.

      The kinds are tightly bound to the values module [V]. In other words, some
      key variations are only possible with some types of values. If we wanted
      to complicate the type system but make it correct, we could use a GADT.
      However, this is a reference implementation and most languages do not have
      a GADT so we stick with the simpler approach. The relationship between
      keys and values is captured in
      {!Alacarte_3_2_apparatus.V.maybe_persistent_hash} *)
  type module_kind =
    | UserFormKind of { slot : MlFront_Thunk.ThunkCommand.object_slot }
    | UserBundleKind
    | UserAssetKind of { asset_path : string }
  [@@deriving ord]

  (** The kinds of package keys. The [DistributionPackageKind] kind are keys
      defined in distributions that have signify keys and other forms of
      attestation. *)
  type package_kind = DistributionPackageKind [@@deriving ord]

  (** The type of kinds of checksum keys.

      The [ValuesFileKind] kind represents a key that is a checksum for a values
      file. *)
  type checksum_kind = ValuesFileKind [@@deriving ord]

  (** The kind of canonical identifier keys.

      The [ValuesKind] kind represents a key that is a canonical identifier for
      a parsed values file.*)
  type canonical_id_kind = Values [@@deriving ord]

  (** Instead of [String] we use versioned module ids and the slot as the key.
  *)
  module K : sig
    type reference_transient = { reference_file : Io.file_object }

    type reference = {
      reference_range : Fmlib_parse.Position.range;
      reference_file_sha256 : string;
      reference_transient : reference_transient option;
    }

    type module_key = {
      module_kind : module_kind;
      module_id : MlFront_Core.StandardModuleId.t;
      module_semver : MlFront_Thunk.ThunkSemver64.t;
    }

    type package_key = {
      package_kind : package_kind;
      package_id : MlFront_Core.PackageId.t;
      package_semver : MlFront_Thunk.ThunkSemver64.t;
    }

    type checksum_key = {
      checksum_kind : checksum_kind;
      checksum_sha256_hex : string;
      checksum_sha256_base32 : string;
    }

    type key_datum =
      | ModuleKey of module_key
      | PackageKey of package_key
      | ChecksumKey of checksum_key

    type t = private {
      key_datum : key_datum;
      debug_reference : reference option;
          (** Anywhere the key is referenced. The reference does not participate
              in {!compare}. *)
    }

    val create_checksum_for_values_file :
      debug_reference:reference option ->
      values_file_sha256:string ->
      unit ->
      (t, string) result
    (** [create_checksum_for_values_file ~values_file_sha256 ()] creates a key
        for a checksum value with SHA-256 hex-encoded checksum [sha256]. *)

    val create_for_distribution :
      debug_reference:reference option ->
      package_id:MlFront_Core.PackageId.t ->
      package_semver:MlFront_Thunk.ThunkSemver64.t ->
      unit ->
      t

    val create_for_form :
      apply_aliases:
        (MlFront_Core.StandardModuleId.t ->
        MlFront_Thunk.ThunkSemver64.t ->
        MlFront_Core.StandardModuleId.t * MlFront_Thunk.ThunkSemver64.t)
        option ->
      debug_reference:reference option ->
      module_id:MlFront_Core.StandardModuleId.t ->
      module_semver:MlFront_Thunk.ThunkSemver64.t ->
      slot:MlFront_Thunk.ThunkCommand.object_slot ->
      unit ->
      t
    (** [create_for_form] creates a key for a form with the [UserFormKind] kind.
    *)

    val create_for_bundle :
      apply_aliases:
        (MlFront_Core.StandardModuleId.t ->
        MlFront_Thunk.ThunkSemver64.t ->
        MlFront_Core.StandardModuleId.t * MlFront_Thunk.ThunkSemver64.t)
        option ->
      debug_reference:reference option ->
      module_id:MlFront_Core.StandardModuleId.t ->
      module_semver:MlFront_Thunk.ThunkSemver64.t ->
      unit ->
      t
    (** [create_for_bundle] creates a key for an bundle with the [UserAssetKind]
        kind. *)

    val create_for_asset :
      apply_aliases:
        (MlFront_Core.StandardModuleId.t ->
        MlFront_Thunk.ThunkSemver64.t ->
        MlFront_Core.StandardModuleId.t * MlFront_Thunk.ThunkSemver64.t)
        option ->
      debug_reference:reference option ->
      module_id:MlFront_Core.StandardModuleId.t ->
      module_semver:MlFront_Thunk.ThunkSemver64.t ->
      asset_path:string ->
      unit ->
      t
    (** [create_for_asset ~module_id ~module_semver ~asset_path] creates a key
        for an asset at path [asset_path] with the [UserAssetKind] kind. *)

    val with_debug_reference : t -> reference -> t
    val show : t -> string
    val pp : Format.formatter -> t -> unit

    val compare : t -> t -> int
    (** Compare two keys. *)

    val equal : t -> t -> bool
    val slot_exn : t -> MlFront_Thunk.ThunkCommand.object_slot
    val slot : t -> MlFront_Thunk.ThunkCommand.object_slot option
    val module_version_exn : t -> MlFront_Thunk.ThunkCommand.module_version

    val distribution_pkgver_exn :
      t -> MlFront_Core.PackageId.t * MlFront_Thunk.ThunkSemver64.t

    val reserved_version_key : t
    (** The key of a task that runs the [version] form.

        ["get-object MlFront_Std.Version Release.Agnostic"] returns a string
        containing the version of the [".values.json"] specification and
        reference implementation. Any change to the specification or reference
        implementation that results would result in an invalid value store must
        increase the version. *)

    val reserved_pingpong_key : t
    (** The key of a task that runs a [ping] form.

        ["get-object Thunk.Sample.Ping Pong"] returns a ["ping"] string for the
        [Pong] slot. *)

    val reserved_pongping_key : t
    (** The key of a task that runs a [pong] form.

        ["get-object Thunk.Sample.Pong Ping"] returns a ["pong"] string for the
        [Ping] slot. *)

    val reserved_fail_key : t
    (** The key of a task that runs the [fail] form which was designed for
        testing failures and negative cases in the build system.

        ["get-object Thunk.Sample.Fail Fail"] will always end in failure. *)

    (* val reserved_dkdriver_exec_entry_key_TODO_abi_slot : t
    (** The key of a task that runs the [DkDriver_Exec.Entry] form of version
        ["2.4.202508011516-signed"]. *) *)

    val reserved_abc_key : t
    (** The key of a task that runs a [pong] form.

        This is a reserved key. The intent is for
        ["get-object Thunk.Sample.Abc Abc"] to return a zip archive containing
        the zero-byte entry ["a/b/c"] for the [Abc] slot. *)
  end = struct
    open MlFront_Core

    type reference_transient = { reference_file : Io.file_object }

    type reference = {
      reference_range : Fmlib_parse.Position.range;
      reference_file_sha256 : string;
      reference_transient : reference_transient option;
    }

    type module_key = {
      module_kind : module_kind;
      module_id : MlFront_Core.StandardModuleId.t;
      module_semver : MlFront_Thunk.ThunkSemver64.t;
    }
    [@@deriving ord]

    type package_key = {
      package_kind : package_kind;
      package_id : MlFront_Core.PackageId.t;
      package_semver : MlFront_Thunk.ThunkSemver64.t;
    }
    [@@deriving ord]

    type checksum_key = {
      checksum_kind : checksum_kind;
      checksum_sha256_hex : string;
      checksum_sha256_base32 : string;
    }
    [@@deriving ord]

    type key_datum =
      | ModuleKey of module_key
      | PackageKey of package_key
      | ChecksumKey of checksum_key
    [@@deriving ord]

    type t = {
      key_datum : key_datum;
      debug_reference : reference option; [@compare fun _ _ -> 0]
    }
    [@@deriving ord]

    let equal a b = compare a b = 0

    let with_debug_reference ({ key_datum; debug_reference = _ } : t)
        debug_reference =
      { key_datum; debug_reference = Some debug_reference }

    let create_checksum_for_values_file ~debug_reference ~values_file_sha256 ()
        =
      match
        BuildPaths.hex_to_base32 ~no_pad:() ~lowercase:() values_file_sha256
      with
      | Error msg -> Error msg
      | Ok checksum_sha256_base32 ->
          Ok
            {
              key_datum =
                ChecksumKey
                  {
                    checksum_kind = ValuesFileKind;
                    checksum_sha256_hex = values_file_sha256;
                    checksum_sha256_base32;
                  };
              debug_reference;
            }

    let apply_aliases_aux apply_aliases module_id module_version =
      match apply_aliases with
      | None -> (module_id, module_version)
      | Some f -> f module_id module_version

    let create_for_distribution ~debug_reference ~package_id ~package_semver ()
        : t =
      {
        key_datum =
          PackageKey
            {
              package_kind = DistributionPackageKind;
              package_id;
              package_semver;
            };
        debug_reference;
      }

    let create_for_form ~apply_aliases ~debug_reference ~module_id
        ~module_semver ~slot () : t =
      let module_id, module_semver =
        apply_aliases_aux apply_aliases module_id module_semver
      in
      {
        key_datum =
          ModuleKey
            { module_kind = UserFormKind { slot }; module_id; module_semver };
        debug_reference;
      }

    let create_for_bundle ~apply_aliases ~debug_reference ~module_id
        ~module_semver () : t =
      let module_id, module_semver =
        apply_aliases_aux apply_aliases module_id module_semver
      in
      {
        key_datum =
          ModuleKey { module_kind = UserBundleKind; module_id; module_semver };
        debug_reference;
      }

    let create_for_asset ~apply_aliases ~debug_reference ~module_id
        ~module_semver ~asset_path () : t =
      let module_id, module_semver =
        apply_aliases_aux apply_aliases module_id module_semver
      in
      {
        key_datum =
          ModuleKey
            {
              module_kind = UserAssetKind { asset_path };
              module_id;
              module_semver;
            };
        debug_reference;
      }

    let pp ppf ({ key_datum; debug_reference = _ } : t) =
      match key_datum with
      | ChecksumKey
          {
            checksum_kind = ValuesFileKind;
            checksum_sha256_hex = _;
            checksum_sha256_base32;
          } ->
          Format.fprintf ppf "%s%s{values.json}"
            BuildPaths.prefix_valuesjsonfile checksum_sha256_base32
      | PackageKey
          { package_kind = DistributionPackageKind; package_id; package_semver }
        ->
          Format.fprintf ppf "%a@%s{dist}" PackageId.pp_dot package_id
            (MlFront_Thunk.ThunkSemver64.to_string package_semver)
      | ModuleKey { module_kind; module_id; module_semver } -> begin
          match module_kind with
          | UserFormKind { slot } ->
              Format.fprintf ppf "%a@%s -s %a" StandardModuleId.pp_dot module_id
                (MlFront_Thunk.ThunkSemver64.to_string module_semver)
                MlFront_Thunk.ThunkCommand.pp_object_slot slot
          | UserBundleKind ->
              Format.fprintf ppf "%a@%s" StandardModuleId.pp_dot module_id
                (MlFront_Thunk.ThunkSemver64.to_string module_semver)
          | UserAssetKind { asset_path } ->
              Format.fprintf ppf "%a@%s -p %s" StandardModuleId.pp_dot module_id
                (MlFront_Thunk.ThunkSemver64.to_string module_semver)
                asset_path
        end

    let show k = Format.asprintf "%a" pp k
    let toerr s = Error s

    let slot_err ({ key_datum; debug_reference = _ } as key) =
      match key_datum with
      | ChecksumKey _ ->
          toerr
          @@ Format.asprintf "The checksum key %a does not have a slot" pp key
      | PackageKey
          {
            package_kind = DistributionPackageKind;
            package_id = _;
            package_semver = _;
          } ->
          toerr
          @@ Format.asprintf "The package key %a does not have a slot" pp key
      | ModuleKey { module_kind; module_id = _; module_semver = _ } -> begin
          match module_kind with
          | UserFormKind { slot } -> Ok slot
          | UserBundleKind ->
              toerr
              @@ Format.asprintf "The bundle kind key %a does not have a slot"
                   pp key
          | UserAssetKind _ ->
              toerr
              @@ Format.asprintf "The asset kind key %a does not have a slot" pp
                   key
        end

    let slot key = match slot_err key with Ok v -> Some v | Error _ -> None

    let slot_exn key =
      match slot_err key with Ok v -> v | Error msg -> invalid_arg msg

    let module_version_exn ({ key_datum; debug_reference = _ } as key) :
        MlFront_Thunk.ThunkCommand.module_version =
      match key_datum with
      | ChecksumKey _ ->
          Format.kasprintf invalid_arg
            "The checksum key %a does not have a module id" pp key
      | ModuleKey { module_kind = _; module_id = id; module_semver = version }
        ->
          { id; version }
      | PackageKey { package_kind = _; package_id; package_semver } -> begin
          match
            MlFront_Core.StandardModuleId.downcast_package_id package_id
          with
          | Some id -> { id; version = package_semver }
          | None ->
              Format.kasprintf invalid_arg
                "The package key %a does not have a module id" pp key
        end

    let distribution_pkgver_exn ({ key_datum; debug_reference = _ } as key) :
        MlFront_Core.PackageId.t * MlFront_Thunk.ThunkSemver64.t =
      match key_datum with
      | PackageKey { package_kind = _; package_id; package_semver } ->
          (package_id, package_semver)
      | ChecksumKey _ ->
          Format.kasprintf invalid_arg
            "The checksum key %a is not a distribution package key" pp key
      | ModuleKey _ ->
          Format.kasprintf invalid_arg
            "The module key %a is not a distribution package key" pp key

    let v1_0_0 : MlFront_Thunk.ThunkSemver64.t =
      MlFront_Thunk.ThunkSemver64.from_parts 1L 0L 0L [] [] |> Option.get

    let mlfront_std_lib = LibraryId.parse_exn "MlFront_Std"

    let thunk_sample_module namespace_tail =
      StandardModuleId.create_explicit ~library_id:mlfront_std_lib
        ~namespace_front:[ "Sample" ] ~namespace_tail

    let object_slot slot =
      MlFront_Thunk.ThunkCommand.InternalUse.parse_object_slot
        (module MakeInitObserver)
        MlFront_Thunk.ThunkParsers.Results.State.none `DirectDecode None slot
      |> if_init_error ("Could not parse the slot for the " ^ slot ^ " form")

    let reserved_version_key : t =
      create_for_form ~apply_aliases:None ~debug_reference:None
        ~module_id:
          (StandardModuleId.create_explicit ~library_id:mlfront_std_lib
             ~namespace_front:[] ~namespace_tail:"Version")
        ~module_semver:v1_0_0
        ~slot:(object_slot "Release.Agnostic")
        ()

    let reserved_pingpong_key : t =
      create_for_form ~apply_aliases:None ~debug_reference:None
        ~module_id:(thunk_sample_module "Ping")
        ~module_semver:v1_0_0
        ~slot:(object_slot "Release.Pong")
        ()

    let reserved_pongping_key : t =
      create_for_form ~apply_aliases:None ~debug_reference:None
        ~module_id:(thunk_sample_module "Pong")
        ~module_semver:v1_0_0
        ~slot:(object_slot "Release.Ping")
        ()

    let reserved_fail_key : t =
      create_for_form ~apply_aliases:None ~debug_reference:None
        ~module_id:(thunk_sample_module "Fail")
        ~module_semver:v1_0_0
        ~slot:(object_slot "Release.Fail")
        ()

    let reserved_abc_key : t =
      create_for_form ~apply_aliases:None ~debug_reference:None
        ~module_id:(thunk_sample_module "Abc")
        ~module_semver:v1_0_0 ~slot:(object_slot "Debug.Abc") ()
  end

  (** The type of task origin. Among other things, it establishes a
      {b task trace} like a stack trace showing why a task came into existence.
  *)
  module O : sig
    type k = K.t

    type item =
      | OutsideTaskTrace
          (** [OutsideTaskTrace] is a marker for an origin that must be passed
              into a [fetch origin] call to preserve type-safety, but does not
              participate in the task trace. The task trace items are
              manipulated exclusively as part of the schedulers and rebuilders.
          *)
      | User
      | IncludeFile
      | Distribution
      | Values_file of Io.file_object
      | Key of k

    type t = private { last : item; previous : item list }
    (** The type of a task trace. It is the reverse concatenation of the [last]
        item and the [previous] items.

        An item [b] that immediately follows an item [a] is a dependency of [a].

        The last item of the task trace is the top-level ancestor of the task,
        which has no dependencies. *)

    (** {2 Accessors} *)

    val depth : t -> int
    val show : t -> string
    val first : t -> item

    (** {2 Constructors} *)

    val user : t
    val include_file : t
    val distribution : t
    val not_relevant : t

    (** {2 Modifications} *)

    val add_needed_by : parent:k -> t -> t
  end = struct
    type k = K.t

    type item =
      | OutsideTaskTrace
      | User
      | IncludeFile
      | Distribution
      | Values_file of Io.file_object
      | Key of k

    type t = { last : item; previous : item list }

    open struct
      let show_item = function
        | OutsideTaskTrace -> "outside-task-trace"
        | User -> "user"
        | IncludeFile -> "include-file"
        | Distribution -> "distribution"
        | Values_file f -> Io.file_origin f
        | Key k -> K.show k
    end

    let first { last; previous } =
      let rec aux = function
        | [] -> last
        | [ first ] -> first
        | _hd :: tl -> aux tl
      in
      aux previous

    let depth { last = _; previous } = 1 + List.length previous

    let show tasktrace =
      let buf = Buffer.create 80 in
      let items =
        match tasktrace with { last; previous } -> last :: previous
      in
      let f idx item =
        if idx > 0 then Buffer.add_string buf " <<< ";
        Buffer.add_string buf (show_item item)
      in
      List.iteri f items;
      Buffer.contents buf

    let not_relevant = { last = OutsideTaskTrace; previous = [] }
    let user = { last = User; previous = [] }
    let include_file = { last = IncludeFile; previous = [] }
    let distribution = { last = Distribution; previous = [] }

    let add_needed_by ~parent:key { last; previous } =
      { last = Key key; previous = last :: previous }
  end

  (** We made a value module that represents a valid AST, a stored object, a
      constant value, or a sentinel value.

      The sentinel values are used to represent special, temporary situations;
      they are never valid values that can be used by other thunks. They make
      the type system correct because we need {i something} ... a real sentinel
      value ... to represent a value while some condition has yet to be handled.

      The [Input_not_found] sentinel is when an input key (a form or an bundle)
      is reference that does not exist in the included [".values.json"] files.
      We do not immediately throw an exception ... instead we propagate the
      value as [Input_not_found] through the monad so ultimately we can present
      a nice error with a friendly backtrace when [Input_not_found] is handled
      later in the sequential chain of [bind]s in the thunk monad.

      The [Failure_is_pending] sentinel is similar; it is used when a semantic
      failure has been injected into the thunk monad (through the state monad)
      and the failure has yet to be handled. [Failure_is_pending] is supplied to
      the monad until the failure can be processed.

      All values except sentinel values have identifiers. These can be hashes,
      autoincrementing ids or UUIDs. The technical requirement is that your
      build clients can retrieve the value from any of the build machines using
      that id. *)
  module V = struct
    type 'a persistent = {
      value_id : string;
      value_sha256 : string;
      value : 'a option;
    }
    (** Value with an identifier persistable in the value store. If the value is
        [None] the value should be loaded from the value store. If the value
        does not exist in the value store (perhaps it was cache evicted), it
        should not be treated as an error.

        The [value_id] is a unique identifier for the value, known immediately
        when the value is created. It can be used for equality and compare
        checks. More important, it has a prefix that indicates the type of value
        (ex. form, bundle, asset, object, constant).

        The [value_sha256] is a SHA-256 hex-encoded hash of the serialized
        value. *)

    type object_ = {
      object_id : MlFront_Thunk.ThunkCommand.module_version;
      object_range : Fmlib_parse.Position.range;
      object_origin : O.t option;
    }

    type values_transient = {
      values : MlFront_Thunk.ThunkAst.t;
      values_file : Io.file_object;
    }

    type values = {
      values_canonical_id : string;
      values_file_sha256 : string;
      values_file_local : [ `Validated of Io.file_object ] option;
      values_transient : values_transient option;
      values_origin : O.t option;
    }

    type form = {
      form_values_canonical_id : string;
      form_values_file_sha256 : string;
      form_id : MlFront_Thunk.ThunkCommand.module_version;
    }

    type bundle = {
      bundle_values_canonical_id : string;
      bundle_values_file_sha256 : string;
      bundle_id : MlFront_Thunk.ThunkCommand.module_version;
      bundle_range : Fmlib_parse.Position.range;
      bundle_values_file_local : [ `Validated of Io.file_object ] option;
    }

    type asset = {
      asset_values_canonical_id : string;
      asset_values_file_sha256 : string;
      asset_id : MlFront_Thunk.ThunkCommand.module_version;
      asset_path : string;
      asset_range : Fmlib_parse.Position.range;
      asset_mirrors : string * string list;
      asset_checksum :
        [ `Sha256 of Fmlib_parse.Position.range * string
        | `Sha1 of Fmlib_parse.Position.range * string ];
    }

    type distribution = {
      distribution_id :
        MlFront_Core.PackageId.t * MlFront_Thunk.ThunkSemver64.t;
      distribution_json : string;
      distribution : MlFront_Thunk.ThunkDist.t;
    }

    type constant_transient = { constant_value : string }
    type constant = { constant_transient : constant_transient option }
    type valuesfile = { valuesfile_canonical_id : string }

    let () =
      (* The [t] sum type has existence checks for [_ persistent] variants.  *)
      Assumptions
      .persisted_values_are_checked_for_existence_during_trace_store_load ()

    type t =
      | ValuesFile of valuesfile persistent
          (** The contents of a values file like ["values.json"]. *)
      | Values of values persistent  (** A parsed values file. *)
      | Distribution of distribution  (** A distribution package. *)
      | Form of form  (** A form. *)
      | Bundle of bundle persistent  (** A bundle. *)
      | Asset of asset persistent  (** An asset. *)
      | Object of object_ persistent
          (** A object is a build generated value that is a file or a directory
              or both.

              In the reference implementation value store the persistent id is
              [hash(cid :: user_slot)], where cid is the canonical id of the AST
              or bundle. When parameters are implemented the parameters will be
              part of the hash as well.

              When reading an object and saving it as a file (ex.
              ["get-object -f FILE"]), if the object is a file the file is
              copied and if the object is a directory the directory is zipped.

              When reading an object and saving it as a directory (ex.
              ["get-object -d DIR"]), if the object is a file the file is copied
              into the directory with the literal name ["OBJECT"] and if the
              object is a directory the directory is copied.

              When a file is being saved as an object, it is saved as-is.

              When a directory is being saved as an object, it is zipped. *)
      | Constant of constant persistent
      | Input_not_found of K.t
          (** The value is [Input_not_found k] when the key [k] was not found on
              the file system (or cloud store, or wherever input keys are
              fetched from). *)
      | Failure_is_pending

    type ('k, 'v) key_dependent_hash = string

    let with_origin v origin =
      match v with
      | Values
          {
            value_id;
            value_sha256;
            value =
              Some
                {
                  values_canonical_id;
                  values_file_sha256;
                  values_file_local;
                  values_transient;
                  values_origin = _;
                };
          } ->
          Values
            {
              value_id;
              value_sha256;
              value =
                Some
                  {
                    values_canonical_id;
                    values_file_sha256;
                    values_file_local;
                    values_transient;
                    values_origin = Some origin;
                  };
            }
      | Object
          {
            value_id;
            value_sha256;
            value = Some { object_id; object_range; object_origin = _ };
          } ->
          Object
            {
              value_id;
              value_sha256;
              value =
                Some { object_id; object_range; object_origin = Some origin };
            }
      | Form { form_values_canonical_id; form_values_file_sha256; form_id } ->
          Form { form_values_canonical_id; form_values_file_sha256; form_id }
      | _ -> v

    let origin_depth = function
      | Values { value = Some { values_origin = Some o; _ }; _ } -> O.depth o
      | Object { value = Some { object_origin = Some o; _ }; _ } -> O.depth o
      | _ -> 0

    (** The values JSON {b file} id will be
        ["'j' || base32(sha256_raw(values_file))"]. The ["j"] prefix
        distinguishes it from the {b values AST} value id which is the ["v"]
        prefix. *)
    let get_valuesjsonfile_value_id ~values_file_sha256 =
      BuildPaths.prefix_valuesjsonfile
      ^ BuildPaths.hex_to_base32_exn ~no_pad:() ~lowercase:() values_file_sha256

    (** The parsed values value id will be
        ["'v' || base32(sha256_raw(values_canonical_id || values_types_id ||
         compatibility_tag))"].

        [values_types_id] is {!MlFront_Thunk.ThunkAstTypes.value_id}, which
        changes whenever there is a change to the [values] AST type or its
        dependencies. By including it in the location, the {!Marshal} will be
        safe from changes.

        [compatibility_tag] is the version and other identifiers (32-bit) of the
        OCaml runtime necessary for {!Marshal} compatibility, assuming the types
        are the same. *)
    let get_values_value_id ~values_canonical_id =
      let hash_input =
        Printf.sprintf "%s%s%s" values_canonical_id
          MlFront_Thunk.ThunkAstTypes.value_id (compatibility_tag ())
      in
      BuildPaths.prefix_values
      ^ BuildPaths.base32_encode ~no_pad:() ~lowercase:()
          (Digestif.SHA256.to_raw_string
             (Digestif.SHA256.digest_string hash_input))

    (** The source file id will be ["'s' || base32(sha256_raw(source_file))"].
    *)
    let get_source_file_value_id ~source_file_sha256 =
      BuildPaths.prefix_sourcefile
      ^ BuildPaths.hex_to_base32_exn ~no_pad:() ~lowercase:() source_file_sha256

    let value_id = function
      | ValuesFile { value_id; _ }
      | Values { value_id; _ }
      | Object { value_id; _ }
      | Bundle { value_id; _ }
      | Asset { value_id; _ }
      | Constant { value_id; _ } ->
          Some value_id
      | Distribution _ | Form _ | Input_not_found _ | Failure_is_pending -> None

    let maybe_cloud_persistent_hash : K.t -> t -> string option =
     fun _k v ->
      match v with
      | ValuesFile { value_sha256; _ }
      | Values { value_sha256; _ }
      | Object { value_sha256; _ }
      | Bundle { value_sha256; _ }
      | Asset { value_sha256; _ }
      | Constant { value_sha256; _ } ->
          Some value_sha256
      | Form
          {
            form_values_canonical_id;
            form_values_file_sha256 = _;
            form_id = { id; version };
          } ->
          Some
            (form_values_canonical_id ^ " "
            ^ MlFront_Core.StandardModuleId.show_dot id
            ^ " "
            ^ MlFront_Thunk.ThunkSemver64.to_string version)
      | Distribution _ | Input_not_found _ | Failure_is_pending -> None

    let strong_hash_equal v1 v2 =
      (* Printf.eprintf "  comparing hashes: %s and %s\n" v1 v2; *)
      String.equal v1 v2

    let strong_hash_compare v1 v2 = String.compare v1 v2
    let strong_hash_show v = v

    let category (v : t) : int =
      match v with
      | ValuesFile _ -> 1
      | Values _ -> 2
      | Form _ -> 3
      | Bundle _ -> 4
      | Asset _ -> 5
      | Object _ -> 6
      | Constant _ -> 7
      | Input_not_found _ -> 8
      | Failure_is_pending -> 9
      | Distribution _ -> 10

    let compare (v1 : t) (v2 : t) =
      match (v1, v2) with
      | ( Form
            {
              form_values_canonical_id = c1;
              form_values_file_sha256 = _;
              form_id = { id = id1; version = v1 };
            },
          Form
            {
              form_values_canonical_id = c2;
              form_values_file_sha256 = _;
              form_id = { id = id2; version = v2 };
            } ) ->
          let c = String.compare c1 c2 in
          if c <> 0 then c
          else
            let c = MlFront_Core.StandardModuleId.compare id1 id2 in
            if c <> 0 then c else MlFront_Thunk.ThunkSemver64.compare v1 v2
      | ( Bundle { value_id = id1; value_sha256 = _; value = _ },
          Bundle { value_id = id2; value_sha256 = _; value = _ } ) ->
          String.compare id1 id2
      | ( Asset { value_id = id1; value_sha256 = _; value = _ },
          Asset { value_id = id2; value_sha256 = _; value = _ } ) ->
          String.compare id1 id2
      | ( Object { value_id = id1; value_sha256 = _; value = _ },
          Object { value_id = id2; value_sha256 = _; value = _ } ) ->
          String.compare id1 id2
      | ( Constant { value_id = id1; value_sha256 = _; value = _ },
          Constant { value_id = id2; value_sha256 = _; value = _ } ) ->
          String.compare id1 id2
      | Input_not_found key1, Input_not_found key2 -> K.compare key1 key2
      | Failure_is_pending, Failure_is_pending -> 0
      | l, r -> category l - category r

    let pp ppf = function
      | ValuesFile { value_id; value_sha256 = _; value = _ } ->
          Format.fprintf ppf "valuesfile:%s" value_id
      | Values { value_id; value_sha256 = _; value = _ } ->
          Format.fprintf ppf "values:%s" value_id
      | Distribution
          {
            distribution_id = package_id, package_semver;
            distribution_json = _;
            distribution = _;
          } ->
          Format.fprintf ppf "dist:%a@%s" MlFront_Core.PackageId.pp_dot
            package_id
            (MlFront_Thunk.ThunkSemver64.to_string package_semver)
      | Form
          { form_values_canonical_id = _; form_values_file_sha256 = _; form_id }
        ->
          Format.fprintf ppf "form:%s"
            (MlFront_Thunk.ThunkCommand.show_module_version form_id)
      | Bundle { value_id; value_sha256 = _; value = None } ->
          Format.fprintf ppf "bundle:%s:unloaded" value_id
      | Bundle
          {
            value_id;
            value_sha256 = _;
            value =
              Some
                {
                  bundle_id;
                  bundle_values_canonical_id = _;
                  bundle_values_file_sha256 = _;
                  bundle_range = _;
                  bundle_values_file_local = _;
                };
          } ->
          Format.fprintf ppf "bundle:%s:%s" value_id
            (MlFront_Thunk.ThunkCommand.show_module_version bundle_id)
      | Asset { value_id; value_sha256 = _; value = None } ->
          Format.fprintf ppf "asset:%s:unloaded" value_id
      | Asset
          {
            value_id = _;
            value_sha256 = _;
            value =
              Some
                {
                  asset_values_canonical_id = _;
                  asset_id;
                  asset_path;
                  asset_values_file_sha256 = _;
                  asset_range = _;
                  asset_mirrors = _;
                  asset_checksum = _;
                };
          } ->
          Format.fprintf ppf "asset:%s:%s"
            (MlFront_Thunk.ThunkCommand.show_module_version asset_id)
            asset_path
      | Object { value_id; value_sha256 = _; value = None } ->
          Format.fprintf ppf "object:%s:unloaded" value_id
      | Object
          {
            value_id;
            value_sha256 = _;
            value = Some { object_id; object_range = _; object_origin = _ };
          } ->
          Format.fprintf ppf "object:%s:%s" value_id
            (MlFront_Thunk.ThunkCommand.show_module_version object_id)
      | Constant
          {
            value_id;
            value_sha256 = _;
            value = Some { constant_transient = Some { constant_value } };
          } ->
          Format.fprintf ppf "constant:%s:%d" value_id
            (String.length constant_value)
      | Constant { value_id; value_sha256 = _; value = _ } ->
          Format.fprintf ppf "constant:%s:unloaded" value_id
      | Input_not_found
          ({
             key_datum = _;
             debug_reference =
               Some
                 {
                   reference_range = _;
                   reference_file_sha256 = _;
                   reference_transient = Some { reference_file };
                 };
           } as key) ->
          Format.fprintf ppf "noinput:(%a):%s" K.pp key
            (Io.file_origin reference_file)
      | Input_not_found key -> Format.fprintf ppf "noinput:(%a)" K.pp key
      | Failure_is_pending -> Format.fprintf ppf "Failure_is_pending"

    let show v = Format.asprintf "%a" pp v

    let create_constant constant_value =
      let constant_sha256 =
        Digestif.SHA256.to_hex (Digestif.SHA256.digest_string constant_value)
      in
      Constant
        {
          value_id =
            BuildPaths.prefix_constant
            ^ BuildPaths.hex_to_base32_exn ~no_pad:() ~lowercase:()
                constant_sha256;
          value_sha256 = constant_sha256;
          value = Some { constant_transient = Some { constant_value } };
        }
  end

  module KMap = Map.Make (K)
  (** We added a map for the ASTs which we can access through the subsequent
      [StoreInfo] *)

  type values_item = {
    values : MlFront_Thunk.ThunkAst.t;
    values_sha256 : string;  (** SHA-256 of the values AST *)
    values_file : Io.file_object;
    values_file_sha256 : string;  (** SHA-256 of the values file *)
  }

  type values_map = values_item KMap.t

  type form_item = {
    form : MlFront_Thunk.ThunkAst.form;
    form_values_file : Io.file_object;
    form_values_file_sha256 : string;  (** SHA-256 of the values file *)
    form_values_canonical_id : string;  (** Canonical id of the values CST *)
  }

  type form_map = form_item KMap.t

  type bundle_item = {
    bundle : MlFront_Thunk.ThunkAst.bundle;
    bundle_range : Fmlib_parse.Position.range;
    bundle_values_file : Io.file_object;
    bundle_values_file_sha256 : string;  (** SHA-256 of the values file *)
    bundle_values_canonical_id : string;  (** Canonical id of the values CST *)
  }

  type bundle_map = bundle_item KMap.t

  type asset_item = {
    asset_bundle : MlFront_Thunk.ThunkAst.bundle;
    asset_path : string;
    asset_range : Fmlib_parse.Position.range;
    asset_values_file : Io.file_object;
    asset_values_file_sha256 : string;  (** SHA-256 of the values file *)
    asset_values_canonical_id : string;  (** Canonical id of the values CST *)
  }

  type asset_map = asset_item KMap.t

  (** 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 Store =
  MlFront_Thunk.BuildSystems.ImmutableFunctionStoreBuilder (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)

  module State = struct
    type state = Store.t
  end

  module CSync = MlFront_Thunk.BuildConstraints.MonadStateWithPureSeq (State)
end

(** Based on ["tests/MlFront_Thunk/alacarte_xtraces_test.ml"]. *)
module Alacarte_xtraces_test = struct
  open Alacarte_xpromise_apparatus

  (** 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 =
      List.iter (fun j -> prerr_endline ("[journal] " ^ j)) json_list;
      Promise.return ()

    (** 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 (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
end

(** Based on ["tests/MlFront_Thunk/alacarte_xasync_apparatus.ml"], but is being
    made more robust. *)
module Alacarte_xasync_apparatus = struct
  (** Apparatus for extra "async" build components (not part of "a la carte" but
      uses some of the same objects). *)

  open Alacarte_3_2_apparatus
  open Alacarte_xpromise_apparatus
  open Alacarte_xtraces_test

  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

  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

  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 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

(** Based on ["tests/MlFront_Thunk/alacarte_6_4_test.ml"]. *)
module Alacarte_6_4_test = struct
  (** {1 Cloud Shake}

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

  open Alacarte_3_2_apparatus
  open Alacarte_xpromise_apparatus
  open Alacarte_xasync_apparatus
  module KSet = Set.Make (K)

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

  module StateSuspending : sig
    type trace = {
      key : K.t;
      dependencies : (K.t * (K.t, V.t) V.key_dependent_hash) list;
      result : V.t;
    }

    type precompiled_traces
    type state
    type 'a promise = 'a Promise.t

    val create : MutableStore.t -> state
    (** Creates a new state with the given store. *)

    val create_with_precompiled_traces :
      MutableStore.t -> precompiled_traces -> state

    val describe : state -> string
    val store : state -> MutableStore.t
    val get_all_traces : state -> trace list

    val get_traces_for_key :
      state -> K.t -> ((K.t * (K.t, V.t) V.key_dependent_hash) list * V.t) list

    val post_record_trace :
      state ->
      K.t ->
      (K.t * (K.t, V.t) V.key_dependent_hash) list ->
      V.t ->
      state

    val precompile_traces : trace list -> precompiled_traces
    val remove_trace : state -> trace -> unit

    val mutate_state :
      state -> MlFront_Thunk.BuildConstraints.StateMessage.t -> unit

    val update :
      state -> MlFront_Thunk.BuildConstraints.StateMessage.t list -> unit

    val flush : 'a -> unit Promise.t
    val is_done : state -> K.t -> bool
    val set_done : state -> K.t -> unit

    (** {2 Values Files} *)

    val assign_asset_to_values_file :
      bundle_id:MlFront_Thunk.ThunkCommand.module_version ->
      values_file_sha256:string ->
      state ->
      unit
    (** [assign_asset_to_values_file ~bundle_id ~values_file_sha256 state]
        maintains a mapping from bundle id to values file SHA-256. This is used
        to determine which values file an bundle came from, for error reporting
        and debugging purposes. *)

    val get_values_file_sha256_for_asset :
      bundle_id:MlFront_Thunk.ThunkCommand.module_version ->
      state ->
      string option
    (** [get_values_file_sha256_for_asset ~bundle_id state] retrieves the values
        file SHA-256 for the bundle with id [bundle_id] if it was added with
        {!assign_asset_to_values_file}. *)

    (** {2 Distributions} *)

    val accept_distribution :
      values_file_sha256:string ->
      json:string ->
      pkg:MlFront_Core.PackageId.t ->
      state ->
      MlFront_Thunk.ThunkDist.t ->
      unit
    (** [accept_distribution ~values_file_sha256  ~json ~pkg state distribution]
        adds the distribution [distribution] for package [pkg] and its JSON
        representation [json] embedded in the values file with checksum
        [values_file_sha256] to the state [state]. If a distribution with the
        same package id (package name and version) already exists in the state,
        the existing distribution is left unchanged.

        On initial scan of the include directories, the distribution versions
        must be added in {b ascending order} of the semver version. That allows
        for continuations to be verified
        ({!Assumptions.distributions_added_in_semver_ascending_order}).

        Any distribution version that is in conflict with a prior distribution
        version (for example, the new distribution version is not a continuation
        of the old one) will result in an error. *)

    val find_distribution_for_module :
      state ->
      MlFront_Core.StandardModuleId.t ->
      MlFront_Thunk.ThunkSemver64Rep.t ->
      [ `FoundDistribution of
        [ `SHA256 of string ]
        * [ `JSON of string ]
        * MlFront_Core.PackageId.t
        * MlFront_Thunk.ThunkDist.t
      | `FoundOtherMajMinModuleVersions of (int64 * int64) list
      | `FoundOtherModules of MlFront_Core.StandardModuleId.t list
      | `DistributionDoesNotExist of MlFront_Core.PackageId.t
      | `NotDistributable ]

    (** {2 Graphs} *)

    val pp_graph_of_key :
      [ `Ancestors | `Dependencies ] -> Format.formatter -> state -> K.t -> unit

    val pp_graph_of_keys :
      [ `Ancestors | `Dependencies ] ->
      Format.formatter ->
      state ->
      K.t list ->
      unit

    val create_depgraph_from_trace_list : trace list -> (K.t, string) CCGraph.t

    val create_ancestorgraph_from_trace_list :
      trace list -> (K.t, string) CCGraph.t

    (** {2 Aliases}

        The virtual lock file maintained in this state contains:

        + a mapping from (module id, version without build metadata) to build
          metadata (a list of strings).

        This allows the following aliasing rules:

        + [(module_id, version_without_build_metadata)] ->
          [(module_id, version_with_build_metadata)]. The alias applies if the
          version doesn't already contain build number metadata of form
          ["bn.*"]. So the semver ["1.0.0"] would be changed to
          ["1.0.0+bn.12345678"], but semver ["1.0.0+bn.87654321"] would be left
          alone.

        Future aliases may include pinning (ala opam) or wholesale substitutions
        of modules. *)

    val apply_aliases :
      build_number:string ->
      state ->
      MlFront_Core.StandardModuleId.t ->
      MlFront_Thunk.ThunkSemver64.t ->
      MlFront_Core.StandardModuleId.t * MlFront_Thunk.ThunkSemver64.t
    (** [apply_aliases ~default lockfile module_id version] applies any build
        metadata and other aliasing rules for the module id [module_id] and the
        version [version] from the lock file [lockfile] to the version
        [version], returning the non-aliased module id and version.

        If the lock file does not have an entry, a new ["bn-${build_number}"]
        build number is added to the existing build metadata of version
        [version]. However, if the lock file does not have an entry but the
        version [version] already contains {i any} ["bn-*"] build metadata, then
        the version [version] is kept as-is. *)

    val apply_aliases_from_precompiled_traces :
      build_number:string ->
      precompiled_traces ->
      MlFront_Core.StandardModuleId.t ->
      MlFront_Thunk.ThunkSemver64.t ->
      MlFront_Core.StandardModuleId.t * MlFront_Thunk.ThunkSemver64.t
    (** [apply_aliases_from_precompiled_traces ~build_number precompiled_traces
         module_id version] applies any build metadata and other aliasing rules
        for the module id [module_id] and the version [version] from the
        precompiled traces [precompiled_traces] to the version [version],
        returning the non-aliased module id and version.

        If the lock file does not have an entry, a new ["bn-${build_number}"]
        build number is added to the existing build metadata of version
        [version]. However, if the lock file does not have an entry but the
        version [version] already contains {i any} ["bn-*"] build metadata, then
        the version [version] is kept as-is. *)
  end = struct
    type trace = {
      key : K.t;
      dependencies : (K.t * (K.t, V.t) V.key_dependent_hash) list;
      result : V.t;
    }

    module TraceData =
      CCMultiMap.Make
        (K)
        (struct
          type t = trace

          let compare_deps =
           fun (k1, kvhash1) (k2, kvhash2) ->
            let c = K.compare k1 k2 in
            if c <> 0 then c else V.strong_hash_compare kvhash1 kvhash2

          let compare { key = k1; dependencies = deps1; result = v1 }
              { key = k2; dependencies = deps2; result = v2 } =
            let c = K.compare k1 k2 in
            if c <> 0 then c
            else
              let c = List.compare compare_deps deps1 deps2 in
              if c <> 0 then c else V.compare v1 v2
        end)

    module LockFileEntryId = struct
      type t = {
        lockfile_module_id : MlFront_Core.StandardModuleId.t;
        lockfile_version_nobuild : MlFront_Thunk.ThunkSemver64.nobuild;
      }
      [@@deriving ord]
    end

    module LockFile = Map.Make (LockFileEntryId)

    type lockfile_entry = { lockfile_version_build : string list }

    module AssetValueFiles = Map.Make (struct
      type t = MlFront_Thunk.ThunkCommand.module_version

      let compare = MlFront_Thunk.ThunkCommand.compare_module_version
    end)

    type package_entry = {
      distribution_values_file_sha256 : string;
      distribution_json : string;
      distribution : MlFront_Thunk.ThunkDist.t;
      distributed_modules : SecPackageRegistry.DistributedModules.t;
    }

    type state = {
      store : MutableStore.t;
      mutable keys_done : KSet.t;
      mutable traces : TraceData.t;
      mutable lockfile : lockfile_entry LockFile.t;
      mutable asset_to_values_files_sha256 : string AssetValueFiles.t;
      mutable registry : package_entry SecPackageRegistry.t;
    }

    type 'a promise = 'a Promise.t

    let describe
        ({
           store = _;
           keys_done;
           traces;
           lockfile;
           asset_to_values_files_sha256;
           registry = _;
         } :
          state) : string =
      Printf.sprintf
        "State: keys_done=%d traces=%d lockfile=%d \
         asset_to_values_files_sha256=%d"
        (KSet.cardinal keys_done) (TraceData.size traces)
        (LockFile.cardinal lockfile)
        (AssetValueFiles.cardinal asset_to_values_files_sha256)

    (** Added this function for convenience. *)
    let store { store; _ } = store

    type precompiled_traces = TraceData.t * lockfile_entry LockFile.t

    let empty_registry () =
      SecPackageRegistry.create
        ~show:(fun
            dist_core
            ({
               distribution_values_file_sha256 = _;
               distribution_json = _;
               distribution =
                 {
                   id = _range, _library, version;
                   producer = _;
                   license = _;
                   continuations = _;
                   build = _;
                 };
               distributed_modules = _;
             } :
              package_entry)
          ->
          Printf.sprintf "%s@%s"
            (Option.value ~default:"<unknown distribution package>"
               (Option.map MlFront_Core.PackageId.full_name
                  (SecPackageRegistry.package_id_for_distcore dist_core)))
            (MlFront_Thunk.ThunkSemver64.to_string version))
        ()

    let create store =
      {
        keys_done = KSet.empty;
        store;
        traces = TraceData.empty;
        lockfile = LockFile.empty;
        asset_to_values_files_sha256 = AssetValueFiles.empty;
        registry = empty_registry ();
      }

    let create_with_precompiled_traces store precompiled_traces =
      let traces, lockfile = precompiled_traces in
      {
        keys_done = KSet.empty;
        store;
        traces;
        lockfile;
        asset_to_values_files_sha256 = AssetValueFiles.empty;
        registry = empty_registry ();
      }

    let get_all_traces { traces; _ } =
      let all = ref [] in
      TraceData.values traces (fun v -> all := v :: !all);
      !all

    let get_traces_for_key
        {
          store = _;
          keys_done = _;
          traces;
          lockfile = _;
          asset_to_values_files_sha256 = _;
          registry = _;
        } k =
      let k_traces : trace list = TraceData.find traces k in
      List.map
        (fun { key = _; dependencies; result } -> (dependencies, result))
        k_traces

    let module_kind_should_have_build_metadata = function
      | UserFormKind _ | UserBundleKind | UserAssetKind _ -> true

    (** [add_lockfile_entry] maintain lock file entries for all
        {!Alacarte_3_2_apparatus.K.ModuleKey} user module keys (ie. user
        form/bundle/asset keys).

        Confer
        {!Assumptions.both_tracestore_and_lockfiles_resolve_build_metadata_for_user_module_keys}.
    *)
    let add_lockfile_entry lockfile k =
      match (k : K.t) with
      | {
       key_datum = ModuleKey { module_kind; module_id; module_semver };
       debug_reference = _;
      } ->
          if module_kind_should_have_build_metadata module_kind then (
            (* Printf.eprintf "Adding lockfile entry for %s version %s\n"
            (MlFront_Core.StandardModuleId.show_dot module_id)
            (MlFront_Thunk.ThunkSemver64.to_string module_semver); *)
            Assumptions
            .both_tracestore_and_lockfiles_resolve_build_metadata_for_user_module_keys
              ();
            LockFile.add
              {
                lockfile_module_id = module_id;
                lockfile_version_nobuild =
                  MlFront_Thunk.ThunkSemver64.to_nobuild module_semver;
              }
              {
                lockfile_version_build =
                  MlFront_Thunk.ThunkSemver64.build module_semver;
              }
              lockfile)
          else lockfile
      | _ ->
          (* Printf.eprintf "Skipping lockfile entry for %s with value %s\n"
            (K.show k) (V.show result); *)
          lockfile

    let remove_lockfile_entry lockfile k =
      match (k : K.t) with
      | {
       key_datum = ModuleKey { module_kind; module_id; module_semver };
       debug_reference = _;
      } ->
          if module_kind_should_have_build_metadata module_kind then (
            Assumptions
            .both_tracestore_and_lockfiles_resolve_build_metadata_for_user_module_keys
              ();
            LockFile.remove
              {
                lockfile_module_id = module_id;
                lockfile_version_nobuild =
                  MlFront_Thunk.ThunkSemver64.to_nobuild module_semver;
              }
              lockfile)
          else lockfile
      | _ -> lockfile

    let post_record_trace
        ({
           store = _;
           keys_done = _;
           traces;
           lockfile;
           asset_to_values_files_sha256 = _;
           registry = _;
         } as state) k depends result =
      (* debug: to find when the TraceData comparators are incorrect, expect
         that when unique keys are added, the size of traces should increase. *)
      (* Printf.eprintf "post_record_trace pre size(traces)=%d k=%s dephashes=%s\n"
        (TraceData.size traces) (K.show k)
        (String.concat "|"
           (List.map (fun (k, kvhash) -> K.show k ^ ":" ^ kvhash) depends)); *)
      state.traces <-
        TraceData.add traces k { key = k; dependencies = depends; result };
      state.lockfile <- add_lockfile_entry lockfile k;
      (* Printf.eprintf "post_record_trace post size(traces)=%d\n"
        (TraceData.size state.traces); *)
      state

    (** Added this function for convenience. *)
    let precompile_traces k_depends_result_list =
      let traces' =
        (* map over traces in-order *)
        TraceData.of_iter (fun f_k_v ->
            List.iter
              (fun { key; dependencies; result } ->
                f_k_v (key, { key; dependencies; result }))
              k_depends_result_list)
      in
      let lockfile' =
        (* fold left so that later results override earlier results *)
        List.fold_left
          (fun lockfile' { key; dependencies = _; result = _ } ->
            add_lockfile_entry lockfile' key)
          LockFile.empty k_depends_result_list
      in
      (traces', lockfile')

    let accept_distribution ~values_file_sha256 ~json ~pkg state distribution =
      (* Update package registry *)
      let distributed_modules =
        SecPackageRegistry.DistributedModules.from_distribution distribution
      in
      let (package_entry : package_entry) =
        {
          distribution_values_file_sha256 = values_file_sha256;
          distribution_json = json;
          distribution;
          distributed_modules;
        }
      in
      state.registry <-
        SecPackageRegistry.accept_if_not_present
          (MlFront_Thunk.ThunkDist.demote distribution)
          package_entry state.registry;

      (* Update trace store. Technically we don't need to do this because
         the distribution dependency is captured with [fetch] tracking
         in BuildTask.depend_on_distribution_and_values_ast just like all
         other dependencies. But we have an assumption ... so guarantee
         it. *)
      Assumptions.accepted_distributions_are_present_in_trace_store ();
      let package_semver =
        match distribution.id with _, _, semver -> semver
      in
      let distribution_key =
        K.create_for_distribution ~debug_reference:None ~package_id:pkg
          ~package_semver ()
      in
      let distribution_value =
        V.Distribution
          {
            distribution_id = (pkg, package_semver);
            distribution_json = json;
            distribution;
          }
      in
      let (_mutated_state : state) =
        post_record_trace state distribution_key [] distribution_value
      in
      ()

    let find_distribution_for_module state module_id module_semver =
      let open struct
        type internal_find = {
          majmin_versions : (int64 * int64) list list;
          modules : MlFront_Core.StandardModuleId.t list list;
        }
      end in
      match SecPackageRegistry.package_id_for_module module_id with
      | None -> `NotDistributable
      | Some pkg -> (
          let pkg_entries = SecPackageRegistry.lookup_desc state.registry pkg in
          let searchresult =
            List.fold_left
              (fun acc
                   ( _core,
                     ({
                        distribution_values_file_sha256;
                        distribution_json;
                        distribution;
                        distributed_modules;
                      } :
                       package_entry) ) ->
                let search agg =
                  (* Search for the module in the distributed modules *)
                  match
                    SecPackageRegistry.DistributedModules.is_distributed
                      module_id module_semver distributed_modules
                  with
                  | Distributed ->
                      (* Stop the search *)
                      `Found
                        ( distribution_values_file_sha256,
                          distribution_json,
                          pkg,
                          distribution )
                  | NotDistributed
                      { available_majmin_versions; available_modules } ->
                      (* Printf.eprintf
                        "[debug] find_distribution_for_module NotDistributed: \
                         module_id=%s version=%s pkg=%s not distributed in \
                         this distribution, available_majmin_versions=[%s] \
                         available_modules=[%s]\n\
                         %!"
                        (MlFront_Core.StandardModuleId.show_dot module_id)
                        (MlFront_Thunk.ThunkSemver64.to_string module_semver)
                        (MlFront_Core.PackageId.full_name pkg)
                        (String.concat "; "
                           (List.map
                              (fun (maj, min) ->
                                Printf.sprintf "%Ld.%Ld" maj min)
                              available_majmin_versions))
                        (String.concat "; "
                           (List.map MlFront_Core.StandardModuleId.show_dot
                              available_modules)); *)
                      (* Aggregate the search results with [agg] *)
                      `ContinueSearch
                        (agg available_majmin_versions available_modules)
                in
                match acc with
                | `Found _ ->
                    (* Search is stopped; result has been found *)
                    acc
                | `Started ->
                    (* First search iteration *)
                    search (fun new_majmins new_modules ->
                        {
                          majmin_versions = [ new_majmins ];
                          modules = [ new_modules ];
                        })
                | `ContinueSearch { majmin_versions; modules } -> begin
                    (* Another search iteration *)
                    search (fun new_majmins new_modules ->
                        {
                          majmin_versions = new_majmins :: majmin_versions;
                          modules = new_modules :: modules;
                        })
                  end)
              `Started pkg_entries
          in
          match searchresult with
          | `Started -> `DistributionDoesNotExist pkg
          | `ContinueSearch { majmin_versions; modules } ->
              let majmin_versions =
                List.flatten majmin_versions |> List.sort_uniq Stdlib.compare
              in
              let modules =
                List.flatten modules
                |> List.sort_uniq MlFront_Core.StandardModuleId.compare
              in
              (* Printf.eprintf
                "[debug] find_distribution_for_module ContinueSearch: \
                 module_id=%s version=%s pkg=%s majmin_versions=[%s] \
                 other_modules=[%s]\n\
                 %!"
                (MlFront_Core.StandardModuleId.show_dot module_id)
                (MlFront_Thunk.ThunkSemver64.to_string module_semver)
                (MlFront_Core.PackageId.full_name pkg)
                (String.concat "; "
                   (List.map
                      (fun (maj, min) -> Printf.sprintf "%Ld.%Ld" maj min)
                      majmin_versions))
                (String.concat "; "
                   (List.map MlFront_Core.StandardModuleId.show_dot modules)); *)
              begin
                match
                  ( majmin_versions,
                    List.filter
                      (fun m ->
                        not (MlFront_Core.StandardModuleId.equal m module_id))
                      modules )
                with
                | [], [] -> `DistributionDoesNotExist pkg
                | _ :: _, _ -> `FoundOtherMajMinModuleVersions majmin_versions
                | [], _ :: _ -> `FoundOtherModules modules
              end
          | `Found (values_file_sha256, json, pkg, dist) ->
              `FoundDistribution
                (`SHA256 values_file_sha256, `JSON json, pkg, dist))

    let apply_aliases_aux ~build_number lockfile :
        MlFront_Core.StandardModuleId.t ->
        MlFront_Thunk.ThunkSemver64.t ->
        MlFront_Core.StandardModuleId.t * MlFront_Thunk.ThunkSemver64.t =
     fun module_id version ->
      let entry_id : LockFileEntryId.t =
        {
          lockfile_module_id = module_id;
          lockfile_version_nobuild =
            MlFront_Thunk.ThunkSemver64.to_nobuild version;
        }
      in
      match LockFile.find_opt entry_id lockfile with
      | Some { lockfile_version_build } ->
          ( module_id,
            MlFront_Thunk.ThunkSemver64.with_build version
              lockfile_version_build )
      | None ->
          let build = MlFront_Thunk.ThunkSemver64.build version in
          if List.exists (fun s -> String.starts_with ~prefix:"bn-" s) build
          then
            (* idempotency *)
            (module_id, version)
          else
            ( module_id,
              MlFront_Thunk.ThunkSemver64.with_build version
                (("bn-" ^ build_number) :: build) )

    let apply_aliases_from_precompiled_traces ~build_number (_, lockfile) =
      apply_aliases_aux ~build_number lockfile

    let apply_aliases ~build_number { lockfile; _ } =
      apply_aliases_aux ~build_number lockfile

    (** Added this function to verify hashes with `--integrity existence` or
        `--integrity checksum`. *)
    let remove_trace
        ({
           store = _;
           keys_done = _;
           traces;
           lockfile;
           asset_to_values_files_sha256 = _;
           registry = _;
         } as state) { key = k; dependencies = deps; result } =
      state.traces <-
        TraceData.remove traces k { key = k; dependencies = deps; result };
      state.lockfile <- remove_lockfile_entry lockfile k

    let mutate_state
        ({
           store;
           keys_done = _;
           traces = _;
           lockfile = _;
           asset_to_values_files_sha256 = _;
           registry = _;
         } :
          state) (msg : MlFront_Thunk.BuildConstraints.StateMessage.t) =
      match MutableStore.mutate_store store msg with
      | `Handled -> ()
      | `NeedsHandler ->
          raise
            (Invalid_argument
               (Printf.sprintf "[98b38f78] 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 ()

    (** Added this function for {!StateSuspendingAccess} *)
    let is_done { keys_done; _ } key = KSet.mem key keys_done

    (** Added this function for {!StateSuspendingAccess} *)
    let set_done t key = t.keys_done <- KSet.add key t.keys_done

    (** {2 Values Files} *)

    let assign_asset_to_values_file ~bundle_id ~values_file_sha256
        ({ asset_to_values_files_sha256; _ } as state) =
      state.asset_to_values_files_sha256 <-
        AssetValueFiles.add bundle_id values_file_sha256
          asset_to_values_files_sha256

    let get_values_file_sha256_for_asset ~bundle_id
        { asset_to_values_files_sha256; _ } =
      AssetValueFiles.find_opt bundle_id asset_to_values_files_sha256

    module G = CCGraph.Map (K)
    (** You can use this in [state] as a [mutable graph]. But only if
        invalidations are enabled ... there is a CPU and memory cost to
        maintaining a graph when we don't need it! *)

    (** If invalidations are enabled, store mutable G.t directly and maintain it
        alongside the [traces]. *)
    let create_depgraph_from_trace_aux fold traces =
      fold traces G.empty (fun g { key; dependencies; result = _ } ->
          List.fold_left
            (fun g (dep_key, dep_kvhash) -> G.add_edge key dep_kvhash dep_key g)
            g dependencies)
      |> G.as_graph

    let create_depgraph_from_trace_list traces =
      create_depgraph_from_trace_aux
        (fun traces' acc f -> List.fold_left f acc traces')
        traces

    (* TraceData.fold: TraceData.t -> 'a -> ('a -> K.t -> trace -> 'a) -> 'a *)
    (* want: TraceData.t -> ('a -> K.t -> trace -> 'a) -> 'a  *)
    let create_depgraph_from_traces { traces; _ } =
      create_depgraph_from_trace_aux
        (fun traces' gmap' f ->
          TraceData.fold traces' gmap' (fun gmap'' _key trace'' ->
              f gmap'' trace''))
        traces

    (** If invalidations are enabled, store mutable G.t directly and maintain it
        alongside the [traces]. *)
    let create_ancestorgraph_from_trace_aux fold traces =
      fold traces G.empty (fun g { key; dependencies; result = _ } ->
          List.fold_left
            (fun g (dep_key, dep_kvhash) -> G.add_edge dep_key dep_kvhash key g)
            g dependencies)
      |> G.as_graph

    let create_ancestorgraph_from_trace_list traces =
      create_ancestorgraph_from_trace_aux
        (fun traces' acc f -> List.fold_left f acc traces')
        traces

    let create_ancestorgraph_from_traces { traces; _ } =
      create_ancestorgraph_from_trace_aux
        (fun traces' gmap' f ->
          TraceData.fold traces' gmap' (fun gmap'' _key trace'' ->
              f gmap'' trace''))
        traces

    let graph typ state =
      match typ with
      | `Ancestors -> create_ancestorgraph_from_traces state
      | `Dependencies -> create_depgraph_from_traces state

    let pp_graph_of_key typ ppf state key =
      let graph = graph typ state in
      let tbl = CCGraph.mk_map ~cmp:K.compare () in
      CCGraph.Dot.pp
        ~attrs_v:(fun k -> [ `Label (K.show k) ])
        ~tbl ~eq:K.equal ~graph ppf key

    let pp_graph_of_keys typ ppf state keys =
      let graph = graph typ state in
      let tbl = CCGraph.mk_map ~cmp:K.compare () in
      CCGraph.Dot.pp_all
        ~attrs_v:(fun k -> [ `Label (K.show k) ])
        ~tbl ~eq:K.equal ~graph ppf (Fun.flip List.iter keys)
  end

  module StateSuspendingAccess = struct
    open StateSuspending

    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 CSuspending =
    MlFront_Thunk.BuildConstraints.MonadStateWriterPromiseWithPureSeq
      (Promise)
      (StateSuspending)
      (ThunkWriterAsync)

  module IR = struct
    type t = StateSuspending.state

    let post_record_trace ir k depends result =
      ignore @@ StateSuspending.post_record_trace ir k depends result;
      CSuspending.pure ()

    let get_traces_for_key ir k = StateSuspending.get_traces_for_key ir k
  end

  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
      (if
         StoreInfo.explain (MutableStore.get_info (StateSuspending.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|"
         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
         | [] ->
             Printf.eprintf "[explain] %snever built `%s`\n%!" (lead "x")
               (K.show k)
         | [ single ] ->
             Printf.eprintf
               "[explain] %sonce built `%s`, but build `%s` does not match the \
                authoritative trace\n\
                %!"
               (lead "!") (K.show k) (V.show single)
         | last :: previous ->
             Printf.eprintf
               "[explain] %s%dx built `%s`, but build `%s` and the others do \
                not match the authoritative trace\n\
                %!"
               (lead "!")
               (1 + List.length previous)
               (K.show k) (V.show last));
      CSuspending.pure ()

    let on_dependency_discovered ~depth ~key ~depends_upon_key =
      let ( let* ) = CSuspending.bind in
      let* state = CSuspending.get in
      (if
         StoreInfo.explain (MutableStore.get_info (StateSuspending.store state))
       then
         let lead c = lead ~first_c:" |" (depth + 1) c in
         Printf.eprintf "[explain] %s%s depends on %s\n%!" (lead "^")
           (K.show key) (K.show depends_upon_key));
      CSuspending.pure ()
  end

  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 CTAsync =
    MlFront_Thunk.BuildTraces.ConstructiveTraceStoreAsyncMinimal
      (Trace)
      (CPHash)
      (IR)

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

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

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

(** Based on the last parts of ["tests/MlFront_Thunk/alacarte_3_7_test.ml"].

    We create the [ThunkTrackingInterpreter] from 6.4's [TasksSuspending] so the
    modules needed to be broken into two. *)
module Alacarte_3_7_test_last = struct
  open Alacarte_3_2_apparatus
  open Alacarte_6_4_test
  open Alacarte_xasync_apparatus
  open Alacarte_xpromise_apparatus

  type MlFront_Thunk.BuildConstraints.StateMessage.obj +=
    | ReceivedBuildResult of V.t

  (** Based on [SPREADSHEET_MONADIC_INTERPRETER_TRACKABLE_MONADSTATE_OF_STORE]
      in ["tests/MlFront_Thunk/alacarte_3_7_test.ml"], but renamed and exposes
      the [post_entry] of the [MONAD_WRITER_ASYNC] API rather than just [MONAD].
  *)
  module type THUNK_INTERPRETER = sig
    module C : sig
      include
        MlFront_Thunk.BuildConstraints.MONAD
          with type 'a t =
            (* WAS: Store.t -> 'a * Store.t * (K.t * V.t) list *)
            (StateSuspending.state * 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

  (** 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
end

(** Based on [backtrace_item_info] and [shutdown] in
    ["tests/MlFront_Thunk/alacarte_xtraces_test.ml"] *)
module Traces (I : Alacarte_3_7_test_last.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