Source file BuildTaskScript.ml

module Semver64Map = Map.Make (MlFront_Thunk.ThunkSemver64)
module Value = MlFront_Thunk.ThunkLuaScript.Value

(** [at_func ~modname values] is the response to the Lua function call
    [require(modname).at(version)] *)
let at_func ~modname ~get_modules_by_semver ~on_error :
    MlFront_Thunk.ThunkLuaScript.Value.value list ->
    MlFront_Thunk.ThunkLuaScript.Value.value list =
  let module V = MlFront_Thunk.ThunkLuaScript.Value in
  function
  | [] ->
      on_error
        (Printf.sprintf
           "The `require(%s).at(version)` call must have a \"version\" argument"
           (MlFront_Thunk.ThunkLuaPrint0.literal_string modname))
  | String modver :: _ ->
      let modver_result =
        MlFront_Thunk.ThunkCommand.InternalUse.parse_semver64 modver
      in
      begin
        match modver_result with
        | Error errmsg ->
            on_error
              (Printf.sprintf
                 "The `require(%s).at(version)` call used an invalid version \
                  `%s`:\n\
                  %s"
                 (MlFront_Thunk.ThunkLuaPrint0.literal_string modname)
                 modver errmsg)
        | Ok semver64 -> (
            let modules_by_semver = get_modules_by_semver () in
            let module_opt = Semver64Map.find_opt semver64 modules_by_semver in
            match module_opt with
            | Some module_return_values -> module_return_values
            | None ->
                on_error
                  (Printf.sprintf
                     "The `require(%s).at(%s)` version not found.\n\
                      Use one of the available versions:\n\
                      %s"
                     (MlFront_Thunk.ThunkLuaPrint0.literal_string modname)
                     (MlFront_Thunk.ThunkLuaPrint0.literal_string
                        (MlFront_Thunk.ThunkSemver64.to_string semver64))
                     (MlFront_Thunk.ThunkStrings.left_pad
                        (String.concat "\n"
                           (List.map
                              (fun v -> MlFront_Thunk.ThunkSemver64.to_string v)
                              (Semver64Map.fold
                                 (fun v _ acc -> v :: acc)
                                 modules_by_semver []))))))
      end
  | _ ->
      on_error
        (Printf.sprintf
           "The `require(%s).at(version)` call must have the \"version\" \
            argument be a string"
           (MlFront_Thunk.ThunkLuaPrint0.literal_string modname))

module Make (Ctx : BuildContext.S) = struct
  module BuildValues' = BuildValues.Make (Ctx)
  module BuildPaths' = BuildPaths.Make (Ctx)

  let log_debug msgf = Ctx.run_isolated_promise @@ Ctx.Log.debug msgf
  let log_warn msgf = Ctx.run_isolated_promise @@ Ctx.Log.warn msgf

  let register_script_module_in_lua_package_registry ~lua_package_registry
      ~lua_state ~module_return_values ~scriptmodule_id ~scriptmodule_range
      ~values_file ~modname () =
    let module V = MlFront_Thunk.ThunkLuaScript.Value in
    let module R = MlFront_Thunk.ThunkLuaErrors.Raise (V) in
    (* Register the module in the Lua package registry *)
    let modules_by_semver =
      (* there should only be one *)
      ref Semver64Map.empty
    in

    let modver =
      MlFront_Thunk.ThunkSemver64.to_string
        (scriptmodule_id : MlFront_Thunk.ThunkCommand.module_version).version
    in
    (* if Ctx.verbose ctx then
    Printf.eprintf "[lua]: Registering script module `%s@%s`\n%!" modname modver; *)
    (* if Ctx.verbose ctx then
      Printf.eprintf
        "[lua]: Module return values being given to \
          [ThunkLuaTypPkgReg.add_module]:\n\
          %s\n"
        (String.concat "\n"
            (List.map MlFront_Thunk.ThunkLuaPrint.show_value
              module_return_values)); *)
    MlFront_Thunk.ThunkLuaTypPkgReg.add_module lua_package_registry
      ~name:modname ~version:modver
      ~create_module_table:(fun () ->
        let at : V.value =
          let srcloc =
            let linedefined =
              1 + Fmlib_parse.Position.line (fst scriptmodule_range)
            in
            V.srcloc ~file:(Ctx.Io.file_origin values_file) ~linedefined
          in
          Function
            ( srcloc,
              at_func ~modname
                ~get_modules_by_semver:(fun () -> !modules_by_semver)
                ~on_error:(R.error lua_state) )
        in
        Value.LuaValueBase.Table (Value.Table.of_list [ ("at", at) ]))
      ~add_package_version_to_module_table:(fun
          _module_table ~version package ->
        match MlFront_Thunk.ThunkCommand.InternalUse.parse_semver64 version with
        | Error msg -> R.error lua_state msg
        | Ok version ->
            modules_by_semver :=
              Semver64Map.add version package !modules_by_semver)
      module_return_values

  let eval_and_register_script_module_in_lua_package_registry ctx ~on_success
      ~on_error_scriptmodule ~on_error_linecol ~lua_ast_chunks ~lua_ast_srcmap
      ~scriptmodule_id ~scriptmodule_range ~values_file ~lua_package_registry
      ~lua_state (module I : MlFront_Thunk.ThunkLuaScript.THUNK_INTERP) =
    (* idempotency check *)
    let modname =
      MlFront_Core.StandardModuleId.show_dot
        (scriptmodule_id : MlFront_Thunk.ThunkCommand.module_version).id
    in
    match
      MlFront_Thunk.ThunkLuaTypPkgReg.get_module_if_loaded lua_package_registry
        modname
    with
    | Some _ -> on_success ()
    | None -> (
        let module IoUtils = MlFront_Thunk.ThunkLuaUtils.IoUtils' (I) in
        (* Run the module chunks to get its Lua return value (the module) *)
        if Ctx.verbose ctx then
          log_debug (fun l ->
              l "[lua]: Registering script module `%s`"
                (MlFront_Thunk.ThunkCommand.show_module_version scriptmodule_id));
        let eval_result =
          IoUtils.eval_chunks ~in_what:"in the script task" lua_state
            lua_ast_srcmap lua_ast_chunks
        in
        if Ctx.verbose ctx then (
          (* want Lua print() statements to be ordered in verbose mode, even if slower. *)
          flush stdout;
          flush stderr);
        match eval_result with
        | Error (msg, Some (`LineCol (line, col))) ->
            on_error_linecol ~because:msg ~line ~col ()
        | Error (msg, None) -> on_error_scriptmodule ~because:msg ()
        | Ok module_return_values ->
            (* Register the module in the Lua package registry *)
            register_script_module_in_lua_package_registry ~lua_package_registry
              ~lua_state ~module_return_values ~scriptmodule_id
              ~scriptmodule_range ~values_file ~modname ();
            on_success ())

  let print_lua_warning_linecol ~because ~line ~col file_object =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    let* read_result = Ctx.Io.read_all file_object in
    match read_result with
    | `Error _ | `ExceededSizeLimit _ ->
        log_warn (fun l ->
            l "[warning 11a59293] %a %s"
              (MlFront_Thunk.ThunkRanges.pp_pos_1based_linecol
                 (Some (Ctx.Io.file_origin file_object)))
              (line, col) because);
        return ()
    | `Content script_content ->
        let _range, rendered =
          MlFront_Thunk.ThunkLuaUtils.render_lua_error
            ~downgrade_errors_into_warnings:() ~code:"11a59293" ~line ~col
            ~script_content ~msg:because ()
        in
        log_warn (fun l -> l "[warning] %s" rendered);
        return ()

  let print_lua_warning ~because file_object
      (module ResultObserver
       : MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT) range =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    let* read_result = Ctx.Io.read_all file_object in
    match read_result with
    | `Error _ | `ExceededSizeLimit _ ->
        log_warn (fun l ->
            l "[warning 938ea9b4] %a %s"
              (MlFront_Thunk.ThunkRanges.pp_range
                 (Some (Ctx.Io.file_origin file_object)))
              range because);
        return ()
    | `Content script_content ->
        let state =
          MlFront_Thunk.ThunkResults.State.create_with_source
            ~downgrade_errors_into_warnings:()
            ~origin:(Ctx.Io.file_origin file_object)
            script_content
        in
        let rendered =
          MlFront_Thunk.ThunkResults.single_error ~code:"938ea9b4" ~msg:because
            ~brief_instruction:"Fix the Lua issue or errors may appear later."
            (module ResultObserver)
            state
            (MlFront_Thunk.ThunkRanges.raw_range range)
        in
        log_warn (fun l -> l "[warning] %s" rendered);
        return ()

  let register_scriptmodule ctx ~kont_state ~scriptmodule_values_canonical_id
      ~scriptmodule_values_file_sha256 ~scriptmodule_id ~scriptmodule_range
      ~scriptmodule_file () =
    let ( let* ), return = Ctx.Promise.(bind, return) in
    let lua_interpreter, lua_package_registry, lua_state =
      Ctx.State.
        ( lua_interpreter kont_state,
          lua_package_registry kont_state,
          lua_state kont_state )
    in
    let module I = (val lua_interpreter) in
    let build_request = BuildRequest.ValidationInitiated in
    let* build_values_opt =
      BuildValues'.get_values_gracefully ctx
        ~validation_resolved_as_filepath:
          (BuildPaths'.resolved_as_filepath_for_build_request ?platform:None
             ~build_request)
        ~values_file_sha256:scriptmodule_values_file_sha256
        ~values_file_type:`Lua
        ~values_canonical_id:scriptmodule_values_canonical_id
        ~k_show:(fun () ->
          MlFront_Thunk.ThunkCommand.show_module_version scriptmodule_id)
        ~v_show:(fun () -> Ctx.Io.file_origin scriptmodule_file)
        kont_state
    in
    match build_values_opt with
    | None ->
        log_warn (fun l ->
            l "[warning] could not get compiled chunk %s in cache"
              (Ctx.V.get_values_cache_id
                 ~values_canonical_id:scriptmodule_values_canonical_id));
        return ()
    | Some { values; safe_maybe_local_values_file; values_file_local = _ } ->
      begin
        match MlFront_Thunk.ThunkAst.get_script values with
        | None ->
            log_warn (fun l ->
                l "[warning] chunk is not a script module: %s"
                  (Ctx.Io.file_origin scriptmodule_file));
            return ()
        | Some
            {
              script_ast =
                _script_range, LuaAst { lua_ast_chunks; lua_ast_srcmap };
            } ->
            (* evaluate and register in Lua package registry *)
            let* () =
              eval_and_register_script_module_in_lua_package_registry ctx
                ~on_success:(fun () -> return ())
                ~on_error_linecol:(fun ~because ~line ~col () ->
                  print_lua_warning_linecol ~because ~line ~col
                    safe_maybe_local_values_file)
                ~on_error_scriptmodule:(fun ~because () ->
                  print_lua_warning ~because safe_maybe_local_values_file
                    (Ctx.observer_result ctx) scriptmodule_range)
                ~lua_ast_chunks ~lua_ast_srcmap ~scriptmodule_id
                ~scriptmodule_range ~values_file:scriptmodule_file
                ~lua_package_registry ~lua_state
                (module I)
            in
            (* maintain association of rules to values files *)
            let rules =
              let f
                  ({
                     chunk_canonical_id = _;
                     chunk_modver;
                     chunk_range;
                     chunk_type;
                   } :
                    MlFront_Thunk.ThunkAst.chunk) acc =
                match chunk_type with
                | `Module -> acc
                | (`UiRule | `FreeRule) as rule_type ->
                    `RuleAssociation
                      ( rule_type,
                        chunk_modver,
                        chunk_range,
                        scriptmodule_values_file_sha256 )
                    :: acc
              in
              MlFront_Thunk.ThunkAst.fold_chunks ~f ~init:[] values
            in
            List.iter
              (fun (`RuleAssociation
                      (rule_type, rule_id, rule_range, values_file_sha256)) ->
                Ctx.State.assign_rule_to_values_file ~rule_id ~rule_type
                  ~rule_range ~values_file_sha256 kont_state)
              rules;
            (* done *)
            return ()
      end
end