{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

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

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Allegra.Scripts (AllegraEraScript, pattern RequireTimeStart)
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxoPredFailure (..),
  AlonzoUtxosPredFailure (..),
  AlonzoUtxowPredFailure (..),
 )
import Cardano.Ledger.Alonzo.Scripts (AlonzoEraScript (..), AsIx, ExUnits (..))
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..))
import Cardano.Ledger.BHeaderView (BHeaderView)
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
import qualified Cardano.Ledger.Babbage.Rules as Babbage
import Cardano.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..), mkTxIxPartial)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core (AlonzoEraTxOut (..), ScriptIntegrityHash)
import qualified Cardano.Ledger.Conway.Rules as Conway
import Cardano.Ledger.Credential (Credential (..), StakeCredential)
import Cardano.Ledger.Plutus (Language)
import Cardano.Ledger.Plutus.Data (Data (..), hashData)
import Cardano.Ledger.Shelley.API (Block, LedgerEnv (..), UtxoEnv (..))
import Cardano.Ledger.Shelley.Core hiding (TranslationError)
import Cardano.Ledger.Shelley.LedgerState (LedgerState, UTxOState, smartUTxOState)
import Cardano.Ledger.Shelley.Rules (BbodyEnv (..), ShelleyBbodyState)
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.Shelley.Scripts (
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.State
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.Val (inject)
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Monad (when)
import Control.State.Transition.Extended (STS (..), TRC (..))
import Data.Default (Default (..))
import Data.Foldable (Foldable (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Word (Word32)
import GHC.Generics (Generic)
import GHC.Stack
import Lens.Micro (Lens', (&), (.~))
import Numeric.Natural (Natural)
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Conway.TreeDiff (
  ToExpr (..),
  ansiDocToString,
  diffExpr,
 )
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkAddr)
import Test.Cardano.Ledger.Generic.Indexed (theKeyHash)
import Test.Cardano.Ledger.Generic.ModelState (Model)
import Test.Cardano.Ledger.Generic.Proof (Proof (..), Reflect (..), runSTS, runSTS')
import Test.Cardano.Ledger.Shelley.Era (EraTest, ShelleyEraTest)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
import Test.Cardano.Ledger.Shelley.ImpTest (ShelleyEraImp)
import Test.Cardano.Ledger.Shelley.Utils (RawSeed (..), mkKeyPair, mkKeyPair')
import Test.Tasty.HUnit (Assertion, assertFailure, (@?=))

data PlutusPurposeTag
  = Spending
  | Minting
  | Certifying
  | Rewarding
  | Voting
  | Proposing
  deriving (PlutusPurposeTag -> PlutusPurposeTag -> Bool
(PlutusPurposeTag -> PlutusPurposeTag -> Bool)
-> (PlutusPurposeTag -> PlutusPurposeTag -> Bool)
-> Eq PlutusPurposeTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
== :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$c/= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
/= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
Eq, Eq PlutusPurposeTag
Eq PlutusPurposeTag =>
(PlutusPurposeTag -> PlutusPurposeTag -> Ordering)
-> (PlutusPurposeTag -> PlutusPurposeTag -> Bool)
-> (PlutusPurposeTag -> PlutusPurposeTag -> Bool)
-> (PlutusPurposeTag -> PlutusPurposeTag -> Bool)
-> (PlutusPurposeTag -> PlutusPurposeTag -> Bool)
-> (PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag)
-> (PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag)
-> Ord PlutusPurposeTag
PlutusPurposeTag -> PlutusPurposeTag -> Bool
PlutusPurposeTag -> PlutusPurposeTag -> Ordering
PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PlutusPurposeTag -> PlutusPurposeTag -> Ordering
compare :: PlutusPurposeTag -> PlutusPurposeTag -> Ordering
$c< :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
< :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$c<= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
<= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$c> :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
> :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$c>= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
>= :: PlutusPurposeTag -> PlutusPurposeTag -> Bool
$cmax :: PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag
max :: PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag
$cmin :: PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag
min :: PlutusPurposeTag -> PlutusPurposeTag -> PlutusPurposeTag
Ord, Int -> PlutusPurposeTag -> ShowS
[PlutusPurposeTag] -> ShowS
PlutusPurposeTag -> String
(Int -> PlutusPurposeTag -> ShowS)
-> (PlutusPurposeTag -> String)
-> ([PlutusPurposeTag] -> ShowS)
-> Show PlutusPurposeTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PlutusPurposeTag -> ShowS
showsPrec :: Int -> PlutusPurposeTag -> ShowS
$cshow :: PlutusPurposeTag -> String
show :: PlutusPurposeTag -> String
$cshowList :: [PlutusPurposeTag] -> ShowS
showList :: [PlutusPurposeTag] -> ShowS
Show, Int -> PlutusPurposeTag
PlutusPurposeTag -> Int
PlutusPurposeTag -> [PlutusPurposeTag]
PlutusPurposeTag -> PlutusPurposeTag
PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
PlutusPurposeTag
-> PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
(PlutusPurposeTag -> PlutusPurposeTag)
-> (PlutusPurposeTag -> PlutusPurposeTag)
-> (Int -> PlutusPurposeTag)
-> (PlutusPurposeTag -> Int)
-> (PlutusPurposeTag -> [PlutusPurposeTag])
-> (PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag])
-> (PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag])
-> (PlutusPurposeTag
    -> PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag])
-> Enum PlutusPurposeTag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: PlutusPurposeTag -> PlutusPurposeTag
succ :: PlutusPurposeTag -> PlutusPurposeTag
$cpred :: PlutusPurposeTag -> PlutusPurposeTag
pred :: PlutusPurposeTag -> PlutusPurposeTag
$ctoEnum :: Int -> PlutusPurposeTag
toEnum :: Int -> PlutusPurposeTag
$cfromEnum :: PlutusPurposeTag -> Int
fromEnum :: PlutusPurposeTag -> Int
$cenumFrom :: PlutusPurposeTag -> [PlutusPurposeTag]
enumFrom :: PlutusPurposeTag -> [PlutusPurposeTag]
$cenumFromThen :: PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
enumFromThen :: PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
$cenumFromTo :: PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
enumFromTo :: PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
$cenumFromThenTo :: PlutusPurposeTag
-> PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
enumFromThenTo :: PlutusPurposeTag
-> PlutusPurposeTag -> PlutusPurposeTag -> [PlutusPurposeTag]
Enum, PlutusPurposeTag
PlutusPurposeTag -> PlutusPurposeTag -> Bounded PlutusPurposeTag
forall a. a -> a -> Bounded a
$cminBound :: PlutusPurposeTag
minBound :: PlutusPurposeTag
$cmaxBound :: PlutusPurposeTag
maxBound :: PlutusPurposeTag
Bounded, (forall x. PlutusPurposeTag -> Rep PlutusPurposeTag x)
-> (forall x. Rep PlutusPurposeTag x -> PlutusPurposeTag)
-> Generic PlutusPurposeTag
forall x. Rep PlutusPurposeTag x -> PlutusPurposeTag
forall x. PlutusPurposeTag -> Rep PlutusPurposeTag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PlutusPurposeTag -> Rep PlutusPurposeTag x
from :: forall x. PlutusPurposeTag -> Rep PlutusPurposeTag x
$cto :: forall x. Rep PlutusPurposeTag x -> PlutusPurposeTag
to :: forall x. Rep PlutusPurposeTag x -> PlutusPurposeTag
Generic)

instance ToExpr PlutusPurposeTag

class EraTest era => EraModel era where
  applyTx :: Int -> SlotNo -> Model era -> Tx era -> Model era
  applyCert :: Model era -> TxCert era -> Model era

  mkRedeemersFromTags :: [((PlutusPurposeTag, Word32), (Data era, ExUnits))] -> Redeemers era
  mkRedeemersFromTags = String
-> [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
forall a. HasCallStack => String -> a
error (String
 -> [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
 -> Redeemers era)
-> String
-> [((PlutusPurposeTag, Word32), (Data era, ExUnits))]
-> Redeemers era
forall a b. (a -> b) -> a -> b
$ String
"No redeemers in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> forall era. Era era => String
eraName @era

  mkRedeemers :: [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
  mkRedeemers = String
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
forall a. HasCallStack => String -> a
error (String
 -> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
 -> Redeemers era)
-> String
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> Redeemers era
forall a b. (a -> b) -> a -> b
$ String
"No redeemers in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> forall era. Era era => String
eraName @era

  newScriptIntegrityHash ::
    PParams era ->
    [Language] ->
    Redeemers era ->
    TxDats era ->
    StrictMaybe ScriptIntegrityHash
  newScriptIntegrityHash PParams era
_ [Language]
_ Redeemers era
_ TxDats era
_ = StrictMaybe ScriptIntegrityHash
forall a. StrictMaybe a
SNothing

  mkPlutusPurposePointer :: PlutusPurposeTag -> Word32 -> PlutusPurpose AsIx era
  mkPlutusPurposePointer = String -> PlutusPurposeTag -> Word32 -> PlutusPurpose AsIx era
forall a. HasCallStack => String -> a
error (String -> PlutusPurposeTag -> Word32 -> PlutusPurpose AsIx era)
-> String -> PlutusPurposeTag -> Word32 -> PlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$ String
"mkPlutusPurposePointer not available in " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> forall era. Era era => String
eraName @era

  always :: Natural -> Script era

  never :: Natural -> Script era

  collateralReturnTxBodyT :: Lens' (TxBody era) (StrictMaybe (TxOut era))

  validTxOut :: Map ScriptHash (Script era) -> TxOut era -> Bool

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

alwaysFailsHash :: forall era. (ShelleyEraScript era, EraModel era) => Natural -> ScriptHash
alwaysFailsHash :: forall era.
(ShelleyEraScript era, EraModel era) =>
Natural -> ScriptHash
alwaysFailsHash Natural
n = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ Natural -> Script era
forall era. EraModel era => Natural -> Script era
never Natural
n

alwaysSucceedsHash :: forall era. (ShelleyEraScript era, EraModel era) => Natural -> ScriptHash
alwaysSucceedsHash :: forall era.
(ShelleyEraScript era, EraModel era) =>
Natural -> ScriptHash
alwaysSucceedsHash Natural
n = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ Natural -> Script era
forall era. EraModel era => Natural -> Script era
always Natural
n

someKeys :: KeyPair 'Payment
someKeys :: KeyPair 'Payment
someKeys = 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 :: Addr
someAddr :: Addr
someAddr = KeyPair 'Payment -> KeyPair 'Staking -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyPair 'Payment
someKeys (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. EraScript era => Script era -> Addr
someScriptAddr :: forall era. EraScript 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 :: AllegraEraScript era => SlotNo -> Script era
timelockScript :: forall era. AllegraEraScript era => SlotNo -> Script era
timelockScript SlotNo
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
$
    StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf
      [ KeyHash 'Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature (KeyHash 'Witness -> NativeScript era)
-> KeyHash 'Witness -> NativeScript era
forall a b. (a -> b) -> a -> b
$ Int -> KeyHash 'Witness
forall (kr :: KeyRole). Int -> KeyHash kr
theKeyHash Int
1
      , SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart (SlotNo
100 SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
s)
      ]

timelockHash ::
  forall era.
  AllegraEraScript era =>
  SlotNo ->
  ScriptHash
timelockHash :: forall era. AllegraEraScript era => SlotNo -> ScriptHash
timelockHash SlotNo
n = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SlotNo -> Script era
forall era. AllegraEraScript era => SlotNo -> Script era
timelockScript SlotNo
n

timelockStakeCred :: forall era. AllegraEraScript era => StakeCredential
timelockStakeCred :: forall era. AllegraEraScript era => StakeCredential
timelockStakeCred = ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (forall era. AllegraEraScript era => SlotNo -> ScriptHash
timelockHash @era SlotNo
2)

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

initUTxO ::
  forall era.
  ( AllegraEraScript era
  , AlonzoEraTxOut era
  , EraModel era
  ) =>
  UTxO era
initUTxO :: forall era.
(AllegraEraScript era, AlonzoEraTxOut era, EraModel era) =>
UTxO era
initUTxO =
  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
Item [Integer]
3 .. Integer
Item [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
Item [Integer]
11 .. Integer
Item [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 =
      Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut (forall era. EraScript era => Script era -> Addr
someScriptAddr @era (Script era -> Addr) -> Script era -> Addr
forall a b. (a -> b) -> a -> b
$ Natural -> Script era
forall era. EraModel era => Natural -> Script era
always Natural
3) (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)
        TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> TxOut era -> Identity (TxOut era)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL ((StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe DataHash -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust (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 =
      Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut (forall era. EraScript era => Script era -> Addr
someScriptAddr @era (Script era -> Addr) -> Script era -> Addr
forall a b. (a -> b) -> a -> b
$ Natural -> Script era
forall era. EraModel era => Natural -> Script era
never Natural
0) (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)
        TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> TxOut era -> Identity (TxOut era)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL ((StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe DataHash -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust (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 = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
someAddr (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 = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
someAddr (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 = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
timelockAddr (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
$ SlotNo -> Script era
tls SlotNo
0
        tls :: SlotNo -> Script era
tls SlotNo
s =
          forall era. EraScript era => NativeScript era -> Script era
fromNativeScript @era (NativeScript era -> Script era) -> NativeScript era -> Script era
forall a b. (a -> b) -> a -> b
$
            StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf
              [ KeyHash 'Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature (KeyHash 'Witness -> NativeScript era)
-> KeyHash 'Witness -> NativeScript era
forall a b. (a -> b) -> a -> b
$ Int -> KeyHash 'Witness
forall (kr :: KeyRole). Int -> KeyHash kr
theKeyHash Int
1
              , SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart (SlotNo
100 SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
s)
              ]
    -- This output is unspendable since it is locked by a plutus script, but has no datum hash.
    unspendableOut :: TxOut era
unspendableOut =
      Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut (forall era. EraScript era => Script era -> Addr
someScriptAddr @era (Script era -> Addr) -> Script era -> Addr
forall a b. (a -> b) -> a -> b
$ Natural -> Script era
forall era. EraModel era => Natural -> Script era
always Natural
3) (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 =
      TxOut era
unspendableOut TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> TxOut era -> Identity (TxOut era)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL ((StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe DataHash -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust (Data era -> DataHash
forall era. Data era -> DataHash
hashData (forall era. Era era => Data era
datumExample1 @era))
    nonScriptOutWithDatum :: TxOut era
nonScriptOutWithDatum =
      Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
someAddr (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)
        TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> TxOut era -> Identity (TxOut era)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL ((StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe DataHash -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust (Data era -> DataHash
forall era. Data era -> DataHash
hashData (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 ::
  forall era. AlonzoEraScript era => PlutusPurpose AsIx era -> Data era -> Redeemers era
mkSingleRedeemer :: forall era.
AlonzoEraScript era =>
PlutusPurpose AsIx era -> Data era -> Redeemers era
mkSingleRedeemer PlutusPurpose AsIx era
tag Data era
datum =
  forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers @era (Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Redeemers era
forall a b. (a -> b) -> a -> b
$ PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. k -> a -> Map k a
Map.singleton PlutusPurpose AsIx era
tag (Data era
datum, Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
5000)

-- 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 ::
  forall era.
  ( HasCallStack
  , Eq (State (EraRule "LEDGERS" era))
  , ToExpr (PredicateFailure (EraRule "BBODY" era))
  , ToExpr (State (EraRule "LEDGERS" era))
  , ShelleyEraImp era
  ) =>
  ShelleyBbodyState era ->
  Block BHeaderView era ->
  Either (NonEmpty (PredicateFailure (EraRule "BBODY" era))) (ShelleyBbodyState era) ->
  PParams era ->
  Assertion
testBBODY :: forall era.
(HasCallStack, Eq (State (EraRule "LEDGERS" era)),
 ToExpr (PredicateFailure (EraRule "BBODY" era)),
 ToExpr (State (EraRule "LEDGERS" era)), ShelleyEraImp era) =>
ShelleyBbodyState era
-> Block BHeaderView era
-> Either
     (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
     (ShelleyBbodyState era)
-> PParams era
-> Assertion
testBBODY 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 forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS @"BBODY" @era ((Environment (EraRule "BBODY" era), State (EraRule "BBODY" era),
 Signal (EraRule "BBODY" era))
-> TRC (EraRule "BBODY" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (BbodyEnv era
Environment (EraRule "BBODY" era)
env, State (EraRule "BBODY" era)
ShelleyBbodyState era
initialSt, Block BHeaderView era
Signal (EraRule "BBODY" era)
block)) (String
-> Either
     (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
     (ShelleyBbodyState era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
     (ShelleyBbodyState era)
-> Assertion
forall (t :: * -> *) x y.
(Eq (t x), Eq y, ToExpr y, HasCallStack, ToExpr (t x)) =>
String -> Either (t x) y -> Either (t x) y -> Assertion
genericCont String
"" Either
  (NonEmpty (PredicateFailure (EraRule "BBODY" era)))
  (ShelleyBbodyState era)
expected)

-- | Use an equality test on the expected and computed [PredicateFailure]
testUTXOW ::
  forall era.
  ( Reflect era
  , HasCallStack
  , ShelleyEraTest era
  , BaseM (EraRule "UTXOW" era) ~ ShelleyBase
  , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
  , STS (EraRule "UTXOW" era)
  , Tx era ~ Signal (EraRule "UTXOW" era)
  , State (EraRule "UTXOW" era) ~ UTxOState era
  , ToExpr (PredicateFailure (EraRule "UTXOW" era))
  ) =>
  UTxO era ->
  PParams era ->
  Tx era ->
  Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (State (EraRule "UTXOW" era)) ->
  Assertion
testUTXOW :: forall era.
(Reflect era, HasCallStack, ShelleyEraTest era,
 BaseM (EraRule "UTXOW" era) ~ ShelleyBase,
 Environment (EraRule "UTXOW" era) ~ UtxoEnv era,
 STS (EraRule "UTXOW" era), Tx era ~ Signal (EraRule "UTXOW" era),
 State (EraRule "UTXOW" era) ~ UTxOState era,
 ToExpr (PredicateFailure (EraRule "UTXOW" era))) =>
UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
testUTXOW UTxO era
utxo PParams era
p Tx era
tx = (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.
(ShelleyEraTest era, STS (EraRule "UTXOW" era),
 BaseM (EraRule "UTXOW" era) ~ ShelleyBase,
 Environment (EraRule "UTXOW" era) ~ UtxoEnv era,
 State (EraRule "UTXOW" era) ~ UTxOState era,
 Tx era ~ Signal (EraRule "UTXOW" era)) =>
(Result era -> Result era -> Assertion)
-> UTxO era -> PParams era -> Tx era -> Result era -> Assertion
testUTXOWwith (String
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (UTxOState era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (UTxOState era)
-> Assertion
forall (t :: * -> *) x y.
(Eq (t x), Eq y, ToExpr y, HasCallStack, ToExpr (t x)) =>
String -> Either (t x) y -> Either (t x) y -> Assertion
genericCont ((UTxO era, Tx era) -> String
forall a. Show a => a -> String
show (UTxO era
utxo, Tx era
tx))) UTxO era
utxo PParams era
p Tx era
tx

-- | Use a subset test on the expected and computed [PredicateFailure]
testUTXOWsubset ::
  forall era.
  ( Reflect era
  , BaseM (EraRule "UTXOW" era) ~ ShelleyBase
  , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
  , State (EraRule "UTXOW" era) ~ UTxOState era
  , Tx era ~ Signal (EraRule "UTXOW" era)
  , STS (EraRule "UTXOW" era)
  , ToExpr (PredicateFailure (EraRule "UTXOW" era))
  , ShelleyEraTest era
  ) =>
  UTxO era ->
  PParams era ->
  Tx era ->
  Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (State (EraRule "UTXOW" era)) ->
  Assertion
testUTXOWsubset :: forall era.
(Reflect era, BaseM (EraRule "UTXOW" era) ~ ShelleyBase,
 Environment (EraRule "UTXOW" era) ~ UtxoEnv era,
 State (EraRule "UTXOW" era) ~ UTxOState era,
 Tx era ~ Signal (EraRule "UTXOW" era), STS (EraRule "UTXOW" era),
 ToExpr (PredicateFailure (EraRule "UTXOW" era)),
 ShelleyEraTest era) =>
UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
testUTXOWsubset = (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.
(ShelleyEraTest era, STS (EraRule "UTXOW" era),
 BaseM (EraRule "UTXOW" era) ~ ShelleyBase,
 Environment (EraRule "UTXOW" era) ~ UtxoEnv era,
 State (EraRule "UTXOW" era) ~ UTxOState era,
 Tx era ~ Signal (EraRule "UTXOW" era)) =>
(Result era -> Result era -> Assertion)
-> UTxO era -> PParams era -> Tx era -> Result era -> Assertion
testUTXOWwith Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (State (EraRule "UTXOW" era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (UTxOState era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (UTxOState era)
-> 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

-- | Use a test where any two (ValidationTagMismatch x y) failures match regardless of 'x' and 'y'
testUTXOspecialCase ::
  forall era.
  ( Reflect era
  , HasCallStack
  , BaseM (EraRule "UTXOW" era) ~ ShelleyBase
  , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
  , State (EraRule "UTXOW" era) ~ UTxOState era
  , Tx era ~ Signal (EraRule "UTXOW" era)
  , STS (EraRule "UTXOW" era)
  ) =>
  UTxO era ->
  PParams era ->
  Tx era ->
  Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (State (EraRule "UTXOW" era)) ->
  Assertion
testUTXOspecialCase :: forall era.
(Reflect era, HasCallStack,
 BaseM (EraRule "UTXOW" era) ~ ShelleyBase,
 Environment (EraRule "UTXOW" era) ~ UtxoEnv era,
 State (EraRule "UTXOW" era) ~ UTxOState era,
 Tx era ~ Signal (EraRule "UTXOW" era),
 STS (EraRule "UTXOW" era)) =>
UTxO era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
     (State (EraRule "UTXOW" era))
-> Assertion
testUTXOspecialCase 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 forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS @"UTXOW" @era ((Environment (EraRule "UTXOW" era), State (EraRule "UTXOW" era),
 Signal (EraRule "UTXOW" era))
-> TRC (EraRule "UTXOW" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (EraRule "UTXOW" era)
env, State (EraRule "UTXOW" era)
UTxOState era
state, Tx era
Signal (EraRule "UTXOW" era)
tx)) (forall era a.
(Eq (PredicateFailure (EraRule "UTXOW" era)), Eq a,
 Show (PredicateFailure (EraRule "UTXOW" era)), Show a, Reflect era,
 HasCallStack) =>
Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Assertion
specialCont @era Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era)))
  (State (EraRule "UTXOW" era))
Either
  (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) (UTxOState era)
expected)

-- | 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.
  ( ShelleyEraTest era
  , STS (EraRule "UTXOW" era)
  , BaseM (EraRule "UTXOW" era) ~ ShelleyBase
  , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
  , State (EraRule "UTXOW" era) ~ UTxOState era
  , Tx era ~ Signal (EraRule "UTXOW" era)
  ) =>
  (Result era -> Result era -> Assertion) ->
  UTxO era ->
  PParams era ->
  Tx era ->
  Result era ->
  Assertion
testUTXOWwith :: forall era.
(ShelleyEraTest era, STS (EraRule "UTXOW" era),
 BaseM (EraRule "UTXOW" era) ~ ShelleyBase,
 Environment (EraRule "UTXOW" era) ~ UtxoEnv era,
 State (EraRule "UTXOW" era) ~ UTxOState era,
 Tx era ~ Signal (EraRule "UTXOW" era)) =>
(Result era -> Result era -> Assertion)
-> UTxO era -> PParams era -> Tx era -> Result era -> Assertion
testUTXOWwith 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 forall (s :: Symbol) e ans.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
TRC (EraRule s e)
-> (Either
      (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
    -> ans)
-> ans
runSTS @"UTXOW" @era ((Environment (EraRule "UTXOW" era), State (EraRule "UTXOW" era),
 Signal (EraRule "UTXOW" era))
-> TRC (EraRule "UTXOW" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (UtxoEnv era
Environment (EraRule "UTXOW" era)
env, State (EraRule "UTXOW" era)
UTxOState era
state, Tx era
Signal (EraRule "UTXOW" era)
tx)) (Result era -> Result era -> Assertion
cont Result era
expected)

runLEDGER ::
  forall era.
  ( BaseM (EraRule "LEDGER" era) ~ ShelleyBase
  , STS (EraRule "LEDGER" era)
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , State (EraRule "LEDGER" era) ~ LedgerState era
  , Tx era ~ Signal (EraRule "LEDGER" era)
  ) =>
  LedgerState era ->
  PParams era ->
  Tx era ->
  Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (State (EraRule "LEDGER" era))
runLEDGER :: forall era.
(BaseM (EraRule "LEDGER" era) ~ ShelleyBase,
 STS (EraRule "LEDGER" era),
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 State (EraRule "LEDGER" era) ~ LedgerState era,
 Tx era ~ Signal (EraRule "LEDGER" era)) =>
LedgerState era
-> PParams era
-> Tx era
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (State (EraRule "LEDGER" era))
runLEDGER 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 forall (s :: Symbol) e.
(BaseM (EraRule s e) ~ ShelleyBase, STS (EraRule s e)) =>
TRC (EraRule s e)
-> Either
     (NonEmpty (PredicateFailure (EraRule s e))) (State (EraRule s e))
runSTS' @"LEDGER" @era ((Environment (EraRule "LEDGER" era), State (EraRule "LEDGER" era),
 Signal (EraRule "LEDGER" era))
-> TRC (EraRule "LEDGER" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv era
Environment (EraRule "LEDGER" era)
env, State (EraRule "LEDGER" era)
LedgerState era
state, Tx era
Signal (EraRule "LEDGER" era)
tx))

-- | A small example of what a continuation for 'runSTS' might look like
genericCont ::
  ( Eq (t x)
  , Eq y
  , ToExpr y
  , HasCallStack
  , ToExpr (t x)
  ) =>
  String ->
  Either (t x) y ->
  Either (t x) y ->
  Assertion
genericCont :: forall (t :: * -> *) x y.
(Eq (t x), Eq y, ToExpr y, HasCallStack, ToExpr (t x)) =>
String -> Either (t x) y -> Either (t x) y -> Assertion
genericCont String
cause Either (t x) y
expected Either (t x) y
computed =
  Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Either (t x) y
computed Either (t x) y -> Either (t x) y -> Bool
forall a. Eq a => a -> a -> Bool
/= Either (t x) y
expected) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$
    String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$
      String
"Mismatch between expected and computed:\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> String
ansiDocToString Doc AnsiStyle
diff String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n\nCause:\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
cause
  where
    diff :: Doc AnsiStyle
diff = Either (t x) y -> Either (t x) y -> Doc AnsiStyle
forall a. ToExpr a => a -> a -> Doc AnsiStyle
diffExpr Either (t x) y
expected Either (t x) y
computed

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 =
  let
    isSubset :: 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
   in
    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 :: * -> *} {t :: * -> *} {a}.
(Foldable t, 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) ->
        String -> Assertion
forall a. HasCallStack => String -> a
error (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$
          String
"expected to pass with "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show (y -> Expr
forall a. ToExpr a => a -> Expr
toExpr y
y)
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\nBut failed with\n\n"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
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]
toList t x
x)
      (Right y
y, Left t x
x) ->
        String -> Assertion
forall a. HasCallStack => String -> a
error (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$
          String
"expected to fail with "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
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]
toList t x
x)
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\nBut passed with\n\n"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show (y -> Expr
forall a. ToExpr a => a -> Expr
toExpr y
y)

specialCont ::
  forall era a.
  ( Eq (PredicateFailure (EraRule "UTXOW" era))
  , Eq a
  , Show (PredicateFailure (EraRule "UTXOW" era))
  , Show a
  , Reflect era
  , HasCallStack
  ) =>
  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, Reflect era,
 HasCallStack) =>
Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Either (NonEmpty (PredicateFailure (EraRule "UTXOW" era))) a
-> Assertion
specialCont 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 (forall era. Reflect era => Proof era
reify @era) 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 (forall era. Reflect era => Proof era
reify @era) 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))
_) -> String -> Assertion
forall a. HasCallStack => String -> a
error String
"Not both ValidationTagMismatch case 1"
    (Left NonEmpty (PredicateFailure (EraRule "UTXOW" era))
_, Left NonEmpty (PredicateFailure (EraRule "UTXOW" era))
_) -> String -> Assertion
forall a. HasCallStack => String -> a
error String
"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
_) -> String -> Assertion
forall a. HasCallStack => String -> a
error String
"expected to pass, but failed."
    (Right a
_, Left NonEmpty (PredicateFailure (EraRule "UTXOW" era))
_) -> String -> Assertion
forall a. HasCallStack => String -> a
error String
"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