{-# 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,
    MockChainBuiltin,
    runTweakFrom,
    MonadModalBlockChain,
    InterpMockChain,
    somewhere,
    runTweak,
    everywhere,
    withTweak,
    there,
  )
where

import Cardano.Node.Emulator qualified as Emulator
import Control.Applicative
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.Pretty.Hashable
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.Address qualified as Script
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

-- | Same as 'interpretAndRunWith' but using 'runMockChainT' as the default way
-- to run the computation.
interpretAndRun :: StagedMockChain a -> [MockChainReturn a]
interpretAndRun :: forall a. StagedMockChain a -> [MockChainReturn a]
interpretAndRun = (forall (m :: * -> *).
 Monad m =>
 MockChainT m a -> m (MockChainReturn a))
-> StagedMockChain a -> [MockChainReturn a]
forall a res.
(forall (m :: * -> *). Monad m => MockChainT m a -> m res)
-> StagedMockChain a -> [res]
interpretAndRunWith MockChainT m a -> m (MockChainReturn a)
forall (m :: * -> *).
Monad m =>
MockChainT m a -> m (MockChainReturn a)
forall (m :: * -> *) a.
Monad m =>
MockChainT m a -> m (MockChainReturn a)
runMockChainT

-- | The semantic domain in which 'StagedMockChain' gets interpreted
type InterpMockChain = MockChainT []

-- | The 'interpret' function gives semantics to our traces. One
-- 'StagedMockChain' computation yields a potential list of 'MockChainT'
-- computations.
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

-- | Abstract representation of all the builtin functions of a 'MonadBlockChain'
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 TxSkelOut)
  WaitNSlots :: (Integral i) => i -> MockChainBuiltin Ledger.Slot
  AllUtxos :: MockChainBuiltin [(Api.TxOutRef, TxSkelOut)]
  UtxosAt :: (Script.ToAddress a) => a -> MockChainBuiltin [(Api.TxOutRef, TxSkelOut)]
  LogEvent :: MockChainLogEntry -> MockChainBuiltin ()
  Define :: (ToHash a) => String -> a -> MockChainBuiltin a
  SetConstitutionScript :: (Script.ToVersioned Script.Script s) => s -> MockChainBuiltin ()
  GetConstitutionScript :: MockChainBuiltin (Maybe (Script.Versioned Script.Script))
  RegisterStakingCred :: (Script.ToCredential c) => c -> Integer -> Integer -> 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

-- | A 'StagedMockChain' is a mockchain that can be modified using
-- 'Cooked.Tweak.Common.Tweak's whenever a transaction is being sent for
-- validation. Selecting which transactions should be modified before going to
-- validations is done using 'Cooked.Ltl.Ltl' formulas.
type StagedMockChain = Staged (LtlOp (UntypedTweak InterpMockChain) MockChainBuiltin)

instance Alternative StagedMockChain where
  empty :: forall a. StagedMockChain a
empty = LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin a
-> (a
    -> Staged
         (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) a)
-> Staged (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) a
forall (op :: * -> *) a1 a.
op a1 -> (a1 -> Staged op a) -> Staged op a
Instr (MockChainBuiltin a
-> LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin a
forall (builtin :: * -> *) a modification.
builtin a -> LtlOp modification builtin a
Builtin MockChainBuiltin a
forall a. MockChainBuiltin a
Empty) a
-> Staged (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) a
forall a (op :: * -> *). a -> Staged op a
Return
  StagedMockChain a
a <|> :: forall a.
StagedMockChain a -> StagedMockChain a -> StagedMockChain a
<|> StagedMockChain a
b = LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin a
-> (a -> StagedMockChain a) -> StagedMockChain a
forall (op :: * -> *) a1 a.
op a1 -> (a1 -> Staged op a) -> Staged op a
Instr (MockChainBuiltin a
-> LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin 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 = LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin a
-> (a
    -> Staged
         (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) a)
-> Staged (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) a
forall (op :: * -> *) a1 a.
op a1 -> (a1 -> Staged op a) -> Staged op a
Instr (MockChainBuiltin a
-> LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin 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 (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) 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 TxSkelOut)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m (Maybe TxSkelOut)
txOutByRef TxOutRef
o
  interpBuiltin (WaitNSlots i
s) = i
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) Slot
forall i.
Integral i =>
i
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) Slot
forall (m :: * -> *) i.
(MonadBlockChainWithoutValidation m, Integral i) =>
i -> m Slot
waitNSlots i
s
  interpBuiltin MockChainBuiltin a
AllUtxos = StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
StateT
  [Ltl (UntypedTweak (MockChainT []))]
  (MockChainT [])
  [(TxOutRef, TxSkelOut)]
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m [(TxOutRef, TxSkelOut)]
allUtxos
  interpBuiltin (UtxosAt a
address) = a
-> StateT
     [Ltl (UntypedTweak (MockChainT []))]
     (MockChainT [])
     [(TxOutRef, TxSkelOut)]
forall a.
ToAddress a =>
a
-> StateT
     [Ltl (UntypedTweak (MockChainT []))]
     (MockChainT [])
     [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a.
(MonadBlockChainBalancing m, ToAddress a) =>
a -> m [(TxOutRef, TxSkelOut)]
utxosAt a
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
  interpBuiltin (Define String
name a
hash) = String
-> a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall a.
ToHash a =>
String
-> a
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
forall (m :: * -> *) a.
(MonadBlockChainWithoutValidation m, ToHash a) =>
String -> a -> m a
define String
name a
hash
  interpBuiltin (SetConstitutionScript s
script) = s -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) ()
forall s.
ToVersioned Script s =>
s -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) ()
forall (m :: * -> *) s.
(MonadBlockChainWithoutValidation m, ToVersioned Script s) =>
s -> m ()
setConstitutionScript s
script
  interpBuiltin MockChainBuiltin a
GetConstitutionScript = StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
StateT
  [Ltl (UntypedTweak (MockChainT []))]
  (MockChainT [])
  (Maybe (Versioned Script))
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m (Maybe (Versioned Script))
getConstitutionScript
  interpBuiltin (RegisterStakingCred c
cred Integer
reward Integer
deposit) = c
-> Integer
-> Integer
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) ()
forall c.
ToCredential c =>
c
-> Integer
-> Integer
-> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) ()
forall (m :: * -> *) c.
(MonadBlockChainWithoutValidation m, ToCredential c) =>
c -> Integer -> Integer -> m ()
registerStakingCred c
cred Integer
reward Integer
deposit

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

-- | Runs a 'Tweak' from a given 'TxSkel' within a mockchain
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

-- | Runs a 'Tweak' from a given 'TxSkel' and 'InitialDistribution' within a
-- mockchain
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 = InitialDistribution
-> MockChainT [] (a, TxSkel) -> [MockChainReturn (a, TxSkel)]
forall (m :: * -> *) a.
Monad m =>
InitialDistribution -> MockChainT m a -> m (MockChainReturn a)
runMockChainTFrom InitialDistribution
initDist (MockChainT [] (a, TxSkel) -> [MockChainReturn (a, TxSkel)])
-> (TxSkel -> MockChainT [] (a, TxSkel))
-> TxSkel
-> [MockChainReturn (a, TxSkel)]
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 (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) a
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin a
 -> Staged
      (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) a)
-> (MockChainError -> MockChainBuiltin a)
-> MockChainError
-> Staged (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) 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
  txOutByRef :: TxOutRef -> StagedMockChain (Maybe TxSkelOut)
txOutByRef = MockChainBuiltin (Maybe TxSkelOut)
-> StagedMockChain (Maybe TxSkelOut)
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin (Maybe TxSkelOut)
 -> StagedMockChain (Maybe TxSkelOut))
-> (TxOutRef -> MockChainBuiltin (Maybe TxSkelOut))
-> TxOutRef
-> StagedMockChain (Maybe TxSkelOut)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> MockChainBuiltin (Maybe TxSkelOut)
TxOutByRef
  utxosAt :: forall a.
ToAddress a =>
a -> StagedMockChain [(TxOutRef, TxSkelOut)]
utxosAt = MockChainBuiltin [(TxOutRef, TxSkelOut)]
-> StagedMockChain [(TxOutRef, TxSkelOut)]
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin [(TxOutRef, TxSkelOut)]
 -> StagedMockChain [(TxOutRef, TxSkelOut)])
-> (a -> MockChainBuiltin [(TxOutRef, TxSkelOut)])
-> a
-> StagedMockChain [(TxOutRef, TxSkelOut)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MockChainBuiltin [(TxOutRef, TxSkelOut)]
forall c.
ToAddress c =>
c -> MockChainBuiltin [(TxOutRef, TxSkelOut)]
UtxosAt
  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, TxSkelOut)]
allUtxos = MockChainBuiltin [(TxOutRef, TxSkelOut)]
-> StagedMockChain [(TxOutRef, TxSkelOut)]
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin MockChainBuiltin [(TxOutRef, TxSkelOut)]
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
  waitNSlots :: forall i. Integral i => i -> StagedMockChain Slot
waitNSlots = MockChainBuiltin Slot -> StagedMockChain Slot
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin Slot -> StagedMockChain Slot)
-> (i -> MockChainBuiltin Slot) -> i -> StagedMockChain Slot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> MockChainBuiltin Slot
forall c. Integral c => c -> MockChainBuiltin Slot
WaitNSlots
  define :: forall a. ToHash a => String -> a -> StagedMockChain a
define String
name = MockChainBuiltin a
-> Staged (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) a
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin a
 -> Staged
      (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) a)
-> (a -> MockChainBuiltin a)
-> a
-> Staged (LtlOp (UntypedTweak (MockChainT [])) MockChainBuiltin) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> MockChainBuiltin a
forall a. ToHash a => String -> a -> MockChainBuiltin a
Define String
name
  setConstitutionScript :: forall s. ToVersioned Script s => s -> StagedMockChain ()
setConstitutionScript = MockChainBuiltin () -> StagedMockChain ()
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin () -> StagedMockChain ())
-> (s -> MockChainBuiltin ()) -> s -> StagedMockChain ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> MockChainBuiltin ()
forall c. ToVersioned Script c => c -> MockChainBuiltin ()
SetConstitutionScript
  getConstitutionScript :: StagedMockChain (Maybe (Versioned Script))
getConstitutionScript = MockChainBuiltin (Maybe (Versioned Script))
-> StagedMockChain (Maybe (Versioned Script))
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin MockChainBuiltin (Maybe (Versioned Script))
GetConstitutionScript
  registerStakingCred :: forall c.
ToCredential c =>
c -> Integer -> Integer -> StagedMockChain ()
registerStakingCred c
cred Integer
reward Integer
deposit = MockChainBuiltin () -> StagedMockChain ()
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin () -> StagedMockChain ())
-> MockChainBuiltin () -> StagedMockChain ()
forall a b. (a -> b) -> a -> b
$ c -> Integer -> Integer -> MockChainBuiltin ()
forall c.
ToCredential c =>
c -> Integer -> Integer -> MockChainBuiltin ()
RegisterStakingCred c
cred Integer
reward Integer
deposit

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