Source file gas_monad.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2021 Nomadic Labs <contact@nomadic-labs.com>                *)
(* Copyright (c) 2021 Trili Tech, <contact@trili.tech>                       *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

(* The outer option is for gas exhaustion. The inner [result] is for all other
   errors. *)
type ('a, 'trace) t =
  Local_gas_counter.local_gas_counter ->
  (('a, 'trace) result * Local_gas_counter.local_gas_counter) option

type ('a, 'trace) gas_monad = ('a, 'trace) t

let of_result x gas = Some (x, gas) [@@ocaml.inline always]

let return x = of_result (ok x) [@@ocaml.inline always]

let return_unit = return ()

(* Inlined [Option.bind] for performance. *)
let ( >>?? ) m f = match m with None -> None | Some x -> f x
  [@@ocaml.inline always]

let bind m f gas =
  m gas >>?? fun (res, gas) ->
  match res with Ok y -> f y gas | Error _ as err -> of_result err gas
  [@@ocaml.inline always]

let map f m gas = m gas >>?? fun (x, gas) -> of_result (x >|? f) gas
  [@@ocaml.inline always]

let bind_result m f = bind (of_result m) f [@@ocaml.inline always]

let bind_recover m f gas = m gas >>?? fun (x, gas) -> f x gas
  [@@ocaml.inline always]

let consume_gas cost gas =
  match Local_gas_counter.consume_opt gas cost with
  | None -> None
  | Some gas -> Some (ok (), gas)

let run ctxt m =
  let open Local_gas_counter in
  match Gas.level ctxt with
  | Gas.Unaccounted -> (
      match m (Local_gas_counter (Saturation_repr.saturated :> int)) with
      | Some (res, _new_gas_counter) -> ok (res, ctxt)
      | None -> error Gas.Operation_quota_exceeded)
  | Limited {remaining = _} -> (
      let gas_counter, outdated_ctxt =
        local_gas_counter_and_outdated_context ctxt
      in
      match m gas_counter with
      | Some (res, new_gas_counter) ->
          let ctxt = update_context new_gas_counter outdated_ctxt in
          ok (res, ctxt)
      | None -> error Gas.Operation_quota_exceeded)

let record_trace_eval :
    type error_trace error_context.
    error_details:(error_context, error_trace) Script_tc_errors.error_details ->
    (error_context -> error) ->
    ('a, error_trace) t ->
    ('a, error_trace) t =
 fun ~error_details ->
  match error_details with
  | Fast -> fun _f m -> m
  | Informative err_ctxt ->
      fun f m gas ->
        m gas >>?? fun (x, gas) ->
        of_result (record_trace_eval (fun () -> f err_ctxt) x) gas

let fail e = of_result (Error e) [@@ocaml.inline always]

module Syntax = struct
  let return = return

  let return_unit = return_unit

  let return_none = return None

  let return_some x = return (Some x)

  let return_nil = return []

  let return_true = return true

  let return_false = return false

  let fail = fail

  let ( let* ) = bind

  let ( let+ ) m f = map f m

  let ( let*? ) = bind_result
end