Source file BuildEngine.ml

(** 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. All of
    those components are in {!BuildCore}. *)

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

open BuildCore

(** Based on [Spreadsheet2] in ["tests/MlFront_Thunk/alacarte_3_2_apparatus.ml"]
*)
module UserBuildProgram (I : Alacarte_3_7_test_last.THUNK_INTERPRETER) = struct
  open Alacarte_3_2_apparatus
  open Traces (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 Strings.zipdir_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 warn s = Format.eprintf "@[<v 2>[warning]: %a@]@." pp_lines_of_text s

let add_values_task_if_missing ~values_file ~alert
    (module Tasks' : BuildInstance.THUNK_TASKS) k task =
  (* let open Alacarte_3_2_apparatus in *)
  let return = Alacarte_xpromise_apparatus.Promise.return in
  match Tasks'.get_task k with
  | Some (_duplicated_key, _task) ->
      (* The values task uses SHA256 of the values file as its key. So there is no need to warn about duplicates. *)
      Assumptions.values_task_includes_sha256_of_values_file_in_key ();
      ignore values_file;
      ignore alert;
      (* let msg =
        Printf.sprintf "[warning] `%s` is duplicated in %s and %s" (K.show k)
          (O.show otherorigin)
          (Io.file_origin values_file)
      in
      warn (alert msg); *)
      return ()
  | None -> Tasks'.add_task k task

type parse_result =
  | HadWarnings
  | AddedValuesFile of { values_file_sha256 : string }

(** [parse_thunk_file_gracefully ?parsetrace ~timestamp
     ~inferred_package_id_or_reason_whynone (module ResultObserver) form_map
     asset_map values_file] parses the values file [values_file] and places the
    values AST and the assets into the ast map [form_map] and bundle map
    [asset_map].

    Skip over all errors except duplicate keys. *)
let parse_values_file_gracefully ?allow_deprecated_toplevel_moduleid ~config
    (module ResultObserver : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
    (module Tasks' : BuildInstance.THUNK_TASKS) (values_file : Io.file_object) :
    parse_result Alacarte_xpromise_apparatus.Promise.t =
  let open Alacarte_3_2_apparatus in
  let ( let* ) = Alacarte_xpromise_apparatus.Promise.bind in
  let return = Alacarte_xpromise_apparatus.Promise.return in
  let alert s = Printf.sprintf "%s: %s" (Io.file_origin values_file) s in
  (* Get SHA256(values file). We can strip CR (13) because it is a JSON file.
     We must strip CR because Git is by default inconsistent with CRLF endings. *)
  let* sha256_result =
    Io.checksum_file ~algo:`Sha256 ~strip_carriage_returns:() values_file
  in
  match sha256_result with
  | `Error err ->
      warn (alert err);
      return HadWarnings
  | `Checksum (values_file_sha256, _values_file_sz) -> (
      (* add values file to value store *)
      let* (_added : bool) =
        BuildInstance.ValueStore.add_values_file_exn
          ~valuestore:(BuildConfig.valuestore config)
          ~values_file_sha256 values_file
      in

      (* Add tasks to mutable Tasks *)
      if BuildConfig.debug_task config then
        Printf.eprintf "[task] %s parses `%s`\n"
          (V.get_valuesjsonfile_value_id ~values_file_sha256)
          (Io.file_origin values_file);
      let* values_result =
        (* trust: [values_file] is local and part of the user include path *)
        Assumptions.no_trust_for_local_values_file ();
        BuildTaskFactory.add_values_tasks_gracefully
          ?allow_deprecated_toplevel_moduleid ~config
          ~values_file:(`Validated values_file) ~values_file_sha256
          ~add_task:
            (add_values_task_if_missing ~values_file ~alert
               (module Tasks' : BuildInstance.THUNK_TASKS))
          (module ResultObserver)
      in
      match values_result with
      | Error msg ->
          warn (alert msg);
          return HadWarnings
      | Ok () -> return (AddedValuesFile { values_file_sha256 }))

let is_values_filename filename =
  String.equal filename "values.json"
  || String.equal filename "values.jsonc"
  || Filename.check_suffix filename ".values.json"
  || Filename.check_suffix filename ".values.jsonc"
  || Filename.check_suffix filename ".thunk.json"
  || Filename.check_suffix filename ".thunk.jsonc"

let values_files_of_reproducible_listing ~dir_fp (files_reproduce : string list)
    =
  List.filter is_values_filename files_reproduce
  |> List.map (fun filename ->
         let flags =
           if
             Filename.check_suffix filename ".thunk.json"
             || Filename.check_suffix filename ".thunk.jsonc"
           then [ `Allow_deprecated_toplevel_moduleid ]
           else []
         in
         if List.mem `Allow_deprecated_toplevel_moduleid flags then
           warn
             (Printf.sprintf
                "%s: *.thunk.json and *.thunk.jsonc files are deprecated. \
                 Please rename to *.values.json or *.values.jsonc and use the \
                 \"$schema\": \
                 \"https://github.com/diskuv/dk/raw/refs/heads/V2_4/etc/jsonschema/mlfront-values.json\" \
                 schema."
                filename);
         (Io.disk_file (MlFront_Core.FilePath.append_exn filename dir_fp), flags))

(** lexographic sort for reproducibility *)
let reproducible_listing = List.sort String.compare

(** [get_values_files_in_dir_and_sublibraries ~explain dir] returns the list of
    values files in the directory [dir] and in any subdirectory that looks like
    a library (ie. has a name like [LibraryName_Std]).

    If [explain] is true then print warnings to stderr if the directory cannot
    be read or if deprecated filenames are used. *)
let get_values_files_in_dir_and_sublibraries ~explain (dir : string) =
  let dir_fp = MlFront_Core.FilePath.of_string_exn dir in
  (* read DIR/* *)
  let l1_files =
    try Sys.readdir dir |> Array.to_list |> reproducible_listing
    with Sys_error err ->
      if explain then
        warn (Printf.sprintf "Failed to read include directory %s. %s" dir err);
      []
  in
  (* level 1 files are the DIR/values.json, etc. *)
  let l1_results = values_files_of_reproducible_listing ~dir_fp l1_files in
  (* level 2 files are the DIR/LIBRARY/values.json, etc. *)
  let l2_results =
    List.fold_right
      (fun maybe_dir acc ->
        match MlFront_Core.LibraryId.parse maybe_dir with
        | None -> acc
        | Some _library_id -> (
            let subdir_fp = MlFront_Core.FilePath.append_exn maybe_dir dir_fp in
            let subdir_str = MlFront_Core.FilePath.show subdir_fp in
            try
              (* read DIR/LIBRARY/* *)
              let level2_files' =
                Sys.readdir subdir_str |> Array.to_list |> reproducible_listing
                |> values_files_of_reproducible_listing ~dir_fp:subdir_fp
              in
              level2_files' :: acc
            with Sys_error err ->
              if explain then
                warn
                  (Printf.sprintf
                     "Failed to read include library subdirectory %s. %s"
                     subdir_str err);
              []))
      l1_files []
  in
  (* combine reproducibly *)
  l1_results @ List.flatten l2_results

type state = Alacarte_6_4_test.StateSuspending.state
(** For .mli *)

type tasks = (module BuildInstance.THUNK_TASKS)
(** For .mli *)

type key = Alacarte_3_2_apparatus.K.t
(** For .mli *)

(** For .mli *)
let create_key_for_form = Alacarte_3_2_apparatus.K.create_for_form

(** For .mli *)
let create_key_for_bundle = Alacarte_3_2_apparatus.K.create_for_bundle

(** For .mli *)
let create_key_for_asset = Alacarte_3_2_apparatus.K.create_for_asset

let friendly_no_input_found_error ?target ~config ~(inputkey : key) fetch state
    =
  let open Alacarte_3_2_apparatus in
  let open Alacarte_xasync_apparatus in
  let open BuildInstance.Syntax in
  (* State variables *)
  let store = Alacarte_6_4_test.StateSuspending.store state in
  (* Defaults *)
  let* error_locations =
    match inputkey.debug_reference with
    | None -> return []
    | Some reference ->
    match reference.reference_transient with
    | None -> return []
    | Some transient ->
        BuildTaskForm.range_into_problem_location
          ~source:transient.reference_file reference.reference_range
  in
  let recommendations =
    if StoreInfo.warnings_during_parsing (MutableStore.get_info store) then
      [ "Fix the warning(s) above." ]
    else []
  in
  let recommendations =
    if BuildConfig.parsetrace config then
      let r1 =
        recommendations
        @ [
            Printf.sprintf
              "Great, you are running with `-d parsetrace`. Make sure you see \
               `%s` in the [parsed] log statements."
              (K.show inputkey);
            "Can't see it in the [parsed] statements? Add the `.values.json` \
             file in one of your include directories (-I INCLUDE_DIRECTORY).";
          ]
      in
      if BuildConfig.debug_task config then begin
        match K.slot inputkey with
        | Some slot ->
            r1
            @ [
                Printf.sprintf
                  "See it in the [parsed] statements? You are using the `-d \
                   task` option, so check the [task] log statements that \
                   precede the [parse] log statements and confirm that a task \
                   for the `-s %s` slot was created. If not, you will need to \
                   edit that [parsed] `*.values.json[c]` file and add slot \
                   `%s` to the `outputs` field."
                  (MlFront_Thunk.ThunkCommand.object_slot_to_shell slot)
                  (MlFront_Thunk.ThunkCommand.object_slot_to_shell slot);
              ]
        | None -> r1
      end
      else
        r1
        @ [
            "See it in the [parsed] statements? Use the `-d task` option to \
             see which tasks were created.";
          ]
    else
      recommendations
      @ [
          "Run with `-d parsetrace` to see which `.values.json` files are \
           included. You may need a `.values.json` file in one of your include \
           directories (-I INCLUDE_DIRECTORY).";
        ]
  in
  let cant_do =
    Printf.sprintf "find `%s`"
      (match target with
      | Some target -> K.show target
      | None -> K.show inputkey)
  in
  (* Decode the key as much as possible *)
  match inputkey.key_datum with
  | ChecksumKey
      {
        checksum_kind = ValuesFileKind;
        checksum_sha256_hex = _;
        checksum_sha256_base32 = _;
      } ->
      (* We can't find the values file. And don't double-mention the key in [cant_do]. *)
      let recommend1 =
        (* In CI we can't display the PIDs, but if user requests intermediate we can. *)
        if BuildConfig.intermediate config then
          let existing_include_dirs =
            match BuildConfig.includedirs config with
            | [] -> "Use the `-I INCLUDE_DIR` option."
            | dirs ->
                "The existing include dirs are: "
                ^ String.concat ", " (List.map (Printf.sprintf "`%s`") dirs)
          in
          Printf.sprintf
            "If you copied the `%s` constructive trace store from another \
             machine, make sure you also a) copied the corresponding \
             `*.values.json[c]` value files and b) add the directory \
             containing value files with `-I INCLUDE_DIR`. %s"
            (MlFront_Core.FilePath.show (BuildConfig.tracestore config))
            existing_include_dirs
        else
          "If you copied the constructive trace store from another machine, \
           make sure you also a) copied the corresponding `*.values.json[c]` \
           value files and b) add the value files to your include directories \
           with `-I INCLUDE_DIR`. (Run with `-d intermediate` to show full \
           path information)."
      in
      fail ~error_code:"7b6d84ed" ~cant_do ~error_locations
        ~recommendations:
          [
            recommend1;
            "Perhaps it was erased from the values store? Consider stopping \
             the erasing process (cache eviction, etc.), then restart the \
             build.";
          ]
        ()
  | PackageKey { package_kind = DistributionPackageKind; _ } ->
      (* We can't find the distribution package. And don't double-mention the key in [cant_do]. *)
      fail ~error_code:"0b0df277" ~cant_do ~error_locations
        ~recommendations:
          [
            "Haven't imported the distribution package? Use a \
             `import-github-l2 -R,--repo [HOST/]OWNER/REPO --tag TAG --outdir \
             DIR` command if you haven't done so already.";
            "Imported the distribution package? Make sure you have copied the \
             package file saved in the `import-github-l2 ... --outdir DIR` \
             into your include path with the `-I INCLUDE_DIR` option.";
          ]
        ()
  | ModuleKey { module_kind = UserFormKind _; _ } ->
      (* We can't find the form. And don't double-mention the key in [cant_do]. *)
      fail ~error_code:"c05caa13" ~cant_do ~error_locations ~recommendations ()
  | ModuleKey { module_kind = UserBundleKind; _ } ->
      (* We can't find the bundle. And don't double-mention the key in [cant_do]. *)
      fail ~error_code:"7cd29a18" ~cant_do ~error_locations ~recommendations ()
  | ModuleKey
      { module_kind = UserAssetKind { asset_path }; module_id; module_semver }
    -> begin
      (* We can't find the Asset. Try to find the Bundle so we can print a
         nice error message. *)
      let* state = get in
      let bundle_id : MlFront_Thunk.ThunkCommand.module_version =
        { id = module_id; version = module_semver }
      in
      match
        Alacarte_6_4_test.StateSuspending.get_values_file_sha256_for_asset
          ~bundle_id state
      with
      | None ->
          fail ~error_code:"e5518246" ~cant_do:"find asset"
            ~because:
              (Printf.sprintf "bundle `%s` was not found in the include path"
                 (MlFront_Thunk.ThunkCommand.show_module_version bundle_id))
            ~error_locations ~recommendations ()
      | Some values_file_sha256 -> (
          let k_result =
            K.create_checksum_for_values_file ~debug_reference:None
              ~values_file_sha256 ()
          in
          match k_result with
          | Error msg ->
              fail ~error_code:"bc0dd255" ~cant_do ~because:msg ~error_locations
                ~recommendations ()
          | Ok k_valuesfile_for_debugging -> (
              let* v_should_be_values = fetch k_valuesfile_for_debugging in
              match v_should_be_values with
              | V.Values
                  {
                    value_id = _;
                    value_sha256 = _;
                    value =
                      Some
                        {
                          values_canonical_id = _;
                          values_file_sha256 = _;
                          values_file_local;
                          values_origin = _;
                          values_transient = Some { values; values_file };
                        };
                  } ->
                  let* maybe_bundle =
                    let safe_maybe_local_values_file =
                      Option.value ~default:values_file
                        (Option.map (fun (`Validated o) -> o) values_file_local)
                    in
                    let bundle_result =
                      MlFront_Thunk.ThunkAst.find_bundle values
                        { id = module_id; version = module_semver }
                      |> Option.map (fun bundle ->
                             (bundle, safe_maybe_local_values_file))
                    in
                    return bundle_result
                  in
                  begin
                    match maybe_bundle with
                    | None ->
                        (* We can't find the bundle. And don't double-mention the key in [cant_do]. *)
                        fail ~error_code:"e38e5941" ~cant_do ~error_locations
                          ~recommendations ()
                    | Some ((bundle, asset_range), maybe_local_values_file) ->
                        (* We can find the bundle. *)
                        let all_paths =
                          MlFront_Thunk.ThunkAst.fold_assets
                            ~f:(fun file acc ->
                              MlFront_Thunk.ThunkAst.asset_path file :: acc)
                            ~init:[] bundle
                          |> List.rev
                        in
                        let* error_locations =
                          BuildTaskForm.range_into_problem_location
                            ~source:maybe_local_values_file asset_range
                        in
                        fail ~error_code:"c4db207c"
                          ~cant_do:
                            (Format.asprintf "find asset `%a`" K.pp inputkey)
                          ~because:
                            (Printf.sprintf
                               "there is no \"path\" `%s` in \"files\""
                               asset_path)
                          ~error_locations
                          ~recommendations:
                            [
                              Format.asprintf
                                "@{<hov 2>Use one of the following paths:@ %a@]"
                                Format.(
                                  pp_print_list
                                    ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
                                    (fun ppf s ->
                                      pp_print_string ppf ("`" ^ s ^ "`")))
                                all_paths;
                            ]
                          ()
                  end
              | _ ->
                  (* We can't find the bundle for the asset. *)
                  fail ~error_code:"6cb01f56" ~cant_do:"find asset"
                    ~because:
                      (Printf.sprintf "bundle `%s` could not be found "
                         (K.show k_valuesfile_for_debugging))
                    ~error_locations ~recommendations ()))
    end

let parse_values_files ~config
    (module ResultObserver : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
    (module Tasks' : BuildInstance.THUNK_TASKS) =
  let open Alacarte_xpromise_apparatus in
  let ( let* ) = Promise.bind in
  (* Find values files *)
  let values_files =
    List.map
      (get_values_files_in_dir_and_sublibraries
         ~explain:(BuildConfig.explain config))
      (BuildConfig.includedirs config)
    |> List.flatten
  in

  (* Parse values files into SourceAst, etc. input keys with values which we'll
     need for the StoreInfo.
     At the same time we'll create tasks for the related Form non-input keys
     and add them to (mutable) Tasks *)
  let f =
   fun (values_file, flags) ->
    let allow_deprecated_toplevel_moduleid =
      if List.mem `Allow_deprecated_toplevel_moduleid flags then Some ()
      else None
    in
    parse_values_file_gracefully ?allow_deprecated_toplevel_moduleid ~config
      (module ResultObserver)
      (module Tasks')
      values_file
  in
  let* file_results = Promise.parallel (List.map f values_files) in

  (* Add embedded values *)
  let* embedded_results =
    let embedded_parse_results =
      List.map (fun v -> f (v, [])) (BuildConfig.builtin_values config)
    in
    Promise.parallel embedded_parse_results
  in

  let final_result =
    List.fold_left
      (fun (acc_warnings, acc_keys) warnings_result ->
        match (acc_warnings, (warnings_result : parse_result)) with
        | `NoWarnings, HadWarnings -> (`HadWarnings, acc_keys)
        | `HadWarnings, HadWarnings -> (`HadWarnings, acc_keys)
        | _, AddedValuesFile { values_file_sha256 } ->
            (acc_warnings, `ValuesFileSHA256 values_file_sha256 :: acc_keys))
      (`NoWarnings, [])
      (file_results @ embedded_results)
  in
  Promise.return final_result

(** For .mli *)
let load_state_and_tasks ~config ~traces
    (module ResultObserver : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
    =
  let open Alacarte_3_2_apparatus 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
  (* Create predetermined tasks *)
  let tasks_module = Expr.cloudshake_predetermined_tasks in
  let module Tasks = (val tasks_module) in
  (* Precompile traces *)
  let precompiled_traces = StateSuspending.precompile_traces traces in

  (* Run the parsing promises. Simultaneously they'll update [Tasks] *)
  let parse_values_files_promise =
    parse_values_files ~config (module ResultObserver) (module Tasks)
  in
  let warnings_result, system_keys =
    BuildInstance.Launcher.run_isolated_promise parse_values_files_promise
  in
  (* This is a good spot to make sure all the prior stdout/stderr messages
     are flushed before we start the build process. If this were not a
     reference implementation, we might start a thread pool in the next
     step for the build tasks. *)
  flush_all ();
  (* Continue on configuring the build system ... *)
  let module CtRebuilder = CtRebuilderOfTasks (Tasks) in
  let module SuspendingScheduler =
    SuspendingSchedulerOfRebuilderAndTasks (CtRebuilder) (Tasks)
  in
  (* Addition: Configure the store which is part of the state. *)
  let store =
    MutableStore.initialise
      (StoreInfo.create
         ~explain:(BuildConfig.explain config)
         ~warnings_during_parsing:
           (match warnings_result with
           | `HadWarnings -> true
           | `NoWarnings -> false))
  in
  (* Continue on configuring the build system ... *)
  let kont_state =
    StateSuspendingAccess.create_with_precompiled_traces store
      precompiled_traces
  in
  (kont_state, (module Tasks : BuildInstance.THUNK_TASKS), system_keys)

let bundle_module_id_of_build_to_sign :
    MlFront_Thunk.ThunkDist.build_to_sign -> MlFront_Core.StandardModuleId.t =
  function
  | {
      build_bundle_id = _range, module_id, _semver;
      build_modules = _;
      build_producer_accepts = _;
      build_bundle_canonical = _;
      build_traces = _;
      build_values = _;
    } ->
      module_id

let bundle_id_semver_of_build_to_sign :
    MlFront_Thunk.ThunkDist.build_to_sign -> MlFront_Thunk.ThunkSemver64.t =
  function
  | {
      build_bundle_id = _range, _module_id, semver;
      build_modules = _;
      build_producer_accepts = _;
      build_bundle_canonical = _;
      build_traces = _;
      build_values = _;
    } ->
      semver

let k_is_asset : Alacarte_3_2_apparatus.K.t -> bool = function
  | {
      key_datum =
        ModuleKey
          {
            module_kind = UserAssetKind { asset_path = _ };
            module_id = _;
            module_semver = _;
          };
      debug_reference = _;
    } ->
      true
  | _ -> false

let troubleshoot_recursion =
  let counter = ref 0 in
  fun () ->
    incr counter;
    if !counter = 3 then failwith "stop at 3"
[@@warning "-unused-value-declaration"]

(** For .mli *)
let mk_tasks ~config ~tasks ~state
    (module ResultObserver : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
    (_origin_outside_task_trace : Alacarte_3_2_apparatus.O.t)
    (k : Alacarte_3_2_apparatus.K.t) : (* CtRebuilder.task *) _ =
  let open Alacarte_3_2_apparatus in
  (* let open Alacarte_3_7_test_last in *)
  let open Alacarte_6_4_test in
  let open Alacarte_xasync_apparatus in
  let open BuildInstance.Syntax in
  let module Tasks = (val tasks : BuildInstance.THUNK_TASKS) in
  (* Printf.eprintf "[build] do_run_exn::tasks |0 k=%s\n%!" (K.show k); *)
  let find_key_task () =
    (* A. CHECK IF THERE IS A DYNAMIC TASK *)
    match Tasks.get_lifted_task k with
    | Some (task_key, task_f) -> begin
        (* A1. DYNAMIC TASK FOUND *)
        (* Printf.eprintf "[build] do_run_exn::tasks |1 k=%s\n%!" (K.show k); *)
        (task_key, task_f)
      end
    | None -> begin
        (* A2. NO DYNAMIC TASK FOUND *)
        (* Printf.eprintf "[build] do_run_exn::tasks |2 k=%s\n%!" (K.show k); *)

        (* B. PERHAPS THE VALUE IS IN THE STORE *)
        match MutableStore.get_value k (StateSuspending.store state) with
        | V.Input_not_found
            ({
               key_datum =
                 ChecksumKey
                   {
                     checksum_kind = ValuesFileKind;
                     checksum_sha256_hex = values_file_sha256;
                     checksum_sha256_base32 = _;
                   };
               debug_reference = _;
             } as inputkey) -> begin
            (* B1. The value is a valuesfile, and it is not in the store.
               The fallback is to check the filesystem instead. *)
            Assumptions.values_files_loaded_on_demand_from_filesystem ();
            (* Printf.eprintf "[build] do_run_exn::tasks |3 k=%s\n%!" (K.show k); *)
            (* let origin = O.values_file_sha256 values_file_sha256 in *)
            ( k,
              fun fetch ->
                let* value_fp_opt =
                  lift_promise
                    (BuildInstance.ValueStore.get_value_file
                       ~valuestore:(BuildConfig.valuestore config)
                       ~value_id:
                         (V.get_valuesjsonfile_value_id ~values_file_sha256)
                       ())
                in
                match value_fp_opt with
                | None -> return (V.Input_not_found inputkey)
                | Some values_fp -> begin
                    let values_file = Io.disk_file values_fp in
                    let values_task =
                      BuildTaskFactory.create_values_task
                        ~allow_deprecated_toplevel_moduleid:() ~config
                        ~values_file:(`Validated values_file)
                        ~values_file_sha256
                        ~policy_fail:(fun _key ->
                          BuildTaskFactory.immediate_fail)
                        ~policy_fail_already_rendered:(fun
                            _key ~error_code ~rendered () ->
                          BuildTaskFactory.immediate_fail ~error_code
                            ~because:rendered ())
                        (module ResultObserver)
                    in
                    values_task fetch
                  end )
          end
        | V.Input_not_found inputkey ->
            (* B2. The value is not in the store, and it is not a values file. *)
            (* Printf.eprintf "[build] do_run_exn::tasks |4 k=%s\n%!" (K.show k); *)
            (k, fun _fetch -> return (V.Input_not_found inputkey))
        | v -> (k, fun _fetch -> return v)
      end
  in

  (* C. CHECK IF DISTRIBUTION PACKAGE EXISTS *)
  let distsearchresultopt =
    (* C1. ONLY MODULE KEYS CAN HAVE DISTRIBUTION PACKAGES *)
    match k with
    | { key_datum = PackageKey _ | ChecksumKey _; debug_reference = _ } ->
        (* Printf.eprintf "[build] do_run_exn::tasks |C1a k=%s\n%!" (K.show k); *)
        None
    | {
     key_datum = ModuleKey { module_kind = _; module_id; module_semver };
     debug_reference = _;
    } ->
        (* Printf.eprintf "[build] do_run_exn::tasks |C1b k=%s\n%!" (K.show k); *)
        Some
          ( module_id,
            module_semver,
            StateSuspending.find_distribution_for_module state module_id
              module_semver )
  in
  match distsearchresultopt with
  | None -> find_key_task ()
  | Some (module_id, module_semver, distsearchresult) -> (
      (* C2. DISTRIBUTION PACKAGE FOUND *)
      let module_id_s = MlFront_Core.StandardModuleId.show_dot module_id in
      let dot_x =
        Printf.sprintf "%s@%Ld.%Ld.x" module_id_s module_semver.major
          module_semver.minor
      in
      (* D. RETRY FINDING MODULE OR PRINT HELPFUL ERROR *)
      match distsearchresult with
      | `FoundDistribution (`SHA256 values_file_sha256, `JSON _json, _pkg, dist)
        when k_is_asset k
             && MlFront_Core.StandardModuleId.equal module_id
                  (bundle_module_id_of_build_to_sign dist.build.build_to_sign)
             && MlFront_Thunk.ThunkSemver64.compare module_semver
                  (bundle_id_semver_of_build_to_sign dist.build.build_to_sign)
                = 0 ->
          (* D1A. ADD ASSET TASKS AND RETRY FINDING MODULE *)
          ( k,
            fun fetch ->
              (* Printf.eprintf "[build] do_run_exn::tasks |D1A k=%s\n%!"
                (K.show k); *)
              let* asset_result =
                BuildTaskAsset.get_asset_value ~config ~fetch
                  ~values_file_sha256 ~k_user_asset:k ()
              in
              match asset_result with
              | Error () -> return V.Failure_is_pending
              | Ok v_asset_imported -> return (V.Asset v_asset_imported) )
      | `FoundDistribution (_values_sha256, _json, _pkg, _dist) ->
          (* D1B. ADD BUNDLE AS A TASK AND RETRY FINDING MODULE *)
          (* Printf.eprintf "[build] do_run_exn::tasks |D1 k=%s\n%!" (K.show k); *)
          find_key_task ()
          (* ( k,
            fun _fetch ->
              let* () =
                fail ~error_code:"todo0001"
                  ~cant_do:(Printf.sprintf "use `%s`" dot_x)
                  ~because:"importing of distributions is not implemented"
                  ~recommendations:[ "File a bug." ] ()
              in
              return V.Failure_is_pending ) *)
      | `FoundOtherMajMinModuleVersions other_majmin_vers ->
          (* D2. OTHER MAJOR/MINOR VERSIONS FOUND BUT NOT THE REQUESTED VERSION *)
          (* Printf.eprintf "[build] do_run_exn::tasks |D2 k=%s\n%!" (K.show k); *)
          ( k,
            fun _fetch ->
              let* () =
                fail ~error_code:"80873075"
                  ~cant_do:(Printf.sprintf "use `%s`" dot_x)
                  ~because:"the version has not been imported"
                  ~recommendations:
                    [
                      Printf.sprintf "Use one of the imported versions: %s"
                        (String.concat ", "
                           (List.map
                              (fun (maj, min) ->
                                Printf.sprintf "%Ld.%Ld.x" maj min)
                              other_majmin_vers));
                      Printf.sprintf
                        "Import a package for version %s using the \
                         `import-github-l2` command."
                        dot_x;
                    ]
                  ()
              in
              return V.Failure_is_pending )
      | `FoundOtherModules others ->
          (* D3. OTHER MODULES FOUND BUT NOT THE REQUESTED MODULE *)
          (* Printf.eprintf "[build] do_run_exn::tasks |D3 k=%s\n%!" (K.show k); *)
          let idx =
            Spelll.Index.of_list
              (List.map
                 (fun v ->
                   let s = MlFront_Core.StandardModuleId.show_dot v in
                   (s, s))
                 others)
          in
          let spelling_recommendations =
            let suggestions =
              (* soupalt: As of Spelll 0.3, distance greater than 2 is intolerably slow *)
              Spelll.Index.retrieve_l idx ~limit:2 module_id_s
            in
            match suggestions with
            | [] -> []
            | [ single ] ->
                [ Printf.sprintf "Did you mean the module `%s`?" single ]
            | _ ->
                let suggestions =
                  let l = List.length suggestions in
                  List.mapi
                    (fun i s ->
                      let sep =
                        if i = l - 1 && l = 2 then " or "
                        else if i = l - 1 then ", or "
                        else if i > 0 then ", "
                        else ""
                      in
                      Printf.sprintf "%s`%s`" sep s)
                    suggestions
                in
                [
                  Printf.sprintf "Did you mean one of the modules %s?"
                    (String.concat "" suggestions);
                ]
          in
          ( k,
            fun _fetch ->
              let* () =
                fail ~error_code:"8ad85363"
                  ~cant_do:(Printf.sprintf "use `%s`" module_id_s)
                  ~because:"the module was not published by the distribution"
                  ~recommendations:
                    (spelling_recommendations
                    @ [
                        Printf.sprintf
                          "Import a package using the `import-github-l2` \
                           command.";
                      ])
                  ()
              in
              return V.Failure_is_pending )
      | `DistributionDoesNotExist pkg ->
          (* D4. DISTRIBUTION DOES NOT EXISTS *)
          (* Printf.eprintf "[build] do_run_exn::tasks |D4 k=%s\n%!" (K.show k); *)
          if BuildTask.package_is_local config pkg then find_key_task ()
          else
            ( k,
              fun _fetch ->
                let* () =
                  fail ~error_code:"890d8d77"
                    ~cant_do:
                      (Printf.sprintf "use `%s`"
                         (MlFront_Core.PackageId.full_name pkg))
                    ~because:"the package has not been imported"
                    ~recommendations:
                      [
                        "Import the package using the `import-github-l2` \
                         command.";
                      ]
                    ()
                in
                return V.Failure_is_pending )
      | `NotDistributable ->
          (* D5. MODULE CAN'T BE IN A DISTRIBUTION *)
          (* Printf.eprintf "[build] do_run_exn::tasks |D5 k=%s\n%!" (K.show k); *)
          find_key_task ())

let do_run_exn ~config ~tasks ~init ~should_continue ~fetched ~not_found
    ~target_fold origin
    (module ResultObserver : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
    : _ =
  let open Alacarte_3_2_apparatus 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 : BuildInstance.THUNK_TASKS) in
  (* Continue on configuring the build system ... *)
  let module CtRebuilder = CtRebuilderOfTasks (Tasks) in
  let module SuspendingScheduler =
    SuspendingSchedulerOfRebuilderAndTasks (CtRebuilder) (Tasks)
  in
  let open BuildInstance.Syntax in
  let* state = get in
  let build_async = SuspendingScheduler.schedule state CtRebuilder.rebuilder in
  let tasks = mk_tasks ~config ~tasks ~state (module ResultObserver) in
  (* The fetch delegates to the rebuilder *)
  let toplevel_user_fetch o k : V.t CSuspending.t =
    (* Printf.eprintf "[build] do_run_exn::fetch fetching %s\n" (K.show k); *)
    let open BuildInstance.Syntax in
    let* state = get in
    let* store =
      lift_promise @@ build_async o tasks k (StateSuspending.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 BuildInstance.Syntax in
  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
          | V.ValuesFile _ | V.Values _ | V.Distribution _ | V.Form _
          | V.Bundle _ | V.Asset _ | V.Object _ | V.Constant _ ->
              return (fetched target v acc)
          | V.Input_not_found inputkey ->
              let* state = CSuspending.get in
              not_found ~target ~inputkey fetch state acc
          | V.Failure_is_pending ->
              failwith
                "Illegal state. Failure_is_pending should have been handled."
        end
      | `Stop stopvalue -> return stopvalue)
    (return init)

(** For .mli *)
let show_key key = Format.asprintf "%a" Alacarte_3_2_apparatus.K.pp key

(** For .mli *)
let cloak_key = Fun.id

(** For .mli *)
let uncloak_key = Fun.id

(** For .mli *)
let cloak_state = Fun.id

(** For .mli *)
let uncloak_state = Fun.id

(** For .mli *)
let make_tasks_from_values_files ~config ~tasks ~initiator
    (module ResultObserver : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
    values_files =
  let open BuildInstance.Syntax in
  let open Alacarte_3_2_apparatus in
  (* Fetch the ASTs from all the values files *)
  let* vs_values =
    do_run_exn ~config ~tasks ~init:[]
      ~should_continue:(fun _ -> `Continue)
      ~fetched:(fun _k v acc -> v :: acc)
      ~not_found:(fun ~target:_ ~inputkey:_ _fetch _state acc -> return acc)
      ~target_fold:(fun f init ->
        let targets =
          List.filter_map
            (function
              | `ValuesFileSHA256 values_file_sha256 ->
                  (* Printf.eprintf "[using] make_tasks_from_values_files 1 %s\n"
                    (V.get_valuesjsonfile_value_id ~values_file_sha256); *)
                  K.create_checksum_for_values_file ~debug_reference:None
                    ~values_file_sha256 ()
                  |> Result.to_option)
            values_files
        in
        List.fold_left f init targets)
      O.include_file
      (module ResultObserver)
  in
  (* Function to apply build metadata derived from precompiled traces *)
  let* state = get in
  let apply_initial_build_metadata =
    Assumptions
    .both_tracestore_and_lockfiles_resolve_build_metadata_for_user_module_keys
      ();
    Alacarte_6_4_test.StateSuspending.apply_aliases
      ~build_number:(BuildConfig.build_number config)
      state
  in

  (* Create tasks for distributions, forms, assets and bundle files *)
  let distribution_ids = Queue.create () in
  let* () =
    List.fold_left
      (fun acc v ->
        let* () = acc in
        match v with
        | V.Values
            {
              value_id = _;
              value_sha256 = _;
              value =
                Some
                  {
                    values_canonical_id = _;
                    values_file_sha256;
                    values_file_local;
                    values_origin = _;
                    values_transient = Some { values; values_file };
                  };
            } ->
            (* Printf.eprintf "[using] make_tasks_from_values_files 2 %s\n"
              (V.get_valuesjsonfile_value_id ~values_file_sha256); *)
            let safe_maybe_local_values_file =
              Option.value ~default:values_file
                (Option.map (fun (`Validated o) -> o) values_file_local)
            in
            let alert s =
              Printf.sprintf "%s: %s"
                (Io.file_origin safe_maybe_local_values_file)
                s
            in
            (* Add tasks *)
            let* bundles =
              lift_promise
              @@ BuildTaskFactory.add_values_from_ast ~config
                   ~values_file_sha256 ~values_file_local
                   ~add_task:
                     (add_values_task_if_missing
                        ~values_file:safe_maybe_local_values_file ~alert tasks)
                   ~initiator
                   ~apply_initial_build_metadata:
                     (Some apply_initial_build_metadata)
                   ~request_slot:(BuildTask.initiator_slot_request_id initiator)
                   values safe_maybe_local_values_file
            in

            (* Assign bundles to the values file, and accept distributions *)
            List.iter
              (function
                | `BundleId bundle_id ->
                    Alacarte_6_4_test.StateSuspending
                    .assign_asset_to_values_file ~bundle_id ~values_file_sha256
                      state;
                    ()
                | `DistributionId (package_version, package_semver) ->
                    Queue.add (package_version, package_semver) distribution_ids)
              bundles;
            return ()
        | V.Values { value_id = _; value_sha256 = _; value = None } ->
            (* Printf.eprintf "[using] make_tasks_from_values_files 4 %s\n"
              (V.show v); *)
            return ()
        | _ ->
            Printf.eprintf "[warning] unsupported task %s\n" (V.show v);
            return ())
      (return ()) vs_values
  in

  (* Run distribution tasks *)
  let distribution_keys =
    Queue.to_seq distribution_ids
    |> List.of_seq
    |> List.map (fun (package_id, package_semver) ->
           K.create_for_distribution ~debug_reference:None ~package_id
             ~package_semver ())
  in
  let* (_vs_distributions : V.t list) =
    do_run_exn ~config ~tasks ~init:[]
      ~should_continue:(fun _ -> `Continue)
      ~fetched:(fun _k v acc -> v :: acc)
      ~not_found:(fun ~target:_ ~inputkey:_ _fetch _state acc -> return acc)
      ~target_fold:(fun f init -> List.fold_left f init distribution_keys)
      O.distribution
      (module ResultObserver)
  in
  return ()

let print_up_to_date ~config =
  let verbose = BuildConfig.verbose config in
  fun k v ->
    (* keys are up-to-date; values are built *)
    if verbose then
      Printf.eprintf "[up-to-date] %s := %s\n" (show_key k)
        (Format.asprintf "%a" Alacarte_3_2_apparatus.V.pp v)
    else Printf.eprintf "[up-to-date] %s\n" (show_key k)

(** For .mli *)
let run_single ~config ~tasks
    (module ResultObserver : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
    target =
  let open BuildInstance.Syntax in
  let print_up_to_date' = print_up_to_date ~config in
  let* succeeded =
    do_run_exn ~config ~tasks ~init:true
      ~should_continue:(fun b -> if b then `Continue else `Stop false)
      ~fetched:(fun k v _ ->
        print_up_to_date' k v;
        true)
      ~not_found:(fun ~target ~inputkey fetch state _acc ->
        let* () =
          friendly_no_input_found_error ~target ~config ~inputkey fetch state
        in
        return false)
      ~target_fold:(fun f init -> f init target)
      Alacarte_3_2_apparatus.O.user
      (module ResultObserver)
  in
  if not succeeded then
    failwith
      "Illegal state. Any failures from V.Input_not_found should have been \
       raised.";
  return ()

(** For .mli *)
let run_multiple ~config ~tasks
    (module ResultObserver : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
    targets =
  let open BuildInstance.Syntax in
  let print_up_to_date' = print_up_to_date ~config in
  let* succeeded =
    do_run_exn ~config ~tasks ~init:[]
      ~should_continue:(fun _ -> `Continue)
      ~fetched:(fun k v acc ->
        print_up_to_date' k v;
        v :: acc)
      ~not_found:(fun ~target ~inputkey fetch state acc ->
        let* () =
          friendly_no_input_found_error ~target ~config ~inputkey fetch state
        in
        return acc)
      ~target_fold:(fun f init -> List.fold_left f init targets)
      Alacarte_3_2_apparatus.O.user
      (module ResultObserver)
  in
  ignore succeeded;
  return ()

(** For .mli *)
let output_get_object ~config ~initiator ~source ~command_output ~archive_member
    key =
  let open BuildInstance.Syntax in
  let* state = get in
  let value =
    Alacarte_xasync_apparatus.MutableStore.get_value key
      (Alacarte_6_4_test.StateSuspending.store state)
  in
  XCommon.output_get_object ~config ~initiator ~source ~command_output
    ~archive_member key value

(** For .mli *)
let output_install_object ~config ~initiator ~source ~command_output
    ~archive_member key =
  let open BuildInstance.Syntax in
  let* state = get in
  let value =
    Alacarte_xasync_apparatus.MutableStore.get_value key
      (Alacarte_6_4_test.StateSuspending.store state)
  in
  XCommon.output_install_object ~config ~initiator ~source ~command_output
    ~archive_member key value

(** For .mli *)
let output_pipe_object ~config ~initiator ~source ~pipe ~archive_member key =
  let open BuildInstance.Syntax in
  let* state = get in
  let value =
    Alacarte_xasync_apparatus.MutableStore.get_value key
      (Alacarte_6_4_test.StateSuspending.store state)
  in
  XCommon.output_pipe_object ~config ~initiator ~source ~pipe ~archive_member
    key value

(** For .mli *)
let output_get_asset ~config ~initiator ~source ~command_output key =
  let open BuildInstance.Syntax in
  let* state = get in
  let value =
    Alacarte_xasync_apparatus.MutableStore.get_value key
      (Alacarte_6_4_test.StateSuspending.store state)
  in
  XCommon.output_get_asset ~config ~initiator ~source ~command_output
    ~archive_member:None key value

(** For .mli *)
let output_get_asset_file ~config ~initiator ~source ~command_output
    ~archive_member key =
  let open BuildInstance.Syntax in
  let* state = get in
  let value =
    Alacarte_xasync_apparatus.MutableStore.get_value key
      (Alacarte_6_4_test.StateSuspending.store state)
  in
  XCommon.output_get_asset_file ~config ~initiator ~source ~command_output
    ~archive_member key value

(** For .mli *)
let unzip_and_cache_value ~config ~source range key =
  let open BuildInstance.Syntax in
  let* state = get in
  let value =
    Alacarte_xasync_apparatus.MutableStore.get_value key
      (Alacarte_6_4_test.StateSuspending.store state)
  in
  XCommon.unzip_and_cache_value ~config ~source range value

(** For .mli *)
let run_unit_continuation kont state =
  match BuildInstance.Launcher.run_continuation kont state with
  | (), state' -> state'

(** For .mli *)
let run_continuation kont state =
  BuildInstance.Launcher.run_continuation kont state

let remove_invalid_values ~config (state : state) =
  let open Alacarte_3_2_apparatus in
  let open Alacarte_6_4_test in
  let valuestore = BuildConfig.valuestore config in
  let buildlogtrace =
    if BuildConfig.buildlogtrace config then Some () else None
  in
  let cont =
    let open BuildInstance.Syntax in
    match BuildConfig.integrity config with
    | `None -> return ()
    | `Existence ->
        (* We don't need to check for existence since already done. *)
        Assumptions
        .persisted_values_are_checked_for_existence_during_trace_store_load ();
        return ()
    | `Checksum as integrity ->
        let integrity_name = "checksum" in
        if buildlogtrace = Some () then
          Printf.eprintf "[buildlog] post load %s check start\n" integrity_name;
        let* state' = get in
        let traces = StateSuspending.get_all_traces state' in
        let visited = Hashtbl.create (List.length traces) in
        let* () =
          List.fold_left
            (fun acc
                 ({ key = k; dependencies = _; result = v } as trace :
                   StateSuspending.trace) ->
              let* () = acc in
              match (V.value_id v, V.maybe_cloud_persistent_hash k v) with
              | Some value_id, Some value_sha256 ->
                  if Hashtbl.mem visited value_id then return ()
                  else begin
                    Hashtbl.add visited value_id ();
                    let* (maybe_available : MlFront_Core.FilePath.t option) =
                      BuildInstance.ValueStore.make_value_available
                        ?buildlogtrace ~valuestore ~value_id ~value_sha256
                        ~integrity ()
                    in
                    match maybe_available with
                    | Some _available_fp -> return ()
                    | None ->
                        if buildlogtrace = Some () then
                          Printf.eprintf "[buildlog] remove trace %s\n" value_id;
                        let* state' = get in
                        StateSuspending.remove_trace state' trace;
                        return ()
                  end
              | _ -> return ())
            (return ()) traces
        in
        if buildlogtrace = Some () then
          Printf.eprintf "[buildlog] post load %s check finished\n"
            integrity_name;
        return ()
  in
  let (), state' = BuildInstance.Launcher.run_continuation cont state in
  state'