{-# LANGUAGE UndecidableInstances #-}

-- | This modules provides a specification for our blockchain monads, in three
-- layers:
--
-- 1. MonadBlockChainBalancing provides what's needing for balancing purposes
--
-- 2. MonadBlockChainWithoutValidation adds up remaining primitives without
-- transaction validation
--
-- 3. MonadBlockChain concludes with the addition of transaction validation,
-- thus modifying the internal index of outputs
--
-- In addition, you will find here many helpers functions which can be derived
-- from the core definition of our blockchain.
module Cooked.MockChain.BlockChain
  ( MockChainError (..),
    MockChainLogEntry (..),
    MonadBlockChainBalancing (..),
    MonadBlockChainWithoutValidation (..),
    MonadBlockChain (..),
    AsTrans (..),
    currentMSRange,
    utxosFromCardanoTx,
    unsafeTxOutByRef,
    typedDatumFromTxOutRef,
    valueFromTxOutRef,
    outputDatumFromTxOutRef,
    datumFromTxOutRef,
    currentSlot,
    awaitSlot,
    getEnclosingSlot,
    awaitEnclosingSlot,
    waitNMSFromSlotLowerBound,
    waitNMSFromSlotUpperBound,
    slotRangeBefore,
    slotRangeAfter,
    slotToMSRange,
    txSkelInputValidators,
    txSkelInputValue,
    lookupUtxos,
    validateTxSkel',
    validateTxSkel_,
    txSkelProposalsDeposit,
    govActionDeposit,
    defineM,
    unsafeOutputDatumFromTxOutRef,
    unsafeDatumFromTxOutRef,
    unsafeTypedDatumFromTxOutRef,
    unsafeValueFromTxOutRef,
    txSkelAllScripts,
  )
where

import Cardano.Api.Ledger qualified as Cardano
import Cardano.Ledger.Conway.PParams qualified as Conway
import Cardano.Node.Emulator qualified as Emulator
import Cardano.Node.Emulator.Internal.Node qualified as Emulator
import Control.Lens qualified as Lens
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Control
import Control.Monad.Writer
import Cooked.Pretty.Hashable
import Cooked.Pretty.Plutus ()
import Cooked.Skeleton
import Cooked.Wallet
import Data.Kind
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe
import Data.Set (Set)
import Ledger.Index qualified as Ledger
import Ledger.Slot qualified as Ledger
import Ledger.Tx qualified as Ledger
import Ledger.Tx.CardanoAPI qualified as Ledger
import ListT
import Optics.Core
import Plutus.Script.Utils.Address qualified as Script
import Plutus.Script.Utils.Data qualified as Script
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api

-- * Mockchain errors

-- | Errors that can be produced by the blockchain
data MockChainError
  = -- | Validation errors, either in Phase 1 or Phase 2
    MCEValidationError Ledger.ValidationPhase Ledger.ValidationError
  | -- | The balancing wallet does not have enough funds
    MCEUnbalanceable Wallet Api.Value
  | -- | The balancing wallet is required but missing
    MCEMissingBalancingWallet String
  | -- | No suitable collateral could be associated with a skeleton
    MCENoSuitableCollateral Integer Integer Api.Value
  | -- | Translating a skeleton element to its Cardano counterpart failed
    MCEToCardanoError String Ledger.ToCardanoError
  | -- | The required reference script is missing from a witness utxo
    MCEWrongReferenceScriptError Api.TxOutRef Api.ScriptHash (Maybe Api.ScriptHash)
  | -- | A UTxO is missing from the mockchain state
    MCEUnknownOutRef Api.TxOutRef
  | -- | A jump in time would result in a past slot
    MCEPastSlot Ledger.Slot Ledger.Slot
  | -- | An attempt to invoke an unsupported feature has been made
    MCEUnsupportedFeature String
  | -- | Used to provide 'MonadFail' instances.
    FailWith String
  deriving (Int -> MockChainError -> ShowS
[MockChainError] -> ShowS
MockChainError -> String
(Int -> MockChainError -> ShowS)
-> (MockChainError -> String)
-> ([MockChainError] -> ShowS)
-> Show MockChainError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MockChainError -> ShowS
showsPrec :: Int -> MockChainError -> ShowS
$cshow :: MockChainError -> String
show :: MockChainError -> String
$cshowList :: [MockChainError] -> ShowS
showList :: [MockChainError] -> ShowS
Show, MockChainError -> MockChainError -> Bool
(MockChainError -> MockChainError -> Bool)
-> (MockChainError -> MockChainError -> Bool) -> Eq MockChainError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MockChainError -> MockChainError -> Bool
== :: MockChainError -> MockChainError -> Bool
$c/= :: MockChainError -> MockChainError -> Bool
/= :: MockChainError -> MockChainError -> Bool
Eq)

-- * Mockchain logs

-- | This represents the specific events that should be logged when processing
-- transactions. If a new kind of event arises, then a new constructor should be
-- provided here.
data MockChainLogEntry
  = -- | Logging a Skeleton as it is submitted by the user.
    MCLogSubmittedTxSkel TxSkel
  | -- | Logging a Skeleton as it has been adjusted by the balancing mechanism,
    -- alongside fee, and possible collateral utxos and return collateral wallet.
    MCLogAdjustedTxSkel TxSkel Integer (Maybe (Set Api.TxOutRef, Wallet))
  | -- | Logging the successful validation of a new transaction, with its id and
    -- number of produced outputs.
    MCLogNewTx Api.TxId Integer
  | -- | Logging the fact that utxos provided by the user for balancing have to be
    -- discarded for a specific reason.
    MCLogDiscardedUtxos Integer String
  | -- | Logging the fact that utxos provided as collaterals will not be used
    -- because the transaction does not involve scripts. There are 2 cases,
    -- depending on whether the user has provided an explicit wallet or a set of
    -- utxos to be used as collaterals.
    MCLogUnusedCollaterals (Either Wallet (Set Api.TxOutRef))
  | -- | Logging the automatic addition of a reference script
    MCLogAddedReferenceScript TxSkelRedeemer Api.TxOutRef Script.ScriptHash
  | -- | Logging the automatic adjusment of a min ada amount
    MCLogAdjustedTxSkelOut TxSkelOut Api.Lovelace
  deriving (Int -> MockChainLogEntry -> ShowS
[MockChainLogEntry] -> ShowS
MockChainLogEntry -> String
(Int -> MockChainLogEntry -> ShowS)
-> (MockChainLogEntry -> String)
-> ([MockChainLogEntry] -> ShowS)
-> Show MockChainLogEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MockChainLogEntry -> ShowS
showsPrec :: Int -> MockChainLogEntry -> ShowS
$cshow :: MockChainLogEntry -> String
show :: MockChainLogEntry -> String
$cshowList :: [MockChainLogEntry] -> ShowS
showList :: [MockChainLogEntry] -> ShowS
Show)

-- * Mockchain layers

-- | This is the first layer of our blockchain, which provides the minimal
-- subset of primitives required to perform balancing.
class (MonadFail m, MonadError MockChainError m) => MonadBlockChainBalancing m where
  -- | Returns the emulator parameters, including protocol parameters
  getParams :: m Emulator.Params

  -- | Returns a list of all UTxOs at a certain address.
  utxosAt :: (Script.ToAddress a) => a -> m [(Api.TxOutRef, TxSkelOut)]

  -- | Returns an output given a reference to it
  txOutByRef :: Api.TxOutRef -> m (Maybe TxSkelOut)

  -- | Logs an event that occured during a BlockChain run
  logEvent :: MockChainLogEntry -> m ()

-- | This is the second layer of our blockchain, which provides all the other
-- blockchain primitives not needed for balancing, except transaction
-- validation. This layers is the one where
-- 'Cooked.MockChain.Tweak.Common.Tweak's are plugged to.
class (MonadBlockChainBalancing m) => MonadBlockChainWithoutValidation m where
  -- | Returns a list of all currently known outputs.
  allUtxos :: m [(Api.TxOutRef, TxSkelOut)]

  -- | Updates parameters
  setParams :: Emulator.Params -> m ()

  -- | Wait a certain amount of slot. Throws 'MCEPastSlot' if the input integer
  -- is negative. Returns the slot after jumping in time.
  waitNSlots :: (Integral i) => i -> m Ledger.Slot

  -- | Binds a hashable quantity of type @a@ to a variable in the mockchain,
  -- while registering its alias for printing purposes.
  define :: (ToHash a) => String -> a -> m a

  -- | Sets the current script to act as the official constitution script
  setConstitutionScript :: (Script.ToVersioned Script.Script s) => s -> m ()

  -- | Gets the current official constitution script
  getConstitutionScript :: m (Maybe (Script.Versioned Script.Script))

  -- | Registers a staking credential with a given reward and deposit
  registerStakingCred :: (Script.ToCredential c) => c -> Integer -> Integer -> m ()

-- | The final layer of our blockchain, adding transaction validation to the
-- mix. This is the only primitive that actually modifies the ledger state.
class (MonadBlockChainWithoutValidation m) => MonadBlockChain m where
  -- | Generates, balances and validates a transaction from a skeleton. It
  -- returns the validated transaction and updates the state of the
  -- blockchain.
  validateTxSkel :: TxSkel -> m Ledger.CardanoTx

-- * Mockchain helpers

-- | Same as 'txOutByRef' but throws an error in case of missing utxo. Use this
-- when you know the utxo is present, or when you want an error to be throw when
-- it's not.
unsafeTxOutByRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m TxSkelOut
unsafeTxOutByRef :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
unsafeTxOutByRef TxOutRef
oRef = m TxSkelOut
-> (TxSkelOut -> m TxSkelOut) -> Maybe TxSkelOut -> m TxSkelOut
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MockChainError -> m TxSkelOut
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TxOutRef -> MockChainError
MCEUnknownOutRef TxOutRef
oRef)) TxSkelOut -> m TxSkelOut
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe TxSkelOut -> m TxSkelOut)
-> m (Maybe TxSkelOut) -> m TxSkelOut
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TxOutRef -> m (Maybe TxSkelOut)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxSkelOut)
txOutByRef TxOutRef
oRef

-- | Validates a skeleton, and retuns the ordered list of produced output
-- references
validateTxSkel' :: (MonadBlockChain m) => TxSkel -> m [Api.TxOutRef]
validateTxSkel' :: forall (m :: * -> *). MonadBlockChain m => TxSkel -> m [TxOutRef]
validateTxSkel' = ((((TxOutRef, TxSkelOut) -> TxOutRef)
-> [(TxOutRef, TxSkelOut)] -> [TxOutRef]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TxOutRef, TxSkelOut) -> TxOutRef
forall a b. (a, b) -> a
fst ([(TxOutRef, TxSkelOut)] -> [TxOutRef])
-> m [(TxOutRef, TxSkelOut)] -> m [TxOutRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m [(TxOutRef, TxSkelOut)] -> m [TxOutRef])
-> (CardanoTx -> m [(TxOutRef, TxSkelOut)])
-> CardanoTx
-> m [TxOutRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoTx -> m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *).
MonadBlockChainBalancing m =>
CardanoTx -> m [(TxOutRef, TxSkelOut)]
utxosFromCardanoTx) (CardanoTx -> m [TxOutRef])
-> (TxSkel -> m CardanoTx) -> TxSkel -> m [TxOutRef]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< TxSkel -> m CardanoTx
forall (m :: * -> *). MonadBlockChain m => TxSkel -> m CardanoTx
validateTxSkel

-- | Validates a skeleton, and erases the outputs
validateTxSkel_ :: (MonadBlockChain m) => TxSkel -> m ()
validateTxSkel_ :: forall (m :: * -> *). MonadBlockChain m => TxSkel -> m ()
validateTxSkel_ = m CardanoTx -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m CardanoTx -> m ()) -> (TxSkel -> m CardanoTx) -> TxSkel -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkel -> m CardanoTx
forall (m :: * -> *). MonadBlockChain m => TxSkel -> m CardanoTx
validateTxSkel

-- | Retrieves the ordered list of outputs of the given "CardanoTx".
--
-- This is useful when writing endpoints and/or traces to fetch utxos of
-- interest right from the start and avoid querying the chain for them
-- afterwards using 'allUtxos' or similar functions.
utxosFromCardanoTx :: (MonadBlockChainBalancing m) => Ledger.CardanoTx -> m [(Api.TxOutRef, TxSkelOut)]
utxosFromCardanoTx :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
CardanoTx -> m [(TxOutRef, TxSkelOut)]
utxosFromCardanoTx =
  ((TxOut, TxIn) -> m (TxOutRef, TxSkelOut))
-> [(TxOut, TxIn)] -> m [(TxOutRef, TxSkelOut)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
    ( \(TxOut
_, TxIn
txIn) ->
        let txOutRef :: TxOutRef
txOutRef = TxIn -> TxOutRef
Ledger.fromCardanoTxIn TxIn
txIn
         in (TxOutRef
txOutRef,) (TxSkelOut -> (TxOutRef, TxSkelOut))
-> m TxSkelOut -> m (TxOutRef, TxSkelOut)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxOutRef -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
unsafeTxOutByRef TxOutRef
txOutRef
    )
    ([(TxOut, TxIn)] -> m [(TxOutRef, TxSkelOut)])
-> (CardanoTx -> [(TxOut, TxIn)])
-> CardanoTx
-> m [(TxOutRef, TxSkelOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoTx -> [(TxOut, TxIn)]
Ledger.getCardanoTxOutRefs

-- | Like 'define', but binds the result of a monadic computation instead
defineM :: (MonadBlockChainWithoutValidation m, ToHash a) => String -> m a -> m a
defineM :: forall (m :: * -> *) a.
(MonadBlockChainWithoutValidation m, ToHash a) =>
String -> m a -> m a
defineM String
name = (String -> a -> m a
forall a. ToHash a => String -> a -> m a
forall (m :: * -> *) a.
(MonadBlockChainWithoutValidation m, ToHash a) =>
String -> a -> m a
define String
name (a -> m a) -> m a -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)

-- | Extracts a potential 'TxSkelOutDatum' from a given 'Api.TxOutRef'
datumFromTxOutRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m (Maybe TxSkelOutDatum)
datumFromTxOutRef :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxSkelOutDatum)
datumFromTxOutRef = ((Optic' A_Lens NoIx TxSkelOut TxSkelOutDatum
-> TxSkelOut -> TxSkelOutDatum
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TxSkelOut TxSkelOutDatum
txSkelOutDatumL (TxSkelOut -> TxSkelOutDatum)
-> Maybe TxSkelOut -> Maybe TxSkelOutDatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe TxSkelOut -> Maybe TxSkelOutDatum)
-> m (Maybe TxSkelOut) -> m (Maybe TxSkelOutDatum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m (Maybe TxSkelOut) -> m (Maybe TxSkelOutDatum))
-> (TxOutRef -> m (Maybe TxSkelOut))
-> TxOutRef
-> m (Maybe TxSkelOutDatum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m (Maybe TxSkelOut)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxSkelOut)
txOutByRef

-- | Same as 'datumFromTxOutRef' but throws an error when the utxo is missing
unsafeDatumFromTxOutRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m TxSkelOutDatum
unsafeDatumFromTxOutRef :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOutDatum
unsafeDatumFromTxOutRef = (Optic' A_Lens NoIx TxSkelOut TxSkelOutDatum
-> TxSkelOut -> TxSkelOutDatum
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TxSkelOut TxSkelOutDatum
txSkelOutDatumL (TxSkelOut -> TxSkelOutDatum) -> m TxSkelOut -> m TxSkelOutDatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m TxSkelOut -> m TxSkelOutDatum)
-> (TxOutRef -> m TxSkelOut) -> TxOutRef -> m TxSkelOutDatum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
unsafeTxOutByRef

-- | Extracts a potential 'Api.OutputDatum' from a given 'Api.TxOutRef'
outputDatumFromTxOutRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m (Maybe Api.OutputDatum)
outputDatumFromTxOutRef :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe OutputDatum)
outputDatumFromTxOutRef = ((TxSkelOutDatum -> OutputDatum)
-> Maybe TxSkelOutDatum -> Maybe OutputDatum
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxSkelOutDatum -> OutputDatum
forall a. ToOutputDatum a => a -> OutputDatum
Script.toOutputDatum (Maybe TxSkelOutDatum -> Maybe OutputDatum)
-> m (Maybe TxSkelOutDatum) -> m (Maybe OutputDatum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m (Maybe TxSkelOutDatum) -> m (Maybe OutputDatum))
-> (TxOutRef -> m (Maybe TxSkelOutDatum))
-> TxOutRef
-> m (Maybe OutputDatum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m (Maybe TxSkelOutDatum)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxSkelOutDatum)
datumFromTxOutRef

-- | Same as 'outputDatumFromTxOutRef' but throws an error when the utxo is
-- missing
unsafeOutputDatumFromTxOutRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m Api.OutputDatum
unsafeOutputDatumFromTxOutRef :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m OutputDatum
unsafeOutputDatumFromTxOutRef = (TxSkelOutDatum -> OutputDatum)
-> m TxSkelOutDatum -> m OutputDatum
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxSkelOutDatum -> OutputDatum
forall a. ToOutputDatum a => a -> OutputDatum
Script.toOutputDatum (m TxSkelOutDatum -> m OutputDatum)
-> (TxOutRef -> m TxSkelOutDatum) -> TxOutRef -> m OutputDatum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m TxSkelOutDatum
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOutDatum
unsafeDatumFromTxOutRef

-- | Like 'datumFromTxOutRef', but uses 'Api.fromBuiltinData' to attempt to
-- deserialize this datum into a given type
typedDatumFromTxOutRef :: (DatumConstrs a, MonadBlockChainBalancing m) => Api.TxOutRef -> m (Maybe a)
typedDatumFromTxOutRef :: forall a (m :: * -> *).
(DatumConstrs a, MonadBlockChainBalancing m) =>
TxOutRef -> m (Maybe a)
typedDatumFromTxOutRef = ((Maybe TxSkelOutDatum -> (TxSkelOutDatum -> Maybe a) -> Maybe a
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Optic' An_AffineTraversal NoIx TxSkelOutDatum a
-> TxSkelOutDatum -> Maybe a
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' An_AffineTraversal NoIx TxSkelOutDatum a
forall a. DatumConstrs a => AffineTraversal' TxSkelOutDatum a
txSkelOutTypedDatumAT) (Maybe TxSkelOutDatum -> Maybe a)
-> m (Maybe TxSkelOutDatum) -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m (Maybe TxSkelOutDatum) -> m (Maybe a))
-> (TxOutRef -> m (Maybe TxSkelOutDatum))
-> TxOutRef
-> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m (Maybe TxSkelOutDatum)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxSkelOutDatum)
datumFromTxOutRef

-- | Like 'typedDatumFromTxOutRef' but throws an error when the utxo is missing
unsafeTypedDatumFromTxOutRef :: (DatumConstrs a, MonadBlockChainBalancing m) => Api.TxOutRef -> m (Maybe a)
unsafeTypedDatumFromTxOutRef :: forall a (m :: * -> *).
(DatumConstrs a, MonadBlockChainBalancing m) =>
TxOutRef -> m (Maybe a)
unsafeTypedDatumFromTxOutRef = (Optic' An_AffineTraversal NoIx TxSkelOutDatum a
-> TxSkelOutDatum -> Maybe a
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' An_AffineTraversal NoIx TxSkelOutDatum a
forall a. DatumConstrs a => AffineTraversal' TxSkelOutDatum a
txSkelOutTypedDatumAT (TxSkelOutDatum -> Maybe a) -> m TxSkelOutDatum -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m TxSkelOutDatum -> m (Maybe a))
-> (TxOutRef -> m TxSkelOutDatum) -> TxOutRef -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m TxSkelOutDatum
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOutDatum
unsafeDatumFromTxOutRef

-- | Resolves an 'Api.TxOutRef' and extracts the value it contains
valueFromTxOutRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m (Maybe Api.Value)
valueFromTxOutRef :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe Value)
valueFromTxOutRef = ((TxSkelOut -> Value
txSkelOutValue (TxSkelOut -> Value) -> Maybe TxSkelOut -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe TxSkelOut -> Maybe Value)
-> m (Maybe TxSkelOut) -> m (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m (Maybe TxSkelOut) -> m (Maybe Value))
-> (TxOutRef -> m (Maybe TxSkelOut)) -> TxOutRef -> m (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m (Maybe TxSkelOut)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxSkelOut)
txOutByRef

-- | Same as 'valueFromTxOutRef' but throws an error when the utxo is missing
unsafeValueFromTxOutRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m Api.Value
unsafeValueFromTxOutRef :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m Value
unsafeValueFromTxOutRef = (TxSkelOut -> Value
txSkelOutValue (TxSkelOut -> Value) -> m TxSkelOut -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m TxSkelOut -> m Value)
-> (TxOutRef -> m TxSkelOut) -> TxOutRef -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
unsafeTxOutByRef

-- | Retrieves the required deposit amount for issuing governance actions.
govActionDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace
govActionDeposit :: forall (m :: * -> *). MonadBlockChainBalancing m => m Lovelace
govActionDeposit = Integer -> Lovelace
Api.Lovelace (Integer -> Lovelace) -> (Params -> Integer) -> Params -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
Cardano.unCoin (Coin -> Integer) -> (Params -> Coin) -> Params -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Coin (PParams EmulatorEra) Coin
-> PParams EmulatorEra -> Coin
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
Lens.view Getting Coin (PParams EmulatorEra) Coin
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams EmulatorEra) Coin
Conway.ppGovActionDepositL (PParams EmulatorEra -> Coin)
-> (Params -> PParams EmulatorEra) -> Params -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> PParams EmulatorEra
Emulator.emulatorPParams (Params -> Lovelace) -> m Params -> m Lovelace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams

-- | Retrieves the total amount of lovelace deposited in proposals in this
-- skeleton (equal to `govActionDeposit` times the number of proposals).
txSkelProposalsDeposit :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Lovelace
txSkelProposalsDeposit :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m Lovelace
txSkelProposalsDeposit TxSkel {[Wallet]
[TxSkelProposal]
[TxSkelOut]
Set TxOutRef
Set TxLabel
TxSkelWithdrawals
Map TxOutRef TxSkelRedeemer
TxSkelMints
SlotRange
TxOpts
txSkelLabel :: Set TxLabel
txSkelOpts :: TxOpts
txSkelMints :: TxSkelMints
txSkelSigners :: [Wallet]
txSkelValidityRange :: SlotRange
txSkelIns :: Map TxOutRef TxSkelRedeemer
txSkelInsReference :: Set TxOutRef
txSkelOuts :: [TxSkelOut]
txSkelProposals :: [TxSkelProposal]
txSkelWithdrawals :: TxSkelWithdrawals
txSkelLabel :: TxSkel -> Set TxLabel
txSkelOpts :: TxSkel -> TxOpts
txSkelMints :: TxSkel -> TxSkelMints
txSkelSigners :: TxSkel -> [Wallet]
txSkelValidityRange :: TxSkel -> SlotRange
txSkelIns :: TxSkel -> Map TxOutRef TxSkelRedeemer
txSkelInsReference :: TxSkel -> Set TxOutRef
txSkelOuts :: TxSkel -> [TxSkelOut]
txSkelProposals :: TxSkel -> [TxSkelProposal]
txSkelWithdrawals :: TxSkel -> TxSkelWithdrawals
..} = Integer -> Lovelace
Api.Lovelace (Integer -> Lovelace)
-> (Lovelace -> Integer) -> Lovelace -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Integer
forall a. Integral a => a -> Integer
toInteger ([TxSkelProposal] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxSkelProposal]
txSkelProposals) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*) (Integer -> Integer)
-> (Lovelace -> Integer) -> Lovelace -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lovelace -> Integer
Api.getLovelace (Lovelace -> Lovelace) -> m Lovelace -> m Lovelace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Lovelace
forall (m :: * -> *). MonadBlockChainBalancing m => m Lovelace
govActionDeposit

-- | Returns all validators which guard transaction inputs
txSkelInputValidators :: (MonadBlockChainBalancing m) => TxSkel -> m [Script.Versioned Script.Validator]
txSkelInputValidators :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m [Versioned Validator]
txSkelInputValidators = ([TxSkelOut] -> [Versioned Validator])
-> m [TxSkelOut] -> m [Versioned Validator]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TxSkelOut -> Maybe (Versioned Validator))
-> [TxSkelOut] -> [Versioned Validator]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxSkelOut -> Maybe (Versioned Validator)
txSkelOutValidator) (m [TxSkelOut] -> m [Versioned Validator])
-> (TxSkel -> m [TxSkelOut]) -> TxSkel -> m [Versioned Validator]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef -> m TxSkelOut) -> [TxOutRef] -> m [TxSkelOut]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TxOutRef -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
unsafeTxOutByRef ([TxOutRef] -> m [TxSkelOut])
-> (TxSkel -> [TxOutRef]) -> TxSkel -> m [TxSkelOut]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxOutRef TxSkelRedeemer -> [TxOutRef]
forall k a. Map k a -> [k]
Map.keys (Map TxOutRef TxSkelRedeemer -> [TxOutRef])
-> (TxSkel -> Map TxOutRef TxSkelRedeemer) -> TxSkel -> [TxOutRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkel -> Map TxOutRef TxSkelRedeemer
txSkelIns

-- | Returns all scripts involved in this 'TxSkel'
txSkelAllScripts :: (MonadBlockChainBalancing m) => TxSkel -> m [Script.Versioned Script.Script]
txSkelAllScripts :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m [Versioned Script]
txSkelAllScripts TxSkel
txSkel = do
  [Versioned Script]
txSkelSpendingScripts <- (Versioned Validator -> Versioned Script)
-> [Versioned Validator] -> [Versioned Script]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Versioned Validator -> Versioned Script
forall s a. ToVersioned s a => a -> Versioned s
Script.toVersioned ([Versioned Validator] -> [Versioned Script])
-> m [Versioned Validator] -> m [Versioned Script]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkel -> m [Versioned Validator]
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m [Versioned Validator]
txSkelInputValidators TxSkel
txSkel
  [Versioned Script] -> m [Versioned Script]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkel -> [Versioned Script]
txSkelMintingScripts TxSkel
txSkel [Versioned Script] -> [Versioned Script] -> [Versioned Script]
forall a. Semigroup a => a -> a -> a
<> TxSkel -> [Versioned Script]
txSkelWithdrawingScripts TxSkel
txSkel [Versioned Script] -> [Versioned Script] -> [Versioned Script]
forall a. Semigroup a => a -> a -> a
<> TxSkel -> [Versioned Script]
txSkelProposingScripts TxSkel
txSkel [Versioned Script] -> [Versioned Script] -> [Versioned Script]
forall a. Semigroup a => a -> a -> a
<> [Versioned Script]
txSkelSpendingScripts)

-- | Go through all of the 'Api.TxOutRef's in the list and look them up in the
-- state of the blockchain, throwing an error if one of them cannot be resolved.
lookupUtxos :: (MonadBlockChainBalancing m) => [Api.TxOutRef] -> m (Map Api.TxOutRef TxSkelOut)
lookupUtxos :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
[TxOutRef] -> m (Map TxOutRef TxSkelOut)
lookupUtxos = (Map TxOutRef TxSkelOut -> TxOutRef -> m (Map TxOutRef TxSkelOut))
-> Map TxOutRef TxSkelOut
-> [TxOutRef]
-> m (Map TxOutRef TxSkelOut)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Map TxOutRef TxSkelOut
m TxOutRef
oRef -> (TxSkelOut -> Map TxOutRef TxSkelOut -> Map TxOutRef TxSkelOut)
-> Map TxOutRef TxSkelOut -> TxSkelOut -> Map TxOutRef TxSkelOut
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TxOutRef
-> TxSkelOut -> Map TxOutRef TxSkelOut -> Map TxOutRef TxSkelOut
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TxOutRef
oRef) Map TxOutRef TxSkelOut
m (TxSkelOut -> Map TxOutRef TxSkelOut)
-> m TxSkelOut -> m (Map TxOutRef TxSkelOut)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxOutRef -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
unsafeTxOutByRef TxOutRef
oRef) Map TxOutRef TxSkelOut
forall k a. Map k a
Map.empty

-- | look up the UTxOs the transaction consumes, and sum their values.
txSkelInputValue :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Value
txSkelInputValue :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m Value
txSkelInputValue = ([Value] -> Value) -> m [Value] -> m Value
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat (m [Value] -> m Value)
-> (TxSkel -> m [Value]) -> TxSkel -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef -> m Value) -> [TxOutRef] -> m [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TxOutRef -> m Value
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m Value
unsafeValueFromTxOutRef ([TxOutRef] -> m [Value])
-> (TxSkel -> [TxOutRef]) -> TxSkel -> m [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxOutRef TxSkelRedeemer -> [TxOutRef]
forall k a. Map k a -> [k]
Map.keys (Map TxOutRef TxSkelRedeemer -> [TxOutRef])
-> (TxSkel -> Map TxOutRef TxSkelRedeemer) -> TxSkel -> [TxOutRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkel -> Map TxOutRef TxSkelRedeemer
txSkelIns

-- * Slot and Time Management

-- $slotandtime
-- #slotandtime#
--
-- Slots are integers that monotonically increase and model the passage of
-- time. By looking at the current slot, a validator gets to know that it is
-- being executed within a certain window of wall-clock time. Things can get
-- annoying pretty fast when trying to mock traces and trying to exercise
-- certain branches of certain validators; make sure you also read the docs on
-- 'autoSlotIncrease' to be able to simulate sending transactions in parallel.

-- | Returns the current slot number
currentSlot :: (MonadBlockChainWithoutValidation m) => m Ledger.Slot
currentSlot :: forall (m :: * -> *). MonadBlockChainWithoutValidation m => m Slot
currentSlot = forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m Slot
waitNSlots @_ @Int Int
0

-- | Wait for a certain slot, or throws an error if the slot is already past
awaitSlot :: (MonadBlockChainWithoutValidation m, Integral i) => i -> m Ledger.Slot
awaitSlot :: forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m Slot
awaitSlot i
slot = m Slot
forall (m :: * -> *). MonadBlockChainWithoutValidation m => m Slot
currentSlot m Slot -> (Slot -> m Slot) -> m Slot
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= i -> m Slot
forall i. Integral i => i -> m Slot
forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m Slot
waitNSlots (i -> m Slot) -> (Slot -> i) -> Slot -> m Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i
slot i -> i -> i
forall a. Num a => a -> a -> a
-) (i -> i) -> (Slot -> i) -> Slot -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slot -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Returns the closed ms interval corresponding to the current slot
currentMSRange :: (MonadBlockChainWithoutValidation m) => m (Api.POSIXTime, Api.POSIXTime)
currentMSRange :: forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m (POSIXTime, POSIXTime)
currentMSRange = Slot -> m (POSIXTime, POSIXTime)
forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m (POSIXTime, POSIXTime)
slotToMSRange (Slot -> m (POSIXTime, POSIXTime))
-> m Slot -> m (POSIXTime, POSIXTime)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Slot
forall (m :: * -> *). MonadBlockChainWithoutValidation m => m Slot
currentSlot

-- | Returns the closed ms interval corresponding to the slot with the given
-- number. It holds that
--
-- > slotToMSRange (getEnclosingSlot t) == (a, b)    ==>   a <= t <= b
--
-- and
--
-- > slotToMSRange n == (a, b)   ==>   getEnclosingSlot a == n && getEnclosingSlot b == n
--
-- and
--
-- > slotToMSRange n == (a, b)   ==>   getEnclosingSlot (a-1) == n-1 && getEnclosingSlot (b+1) == n+1
slotToMSRange :: (MonadBlockChainWithoutValidation m, Integral i) => i -> m (Api.POSIXTime, Api.POSIXTime)
slotToMSRange :: forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m (POSIXTime, POSIXTime)
slotToMSRange (i -> Slot
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Slot
slot) = do
  SlotConfig
slotConfig <- Params -> SlotConfig
Emulator.pSlotConfig (Params -> SlotConfig) -> m Params -> m SlotConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  case SlotConfig -> Slot -> POSIXTimeRange
Emulator.slotToPOSIXTimeRange SlotConfig
slotConfig Slot
slot of
    Api.Interval
      (Api.LowerBound (Api.Finite POSIXTime
l) Bool
leftclosed)
      (Api.UpperBound (Api.Finite POSIXTime
r) Bool
rightclosed) ->
        (POSIXTime, POSIXTime) -> m (POSIXTime, POSIXTime)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
          ( if Bool
leftclosed then POSIXTime
l else POSIXTime
l POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ POSIXTime
1,
            if Bool
rightclosed then POSIXTime
r else POSIXTime
r POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
1
          )
    POSIXTimeRange
_ -> String -> m (POSIXTime, POSIXTime)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected unbounded slot: please report a bug at https://github.com/tweag/cooked-validators/issues"

-- | Return the slot that contains the given time. See 'slotToMSRange' for
-- some satisfied equational properties.
getEnclosingSlot :: (MonadBlockChainWithoutValidation m) => Api.POSIXTime -> m Ledger.Slot
getEnclosingSlot :: forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
POSIXTime -> m Slot
getEnclosingSlot POSIXTime
t = (SlotConfig -> POSIXTime -> Slot
`Emulator.posixTimeToEnclosingSlot` POSIXTime
t) (SlotConfig -> Slot) -> (Params -> SlotConfig) -> Params -> Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> SlotConfig
Emulator.pSlotConfig (Params -> Slot) -> m Params -> m Slot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams

-- | Waits until the current slot becomes greater or equal to the slot
--  containing the given POSIX time.  Note that that it might not wait for
--  anything if the current slot is large enough.
awaitEnclosingSlot :: (MonadBlockChainWithoutValidation m) => Api.POSIXTime -> m Ledger.Slot
awaitEnclosingSlot :: forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
POSIXTime -> m Slot
awaitEnclosingSlot = Slot -> m Slot
forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m Slot
awaitSlot (Slot -> m Slot) -> (POSIXTime -> m Slot) -> POSIXTime -> m Slot
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< POSIXTime -> m Slot
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
POSIXTime -> m Slot
getEnclosingSlot

-- | Wait a given number of ms from the lower bound of the current slot and
-- returns the current slot after waiting.
waitNMSFromSlotLowerBound :: (MonadBlockChainWithoutValidation m, Integral i) => i -> m Ledger.Slot
waitNMSFromSlotLowerBound :: forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m Slot
waitNMSFromSlotLowerBound i
duration = m (POSIXTime, POSIXTime)
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m (POSIXTime, POSIXTime)
currentMSRange m (POSIXTime, POSIXTime)
-> ((POSIXTime, POSIXTime) -> m Slot) -> m Slot
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= POSIXTime -> m Slot
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
POSIXTime -> m Slot
awaitEnclosingSlot (POSIXTime -> m Slot)
-> ((POSIXTime, POSIXTime) -> POSIXTime)
-> (POSIXTime, POSIXTime)
-> m Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ i -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral i
duration) (POSIXTime -> POSIXTime)
-> ((POSIXTime, POSIXTime) -> POSIXTime)
-> (POSIXTime, POSIXTime)
-> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime, POSIXTime) -> POSIXTime
forall a b. (a, b) -> a
fst

-- | Wait a given number of ms from the upper bound of the current slot and
-- returns the current slot after waiting.
waitNMSFromSlotUpperBound :: (MonadBlockChainWithoutValidation m, Integral i) => i -> m Ledger.Slot
waitNMSFromSlotUpperBound :: forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m Slot
waitNMSFromSlotUpperBound i
duration = m (POSIXTime, POSIXTime)
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m (POSIXTime, POSIXTime)
currentMSRange m (POSIXTime, POSIXTime)
-> ((POSIXTime, POSIXTime) -> m Slot) -> m Slot
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= POSIXTime -> m Slot
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
POSIXTime -> m Slot
awaitEnclosingSlot (POSIXTime -> m Slot)
-> ((POSIXTime, POSIXTime) -> POSIXTime)
-> (POSIXTime, POSIXTime)
-> m Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ i -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral i
duration) (POSIXTime -> POSIXTime)
-> ((POSIXTime, POSIXTime) -> POSIXTime)
-> (POSIXTime, POSIXTime)
-> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (POSIXTime, POSIXTime) -> POSIXTime
forall a b. (a, b) -> b
snd

-- | The infinite range of slots ending before or at the given time
slotRangeBefore :: (MonadBlockChainWithoutValidation m) => Api.POSIXTime -> m Ledger.SlotRange
slotRangeBefore :: forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
POSIXTime -> m SlotRange
slotRangeBefore POSIXTime
t = do
  Slot
n <- POSIXTime -> m Slot
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
POSIXTime -> m Slot
getEnclosingSlot POSIXTime
t
  (POSIXTime
_, POSIXTime
b) <- Slot -> m (POSIXTime, POSIXTime)
forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m (POSIXTime, POSIXTime)
slotToMSRange Slot
n
  -- If the given time @t@ happens to be the last ms of its slot, we can include
  -- the whole slot. Otherwise, the only way to be sure that the returned slot
  -- range contains no time after @t@ is to go to the preceding slot.
  SlotRange -> m SlotRange
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotRange -> m SlotRange) -> SlotRange -> m SlotRange
forall a b. (a -> b) -> a -> b
$ Slot -> SlotRange
forall a. a -> Interval a
Api.to (Slot -> SlotRange) -> Slot -> SlotRange
forall a b. (a -> b) -> a -> b
$ if POSIXTime
t POSIXTime -> POSIXTime -> Bool
forall a. Eq a => a -> a -> Bool
== POSIXTime
b then Slot
n else Slot
n Slot -> Slot -> Slot
forall a. Num a => a -> a -> a
- Slot
1

-- | The infinite range of slots starting after or at the given time
slotRangeAfter :: (MonadBlockChainWithoutValidation m) => Api.POSIXTime -> m Ledger.SlotRange
slotRangeAfter :: forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
POSIXTime -> m SlotRange
slotRangeAfter POSIXTime
t = do
  Slot
n <- POSIXTime -> m Slot
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
POSIXTime -> m Slot
getEnclosingSlot POSIXTime
t
  (POSIXTime
a, POSIXTime
_) <- Slot -> m (POSIXTime, POSIXTime)
forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m (POSIXTime, POSIXTime)
slotToMSRange Slot
n
  SlotRange -> m SlotRange
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotRange -> m SlotRange) -> SlotRange -> m SlotRange
forall a b. (a -> b) -> a -> b
$ Slot -> SlotRange
forall a. a -> Interval a
Api.from (Slot -> SlotRange) -> Slot -> SlotRange
forall a b. (a -> b) -> a -> b
$ if POSIXTime
t POSIXTime -> POSIXTime -> Bool
forall a. Eq a => a -> a -> Bool
== POSIXTime
a then Slot
n else Slot
n Slot -> Slot -> Slot
forall a. Num a => a -> a -> a
+ Slot
1

-- * Deriving further 'MonadBlockChain' instances

-- | A newtype wrapper to be used with '-XDerivingVia' to derive instances of
-- 'MonadBlockChain' for any 'MonadTransControl'.
--
-- For example, to derive 'MonadBlockChain m => MonadBlockChain (ReaderT r m)',
-- you'd write
--
-- > deriving via (AsTrans (ReaderT r) m) instance MonadBlockChain m => MonadBlockChain (ReaderT r m)
--
-- and avoid the trouble of defining all the class methods yourself.
newtype AsTrans t (m :: Type -> Type) a = AsTrans {forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (a :: k).
AsTrans t m a -> t m a
getTrans :: t m a}
  deriving newtype ((forall a b. (a -> b) -> AsTrans t m a -> AsTrans t m b)
-> (forall a b. a -> AsTrans t m b -> AsTrans t m a)
-> Functor (AsTrans t m)
forall a b. a -> AsTrans t m b -> AsTrans t m a
forall a b. (a -> b) -> AsTrans t m a -> AsTrans t m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor (t m) =>
a -> AsTrans t m b -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor (t m) =>
(a -> b) -> AsTrans t m a -> AsTrans t m b
$cfmap :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor (t m) =>
(a -> b) -> AsTrans t m a -> AsTrans t m b
fmap :: forall a b. (a -> b) -> AsTrans t m a -> AsTrans t m b
$c<$ :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor (t m) =>
a -> AsTrans t m b -> AsTrans t m a
<$ :: forall a b. a -> AsTrans t m b -> AsTrans t m a
Functor, Functor (AsTrans t m)
Functor (AsTrans t m) =>
(forall a. a -> AsTrans t m a)
-> (forall a b.
    AsTrans t m (a -> b) -> AsTrans t m a -> AsTrans t m b)
-> (forall a b c.
    (a -> b -> c) -> AsTrans t m a -> AsTrans t m b -> AsTrans t m c)
-> (forall a b. AsTrans t m a -> AsTrans t m b -> AsTrans t m b)
-> (forall a b. AsTrans t m a -> AsTrans t m b -> AsTrans t m a)
-> Applicative (AsTrans t m)
forall a. a -> AsTrans t m a
forall a b. AsTrans t m a -> AsTrans t m b -> AsTrans t m a
forall a b. AsTrans t m a -> AsTrans t m b -> AsTrans t m b
forall a b. AsTrans t m (a -> b) -> AsTrans t m a -> AsTrans t m b
forall a b c.
(a -> b -> c) -> AsTrans t m a -> AsTrans t m b -> AsTrans t m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
Applicative (t m) =>
Functor (AsTrans t m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Applicative (t m) =>
a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
AsTrans t m a -> AsTrans t m b -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
AsTrans t m a -> AsTrans t m b -> AsTrans t m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
AsTrans t m (a -> b) -> AsTrans t m a -> AsTrans t m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b c.
Applicative (t m) =>
(a -> b -> c) -> AsTrans t m a -> AsTrans t m b -> AsTrans t m c
$cpure :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Applicative (t m) =>
a -> AsTrans t m a
pure :: forall a. a -> AsTrans t m a
$c<*> :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
AsTrans t m (a -> b) -> AsTrans t m a -> AsTrans t m b
<*> :: forall a b. AsTrans t m (a -> b) -> AsTrans t m a -> AsTrans t m b
$cliftA2 :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b c.
Applicative (t m) =>
(a -> b -> c) -> AsTrans t m a -> AsTrans t m b -> AsTrans t m c
liftA2 :: forall a b c.
(a -> b -> c) -> AsTrans t m a -> AsTrans t m b -> AsTrans t m c
$c*> :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
AsTrans t m a -> AsTrans t m b -> AsTrans t m b
*> :: forall a b. AsTrans t m a -> AsTrans t m b -> AsTrans t m b
$c<* :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative (t m) =>
AsTrans t m a -> AsTrans t m b -> AsTrans t m a
<* :: forall a b. AsTrans t m a -> AsTrans t m b -> AsTrans t m a
Applicative, Applicative (AsTrans t m)
Applicative (AsTrans t m) =>
(forall a b.
 AsTrans t m a -> (a -> AsTrans t m b) -> AsTrans t m b)
-> (forall a b. AsTrans t m a -> AsTrans t m b -> AsTrans t m b)
-> (forall a. a -> AsTrans t m a)
-> Monad (AsTrans t m)
forall a. a -> AsTrans t m a
forall a b. AsTrans t m a -> AsTrans t m b -> AsTrans t m b
forall a b. AsTrans t m a -> (a -> AsTrans t m b) -> AsTrans t m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
Monad (t m) =>
Applicative (AsTrans t m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Monad (t m) =>
a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad (t m) =>
AsTrans t m a -> AsTrans t m b -> AsTrans t m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad (t m) =>
AsTrans t m a -> (a -> AsTrans t m b) -> AsTrans t m b
$c>>= :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad (t m) =>
AsTrans t m a -> (a -> AsTrans t m b) -> AsTrans t m b
>>= :: forall a b. AsTrans t m a -> (a -> AsTrans t m b) -> AsTrans t m b
$c>> :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad (t m) =>
AsTrans t m a -> AsTrans t m b -> AsTrans t m b
>> :: forall a b. AsTrans t m a -> AsTrans t m b -> AsTrans t m b
$creturn :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Monad (t m) =>
a -> AsTrans t m a
return :: forall a. a -> AsTrans t m a
Monad, (forall (m :: * -> *). Monad m => Monad (AsTrans t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a)
-> MonadTrans (AsTrans t)
forall (m :: * -> *). Monad m => Monad (AsTrans t m)
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTrans t, Monad m) =>
Monad (AsTrans t m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> AsTrans t m a
lift :: forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
MonadTrans, MonadTrans (AsTrans t)
MonadTrans (AsTrans t) =>
(forall (m :: * -> *) a.
 Monad m =>
 (Run (AsTrans t) -> m a) -> AsTrans t m a)
-> (forall (m :: * -> *) a.
    Monad m =>
    m (StT (AsTrans t) a) -> AsTrans t m a)
-> MonadTransControl (AsTrans t)
forall (m :: * -> *) a.
Monad m =>
m (StT (AsTrans t) a) -> AsTrans t m a
forall (m :: * -> *) a.
Monad m =>
(Run (AsTrans t) -> m a) -> AsTrans t m a
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
(forall (m :: * -> *) a. Monad m => (Run t -> m a) -> t m a)
-> (forall (m :: * -> *) a. Monad m => m (StT t a) -> t m a)
-> MonadTransControl t
forall (t :: (* -> *) -> * -> *).
MonadTransControl t =>
MonadTrans (AsTrans t)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT (AsTrans t) a) -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run (AsTrans t) -> m a) -> AsTrans t m a
$cliftWith :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run (AsTrans t) -> m a) -> AsTrans t m a
liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (AsTrans t) -> m a) -> AsTrans t m a
$crestoreT :: forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT (AsTrans t) a) -> AsTrans t m a
restoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT (AsTrans t) a) -> AsTrans t m a
MonadTransControl)

instance (MonadTrans t, MonadFail m, Monad (t m)) => MonadFail (AsTrans t m) where
  fail :: forall a. String -> AsTrans t m a
fail = m a -> AsTrans t m a
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> AsTrans t m a)
-> (String -> m a) -> String -> AsTrans t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

instance (MonadTransControl t, MonadError MockChainError m, Monad (t m)) => MonadError MockChainError (AsTrans t m) where
  throwError :: forall a. MockChainError -> AsTrans t m a
throwError = m a -> AsTrans t m a
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> AsTrans t m a)
-> (MockChainError -> m a) -> MockChainError -> AsTrans t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockChainError -> m a
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: forall a.
AsTrans t m a -> (MockChainError -> AsTrans t m a) -> AsTrans t m a
catchError AsTrans t m a
act MockChainError -> AsTrans t m a
f = (Run (AsTrans t) -> m (StT t a)) -> AsTrans t m (StT t a)
forall (m :: * -> *) a.
Monad m =>
(Run (AsTrans t) -> m a) -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith (\Run (AsTrans t)
run -> m (StT t a) -> (MockChainError -> m (StT t a)) -> m (StT t a)
forall a. m a -> (MockChainError -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (AsTrans t m a -> m (StT (AsTrans t) a)
Run (AsTrans t)
run AsTrans t m a
act) (AsTrans t m a -> m (StT t a)
AsTrans t m a -> m (StT (AsTrans t) a)
Run (AsTrans t)
run (AsTrans t m a -> m (StT t a))
-> (MockChainError -> AsTrans t m a)
-> MockChainError
-> m (StT t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockChainError -> AsTrans t m a
f)) AsTrans t m (StT t a)
-> (StT t a -> AsTrans t m a) -> AsTrans t m a
forall a b. AsTrans t m a -> (a -> AsTrans t m b) -> AsTrans t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (StT t a) -> AsTrans t m a
m (StT (AsTrans t) a) -> AsTrans t m a
forall (m :: * -> *) a.
Monad m =>
m (StT (AsTrans t) a) -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (m (StT t a) -> AsTrans t m a)
-> (StT t a -> m (StT t a)) -> StT t a -> AsTrans t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StT t a -> m (StT t a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance (MonadTrans t, MonadBlockChainBalancing m, Monad (t m), MonadError MockChainError (AsTrans t m)) => MonadBlockChainBalancing (AsTrans t m) where
  getParams :: AsTrans t m Params
getParams = m Params -> AsTrans t m Params
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  utxosAt :: forall a. ToAddress a => a -> AsTrans t m [(TxOutRef, TxSkelOut)]
utxosAt = m [(TxOutRef, TxSkelOut)] -> AsTrans t m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [(TxOutRef, TxSkelOut)] -> AsTrans t m [(TxOutRef, TxSkelOut)])
-> (a -> m [(TxOutRef, TxSkelOut)])
-> a
-> AsTrans t m [(TxOutRef, TxSkelOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m [(TxOutRef, TxSkelOut)]
forall a. ToAddress a => a -> m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a.
(MonadBlockChainBalancing m, ToAddress a) =>
a -> m [(TxOutRef, TxSkelOut)]
utxosAt
  txOutByRef :: TxOutRef -> AsTrans t m (Maybe TxSkelOut)
txOutByRef = m (Maybe TxSkelOut) -> AsTrans t m (Maybe TxSkelOut)
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe TxSkelOut) -> AsTrans t m (Maybe TxSkelOut))
-> (TxOutRef -> m (Maybe TxSkelOut))
-> TxOutRef
-> AsTrans t m (Maybe TxSkelOut)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m (Maybe TxSkelOut)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxSkelOut)
txOutByRef
  logEvent :: MockChainLogEntry -> AsTrans t m ()
logEvent = m () -> AsTrans t m ()
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> AsTrans t m ())
-> (MockChainLogEntry -> m ())
-> MockChainLogEntry
-> AsTrans t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockChainLogEntry -> m ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent

instance (MonadTrans t, MonadBlockChainWithoutValidation m, Monad (t m), MonadError MockChainError (AsTrans t m)) => MonadBlockChainWithoutValidation (AsTrans t m) where
  allUtxos :: AsTrans t m [(TxOutRef, TxSkelOut)]
allUtxos = m [(TxOutRef, TxSkelOut)] -> AsTrans t m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m [(TxOutRef, TxSkelOut)]
allUtxos
  setParams :: Params -> AsTrans t m ()
setParams = m () -> AsTrans t m ()
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> AsTrans t m ())
-> (Params -> m ()) -> Params -> AsTrans t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> m ()
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
Params -> m ()
setParams
  waitNSlots :: forall i. Integral i => i -> AsTrans t m Slot
waitNSlots = m Slot -> AsTrans t m Slot
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Slot -> AsTrans t m Slot)
-> (i -> m Slot) -> i -> AsTrans t m Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> m Slot
forall i. Integral i => i -> m Slot
forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m Slot
waitNSlots
  define :: forall a. ToHash a => String -> a -> AsTrans t m a
define String
name = m a -> AsTrans t m a
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> AsTrans t m a) -> (a -> m a) -> a -> AsTrans t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> m a
forall a. ToHash a => String -> a -> m a
forall (m :: * -> *) a.
(MonadBlockChainWithoutValidation m, ToHash a) =>
String -> a -> m a
define String
name
  setConstitutionScript :: forall s. ToVersioned Script s => s -> AsTrans t m ()
setConstitutionScript = m () -> AsTrans t m ()
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> AsTrans t m ()) -> (s -> m ()) -> s -> AsTrans t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s. ToVersioned Script s => s -> m ()
forall (m :: * -> *) s.
(MonadBlockChainWithoutValidation m, ToVersioned Script s) =>
s -> m ()
setConstitutionScript
  getConstitutionScript :: AsTrans t m (Maybe (Versioned Script))
getConstitutionScript = m (Maybe (Versioned Script))
-> AsTrans t m (Maybe (Versioned Script))
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe (Versioned Script))
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m (Maybe (Versioned Script))
getConstitutionScript
  registerStakingCred :: forall c.
ToCredential c =>
c -> Integer -> Integer -> AsTrans t m ()
registerStakingCred c
cred Integer
reward Integer
deposit = m () -> AsTrans t m ()
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> AsTrans t m ()) -> m () -> AsTrans t m ()
forall a b. (a -> b) -> a -> b
$ c -> Integer -> Integer -> m ()
forall c. ToCredential c => c -> Integer -> Integer -> m ()
forall (m :: * -> *) c.
(MonadBlockChainWithoutValidation m, ToCredential c) =>
c -> Integer -> Integer -> m ()
registerStakingCred c
cred Integer
reward Integer
deposit

instance (MonadTrans t, MonadBlockChain m, MonadBlockChainWithoutValidation (AsTrans t m)) => MonadBlockChain (AsTrans t m) where
  validateTxSkel :: TxSkel -> AsTrans t m CardanoTx
validateTxSkel = m CardanoTx -> AsTrans t m CardanoTx
forall (m :: * -> *) a. Monad m => m a -> AsTrans t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m CardanoTx -> AsTrans t m CardanoTx)
-> (TxSkel -> m CardanoTx) -> TxSkel -> AsTrans t m CardanoTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkel -> m CardanoTx
forall (m :: * -> *). MonadBlockChain m => TxSkel -> m CardanoTx
validateTxSkel

deriving via (AsTrans (WriterT w) m) instance (Monoid w, MonadBlockChainBalancing m) => MonadBlockChainBalancing (WriterT w m)

deriving via (AsTrans (WriterT w) m) instance (Monoid w, MonadBlockChainWithoutValidation m) => MonadBlockChainWithoutValidation (WriterT w m)

deriving via (AsTrans (WriterT w) m) instance (Monoid w, MonadBlockChain m) => MonadBlockChain (WriterT w m)

deriving via (AsTrans (ReaderT r) m) instance (MonadBlockChainBalancing m) => MonadBlockChainBalancing (ReaderT r m)

deriving via (AsTrans (ReaderT r) m) instance (MonadBlockChainWithoutValidation m) => MonadBlockChainWithoutValidation (ReaderT r m)

deriving via (AsTrans (ReaderT r) m) instance (MonadBlockChain m) => MonadBlockChain (ReaderT r m)

deriving via (AsTrans (StateT s) m) instance (MonadBlockChainBalancing m) => MonadBlockChainBalancing (StateT s m)

deriving via (AsTrans (StateT s) m) instance (MonadBlockChainWithoutValidation m) => MonadBlockChainWithoutValidation (StateT s m)

deriving via (AsTrans (StateT s) m) instance (MonadBlockChain m) => MonadBlockChain (StateT s m)

-- 'ListT' has no 'MonadTransControl' instance, so the @deriving via ...@
-- machinery is unusable here. However, there is
--
-- > MonadError e m => MonadError e (ListT m)
--
-- so I decided to go with a bit of code duplication to implement the
-- 'MonadBlockChainWithoutValidation' and 'MonadBlockChain' instances for
-- 'ListT', instead of more black magic...

instance (MonadBlockChainBalancing m) => MonadBlockChainBalancing (ListT m) where
  getParams :: ListT m Params
getParams = m Params -> ListT m Params
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  utxosAt :: forall a. ToAddress a => a -> ListT m [(TxOutRef, TxSkelOut)]
utxosAt = m [(TxOutRef, TxSkelOut)] -> ListT m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [(TxOutRef, TxSkelOut)] -> ListT m [(TxOutRef, TxSkelOut)])
-> (a -> m [(TxOutRef, TxSkelOut)])
-> a
-> ListT m [(TxOutRef, TxSkelOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m [(TxOutRef, TxSkelOut)]
forall a. ToAddress a => a -> m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a.
(MonadBlockChainBalancing m, ToAddress a) =>
a -> m [(TxOutRef, TxSkelOut)]
utxosAt
  txOutByRef :: TxOutRef -> ListT m (Maybe TxSkelOut)
txOutByRef = m (Maybe TxSkelOut) -> ListT m (Maybe TxSkelOut)
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe TxSkelOut) -> ListT m (Maybe TxSkelOut))
-> (TxOutRef -> m (Maybe TxSkelOut))
-> TxOutRef
-> ListT m (Maybe TxSkelOut)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m (Maybe TxSkelOut)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxSkelOut)
txOutByRef
  logEvent :: MockChainLogEntry -> ListT m ()
logEvent = m () -> ListT m ()
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ListT m ())
-> (MockChainLogEntry -> m ()) -> MockChainLogEntry -> ListT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockChainLogEntry -> m ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent

instance (MonadBlockChainWithoutValidation m) => MonadBlockChainWithoutValidation (ListT m) where
  allUtxos :: ListT m [(TxOutRef, TxSkelOut)]
allUtxos = m [(TxOutRef, TxSkelOut)] -> ListT m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m [(TxOutRef, TxSkelOut)]
allUtxos
  setParams :: Params -> ListT m ()
setParams = m () -> ListT m ()
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ListT m ()) -> (Params -> m ()) -> Params -> ListT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> m ()
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
Params -> m ()
setParams
  waitNSlots :: forall i. Integral i => i -> ListT m Slot
waitNSlots = m Slot -> ListT m Slot
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Slot -> ListT m Slot) -> (i -> m Slot) -> i -> ListT m Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> m Slot
forall i. Integral i => i -> m Slot
forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m Slot
waitNSlots
  define :: forall a. ToHash a => String -> a -> ListT m a
define String
name = m a -> ListT m a
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ListT m a) -> (a -> m a) -> a -> ListT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> m a
forall a. ToHash a => String -> a -> m a
forall (m :: * -> *) a.
(MonadBlockChainWithoutValidation m, ToHash a) =>
String -> a -> m a
define String
name
  setConstitutionScript :: forall s. ToVersioned Script s => s -> ListT m ()
setConstitutionScript = m () -> ListT m ()
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ListT m ()) -> (s -> m ()) -> s -> ListT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s. ToVersioned Script s => s -> m ()
forall (m :: * -> *) s.
(MonadBlockChainWithoutValidation m, ToVersioned Script s) =>
s -> m ()
setConstitutionScript
  getConstitutionScript :: ListT m (Maybe (Versioned Script))
getConstitutionScript = m (Maybe (Versioned Script)) -> ListT m (Maybe (Versioned Script))
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Maybe (Versioned Script))
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m (Maybe (Versioned Script))
getConstitutionScript
  registerStakingCred :: forall c. ToCredential c => c -> Integer -> Integer -> ListT m ()
registerStakingCred c
cred Integer
reward Integer
deposit = m () -> ListT m ()
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ListT m ()) -> m () -> ListT m ()
forall a b. (a -> b) -> a -> b
$ c -> Integer -> Integer -> m ()
forall c. ToCredential c => c -> Integer -> Integer -> m ()
forall (m :: * -> *) c.
(MonadBlockChainWithoutValidation m, ToCredential c) =>
c -> Integer -> Integer -> m ()
registerStakingCred c
cred Integer
reward Integer
deposit

instance (MonadBlockChain m) => MonadBlockChain (ListT m) where
  validateTxSkel :: TxSkel -> ListT m CardanoTx
validateTxSkel = m CardanoTx -> ListT m CardanoTx
forall (m :: * -> *) a. Monad m => m a -> ListT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m CardanoTx -> ListT m CardanoTx)
-> (TxSkel -> m CardanoTx) -> TxSkel -> ListT m CardanoTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkel -> m CardanoTx
forall (m :: * -> *). MonadBlockChain m => TxSkel -> m CardanoTx
validateTxSkel