{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Conway.TxInfoSpec (spec) where

import Cardano.Ledger.Alonzo.Plutus.Context (toPlutusTxCert)
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway (ConwayEra)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Credential (StakeCredential)
import Cardano.Ledger.Plutus.Language (Language (..))
import Data.Proxy (Proxy (..))
import qualified PlutusLedgerApi.V2 as PV2
import qualified PlutusLedgerApi.V3 as PV3
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Conway.Genesis ()

spec :: Spec
spec :: Spec
spec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TxInfo" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    let trans :: ProtVer -> ConwayTxCert ConwayEra -> TxCert
trans ProtVer
pv ConwayTxCert ConwayEra
cert = (ConwayContextError ConwayEra -> TxCert)
-> (TxCert -> TxCert)
-> Either (ConwayContextError ConwayEra) TxCert
-> TxCert
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> TxCert
forall a. HasCallStack => String -> a
error (String -> TxCert)
-> (ConwayContextError ConwayEra -> String)
-> ConwayContextError ConwayEra
-> TxCert
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayContextError ConwayEra -> String
forall a. Show a => a -> String
show) TxCert -> TxCert
forall a. a -> a
id (forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> ProtVer
-> TxCert era
-> Either (ContextError era) (PlutusTxCert l)
toPlutusTxCert @'PlutusV3 @ConwayEra Proxy 'PlutusV3
forall {k} (t :: k). Proxy t
Proxy ProtVer
pv TxCert ConwayEra
ConwayTxCert ConwayEra
cert)
        transV9 :: ConwayTxCert ConwayEra -> TxCert
transV9 = ProtVer -> ConwayTxCert ConwayEra -> TxCert
trans (Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) Natural
0)
        transV10 :: ConwayTxCert ConwayEra -> TxCert
transV10 = ProtVer -> ConwayTxCert ConwayEra -> TxCert
trans (Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10) Natural
0)

    String -> (StakeCredential -> Coin -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Deposit in registration certs" ((StakeCredential -> Coin -> IO ()) -> Spec)
-> (StakeCredential -> Coin -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \(StakeCredential
cred :: StakeCredential) (Coin
coin :: Coin) -> do
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ StakeCredential -> StrictMaybe Coin -> ConwayDelegCert
ConwayRegCert StakeCredential
cred (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
coin)
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ StakeCredential -> Coin -> TxCert ConwayEra
forall era.
ConwayEraTxCert era =>
StakeCredential -> Coin -> TxCert era
RegDepositTxCert StakeCredential
cred Coin
coin
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ StakeCredential -> StrictMaybe Coin -> ConwayDelegCert
ConwayRegCert StakeCredential
cred StrictMaybe Coin
forall a. StrictMaybe a
SNothing

      Coin -> TxCert -> IO ()
expectDeposit Coin
coin (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ StakeCredential -> StrictMaybe Coin -> ConwayDelegCert
ConwayRegCert StakeCredential
cred (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
coin)
      Coin -> TxCert -> IO ()
expectDeposit Coin
coin (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ StakeCredential -> Coin -> TxCert ConwayEra
forall era.
ConwayEraTxCert era =>
StakeCredential -> Coin -> TxCert era
RegDepositTxCert StakeCredential
cred Coin
coin
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ StakeCredential -> StrictMaybe Coin -> ConwayDelegCert
ConwayRegCert StakeCredential
cred StrictMaybe Coin
forall a. StrictMaybe a
SNothing

    String -> (StakeCredential -> Coin -> IO ()) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Deposit in unregistration certs" ((StakeCredential -> Coin -> IO ()) -> Spec)
-> (StakeCredential -> Coin -> IO ()) -> Spec
forall a b. (a -> b) -> a -> b
$ \(StakeCredential
cred :: StakeCredential) (Coin
coin :: Coin) -> do
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ StakeCredential -> StrictMaybe Coin -> ConwayDelegCert
ConwayUnRegCert StakeCredential
cred (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
coin)
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ StakeCredential -> Coin -> TxCert ConwayEra
forall era.
ConwayEraTxCert era =>
StakeCredential -> Coin -> TxCert era
UnRegDepositTxCert StakeCredential
cred Coin
coin
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV9 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ StakeCredential -> StrictMaybe Coin -> ConwayDelegCert
ConwayUnRegCert StakeCredential
cred StrictMaybe Coin
forall a. StrictMaybe a
SNothing

      Coin -> TxCert -> IO ()
expectDeposit Coin
coin (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ StakeCredential -> StrictMaybe Coin -> ConwayDelegCert
ConwayUnRegCert StakeCredential
cred (Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
coin)
      Coin -> TxCert -> IO ()
expectDeposit Coin
coin (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ StakeCredential -> Coin -> TxCert ConwayEra
forall era.
ConwayEraTxCert era =>
StakeCredential -> Coin -> TxCert era
UnRegDepositTxCert StakeCredential
cred Coin
coin
      TxCert -> IO ()
expectNoDeposit (TxCert -> IO ()) -> TxCert -> IO ()
forall a b. (a -> b) -> a -> b
$ ConwayTxCert ConwayEra -> TxCert
transV10 (ConwayTxCert ConwayEra -> TxCert)
-> ConwayTxCert ConwayEra -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert ConwayEra
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert ConwayEra)
-> ConwayDelegCert -> ConwayTxCert ConwayEra
forall a b. (a -> b) -> a -> b
$ StakeCredential -> StrictMaybe Coin -> ConwayDelegCert
ConwayUnRegCert StakeCredential
cred StrictMaybe Coin
forall a. StrictMaybe a
SNothing
  where
    expectDeposit :: Coin -> PV3.TxCert -> IO ()
    expectDeposit :: Coin -> TxCert -> IO ()
expectDeposit (Coin Integer
c) =
      \case
        PV3.TxCertRegStaking Credential
_ (Just Lovelace
d) -> Integer -> Lovelace
PV2.Lovelace Integer
c Lovelace -> Lovelace -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Lovelace
d
        PV3.TxCertUnRegStaking Credential
_ (Just Lovelace
d) -> Integer -> Lovelace
PV2.Lovelace Integer
c Lovelace -> Lovelace -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Lovelace
d
        TxCert
txcert ->
          HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Deposit: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall a. Show a => a -> String
show (Integer -> Coin
Coin Integer
c) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" expected in: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxCert -> String
forall a. Show a => a -> String
show TxCert
txcert String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", but not found"
    expectNoDeposit :: PV3.TxCert -> IO ()
    expectNoDeposit :: TxCert -> IO ()
expectNoDeposit =
      \case
        PV3.TxCertRegStaking Credential
_ Maybe Lovelace
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        PV3.TxCertUnRegStaking Credential
_ Maybe Lovelace
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        TxCert
txcert ->
          HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Deposit not expected, but found in: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxCert -> String
forall a. Show a => a -> String
show TxCert
txcert