{-# 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,
  alwaysFailsHash,
  alwaysSucceedsHash,
  timelockScript,
  timelockHash,
) where

import Cardano.Ledger.Allegra.Scripts (AllegraEraScript, pattern RequireTimeStart)
import Cardano.Ledger.Alonzo.Scripts (AlonzoEraScript (..), AsIx, ExUnits (..))
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..))
import Cardano.Ledger.BaseTypes (StrictMaybe (..), mkTxIxPartial)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core (AlonzoEraTxOut (..), ScriptIntegrityHash)
import Cardano.Ledger.Plutus (Language)
import Cardano.Ledger.Plutus.Data (Data (..), hashData)
import Cardano.Ledger.Shelley.Core hiding (TranslationError)
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 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.Common hiding (Result)
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.Shelley.Era (EraTest)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
import Test.Cardano.Ledger.Shelley.Utils (RawSeed (..), mkKeyPair, mkKeyPair')

data PlutusPurposeTag
  = Spending
  | Minting
  | Certifying
  | Withdrawing
  | 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 TopTx 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 TopTx 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

-- ======================================================================
-- ========================= 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)