{-# 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
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TxInfo" forall a b. (a -> b) -> a -> b
$ do
    let trans :: ProtVer -> ConwayTxCert ConwayEra -> TxCert
trans ProtVer
pv ConwayTxCert ConwayEra
cert = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) 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 forall {k} (t :: k). Proxy t
Proxy ProtVer
pv 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)

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

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

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

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