{-# OPTIONS_GHC -Wno-orphans #-}

-- | This module provides a staged implementation of our `MonadBlockChain`. The
-- motivation behind this is to be able to modify traces using `Cooked.Ltl` and
-- `Cooked.Tweak` while they are interpreted.
module Cooked.MockChain.Staged
  ( interpretAndRunWith,
    interpretAndRun,
    StagedMockChain,
    runTweakFrom,
    MonadModalBlockChain,
    somewhere,
    runTweak,
    everywhere,
    withTweak,
    there,
  )
where

import Cardano.Node.Emulator qualified as Emulator
import Control.Applicative
import Control.Arrow hiding ((<+>))
import Control.Monad (MonadPlus (..), msum)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Cooked.InitialDistribution
import Cooked.Ltl
import Cooked.MockChain.BlockChain
import Cooked.MockChain.Direct
import Cooked.MockChain.UtxoState
import Cooked.Skeleton
import Cooked.Tweak.Common
import Data.Default
import Ledger.Slot qualified as Ledger
import Ledger.Tx qualified as Ledger
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api

-- * Interpreting and running 'StagedMockChain'

-- | Interprets the staged mockchain then runs the resulting computation with a
-- custom function. This can be used, for example, to supply a custom
-- 'InitialDistribution' by providing 'runMockChainTFrom'.
interpretAndRunWith ::
  (forall m. (Monad m) => MockChainT m a -> m res) ->
  StagedMockChain a ->
  [res]
interpretAndRunWith :: forall a res.
(forall (m :: * -> *). Monad m => MockChainT m a -> m res)
-> StagedMockChain a -> [res]
interpretAndRunWith forall (m :: * -> *). Monad m => MockChainT m a -> m res
f StagedMockChain a
smc = MockChainT [] a -> [res]
forall (m :: * -> *). Monad m => MockChainT m a -> m res
f (MockChainT [] a -> [res]) -> MockChainT [] a -> [res]
forall a b. (a -> b) -> a -> b
$ StagedMockChain a -> MockChainT [] a
forall a. StagedMockChain a -> InterpMockChain a
interpret StagedMockChain a
smc

interpretAndRun :: StagedMockChain a -> [MockChainReturn a UtxoState]
interpretAndRun :: forall a. StagedMockChain a -> [MockChainReturn a UtxoState]
interpretAndRun = (forall (m :: * -> *).
 Monad m =>
 MockChainT m a -> m (MockChainReturn a UtxoState))
-> StagedMockChain a -> [MockChainReturn a UtxoState]
forall a res.
(forall (m :: * -> *). Monad m => MockChainT m a -> m res)
-> StagedMockChain a -> [res]
interpretAndRunWith MockChainT m a -> m (MockChainReturn a UtxoState)
forall (m :: * -> *).
Monad m =>
MockChainT m a -> m (MockChainReturn a UtxoState)
forall (m :: * -> *) a.
Monad m =>
MockChainT m a -> m (MockChainReturn a UtxoState)
runMockChainT

-- | The semantic domain in which 'StagedMockChain' gets interpreted; see the
-- 'interpret' function for more.
type InterpMockChain = MockChainT []

-- | The 'interpret' function gives semantics to our traces. One
-- 'StagedMockChain' computation yields a potential list of 'MockChainT'
-- computations, which emit a description of their operation. Recall a
-- 'MockChainT' is a state and except monad composed:
--
--  >     MockChainT (WriterT TraceDescr []) a
--  > =~= st -> (WriterT TraceDescr []) (Either err (a, st))
--  > =~= st -> [(Either err (a, st) , TraceDescr)]
interpret :: StagedMockChain a -> InterpMockChain a
interpret :: forall a. StagedMockChain a -> InterpMockChain a
interpret = (StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
 -> [Ltl (UntypedTweak (MockChainT []))] -> InterpMockChain a)
-> [Ltl (UntypedTweak (MockChainT []))]
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
-> InterpMockChain a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
-> [Ltl (UntypedTweak (MockChainT []))] -> InterpMockChain a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT [] (StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
 -> InterpMockChain a)
-> (StagedMockChain a
    -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a)
-> StagedMockChain a
-> InterpMockChain a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StagedMockChain a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall modification (builtin :: * -> *) (m :: * -> *) a.
InterpLtl modification builtin m =>
Staged (LtlOp modification builtin) a
-> StateT [Ltl modification] m a
interpLtlAndPruneUnfinished

-- * 'StagedMockChain': An AST for 'MonadMockChain' computations

data MockChainBuiltin a where
  -- methods of 'MonadBlockChain'
  GetParams :: MockChainBuiltin Emulator.Params
  SetParams :: Emulator.Params -> MockChainBuiltin ()
  ValidateTxSkel :: TxSkel -> MockChainBuiltin Ledger.CardanoTx
  TxOutByRef :: Api.TxOutRef -> MockChainBuiltin (Maybe Api.TxOut)
  GetCurrentSlot :: MockChainBuiltin Ledger.Slot
  AwaitSlot :: Ledger.Slot -> MockChainBuiltin Ledger.Slot
  DatumFromHash :: Api.DatumHash -> MockChainBuiltin (Maybe Api.Datum)
  AllUtxos :: MockChainBuiltin [(Api.TxOutRef, Api.TxOut)]
  UtxosAt :: Api.Address -> MockChainBuiltin [(Api.TxOutRef, Api.TxOut)]
  ValidatorFromHash :: Script.ValidatorHash -> MockChainBuiltin (Maybe (Script.Versioned Script.Validator))
  LogEvent :: MockChainLogEntry -> MockChainBuiltin ()
  -- | The empty set of traces
  Empty :: MockChainBuiltin a
  -- | The union of two sets of traces
  Alt :: StagedMockChain a -> StagedMockChain a -> MockChainBuiltin a
  -- for the 'MonadFail' instance
  Fail :: String -> MockChainBuiltin a
  -- for the 'MonadError MockChainError' instance
  ThrowError :: MockChainError -> MockChainBuiltin a
  CatchError :: StagedMockChain a -> (MockChainError -> StagedMockChain a) -> MockChainBuiltin a

type MockChainOp = LtlOp (UntypedTweak InterpMockChain) MockChainBuiltin

type StagedMockChain = Staged MockChainOp

instance Alternative StagedMockChain where
  empty :: forall a. StagedMockChain a
empty = MockChainOp a
-> (a -> Staged MockChainOp a) -> Staged MockChainOp a
forall (op :: * -> *) a1 a.
op a1 -> (a1 -> Staged op a) -> Staged op a
Instr (MockChainBuiltin a -> MockChainOp a
forall (builtin :: * -> *) a modification.
builtin a -> LtlOp modification builtin a
Builtin MockChainBuiltin a
forall a. MockChainBuiltin a
Empty) a -> Staged MockChainOp a
forall a (op :: * -> *). a -> Staged op a
Return
  StagedMockChain a
a <|> :: forall a.
StagedMockChain a -> StagedMockChain a -> StagedMockChain a
<|> StagedMockChain a
b = MockChainOp a -> (a -> StagedMockChain a) -> StagedMockChain a
forall (op :: * -> *) a1 a.
op a1 -> (a1 -> Staged op a) -> Staged op a
Instr (MockChainBuiltin a -> MockChainOp a
forall (builtin :: * -> *) a modification.
builtin a -> LtlOp modification builtin a
Builtin (StagedMockChain a -> StagedMockChain a -> MockChainBuiltin a
forall a.
StagedMockChain a -> StagedMockChain a -> MockChainBuiltin a
Alt StagedMockChain a
a StagedMockChain a
b)) a -> StagedMockChain a
forall a (op :: * -> *). a -> Staged op a
Return

instance MonadFail StagedMockChain where
  fail :: forall a. String -> StagedMockChain a
fail String
msg = MockChainOp a
-> (a -> Staged MockChainOp a) -> Staged MockChainOp a
forall (op :: * -> *) a1 a.
op a1 -> (a1 -> Staged op a) -> Staged op a
Instr (MockChainBuiltin a -> MockChainOp a
forall (builtin :: * -> *) a modification.
builtin a -> LtlOp modification builtin a
Builtin (String -> MockChainBuiltin a
forall a. String -> MockChainBuiltin a
Fail String
msg)) a -> Staged MockChainOp a
forall a (op :: * -> *). a -> Staged op a
Return

-- * 'InterpLtl' instance

instance (MonadPlus m) => MonadPlus (MockChainT m) where
  mzero :: forall a. MockChainT m a
mzero = m a -> MockChainT m a
forall (m :: * -> *) a. Monad m => m a -> MockChainT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  mplus :: forall a. MockChainT m a -> MockChainT m a -> MockChainT m a
mplus = (forall a. m a -> m a -> m a)
-> MockChainT m a -> MockChainT m a -> MockChainT m a
forall (m :: * -> *) x.
(forall a. m a -> m a -> m a)
-> MockChainT m x -> MockChainT m x -> MockChainT m x
combineMockChainT m a -> m a -> m a
forall a. m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance InterpLtl (UntypedTweak InterpMockChain) MockChainBuiltin InterpMockChain where
  interpBuiltin :: forall a.
MockChainBuiltin a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
interpBuiltin MockChainBuiltin a
GetParams = StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  interpBuiltin (SetParams Params
params) = Params
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) ()
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
Params -> m ()
setParams Params
params
  interpBuiltin (ValidateTxSkel TxSkel
skel) =
    StateT
  [Ltl (UntypedTweak (MockChainT []))]
  (MockChainT [])
  [Ltl (UntypedTweak (MockChainT []))]
forall s (m :: * -> *). MonadState s m => m s
get
      StateT
  [Ltl (UntypedTweak (MockChainT []))]
  (MockChainT [])
  [Ltl (UntypedTweak (MockChainT []))]
-> ([Ltl (UntypedTweak (MockChainT []))]
    -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a)
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall a b.
StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
-> (a
    -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) b)
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a]
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum
        ([StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a]
 -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a)
-> ([Ltl (UntypedTweak (MockChainT []))]
    -> [StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a])
-> [Ltl (UntypedTweak (MockChainT []))]
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UntypedTweak (MockChainT []),
  [Ltl (UntypedTweak (MockChainT []))])
 -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a)
-> [(UntypedTweak (MockChainT []),
     [Ltl (UntypedTweak (MockChainT []))])]
-> [StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a]
forall a b. (a -> b) -> [a] -> [b]
map ((UntypedTweak (MockChainT [])
 -> [Ltl (UntypedTweak (MockChainT []))]
 -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a)
-> (UntypedTweak (MockChainT []),
    [Ltl (UntypedTweak (MockChainT []))])
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry UntypedTweak (MockChainT [])
-> [Ltl (UntypedTweak (MockChainT []))]
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
UntypedTweak (MockChainT [])
-> [Ltl (UntypedTweak (MockChainT []))]
-> StateT
     [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) CardanoTx
interpretNow)
        ([(UntypedTweak (MockChainT []),
   [Ltl (UntypedTweak (MockChainT []))])]
 -> [StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a])
-> ([Ltl (UntypedTweak (MockChainT []))]
    -> [(UntypedTweak (MockChainT []),
         [Ltl (UntypedTweak (MockChainT []))])])
-> [Ltl (UntypedTweak (MockChainT []))]
-> [StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ltl (UntypedTweak (MockChainT []))]
-> [(UntypedTweak (MockChainT []),
     [Ltl (UntypedTweak (MockChainT []))])]
forall a. Monoid a => [Ltl a] -> [(a, [Ltl a])]
nowLaterList
    where
      interpretNow ::
        UntypedTweak InterpMockChain ->
        [Ltl (UntypedTweak InterpMockChain)] ->
        StateT [Ltl (UntypedTweak InterpMockChain)] InterpMockChain Ledger.CardanoTx
      interpretNow :: UntypedTweak (MockChainT [])
-> [Ltl (UntypedTweak (MockChainT []))]
-> StateT
     [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) CardanoTx
interpretNow (UntypedTweak Tweak (MockChainT []) a
now) [Ltl (UntypedTweak (MockChainT []))]
later = do
        (a
_, TxSkel
skel') <- InterpMockChain (a, TxSkel)
-> StateT
     [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) (a, TxSkel)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT [Ltl (UntypedTweak (MockChainT []))] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InterpMockChain (a, TxSkel)
 -> StateT
      [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) (a, TxSkel))
-> InterpMockChain (a, TxSkel)
-> StateT
     [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) (a, TxSkel)
forall a b. (a -> b) -> a -> b
$ Tweak (MockChainT []) a -> TxSkel -> InterpMockChain (a, TxSkel)
forall (m :: * -> *) a.
MonadPlus m =>
Tweak m a -> TxSkel -> m (a, TxSkel)
runTweakInChain Tweak (MockChainT []) a
now TxSkel
skel
        [Ltl (UntypedTweak (MockChainT []))]
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [Ltl (UntypedTweak (MockChainT []))]
later
        TxSkel
-> StateT
     [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) CardanoTx
forall (m :: * -> *). MonadBlockChain m => TxSkel -> m CardanoTx
validateTxSkel TxSkel
skel'
  interpBuiltin (TxOutByRef TxOutRef
o) = TxOutRef
-> StateT
     [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) (Maybe TxOut)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxOut)
txOutByRef TxOutRef
o
  interpBuiltin MockChainBuiltin a
GetCurrentSlot = StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) Slot
forall (m :: * -> *). MonadBlockChainWithoutValidation m => m Slot
currentSlot
  interpBuiltin (AwaitSlot Slot
s) = Slot
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) Slot
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
Slot -> m Slot
awaitSlot Slot
s
  interpBuiltin (DatumFromHash DatumHash
h) = DatumHash
-> StateT
     [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) (Maybe Datum)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
DatumHash -> m (Maybe Datum)
datumFromHash DatumHash
h
  interpBuiltin (ValidatorFromHash ValidatorHash
h) = ValidatorHash
-> StateT
     [Ltl (UntypedTweak (MockChainT []))]
     (MockChainT [])
     (Maybe (Versioned Validator))
forall (m :: * -> *).
MonadBlockChainBalancing m =>
ValidatorHash -> m (Maybe (Versioned Validator))
validatorFromHash ValidatorHash
h
  interpBuiltin MockChainBuiltin a
AllUtxos = StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
StateT
  [Ltl (UntypedTweak (MockChainT []))]
  (MockChainT [])
  [(TxOutRef, TxOut)]
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m [(TxOutRef, TxOut)]
allUtxos
  interpBuiltin (UtxosAt Address
address) = Address
-> StateT
     [Ltl (UntypedTweak (MockChainT []))]
     (MockChainT [])
     [(TxOutRef, TxOut)]
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Address -> m [(TxOutRef, TxOut)]
utxosAt Address
address
  interpBuiltin MockChainBuiltin a
Empty = StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall a.
StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  interpBuiltin (Alt StagedMockChain a
l StagedMockChain a
r) = StagedMockChain a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall modification (builtin :: * -> *) (m :: * -> *) a.
InterpLtl modification builtin m =>
Staged (LtlOp modification builtin) a
-> StateT [Ltl modification] m a
interpLtl StagedMockChain a
l StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall a.
StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` StagedMockChain a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall modification (builtin :: * -> *) (m :: * -> *) a.
InterpLtl modification builtin m =>
Staged (LtlOp modification builtin) a
-> StateT [Ltl modification] m a
interpLtl StagedMockChain a
r
  interpBuiltin (Fail String
msg) = String
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall a.
String
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg
  interpBuiltin (ThrowError MockChainError
err) = MockChainError
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall a.
MockChainError
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MockChainError
err
  interpBuiltin (CatchError StagedMockChain a
act MockChainError -> StagedMockChain a
handler) = StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
-> (MockChainError
    -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a)
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall a.
StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
-> (MockChainError
    -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a)
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (StagedMockChain a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall modification (builtin :: * -> *) (m :: * -> *) a.
InterpLtl modification builtin m =>
Staged (LtlOp modification builtin) a
-> StateT [Ltl modification] m a
interpLtl StagedMockChain a
act) (StagedMockChain a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall modification (builtin :: * -> *) (m :: * -> *) a.
InterpLtl modification builtin m =>
Staged (LtlOp modification builtin) a
-> StateT [Ltl modification] m a
interpLtl (StagedMockChain a
 -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a)
-> (MockChainError -> StagedMockChain a)
-> MockChainError
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockChainError -> StagedMockChain a
handler)
  interpBuiltin (LogEvent MockChainLogEntry
entry) = MockChainLogEntry
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent MockChainLogEntry
entry

-- ** Helpers to run tweaks for use in tests for tweaks

runTweak :: Tweak InterpMockChain a -> TxSkel -> [MockChainReturn a TxSkel]
runTweak :: forall a.
Tweak (MockChainT []) a -> TxSkel -> [MockChainReturn a TxSkel]
runTweak = InitialDistribution
-> Tweak (MockChainT []) a -> TxSkel -> [MockChainReturn a TxSkel]
forall a.
InitialDistribution
-> Tweak (MockChainT []) a -> TxSkel -> [MockChainReturn a TxSkel]
runTweakFrom InitialDistribution
forall a. Default a => a
def

runTweakFrom :: InitialDistribution -> Tweak InterpMockChain a -> TxSkel -> [MockChainReturn a TxSkel]
runTweakFrom :: forall a.
InitialDistribution
-> Tweak (MockChainT []) a -> TxSkel -> [MockChainReturn a TxSkel]
runTweakFrom InitialDistribution
initDist Tweak (MockChainT []) a
tweak = (MockChainReturn (a, TxSkel) UtxoState -> MockChainReturn a TxSkel)
-> [MockChainReturn (a, TxSkel) UtxoState]
-> [MockChainReturn a TxSkel]
forall a b. (a -> b) -> [a] -> [b]
map ((Either MockChainError ((a, TxSkel), UtxoState)
 -> Either MockChainError (a, TxSkel))
-> MockChainReturn (a, TxSkel) UtxoState
-> MockChainReturn a TxSkel
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((((a, TxSkel), UtxoState) -> (a, TxSkel))
-> Either MockChainError ((a, TxSkel), UtxoState)
-> Either MockChainError (a, TxSkel)
forall b c d. (b -> c) -> Either d b -> Either d c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right ((a, TxSkel), UtxoState) -> (a, TxSkel)
forall a b. (a, b) -> a
fst)) ([MockChainReturn (a, TxSkel) UtxoState]
 -> [MockChainReturn a TxSkel])
-> (TxSkel -> [MockChainReturn (a, TxSkel) UtxoState])
-> TxSkel
-> [MockChainReturn a TxSkel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitialDistribution
-> MockChainT [] (a, TxSkel)
-> [MockChainReturn (a, TxSkel) UtxoState]
forall (m :: * -> *) a.
Monad m =>
InitialDistribution
-> MockChainT m a -> m (MockChainReturn a UtxoState)
runMockChainTFrom InitialDistribution
initDist (MockChainT [] (a, TxSkel)
 -> [MockChainReturn (a, TxSkel) UtxoState])
-> (TxSkel -> MockChainT [] (a, TxSkel))
-> TxSkel
-> [MockChainReturn (a, TxSkel) UtxoState]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tweak (MockChainT []) a -> TxSkel -> MockChainT [] (a, TxSkel)
forall (m :: * -> *) a.
MonadPlus m =>
Tweak m a -> TxSkel -> m (a, TxSkel)
runTweakInChain Tweak (MockChainT []) a
tweak

-- ** Modalities

-- | A modal mock chain is a mock chain that allows us to use LTL modifications
-- with 'Tweak's
type MonadModalBlockChain m = (MonadBlockChain m, MonadModal m, Modification m ~ UntypedTweak InterpMockChain)

-- | Apply a 'Tweak' to some transaction in the given Trace. The tweak must
-- apply at least once.
somewhere :: (MonadModalBlockChain m) => Tweak InterpMockChain b -> m a -> m a
somewhere :: forall (m :: * -> *) b a.
MonadModalBlockChain m =>
Tweak (MockChainT []) b -> m a -> m a
somewhere = Ltl (Modification m) -> m a -> m a
Ltl (UntypedTweak (MockChainT [])) -> m a -> m a
forall a. Ltl (Modification m) -> m a -> m a
forall (m :: * -> *) a.
MonadModal m =>
Ltl (Modification m) -> m a -> m a
modifyLtl (Ltl (UntypedTweak (MockChainT [])) -> m a -> m a)
-> (Tweak (MockChainT []) b -> Ltl (UntypedTweak (MockChainT [])))
-> Tweak (MockChainT []) b
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ltl (UntypedTweak (MockChainT []))
-> Ltl (UntypedTweak (MockChainT []))
-> Ltl (UntypedTweak (MockChainT []))
forall a. Ltl a -> Ltl a -> Ltl a
LtlUntil Ltl (UntypedTweak (MockChainT []))
forall a. Ltl a
LtlTruth (Ltl (UntypedTweak (MockChainT []))
 -> Ltl (UntypedTweak (MockChainT [])))
-> (Tweak (MockChainT []) b -> Ltl (UntypedTweak (MockChainT [])))
-> Tweak (MockChainT []) b
-> Ltl (UntypedTweak (MockChainT []))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UntypedTweak (MockChainT []) -> Ltl (UntypedTweak (MockChainT []))
forall a. a -> Ltl a
LtlAtom (UntypedTweak (MockChainT [])
 -> Ltl (UntypedTweak (MockChainT [])))
-> (Tweak (MockChainT []) b -> UntypedTweak (MockChainT []))
-> Tweak (MockChainT []) b
-> Ltl (UntypedTweak (MockChainT []))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tweak (MockChainT []) b -> UntypedTweak (MockChainT [])
forall (m :: * -> *) a. Tweak m a -> UntypedTweak m
UntypedTweak

-- | Apply a 'Tweak' to every transaction in a given trace. This is also
-- successful if there are no transactions at all.
everywhere :: (MonadModalBlockChain m) => Tweak InterpMockChain b -> m a -> m a
everywhere :: forall (m :: * -> *) b a.
MonadModalBlockChain m =>
Tweak (MockChainT []) b -> m a -> m a
everywhere = Ltl (Modification m) -> m a -> m a
Ltl (UntypedTweak (MockChainT [])) -> m a -> m a
forall a. Ltl (Modification m) -> m a -> m a
forall (m :: * -> *) a.
MonadModal m =>
Ltl (Modification m) -> m a -> m a
modifyLtl (Ltl (UntypedTweak (MockChainT [])) -> m a -> m a)
-> (Tweak (MockChainT []) b -> Ltl (UntypedTweak (MockChainT [])))
-> Tweak (MockChainT []) b
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ltl (UntypedTweak (MockChainT []))
-> Ltl (UntypedTweak (MockChainT []))
-> Ltl (UntypedTweak (MockChainT []))
forall a. Ltl a -> Ltl a -> Ltl a
LtlRelease Ltl (UntypedTweak (MockChainT []))
forall a. Ltl a
LtlFalsity (Ltl (UntypedTweak (MockChainT []))
 -> Ltl (UntypedTweak (MockChainT [])))
-> (Tweak (MockChainT []) b -> Ltl (UntypedTweak (MockChainT [])))
-> Tweak (MockChainT []) b
-> Ltl (UntypedTweak (MockChainT []))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UntypedTweak (MockChainT []) -> Ltl (UntypedTweak (MockChainT []))
forall a. a -> Ltl a
LtlAtom (UntypedTweak (MockChainT [])
 -> Ltl (UntypedTweak (MockChainT [])))
-> (Tweak (MockChainT []) b -> UntypedTweak (MockChainT []))
-> Tweak (MockChainT []) b
-> Ltl (UntypedTweak (MockChainT []))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tweak (MockChainT []) b -> UntypedTweak (MockChainT [])
forall (m :: * -> *) a. Tweak m a -> UntypedTweak m
UntypedTweak

-- | Apply a 'Tweak' to the (0-indexed) nth transaction in a given
-- trace. Successful when this transaction exists and can be modified.
there :: (MonadModalBlockChain m) => Integer -> Tweak InterpMockChain b -> m a -> m a
there :: forall (m :: * -> *) b a.
MonadModalBlockChain m =>
Integer -> Tweak (MockChainT []) b -> m a -> m a
there Integer
n = Ltl (Modification m) -> m a -> m a
Ltl (UntypedTweak (MockChainT [])) -> m a -> m a
forall a. Ltl (Modification m) -> m a -> m a
forall (m :: * -> *) a.
MonadModal m =>
Ltl (Modification m) -> m a -> m a
modifyLtl (Ltl (UntypedTweak (MockChainT [])) -> m a -> m a)
-> (Tweak (MockChainT []) b -> Ltl (UntypedTweak (MockChainT [])))
-> Tweak (MockChainT []) b
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer
-> Tweak (MockChainT []) b -> Ltl (UntypedTweak (MockChainT []))
forall {t} {m :: * -> *} {a}.
(Eq t, Num t) =>
t -> Tweak m a -> Ltl (UntypedTweak m)
mkLtlFormula Integer
n
  where
    mkLtlFormula :: t -> Tweak m a -> Ltl (UntypedTweak m)
mkLtlFormula t
x =
      if t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0
        then UntypedTweak m -> Ltl (UntypedTweak m)
forall a. a -> Ltl a
LtlAtom (UntypedTweak m -> Ltl (UntypedTweak m))
-> (Tweak m a -> UntypedTweak m)
-> Tweak m a
-> Ltl (UntypedTweak m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tweak m a -> UntypedTweak m
forall (m :: * -> *) a. Tweak m a -> UntypedTweak m
UntypedTweak
        else Ltl (UntypedTweak m) -> Ltl (UntypedTweak m)
forall a. Ltl a -> Ltl a
LtlNext (Ltl (UntypedTweak m) -> Ltl (UntypedTweak m))
-> (Tweak m a -> Ltl (UntypedTweak m))
-> Tweak m a
-> Ltl (UntypedTweak m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Tweak m a -> Ltl (UntypedTweak m)
mkLtlFormula (t
x t -> t -> t
forall a. Num a => a -> a -> a
- t
1)

-- | Apply a 'Tweak' to the next transaction in the given trace. The order of
-- arguments is reversed compared to 'somewhere' and 'everywhere', because that
-- enables an idiom like
--
-- > do ...
-- >    endpoint arguments `withTweak` someModification
-- >    ...
--
-- where @endpoint@ builds and validates a single transaction depending on the
-- given @arguments@. Then `withTweak` says "I want to modify the transaction
-- returned by this endpoint in the following way".
withTweak :: (MonadModalBlockChain m) => m x -> Tweak InterpMockChain a -> m x
withTweak :: forall (m :: * -> *) x a.
MonadModalBlockChain m =>
m x -> Tweak (MockChainT []) a -> m x
withTweak = (Tweak (MockChainT []) a -> m x -> m x)
-> m x -> Tweak (MockChainT []) a -> m x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Integer -> Tweak (MockChainT []) a -> m x -> m x
forall (m :: * -> *) b a.
MonadModalBlockChain m =>
Integer -> Tweak (MockChainT []) b -> m a -> m a
there Integer
0)

-- * 'MonadBlockChain' and 'MonadMockChain' instances

singletonBuiltin :: builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin :: forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin builtin a
b = LtlOp modification builtin a
-> (a -> Staged (LtlOp modification builtin) a)
-> Staged (LtlOp modification builtin) a
forall (op :: * -> *) a1 a.
op a1 -> (a1 -> Staged op a) -> Staged op a
Instr (builtin a -> LtlOp modification builtin a
forall (builtin :: * -> *) a modification.
builtin a -> LtlOp modification builtin a
Builtin builtin a
b) a -> Staged (LtlOp modification builtin) a
forall a (op :: * -> *). a -> Staged op a
Return

instance MonadError MockChainError StagedMockChain where
  throwError :: forall a. MockChainError -> StagedMockChain a
throwError = MockChainBuiltin a -> Staged MockChainOp a
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin a -> Staged MockChainOp a)
-> (MockChainError -> MockChainBuiltin a)
-> MockChainError
-> Staged MockChainOp a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockChainError -> MockChainBuiltin a
forall a. MockChainError -> MockChainBuiltin a
ThrowError
  catchError :: forall a.
StagedMockChain a
-> (MockChainError -> StagedMockChain a) -> StagedMockChain a
catchError StagedMockChain a
act MockChainError -> StagedMockChain a
handler = MockChainBuiltin a -> StagedMockChain a
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin a -> StagedMockChain a)
-> MockChainBuiltin a -> StagedMockChain a
forall a b. (a -> b) -> a -> b
$ StagedMockChain a
-> (MockChainError -> StagedMockChain a) -> MockChainBuiltin a
forall a.
StagedMockChain a
-> (MockChainError -> StagedMockChain a) -> MockChainBuiltin a
CatchError StagedMockChain a
act MockChainError -> StagedMockChain a
handler

instance MonadBlockChainBalancing StagedMockChain where
  getParams :: StagedMockChain Params
getParams = MockChainBuiltin Params -> StagedMockChain Params
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin MockChainBuiltin Params
GetParams
  datumFromHash :: DatumHash -> StagedMockChain (Maybe Datum)
datumFromHash = MockChainBuiltin (Maybe Datum) -> StagedMockChain (Maybe Datum)
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin (Maybe Datum) -> StagedMockChain (Maybe Datum))
-> (DatumHash -> MockChainBuiltin (Maybe Datum))
-> DatumHash
-> StagedMockChain (Maybe Datum)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatumHash -> MockChainBuiltin (Maybe Datum)
DatumFromHash
  txOutByRef :: TxOutRef -> StagedMockChain (Maybe TxOut)
txOutByRef = MockChainBuiltin (Maybe TxOut) -> StagedMockChain (Maybe TxOut)
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin (Maybe TxOut) -> StagedMockChain (Maybe TxOut))
-> (TxOutRef -> MockChainBuiltin (Maybe TxOut))
-> TxOutRef
-> StagedMockChain (Maybe TxOut)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> MockChainBuiltin (Maybe TxOut)
TxOutByRef
  utxosAt :: Address -> StagedMockChain [(TxOutRef, TxOut)]
utxosAt = MockChainBuiltin [(TxOutRef, TxOut)]
-> StagedMockChain [(TxOutRef, TxOut)]
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin [(TxOutRef, TxOut)]
 -> StagedMockChain [(TxOutRef, TxOut)])
-> (Address -> MockChainBuiltin [(TxOutRef, TxOut)])
-> Address
-> StagedMockChain [(TxOutRef, TxOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Address -> MockChainBuiltin [(TxOutRef, TxOut)]
UtxosAt
  validatorFromHash :: ValidatorHash -> StagedMockChain (Maybe (Versioned Validator))
validatorFromHash = MockChainBuiltin (Maybe (Versioned Validator))
-> StagedMockChain (Maybe (Versioned Validator))
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin (Maybe (Versioned Validator))
 -> StagedMockChain (Maybe (Versioned Validator)))
-> (ValidatorHash
    -> MockChainBuiltin (Maybe (Versioned Validator)))
-> ValidatorHash
-> StagedMockChain (Maybe (Versioned Validator))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorHash -> MockChainBuiltin (Maybe (Versioned Validator))
ValidatorFromHash
  logEvent :: MockChainLogEntry -> StagedMockChain ()
logEvent = MockChainBuiltin () -> StagedMockChain ()
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin () -> StagedMockChain ())
-> (MockChainLogEntry -> MockChainBuiltin ())
-> MockChainLogEntry
-> StagedMockChain ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockChainLogEntry -> MockChainBuiltin ()
LogEvent

instance MonadBlockChainWithoutValidation StagedMockChain where
  allUtxos :: StagedMockChain [(TxOutRef, TxOut)]
allUtxos = MockChainBuiltin [(TxOutRef, TxOut)]
-> StagedMockChain [(TxOutRef, TxOut)]
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin MockChainBuiltin [(TxOutRef, TxOut)]
AllUtxos
  setParams :: Params -> StagedMockChain ()
setParams = MockChainBuiltin () -> StagedMockChain ()
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin () -> StagedMockChain ())
-> (Params -> MockChainBuiltin ()) -> Params -> StagedMockChain ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> MockChainBuiltin ()
SetParams
  currentSlot :: StagedMockChain Slot
currentSlot = MockChainBuiltin Slot -> StagedMockChain Slot
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin MockChainBuiltin Slot
GetCurrentSlot
  awaitSlot :: Slot -> StagedMockChain Slot
awaitSlot = MockChainBuiltin Slot -> StagedMockChain Slot
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin Slot -> StagedMockChain Slot)
-> (Slot -> MockChainBuiltin Slot) -> Slot -> StagedMockChain Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slot -> MockChainBuiltin Slot
AwaitSlot

instance MonadBlockChain StagedMockChain where
  validateTxSkel :: TxSkel -> StagedMockChain CardanoTx
validateTxSkel = MockChainBuiltin CardanoTx -> StagedMockChain CardanoTx
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin CardanoTx -> StagedMockChain CardanoTx)
-> (TxSkel -> MockChainBuiltin CardanoTx)
-> TxSkel
-> StagedMockChain CardanoTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkel -> MockChainBuiltin CardanoTx
ValidateTxSkel