Source file ThunkAst.ml

include ThunkAstType

let canonical_id_bundle { bundle_canonical_id; _ } = bundle_canonical_id
let canonical_id_asset_file { file_canonical_id; _ } = file_canonical_id
let canonical_id_form { form_canonical_id; _ } = form_canonical_id

let canonical_id_precommand { precommand_canonical_id; _ } =
  precommand_canonical_id

let canonical_id { canonical_id; _ } = canonical_id

let find_form
    ({ canonical_id = _; bundles = _; assets = _; forms; distributions = _ } :
      t) search =
  let agnostic_search =
    ThunkCommand.versioned_module_id_with_dropped_bn_build_metadata search
  in
  match FormTable.get agnostic_search forms with
  | None -> None
  | Some (range, form) -> Some (form, range)

let find_bundle
    ({ canonical_id = _; bundles; assets = _; forms = _; distributions = _ } :
      t) search =
  let agnostic_search =
    ThunkCommand.versioned_module_id_with_dropped_bn_build_metadata search
  in
  match BundleTable.get agnostic_search bundles with
  | None -> None
  | Some (range, bundle) -> Some (bundle, range)

let find_asset
    ({ canonical_id = _; bundles = _; assets; forms = _; distributions = _ } :
      t) search_id search_path =
  let agnostic_search =
    ThunkCommand.versioned_module_id_with_dropped_bn_build_metadata search_id
  in
  match AssetTable.get (agnostic_search, search_path) assets with
  | None -> None
  | Some (range, asset_file, asset_origin) ->
      Some (asset_file, asset_origin, range)

let find_asset_in_asset
    { asset_files; listing; bundle_canonical_id = _; listing_unencrypted = _ }
    path =
  let file =
    List.find_opt
      (fun (_range, { file_path; _ }) -> String.equal file_path path)
      asset_files
  in
  match file with
  | None -> None
  | Some
      ( range,
        ({
           file_canonical_id = _;
           file_origin;
           file_path = _;
           file_checksum = _;
           file_sz = _;
         } as file) ) -> (
      let origin =
        List.find_opt
          (fun { origin_name; _ } -> String.equal origin_name file_origin)
          listing.origins
      in
      match origin with
      | Some origin -> Some (file, origin, range)
      | None -> None)

let find_distribution
    ({ canonical_id = _; bundles = _; assets = _; forms = _; distributions } :
      t) pkg_id semver =
  let semver_buildless = ThunkSemver64.with_dropped_bn_build_metadata semver in
  match DistributionTable.get (pkg_id, semver_buildless) distributions with
  | None -> None
  | Some (range, distribution) -> Some (distribution, range)

let fold_distributions_with_ranges ~f ~init
    { canonical_id = _; bundles = _; assets = _; forms = _; distributions } =
  DistributionTable.fold
    (fun acc _distribution_id (range, distribution) -> f distribution range acc)
    init distributions

let fold_forms ~f ~init
    { canonical_id = _; bundles = _; assets = _; forms; distributions = _ } =
  FormTable.fold (fun acc _form_id (_range, form) -> f form acc) init forms

let fold_forms_with_ranges ~f ~init
    { canonical_id = _; bundles = _; assets = _; forms; distributions = _ } =
  FormTable.fold (fun acc _form_id (range, form) -> f form range acc) init forms

let fold_bundles ~f ~init
    { canonical_id = _; bundles; assets = _; forms = _; distributions = _ } =
  BundleTable.fold
    (fun acc _asset_id (_range, bundle) -> f bundle acc)
    init bundles

let fold_bundles_with_ranges ~f ~init
    { canonical_id = _; bundles; assets = _; forms = _; distributions = _ } =
  BundleTable.fold
    (fun acc _bundle_id (range, bundle) -> f bundle range acc)
    init bundles

let fold_assets ~f ~init bundle =
  List.fold_left
    (fun acc (_range, asset_file) -> f asset_file acc)
    init bundle.asset_files

let fold_assets_wth_ranges ~f ~init bundle =
  List.fold_left
    (fun acc (range, asset_file) -> f asset_file range acc)
    init bundle.asset_files

let mk_origins_table_from_bundles bundles =
  let tbl_origins = Hashtbl.create 16 in
  BundleTable.iter bundles (fun _bundle_id (_bundlerange, bundle) ->
      List.iter
        (fun ({ origin_name; origin_mirrors = _ } as origin : asset_origin2) ->
          if not (Hashtbl.mem tbl_origins origin_name) then
            Hashtbl.add tbl_origins origin_name origin)
        bundle.listing.origins);
  tbl_origins

module Parsing = struct
  exception FailedParse of string

  let err s = raise (FailedParse s)

  let spr : ('a, Format.formatter, unit, string) format4 -> 'a =
   fun fmt -> Format.asprintf ("@[<v 1>" ^^ fmt ^^ "@]")

  let parse_arg (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
      sourcestate decodestate (argrange, argvalue) =
    match
      ThunkCommand.InternalUse.parse_evalable_term
        (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
        sourcestate decodestate (Some argrange) argvalue
    with
    | Ok v -> v
    | Error { error_range = _; error_message; is_rendered = _ } ->
        err
        @@ spr "The argument `%s` is invalid.@;%a" argvalue
             Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
             (String.split_on_char '\n' error_message)

  let parse_output
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) sourcestate
      decodestate
      ({ slots = _slotrange, slotvalues; paths = _range, pathvalues } :
        ThunkCst.output) : output =
    let slots =
      List.map
        (fun (slotrange, slotvalue) ->
          match
            ThunkCommand.InternalUse.parse_object_slot
              (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
              sourcestate decodestate (Some slotrange) slotvalue
          with
          | Ok slot -> (ThunkLexers.Ranges.display_range slotrange, slot)
          | Error { error_range = _; error_message; is_rendered = _ } ->
              err
              @@ spr "The output slot `%s` is invalid.@;%a" slotvalue
                   Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
                   (String.split_on_char '\n' error_message))
        slotvalues
    in
    let first_slot, rest_slots =
      match slots with
      | [] -> err (spr "There are no output slots.")
      | first :: rest -> (first, rest)
    in
    let first_path, rest_paths =
      match
        List.map
          (fun (r, v) -> (ThunkLexers.Ranges.display_range r, v))
          pathvalues
      with
      | [] -> err (spr "There are no output paths.")
      | first :: rest -> (first, rest)
    in
    { slots = (first_slot, rest_slots); paths = (first_path, rest_paths) }

  module Final = struct
    type t = envmod
  end

  module EnvModParse = struct
    include
      Fmlib_parse.Ucharacter.Make_utf8 (ThunkParsers.Results.State) (Final)
        (ThunkParsers.Results.Semantic)

    let make_at ?(pos = Fmlib_parse.Position.start) state
        (final : Parser.final t) : Parser.t =
      make_partial pos state (final >>= expect_end)
  end

  (** Character set is defined in
      {{:https://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap08.html}POSIX
       specification}.

      In particular, the rules use the
      {{:https://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap06.html#tagtcjh_3}Portable
       Character Set} and omit the [=] and [NUL] symbols.

      MlFront per the SPECIFICATION.md restricts further: no whitespace except
      space, and no control characters. *)
  let char_envname : char -> bool = function
    | '=' -> false
    | ' ' -> true
    | '!' .. '/' -> true
    | '0' .. '9' -> true
    | ':' .. '@' -> true
    | 'A' .. 'Z' -> true
    | '[' .. '`' -> true
    | 'a' .. 'z' -> true
    | '{' .. '~' -> true
    | _ -> false

  let char_envname_no_digit : char -> bool = function
    | '0' .. '9' -> false
    | c -> char_envname c

  let envname_firstchar_c =
    EnvModParse.charp char_envname_no_digit
      "The first character of an environment variable name must not be a digit \
       or an equal symbol (=), and it must be in the Portable Character Set \
       (space, !, \", #, $, %, &, ', (, ), *, +, ,, -, ., /, 0-9, :, ;, <, >, \
       ?, @,\
      \ A-Z, [, \\, ], ^, _, `, a-z, {, |, }, ~)."

  let envname_rest_c =
    EnvModParse.zero_or_more
      (EnvModParse.charp char_envname
         "The second and remaining characters of the environment variable name \
          must not be the equal symbol (=), and must be in the Portable \
          Character Set (space, !, \", #, $, %, &, ', (, ), *, +, ,, -, ., /, \
          0-9, :, ;, <, >, ?, @,\
         \ A-Z, [, \\, ], ^, _, `, a-z, {, |, }, ~).")

  let any_char =
    EnvModParse.charp (fun _ -> true) "Binary data has no restrictions."

  let string_of_chars chars =
    let buf = Buffer.create 16 in
    List.iter (Buffer.add_char buf) chars;
    Buffer.contents buf

  let process_envpair ~envname_firstchar ~envname_rest
      ~located_envvalue:(envvaluerange, envvaluevalue)
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) sourcestate
      decodestate f =
    let envname = string_of_chars (envname_firstchar :: envname_rest) in
    let envvalue = string_of_chars envvaluevalue in
    match
      ThunkCommand.InternalUse.parse_evalable_term
        (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
        sourcestate decodestate (Some envvaluerange) envvalue
    with
    | Error { error_range = _; error_message; is_rendered = _ } ->
        err
        @@ spr
             "The value `%s` of the environment variable `%s` had an invalid \
              syntax;%a"
             envvalue envname
             Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
             (String.split_on_char '\n' error_message)
    | Ok envvalue -> f envname envvalue

  let addenv_c (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) :
      envmod EnvModParse.t =
    let open EnvModParse in
    let* _c =
      char '+' <?> "An opening equals sign (=) to add an environment variable."
    in
    let* envname_firstchar = envname_firstchar_c in
    let* envname_rest = envname_rest_c in
    let* _ = char '=' in
    let* located_envvalue = zero_or_more any_char |> located in
    let* sourcestate = get in
    process_envpair ~envname_firstchar ~envname_rest
      ~located_envvalue:(Raw_range (fst located_envvalue), snd located_envvalue)
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
      sourcestate `DirectDecode
      (fun envname envvalue -> return @@ AddEnv { envname; envvalue })

  let removeenv_c : envmod EnvModParse.t =
    let open EnvModParse in
    let* _ =
      char '-'
      <?> "An opening minus symbol (-) to remove an environment variable."
    in
    let* envname_firstchar = envname_firstchar_c in
    let* envname_rest = envname_rest_c in
    let envname = string_of_chars (envname_firstchar :: envname_rest) in
    return (RemoveEnv envname)

  let prependpath_c
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) :
      envmod EnvModParse.t =
    let open EnvModParse in
    let* _c =
      char '<'
      <?> "An opening angle bracket (<) to prepend a PATH-like variable."
    in
    let* envname_firstchar = envname_firstchar_c in
    let* envname_rest = envname_rest_c in
    let* _ = char '=' in
    let* located_envvalue = zero_or_more any_char |> located in
    let* sourcestate = get in
    process_envpair ~envname_firstchar ~envname_rest
      ~located_envvalue:(Raw_range (fst located_envvalue), snd located_envvalue)
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
      sourcestate `DirectDecode
      (fun pathenvname pathenvvalue ->
        return @@ PrependPathEnv { pathenvname; pathenvvalue })

  let envmod_c (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) :
      envmod EnvModParse.t =
    let open EnvModParse in
    prependpath_c (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
    </> removeenv_c
    </> addenv_c (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)

  let parse_envmod'
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) sourcestate
      envmodrange envmodvalue =
    let module H = ResultObserver.Make (EnvModParse.Parser) in
    let parser =
      EnvModParse.make_at
        ?pos:(Option.map ThunkLexers.Ranges.start_of_range_plus envmodrange)
        sourcestate
        (envmod_c
           (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT))
    in
    let source, parser =
      let module Subparse = ThunkParsers.MakeSubparse (EnvModParse.Parser) in
      Subparse.parse sourcestate envmodrange parser envmodvalue
    in
    H.observe
      ~cant_do:
        (Printf.sprintf "parse the environment modification `%s`" envmodvalue)
      ~source sourcestate parser

  let parse_envmod
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) sourcestate
      ((envmodrangeplus, envmodvalue) : ThunkLexers.Ranges.range_plus * string)
      =
    match
      parse_envmod'
        (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
        sourcestate (Some envmodrangeplus) envmodvalue
    with
    | Ok v -> v
    | Error { error_range = _; error_message; is_rendered = _ } ->
        err
        @@ spr "The environment modification `%s` has an invalid syntax.@;%a"
             envmodvalue
             Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
             (String.split_on_char '\n' error_message)

  let parse_library_version ~drop_bn_build_metadata
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) sourcestate
      decodestate (range, value) =
    match
      ThunkCommand.InternalUse.parse_library_version
        (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
        sourcestate decodestate range value
    with
    | Ok (library_id, version) ->
        if drop_bn_build_metadata then
          (library_id, ThunkSemver64.with_dropped_bn_build_metadata version)
        else (library_id, version)
    | Error { error_range = _; error_message; is_rendered = _ } ->
        err
        @@ spr "The library version `%s` is invalid.@;%a" value
             Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
             (String.split_on_char '\n' error_message)

  let parse_module_version ~drop_bn_build_metadata ~package_id_opt
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) sourcestate
      decodestate (range, value) =
    match
      ThunkCommand.InternalUse.parse_module_version ~package_id_opt
        (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
        sourcestate decodestate range value
    with
    | Ok { id; version } ->
        if drop_bn_build_metadata then
          {
            ThunkCommand.id;
            version = ThunkSemver64.with_dropped_bn_build_metadata version;
          }
        else { id; version }
    | Error { error_range = _; error_message; is_rendered = _ } ->
        err
        @@ spr "The module version `%s` is invalid.@;%a" value
             Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
             (String.split_on_char '\n' error_message)

  let parse_precommand_instance ~cst_canonical_id
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) sourcestate
      ((precommandrangeplus, precommandvalue) :
        ThunkLexers.Ranges.range_plus * string) : precommand_instance =
    match
      ThunkCommand.parse_embedded_in_json
        (module ResultObserver)
        sourcestate (Some precommandrangeplus) precommandvalue
    with
    | Ok v ->
        let precommand_canonical_id =
          Digestif.SHA256.to_hex
            (Digestif.SHA256.digest_string
               (cst_canonical_id ^ "|precommand|" ^ precommandvalue))
        in
        {
          precommand_canonical_id;
          precommand = (ThunkLexers.Ranges.display_range precommandrangeplus, v);
        }
    | Error { error_range = _; error_message; is_rendered = _ } ->
        err error_message

  let parse_asset_origin2
      ({ origin_name; origin_mirrors } : ThunkBundle.asset_origin2) :
      asset_origin2 =
    { origin_name; origin_mirrors }

  let parse_asset_file2
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) sourcestate
      (( rangeplus,
         ({
            file_origin;
            file_path;
            file_checksum = { checksum_sha256; checksum_sha1 };
            file_sz;
          } as file) ) :
        ThunkLexers.Ranges.range_plus * ThunkBundle.asset_file2) :
      Fmlib_parse.Position.range * asset_file2 =
    let file_canonical_id = ThunkBundle.canonical_asset_file_id file in
    match (file_origin, checksum_sha256, checksum_sha1, file_sz) with
    | None, _, _, _ ->
        err
        @@ ThunkParsers.Results.single_error ~code:"e85e306d"
             ~msg:"The `origin` field is required"
             ~brief_instruction:"Provide a valid origin."
             (module ResultObserver)
             sourcestate rangeplus
    | _, None, None, _ ->
        err
        @@ ThunkParsers.Results.single_error ~code:"bb2bd3cb"
             ~msg:
               (spr
                  "The `checksum_sha256` or `checksum_sha1` field is required \
                   for bundle files.")
             ~brief_instruction:"Provide `checksum_sha256` or `checksum_sha1`."
             (module ResultObserver)
             sourcestate rangeplus
    | ( Some file_origin,
        Some (checksum_range, checksum_sha256),
        _,
        (size_range, size) ) ->
        ( ThunkLexers.Ranges.display_range rangeplus,
          {
            file_canonical_id;
            file_origin;
            file_path;
            file_checksum =
              `Sha256
                ( ThunkLexers.Ranges.display_range checksum_range,
                  checksum_sha256 );
            file_sz = (ThunkLexers.Ranges.display_range size_range, size);
          } )
    | ( Some file_origin,
        _,
        Some (checksum_range, checksum_sha1),
        (size_range, size) ) ->
        ( ThunkLexers.Ranges.display_range rangeplus,
          {
            file_canonical_id;
            file_origin;
            file_path;
            file_checksum =
              `Sha1
                (ThunkLexers.Ranges.display_range checksum_range, checksum_sha1);
            file_sz = (ThunkLexers.Ranges.display_range size_range, size);
          } )

  let parse_asset (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
      sourcestate decodestate (bundle : ThunkBundle.t) : bundle =
    let asset_range, bundle_id = bundle.bundle_id in
    let bundle_id =
      Assumptions.values_ast_is_buildnumber_agnostic ();
      parse_module_version ~drop_bn_build_metadata:true ~package_id_opt:None
        (module ResultObserver)
        sourcestate decodestate (asset_range, bundle_id)
    in
    {
      bundle_canonical_id = ThunkBundle.canonical_id bundle;
      listing_unencrypted = { bundle_id };
      listing =
        { origins = List.map parse_asset_origin2 bundle.listing.origins };
      asset_files =
        List.map
          (parse_asset_file2 (module ResultObserver) sourcestate)
          bundle.files;
    }

  let parse_distribution
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) sourcestate
      decodestate (distribution : ThunkDist.t) : distribution =
    let distribution_range, distribution_library, distribution_version =
      distribution.id
    in
    let distribution_id =
      Assumptions.values_ast_is_buildnumber_agnostic ();
      let id =
        ThunkDist.InternalUse.id_of_library_version distribution_library
          distribution_version
      in
      parse_library_version ~drop_bn_build_metadata:true
        (module ResultObserver)
        sourcestate decodestate
        (Some distribution_range, id)
    in
    {
      distribution_canonical_id = ThunkDist.canonical_id distribution;
      distribution_id =
        ( ThunkLexers.Ranges.display_range distribution_range,
          fst distribution_id,
          snd distribution_id );
      producer = distribution.producer;
      license = distribution.license;
      continuations = distribution.continuations;
      build = distribution.build;
    }

  let parse_form ~inferred_package_id_or_reason_whynone ~cst_canonical_id
      (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT) sourcestate
      form_range : ThunkCst.form -> form = function
    | {
        id;
        precommands = { private_; public_ };
        function_;
        outputs =
          {
            output_files : (ThunkLexers.Ranges.range_plus
                           * ThunkCst.output list)
                           option;
          };
      } ->
        let open MlFront_Core in
        let package_id_opt =
          match inferred_package_id_or_reason_whynone with
          | Either.Left package_id -> Some package_id
          | Either.Right _reason -> None
        in
        let form_id =
          Assumptions.values_ast_is_buildnumber_agnostic ();
          parse_module_version ~drop_bn_build_metadata:true ~package_id_opt
            (module ResultObserver)
            sourcestate `DirectDecode id
        in
        let function_ : (compare_free_range * function_) option =
          match function_ with
          | None -> None
          | Some (_range, { args = []; envmods = _ }) -> None
          | Some (range, { args = first :: rest; envmods }) ->
              let first_arg =
                parse_arg
                  (module ResultObserver)
                  sourcestate `DirectDecode first
              in
              let rest_args : ThunkCommand.evalable_term list =
                List.map
                  (fun (arg : ThunkLexers.Ranges.range_plus * string) ->
                    parse_arg
                      (module ResultObserver)
                      sourcestate `DirectDecode arg)
                  rest
              in
              let envmods =
                List.map
                  (fun ((envmodrange, _) as envmod :
                         ThunkLexers.Ranges.range_plus * string) ->
                    let envmod' =
                      parse_envmod
                        (module ResultObserver
                        : ThunkParsers.Results.OBSERVER_RESULT)
                        sourcestate envmod
                    in
                    (ThunkLexers.Ranges.display_range envmodrange, envmod'))
                  envmods
              in
              Some
                ( ThunkLexers.Ranges.display_range range,
                  { args = (first_arg, rest_args); envmods } )
        in
        let output_files : compare_free_range * output * output list =
          match output_files with
          | None ->
              err
              @@ ThunkParsers.Results.single_error ~code:"4a37e0e1"
                   ~msg:"The form does not have the `outputs` field."
                   ~brief_instruction:"Add `outputs` field with an output file."
                   (module ResultObserver)
                   sourcestate form_range
          | Some (range, output_files) ->
          match
            List.map
              (parse_output (module ResultObserver) sourcestate `DirectDecode)
              output_files
          with
          | [] ->
              err
              @@ ThunkParsers.Results.single_error ~code:"158ccc66"
                   ~msg:"The form does not have at least one output file."
                   ~brief_instruction:"Add an output file."
                   (module ResultObserver)
                   sourcestate range
          | first :: rest ->
              (ThunkLexers.Ranges.display_range range, first, rest)
        in
        let form_canonical_id =
          let { id; version } : ThunkCommand.module_version = form_id in
          Digestif.SHA256.to_hex
            (Digestif.SHA256.digest_string
               (cst_canonical_id ^ "|form|"
               ^ StandardModuleId.show_dot id
               ^ "@"
               ^ ThunkSemver64.to_string version))
        in
        {
          form_canonical_id;
          form_id;
          precommands =
            {
              private_ =
                List.map
                  (parse_precommand_instance ~cst_canonical_id
                     (module ResultObserver)
                     sourcestate)
                  private_;
              public_ =
                List.map
                  (parse_precommand_instance ~cst_canonical_id
                     (module ResultObserver)
                     sourcestate)
                  public_;
            };
          function_;
          outputs = { files = output_files };
        }
end

let parse ?downgrade_errors_into_warnings ~origin
    ~(inferred_package_id_or_reason_whynone :
       (MlFront_Core.PackageId.t, string) Either.t)
    (module ResultObserver : ThunkParsers.Results.OBSERVER_RESULT)
    (cst : ThunkCst.t) : (t, string) result =
  let sourcestate =
    match cst with
    | { contents = Some contents; _ } ->
        ThunkParsers.Results.State.create_with_source ?origin
          ?downgrade_errors_into_warnings contents
    | { contents = None; _ } ->
        ThunkParsers.Results.State.create_without_source ?origin
          ?downgrade_errors_into_warnings ()
  in
  let aux : ThunkCst.t -> t = function
    | {
        contents = _;
        schema = _;
        schema_version = _;
        bundles;
        forms;
        distributions;
      } ->
        let canonical_id = ThunkCst.canonical_id cst in
        let bundles =
          List.fold_left
            (fun acc (rangeplus, bundle) ->
              let ( bundle_range,
                    ({ listing_unencrypted = { bundle_id }; _ } as ast_bundle :
                      bundle) ) =
                ( ThunkLexers.Ranges.display_range rangeplus,
                  Parsing.parse_asset
                    (module ResultObserver)
                    sourcestate `DirectDecode bundle )
              in
              BundleTable.add acc bundle_id (bundle_range, ast_bundle))
            (BundleTable.create (List.length bundles))
            bundles
        in
        let assets =
          (* Build the assets index from the bundle files in the assets. *)
          (* a. First collect all the origins. *)
          let tbl_origins = mk_origins_table_from_bundles bundles in
          (* b. Then visit all the bundle files of all the assets. *)
          BundleTable.fold
            (fun acc bundle_id (_assetrange, bundle) ->
              List.fold_left
                (fun acc (asset_range, asset) ->
                  let ({ file_path; file_origin; _ } : asset_file2) = asset in
                  match Hashtbl.find_opt tbl_origins file_origin with
                  | None -> acc
                  | Some origin ->
                      AssetTable.add acc (bundle_id, file_path)
                        (asset_range, asset, origin))
                acc bundle.asset_files)
            (AssetTable.create 16) bundles
        in
        let distributions =
          List.fold_left
            (fun acc (rangeplus, (dist : ThunkDist.t)) ->
              let ( asset_range,
                    ({
                       distribution_id = _range, library_id, library_version;
                       _;
                     } as ast_distribution :
                      distribution) ) =
                ( ThunkLexers.Ranges.display_range rangeplus,
                  Parsing.parse_distribution
                    (module ResultObserver)
                    sourcestate `DirectDecode dist )
              in
              DistributionTable.add acc
                ( MlFront_Core.PackageId.of_library_id library_id,
                  library_version )
                (asset_range, ast_distribution))
            (DistributionTable.create (List.length distributions))
            distributions
        in
        {
          canonical_id;
          bundles;
          assets;
          forms =
            List.fold_left
              (fun acc (rangeplus, cst_form) ->
                let form_range, ({ form_id; _ } as ast_form : form) =
                  ( ThunkLexers.Ranges.display_range rangeplus,
                    Parsing.parse_form ~inferred_package_id_or_reason_whynone
                      ~cst_canonical_id:canonical_id
                      (module ResultObserver)
                      sourcestate rangeplus cst_form )
                in
                FormTable.add acc form_id (form_range, ast_form))
              (FormTable.create (List.length forms))
              forms;
          distributions;
        }
  in
  match aux cst with
  | v -> Ok v
  | exception Parsing.FailedParse msg -> Error msg

let form_slots_exported ~request_slot (form : form) :
    (ThunkCommand.object_slot * Fmlib_parse.Position.range) list =
  let to_thunk_command commands =
    List.map
      (fun { precommand = _range, command; precommand_canonical_id = _ } ->
        command)
      commands
  in
  let command_list_has_slot_request (commands : precommand_instance list) =
    List.exists
      (fun { precommand = _range, command; precommand_canonical_id = _ } ->
        ThunkCommand.has_slot_request command)
      commands
  in
  let function_args_has_slot_request (args : ThunkCommand.evalable_term list) =
    List.exists ThunkCommand.InternalUse.evalable_term_has_slot_request args
  in
  let any_has_slot_request =
    command_list_has_slot_request form.precommands.private_
    || command_list_has_slot_request form.precommands.public_
    ||
    match form.function_ with
    | None -> false
    | Some (_range, { args = first_arg, rest_args; _ }) ->
        function_args_has_slot_request (first_arg :: rest_args)
  in
  (* We use all the output slots if ${SLOT.request} is used
     (or else we wouldn't be able to do request an execution ABI different
      from the host ABI).

     But without ${SLOT.request}, we infer the slots from the private and
     public commands and the function arguments. That will allow good
     errors that there is no way for the commands or function to create
     content for a slot. *)
  if any_has_slot_request then
    (* use all the output slots *)
    let to_slot ((first, rest) : ranged_slot * ranged_slot list) =
      let slots = List.map (fun (r, s) -> (s, r)) (first :: rest) in
      slots
    in
    let get_output_slots (outputs : compare_free_range * output * output list) =
      let _range, first_output, rest_outputs = outputs in
      to_slot first_output.slots
      @ List.flatten (List.map (fun s -> to_slot s.slots) rest_outputs)
    in
    let ret = get_output_slots form.outputs.files in
    (* Printf.eprintf "form_slots_exported for %s: using all output slots %d\n%!"
      (ThunkCommand.show_module_version form.form_id)
      (List.length ret); *)
    ret
  else
    (* use the private and public slots *)
    let private_slots, public_slots =
      let get_command_list_slots (commands : precommand_instance list) =
        List.map
          (ThunkCommand.slots_exported ~request_slot)
          (to_thunk_command commands)
        |> List.flatten
      in
      ( get_command_list_slots form.precommands.private_,
        get_command_list_slots form.precommands.public_ )
    in
    (* and the function args slots *)
    let function_args_slots =
      let get_function_args_slots (args : ThunkCommand.evalable_term list) =
        List.map
          (ThunkCommand.InternalUse.evalable_term_slots ~request_slot)
          args
        |> List.flatten
      in
      match form.function_ with
      | None -> []
      | Some (_range, { args = first_arg, rest_args; _ }) ->
          get_function_args_slots (first_arg :: rest_args)
    in
    (* Printf.eprintf
      "form_slots_exported for %s: private %d, public %d, function %s\n%!"
      (ThunkCommand.show_module_version form.form_id)
      (List.length private_slots)
      (List.length public_slots)
      (String.concat ", "
         (List.map fst function_args_slots
         |> List.map ThunkCommand.object_slot_to_shell)); *)
    private_slots @ public_slots @ function_args_slots

let asset_path
    ({
       file_canonical_id = _;
       file_origin = _;
       file_path;
       file_checksum = _;
       file_sz = _;
     } :
      asset_file2) =
  file_path

let form_output_files_range (form : form) : Fmlib_parse.Position.range =
  match form.outputs.files with range, _, _ -> range

let bundles_range (thunk : t) : Fmlib_parse.Position.range option =
  (* Get first and last bundle, if any *)
  let f acc _asset_id (range, _asset) =
    match acc with
    | None -> Some range
    | Some range' -> Some (Fmlib_parse.Position.merge range' range)
  in
  BundleTable.fold f None thunk.bundles

let zerorangeplus =
  ThunkLexers.Ranges.Raw_range Fmlib_parse.Position.(start, start)

let concrete_range range = ThunkLexers.Ranges.Raw_range range

let concrete_range_fst (range, second) =
  (ThunkLexers.Ranges.Raw_range range, second)

let concrete_bundle : bundle -> ThunkBundle.t =
  let concrete_origin : asset_origin2 -> ThunkBundle.asset_origin2 =
   fun { origin_name; origin_mirrors } -> { origin_name; origin_mirrors }
  in
  let concrete_file : asset_file2 -> ThunkBundle.asset_file2 =
   fun { file_canonical_id = _; file_origin; file_path; file_checksum; file_sz }
     ->
    let checksum_sha256, checksum_sha1 =
      match file_checksum with
      | `Sha256 v -> (Some v, None)
      | `Sha1 v -> (None, Some v)
    in
    {
      file_origin = Some file_origin;
      file_path;
      file_checksum =
        {
          checksum_sha256 = Option.map concrete_range_fst checksum_sha256;
          checksum_sha1 = Option.map concrete_range_fst checksum_sha1;
        };
      file_sz = concrete_range_fst file_sz;
    }
  in
  function
  | {
      bundle_canonical_id = _;
      listing_unencrypted = { bundle_id = { id; version } };
      listing = { origins };
      asset_files;
    } ->
      {
        bundle_id =
          ( None,
            Printf.sprintf "%s@%s"
              (MlFront_Core.StandardModuleId.show_dot id)
              (ThunkSemver64.to_string version) );
        listing = { origins = List.map concrete_origin origins };
        files =
          List.map
            (fun (range, file) -> (concrete_range range, concrete_file file))
            asset_files;
      }

let concrete : t -> ThunkCst.t =
  let concrete_precommand :
      precommand_instance -> ThunkLexers.Ranges.range_plus * string =
   fun { precommand_canonical_id = _; precommand = range, command } ->
    (concrete_range range, ThunkCommand.to_shell command)
  in
  let concrete_envmod (envmod : envmod) : string =
    match envmod with
    | AddEnv { envname; envvalue } ->
        Printf.sprintf "+%s=%s" envname
          (ThunkCommand.evalable_term_to_shell envvalue)
    | RemoveEnv envname -> Printf.sprintf "-%s" envname
    | PrependPathEnv { pathenvname; pathenvvalue } ->
        Printf.sprintf "<%s=%s" pathenvname
          (ThunkCommand.evalable_term_to_shell pathenvvalue)
  in
  let concrete_function :
      compare_free_range * function_ ->
      ThunkLexers.Ranges.range_plus * ThunkCst.function_ =
   fun (range, { args = first_arg, rest_args; envmods }) ->
    ( concrete_range range,
      {
        args =
          List.map
            (fun arg ->
              (zerorangeplus, ThunkCommand.evalable_term_to_shell arg))
            (first_arg :: rest_args);
        envmods =
          List.map
            (fun (envmodrange, envmod) ->
              (concrete_range envmodrange, concrete_envmod envmod))
            envmods;
      } )
  in
  let concrete_output : output -> ThunkCst.output =
   fun { slots = first_slot, rest_slots; paths = first_path, rest_paths } ->
    {
      slots =
        ( zerorangeplus,
          List.map
            (fun (range, slot) ->
              (concrete_range range, ThunkCommand.object_slot_to_shell slot))
            (first_slot :: rest_slots) );
      paths =
        ( zerorangeplus,
          List.map
            (fun (range, path) -> (concrete_range range, path))
            (first_path :: rest_paths) );
    }
  in
  let concrete_form : form -> ThunkCst.form = function
    | {
        form_canonical_id = _;
        form_id = { id; version };
        precommands = { private_; public_ };
        function_;
        outputs = { files = files_range, first_file, rest_files };
      } ->
        {
          id =
            ( None,
              Printf.sprintf "%s@%s"
                (MlFront_Core.StandardModuleId.show_dot id)
                (ThunkSemver64.to_string version) );
          precommands =
            {
              private_ = List.map concrete_precommand private_;
              public_ = List.map concrete_precommand public_;
            };
          function_ = Option.map concrete_function function_;
          outputs =
            {
              output_files =
                Some
                  ( concrete_range files_range,
                    List.map concrete_output (first_file :: rest_files) );
            };
        }
  in
  let concrete_distribution : distribution -> ThunkDist.t =
   fun {
         distribution_canonical_id = _;
         distribution_id = _range, id, version;
         producer;
         license;
         continuations;
         build;
       } ->
    {
      id = (zerorangeplus, id, version);
      producer;
      license;
      continuations;
      build;
    }
  in
  function
  | { canonical_id = _; bundles; assets = _; forms; distributions } ->
      {
        contents = None;
        schema =
          Some
            "https://github.com/diskuv/dk/raw/refs/heads/V2_4/etc/jsonschema/mlfront-values.json";
        schema_version = { smajor = 1; sminor = 0 };
        bundles =
          List.map
            (fun (_asset_id, (range, bundle)) ->
              (concrete_range range, concrete_bundle bundle))
            (BundleTable.to_list bundles);
        forms =
          List.map
            (fun (_form_id, (range, form)) ->
              (concrete_range range, concrete_form form))
            (FormTable.to_list forms);
        distributions =
          List.map
            (fun (_dist_id, (range, distribution)) ->
              (concrete_range range, concrete_distribution distribution))
            (DistributionTable.to_list distributions);
      }

let invalidate_asset_files ~remove
    { canonical_id; bundles; assets; forms; distributions } =
  let new_assets =
    AssetTable.filter
      (fun (_asset_id, _path) (_range, asset, origin) ->
        not (remove origin asset))
      assets
  in
  let modified = AssetTable.length new_assets <> AssetTable.length assets in
  if modified then begin
    let tbl_origins = mk_origins_table_from_bundles bundles in
    let new_bundles =
      BundleTable.fold
        (fun (acc : _ BundleTable.t) bundle_id
             ( bundle_range,
               {
                 bundle_canonical_id;
                 listing_unencrypted;
                 listing;
                 asset_files;
               } ) ->
          let asset_files' =
            List.fold_left
              (fun acc (asset_range, asset) ->
                match Hashtbl.find_opt tbl_origins asset.file_origin with
                | None -> acc
                | Some origin ->
                    if remove origin asset then acc
                    else (asset_range, asset) :: acc)
              [] asset_files
          in
          let new_asset =
            {
              bundle_canonical_id;
              listing_unencrypted;
              listing;
              asset_files = asset_files';
            }
          in
          let cst_of_new_bundle = concrete_bundle new_asset in
          let new_bundle =
            {
              new_asset with
              bundle_canonical_id = ThunkBundle.canonical_id cst_of_new_bundle;
            }
          in
          BundleTable.add acc bundle_id (bundle_range, new_bundle))
        (BundleTable.create (BundleTable.length bundles))
        bundles
    in
    let new_ast =
      {
        canonical_id;
        bundles = new_bundles;
        assets = new_assets;
        forms;
        distributions;
      }
    in
    let cst_of_new_ast = concrete new_ast in
    let new_ast =
      { new_ast with canonical_id = ThunkCst.canonical_id cst_of_new_ast }
    in
    `Modified new_ast
  end
  else `Unmodified

module InternalUse = struct
  let parse_envmod = Parsing.parse_envmod'
end