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

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

import Cardano.Ledger.Babbage
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary
import Cardano.Ledger.Conway
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Genesis
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Credential
import Cardano.Ledger.Crypto
import Cardano.Ledger.Shelley.LedgerState
import Data.Default (def)
import qualified Data.Map.Strict as Map
import Lens.Micro
import Test.Cardano.Ledger.Binary.RoundTrip
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Cardano.Ledger.Conway.Binary.RoundTrip (roundTripConwayCommonSpec)
import Test.Cardano.Ledger.Conway.TreeDiff ()
import Test.Cardano.Ledger.Core.Binary (specUpgrade)
import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraSpec)

spec :: Spec
spec :: Spec
spec = do
  forall era.
(Arbitrary (TxOut (PreviousEra era)),
 Arbitrary (TxCert (PreviousEra era)),
 Arbitrary (TxAuxData (PreviousEra era)),
 Arbitrary (TxWits (PreviousEra era)),
 Arbitrary (TxBody (PreviousEra era)), EraTx (PreviousEra era),
 EraTx era, Arbitrary (Tx (PreviousEra era)),
 Arbitrary (Script (PreviousEra era)), HasCallStack,
 ToExpr (Tx era), ToExpr (TxBody era), ToExpr (TxWits era),
 ToExpr (TxAuxData era)) =>
BinaryUpgradeOpts -> Spec
specUpgrade @Conway forall a. Default a => a
def
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RoundTrip" forall a b. (a -> b) -> a -> b
$ do
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovActionId StandardCrypto)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'PParamUpdatePurpose Conway)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'HardForkPurpose Conway)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'CommitteePurpose Conway)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'ConstitutionPurpose Conway)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @Vote
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(Voter StandardCrypto)
    forall era.
(EraTx era, EraGov era, StashedAVVMAddresses era ~ (),
 Arbitrary (Tx era), Arbitrary (TxBody era), Arbitrary (TxOut era),
 Arbitrary (TxCert era), Arbitrary (TxWits era),
 Arbitrary (TxAuxData era), Arbitrary (Value era),
 Arbitrary (CompactForm (Value era)), Arbitrary (Script era),
 Arbitrary (GovState era), Arbitrary (PParams era),
 Arbitrary (PParamsUpdate era),
 Arbitrary (PParamsHKD StrictMaybe era), RuleListEra era) =>
Spec
roundTripConwayCommonSpec @Conway
    -- ConwayGenesis only makes sense in Conway era
    forall era t.
(Era era, Show t, Eq t, EncCBOR t, DecCBOR t, Arbitrary t,
 HasCallStack) =>
Spec
roundTripEraSpec @Conway @(ConwayGenesis StandardCrypto)
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Regression" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Drop Ptrs from Incrementasl Stake" forall a b. (a -> b) -> a -> b
$ \(LedgerState Babbage
ls :: LedgerState Babbage) ConwayGenesis StandardCrypto
conwayGenesis SlotNo
slotNo CompactForm Coin
testCoin -> do
        let
          badPtr :: Ptr
badPtr = SlotNo -> TxIx -> CertIx -> Ptr
Ptr SlotNo
slotNo (Word64 -> TxIx
TxIx forall a. Bounded a => a
maxBound) (Word64 -> CertIx
CertIx forall a. Bounded a => a
maxBound)
          lsBabbage :: LedgerState Babbage
          lsBabbage :: LedgerState Babbage
lsBabbage = LedgerState Babbage
ls forall a b. a -> (a -> b) -> b
& forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (UTxOState era) (IncrementalStake (EraCrypto era))
utxosStakeDistrL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Lens' (IncrementalStake c) (Map Ptr (CompactForm Coin))
ptrMapL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall k a. k -> a -> Map k a
Map.singleton Ptr
badPtr CompactForm Coin
testCoin
          lsConway :: LedgerState Conway
          lsConway :: LedgerState Conway
lsConway = forall era (f :: * -> *).
(TranslateEra era f, TranslationError era f ~ Void) =>
TranslationContext era -> f (PreviousEra era) -> f era
translateEra' ConwayGenesis StandardCrypto
conwayGenesis LedgerState Babbage
lsBabbage
          v :: Version
v = forall era. Era era => Version
eraProtVerLow @Conway
          expectNoBadPtr :: LedgerState Conway -> LedgerState Conway -> Expectation
          expectNoBadPtr :: LedgerState Conway -> LedgerState Conway -> Expectation
expectNoBadPtr LedgerState Conway
x LedgerState Conway
y = LedgerState Conway
x forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` (LedgerState Conway
y forall a b. a -> (a -> b) -> b
& forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Lens' (UTxOState era) (IncrementalStake (EraCrypto era))
utxosStakeDistrL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Lens' (IncrementalStake c) (Map Ptr (CompactForm Coin))
ptrMapL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => a
mempty)
        forall a b.
(Typeable b, Eq b, HasCallStack) =>
Version
-> Version
-> Trip a b
-> (b -> a -> Expectation)
-> a
-> Expectation
embedTripExpectation Version
v Version
v (forall a b. (a -> Encoding) -> (forall s. Decoder s b) -> Trip a b
mkTrip forall a. EncCBOR a => a -> Encoding
encCBOR forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR) LedgerState Conway -> LedgerState Conway -> Expectation
expectNoBadPtr LedgerState Conway
lsConway