{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Examples.STSTestUtils (
  initUTxO,
  mkGenesisTxIn,
  mkTxDats,
  mkSingleRedeemer,
  someAddr,
  someKeys,
  someScriptAddr,
  testBBODY,
  runLEDGER,
  testUTXOW,
  testUTXOWsubset,
  testUTXOspecialCase,
  trustMeP,
  alwaysFailsHash,
  alwaysSucceedsHash,
  timelockScript,
  timelockHash,
  timelockStakeCred,
) where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxoPredFailure (..),
  AlonzoUtxosPredFailure (..),
  AlonzoUtxowPredFailure (..),
 )
import Cardano.Ledger.Alonzo.Scripts (ExUnits (..))
import Cardano.Ledger.Alonzo.Tx (
  AlonzoTx (..),
  IsValid (..),
 )
import Cardano.Ledger.Alonzo.TxWits (Redeemers, TxDats (..))
import Cardano.Ledger.BHeaderView (BHeaderView (..))
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
import Cardano.Ledger.Babbage.Rules as Babbage (BabbageUtxowPredFailure (..))
import Cardano.Ledger.BaseTypes (mkTxIxPartial)
import Cardano.Ledger.Coin (Coin (..))
import qualified Cardano.Ledger.Conway.Rules as Conway
import Cardano.Ledger.Credential (Credential (..), StakeCredential)
import Cardano.Ledger.Plutus.Data (Data (..), hashData)
import Cardano.Ledger.Shelley.API (
  Block (..),
  LedgerEnv (..),
  LedgerState (..),
 )
import Cardano.Ledger.Shelley.Core hiding (TranslationError)
import Cardano.Ledger.Shelley.LedgerState (smartUTxOState)
import Cardano.Ledger.Shelley.Rules (
  BbodyEnv (..),
  ShelleyBbodyState,
  UtxoEnv (..),
 )
import Cardano.Ledger.Shelley.Rules as Shelley (ShelleyUtxowPredFailure (..))
import Cardano.Ledger.State
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.Val (inject)
import Cardano.Slotting.Slot (SlotNo (..))
import Control.State.Transition.Extended hiding (Assertion)
import Data.Default (Default (..))
import qualified Data.Foldable as F
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.Map.Strict as Map
import Data.MapExtras (fromElems)
import GHC.IsList (IsList (..))
import GHC.Natural (Natural)
import GHC.Stack
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Common (ToExpr, toExpr)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkAddr)
import Test.Cardano.Ledger.Era
import Test.Cardano.Ledger.Generic.Fields (TxOutField (..))
import Test.Cardano.Ledger.Generic.GenState (PlutusPurposeTag, mkRedeemersFromTags)
import Test.Cardano.Ledger.Generic.Proof
import Test.Cardano.Ledger.Generic.Scriptic (PostShelley, Scriptic (..), after, matchkey)
import Test.Cardano.Ledger.Generic.Updaters
import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
import Test.Cardano.Ledger.Shelley.Utils (RawSeed (..), mkKeyPair, mkKeyPair')
import Test.Tasty.HUnit (Assertion, assertFailure, (@?=))

-- =================================================================
-- =========================  Shared data  =========================
--   Data with specific semantics ("constants")
-- =================================================================

alwaysFailsHash :: forall era. Scriptic era => Natural -> Proof era -> ScriptHash
alwaysFailsHash :: forall era. Scriptic era => Natural -> Proof era -> ScriptHash
alwaysFailsHash Natural
n Proof era
pf = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ Natural -> Proof era -> Script era
forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
n Proof era
pf

alwaysSucceedsHash ::
  forall era.
  Scriptic era =>
  Natural ->
  Proof era ->
  ScriptHash
alwaysSucceedsHash :: forall era. Scriptic era => Natural -> Proof era -> ScriptHash
alwaysSucceedsHash Natural
n Proof era
pf = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ Natural -> Proof era -> Script era
forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
n Proof era
pf

someKeys :: forall era. Proof era -> KeyPair 'Payment
someKeys :: forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
_pf = VKey 'Payment -> SignKeyDSIGN DSIGN -> KeyPair 'Payment
forall (kd :: KeyRole). VKey kd -> SignKeyDSIGN DSIGN -> KeyPair kd
KeyPair VKey 'Payment
forall {kd :: KeyRole}. VKey kd
vk SignKeyDSIGN DSIGN
sk
  where
    (SignKeyDSIGN DSIGN
sk, VKey kd
vk) = RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
forall (kd :: KeyRole). RawSeed -> (SignKeyDSIGN DSIGN, VKey kd)
mkKeyPair (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
1 Word64
1 Word64
1 Word64
1 Word64
1)

someAddr :: forall era. Proof era -> Addr
someAddr :: forall era. Proof era -> Addr
someAddr Proof era
pf = KeyPair 'Payment -> KeyPair 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr (Proof era -> KeyPair 'Payment
forall era. Proof era -> KeyPair 'Payment
someKeys Proof era
pf) (KeyPair 'Staking -> Addr) -> KeyPair 'Staking -> Addr
forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' @'Staking (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
0 Word64
0 Word64
0 Word64
0 Word64
2)

-- Create an address with a given payment script.
someScriptAddr :: forall era. Scriptic era => Script era -> Addr
someScriptAddr :: forall era. Scriptic era => Script era -> Addr
someScriptAddr Script era
s = ScriptHash -> KeyPair 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr (Script era -> ScriptHash
forall era. EraScript era => Script era -> ScriptHash
hashScript Script era
s) (KeyPair 'Staking -> Addr) -> KeyPair 'Staking -> Addr
forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' @'Staking (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
0 Word64
0 Word64
0 Word64
0 Word64
0)

timelockScript :: PostShelley era => Int -> Proof era -> Script era
timelockScript :: forall era. PostShelley era => Int -> Proof era -> Script era
timelockScript Int
s = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript (NativeScript era -> Script era)
-> (Proof era -> NativeScript era) -> Proof era -> Script era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Proof era -> NativeScript era] -> Proof era -> NativeScript era
forall era.
Scriptic era =>
[Proof era -> NativeScript era] -> Proof era -> NativeScript era
allOf [Int -> Proof era -> NativeScript era
forall era. Scriptic era => Int -> Proof era -> NativeScript era
matchkey Int
1, Int -> Proof era -> NativeScript era
forall era. PostShelley era => Int -> Proof era -> NativeScript era
after (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s)]

timelockHash ::
  forall era.
  PostShelley era =>
  Int ->
  Proof era ->
  ScriptHash
timelockHash :: forall era. PostShelley era => Int -> Proof era -> ScriptHash
timelockHash Int
n Proof era
pf = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ Int -> Proof era -> Script era
forall era. PostShelley era => Int -> Proof era -> Script era
timelockScript Int
n Proof era
pf

timelockStakeCred :: PostShelley era => Proof era -> StakeCredential
timelockStakeCred :: forall era. PostShelley era => Proof era -> StakeCredential
timelockStakeCred Proof era
pf = ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (Int -> Proof era -> ScriptHash
forall era. PostShelley era => Int -> Proof era -> ScriptHash
timelockHash Int
2 Proof era
pf)

-- ======================================================================
-- ========================= Initial Utxo ===============================
-- ======================================================================

initUTxO :: forall era. (EraTxOut era, PostShelley era) => Proof era -> UTxO era
initUTxO :: forall era.
(EraTxOut era, PostShelley era) =>
Proof era -> UTxO era
initUTxO Proof era
pf =
  Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era) -> UTxO era)
-> Map TxIn (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$
    [(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut era)] -> Map TxIn (TxOut era))
-> [(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall a b. (a -> b) -> a -> b
$
      [ (HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
1, TxOut era
alwaysSucceedsOutput)
      , (HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
2, TxOut era
alwaysFailsOutput)
      ]
        [(TxIn, TxOut era)] -> [(TxIn, TxOut era)] -> [(TxIn, TxOut era)]
forall a. [a] -> [a] -> [a]
++ (Integer -> (TxIn, TxOut era)) -> [Integer] -> [(TxIn, TxOut era)]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
i -> (HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
i, TxOut era
someOutput)) [Integer
3 .. Integer
8]
        [(TxIn, TxOut era)] -> [(TxIn, TxOut era)] -> [(TxIn, TxOut era)]
forall a. [a] -> [a] -> [a]
++ (Integer -> (TxIn, TxOut era)) -> [Integer] -> [(TxIn, TxOut era)]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
i -> (HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
i, TxOut era
collateralOutput)) [Integer
11 .. Integer
18]
        [(TxIn, TxOut era)] -> [(TxIn, TxOut era)] -> [(TxIn, TxOut era)]
forall a. [a] -> [a] -> [a]
++ [ (HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
100, TxOut era
timelockOut)
           , (HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
101, TxOut era
unspendableOut)
           , (HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
102, TxOut era
alwaysSucceedsOutputV1)
           , (HasCallStack => Integer -> TxIn
Integer -> TxIn
mkGenesisTxIn Integer
103, TxOut era
nonScriptOutWithDatum)
           ]
  where
    alwaysSucceedsOutput :: TxOut era
alwaysSucceedsOutput =
      Proof era -> [TxOutField era] -> TxOut era
forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut
        Proof era
pf
        [ Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address (Script era -> Addr
forall era. Scriptic era => Script era -> Addr
someScriptAddr (Natural -> Proof era -> Script era
forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
3 Proof era
pf))
        , Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5000)
        , [DataHash] -> TxOutField era
forall era. [DataHash] -> TxOutField era
DHash' [Data era -> DataHash
forall era. Data era -> DataHash
hashData (Data era -> DataHash) -> Data era -> DataHash
forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data era
datumExample1 @era]
        ]
    alwaysFailsOutput :: TxOut era
alwaysFailsOutput =
      Proof era -> [TxOutField era] -> TxOut era
forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut
        Proof era
pf
        [ Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address (Script era -> Addr
forall era. Scriptic era => Script era -> Addr
someScriptAddr (Natural -> Proof era -> Script era
forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
0 Proof era
pf))
        , Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
3000)
        , [DataHash] -> TxOutField era
forall era. [DataHash] -> TxOutField era
DHash' [Data era -> DataHash
forall era. Data era -> DataHash
hashData (Data era -> DataHash) -> Data era -> DataHash
forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data era
datumExample2 @era]
        ]
    someOutput :: TxOut era
someOutput = Proof era -> [TxOutField era] -> TxOut era
forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address (Addr -> TxOutField era) -> Addr -> TxOutField era
forall a b. (a -> b) -> a -> b
$ Proof era -> Addr
forall era. Proof era -> Addr
someAddr Proof era
pf, Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1000)]
    collateralOutput :: TxOut era
collateralOutput = Proof era -> [TxOutField era] -> TxOut era
forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address (Addr -> TxOutField era) -> Addr -> TxOutField era
forall a b. (a -> b) -> a -> b
$ Proof era -> Addr
forall era. Proof era -> Addr
someAddr Proof era
pf, Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5)]
    timelockOut :: TxOut era
timelockOut = Proof era -> [TxOutField era] -> TxOut era
forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut Proof era
pf [Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address (Addr -> TxOutField era) -> Addr -> TxOutField era
forall a b. (a -> b) -> a -> b
$ Addr
timelockAddr, Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1)]
    timelockAddr :: Addr
timelockAddr = ScriptHash -> KeyPair 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
tlh (KeyPair 'Staking -> Addr) -> KeyPair 'Staking -> Addr
forall a b. (a -> b) -> a -> b
$ forall (kd :: KeyRole). RawSeed -> KeyPair kd
mkKeyPair' @'Staking (Word64 -> Word64 -> Word64 -> Word64 -> Word64 -> RawSeed
RawSeed Word64
0 Word64
0 Word64
0 Word64
0 Word64
2)
      where
        tlh :: ScriptHash
tlh = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ Int -> Script era
tls Int
0
        tls :: Int -> Script era
tls Int
s = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript (NativeScript era -> Script era) -> NativeScript era -> Script era
forall a b. (a -> b) -> a -> b
$ [Proof era -> NativeScript era] -> Proof era -> NativeScript era
forall era.
Scriptic era =>
[Proof era -> NativeScript era] -> Proof era -> NativeScript era
allOf [Int -> Proof era -> NativeScript era
forall era. Scriptic era => Int -> Proof era -> NativeScript era
matchkey Int
1, Int -> Proof era -> NativeScript era
forall era. PostShelley era => Int -> Proof era -> NativeScript era
after (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s)] Proof era
pf
    -- This output is unspendable since it is locked by a plutus script, but has no datum hash.
    unspendableOut :: TxOut era
unspendableOut =
      Proof era -> [TxOutField era] -> TxOut era
forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut
        Proof era
pf
        [ Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address (Script era -> Addr
forall era. Scriptic era => Script era -> Addr
someScriptAddr (Natural -> Proof era -> Script era
forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
3 Proof era
pf))
        , Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5000)
        ]
    alwaysSucceedsOutputV1 :: TxOut era
alwaysSucceedsOutputV1 =
      Proof era -> [TxOutField era] -> TxOut era
forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut
        Proof era
pf
        [ Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address (Script era -> Addr
forall era. Scriptic era => Script era -> Addr
someScriptAddr (Natural -> Proof era -> Script era
forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
3 Proof era
pf))
        , Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5000)
        , [DataHash] -> TxOutField era
forall era. [DataHash] -> TxOutField era
DHash' [Data era -> DataHash
forall era. Data era -> DataHash
hashData (Data era -> DataHash) -> Data era -> DataHash
forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data era
datumExample1 @era]
        ]
    nonScriptOutWithDatum :: TxOut era
nonScriptOutWithDatum =
      Proof era -> [TxOutField era] -> TxOut era
forall era. Proof era -> [TxOutField era] -> TxOut era
newTxOut
        Proof era
pf
        [ Addr -> TxOutField era
forall era. Addr -> TxOutField era
Address (Proof era -> Addr
forall era. Proof era -> Addr
someAddr Proof era
pf)
        , Value era -> TxOutField era
forall era. Value era -> TxOutField era
Amount (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1221)
        , [DataHash] -> TxOutField era
forall era. [DataHash] -> TxOutField era
DHash' [Data era -> DataHash
forall era. Data era -> DataHash
hashData (Data era -> DataHash) -> Data era -> DataHash
forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data era
datumExample1 @era]
        ]

datumExample1 :: Era era => Data era
datumExample1 :: forall era. Era era => Data era
datumExample1 = Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
123)

datumExample2 :: Era era => Data era
datumExample2 :: forall era. Era era => Data era
datumExample2 = Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
PV1.I Integer
0)

-- ======================================================================
-- ========================= Shared helper functions  ===================
-- ======================================================================

mkGenesisTxIn :: HasCallStack => Integer -> TxIn
mkGenesisTxIn :: HasCallStack => Integer -> TxIn
mkGenesisTxIn = TxId -> TxIx -> TxIn
TxIn TxId
genesisId (TxIx -> TxIn) -> (Integer -> TxIx) -> Integer -> TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Integer -> TxIx
Integer -> TxIx
mkTxIxPartial

mkTxDats :: Era era => Data era -> TxDats era
mkTxDats :: forall era. Era era => Data era -> TxDats era
mkTxDats Data era
d = Map DataHash (Data era) -> TxDats era
forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats (Map DataHash (Data era) -> TxDats era)
-> Map DataHash (Data era) -> TxDats era
forall a b. (a -> b) -> a -> b
$ DataHash -> Data era -> Map DataHash (Data era)
forall k a. k -> a -> Map k a
Map.singleton (Data era -> DataHash
forall era. Data era -> DataHash
hashData Data era
d) Data era
d

mkSingleRedeemer :: Proof era -> PlutusPurposeTag -> Data era -> Redeemers era
mkSingleRedeemer :: forall era.
Proof era -> PlutusPurposeTag -> Data era -> Redeemers era
mkSingleRedeemer Proof era
proof PlutusPurposeTag
tag Data era
datum =
  Proof era
-> [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
forall era.
Proof era
-> [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
mkRedeemersFromTags Proof era
proof [((PlutusPurposeTag
tag, Word32
0), (Data era
datum, Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
5000))]

trustMeP :: Proof era -> Bool -> Tx era -> Tx era
trustMeP :: forall era. Proof era -> Bool -> Tx era -> Tx era
trustMeP Proof era
Alonzo Bool
iv' (AlonzoTx TxBody AlonzoEra
b TxWits AlonzoEra
w IsValid
_ StrictMaybe (TxAuxData AlonzoEra)
m) = TxBody AlonzoEra
-> TxWits AlonzoEra
-> IsValid
-> StrictMaybe (TxAuxData AlonzoEra)
-> AlonzoTx AlonzoEra
forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx TxBody AlonzoEra
b TxWits AlonzoEra
w (Bool -> IsValid
IsValid Bool
iv') StrictMaybe (TxAuxData AlonzoEra)
m
trustMeP Proof era
Babbage Bool
iv' (AlonzoTx TxBody BabbageEra
b TxWits BabbageEra
w IsValid
_ StrictMaybe (TxAuxData BabbageEra)
m) = TxBody BabbageEra
-> TxWits BabbageEra
-> IsValid
-> StrictMaybe (TxAuxData BabbageEra)
-> AlonzoTx BabbageEra
forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx TxBody BabbageEra
b TxWits BabbageEra
w (Bool -> IsValid
IsValid Bool
iv') StrictMaybe (TxAuxData BabbageEra)
m
trustMeP Proof era
Conway Bool
iv' (AlonzoTx TxBody ConwayEra
b TxWits ConwayEra
w IsValid
_ StrictMaybe (TxAuxData ConwayEra)
m) = TxBody ConwayEra
-> TxWits ConwayEra
-> IsValid
-> StrictMaybe (TxAuxData ConwayEra)
-> AlonzoTx ConwayEra
forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx TxBody ConwayEra
b TxWits ConwayEra
w (Bool -> IsValid
IsValid Bool
iv') StrictMaybe (TxAuxData ConwayEra)
m
trustMeP Proof era
_ Bool
_ Tx era
tx = Tx era
tx

-- This implements a special rule to test that for ValidationTagMismatch. Rather than comparing the insides of
-- ValidationTagMismatch (which are complicated and depend on Plutus) we just note that both the computed
-- and expected are ValidationTagMismatch. Of course the 'path' to ValidationTagMismatch differs by Era.
-- so we need to case over the Era proof, to get the path correctly.
testBBODY ::
  (HasCallStack, EraTest era, Reflect era) =>
  WitRule "BBODY" era ->
  ShelleyBbodyState era ->
  Block BHeaderView era ->
  Either (NonEmpty (PredicateFailure (EraRule "BBODY" era))) (ShelleyBbodyState era) ->
  PParams era ->
  Assertion
testBBODY :: forall era.
(HasCallStack, EraTest era, Reflect era) =>
WitRule "BBODY" era
-> ShelleyBbodyState era
-> Block BHeaderView era
-> Either
     (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
     (ShelleyBbodyState era)
-> PParams era
-> Assertion
testBBODY wit :: WitRule "BBODY" era
wit@(BBODY Proof era
proof) ShelleyBbodyState era
initialSt Block BHeaderView era
block Either
  (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
  (ShelleyBbodyState era)
expected PParams era
pparams =
  let env :: BbodyEnv era
env = PParams era -> ChainAccountState -> BbodyEnv era
forall era. PParams era -> ChainAccountState -> BbodyEnv era
BbodyEnv PParams era
pparams ChainAccountState
forall a. Default a => a
def
   in case Proof era
proof of
        Proof era
Alonzo -> WitRule "BBODY" era
-> TRC (EraRule "BBODY" era)
-> (Either
      (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
      (State (EraRule "BBODY" era))
    -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "BBODY" era
wit ((Environment (AlonzoBBODY AlonzoEra),
 State (AlonzoBBODY AlonzoEra), Signal (AlonzoBBODY AlonzoEra))
-> TRC (AlonzoBBODY AlonzoEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (BbodyEnv era
Environment (AlonzoBBODY AlonzoEra)
env, State (AlonzoBBODY AlonzoEra)
ShelleyBbodyState era
initialSt, Block BHeaderView era
Signal (AlonzoBBODY AlonzoEra)
block)) ([Char]
-> Either
     (NonEmpty (AlonzoBbodyPredFailure AlonzoEra))
     (ShelleyBbodyState era)
-> Either
     (NonEmpty (AlonzoBbodyPredFailure AlonzoEra))
     (ShelleyBbodyState era)
-> Assertion
forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq y, ToExpr x, ToExpr y, HasCallStack) =>
[Char] -> Either (t x) y -> Either (t x) y -> Assertion
genericCont [Char]
"" Either
  (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
  (ShelleyBbodyState era)
Either
  (NonEmpty (AlonzoBbodyPredFailure AlonzoEra))
  (ShelleyBbodyState era)
expected)
        Proof era
Babbage -> WitRule "BBODY" era
-> TRC (EraRule "BBODY" era)
-> (Either
      (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
      (State (EraRule "BBODY" era))
    -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "BBODY" era
wit ((Environment (AlonzoBBODY BabbageEra),
 State (AlonzoBBODY BabbageEra), Signal (AlonzoBBODY BabbageEra))
-> TRC (AlonzoBBODY BabbageEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (BbodyEnv era
Environment (AlonzoBBODY BabbageEra)
env, State (AlonzoBBODY BabbageEra)
ShelleyBbodyState era
initialSt, Block BHeaderView era
Signal (AlonzoBBODY BabbageEra)
block)) ([Char]
-> Either
     (NonEmpty (AlonzoBbodyPredFailure BabbageEra))
     (ShelleyBbodyState era)
-> Either
     (NonEmpty (AlonzoBbodyPredFailure BabbageEra))
     (ShelleyBbodyState era)
-> Assertion
forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq y, ToExpr x, ToExpr y, HasCallStack) =>
[Char] -> Either (t x) y -> Either (t x) y -> Assertion
genericCont [Char]
"" Either
  (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
  (ShelleyBbodyState era)
Either
  (NonEmpty (AlonzoBbodyPredFailure BabbageEra))
  (ShelleyBbodyState era)
expected)
        Proof era
Conway -> WitRule "BBODY" era
-> TRC (EraRule "BBODY" era)
-> (Either
      (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
      (State (EraRule "BBODY" era))
    -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "BBODY" era
wit ((Environment (ConwayBBODY ConwayEra),
 State (ConwayBBODY ConwayEra), Signal (ConwayBBODY ConwayEra))
-> TRC (ConwayBBODY ConwayEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (BbodyEnv era
Environment (ConwayBBODY ConwayEra)
env, State (ConwayBBODY ConwayEra)
ShelleyBbodyState era
initialSt, Block BHeaderView era
Signal (ConwayBBODY ConwayEra)
block)) ([Char]
-> Either
     (NonEmpty (ConwayBbodyPredFailure ConwayEra))
     (ShelleyBbodyState era)
-> Either
     (NonEmpty (ConwayBbodyPredFailure ConwayEra))
     (ShelleyBbodyState era)
-> Assertion
forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq y, ToExpr x, ToExpr y, HasCallStack) =>
[Char] -> Either (t x) y -> Either (t x) y -> Assertion
genericCont [Char]
"" Either
  (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
  (ShelleyBbodyState era)
Either
  (NonEmpty (ConwayBbodyPredFailure ConwayEra))
  (ShelleyBbodyState era)
expected)
        Proof era
other -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> a
error ([Char]
"We cannot testBBODY in era " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Proof era -> [Char]
forall a. Show a => a -> [Char]
show Proof era
other)

testUTXOW ::
  forall era.
  ( Reflect era
  , HasCallStack
  ) =>
  WitRule "UTXOW" era ->
  UTxO era ->
  PParams era ->
  Tx era ->
  Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (State (EraRule "UTXOW" era)) ->
  Assertion

-- | Use an equality test on the expected and computed [PredicateFailure]
testUTXOW :: forall era.
(Reflect era, HasCallStack) =>
WitRule "UTXOW" era
-> UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
testUTXOW wit :: WitRule "UTXOW" era
wit@(UTXOW Proof era
Alonzo) UTxO era
utxo PParams era
p Tx era
tx =
  WitRule "UTXOW" era
-> (Either
      (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
      (State (EraRule "UTXOW" era))
    -> Either
         (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
         (State (EraRule "UTXOW" era))
    -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era) =>
WitRule "UTXOW" era
-> (Result era -> Result era -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Result era
-> Assertion
testUTXOWwith WitRule "UTXOW" era
wit ([Char]
-> Either
     (NonEmpty (AlonzoUtxowPredFailure AlonzoEra)) (UTxOState AlonzoEra)
-> Either
     (NonEmpty (AlonzoUtxowPredFailure AlonzoEra)) (UTxOState AlonzoEra)
-> Assertion
forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq y, ToExpr x, ToExpr y, HasCallStack) =>
[Char] -> Either (t x) y -> Either (t x) y -> Assertion
genericCont ((UTxO era, AlonzoTx AlonzoEra) -> [Char]
forall a. Show a => a -> [Char]
show (UTxO era
utxo, Tx era
AlonzoTx AlonzoEra
tx))) UTxO era
utxo PParams era
p Tx era
tx
testUTXOW wit :: WitRule "UTXOW" era
wit@(UTXOW Proof era
Babbage) UTxO era
utxo PParams era
p Tx era
tx = WitRule "UTXOW" era
-> (Either
      (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
      (State (EraRule "UTXOW" era))
    -> Either
         (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
         (State (EraRule "UTXOW" era))
    -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era) =>
WitRule "UTXOW" era
-> (Result era -> Result era -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Result era
-> Assertion
testUTXOWwith WitRule "UTXOW" era
wit ([Char]
-> Either
     (NonEmpty (BabbageUtxowPredFailure BabbageEra))
     (UTxOState BabbageEra)
-> Either
     (NonEmpty (BabbageUtxowPredFailure BabbageEra))
     (UTxOState BabbageEra)
-> Assertion
forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq y, ToExpr x, ToExpr y, HasCallStack) =>
[Char] -> Either (t x) y -> Either (t x) y -> Assertion
genericCont (AlonzoTx BabbageEra -> [Char]
forall a. Show a => a -> [Char]
show Tx era
AlonzoTx BabbageEra
tx)) UTxO era
utxo PParams era
p Tx era
tx
testUTXOW wit :: WitRule "UTXOW" era
wit@(UTXOW Proof era
Conway) UTxO era
utxo PParams era
p Tx era
tx = WitRule "UTXOW" era
-> (Either
      (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
      (State (EraRule "UTXOW" era))
    -> Either
         (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
         (State (EraRule "UTXOW" era))
    -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era) =>
WitRule "UTXOW" era
-> (Result era -> Result era -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Result era
-> Assertion
testUTXOWwith WitRule "UTXOW" era
wit ([Char]
-> Either
     (NonEmpty (ConwayUtxowPredFailure ConwayEra)) (UTxOState ConwayEra)
-> Either
     (NonEmpty (ConwayUtxowPredFailure ConwayEra)) (UTxOState ConwayEra)
-> Assertion
forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq y, ToExpr x, ToExpr y, HasCallStack) =>
[Char] -> Either (t x) y -> Either (t x) y -> Assertion
genericCont (AlonzoTx ConwayEra -> [Char]
forall a. Show a => a -> [Char]
show Tx era
AlonzoTx ConwayEra
tx)) UTxO era
utxo PParams era
p Tx era
tx
testUTXOW (UTXOW Proof era
other) UTxO era
_ PParams era
_ Tx era
_ = [Char]
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot use testUTXOW in era " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Proof era -> [Char]
forall a. Show a => a -> [Char]
show Proof era
other)

testUTXOWsubset
  , testUTXOspecialCase ::
    forall era.
    ( Reflect era
    , HasCallStack
    ) =>
    WitRule "UTXOW" era ->
    UTxO era ->
    PParams era ->
    Tx era ->
    Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (State (EraRule "UTXOW" era)) ->
    Assertion

-- | Use a subset test on the expected and computed [PredicateFailure]
testUTXOWsubset :: forall era.
(Reflect era, HasCallStack) =>
WitRule "UTXOW" era
-> UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
testUTXOWsubset wit :: WitRule "UTXOW" era
wit@(UTXOW Proof era
Alonzo) UTxO era
utxo = WitRule "UTXOW" era
-> (Either
      (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
      (State (EraRule "UTXOW" era))
    -> Either
         (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
         (State (EraRule "UTXOW" era))
    -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era) =>
WitRule "UTXOW" era
-> (Result era -> Result era -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Result era
-> Assertion
testUTXOWwith WitRule "UTXOW" era
wit Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (State (EraRule "UTXOW" era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
Either
  (NonEmpty (AlonzoUtxowPredFailure AlonzoEra)) (UTxOState AlonzoEra)
-> Either
     (NonEmpty (AlonzoUtxowPredFailure AlonzoEra)) (UTxOState AlonzoEra)
-> Assertion
forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq x, Eq y, ToExpr x, ToExpr y, Show (t x),
 Show y) =>
Either (t x) y -> Either (t x) y -> Assertion
subsetCont UTxO era
utxo
testUTXOWsubset wit :: WitRule "UTXOW" era
wit@(UTXOW Proof era
Babbage) UTxO era
utxo = WitRule "UTXOW" era
-> (Either
      (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
      (State (EraRule "UTXOW" era))
    -> Either
         (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
         (State (EraRule "UTXOW" era))
    -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era) =>
WitRule "UTXOW" era
-> (Result era -> Result era -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Result era
-> Assertion
testUTXOWwith WitRule "UTXOW" era
wit Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (State (EraRule "UTXOW" era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
Either
  (NonEmpty (BabbageUtxowPredFailure BabbageEra))
  (UTxOState BabbageEra)
-> Either
     (NonEmpty (BabbageUtxowPredFailure BabbageEra))
     (UTxOState BabbageEra)
-> Assertion
forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq x, Eq y, ToExpr x, ToExpr y, Show (t x),
 Show y) =>
Either (t x) y -> Either (t x) y -> Assertion
subsetCont UTxO era
utxo
testUTXOWsubset wit :: WitRule "UTXOW" era
wit@(UTXOW Proof era
Conway) UTxO era
utxo = WitRule "UTXOW" era
-> (Either
      (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
      (State (EraRule "UTXOW" era))
    -> Either
         (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
         (State (EraRule "UTXOW" era))
    -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era) =>
WitRule "UTXOW" era
-> (Result era -> Result era -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Result era
-> Assertion
testUTXOWwith WitRule "UTXOW" era
wit Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (State (EraRule "UTXOW" era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
Either
  (NonEmpty (ConwayUtxowPredFailure ConwayEra)) (UTxOState ConwayEra)
-> Either
     (NonEmpty (ConwayUtxowPredFailure ConwayEra)) (UTxOState ConwayEra)
-> Assertion
forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq x, Eq y, ToExpr x, ToExpr y, Show (t x),
 Show y) =>
Either (t x) y -> Either (t x) y -> Assertion
subsetCont UTxO era
utxo
testUTXOWsubset (UTXOW Proof era
other) UTxO era
_ = [Char]
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot use testUTXOW in era " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Proof era -> [Char]
forall a. Show a => a -> [Char]
show Proof era
other)

-- | Use a test where any two (ValidationTagMismatch x y) failures match regardless of 'x' and 'y'
testUTXOspecialCase :: forall era.
(Reflect era, HasCallStack) =>
WitRule "UTXOW" era
-> UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
testUTXOspecialCase wit :: WitRule "UTXOW" era
wit@(UTXOW Proof era
proof) UTxO era
utxo PParams era
pparam Tx era
tx Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (State (EraRule "UTXOW" era))
expected =
  let env :: UtxoEnv era
env = SlotNo -> PParams era -> CertState era -> UtxoEnv era
forall era. SlotNo -> PParams era -> CertState era -> UtxoEnv era
UtxoEnv (Word64 -> SlotNo
SlotNo Word64
0) PParams era
pparam CertState era
forall a. Default a => a
def
      state :: UTxOState era
state = PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
forall era.
EraStake era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState PParams era
pparam UTxO era
utxo (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) GovState era
forall a. Default a => a
def Coin
forall a. Monoid a => a
mempty
   in case Proof era
proof of
        Proof era
Alonzo -> WitRule "UTXOW" era
-> TRC (EraRule "UTXOW" era)
-> (Either
      (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
      (State (EraRule "UTXOW" era))
    -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "UTXOW" era
wit ((Environment (AlonzoUTXOW AlonzoEra),
 State (AlonzoUTXOW AlonzoEra), Signal (AlonzoUTXOW AlonzoEra))
-> TRC (AlonzoUTXOW AlonzoEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (AlonzoUTXOW AlonzoEra)
env, State (AlonzoUTXOW AlonzoEra)
UTxOState era
state, Tx era
Signal (AlonzoUTXOW AlonzoEra)
tx)) (Proof era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (UTxOState AlonzoEra)
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (UTxOState AlonzoEra)
-> Assertion
forall era a.
(Eq (PredicateFailure (EraRule "UTXOW" era)), Eq a,
 Show (PredicateFailure (EraRule "UTXOW" era)), Show a,
 HasCallStack) =>
Proof era
-> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Assertion
specialCont Proof era
proof Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (State (EraRule "UTXOW" era))
Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (UTxOState AlonzoEra)
expected)
        Proof era
Babbage -> WitRule "UTXOW" era
-> TRC (EraRule "UTXOW" era)
-> (Either
      (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
      (State (EraRule "UTXOW" era))
    -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "UTXOW" era
wit ((Environment (BabbageUTXOW BabbageEra),
 State (BabbageUTXOW BabbageEra), Signal (BabbageUTXOW BabbageEra))
-> TRC (BabbageUTXOW BabbageEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (BabbageUTXOW BabbageEra)
env, State (BabbageUTXOW BabbageEra)
UTxOState era
state, Tx era
Signal (BabbageUTXOW BabbageEra)
tx)) (Proof era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (UTxOState BabbageEra)
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (UTxOState BabbageEra)
-> Assertion
forall era a.
(Eq (PredicateFailure (EraRule "UTXOW" era)), Eq a,
 Show (PredicateFailure (EraRule "UTXOW" era)), Show a,
 HasCallStack) =>
Proof era
-> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Assertion
specialCont Proof era
proof Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (State (EraRule "UTXOW" era))
Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (UTxOState BabbageEra)
expected)
        Proof era
Conway -> WitRule "UTXOW" era
-> TRC (EraRule "UTXOW" era)
-> (Either
      (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
      (State (EraRule "UTXOW" era))
    -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "UTXOW" era
wit ((Environment (ConwayUTXOW ConwayEra),
 State (ConwayUTXOW ConwayEra), Signal (ConwayUTXOW ConwayEra))
-> TRC (ConwayUTXOW ConwayEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (ConwayUTXOW ConwayEra)
env, State (ConwayUTXOW ConwayEra)
UTxOState era
state, Tx era
Signal (ConwayUTXOW ConwayEra)
tx)) (Proof era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (UTxOState ConwayEra)
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (UTxOState ConwayEra)
-> Assertion
forall era a.
(Eq (PredicateFailure (EraRule "UTXOW" era)), Eq a,
 Show (PredicateFailure (EraRule "UTXOW" era)), Show a,
 HasCallStack) =>
Proof era
-> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Assertion
specialCont Proof era
proof Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (State (EraRule "UTXOW" era))
Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (UTxOState ConwayEra)
expected)
        Proof era
other -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot use specialCase in era " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Proof era -> [Char]
forall a. Show a => a -> [Char]
show Proof era
other)

-- | This type is what you get when you use runSTS in the UTXOW rule. It is also
--   the type one uses for expected answers, to compare the 'computed' against 'expected'
type Result era =
  Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (State (EraRule "UTXOW" era))

testUTXOWwith ::
  forall era.
  ( EraTx era
  , EraGov era
  , EraStake era
  , EraCertState era
  ) =>
  WitRule "UTXOW" era ->
  (Result era -> Result era -> Assertion) ->
  UTxO era ->
  PParams era ->
  Tx era ->
  Result era ->
  Assertion
testUTXOWwith :: forall era.
(EraTx era, EraGov era, EraStake era, EraCertState era) =>
WitRule "UTXOW" era
-> (Result era -> Result era -> Assertion)
-> UTxO era
-> PParams era
-> Tx era
-> Result era
-> Assertion
testUTXOWwith wit :: WitRule "UTXOW" era
wit@(UTXOW Proof era
proof) Result era -> Result era -> Assertion
cont UTxO era
utxo PParams era
pparams Tx era
tx Result era
expected =
  let env :: UtxoEnv era
env = SlotNo -> PParams era -> CertState era -> UtxoEnv era
forall era. SlotNo -> PParams era -> CertState era -> UtxoEnv era
UtxoEnv (Word64 -> SlotNo
SlotNo Word64
0) PParams era
pparams CertState era
forall a. Default a => a
def
      state :: UTxOState era
state = PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
forall era.
EraStake era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState PParams era
pparams UTxO era
utxo (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) GovState era
forall a. Default a => a
def Coin
forall a. Monoid a => a
mempty
   in case Proof era
proof of
        Proof era
Conway -> WitRule "UTXOW" era
-> TRC (EraRule "UTXOW" era)
-> (Result era -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "UTXOW" era
wit ((Environment (ConwayUTXOW ConwayEra),
 State (ConwayUTXOW ConwayEra), Signal (ConwayUTXOW ConwayEra))
-> TRC (ConwayUTXOW ConwayEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (ConwayUTXOW ConwayEra)
env, State (ConwayUTXOW ConwayEra)
UTxOState era
state, Tx era
Signal (ConwayUTXOW ConwayEra)
tx)) (Result era -> Result era -> Assertion
cont Result era
expected)
        Proof era
Babbage -> WitRule "UTXOW" era
-> TRC (EraRule "UTXOW" era)
-> (Result era -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "UTXOW" era
wit ((Environment (BabbageUTXOW BabbageEra),
 State (BabbageUTXOW BabbageEra), Signal (BabbageUTXOW BabbageEra))
-> TRC (BabbageUTXOW BabbageEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (BabbageUTXOW BabbageEra)
env, State (BabbageUTXOW BabbageEra)
UTxOState era
state, Tx era
Signal (BabbageUTXOW BabbageEra)
tx)) (Result era -> Result era -> Assertion
cont Result era
expected)
        Proof era
Alonzo -> WitRule "UTXOW" era
-> TRC (EraRule "UTXOW" era)
-> (Result era -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "UTXOW" era
wit ((Environment (AlonzoUTXOW AlonzoEra),
 State (AlonzoUTXOW AlonzoEra), Signal (AlonzoUTXOW AlonzoEra))
-> TRC (AlonzoUTXOW AlonzoEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (AlonzoUTXOW AlonzoEra)
env, State (AlonzoUTXOW AlonzoEra)
UTxOState era
state, Tx era
Signal (AlonzoUTXOW AlonzoEra)
tx)) (Result era -> Result era -> Assertion
cont Result era
expected)
        Proof era
Mary -> WitRule "UTXOW" era
-> TRC (EraRule "UTXOW" era)
-> (Result era -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "UTXOW" era
wit ((Environment (AllegraUTXOW MaryEra), State (AllegraUTXOW MaryEra),
 Signal (AllegraUTXOW MaryEra))
-> TRC (AllegraUTXOW MaryEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (AllegraUTXOW MaryEra)
env, State (AllegraUTXOW MaryEra)
UTxOState era
state, Tx era
Signal (AllegraUTXOW MaryEra)
tx)) (Result era -> Result era -> Assertion
cont Result era
expected)
        Proof era
Allegra -> WitRule "UTXOW" era
-> TRC (EraRule "UTXOW" era)
-> (Result era -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "UTXOW" era
wit ((Environment (AllegraUTXOW AllegraEra),
 State (AllegraUTXOW AllegraEra), Signal (AllegraUTXOW AllegraEra))
-> TRC (AllegraUTXOW AllegraEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (AllegraUTXOW AllegraEra)
env, State (AllegraUTXOW AllegraEra)
UTxOState era
state, Tx era
Signal (AllegraUTXOW AllegraEra)
tx)) (Result era -> Result era -> Assertion
cont Result era
expected)
        Proof era
Shelley -> WitRule "UTXOW" era
-> TRC (EraRule "UTXOW" era)
-> (Result era -> Assertion)
-> Assertion
forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS WitRule "UTXOW" era
wit ((Environment (ShelleyUTXOW ShelleyEra),
 State (ShelleyUTXOW ShelleyEra), Signal (ShelleyUTXOW ShelleyEra))
-> TRC (ShelleyUTXOW ShelleyEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (ShelleyUTXOW ShelleyEra)
env, State (ShelleyUTXOW ShelleyEra)
UTxOState era
state, Tx era
Signal (ShelleyUTXOW ShelleyEra)
tx)) (Result era -> Result era -> Assertion
cont Result era
expected)

runLEDGER ::
  forall era.
  ( EraTx era
  , EraGov era
  ) =>
  WitRule "LEDGER" era ->
  LedgerState era ->
  PParams era ->
  Tx era ->
  Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (State (EraRule "LEDGER" era))
runLEDGER :: forall era.
(EraTx era, EraGov era) =>
WitRule "LEDGER" era
-> LedgerState era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
runLEDGER wit :: WitRule "LEDGER" era
wit@(LEDGER Proof era
proof) LedgerState era
state PParams era
pparams Tx era
tx =
  let env :: LedgerEnv era
env = SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> ChainAccountState
-> LedgerEnv era
forall era.
SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> ChainAccountState
-> LedgerEnv era
LedgerEnv (Word64 -> SlotNo
SlotNo Word64
0) Maybe EpochNo
forall a. Maybe a
Nothing TxIx
forall a. Bounded a => a
minBound PParams era
pparams ChainAccountState
forall a. Default a => a
def
   in case Proof era
proof of
        Proof era
Conway -> WitRule "LEDGER" era
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
forall (s :: Symbol) e.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> Either
     (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
runSTS' WitRule "LEDGER" era
wit ((Environment (ConwayLEDGER ConwayEra),
 State (ConwayLEDGER ConwayEra), Signal (ConwayLEDGER ConwayEra))
-> TRC (ConwayLEDGER ConwayEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv era
Environment (ConwayLEDGER ConwayEra)
env, State (ConwayLEDGER ConwayEra)
LedgerState era
state, Tx era
Signal (ConwayLEDGER ConwayEra)
tx))
        Proof era
Babbage -> WitRule "LEDGER" era
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
forall (s :: Symbol) e.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> Either
     (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
runSTS' WitRule "LEDGER" era
wit ((Environment (BabbageLEDGER BabbageEra),
 State (BabbageLEDGER BabbageEra),
 Signal (BabbageLEDGER BabbageEra))
-> TRC (BabbageLEDGER BabbageEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv era
Environment (BabbageLEDGER BabbageEra)
env, State (BabbageLEDGER BabbageEra)
LedgerState era
state, Tx era
Signal (BabbageLEDGER BabbageEra)
tx))
        Proof era
Alonzo -> WitRule "LEDGER" era
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
forall (s :: Symbol) e.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> Either
     (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
runSTS' WitRule "LEDGER" era
wit ((Environment (AlonzoLEDGER AlonzoEra),
 State (AlonzoLEDGER AlonzoEra), Signal (AlonzoLEDGER AlonzoEra))
-> TRC (AlonzoLEDGER AlonzoEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv era
Environment (AlonzoLEDGER AlonzoEra)
env, State (AlonzoLEDGER AlonzoEra)
LedgerState era
state, Tx era
Signal (AlonzoLEDGER AlonzoEra)
tx))
        Proof era
Mary -> WitRule "LEDGER" era
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
forall (s :: Symbol) e.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> Either
     (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
runSTS' WitRule "LEDGER" era
wit ((Environment (ShelleyLEDGER MaryEra),
 State (ShelleyLEDGER MaryEra), Signal (ShelleyLEDGER MaryEra))
-> TRC (ShelleyLEDGER MaryEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv era
Environment (ShelleyLEDGER MaryEra)
env, State (ShelleyLEDGER MaryEra)
LedgerState era
state, Tx era
Signal (ShelleyLEDGER MaryEra)
tx))
        Proof era
Allegra -> WitRule "LEDGER" era
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
forall (s :: Symbol) e.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> Either
     (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
runSTS' WitRule "LEDGER" era
wit ((Environment (ShelleyLEDGER AllegraEra),
 State (ShelleyLEDGER AllegraEra),
 Signal (ShelleyLEDGER AllegraEra))
-> TRC (ShelleyLEDGER AllegraEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv era
Environment (ShelleyLEDGER AllegraEra)
env, State (ShelleyLEDGER AllegraEra)
LedgerState era
state, Tx era
Signal (ShelleyLEDGER AllegraEra)
tx))
        Proof era
Shelley -> WitRule "LEDGER" era
-> TRC (EraRule "LEDGER" era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
forall (s :: Symbol) e.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
WitRule s e
-> TRC (EraRule s e)
-> Either
     (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
runSTS' WitRule "LEDGER" era
wit ((Environment (ShelleyLEDGER ShelleyEra),
 State (ShelleyLEDGER ShelleyEra),
 Signal (ShelleyLEDGER ShelleyEra))
-> TRC (ShelleyLEDGER ShelleyEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv era
Environment (ShelleyLEDGER ShelleyEra)
env, State (ShelleyLEDGER ShelleyEra)
LedgerState era
state, Tx era
Signal (ShelleyLEDGER ShelleyEra)
tx))

-- ======================================================================
-- =========================  Internal helper functions  ================
-- ======================================================================

-- | A small example of what a continuation for 'runSTS' might look like
genericCont ::
  ( Foldable t
  , Eq (t x)
  , Eq y
  , ToExpr x
  , ToExpr y
  , HasCallStack
  ) =>
  String ->
  Either (t x) y ->
  Either (t x) y ->
  Assertion
genericCont :: forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq y, ToExpr x, ToExpr y, HasCallStack) =>
[Char] -> Either (t x) y -> Either (t x) y -> Assertion
genericCont [Char]
cause Either (t x) y
expected Either (t x) y
computed =
  case (Either (t x) y
computed, Either (t x) y
expected) of
    (Left t x
c, Left t x
e)
      | t x
c t x -> t x -> Bool
forall a. Eq a => a -> a -> Bool
/= t x
e -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
causedBy [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t x -> [Char]
forall {a} {t :: * -> *}. (ToExpr a, Foldable t) => t a -> [Char]
expectedToFail t x
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t x -> [Char]
forall {a} {t :: * -> *}. (ToExpr a, Foldable t) => t a -> [Char]
failedWith t x
c
    (Right y
c, Right y
e)
      | y
c y -> y -> Bool
forall a. Eq a => a -> a -> Bool
/= y
e -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
causedBy [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ y -> [Char]
forall {a}. ToExpr a => a -> [Char]
expectedToPass y
e [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ y -> [Char]
forall {a}. ToExpr a => a -> [Char]
passedWith y
c
    (Left t x
x, Right y
y) ->
      [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
causedBy [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ y -> [Char]
forall {a}. ToExpr a => a -> [Char]
expectedToPass y
y [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t x -> [Char]
forall {a} {t :: * -> *}. (ToExpr a, Foldable t) => t a -> [Char]
failedWith t x
x
    (Right y
x, Left t x
y) ->
      [Char] -> Assertion
forall a. HasCallStack => [Char] -> IO a
assertFailure ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ [Char]
causedBy [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t x -> [Char]
forall {a} {t :: * -> *}. (ToExpr a, Foldable t) => t a -> [Char]
expectedToFail t x
y [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ y -> [Char]
forall {a}. ToExpr a => a -> [Char]
passedWith y
x
    (Either (t x) y, Either (t x) y)
_ -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    causedBy :: [Char]
causedBy
      | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
cause = [Char]
""
      | Bool
otherwise = [Char]
"Caused by:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cause [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    expectedToPass :: a -> [Char]
expectedToPass a
y = [Char]
"Expected to pass with:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr -> [Char]
forall a. Show a => a -> [Char]
show (a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
y) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    expectedToFail :: t a -> [Char]
expectedToFail t a
x = [Char]
"Expected to fail with:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr -> [Char]
forall a. Show a => a -> [Char]
show ([a] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([a] -> Expr) -> [a] -> Expr
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t a
x) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
    failedWith :: t a -> [Char]
failedWith t a
x = [Char]
"But failed with:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr -> [Char]
forall a. Show a => a -> [Char]
show ([a] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([a] -> Expr) -> [a] -> Expr
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t a
x)
    passedWith :: a -> [Char]
passedWith a
y = [Char]
"But passed with:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr -> [Char]
forall a. Show a => a -> [Char]
show (a -> Expr
forall a. ToExpr a => a -> Expr
toExpr a
y)

subsetCont ::
  ( Foldable t
  , Eq (t x)
  , Eq x
  , Eq y
  , ToExpr x
  , ToExpr y
  , Show (t x)
  , Show y
  ) =>
  Either (t x) y ->
  Either (t x) y ->
  Assertion
subsetCont :: forall (t :: * -> *) x y.
(Foldable t, Eq (t x), Eq x, Eq y, ToExpr x, ToExpr y, Show (t x),
 Show y) =>
Either (t x) y -> Either (t x) y -> Assertion
subsetCont Either (t x) y
expected Either (t x) y
computed =
  case (Either (t x) y
computed, Either (t x) y
expected) of
    (Left t x
c, Left t x
e) ->
      -- It is OK if the expected is a subset of what's computed
      if t x -> t x -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => t a -> t a -> Bool
isSubset t x
e t x
c then t x
e t x -> t x -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= t x
e else t x
c t x -> t x -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= t x
e
    (Right y
c, Right y
e) -> y
c y -> y -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= y
e
    (Left t x
x, Right y
y) ->
      [Char] -> Assertion
forall a. HasCallStack => [Char] -> a
error ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$
        [Char]
"expected to pass with "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr -> [Char]
forall a. Show a => a -> [Char]
show (y -> Expr
forall a. ToExpr a => a -> Expr
toExpr y
y)
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\nBut failed with\n\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr -> [Char]
forall a. Show a => a -> [Char]
show ([x] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([x] -> Expr) -> [x] -> Expr
forall a b. (a -> b) -> a -> b
$ t x -> [x]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t x
x)
    (Right y
y, Left t x
x) ->
      [Char] -> Assertion
forall a. HasCallStack => [Char] -> a
error ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$
        [Char]
"expected to fail with "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr -> [Char]
forall a. Show a => a -> [Char]
show ([x] -> Expr
forall a. ToExpr a => a -> Expr
toExpr ([x] -> Expr) -> [x] -> Expr
forall a b. (a -> b) -> a -> b
$ t x -> [x]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t x
x)
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n\nBut passed with\n\n"
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr -> [Char]
forall a. Show a => a -> [Char]
show (y -> Expr
forall a. ToExpr a => a -> Expr
toExpr y
y)

specialCont ::
  ( Eq (PredicateFailure (EraRule "UTXOW" era))
  , Eq a
  , Show (PredicateFailure (EraRule "UTXOW" era))
  , Show a
  , HasCallStack
  ) =>
  Proof era ->
  Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a ->
  Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a ->
  Assertion
specialCont :: forall era a.
(Eq (PredicateFailure (EraRule "UTXOW" era)), Eq a,
 Show (PredicateFailure (EraRule "UTXOW" era)), Show a,
 HasCallStack) =>
Proof era
-> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Assertion
specialCont Proof era
proof Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
expected Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
computed =
  case (Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
computed, Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
expected) of
    (Left (PredicateFailure (EraRule "UTXOW" era)
x :| []), Left (PredicateFailure (EraRule "UTXOW" era)
y :| [])) ->
      case (Proof era
-> PredicateFailure (EraRule "UTXOW" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
forall era.
Proof era
-> PredicateFailure (EraRule "UTXOW" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
findMismatch Proof era
proof PredicateFailure (EraRule "UTXOW" era)
x, Proof era
-> PredicateFailure (EraRule "UTXOW" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
forall era.
Proof era
-> PredicateFailure (EraRule "UTXOW" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
findMismatch Proof era
proof PredicateFailure (EraRule "UTXOW" era)
y) of
        (Just PredicateFailure (EraRule "UTXOS" era)
_, Just PredicateFailure (EraRule "UTXOS" era)
_) -> PredicateFailure (EraRule "UTXOW" era)
y PredicateFailure (EraRule "UTXOW" era)
-> PredicateFailure (EraRule "UTXOW" era) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= PredicateFailure (EraRule "UTXOW" era)
y
        (Maybe (PredicateFailure (EraRule "UTXOS" era))
_, Maybe (PredicateFailure (EraRule "UTXOS" era))
_) -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> a
error [Char]
"Not both ValidationTagMismatch case 1"
    (Left NonEmpty (PredicateFailure (EraRule "UTXOW" era))
_, Left NonEmpty (PredicateFailure (EraRule "UTXOW" era))
_) -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> a
error [Char]
"Not both ValidationTagMismatch case 2"
    (Right a
x, Right a
y) -> a
x a -> a -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= a
y
    (Left NonEmpty (PredicateFailure (EraRule "UTXOW" era))
_, Right a
_) -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> a
error [Char]
"expected to pass, but failed."
    (Right a
_, Left NonEmpty (PredicateFailure (EraRule "UTXOW" era))
_) -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> a
error [Char]
"expected to fail, but passed."

-- ========================================
-- This implements a special rule to test that for ValidationTagMismatch. Rather than comparing the insides of
-- ValidationTagMismatch (which are complicated and depend on Plutus) we just note that both the computed
-- and expected are ValidationTagMismatch. Of course the 'path' to ValidationTagMismatch differs by Era.
-- so we need to case over the Era proof, to get the path correctly.
findMismatch ::
  Proof era ->
  PredicateFailure (EraRule "UTXOW" era) ->
  Maybe (PredicateFailure (EraRule "UTXOS" era))
findMismatch :: forall era.
Proof era
-> PredicateFailure (EraRule "UTXOW" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
findMismatch Proof era
Alonzo (ShelleyInAlonzoUtxowPredFailure (Shelley.UtxoFailure (UtxosFailure x :: PredicateFailure (EraRule "UTXOS" AlonzoEra)
x@(ValidationTagMismatch IsValid
_ TagMismatchDescription
_)))) = PredicateFailure (EraRule "UTXOS" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
forall a. a -> Maybe a
Just (PredicateFailure (EraRule "UTXOS" era)
 -> Maybe (PredicateFailure (EraRule "UTXOS" era)))
-> PredicateFailure (EraRule "UTXOS" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
forall a b. (a -> b) -> a -> b
$ AlonzoUtxosPredFailure AlonzoEra
-> EraRuleFailure "UTXOS" AlonzoEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure PredicateFailure (EraRule "UTXOS" AlonzoEra)
AlonzoUtxosPredFailure AlonzoEra
x
findMismatch Proof era
Babbage (Babbage.UtxoFailure (AlonzoInBabbageUtxoPredFailure (UtxosFailure x :: PredicateFailure (EraRule "UTXOS" BabbageEra)
x@(ValidationTagMismatch IsValid
_ TagMismatchDescription
_)))) = PredicateFailure (EraRule "UTXOS" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
forall a. a -> Maybe a
Just (PredicateFailure (EraRule "UTXOS" era)
 -> Maybe (PredicateFailure (EraRule "UTXOS" era)))
-> PredicateFailure (EraRule "UTXOS" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
forall a b. (a -> b) -> a -> b
$ AlonzoUtxosPredFailure BabbageEra
-> EraRuleFailure "UTXOS" BabbageEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure PredicateFailure (EraRule "UTXOS" BabbageEra)
AlonzoUtxosPredFailure BabbageEra
x
findMismatch
  Proof era
Conway
  ( Conway.UtxoFailure
      (Conway.UtxosFailure x :: PredicateFailure (EraRule "UTXOS" ConwayEra)
x@(Conway.ValidationTagMismatch IsValid
_ TagMismatchDescription
_))
    ) = PredicateFailure (EraRule "UTXOS" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
forall a. a -> Maybe a
Just (PredicateFailure (EraRule "UTXOS" era)
 -> Maybe (PredicateFailure (EraRule "UTXOS" era)))
-> PredicateFailure (EraRule "UTXOS" era)
-> Maybe (PredicateFailure (EraRule "UTXOS" era))
forall a b. (a -> b) -> a -> b
$ ConwayUtxosPredFailure ConwayEra
-> EraRuleFailure "UTXOS" ConwayEra
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure PredicateFailure (EraRule "UTXOS" ConwayEra)
ConwayUtxosPredFailure ConwayEra
x
findMismatch Proof era
_ PredicateFailure (EraRule "UTXOW" era)
_ = Maybe (PredicateFailure (EraRule "UTXOS" era))
forall a. Maybe a
Nothing

isSubset :: (Foldable t, Eq a) => t a -> t a -> Bool
isSubset :: forall (t :: * -> *) a. (Foldable t, Eq a) => t a -> t a -> Bool
isSubset t a
small t a
big = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> t a -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
big) t a
small

instance Era era => IsList (TxDats era) where
  type Item (TxDats era) = Data era
  fromList :: [Item (TxDats era)] -> TxDats era
fromList = Map DataHash (Data era) -> TxDats era
forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats (Map DataHash (Data era) -> TxDats era)
-> ([Data era] -> Map DataHash (Data era))
-> [Data era]
-> TxDats era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Data era -> DataHash) -> [Data era] -> Map DataHash (Data era)
forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
fromElems Data era -> DataHash
forall era. Data era -> DataHash
hashData
  toList :: TxDats era -> [Item (TxDats era)]
toList (TxDats Map DataHash (Data era)
m) = Map DataHash (Data era) -> [Data era]
forall k a. Map k a -> [a]
Map.elems Map DataHash (Data era)
m