{-# 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.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 @ConwayEra 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
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'PParamUpdatePurpose ConwayEra)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'HardForkPurpose ConwayEra)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'CommitteePurpose ConwayEra)
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(GovPurposeId 'ConstitutionPurpose ConwayEra)
    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
    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 @ConwayEra
    -- 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 @ConwayEra @ConwayGenesis
    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 BabbageEra
ls :: LedgerState BabbageEra) ConwayGenesis
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 BabbageEra
          lsBabbage :: LedgerState BabbageEra
lsBabbage = LedgerState BabbageEra
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
utxosStakeDistrL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IncrementalStake (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 ConwayEra
          lsConway :: LedgerState ConwayEra
lsConway = forall era (f :: * -> *).
(TranslateEra era f, TranslationError era f ~ Void) =>
TranslationContext era -> f (PreviousEra era) -> f era
translateEra' ConwayGenesis
conwayGenesis LedgerState BabbageEra
lsBabbage
          v :: Version
v = forall era. Era era => Version
eraProtVerLow @ConwayEra
          expectNoBadPtr :: LedgerState ConwayEra -> LedgerState ConwayEra -> Expectation
          expectNoBadPtr :: LedgerState ConwayEra -> LedgerState ConwayEra -> Expectation
expectNoBadPtr LedgerState ConwayEra
x LedgerState ConwayEra
y = LedgerState ConwayEra
x forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` (LedgerState ConwayEra
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
utxosStakeDistrL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IncrementalStake (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 ConwayEra -> LedgerState ConwayEra -> Expectation
expectNoBadPtr LedgerState ConwayEra
lsConway