Source file BuildTaskFactory.ml

open BuildCore

module ObjectSlotMap = Map.Make (struct
  type t = MlFront_Thunk.ThunkCommand.object_slot

  let compare = MlFront_Thunk.ThunkCommand.compare_object_slot
end)

module CstIo = MlFront_Thunk.ThunkCst.Io (Alacarte_xpromise_apparatus.Promise)

let warn s = Format.eprintf "@[<v 2>[warning]: %a@]@." pp_lines_of_text s

let type_error expected v' =
  let open BuildInstance.Syntax in
  let open Alacarte_3_2_apparatus in
  (* PROGRAMMER ERROR! Use key-dependent value GADT in BuildEngine to avoid the situation. *)
  let* () =
    fail ~error_code:"e5210732" ~cant_do:"create a build task"
      ~because:(Printf.sprintf "expected a value of type %s" expected)
      ~recommendations:
        [
          Printf.sprintf
            "This is a programmer error. Please file a bug and include the \
             text: %s"
            (V.show v');
        ]
      ()
  in
  return V.Failure_is_pending
[@@warning "-unused-value-declaration"]

let get_distribution ~package_id ~package_semver ~distribution_range
    ~values_file ~values =
  match
    Alacarte_xpromise_apparatus.Promise.run_promise
    @@ BuildCore.Io.read_all values_file
  with
  | `Error msg -> `Error msg
  | `ExceededSizeLimit l -> `ExceededSizeLimit l
  | `Content values_json -> (
      let find_result =
        MlFront_Thunk.ThunkAst.find_distribution values package_id
          package_semver
      in
      match find_result with
      | None -> `Error (Printf.sprintf "Distribution not found in values file")
      | Some
          ( {
              distribution_canonical_id = _;
              distribution_id = did_range, did_library_id, did_semver;
              producer;
              license;
              continuations;
              build;
            },
            _distrange ) ->
          let distribution : MlFront_Thunk.ThunkDist.t =
            {
              id =
                ( MlFront_Thunk.ThunkLexers.Ranges.Raw_range did_range,
                  did_library_id,
                  did_semver );
              producer;
              license;
              continuations;
              build;
            }
          in
          let dist_in_values_json =
            let startp, endp = distribution_range in
            let startb, endb =
              ( Fmlib_parse.Position.byte_offset startp,
                Fmlib_parse.Position.byte_offset endp )
            in
            if endb > String.length values_json then
              (* use compact JSON (no comments) *)
              let yojson =
                MlFront_Thunk.ThunkDist.yojson ~canonical:false distribution
              in
              MlFront_Thunk.YojsonSafe.to_string yojson
            else String.sub values_json startb (endb - startb)
          in
          `Distribution (distribution, dist_in_values_json))

let add_distribution_tasks ~config
    ~(k_distribution : Alacarte_3_2_apparatus.K.t) ~values_file_sha256
    ~values_file ~values ~distribution_range ~add_task
    ~apply_initial_build_metadata =
  let open Alacarte_3_2_apparatus in
  let valuestore = BuildConfig.valuestore config in
  let build_pubkey = BuildConfig.build_pubkey config in
  let build_seckey = BuildConfig.build_seckey config in
  let importtrace = BuildConfig.importtrace config in
  let importtrace2 = BuildConfig.importtrace2 config in
  let package_id, package_semver =
    match k_distribution.key_datum with
    | PackageKey
        { package_kind = DistributionPackageKind; package_id; package_semver }
      ->
        (package_id, package_semver)
    | _ -> invalid_arg "non-distribution package kind key"
  in

  let init fetch =
    let open BuildInstance.Syntax in
    match
      get_distribution ~package_id ~package_semver ~distribution_range
        ~values_file ~values
    with
    | `Error msg ->
        let* () =
          fail ~error_code:"1f15eb52" ~cant_do:"get distribution" ~because:msg
            ()
        in
        return V.Failure_is_pending
    | `ExceededSizeLimit l ->
        let* () =
          fail ~error_code:"9d439b9a" ~cant_do:"get distribution"
            ~because:(Printf.sprintf "it exceeded size limit of %Ld bytes" l)
            ()
        in
        return V.Failure_is_pending
    | `Distribution (distribution, distribution_json) ->
        (* This Distribution entry point is the include files. *)
        Assumptions.distribution_entry_points_only_trace_stores_and_include_dirs
          ();
        (* Accept the distribution *)
        let* state = get in
        BuildCore.Alacarte_6_4_test.StateSuspending.accept_distribution
          ~values_file_sha256 ~json:distribution_json ~pkg:package_id state
          distribution;
        (* Make the task *)
        BuildTaskDistribution.make_task ~valuestore ~importtrace ~importtrace2
          ~build_pubkey ~build_seckey ~values_file ~package_id ~package_semver
          ~apply_aliases:apply_initial_build_metadata distribution
          distribution_json fetch
  in
  let task =
    let memo = ref None in
    fun (fetch : O.t -> K.t -> V.t BuildInstance.Syntax.cont) ->
      match !memo with
      | Some v -> v
      | None ->
          let v' = init fetch in
          memo := Some v';
          v'
  in
  let ( let* ), return = Alacarte_xpromise_apparatus.Promise.(bind, return) in
  let* () = add_task k_distribution task in
  return (`DistributionId (package_id, package_semver))

let add_form_tasks ~config ~(k_user_form : Alacarte_3_2_apparatus.K.t)
    ~values_file_sha256 ~add_task =
  let open Alacarte_3_2_apparatus in
  (match k_user_form.key_datum with
  | ModuleKey { module_kind = UserFormKind _; _ } -> ()
  | _ -> invalid_arg "non-user form kind key");
  let user_task (fetch : O.t -> K.t -> V.t BuildInstance.Syntax.cont) =
    let open BuildInstance.Syntax in
    (* Depend on MlFront_Std.Version *)
    let* _v_version = fetch O.not_relevant K.reserved_version_key in
    let* task =
      BuildTaskForm.make_userformkind_task ~config ~k_user_form
        ~values_file_sha256
    in
    task fetch
  in
  add_task k_user_form user_task

let add_bundle_tasks ~config ~initiator
    ~(k_user_bundle : Alacarte_3_2_apparatus.K.t) ~values_file_sha256
    ~values_file_local ~add_task =
  let open Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  (match k_user_bundle.key_datum with
  | ModuleKey { module_kind = UserBundleKind; _ } -> ()
  | _ -> invalid_arg "non-user bundle kind key");
  let user_task (fetch : O.t -> K.t -> V.t cont) =
    let open BuildInstance.Syntax in
    (* Depend on MlFront_Std.Version *)
    let* _v_version = fetch O.not_relevant K.reserved_version_key in
    BuildTaskBundle.make_userbundlekind_task_of_bundle ~config ~k_user_bundle
      ~values_file_sha256 ~values_file_local ~initiator fetch
  in
  add_task k_user_bundle user_task

let add_asset_tasks ~config ~(k_user_asset : Alacarte_3_2_apparatus.K.t)
    ~values_file_sha256 ~add_task =
  let open Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  (match k_user_asset.key_datum with
  | ModuleKey { module_kind = UserAssetKind _; _ } -> ()
  | _ -> invalid_arg "non-user asset kind key");
  let user_task (fetch : O.t -> K.t -> V.t cont) =
    let open BuildInstance.Syntax in
    (* Depend on MlFront_Std.Version *)
    let* _v_version = fetch O.not_relevant K.reserved_version_key in
    BuildTaskAsset.make_userassetkind_task_of_asset ~config ~k_user_asset
      ~values_file_sha256 fetch
  in
  add_task k_user_asset user_task

let mk_ref ~values_file_sha256 range source :
    Alacarte_3_2_apparatus.K.reference option =
  Some
    {
      reference_range = range;
      reference_transient = Some { reference_file = source };
      reference_file_sha256 = values_file_sha256;
    }

let trim_right s =
  let l = String.length s in
  let rec aux_len i =
    if i < 0 then 0
    else
      match s.[i] with
      | ' ' | '\t' | '\r' | '\n' -> aux_len (i - 1)
      | _ -> i + 1
  in
  let new_l = aux_len (l - 1) in
  String.sub s 0 new_l

let left_pad s =
  let lines = String.split_on_char '\n' s in
  String.concat "\n" (List.map (fun line -> "  " ^ trim_right line) lines)

let immediate_fail ~error_code ?cant_do ?because ?error_locations
    ?recommendations ?exitcode_posix ?exitcode_windows () :
    Alacarte_3_2_apparatus.V.t
    Alacarte_3_7_test_last.ThunkTrackingInterpreter.C.t =
  let open BuildInstance.Syntax in
  let* () =
    BuildInstance.Syntax.fail ~error_code ?cant_do ?because ?error_locations
      ?recommendations ?exitcode_posix ?exitcode_windows ()
  in
  return Alacarte_3_2_apparatus.V.Failure_is_pending

(* The [values_file] must be local and part of the user include path. *)
let create_values_task ?allow_deprecated_toplevel_moduleid ~config ~values_file
    ~values_file_sha256
    ~(policy_fail :
       Alacarte_3_2_apparatus.K.t ->
       error_code:string ->
       ?cant_do:string ->
       ?because:string ->
       ?error_locations:
         MlFront_Thunk.BuildWriters.Standard.problem_location list ->
       ?recommendations:string list ->
       ?exitcode_posix:int ->
       ?exitcode_windows:int ->
       unit ->
       Alacarte_3_2_apparatus.V.t
       Alacarte_3_7_test_last.ThunkTrackingInterpreter.C.t)
    ~policy_fail_already_rendered
    (module ResultObserver : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
    (fetch :
      Alacarte_3_2_apparatus.O.t ->
      Alacarte_3_2_apparatus.K.t ->
      Alacarte_3_2_apparatus.V.t BuildInstance.Syntax.cont) =
  let valuestore = BuildConfig.valuestore config in
  let build_pubkey = BuildConfig.build_pubkey config in
  let build_seckey = BuildConfig.build_seckey config in
  let open Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  let safe_maybe_local_values_file =
    match values_file with `Validated o -> o
  in
  (* if BuildConfig.debug_task config then
    Printf.eprintf "[task] %s starting parse `%s`\n"
      (V.get_valuesjsonfile_value_id ~values_file_sha256)
      (Io.file_origin safe_maybe_local_values_file); *)

  (* Make a key for when the values file can't be loaded *)
  match
    K.create_checksum_for_values_file ~debug_reference:None ~values_file_sha256
      ()
  with
  | Error msg -> immediate_fail ~error_code:"2f3b2a13" ~because:msg ()
  | Ok k_valuesfile -> (
      (* Always put a dependency on the MlFront_Std.Version. *)
      let* _v_version = fetch O.not_relevant K.reserved_version_key in

      (* Parse the values file into CST *)
      let* parsed =
        lift_promise
        @@ CstIo.parse ?allow_deprecated_toplevel_moduleid
             ~downgrade_errors_into_warnings:()
             (module ResultObserver)
             safe_maybe_local_values_file
      in
      let maybe_cst =
        Result.map_error
          MlFront_Thunk.ThunkParsers.Results.Semantic.error_message parsed
      in
      if BuildConfig.parsetrace config then
        Printf.eprintf "[parse] %s from `%s`\n" (K.show k_valuesfile)
          (Io.file_origin safe_maybe_local_values_file);

      match maybe_cst with
      | Error msg ->
          (* We need some random key so we can return Input_not_found
             if that is our policy *)
          policy_fail k_valuesfile ~error_code:"609c36f9"
            ~because:(Printf.sprintf "errored with: %s" msg)
            ~recommendations:[ "Fix the syntax errors in the values file." ]
            ()
      | Ok cst -> begin
          let values_canonical_id = MlFront_Thunk.ThunkCst.canonical_id cst in
          let value_id = V.get_values_value_id ~values_canonical_id in

          (* Check if AST already in the value store *)
          let* values_opt =
            lift_promise
            @@ BuildInstance.ValueStore.get_generic_ast ~valuestore
                 ~build_pubkey
                 ~value_id:(V.get_values_value_id ~values_canonical_id)
                 ~unmarshal:(fun bs -> Marshal.from_bytes bs 0)
                 ()
          in
          match values_opt with
          | Some (values, `Sha256 value_sha256) ->
              (* AST already in value store *)
              return
                (V.Values
                   {
                     value_id;
                     value_sha256;
                     value =
                       Some
                         {
                           values_canonical_id;
                           values_file_sha256;
                           values_file_local = Some values_file;
                           values_origin = None;
                           values_transient =
                             Some
                               {
                                 values;
                                 values_file = safe_maybe_local_values_file;
                               };
                         };
                   })
          | None -> begin
              (* Parse the CST into AST *)
              Assumptions.values_files_loaded_on_demand_from_filesystem ();
              match
                MlFront_Thunk.ThunkAst.parse ~downgrade_errors_into_warnings:()
                  ~origin:(Some (Io.file_origin safe_maybe_local_values_file))
                  ~inferred_package_id_or_reason_whynone:
                    (BuildConfig.inferred_package_id_or_reason_whynone config)
                  (module ResultObserver)
                  cst
              with
              | Error msg ->
                  policy_fail k_valuesfile ~error_code:"b8c41540"
                    ~because:(Printf.sprintf "errored with: %s" msg)
                    ()
              | Ok values -> begin
                  (* Validate the AST of each form *)
                  let* validation_result =
                    let cont_of_result x =
                      lift_promise (Alacarte_xpromise_apparatus.Promise.pure x)
                    in
                    MlFront_Thunk.ThunkAst.fold_forms
                      ~init:(cont_of_result (Ok ()))
                      ~f:(fun (form : MlFront_Thunk.ThunkAst.form) acc ->
                        let* acc_result = acc in
                        match acc_result with
                        | Error e -> cont_of_result (Error e)
                        | Ok () -> begin
                            match form with
                            | { precommands = { private_; public_ }; _ } ->
                                let precommands = private_ @ public_ in
                                lift_promise
                                @@ BuildValidation.validate_precommands
                                     ~downgrade_errors_into_warnings:() ~config
                                     ~source:safe_maybe_local_values_file
                                     precommands
                          end)
                      values
                  in
                  match validation_result with
                  | Error msg ->
                      policy_fail_already_rendered k_valuesfile
                        ~error_code:"dfd8d3c3" ~rendered:msg ()
                  | Ok () -> begin
                      (* add parsed values to value store *)
                      let* _added, (value_sha256, _values_size) =
                        lift_promise
                        @@ BuildInstance.ValueStore.add_generic_ast_exn
                             ~valuestore ~build_seckey ~value_id
                             ~marshalled_ast_bytes:(fun () ->
                               Marshal.to_bytes values [])
                             ()
                      in

                      (* done *)
                      return
                        (V.Values
                           {
                             value_id;
                             value_sha256;
                             value =
                               Some
                                 {
                                   values_canonical_id;
                                   values_file_sha256;
                                   values_file_local = Some values_file;
                                   values_origin = None;
                                   values_transient =
                                     Some
                                       {
                                         values;
                                         values_file =
                                           safe_maybe_local_values_file;
                                       };
                                 };
                           })
                    end
                end
            end
        end)

let add_values_tasks_gracefully ?allow_deprecated_toplevel_moduleid ~config
    ~values_file ~values_file_sha256 ~add_task
    (module ResultObserver : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT)
    =
  let open Alacarte_3_2_apparatus in
  let safe_maybe_local_values_file =
    match values_file with `Validated o -> o
  in
  let ( let* ) = Alacarte_xpromise_apparatus.Promise.bind in
  let return = Alacarte_xpromise_apparatus.Promise.return in
  let policy_fail k ~error_code ?cant_do ?because ?error_locations
      ?recommendations ?exitcode_posix ?exitcode_windows () :
      V.t Alacarte_3_7_test_last.ThunkTrackingInterpreter.C.t =
    ignore exitcode_posix;
    ignore exitcode_windows;
    let open BuildInstance.Syntax in
    let cant_do =
      Option.value
        ~default:
          (Printf.sprintf "parse `%s` (%s)"
             (Io.file_origin safe_maybe_local_values_file)
             (K.show k))
        cant_do
    in
    let because = Option.value ~default:"" because in
    let error_locations = Option.value ~default:[] error_locations in
    let recommendations = Option.value ~default:[] recommendations in
    let rendered, _summary =
      let (`Validated source_file) = values_file in
      BuildValidation.render_trace ~downgrade_errors_into_warnings:() ~cant_do
        ~observer_result:(module ResultObserver)
        ~source_file
        MlFront_Thunk.BuildWriters.Standard.
          [
            ErrorBacktraceItem'
              { error_code; cant_do; because; error_locations; recommendations };
          ]
    in
    prerr_endline rendered;
    return (V.Input_not_found k)
  in
  let policy_fail_already_rendered k ~error_code ~rendered () :
      V.t Alacarte_3_7_test_last.ThunkTrackingInterpreter.C.t =
    let open BuildInstance.Syntax in
    let padded = "\n" ^ left_pad rendered in
    Printf.eprintf "[warning %s] parse failed for %s%s\n" error_code (K.show k)
      padded;
    return (V.Input_not_found k)
  in
  let values_task =
    create_values_task ?allow_deprecated_toplevel_moduleid ~config ~values_file
      ~values_file_sha256 ~policy_fail ~policy_fail_already_rendered
      (module ResultObserver)
  in
  match
    K.create_checksum_for_values_file ~debug_reference:None ~values_file_sha256
      ()
  with
  | Error msg -> return (Error msg)
  | Ok k_checksum ->
      Assumptions.values_task_includes_sha256_of_values_file_in_key ();
      let* () = add_task k_checksum values_task in
      return (Ok ())

type add_values_result =
  [ `BundleId of MlFront_Thunk.ThunkCommand.module_version
  | `DistributionId of MlFront_Core.PackageId.t * MlFront_Thunk.ThunkSemver64.t
  ]
  list

let rec add_values_from_ast ~config ~values_file_sha256 ~values_file_local
    ~add_task ~initiator ~apply_initial_build_metadata ~request_slot values
    values_file :
    [ `BundleId of MlFront_Thunk.ThunkCommand.module_version
    | `DistributionId of
      MlFront_Core.PackageId.t * MlFront_Thunk.ThunkSemver64.t ]
    list
    Alacarte_xpromise_apparatus.Promise.t =
  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

  (* if BuildConfig.parsetrace config then
    Printf.eprintf "[parse] add_values_from_ast %s values:\n%s\n"
      (Alacarte_3_2_apparatus.V.get_valuesjsonfile_value_id ~values_file_sha256)
      (Format.asprintf "%a" MlFront_Thunk.ThunkCst.pp
         (MlFront_Thunk.ThunkAst.concrete values)); *)

  (* distributions *)
  let* distributions =
    add_distributions_from_ast ~config ~add_task ~apply_initial_build_metadata
      ~values_file_sha256 ~values_file ~alert values
  in

  (* forms *)
  let* () =
    add_forms_from_ast ~config ~add_task ~apply_initial_build_metadata
      ~values_file_sha256 ~request_slot ~alert values values_file
  in

  (* bundles and assets *)
  let* bundles =
    add_bundles_and_assets_from_ast ~config ~add_task
      ~apply_initial_build_metadata ~values_file_sha256 ~values_file_local
      ~initiator values values_file
  in
  return ((bundles :> add_values_result) @ (distributions :> add_values_result))

and add_distributions_from_ast ~config ~add_task ~apply_initial_build_metadata
    ~values_file_sha256 ~values_file ~alert (ast : MlFront_Thunk.ThunkAst.t) :
    [ `DistributionId of
      MlFront_Core.PackageId.t * MlFront_Thunk.ThunkSemver64.t ]
    list
    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 f distribution distribution_range acc =
    let {
      distribution_canonical_id = _;
      distribution_id = _range, _id, version;
      producer = _;
      license = _;
      continuations = _;
      build = _;
    } : MlFront_Thunk.ThunkAst.distribution =
      distribution
    in
    (* Printf.eprintf
      "[debug] add_distributions_from_ast: found distribution %s version %s\n%!"
      (MlFront_Core.LibraryId.full_name _id)
      (MlFront_Thunk.ThunkSemver64.to_string version); *)
    let* acc = acc in

    match SecPackageRegistry.package_id_for_distribution' distribution with
    | None ->
        warn (alert "skipping distribution that cannot be distributed");
        return acc
    | Some package_id ->
        (* Distribution key *)
        let k_distribution =
          K.create_for_distribution
            ~debug_reference:
              (mk_ref ~values_file_sha256 distribution_range values_file)
            ~package_id ~package_semver:version ()
        in

        (* Add user-visible task to mutable Tasks *)
        if BuildConfig.parsetrace config then
          Printf.eprintf "[parse] %s\n" (K.show k_distribution);
        if BuildConfig.debug_task config then
          Printf.eprintf "[task] %s\n" (K.show k_distribution);
        let* r =
          add_distribution_tasks ~config ~k_distribution ~values_file_sha256
            ~values_file ~values:ast ~distribution_range ~add_task
            ~apply_initial_build_metadata
        in
        return (r :: acc)
  in
  MlFront_Thunk.ThunkAst.fold_distributions_with_ranges ~f ~init:(return []) ast

(** Build up the map of forms. *)
and add_forms_from_ast ~config ~add_task ~apply_initial_build_metadata
    ~values_file_sha256 ~request_slot ~alert (ast : MlFront_Thunk.ThunkAst.t)
    values_file : unit 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 f form formrange acc =
    let {
      form_canonical_id = _;
      form_id = { id; version };
      precommands = _;
      function_ = _;
      outputs = _;
    } : MlFront_Thunk.ThunkAst.form =
      form
    in
    let* () = acc in

    let exception Failed of string in
    let failed s = raise (Failed s) in
    try
      let slots :
          (MlFront_Thunk.ThunkCommand.object_slot * Fmlib_parse.Position.range)
          list =
        MlFront_Thunk.ThunkAst.form_slots_exported ~request_slot form
      in
      let atleastoneslot =
        match slots with
        | [] ->
            failed
              "There were no slots exported. You need at least one \
               ${SLOT.Some.Slot.Name} in the function [args] or in the `-f \
               OUTPUT_FILE` or `-d OUTPUT_DIR` precommand expressions."
        | _ -> slots
      in

      (* Add the reserved slot that will be used as a dependency for bundle
            and asset. *)
      let slotmap =
        ObjectSlotMap.add MlFront_Thunk.ThunkCommand.reserved_any_slot ()
          ObjectSlotMap.empty
      in

      (* De-duplicate to unique slots since more than one range for a [slot].

            We don't care about the [range]!
            We can always recover all the ranges using something like
            [MlFront_Thunk.ThunkAst.slots_exported (get_form form_map)]. *)
      let atleastoneuniqueslot =
        List.fold_left
          (fun map'
               ((slot, _range) :
                 MlFront_Thunk.ThunkCommand.object_slot
                 * Fmlib_parse.Position.range) ->
            if ObjectSlotMap.mem slot map' then map'
            else ObjectSlotMap.add slot () map')
          slotmap atleastoneslot
      in

      let* () =
        List.fold_left
          (fun acc (slot, ()) ->
            let* () = acc in
            (* Form key *)
            let k_user_form =
              K.create_for_form ~apply_aliases:apply_initial_build_metadata
                ~debug_reference:
                  (mk_ref ~values_file_sha256 formrange values_file)
                ~module_id:id ~module_semver:version ~slot ()
            in
            (* Add tasks to mutable Tasks *)
            if BuildConfig.parsetrace config then
              Printf.eprintf "[parse] %s\n" (K.show k_user_form);
            if BuildConfig.debug_task config then
              Printf.eprintf "[task] %s\n" (K.show k_user_form);
            add_form_tasks ~config ~k_user_form ~values_file_sha256 ~add_task)
          (return ())
          (ObjectSlotMap.bindings atleastoneuniqueslot)
      in
      return ()
    with Failed msg ->
      warn (alert msg);
      return ()
  in
  MlFront_Thunk.ThunkAst.fold_forms_with_ranges ~f ~init:(return ()) ast

(** Build up the map of assets and bundle files. *)
and add_bundles_and_assets_from_ast ~config ~add_task
    ~apply_initial_build_metadata ~values_file_sha256 ~values_file_local
    ~initiator values values_file :
    [ `BundleId of MlFront_Thunk.ThunkCommand.module_version ] list
    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

  (* if BuildConfig.parsetrace config then
    Printf.eprintf "[parse] add_assets_from_ast %s ast:\n%s\n"
      (V.get_valuesjsonfile_value_id ~values_file_sha256)
      (Format.asprintf "%a" MlFront_Thunk.ThunkCst.pp
         (MlFront_Thunk.ThunkAst.concrete values)); *)

  (* Add all the assets *)
  let f bundle assetrange acc =
    let {
      bundle_canonical_id = _;
      listing = _;
      listing_unencrypted = { bundle_id = { id; version } as bundle_id };
      asset_files = _;
    } : MlFront_Thunk.ThunkAst.bundle =
      bundle
    in
    let* acc = acc in

    (* Bundle key *)
    let k_user_bundle =
      K.create_for_bundle ~apply_aliases:apply_initial_build_metadata
        ~debug_reference:(mk_ref ~values_file_sha256 assetrange values_file)
        ~module_id:id ~module_semver:version ()
    in

    (* Add user-visible task to mutable Tasks *)
    if BuildConfig.parsetrace config then
      Printf.eprintf "[parse] %s\n" (K.show k_user_bundle);
    if BuildConfig.debug_task config then
      Printf.eprintf "[task] %s\n" (K.show k_user_bundle);
    let* () =
      add_bundle_tasks ~config ~initiator ~k_user_bundle ~values_file_sha256
        ~values_file_local ~add_task
    in

    (* Add all the bundle files *)
    let* () =
      MlFront_Thunk.ThunkAst.fold_assets_wth_ranges
        ~f:(fun asset_file asset_range acc ->
          let {
            file_canonical_id = _;
            file_origin = _;
            file_path;
            file_checksum = _;
            file_sz = _;
          } : MlFront_Thunk.ThunkAst.asset_file2 =
            asset_file
          in
          let* () = acc in

          (* Asset keys *)
          let k_user_asset =
            K.create_for_asset ~apply_aliases:apply_initial_build_metadata
              ~debug_reference:
                (mk_ref ~values_file_sha256 asset_range values_file)
              ~module_id:id ~module_semver:version ~asset_path:file_path ()
          in

          (* Add user-visible task to mutable Tasks *)
          if BuildConfig.parsetrace config then
            Printf.eprintf "[parse] %s\n" (K.show k_user_asset);
          if BuildConfig.debug_task config then
            Printf.eprintf "[task] %s\n" (K.show k_user_asset);

          add_asset_tasks ~config ~k_user_asset ~values_file_sha256 ~add_task)
        ~init:(return ()) bundle
    in

    return (`BundleId bundle_id :: acc)
  in
  MlFront_Thunk.ThunkAst.fold_bundles_with_ranges ~f ~init:(return []) values