{-# 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,
    somewhere',
    runTweak,
    everywhere,
    everywhere',
    withTweak,
    there,
    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.Ltl.Combinators (always', delay', eventually')
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 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 'runMockChainTFromInitDist'.
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
  TxSkelOutByRef :: Api.TxOutRef -> MockChainBuiltin 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 :: (ToVScript s) => s -> MockChainBuiltin ()
  GetConstitutionScript :: MockChainBuiltin (Maybe VScript)
  GetCurrentReward :: (Script.ToCredential c) => c -> MockChainBuiltin (Maybe Api.Lovelace)
  ForceOutputs :: [TxSkelOut] -> MockChainBuiltin [Api.TxOutRef]
  -- 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 (TxSkelOutByRef TxOutRef
o) = TxOutRef
-> StateT
     [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxOutRef -> m TxSkelOut
txSkelOutByRef 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.
ToVScript s =>
s -> StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) ()
forall (m :: * -> *) s.
(MonadBlockChainWithoutValidation m, ToVScript s) =>
s -> m ()
setConstitutionScript s
script
  interpBuiltin MockChainBuiltin a
GetConstitutionScript = StateT [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) a
StateT
  [Ltl (UntypedTweak (MockChainT []))]
  (MockChainT [])
  (Maybe VScript)
forall (m :: * -> *).
MonadBlockChainWithoutValidation m =>
m (Maybe VScript)
getConstitutionScript
  interpBuiltin (GetCurrentReward c
cred) = c
-> StateT
     [Ltl (UntypedTweak (MockChainT []))]
     (MockChainT [])
     (Maybe Lovelace)
forall c.
ToCredential c =>
c
-> StateT
     [Ltl (UntypedTweak (MockChainT []))]
     (MockChainT [])
     (Maybe Lovelace)
forall (m :: * -> *) c.
(MonadBlockChainWithoutValidation m, ToCredential c) =>
c -> m (Maybe Lovelace)
getCurrentReward c
cred
  interpBuiltin (ForceOutputs [TxSkelOut]
outs) = [TxSkelOut]
-> StateT
     [Ltl (UntypedTweak (MockChainT []))] (MockChainT []) [TxOutRef]
forall (m :: * -> *).
MonadBlockChain m =>
[TxSkelOut] -> m [TxOutRef]
forceOutputs [TxSkelOut]
outs

-- ** 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)
runMockChainTFromInitDist 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)

fromTweak :: Tweak m a -> Ltl (UntypedTweak m)
fromTweak :: forall (m :: * -> *) a. Tweak m a -> Ltl (UntypedTweak m)
fromTweak = 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

-- | 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 (m :: * -> *) a.
MonadModal m =>
Ltl (Modification m) -> m a -> m a
somewhere' (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
. Tweak (MockChainT []) b -> Ltl (UntypedTweak (MockChainT []))
forall (m :: * -> *) a. Tweak m a -> Ltl (UntypedTweak m)
fromTweak

-- | Apply an Ltl modification somewhere in the given Trace. The modification
-- must apply at least once.
somewhere' :: (MonadModal m) => Ltl (Modification m) -> m a -> m a
somewhere' :: forall (m :: * -> *) a.
MonadModal m =>
Ltl (Modification m) -> m a -> m a
somewhere' = Ltl (Modification m) -> 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 (Modification m) -> m a -> m a)
-> (Ltl (Modification m) -> Ltl (Modification m))
-> Ltl (Modification m)
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ltl (Modification m) -> Ltl (Modification m)
forall a. Ltl a -> Ltl a
eventually'

-- | 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 (m :: * -> *) a.
MonadModal m =>
Ltl (Modification m) -> m a -> m a
everywhere' (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
. Tweak (MockChainT []) b -> Ltl (UntypedTweak (MockChainT []))
forall (m :: * -> *) a. Tweak m a -> Ltl (UntypedTweak m)
fromTweak

-- | Apply an Ltl modification everywhere it can be (including nowhere if it
-- does not apply). If the modification branches, this will branch at every
-- location the modification can be applied.
everywhere' :: (MonadModal m) => Ltl (Modification m) -> m a -> m a
everywhere' :: forall (m :: * -> *) a.
MonadModal m =>
Ltl (Modification m) -> m a -> m a
everywhere' = Ltl (Modification m) -> 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 (Modification m) -> m a -> m a)
-> (Ltl (Modification m) -> Ltl (Modification m))
-> Ltl (Modification m)
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ltl (Modification m) -> Ltl (Modification m)
forall a. Ltl a -> Ltl a
always'

-- | 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 = Integer -> Ltl (Modification m) -> m a -> m a
forall (m :: * -> *) a.
MonadModal m =>
Integer -> Ltl (Modification m) -> m a -> m a
there' Integer
n (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
. Tweak (MockChainT []) b -> Ltl (UntypedTweak (MockChainT []))
forall (m :: * -> *) a. Tweak m a -> Ltl (UntypedTweak m)
fromTweak

-- | Apply an Ltl modification to the (0-indexed) nth transaction in a
-- given trace. Successful when this transaction exists and can be modified.
--
-- See also `Cooked.Tweak.Labels.labelled'` to select transactions based on
-- labels instead of their order.
there' :: (MonadModal m) => Integer -> Ltl (Modification m) -> m a -> m a
there' :: forall (m :: * -> *) a.
MonadModal m =>
Integer -> Ltl (Modification m) -> m a -> m a
there' Integer
n = Ltl (Modification m) -> 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 (Modification m) -> m a -> m a)
-> (Ltl (Modification m) -> Ltl (Modification m))
-> Ltl (Modification m)
-> m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Ltl (Modification m) -> Ltl (Modification m)
forall a. Integer -> Ltl a -> Ltl a
delay' Integer
n

-- | 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
  txSkelOutByRef :: TxOutRef -> StagedMockChain TxSkelOut
txSkelOutByRef = MockChainBuiltin TxSkelOut -> StagedMockChain TxSkelOut
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin TxSkelOut -> StagedMockChain TxSkelOut)
-> (TxOutRef -> MockChainBuiltin TxSkelOut)
-> TxOutRef
-> StagedMockChain TxSkelOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> MockChainBuiltin TxSkelOut
TxSkelOutByRef
  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. ToVScript 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. ToVScript c => c -> MockChainBuiltin ()
SetConstitutionScript
  getConstitutionScript :: StagedMockChain (Maybe VScript)
getConstitutionScript = MockChainBuiltin (Maybe VScript) -> StagedMockChain (Maybe VScript)
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin MockChainBuiltin (Maybe VScript)
GetConstitutionScript
  getCurrentReward :: forall c. ToCredential c => c -> StagedMockChain (Maybe Lovelace)
getCurrentReward = MockChainBuiltin (Maybe Lovelace)
-> StagedMockChain (Maybe Lovelace)
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin (Maybe Lovelace)
 -> StagedMockChain (Maybe Lovelace))
-> (c -> MockChainBuiltin (Maybe Lovelace))
-> c
-> StagedMockChain (Maybe Lovelace)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> MockChainBuiltin (Maybe Lovelace)
forall c. ToCredential c => c -> MockChainBuiltin (Maybe Lovelace)
GetCurrentReward

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
  forceOutputs :: [TxSkelOut] -> StagedMockChain [TxOutRef]
forceOutputs = MockChainBuiltin [TxOutRef] -> StagedMockChain [TxOutRef]
forall (builtin :: * -> *) a modification.
builtin a -> Staged (LtlOp modification builtin) a
singletonBuiltin (MockChainBuiltin [TxOutRef] -> StagedMockChain [TxOutRef])
-> ([TxSkelOut] -> MockChainBuiltin [TxOutRef])
-> [TxSkelOut]
-> StagedMockChain [TxOutRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxSkelOut] -> MockChainBuiltin [TxOutRef]
ForceOutputs