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

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

import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusTxInfo, toPlutusTxCert)
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
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.Era (ConwayEraTest)
import Test.Cardano.Ledger.Conway.Genesis ()

spec ::
  forall era.
  ( ConwayEraTest era
  , EraPlutusTxInfo PlutusV3 era
  , TxCert era ~ ConwayTxCert era
  ) =>
  Spec
spec :: forall era.
(ConwayEraTest era, EraPlutusTxInfo 'PlutusV3 era,
 TxCert era ~ ConwayTxCert era) =>
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 -> TxCert era -> TxCert
trans ProtVer
pv TxCert era
cert = (ContextError era -> TxCert)
-> (TxCert -> TxCert) -> Either (ContextError era) 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)
-> (ContextError era -> String) -> ContextError era -> TxCert
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextError era -> 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 @era Proxy 'PlutusV3
forall {k} (t :: k). Proxy t
Proxy ProtVer
pv TxCert era
cert)
        transV9 :: TxCert era -> TxCert
transV9 = ProtVer -> TxCert era -> TxCert
trans (Version -> Nat -> ProtVer
ProtVer (forall (v :: Nat).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) Nat
0)
        transV10 :: TxCert era -> TxCert
transV10 = ProtVer -> TxCert era -> TxCert
trans (Version -> Nat -> ProtVer
ProtVer (forall (v :: Nat).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @10) Nat
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
$ TxCert era -> TxCert
transV9 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert era
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert era)
-> ConwayDelegCert -> ConwayTxCert era
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
$ TxCert era -> TxCert
transV9 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ StakeCredential -> Coin -> TxCert era
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
$ TxCert era -> TxCert
transV9 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert era
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert era)
-> ConwayDelegCert -> ConwayTxCert era
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
$ TxCert era -> TxCert
transV10 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert era
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert era)
-> ConwayDelegCert -> ConwayTxCert era
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
$ TxCert era -> TxCert
transV10 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ StakeCredential -> Coin -> TxCert era
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
$ TxCert era -> TxCert
transV10 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert era
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert era)
-> ConwayDelegCert -> ConwayTxCert era
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
$ TxCert era -> TxCert
transV9 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert era
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert era)
-> ConwayDelegCert -> ConwayTxCert era
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
$ TxCert era -> TxCert
transV9 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ StakeCredential -> Coin -> TxCert era
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
$ TxCert era -> TxCert
transV9 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert era
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert era)
-> ConwayDelegCert -> ConwayTxCert era
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
$ TxCert era -> TxCert
transV10 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert era
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert era)
-> ConwayDelegCert -> ConwayTxCert era
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
$ TxCert era -> TxCert
transV10 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ StakeCredential -> Coin -> TxCert era
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
$ TxCert era -> TxCert
transV10 (TxCert era -> TxCert) -> TxCert era -> TxCert
forall a b. (a -> b) -> a -> b
$ ConwayDelegCert -> ConwayTxCert era
forall era. ConwayDelegCert -> ConwayTxCert era
ConwayTxCertDeleg (ConwayDelegCert -> ConwayTxCert era)
-> ConwayDelegCert -> ConwayTxCert era
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