{-# 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
  ( Fee,
    CollateralIns,
    Collaterals,
    Utxos,
    MockChainError (..),
    MockChainLogEntry (..),
    MonadBlockChainBalancing (..),
    MonadBlockChainWithoutValidation (..),
    MonadBlockChain (..),
    AsTrans (..),
    currentMSRange,
    utxosFromCardanoTx,
    currentSlot,
    awaitSlot,
    getEnclosingSlot,
    awaitEnclosingSlot,
    waitNMSFromSlotLowerBound,
    waitNMSFromSlotUpperBound,
    slotRangeBefore,
    slotRangeAfter,
    slotToMSRange,
    txSkelInputScripts,
    txSkelInputValue,
    lookupUtxos,
    validateTxSkel',
    validateTxSkel_,
    txSkelDepositedValueInProposals,
    govActionDeposit,
    defineM,
    txSkelAllScripts,
    previewByRef,
    viewByRef,
    dRepDeposit,
    stakeAddressDeposit,
    stakePoolDeposit,
    txSkelDepositedValueInCertificates,
  )
where

import Cardano.Api.Ledger qualified as Cardano
import Cardano.Ledger.Conway.Core 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 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.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api

-- * Type aliases

-- | An alias for Integers used as fees
type Fee = Integer

-- | An alias for sets of utxos used as collateral inputs
type CollateralIns = Set Api.TxOutRef

-- | An alias for optional pairs of collateral inputs and return collateral peer
type Collaterals = Maybe (CollateralIns, Peer)

-- | An alias for lists of utxos with their associated output
type Utxos = [(Api.TxOutRef, TxSkelOut)]

-- * 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 user does not have enough funds
    MCEUnbalanceable Peer Api.Value
  | -- | The balancing user is required but missing
    MCEMissingBalancingUser 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 user.
    MCLogAdjustedTxSkel TxSkel Fee Collaterals
  | -- | 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 user or a set of
    -- utxos to be used as collaterals.
    MCLogUnusedCollaterals (Either Peer CollateralIns)
  | -- | Logging the automatic addition of a reference script
    MCLogAddedReferenceScript TxSkelRedeemer Api.TxOutRef Script.ScriptHash
  | -- | Logging the automatic addition of a withdrawal amount
    MCLogAutoFilledWithdrawalAmount Api.Credential Api.Lovelace
  | -- | Logging the automatic addition of the constitution script
    MCLogAutoFilledConstitution Api.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 Utxos

  -- | Returns an output given a reference to it. If the output does not exist,
  -- throws a 'MCEUnknownOutRef' error.
  txSkelOutByRef :: Api.TxOutRef -> m 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 Utxos

  -- | 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 :: (ToVScript s) => s -> m ()

  -- | Gets the current official constitution script
  getConstitutionScript :: m (Maybe VScript)

  -- | Gets the current reward associated with a credential
  getCurrentReward :: (Script.ToCredential c) => c -> m (Maybe Api.Lovelace)

-- | 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

  -- | Forces the generation of utxos corresponding to certain 'TxSkelOut'
  forceOutputs :: [TxSkelOut] -> m [Api.TxOutRef]

-- * Mockchain helpers

-- | Retrieves an output and views a specific element out of it
viewByRef :: (MonadBlockChainBalancing m, Is g A_Getter) => Optic' g is TxSkelOut c -> Api.TxOutRef -> m c
viewByRef :: forall (m :: * -> *) g (is :: IxList) c.
(MonadBlockChainBalancing m, Is g A_Getter) =>
Optic' g is TxSkelOut c -> TxOutRef -> m c
viewByRef Optic' g is TxSkelOut c
optic = (Optic' g is TxSkelOut c -> TxSkelOut -> c
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' g is TxSkelOut c
optic (TxSkelOut -> c) -> m TxSkelOut -> m c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m TxSkelOut -> m c)
-> (TxOutRef -> m TxSkelOut) -> TxOutRef -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
txSkelOutByRef

-- | Retrieves an output and previews a specific element out of it
previewByRef :: (MonadBlockChainBalancing m, Is af An_AffineFold) => Optic' af is TxSkelOut c -> Api.TxOutRef -> m (Maybe c)
previewByRef :: forall (m :: * -> *) af (is :: IxList) c.
(MonadBlockChainBalancing m, Is af An_AffineFold) =>
Optic' af is TxSkelOut c -> TxOutRef -> m (Maybe c)
previewByRef Optic' af is TxSkelOut c
optic = (Optic' af is TxSkelOut c -> TxSkelOut -> Maybe c
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' af is TxSkelOut c
optic (TxSkelOut -> Maybe c) -> m TxSkelOut -> m (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m TxSkelOut -> m (Maybe c))
-> (TxOutRef -> m TxSkelOut) -> TxOutRef -> m (Maybe c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
txSkelOutByRef

-- | 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 =
  (TxOutRef -> m (TxOutRef, TxSkelOut))
-> [TxOutRef] -> 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 (\TxOutRef
txOutRef -> (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
txSkelOutByRef TxOutRef
txOutRef)
    ([TxOutRef] -> m [(TxOutRef, TxSkelOut)])
-> (CardanoTx -> [TxOutRef])
-> CardanoTx
-> m [(TxOutRef, TxSkelOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxOut, TxIn) -> TxOutRef) -> [(TxOut, TxIn)] -> [TxOutRef]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TxIn -> TxOutRef
Ledger.fromCardanoTxIn (TxIn -> TxOutRef)
-> ((TxOut, TxIn) -> TxIn) -> (TxOut, TxIn) -> TxOutRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut, TxIn) -> TxIn
forall a b. (a, b) -> b
snd)
    ([(TxOut, TxIn)] -> [TxOutRef])
-> (CardanoTx -> [(TxOut, TxIn)]) -> CardanoTx -> [TxOutRef]
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
=<<)

-- | Retrieves the required governance action deposit amount
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 required drep deposit amount
dRepDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace
dRepDeposit :: forall (m :: * -> *). MonadBlockChainBalancing m => m Lovelace
dRepDeposit = 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.ppDRepDepositL (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 required stake address deposit amount
stakeAddressDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace
stakeAddressDeposit :: forall (m :: * -> *). MonadBlockChainBalancing m => m Lovelace
stakeAddressDeposit = 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. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams EmulatorEra) Coin
Conway.ppKeyDepositL (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 required stake pool deposit amount
stakePoolDeposit :: (MonadBlockChainBalancing m) => m Api.Lovelace
stakePoolDeposit :: forall (m :: * -> *). MonadBlockChainBalancing m => m Lovelace
stakePoolDeposit = 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. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams EmulatorEra) Coin
Conway.ppPoolDepositL (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).
txSkelDepositedValueInProposals :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Lovelace
txSkelDepositedValueInProposals :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m Lovelace
txSkelDepositedValueInProposals TxSkel {[TxSkelProposal]
txSkelProposals :: [TxSkelProposal]
txSkelProposals :: TxSkel -> [TxSkelProposal]
txSkelProposals} = 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

-- | Retrieves the total amount of lovelace deposited in certificates in this
-- skeleton. Note that unregistering a staking address or a dRep lead to a
-- negative deposit (a withdrawal, in fact) which means this function can return
-- a negative amount of lovelace, which is intended. The deposited amounts are
-- dictated by the current protocol parameters, and computed as such.
txSkelDepositedValueInCertificates :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Lovelace
txSkelDepositedValueInCertificates :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m Lovelace
txSkelDepositedValueInCertificates TxSkel
txSkel = do
  Lovelace
sDep <- m Lovelace
forall (m :: * -> *). MonadBlockChainBalancing m => m Lovelace
stakeAddressDeposit
  Lovelace
dDep <- m Lovelace
forall (m :: * -> *). MonadBlockChainBalancing m => m Lovelace
dRepDeposit
  Lovelace
pDep <- m Lovelace
forall (m :: * -> *). MonadBlockChainBalancing m => m Lovelace
stakePoolDeposit
  Lovelace -> m Lovelace
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lovelace -> m Lovelace) -> Lovelace -> m Lovelace
forall a b. (a -> b) -> a -> b
$
    Optic' A_Fold '[] TxSkel Lovelace -> TxSkel -> Lovelace
forall k a (is :: IxList) s.
(Is k A_Fold, Monoid a) =>
Optic' k is s a -> s -> a
foldOf
      ( Lens' TxSkel [TxSkelCertificate]
txSkelCertificatesL
          Lens' TxSkel [TxSkelCertificate]
-> Optic
     A_Traversal
     '[]
     [TxSkelCertificate]
     [TxSkelCertificate]
     TxSkelCertificate
     TxSkelCertificate
-> Optic
     A_Traversal '[] TxSkel TxSkel TxSkelCertificate TxSkelCertificate
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Traversal
  '[]
  [TxSkelCertificate]
  [TxSkelCertificate]
  TxSkelCertificate
  TxSkelCertificate
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed
          Optic
  A_Traversal '[] TxSkel TxSkel TxSkelCertificate TxSkelCertificate
-> Optic
     A_Getter '[] TxSkelCertificate TxSkelCertificate Lovelace Lovelace
-> Optic' A_Fold '[] TxSkel Lovelace
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (TxSkelCertificate -> Lovelace)
-> Optic
     A_Getter '[] TxSkelCertificate TxSkelCertificate Lovelace Lovelace
forall s a. (s -> a) -> Getter s a
to
            ( \case
                TxSkelCertificate User kind 'Redemption
_ StakingRegister {} -> Lovelace
sDep
                TxSkelCertificate User kind 'Redemption
_ StakingRegisterDelegate {} -> Lovelace
sDep
                TxSkelCertificate User kind 'Redemption
_ StakingUnRegister {} -> -Lovelace
sDep
                TxSkelCertificate User kind 'Redemption
_ DRepRegister {} -> Lovelace
dDep
                TxSkelCertificate User kind 'Redemption
_ DRepUnRegister {} -> -Lovelace
dDep
                TxSkelCertificate User kind 'Redemption
_ PoolRegister {} -> Lovelace
pDep
                -- There is no special case for 'PoolRetire' because the deposit
                -- is given back to the reward account.
                TxSkelCertificate
_ -> Integer -> Lovelace
Api.Lovelace Integer
0
            )
      )
      TxSkel
txSkel

-- | Returns all scripts which guard transaction inputs
txSkelInputScripts :: (MonadBlockChainBalancing m) => TxSkel -> m [VScript]
txSkelInputScripts :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m [VScript]
txSkelInputScripts = ([Maybe VScript] -> [VScript]) -> m [Maybe VScript] -> m [VScript]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe VScript] -> [VScript]
forall a. [Maybe a] -> [a]
catMaybes (m [Maybe VScript] -> m [VScript])
-> (TxSkel -> m [Maybe VScript]) -> TxSkel -> m [VScript]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef -> m (Maybe VScript)) -> [TxOutRef] -> m [Maybe VScript]
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 (Optic' An_AffineTraversal '[] TxSkelOut VScript
-> TxOutRef -> m (Maybe VScript)
forall (m :: * -> *) af (is :: IxList) c.
(MonadBlockChainBalancing m, Is af An_AffineFold) =>
Optic' af is TxSkelOut c -> TxOutRef -> m (Maybe c)
previewByRef (Lens' TxSkelOut (User 'IsEither 'Allocation)
txSkelOutOwnerL Lens' TxSkelOut (User 'IsEither 'Allocation)
-> Optic
     An_AffineTraversal
     '[]
     (User 'IsEither 'Allocation)
     (User 'IsEither 'Allocation)
     VScript
     VScript
-> Optic' An_AffineTraversal '[] TxSkelOut VScript
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_AffineTraversal
  '[]
  (User 'IsEither 'Allocation)
  (User 'IsEither 'Allocation)
  VScript
  VScript
forall (kind :: UserKind) (mode :: UserMode).
AffineTraversal' (User kind mode) VScript
userVScriptAT)) ([TxOutRef] -> m [Maybe VScript])
-> (TxSkel -> [TxOutRef]) -> TxSkel -> m [Maybe VScript]
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 [VScript]
txSkelAllScripts :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m [VScript]
txSkelAllScripts TxSkel
txSkel = do
  [VScript]
txSkelSpendingScripts <- TxSkel -> m [VScript]
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m [VScript]
txSkelInputScripts TxSkel
txSkel
  [VScript] -> m [VScript]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( TxSkel -> [VScript]
txSkelMintingScripts TxSkel
txSkel
        [VScript] -> [VScript] -> [VScript]
forall a. Semigroup a => a -> a -> a
<> TxSkel -> [VScript]
txSkelWithdrawingScripts TxSkel
txSkel
        [VScript] -> [VScript] -> [VScript]
forall a. Semigroup a => a -> a -> a
<> TxSkel -> [VScript]
txSkelProposingScripts TxSkel
txSkel
        [VScript] -> [VScript] -> [VScript]
forall a. Semigroup a => a -> a -> a
<> TxSkel -> [VScript]
txSkelCertifyingScripts TxSkel
txSkel
        [VScript] -> [VScript] -> [VScript]
forall a. Semigroup a => a -> a -> a
<> [VScript]
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
txSkelOutByRef 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 (Optic' A_Lens '[] TxSkelOut Value -> TxOutRef -> m Value
forall (m :: * -> *) g (is :: IxList) c.
(MonadBlockChainBalancing m, Is g A_Getter) =>
Optic' g is TxSkelOut c -> TxOutRef -> m c
viewByRef Optic' A_Lens '[] TxSkelOut Value
txSkelOutValueL) ([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
  txSkelOutByRef :: TxOutRef -> AsTrans t m TxSkelOut
txSkelOutByRef = m TxSkelOut -> AsTrans t m 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 TxSkelOut -> AsTrans t m TxSkelOut)
-> (TxOutRef -> m TxSkelOut) -> TxOutRef -> AsTrans t m TxSkelOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
txSkelOutByRef
  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. ToVScript 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. ToVScript s => s -> m ()
forall (m :: * -> *) s.
(MonadBlockChainWithoutValidation m, ToVScript s) =>
s -> m ()
setConstitutionScript
  getConstitutionScript :: AsTrans t m (Maybe VScript)
getConstitutionScript = m (Maybe VScript) -> AsTrans t m (Maybe VScript)
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 VScript)
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m (Maybe VScript)
getConstitutionScript
  getCurrentReward :: forall c. ToCredential c => c -> AsTrans t m (Maybe Lovelace)
getCurrentReward = m (Maybe Lovelace) -> AsTrans t m (Maybe Lovelace)
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 Lovelace) -> AsTrans t m (Maybe Lovelace))
-> (c -> m (Maybe Lovelace)) -> c -> AsTrans t m (Maybe Lovelace)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> m (Maybe Lovelace)
forall c. ToCredential c => c -> m (Maybe Lovelace)
forall (m :: * -> *) c.
(MonadBlockChainWithoutValidation m, ToCredential c) =>
c -> m (Maybe Lovelace)
getCurrentReward

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
  forceOutputs :: [TxSkelOut] -> AsTrans t m [TxOutRef]
forceOutputs = m [TxOutRef] -> AsTrans t m [TxOutRef]
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] -> AsTrans t m [TxOutRef])
-> ([TxSkelOut] -> m [TxOutRef])
-> [TxSkelOut]
-> AsTrans t m [TxOutRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxSkelOut] -> m [TxOutRef]
forall (m :: * -> *).
MonadBlockChain m =>
[TxSkelOut] -> m [TxOutRef]
forceOutputs

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
  txSkelOutByRef :: TxOutRef -> ListT m TxSkelOut
txSkelOutByRef = m TxSkelOut -> ListT m 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 TxSkelOut -> ListT m TxSkelOut)
-> (TxOutRef -> m TxSkelOut) -> TxOutRef -> ListT m TxSkelOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
txSkelOutByRef
  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. ToVScript 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. ToVScript s => s -> m ()
forall (m :: * -> *) s.
(MonadBlockChainWithoutValidation m, ToVScript s) =>
s -> m ()
setConstitutionScript
  getConstitutionScript :: ListT m (Maybe VScript)
getConstitutionScript = m (Maybe VScript) -> ListT m (Maybe VScript)
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 VScript)
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m (Maybe VScript)
getConstitutionScript
  getCurrentReward :: forall c. ToCredential c => c -> ListT m (Maybe Lovelace)
getCurrentReward = m (Maybe Lovelace) -> ListT m (Maybe Lovelace)
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 Lovelace) -> ListT m (Maybe Lovelace))
-> (c -> m (Maybe Lovelace)) -> c -> ListT m (Maybe Lovelace)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> m (Maybe Lovelace)
forall c. ToCredential c => c -> m (Maybe Lovelace)
forall (m :: * -> *) c.
(MonadBlockChainWithoutValidation m, ToCredential c) =>
c -> m (Maybe Lovelace)
getCurrentReward

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
  forceOutputs :: [TxSkelOut] -> ListT m [TxOutRef]
forceOutputs = m [TxOutRef] -> ListT m [TxOutRef]
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] -> ListT m [TxOutRef])
-> ([TxSkelOut] -> m [TxOutRef])
-> [TxSkelOut]
-> ListT m [TxOutRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxSkelOut] -> m [TxOutRef]
forall (m :: * -> *).
MonadBlockChain m =>
[TxSkelOut] -> m [TxOutRef]
forceOutputs