{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Shelley.Imp.LedgerSpec (
  spec,
) where

import Cardano.Ledger.BaseTypes (inject)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.UTxO (UTxO (..))
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro ((&), (.~), (^.))
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.ImpTest

spec ::
  forall era.
  ShelleyEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
ShelleyEraImp era =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"LEDGER" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Transactions update UTxO" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    Addr
addr1 <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
    let coin1 :: Coin
coin1 = Integer -> Coin
Coin Integer
2000000
    Tx era
tx1 <-
      String -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"First transaction" (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (TxBody era -> Tx era)
-> TxBody era
-> ImpM (LedgerSpec era) (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> ImpM (LedgerSpec era) (Tx era))
-> TxBody era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
        TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL @era
            ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a
SSeq.singleton
              (Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr1 (Value era -> TxOut era) -> Value era -> TxOut era
forall a b. (a -> b) -> a -> b
$ Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
coin1)
    UTxO Map TxIn (TxOut era)
utxo1 <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
    case TxIn -> Map TxIn (TxOut era) -> Maybe (TxOut era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Int -> Tx era -> TxIn
forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Int
0 :: Int) Tx era
tx1) Map TxIn (TxOut era)
utxo1 of
      Just TxOut era
out1 -> TxOut era
out1 TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
coin1
      Maybe (TxOut era)
Nothing -> String -> ImpM (LedgerSpec era) ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => String -> m ()
expectationFailure String
"Could not find the TxOut of the first transaction"
    Addr
addr2 <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
    let coin2 :: Coin
coin2 = Integer -> Coin
Coin Integer
3000000
    Tx era
tx2 <-
      String -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Second transaction" (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (TxBody era -> Tx era)
-> TxBody era
-> ImpM (LedgerSpec era) (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> ImpM (LedgerSpec era) (Tx era))
-> TxBody era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
        TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
            ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton
              (Int -> Tx era -> TxIn
forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Int
0 :: Int) Tx era
tx1)
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL @era
            ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a
SSeq.singleton (Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr2 (Value era -> TxOut era) -> Value era -> TxOut era
forall a b. (a -> b) -> a -> b
$ Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
coin2)
    UTxO Map TxIn (TxOut era)
utxo2 <- ImpTestM era (UTxO era)
forall era. ImpTestM era (UTxO era)
getUTxO
    case TxIn -> Map TxIn (TxOut era) -> Maybe (TxOut era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Int -> Tx era -> TxIn
forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Int
0 :: Int) Tx era
tx2) Map TxIn (TxOut era)
utxo2 of
      Just TxOut era
out1 -> do
        TxOut era
out1 TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Coin
coin2
      Maybe (TxOut era)
Nothing -> String -> ImpM (LedgerSpec era) ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => String -> m ()
expectationFailure String
"Could not find the TxOut of the second transaction"