diff --git a/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal b/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal index d009910ba88..ba2c0be5056 100644 --- a/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal +++ b/shelley-ma/shelley-ma-test/cardano-ledger-shelley-ma-test.cabal @@ -20,11 +20,10 @@ source-repository head library exposed-modules: Test.Cardano.Ledger.ShelleyMA.TestEra - Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators Test.Cardano.Ledger.ShelleyMA.TxBody Test.Cardano.Ledger.ShelleyMA.Serialisation.Timelocks Test.Cardano.Ledger.ShelleyMA.Serialisation.Coders - + Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators -- other-extensions: build-depends: array, @@ -33,9 +32,13 @@ library base >=4.9 && <4.15, bytestring, cardano-binary, + cardano-crypto, cardano-crypto-class, cardano-crypto-praos, + cardano-crypto-test, + cardano-crypto-wrapper, cardano-prelude, + generic-random, cardano-slotting, cborg, containers, @@ -50,6 +53,7 @@ library tasty-quickcheck, tasty, text, + QuickCheck >= 2.13.2, hs-source-dirs: src ghc-options: -Wall @@ -82,12 +86,18 @@ test-suite cardano-ledger-shelley-ma-test -- determined ad-hoc. "-with-rtsopts=-K4m -M250m" build-depends: + cardano-ledger-shelley-ma, + shelley-spec-ledger-test, cardano-ledger-shelley-ma-test, base >=4.9 && <4.15, bytestring, cardano-binary, + cardano-crypto, cardano-crypto-class, cardano-crypto-praos, + cardano-crypto-test, + cardano-crypto-wrapper, + generic-random, cardano-prelude, cardano-slotting, cborg, @@ -102,3 +112,5 @@ test-suite cardano-ledger-shelley-ma-test tasty-hunit, tasty-quickcheck, tasty, + text, + QuickCheck, diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs index 61dfe3c0ccb..ecd9259e1b8 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Generators.hs @@ -1,31 +1,90 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-orphans #-} -- orphan Arbitrary instances - --- | This module is usually imported for its Arbitrary instances -module Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators where +module Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators + ( sizedTimelock, + maxTimelockDepth, + ) +where -import Cardano.Slotting.Slot (SlotNo (..)) -import Cardano.Ledger.Era(Era(..)) -import Cardano.Ledger.ShelleyMA.Timelocks - ( Timelock (RequireSignature, RequireAllOf, RequireAnyOf, RequireMOf, RequireTimeExpire, RequireTimeStart), +import Cardano.Binary + ( toCBOR, ) +import Cardano.Crypto.Hash (HashAlgorithm, hashWithSerialiser) +import qualified Cardano.Crypto.Hash as Hash +import Cardano.Ledger.Allegra (AllegraEra) +import qualified Cardano.Ledger.Core as Abstract +import Cardano.Ledger.Era (Era) +import Cardano.Ledger.Mary (MaryEra) +import qualified Cardano.Ledger.Mary.Value as Mary (AssetID (..), PolicyID (..), Value (..)) +import Cardano.Ledger.Shelley (ShelleyBased) +import qualified Cardano.Ledger.ShelleyMA.Rules.Utxo as MA.STS +import qualified Cardano.Ledger.ShelleyMA.Scripts as MA (Timelock (..)) +import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..), ValidityInterval) +import qualified Cardano.Ledger.ShelleyMA.TxBody as MA (TxBody (..)) +import Data.Coerce (coerce) import Data.Sequence.Strict (fromList) -import Shelley.Spec.Ledger.Keys (KeyHash (..)) -import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (SJust, SNothing)) -import Test.Shelley.Spec.Ledger.Serialisation.Generators(mkDummyHash) -- imports arbitray instance for MultiSig -import Test.Tasty.QuickCheck hiding (scale) +import Generic.Random (genericArbitraryU) +import Shelley.Spec.Ledger.API hiding (SignedDSIGN, TxBody (..)) +import Test.QuickCheck + ( Arbitrary, + arbitrary, + choose, + genericShrink, + listOf, + oneof, + resize, + shrink, + ) +import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) +import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators () +import Test.Tasty.QuickCheck (Gen) + +{------------------------------------------------------------------------------- + ShelleyMAEra Generators --- ================================================================ + Generators used for roundtrip tests, generated values are not + necessarily valid +-------------------------------------------------------------------------------} --- ================================================================================ --- Some generators for Timelock +mkDummyHash :: forall h a. HashAlgorithm h => Int -> Hash.Hash h a +mkDummyHash = coerce . hashWithSerialiser @h toCBOR -genSlot :: Gen (StrictMaybe SlotNo) -genSlot = oneof [ pure SNothing, (SJust . SlotNo) <$> choose (0,10)] +genTxBody :: + ( ShelleyBased era, + Arbitrary (Abstract.Value era), + Arbitrary (TxOut era), + Arbitrary (DCert era), + Arbitrary (Wdrl era), + Arbitrary (Update era) + ) => + Gen (MA.TxBody era) +genTxBody = + MA.TxBody + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary maxTimelockDepth :: Int maxTimelockDepth = 3 @@ -33,19 +92,59 @@ maxTimelockDepth = 3 maxTimelockListLens :: Int maxTimelockListLens = 5 -sizedTimelock :: (Era era) => Int -> Gen (Timelock era) -sizedTimelock 0 = (RequireSignature . KeyHash . mkDummyHash) <$> arbitrary +sizedTimelock :: + Era era => + Int -> + Gen (Timelock era) +sizedTimelock 0 = (MA.RequireSignature . KeyHash . mkDummyHash) <$> arbitrary sizedTimelock n = oneof - [ (RequireSignature . KeyHash . mkDummyHash) <$> arbitrary, - RequireAllOf <$> (fromList <$> resize maxTimelockListLens (listOf (sizedTimelock (n -1)))), - RequireAnyOf <$> (fromList <$> resize maxTimelockListLens (listOf (sizedTimelock (n -1)))), - do subs <- resize maxTimelockListLens (listOf (sizedTimelock (n -1))) - let i = length subs - RequireMOf <$> choose (0,i) <*> pure (fromList subs), - RequireTimeStart <$> genSlot, - RequireTimeExpire <$> genSlot + [ (MA.RequireSignature . KeyHash . mkDummyHash) <$> arbitrary, + MA.RequireAllOf <$> (fromList <$> resize maxTimelockListLens (listOf (sizedTimelock (n -1)))), + MA.RequireAnyOf <$> (fromList <$> resize maxTimelockListLens (listOf (sizedTimelock (n -1)))), + do + subs <- resize maxTimelockListLens (listOf (sizedTimelock (n -1))) + let i = length subs + MA.RequireMOf <$> choose (0, i) <*> pure (fromList subs), + RequireTimeStart <$> arbitrary, + RequireTimeExpire <$> arbitrary ] -instance (Era era) => Arbitrary (Timelock era) where +{------------------------------------------------------------------------------- + MaryEra Generators +-------------------------------------------------------------------------------} + +instance Mock c => Arbitrary (MA.TxBody (MaryEra c)) where + arbitrary = genTxBody + +instance Mock c => Arbitrary (Timelock (MaryEra c)) where arbitrary = sizedTimelock maxTimelockDepth + +instance Mock c => Arbitrary (Mary.PolicyID (MaryEra c)) where + arbitrary = Mary.PolicyID <$> arbitrary + +instance Mock c => Arbitrary (Mary.Value (MaryEra c)) where + arbitrary = Mary.Value <$> arbitrary <*> arbitrary + +instance Arbitrary Mary.AssetID where + arbitrary = Mary.AssetID <$> arbitrary + +instance Mock c => Arbitrary (MA.STS.UtxoPredicateFailure (MaryEra c)) where + arbitrary = genericArbitraryU + +{------------------------------------------------------------------------------- + AllegraEra Generators +-------------------------------------------------------------------------------} + +instance Mock c => Arbitrary (MA.TxBody (AllegraEra c)) where + arbitrary = genTxBody + +instance Mock c => Arbitrary (Timelock (AllegraEra c)) where + arbitrary = sizedTimelock maxTimelockDepth + +instance Arbitrary ValidityInterval where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance Mock c => Arbitrary (MA.STS.UtxoPredicateFailure (AllegraEra c)) where + arbitrary = genericArbitraryU diff --git a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Timelocks.hs b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Timelocks.hs index a3b050e7d64..4e8b1f9e26e 100644 --- a/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Timelocks.hs +++ b/shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Timelocks.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Test.Cardano.Ledger.ShelleyMA.Serialisation.Timelocks ( timelockTests, @@ -12,34 +14,38 @@ module Test.Cardano.Ledger.ShelleyMA.Serialisation.Timelocks ) where -import Cardano.Binary( Annotator (..), FromCBOR(..), ToCBOR(..) ) +import Cardano.Binary (Annotator (..), FromCBOR (..), ToCBOR (..)) +import Cardano.Ledger.Era (PreviousEra) import Cardano.Ledger.ShelleyMA.Timelocks - ( Timelock(..), - pattern Timelock, - translate, + ( Timelock (..), showTimelock, + translate, + pattern Timelock, ) import Cardano.Slotting.Slot (SlotNo (..)) import qualified Data.ByteString.Lazy as Lazy +import Data.MemoBytes (MemoBytes (Memo)) import Data.Sequence.Strict (fromList) import Shelley.Spec.Ledger.BaseTypes (StrictMaybe (SJust, SNothing)) +import Shelley.Spec.Ledger.Scripts (MultiSig, getMultiSigBytes) +import Test.Cardano.Ledger.ShelleyMA.Serialisation.Coders (embedTripAnn, roundTripAnn) +import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators (maxTimelockDepth, sizedTimelock) import Test.Cardano.Ledger.ShelleyMA.TxBody (TestEra) +import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators () +import Test.Shelley.Spec.Ledger.Serialisation.Generators () import Test.Tasty -import Test.Tasty.QuickCheck hiding (scale) -import Shelley.Spec.Ledger.Scripts(MultiSig,getMultiSigBytes) -import Test.Shelley.Spec.Ledger.Serialisation.Generators() -- imports arbitrary instance for MultiSig -import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators() -- imports arbitrary instance for Timelock -import Test.Cardano.Ledger.ShelleyMA.Serialisation.Coders(roundTripAnn, embedTripAnn) -import Data.MemoBytes(MemoBytes(Memo)) -import Cardano.Ledger.Era(PreviousEra) +import Test.Tasty.QuickCheck (Arbitrary, arbitrary, testProperty) + +instance Arbitrary (Timelock TestEra) where + arbitrary = sizedTimelock maxTimelockDepth -- ================================================================ s1 :: Timelock TestEra -s1 = RequireAllOf (fromList [ RequireTimeStart (SJust (SlotNo 12)), RequireTimeExpire SNothing]) +s1 = RequireAllOf (fromList [RequireTimeStart (SJust (SlotNo 12)), RequireTimeExpire SNothing]) s2 :: Timelock TestEra -s2 = RequireAllOf (fromList [ RequireTimeStart (SJust (SlotNo 12)), RequireTimeExpire (SJust (SlotNo 23))]) +s2 = RequireAllOf (fromList [RequireTimeStart (SJust (SlotNo 12)), RequireTimeExpire (SJust (SlotNo 23))]) s4 :: Timelock TestEra s4 = RequireAllOf (fromList [s1, s2]) @@ -54,15 +60,15 @@ checkOne nm t = testProperty ("RoundTrip: " ++ nm) $ checkAnn :: Timelock TestEra -> Bool checkAnn t = - case roundTripAnn t of - Right _ -> True - Left s -> error (show s) + case roundTripAnn t of + Right _ -> True + Left s -> error (show s) checkEmbed :: MultiSig TestEra -> Bool checkEmbed multi = case embedTripAnn @(Timelock TestEra) multi of - Right (left,_) | left == Lazy.empty -> True - Right (left,_) -> error("Bytes left over: "++show left) + Right (left, _) | left == Lazy.empty -> True + Right (left, _) -> error ("Bytes left over: " ++ show left) Left s -> error (show s) -- The translate tests depend upon translating from a previous era @@ -70,13 +76,13 @@ checkEmbed multi = -- PreviousEra. TestEra is only used in Serialisations tests, so -- this should not have any wider effect. -type instance PreviousEra(TestEra) = TestEra +type instance PreviousEra (TestEra) = TestEra checkTranslate :: MultiSig TestEra -> Bool checkTranslate multi = bytes == bytes2 - where bytes = getMultiSigBytes multi - (Timelock (Memo _ bytes2)) = translate @TestEra multi - + where + bytes = getMultiSigBytes multi + (Timelock (Memo _ bytes2)) = translate @TestEra multi timelockTests :: TestTree timelockTests = @@ -88,4 +94,4 @@ timelockTests = testProperty "roundtripTimelock" checkAnn, testProperty "MultiSig deserialises as Timelock" checkEmbed, testProperty "Translate preserves bytes" checkTranslate - ] \ No newline at end of file + ] diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchUTxOAggregate.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchUTxOAggregate.hs index 222e7a59ee2..6fca06bc282 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchUTxOAggregate.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/bench/BenchUTxOAggregate.hs @@ -9,16 +9,16 @@ module BenchUTxOAggregate where import Cardano.Ledger.Compactible (toCompact) import Cardano.Ledger.Era (Era (Crypto)) import qualified Cardano.Ledger.Val as Val -import Control.SetAlgebra (Bimap, biMapFromList, dom, (▷), (◁)) import Control.Iterate.SetAlgebra (compile, compute, run) +import Control.SetAlgebra (Bimap, biMapFromList, dom, (▷), (◁)) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Sequence as Seq import Shelley.Spec.Ledger.Address ( Addr (..), ) -import Shelley.Spec.Ledger.CompactAddr (compactAddr) import Shelley.Spec.Ledger.Coin (Coin (..)) +import Shelley.Spec.Ledger.CompactAddr (compactAddr) import Shelley.Spec.Ledger.Credential ( Credential (..), Ptr (..), @@ -30,6 +30,7 @@ import Shelley.Spec.Ledger.LedgerState InstantaneousRewards (..), PState (..), ) +import Shelley.Spec.Ledger.Scripts () import Shelley.Spec.Ledger.TxBody ( PoolParams (..), TxId (..), @@ -42,7 +43,8 @@ import Shelley.Spec.Ledger.UTxO import Test.QuickCheck import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (C, C_Crypto) import Test.Shelley.Spec.Ledger.Examples.Cast (alicePoolParams) -import Test.Shelley.Spec.Ledger.Serialisation.Generators (mkDummyHash) +import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators (mkDummyHash) +import Test.Shelley.Spec.Ledger.Serialisation.Generators () genTestCase :: Int -> -- The size of the utxo diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal b/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal index 260cc5d7f78..a7a0726398c 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal @@ -39,6 +39,7 @@ library Test.Shelley.Spec.Ledger.Generator.Utxo Test.Shelley.Spec.Ledger.Orphans Test.Shelley.Spec.Ledger.Serialisation.Generators + Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators Test.Shelley.Spec.Ledger.Serialisation.Generators.Bootstrap Test.Shelley.Spec.Ledger.Serialisation.Generators.Genesis Test.Shelley.Spec.Ledger.Shrinkers diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs new file mode 100644 index 00000000000..5d288e58613 --- /dev/null +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/EraIndepGenerators.hs @@ -0,0 +1,777 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators + ( genPParams, + mkDummyHash, + genHash, + genShelleyAddress, + genByronAddress, + MockGen, + maxTxWits, + ) +where + +import Cardano.Binary + ( ToCBOR (..), + toCBOR, + ) +import Cardano.Crypto.DSIGN.Class + ( DSIGNAlgorithm, + SignedDSIGN (..), + rawDeserialiseSigDSIGN, + rawDeserialiseVerKeyDSIGN, + sizeSigDSIGN, + sizeVerKeyDSIGN, + ) +import Cardano.Crypto.DSIGN.Mock (VerKeyDSIGN (..)) +import Cardano.Crypto.Hash (HashAlgorithm, hashWithSerialiser) +import qualified Cardano.Crypto.Hash as Hash +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Crypto (DSIGN) +import qualified Cardano.Ledger.Crypto as CC (Crypto) +import Cardano.Ledger.Era (Crypto, Era) +import Cardano.Ledger.Shelley (ShelleyBased) +import qualified Cardano.Ledger.Shelley as Shelley +import Cardano.Slotting.Block (BlockNo (..)) +import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..)) +import Control.SetAlgebra (biMapFromList) +import qualified Data.ByteString.Char8 as BS +import Data.Coerce (coerce) +import Data.IP (IPv4, IPv6, toIPv4, toIPv6) +import qualified Data.Map.Strict as Map (empty, fromList) +import Data.Maybe (fromJust) +import Data.Proxy (Proxy (..)) +import Data.Ratio ((%)) +import Data.Sequence.Strict (StrictSeq) +import qualified Data.Sequence.Strict as StrictSeq +import qualified Data.Text as T +import qualified Data.Time as Time +import qualified Data.Time.Calendar.OrdinalDate as Time +import Data.Typeable (Typeable) +import Data.Word (Word64, Word8) +import Generic.Random (genericArbitraryU) +import Numeric.Natural (Natural) +import Shelley.Spec.Ledger.API hiding (SignedDSIGN, TxBody (..)) +import Shelley.Spec.Ledger.Address.Bootstrap + ( ChainCode (..), + ) +import Shelley.Spec.Ledger.BaseTypes + ( ActiveSlotCoeff, + DnsName, + UnitInterval, + Url, + mkActiveSlotCoeff, + mkNonceFromNumber, + mkUnitInterval, + textToDns, + textToUrl, + ) +import Shelley.Spec.Ledger.Coin (DeltaCoin (..)) +import Shelley.Spec.Ledger.Delegation.Certificates (IndividualPoolStake (..)) +import Shelley.Spec.Ledger.EpochBoundary (BlocksMade (..)) +import Shelley.Spec.Ledger.LedgerState + ( FutureGenDeleg, + emptyRewardUpdate, + ) +import qualified Shelley.Spec.Ledger.MetaData as MD +import Shelley.Spec.Ledger.Rewards + ( Likelihood (..), + LogWeight (..), + PerformanceEstimate (..), + ) +import qualified Shelley.Spec.Ledger.STS.Deleg as STS +import qualified Shelley.Spec.Ledger.STS.Delegs as STS +import qualified Shelley.Spec.Ledger.STS.Delpl as STS +import qualified Shelley.Spec.Ledger.STS.Ledger as STS +import qualified Shelley.Spec.Ledger.STS.Ledgers as STS +import qualified Shelley.Spec.Ledger.STS.Pool as STS +import qualified Shelley.Spec.Ledger.STS.Ppup as STS +import qualified Shelley.Spec.Ledger.STS.Prtcl as STS (PrtclState) +import qualified Shelley.Spec.Ledger.STS.Tickn as STS +import qualified Shelley.Spec.Ledger.STS.Utxow as STS +import Shelley.Spec.Ledger.Tx (ValidateScript, WitnessSetHKD (WitnessSet), hashScript) +import Test.QuickCheck + ( Arbitrary, + arbitrary, + genericShrink, + listOf, + oneof, + resize, + shrink, + vectorOf, + ) +import Test.QuickCheck.Gen (chooseAny) +import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) +import Test.Shelley.Spec.Ledger.Generator.Constants (defaultConstants) +import Test.Shelley.Spec.Ledger.Generator.Core + ( KeySpace (KeySpace_), + geConstants, + geKeySpace, + ksCoreNodes, + mkBlock, + mkBlockHeader, + mkOCert, + ) +import Test.Shelley.Spec.Ledger.Generator.Presets (coreNodeKeys, genEnv) +import qualified Test.Shelley.Spec.Ledger.Generator.Update as Update +import Test.Shelley.Spec.Ledger.Serialisation.Generators.Bootstrap + ( genBootstrapAddress, + genSignature, + ) +import Test.Tasty.QuickCheck (Gen, choose, elements) + +genHash :: forall a h. HashAlgorithm h => Gen (Hash.Hash h a) +genHash = mkDummyHash <$> arbitrary + +mkDummyHash :: forall h a. HashAlgorithm h => Int -> Hash.Hash h a +mkDummyHash = coerce . hashWithSerialiser @h toCBOR + +{------------------------------------------------------------------------------- + Generators + + These are generators for roundtrip tests, so the generated values are not + necessarily valid +-------------------------------------------------------------------------------} + +type MockGen era = + ( Mock (Crypto era), + Arbitrary (VerKeyDSIGN (DSIGN (Crypto era))) + ) + +instance Mock crypto => Arbitrary (BHeader crypto) where + arbitrary = do + prevHash <- arbitrary :: Gen (HashHeader crypto) + allPoolKeys <- elements (map snd (coreNodeKeys defaultConstants)) + curSlotNo <- SlotNo <$> choose (0, 10) + curBlockNo <- BlockNo <$> choose (0, 100) + epochNonce <- arbitrary :: Gen Nonce + bodySize <- arbitrary + bodyHash <- arbitrary + let kesPeriod = 1 + keyRegKesPeriod = 1 + ocert = mkOCert allPoolKeys 1 (KESPeriod kesPeriod) + return $ + mkBlockHeader + prevHash + allPoolKeys + curSlotNo + curBlockNo + epochNonce + kesPeriod + keyRegKesPeriod + ocert + bodySize + bodyHash + +instance DSIGNAlgorithm crypto => Arbitrary (SignedDSIGN crypto a) where + arbitrary = + SignedDSIGN . fromJust . rawDeserialiseSigDSIGN + <$> (genByteString . fromIntegral $ sizeSigDSIGN (Proxy @crypto)) + +instance DSIGNAlgorithm crypto => Arbitrary (VerKeyDSIGN crypto) where + arbitrary = + fromJust . rawDeserialiseVerKeyDSIGN + <$> (genByteString . fromIntegral $ sizeVerKeyDSIGN (Proxy @crypto)) + +instance + (Era era, MockGen era) => + Arbitrary (BootstrapWitness era) + where + arbitrary = do + key <- arbitrary + sig <- genSignature + chainCode <- ChainCode <$> arbitrary + attributes <- arbitrary + pure $ BootstrapWitness key sig chainCode attributes + +instance CC.Crypto crypto => Arbitrary (HashHeader crypto) where + arbitrary = HashHeader <$> genHash + +instance CC.Crypto crypto => Arbitrary (HashBBody crypto) where + arbitrary = UnsafeHashBBody <$> genHash + +instance (Typeable kr, Era era, Mock (Crypto era)) => Arbitrary (WitVKey kr era) where + arbitrary = + WitVKey + <$> arbitrary + <*> arbitrary + +instance (Era era, Mock (Crypto era)) => Arbitrary (Wdrl era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (ProposedPPUpdates era) where + arbitrary = ProposedPPUpdates <$> pure Map.empty + +instance (Era era, Mock (Crypto era)) => Arbitrary (Update era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +maxMetaDatumDepth :: Int +maxMetaDatumDepth = 2 + +maxMetaDatumListLens :: Int +maxMetaDatumListLens = 5 + +sizedMetaDatum :: Int -> Gen MD.MetaDatum +sizedMetaDatum 0 = + oneof + [ MD.I <$> arbitrary, + MD.B <$> arbitrary, + MD.S <$> (T.pack <$> arbitrary) + ] +sizedMetaDatum n = + oneof + [ MD.Map + <$> ( zip + <$> (resize maxMetaDatumListLens (listOf (sizedMetaDatum (n -1)))) + <*> (listOf (sizedMetaDatum (n -1))) + ), + MD.List <$> resize maxMetaDatumListLens (listOf (sizedMetaDatum (n -1))), + MD.I <$> arbitrary, + MD.B <$> arbitrary, + MD.S <$> (T.pack <$> arbitrary) + ] + +instance Arbitrary MD.MetaDatum where + arbitrary = sizedMetaDatum maxMetaDatumDepth + +instance Arbitrary MD.MetaData where + arbitrary = MD.MetaData <$> arbitrary + +maxTxWits :: Int +maxTxWits = 5 + +instance Era era => Arbitrary (TxId era) where + arbitrary = TxId <$> genHash + +instance Era era => Arbitrary (TxIn era) where + arbitrary = + TxIn + <$> (TxId <$> genHash) + <*> arbitrary + +instance + (ShelleyBased era, Mock (Crypto era), Arbitrary (Core.Value era)) => + Arbitrary (TxOut era) + where + arbitrary = TxOut <$> arbitrary <*> arbitrary + +instance Arbitrary Nonce where + arbitrary = + oneof + [ return NeutralNonce, + mkNonceFromNumber <$> choose (1, 123 :: Word64) + ] + +instance Arbitrary UnitInterval where + arbitrary = fromJust . mkUnitInterval . (% 100) <$> choose (1, 99) + +instance + (CC.Crypto crypto) => + Arbitrary (KeyHash a crypto) + where + arbitrary = KeyHash <$> genHash + +instance Era era => Arbitrary (WitHashes era) where + arbitrary = genericArbitraryU + +instance Arbitrary MIRPot where + arbitrary = genericArbitraryU + +instance Arbitrary Natural where + arbitrary = fromInteger <$> choose (0, 1000) + +instance Arbitrary STS.VotingPeriod where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance Arbitrary Coin where + -- Cannot be negative even though it is an 'Integer' + arbitrary = Coin <$> choose (0, 1000) + +instance Arbitrary DeltaCoin where + arbitrary = DeltaCoin <$> choose (-1000, 1000) + +instance Arbitrary SlotNo where + -- Cannot be negative even though it is an 'Integer' + arbitrary = SlotNo <$> choose (1, 100000) + +instance Arbitrary EpochNo where + -- Cannot be negative even though it is an 'Integer' + arbitrary = EpochNo <$> choose (1, 100000) + +instance (Era era, Mock (Crypto era)) => Arbitrary (Addr era) where + arbitrary = oneof [genShelleyAddress, genByronAddress] + +genShelleyAddress :: (Era era, Mock (Crypto era)) => Gen (Addr era) +genShelleyAddress = Addr <$> arbitrary <*> arbitrary <*> arbitrary + +genByronAddress :: Gen (Addr era) +genByronAddress = AddrBootstrap <$> genBootstrapAddress + +instance (Era era, Mock (Crypto era)) => Arbitrary (StakeReference era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance Era era => Arbitrary (Credential r era) where + arbitrary = + oneof + [ ScriptHashObj . ScriptHash <$> genHash, + KeyHashObj <$> arbitrary + ] + +instance Arbitrary Ptr where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (RewardAcnt era) where + arbitrary = RewardAcnt <$> arbitrary <*> arbitrary + +instance Arbitrary Network where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Arbitrary (VerKeyDSIGN (DSIGN crypto))) => Arbitrary (VKey kd crypto) where + arbitrary = VKey <$> arbitrary + +instance Arbitrary ProtVer where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance Era era => Arbitrary (ScriptHash era) where + arbitrary = ScriptHash <$> genHash + +instance Era era => Arbitrary (MD.MetaDataHash era) where + arbitrary = MD.MetaDataHash <$> genHash + +instance HashAlgorithm h => Arbitrary (Hash.Hash h a) where + arbitrary = genHash + +instance Arbitrary STS.TicknState where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance CC.Crypto crypto => Arbitrary (STS.PrtclState crypto) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance + (ShelleyBased era, Mock (Crypto era), Arbitrary (Core.Value era)) => + Arbitrary (UTxO era) + where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (PState era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (InstantaneousRewards era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Mock crypto) => Arbitrary (FutureGenDeleg crypto) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Mock crypto) => Arbitrary (GenDelegs crypto) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Mock crypto) => Arbitrary (GenDelegPair crypto) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (DState era) where + arbitrary = + DState + <$> arbitrary + <*> arbitrary + <*> (biMapFromList const <$> arbitrary) + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance (Era era, Mock (Crypto era)) => Arbitrary (DelegCert era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (Delegation era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (PoolCert era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (GenesisDelegCert era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (MIRCert era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (DCert era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (PPUPState era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (DPState era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance + (ShelleyBased era, Mock (Crypto era), Arbitrary (Core.Value era)) => + Arbitrary (UTxOState era) + where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance + (ShelleyBased era, Mock (Crypto era), Arbitrary (Core.Value era)) => + Arbitrary (LedgerState era) + where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance + (ShelleyBased era, Mock (Crypto era), Arbitrary (Core.Value era)) => + Arbitrary (NewEpochState era) + where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance Era era => Arbitrary (BlocksMade era) where + arbitrary = BlocksMade <$> arbitrary + +instance CC.Crypto crypto => Arbitrary (PoolDistr crypto) where + arbitrary = + PoolDistr . Map.fromList + <$> listOf ((,) <$> arbitrary <*> genVal) + where + genVal = IndividualPoolStake <$> arbitrary <*> genHash + +instance + (ShelleyBased era, Mock (Crypto era), Arbitrary (Core.Value era)) => + Arbitrary (EpochState era) + where + arbitrary = + EpochState + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> genPParams (Proxy @era) + <*> genPParams (Proxy @era) + <*> arbitrary + +instance Arbitrary (RewardUpdate era) where + arbitrary = return emptyRewardUpdate + +instance Arbitrary a => Arbitrary (StrictMaybe a) where + arbitrary = genericArbitraryU + shrink = genericShrink + +genPParams :: + (Shelley.TxBodyConstraints era) => + proxy era -> + Gen (PParams era) +genPParams p = Update.genPParams (geConstants (genEnv p)) + +instance CC.Crypto crypto => Arbitrary (OBftSlot crypto) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance Arbitrary ActiveSlotCoeff where + arbitrary = mkActiveSlotCoeff <$> arbitrary + +instance Arbitrary Likelihood where + arbitrary = Likelihood <$> arbitrary + +instance Arbitrary LogWeight where + arbitrary = LogWeight <$> arbitrary + +instance Era era => Arbitrary (NonMyopic era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (SnapShot era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance (Era era, Mock (Crypto era)) => Arbitrary (SnapShots era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance Arbitrary PerformanceEstimate where + arbitrary = PerformanceEstimate <$> arbitrary + +instance (Era era, Mock (Crypto era)) => Arbitrary (Stake era) where + arbitrary = Stake <$> arbitrary + +instance (Era era, Mock (Crypto era)) => Arbitrary (PoolParams era) where + arbitrary = + PoolParams + <$> arbitrary + <*> genHash + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary PoolMetaData where + arbitrary = (`PoolMetaData` BS.pack "bytestring") <$> arbitrary + +instance Arbitrary Url where + arbitrary = return . fromJust $ textToUrl "text" + +instance Arbitrary a => Arbitrary (StrictSeq a) where + arbitrary = StrictSeq.toStrict <$> arbitrary + shrink = map StrictSeq.toStrict . shrink . StrictSeq.getSeq + +instance Arbitrary StakePoolRelay where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance Arbitrary Port where + arbitrary = fromIntegral @Word8 @Port <$> arbitrary + +instance Arbitrary IPv4 where + arbitrary = pure $ toIPv4 [192, 0, 2, 1] + +instance Arbitrary IPv6 where + arbitrary = pure $ toIPv6 [0x2001, 0xDB8, 0, 0, 0, 0, 0, 1] + +instance Arbitrary DnsName where + arbitrary = pure . fromJust $ textToDns "foo.example.com" + +instance Arbitrary AccountState where + arbitrary = genericArbitraryU + shrink = genericShrink + +maxMultiSigDepth :: Int +maxMultiSigDepth = 3 + +maxMultiSigListLens :: Int +maxMultiSigListLens = 5 + +sizedMultiSig :: Era era => Int -> Gen (MultiSig era) +sizedMultiSig 0 = RequireSignature <$> arbitrary +sizedMultiSig n = + oneof + [ RequireSignature <$> arbitrary, + RequireAllOf <$> resize maxMultiSigListLens (listOf (sizedMultiSig (n -1))), + RequireAnyOf <$> resize maxMultiSigListLens (listOf (sizedMultiSig (n -1))), + RequireMOf <$> arbitrary <*> resize maxMultiSigListLens (listOf (sizedMultiSig (n -1))) + ] + +instance + (Era era, Mock (Crypto era)) => + Arbitrary (MultiSig era) + where + arbitrary = sizedMultiSig maxMultiSigDepth + +-- | +-- Generate a byte string of a given size. +genByteString :: Int -> Gen BS.ByteString +genByteString size = do + ws <- vectorOf size (chooseAny @Char) + return $ BS.pack ws + +genUTCTime :: Gen Time.UTCTime +genUTCTime = do + year <- arbitrary + dayOfYear <- arbitrary + diff <- arbitrary + pure $ + Time.UTCTime + (Time.fromOrdinalDate year dayOfYear) + (Time.picosecondsToDiffTime diff) + +instance + (ShelleyBased era, Mock (Crypto era)) => + Arbitrary (ShelleyGenesis era) + where + arbitrary = + ShelleyGenesis + <$> genUTCTime -- sgSystemStart + <*> arbitrary -- sgNetworkMagic + <*> arbitrary -- sgNetworkId + <*> arbitrary -- sgActiveSlotsCoeff + <*> arbitrary -- sgSecurityParam + <*> (EpochSize <$> arbitrary) -- sgEpochLength + <*> arbitrary -- sgSlotsPerKESPeriod + <*> arbitrary -- sgMaxKESEvolutions + <*> (fromInteger <$> arbitrary) -- sgSlotLength + <*> arbitrary -- sgUpdateQuorum + <*> arbitrary -- sgMaxLovelaceSupply + <*> genPParams (Proxy @era) -- sgProtocolParams + <*> arbitrary -- sgGenDelegs + <*> arbitrary -- sgInitialFunds + <*> (ShelleyGenesisStaking <$> arbitrary <*> arbitrary) -- sgStaking + +instance + ( ShelleyBased era, + Mock (Crypto era), + ValidateScript era, + Arbitrary (Core.Script era) + ) => + Arbitrary (WitnessSet era) + where + arbitrary = + WitnessSet + <$> arbitrary + <*> (mscriptsToWits <$> arbitrary) + <*> arbitrary + where + mscriptsToWits = Map.fromList . map (\s -> (hashScript s, s)) + +instance Era era => Arbitrary (STS.PpupPredicateFailure era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance Era era => Arbitrary (STS.PoolPredicateFailure era) where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance + (Era era, Mock (Crypto era)) => + Arbitrary (STS.DelplPredicateFailure era) + where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance + (Era era, Mock (Crypto era)) => + Arbitrary (STS.DelegPredicateFailure era) + where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance + (Era era, Mock (Crypto era)) => + Arbitrary (STS.DelegsPredicateFailure era) + where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance + ( Era era, + Arbitrary (STS.PredicateFailure (LEDGER era)) + ) => + Arbitrary (STS.LedgersPredicateFailure era) + where + arbitrary = genericArbitraryU + shrink = genericShrink + +instance + ( Era era, + Arbitrary (STS.PredicateFailure (DELEGS era)), + Arbitrary (STS.PredicateFailure (UTXOW era)) + ) => + Arbitrary (STS.LedgerPredicateFailure era) + where + arbitrary = genericArbitraryU + shrink _ = [] + +instance + ( Era era, + Arbitrary (STS.PredicateFailure (UTXO era)), + Arbitrary (WitHashes era) + ) => + Arbitrary (STS.UtxowPredicateFailure era) + where + arbitrary = genericArbitraryU + shrink _ = [] + +genTx :: + ( ShelleyBased era, + Arbitrary (WitnessSet era), + Arbitrary (Core.TxBody era) + ) => + Gen (Tx era) +genTx = + Tx + <$> arbitrary + <*> (resize maxTxWits arbitrary) + <*> arbitrary + +genBlock :: + forall era. + ( ShelleyBased era, + Mock (Crypto era), + Arbitrary (WitnessSet era), + Arbitrary (Core.TxBody era) + ) => + Gen (Block era) +genBlock = do + let KeySpace_ {ksCoreNodes} = geKeySpace (genEnv p) + prevHash <- arbitrary :: Gen (HashHeader (Crypto era)) + allPoolKeys <- elements (map snd ksCoreNodes) + txs <- listOf (genTx @era) + curSlotNo <- SlotNo <$> choose (0, 10) + curBlockNo <- BlockNo <$> choose (0, 100) + epochNonce <- arbitrary :: Gen Nonce + let kesPeriod = 1 + keyRegKesPeriod = 1 + ocert = mkOCert allPoolKeys 1 (KESPeriod kesPeriod) + return $ + mkBlock + prevHash + allPoolKeys + txs + curSlotNo + curBlockNo + epochNonce + kesPeriod + keyRegKesPeriod + ocert + where + p :: Proxy era + p = Proxy + +instance + ( ShelleyBased era, + Mock (Crypto era), + ValidateScript era, + Arbitrary (Core.TxBody era), + Arbitrary (Core.Value era), + Arbitrary (Core.Script era) + ) => + Arbitrary (Tx era) + where + arbitrary = genTx + +instance + ( ShelleyBased era, + Mock (Crypto era), + ValidateScript era, + Arbitrary (Core.TxBody era), + Arbitrary (Core.Value era), + Arbitrary (Core.Script era) + ) => + Arbitrary (Block era) + where + arbitrary = genBlock diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/Generators.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/Generators.hs index b07024b8f2c..dd560d30832 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/Generators.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/src/Test/Shelley/Spec/Ledger/Serialisation/Generators.hs @@ -14,265 +14,28 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Test.Shelley.Spec.Ledger.Serialisation.Generators - ( genPParams, - mkDummyHash, - genShelleyAddress, - genByronAddress, - ) -where +module Test.Shelley.Spec.Ledger.Serialisation.Generators () where -import Cardano.Binary - ( ToCBOR (..), - toCBOR, - ) -import Cardano.Crypto.DSIGN.Class - ( DSIGNAlgorithm, - SignedDSIGN (..), - rawDeserialiseSigDSIGN, - rawDeserialiseVerKeyDSIGN, - sizeSigDSIGN, - sizeVerKeyDSIGN, - ) -import Cardano.Crypto.DSIGN.Mock (VerKeyDSIGN (..)) -import Cardano.Crypto.Hash (HashAlgorithm, hashWithSerialiser) -import qualified Cardano.Crypto.Hash as Hash -import qualified Cardano.Ledger.Core as Core -import Cardano.Ledger.Crypto (DSIGN) -import qualified Cardano.Ledger.Crypto as CC (Crypto) -import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Shelley (ShelleyEra) -import qualified Cardano.Ledger.Shelley as Shelley -import Cardano.Ledger.Torsor (Torsor (..)) -import Cardano.Slotting.Block (BlockNo (..)) -import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..)) -import Control.SetAlgebra (biMapFromList) -import qualified Data.ByteString.Char8 as BS -import Data.Coerce (coerce) -import Data.IP (IPv4, IPv6, toIPv4, toIPv6) -import qualified Data.Map.Strict as Map (empty, fromList) -import Data.Maybe (fromJust) -import Data.Proxy (Proxy (..)) -import Data.Ratio ((%)) -import Data.Sequence.Strict (StrictSeq) -import qualified Data.Sequence.Strict as StrictSeq -import qualified Data.Text as T -import qualified Data.Time as Time -import qualified Data.Time.Calendar.OrdinalDate as Time -import Data.Typeable (Typeable) -import Data.Word (Word64, Word8) import Generic.Random (genericArbitraryU) -import Numeric.Natural (Natural) -import Shelley.Spec.Ledger.API hiding (SignedDSIGN) -import Shelley.Spec.Ledger.Address.Bootstrap - ( ChainCode (..), - ) -import Shelley.Spec.Ledger.BaseTypes - ( ActiveSlotCoeff, - DnsName, - UnitInterval, - Url, - mkActiveSlotCoeff, - mkNonceFromNumber, - mkUnitInterval, - textToDns, - textToUrl, - ) -import Shelley.Spec.Ledger.Coin (DeltaCoin (..)) -import Shelley.Spec.Ledger.Delegation.Certificates (IndividualPoolStake (..)) -import Shelley.Spec.Ledger.EpochBoundary (BlocksMade (..)) -import Shelley.Spec.Ledger.LedgerState - ( FutureGenDeleg, - emptyRewardUpdate, - ) -import qualified Shelley.Spec.Ledger.MetaData as MD -import Shelley.Spec.Ledger.Rewards - ( Likelihood (..), - LogWeight (..), - PerformanceEstimate (..), - ) -import qualified Shelley.Spec.Ledger.STS.Deleg as STS -import qualified Shelley.Spec.Ledger.STS.Delegs as STS -import qualified Shelley.Spec.Ledger.STS.Delpl as STS -import qualified Shelley.Spec.Ledger.STS.Ledger as STS -import qualified Shelley.Spec.Ledger.STS.Ledgers as STS -import qualified Shelley.Spec.Ledger.STS.Pool as STS -import qualified Shelley.Spec.Ledger.STS.Ppup as STS -import qualified Shelley.Spec.Ledger.STS.Prtcl as STS (PrtclState) -import qualified Shelley.Spec.Ledger.STS.Tickn as STS +import Shelley.Spec.Ledger.API (TxBody (TxBody)) import qualified Shelley.Spec.Ledger.STS.Utxo as STS -import qualified Shelley.Spec.Ledger.STS.Utxow as STS -import Shelley.Spec.Ledger.Tx (WitnessSetHKD (WitnessSet), hashScript) import Test.QuickCheck ( Arbitrary, arbitrary, - genericShrink, - listOf, - oneof, - resize, shrink, - vectorOf, ) -import Test.QuickCheck.Gen (chooseAny) import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) -import Test.Shelley.Spec.Ledger.Generator.Constants (defaultConstants) -import Test.Shelley.Spec.Ledger.Generator.Core - ( KeySpace (KeySpace_), - geConstants, - geKeySpace, - ksCoreNodes, - mkBlock, - mkBlockHeader, - mkOCert, - ) -import Test.Shelley.Spec.Ledger.Generator.Presets (coreNodeKeys, genEnv) -import qualified Test.Shelley.Spec.Ledger.Generator.Update as Update -import Test.Shelley.Spec.Ledger.Serialisation.Generators.Bootstrap - ( genBootstrapAddress, - genSignature, - ) -import Test.Shelley.Spec.Ledger.Utils (ShelleyTest) -import Test.Tasty.QuickCheck (Gen, choose, elements) - -genHash :: forall a h. HashAlgorithm h => Gen (Hash.Hash h a) -genHash = mkDummyHash <$> arbitrary - -mkDummyHash :: forall h a. HashAlgorithm h => Int -> Hash.Hash h a -mkDummyHash = coerce . hashWithSerialiser @h toCBOR +import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators () {------------------------------------------------------------------------------- - Generators + ShelleyEra Generators These are generators for roundtrip tests, so the generated values are not necessarily valid -------------------------------------------------------------------------------} -type MockGen era = - ( Mock (Crypto era), - Arbitrary (VerKeyDSIGN (DSIGN (Crypto era))) - ) - -instance - ( ShelleyTest era, - Mock (Crypto era), - Arbitrary (WitnessSet era), - Arbitrary (Core.Value era) - ) => - Arbitrary (Block era) - where - arbitrary = do - let KeySpace_ {ksCoreNodes} = geKeySpace (genEnv p) - prevHash <- arbitrary :: Gen (HashHeader (Crypto era)) - allPoolKeys <- elements (map snd ksCoreNodes) - txs <- arbitrary - curSlotNo <- SlotNo <$> choose (0, 10) - curBlockNo <- BlockNo <$> choose (0, 100) - epochNonce <- arbitrary :: Gen Nonce - let kesPeriod = 1 - keyRegKesPeriod = 1 - ocert = mkOCert allPoolKeys 1 (KESPeriod kesPeriod) - return $ - mkBlock - prevHash - allPoolKeys - txs - curSlotNo - curBlockNo - epochNonce - kesPeriod - keyRegKesPeriod - ocert - where - p :: Proxy era - p = Proxy - -instance Mock crypto => Arbitrary (BHeader crypto) where - arbitrary = do - prevHash <- arbitrary :: Gen (HashHeader crypto) - allPoolKeys <- elements (map snd (coreNodeKeys defaultConstants)) - curSlotNo <- SlotNo <$> choose (0, 10) - curBlockNo <- BlockNo <$> choose (0, 100) - epochNonce <- arbitrary :: Gen Nonce - bodySize <- arbitrary - bodyHash <- arbitrary - let kesPeriod = 1 - keyRegKesPeriod = 1 - ocert = mkOCert allPoolKeys 1 (KESPeriod kesPeriod) - return $ - mkBlockHeader - prevHash - allPoolKeys - curSlotNo - curBlockNo - epochNonce - kesPeriod - keyRegKesPeriod - ocert - bodySize - bodyHash - -instance DSIGNAlgorithm crypto => Arbitrary (SignedDSIGN crypto a) where - arbitrary = - SignedDSIGN . fromJust . rawDeserialiseSigDSIGN - <$> (genByteString . fromIntegral $ sizeSigDSIGN (Proxy @crypto)) - -instance DSIGNAlgorithm crypto => Arbitrary (VerKeyDSIGN crypto) where - arbitrary = - fromJust . rawDeserialiseVerKeyDSIGN - <$> (genByteString . fromIntegral $ sizeVerKeyDSIGN (Proxy @crypto)) - -instance - (Era era, MockGen era) => - Arbitrary (BootstrapWitness era) - where - arbitrary = do - key <- arbitrary - sig <- genSignature - chainCode <- ChainCode <$> arbitrary - attributes <- arbitrary - pure $ BootstrapWitness key sig chainCode attributes - -instance CC.Crypto crypto => Arbitrary (HashHeader crypto) where - arbitrary = HashHeader <$> genHash - -instance CC.Crypto crypto => Arbitrary (HashBBody crypto) where - arbitrary = UnsafeHashBBody <$> genHash - -instance (Typeable kr, Era era, Mock (Crypto era)) => Arbitrary (WitVKey kr era) where - arbitrary = - WitVKey - <$> arbitrary - <*> arbitrary - -instance - (Mock c) => - Arbitrary (WitnessSet (ShelleyEra c)) - where - arbitrary = - WitnessSet - <$> arbitrary - <*> (mscriptsToWits <$> arbitrary) - <*> arbitrary - where - mscriptsToWits = Map.fromList . map (\s -> (hashScript s, s)) - -instance (Era era, Mock (Crypto era)) => Arbitrary (Wdrl era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (ProposedPPUpdates era) where - arbitrary = ProposedPPUpdates <$> pure Map.empty - -instance (Era era, Mock (Crypto era)) => Arbitrary (Update era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - (ShelleyTest era, Mock (Crypto era), Arbitrary (Core.Value era)) => - Arbitrary (TxBody era) - where - -- Our arbitrary instance constructs things using the pattern in order to have - -- the correct serialised bytes. +instance Mock c => Arbitrary (TxBody (ShelleyEra c)) where arbitrary = TxBody <$> arbitrary @@ -284,508 +47,6 @@ instance <*> arbitrary <*> arbitrary -maxMetaDatumDepth :: Int -maxMetaDatumDepth = 2 - -maxMetaDatumListLens :: Int -maxMetaDatumListLens = 5 - -sizedMetaDatum :: Int -> Gen MD.MetaDatum -sizedMetaDatum 0 = - oneof - [ MD.I <$> arbitrary, - MD.B <$> arbitrary, - MD.S <$> (T.pack <$> arbitrary) - ] -sizedMetaDatum n = - oneof - [ MD.Map - <$> ( zip - <$> (resize maxMetaDatumListLens (listOf (sizedMetaDatum (n -1)))) - <*> (listOf (sizedMetaDatum (n -1))) - ), - MD.List <$> resize maxMetaDatumListLens (listOf (sizedMetaDatum (n -1))), - MD.I <$> arbitrary, - MD.B <$> arbitrary, - MD.S <$> (T.pack <$> arbitrary) - ] - -instance Arbitrary MD.MetaDatum where - arbitrary = sizedMetaDatum maxMetaDatumDepth - -instance Arbitrary MD.MetaData where - arbitrary = MD.MetaData <$> arbitrary - -maxTxWits :: Int -maxTxWits = 5 - -instance - ( ShelleyTest era, - Mock (Crypto era), - Arbitrary (WitnessSet era), - Arbitrary (Core.Value era) - ) => - Arbitrary (Tx era) - where - -- Our arbitrary instance constructs things using the pattern in order to have - -- the correct serialised bytes. - arbitrary = - Tx - <$> arbitrary - <*> (resize maxTxWits arbitrary) - <*> arbitrary - -instance Era era => Arbitrary (TxId era) where - arbitrary = TxId <$> genHash - -instance Era era => Arbitrary (TxIn era) where - arbitrary = - TxIn - <$> (TxId <$> genHash) - <*> arbitrary - -instance - (ShelleyTest era, Mock (Crypto era), Arbitrary (Core.Value era)) => - Arbitrary (TxOut era) - where - arbitrary = TxOut <$> arbitrary <*> arbitrary - -instance Arbitrary Nonce where - arbitrary = - oneof - [ return NeutralNonce, - mkNonceFromNumber <$> choose (1, 123 :: Word64) - ] - -instance Arbitrary UnitInterval where - arbitrary = fromJust . mkUnitInterval . (% 100) <$> choose (1, 99) - -instance - (CC.Crypto crypto) => - Arbitrary (KeyHash a crypto) - where - arbitrary = KeyHash <$> genHash - -instance Era era => Arbitrary (WitHashes era) where - arbitrary = genericArbitraryU - -instance Arbitrary MIRPot where - arbitrary = genericArbitraryU - -instance Arbitrary Natural where - arbitrary = fromInteger <$> choose (0, 1000) - -instance Arbitrary STS.VotingPeriod where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance Era era => Arbitrary (STS.PpupPredicateFailure era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - ( ShelleyTest era, - Mock (Crypto era), - Arbitrary (Core.Value era), - Arbitrary (Delta (Core.Value era)) - ) => - Arbitrary (STS.UtxoPredicateFailure era) - where - arbitrary = genericArbitraryU - -- we don't have a shrinker for Value, so we do not shrink this - -- predicate failure, as its constructor contains Value - shrink pf = [pf] - -instance - ( ShelleyTest era, - MockGen era, - Arbitrary (STS.PredicateFailure (UTXO era)) - ) => - Arbitrary (STS.UtxowPredicateFailure era) - where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - Era era => - Arbitrary (STS.PoolPredicateFailure era) - where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - (Era era, Mock (Crypto era)) => - Arbitrary (STS.DelplPredicateFailure era) - where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - (Era era, Mock (Crypto era)) => - Arbitrary (STS.DelegPredicateFailure era) - where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - (Era era, Mock (Crypto era)) => - Arbitrary (STS.DelegsPredicateFailure era) - where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - ( ShelleyTest era, - MockGen era, - Arbitrary - (STS.PredicateFailure (DELEGS era)), - Arbitrary - (STS.PredicateFailure (UTXOW era)) - ) => - Arbitrary (STS.LedgerPredicateFailure era) - where +instance Mock c => Arbitrary (STS.UtxoPredicateFailure (ShelleyEra c)) where arbitrary = genericArbitraryU - shrink = genericShrink - -instance - ( ShelleyTest era, - MockGen era, - Arbitrary (STS.PredicateFailure (LEDGER era)) - ) => - Arbitrary (STS.LedgersPredicateFailure era) - where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance Arbitrary Coin where - -- Cannot be negative even though it is an 'Integer' - arbitrary = Coin <$> choose (0, 1000) - -instance Arbitrary DeltaCoin where - arbitrary = DeltaCoin <$> choose (-1000, 1000) - -instance Arbitrary SlotNo where - -- Cannot be negative even though it is an 'Integer' - arbitrary = SlotNo <$> choose (1, 100000) - -instance Arbitrary EpochNo where - -- Cannot be negative even though it is an 'Integer' - arbitrary = EpochNo <$> choose (1, 100000) - -instance (Era era, Mock (Crypto era)) => Arbitrary (Addr era) where - arbitrary = oneof [genShelleyAddress, genByronAddress] - -genShelleyAddress :: (Era era, Mock (Crypto era)) => Gen (Addr era) -genShelleyAddress = Addr <$> arbitrary <*> arbitrary <*> arbitrary - -genByronAddress :: Gen (Addr era) -genByronAddress = AddrBootstrap <$> genBootstrapAddress - -instance (Era era, Mock (Crypto era)) => Arbitrary (StakeReference era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - ( Era era, - Mock (Crypto era) - ) => - Arbitrary (Credential r era) - where - arbitrary = - oneof - [ ScriptHashObj . ScriptHash <$> genHash, - KeyHashObj <$> arbitrary - ] - -instance Arbitrary Ptr where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (RewardAcnt era) where - arbitrary = RewardAcnt <$> arbitrary <*> arbitrary - -instance Arbitrary Network where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Arbitrary (VerKeyDSIGN (DSIGN crypto))) => Arbitrary (VKey kd crypto) where - arbitrary = VKey <$> arbitrary - -instance Arbitrary ProtVer where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance Era era => Arbitrary (ScriptHash era) where - arbitrary = ScriptHash <$> genHash - -instance Era era => Arbitrary (MD.MetaDataHash era) where - arbitrary = MD.MetaDataHash <$> genHash - -instance HashAlgorithm h => Arbitrary (Hash.Hash h a) where - arbitrary = genHash - -instance Arbitrary STS.TicknState where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance CC.Crypto crypto => Arbitrary (STS.PrtclState crypto) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - (ShelleyTest era, Mock (Crypto era), Arbitrary (Core.Value era)) => - Arbitrary (UTxO era) - where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (PState era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (InstantaneousRewards era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Mock crypto) => Arbitrary (FutureGenDeleg crypto) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Mock crypto) => Arbitrary (GenDelegs crypto) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Mock crypto) => Arbitrary (GenDelegPair crypto) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (DState era) where - arbitrary = - DState - <$> arbitrary - <*> arbitrary - <*> (biMapFromList const <$> arbitrary) - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance (Era era, Mock (Crypto era)) => Arbitrary (DelegCert era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (Delegation era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (PoolCert era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (GenesisDelegCert era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (MIRCert era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (DCert era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (PPUPState era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (DPState era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - (ShelleyTest era, Mock (Crypto era), Arbitrary (Core.Value era)) => - Arbitrary (UTxOState era) - where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - (ShelleyTest era, Mock (Crypto era), Arbitrary (Core.Value era)) => - Arbitrary (LedgerState era) - where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance - (ShelleyTest era, Mock (Crypto era), Arbitrary (Core.Value era)) => - Arbitrary (NewEpochState era) - where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance Era era => Arbitrary (BlocksMade era) where - arbitrary = BlocksMade <$> arbitrary - -instance CC.Crypto crypto => Arbitrary (PoolDistr crypto) where - arbitrary = - PoolDistr . Map.fromList - <$> listOf ((,) <$> arbitrary <*> genVal) - where - genVal = IndividualPoolStake <$> arbitrary <*> genHash - -instance - (ShelleyTest era, Mock (Crypto era), Arbitrary (Core.Value era)) => - Arbitrary (EpochState era) - where - arbitrary = - EpochState - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> genPParams (Proxy @era) - <*> genPParams (Proxy @era) - <*> arbitrary - -instance Arbitrary (RewardUpdate era) where - arbitrary = return emptyRewardUpdate - -instance Arbitrary a => Arbitrary (StrictMaybe a) where - arbitrary = genericArbitraryU - shrink = genericShrink - -genPParams :: - (Shelley.TxBodyConstraints era) => - proxy era -> - Gen (PParams era) -genPParams p = Update.genPParams (geConstants (genEnv p)) - -instance CC.Crypto crypto => Arbitrary (OBftSlot crypto) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance Arbitrary ActiveSlotCoeff where - arbitrary = mkActiveSlotCoeff <$> arbitrary - -instance Arbitrary Likelihood where - arbitrary = Likelihood <$> arbitrary - -instance Arbitrary LogWeight where - arbitrary = LogWeight <$> arbitrary - -instance (Era era, Mock (Crypto era)) => Arbitrary (NonMyopic era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (SnapShot era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance (Era era, Mock (Crypto era)) => Arbitrary (SnapShots era) where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance Arbitrary PerformanceEstimate where - arbitrary = PerformanceEstimate <$> arbitrary - -instance (Era era, Mock (Crypto era)) => Arbitrary (Stake era) where - arbitrary = Stake <$> arbitrary - -instance (Era era, Mock (Crypto era)) => Arbitrary (PoolParams era) where - arbitrary = - PoolParams - <$> arbitrary - <*> genHash - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - -instance Arbitrary PoolMetaData where - arbitrary = (`PoolMetaData` BS.pack "bytestring") <$> arbitrary - -instance Arbitrary Url where - arbitrary = return . fromJust $ textToUrl "text" - -instance Arbitrary a => Arbitrary (StrictSeq a) where - arbitrary = StrictSeq.toStrict <$> arbitrary - shrink = map StrictSeq.toStrict . shrink . StrictSeq.getSeq - -instance Arbitrary StakePoolRelay where - arbitrary = genericArbitraryU - shrink = genericShrink - -instance Arbitrary Port where - arbitrary = fromIntegral @Word8 @Port <$> arbitrary - -instance Arbitrary IPv4 where - arbitrary = pure $ toIPv4 [192, 0, 2, 1] - -instance Arbitrary IPv6 where - arbitrary = pure $ toIPv6 [0x2001, 0xDB8, 0, 0, 0, 0, 0, 1] - -instance Arbitrary DnsName where - arbitrary = pure . fromJust $ textToDns "foo.example.com" - -instance Arbitrary AccountState where - arbitrary = genericArbitraryU - shrink = genericShrink - -maxMultiSigDepth :: Int -maxMultiSigDepth = 3 - -maxMultiSigListLens :: Int -maxMultiSigListLens = 5 - -sizedMultiSig :: (Era era, Mock (Crypto era)) => Int -> Gen (MultiSig era) -sizedMultiSig 0 = RequireSignature <$> arbitrary -sizedMultiSig n = - oneof - [ RequireSignature <$> arbitrary, - RequireAllOf <$> resize maxMultiSigListLens (listOf (sizedMultiSig (n -1))), - RequireAnyOf <$> resize maxMultiSigListLens (listOf (sizedMultiSig (n -1))), - RequireMOf <$> arbitrary <*> resize maxMultiSigListLens (listOf (sizedMultiSig (n -1))) - ] - -instance - (Era era, Mock (Crypto era)) => - Arbitrary (MultiSig era) - where - arbitrary = sizedMultiSig maxMultiSigDepth - --- | --- Generate a byte string of a given size. -genByteString :: Int -> Gen BS.ByteString -genByteString size = do - ws <- vectorOf size (chooseAny @Char) - return $ BS.pack ws - -genUTCTime :: Gen Time.UTCTime -genUTCTime = do - year <- arbitrary - dayOfYear <- arbitrary - diff <- arbitrary - pure $ - Time.UTCTime - (Time.fromOrdinalDate year dayOfYear) - (Time.picosecondsToDiffTime diff) - -instance (ShelleyTest era, Mock (Crypto era)) => Arbitrary (ShelleyGenesis era) where - arbitrary = - ShelleyGenesis - <$> genUTCTime -- sgSystemStart - <*> arbitrary -- sgNetworkMagic - <*> arbitrary -- sgNetworkId - <*> arbitrary -- sgActiveSlotsCoeff - <*> arbitrary -- sgSecurityParam - <*> (EpochSize <$> arbitrary) -- sgEpochLength - <*> arbitrary -- sgSlotsPerKESPeriod - <*> arbitrary -- sgMaxKESEvolutions - <*> (fromInteger <$> arbitrary) -- sgSlotLength - <*> arbitrary -- sgUpdateQuorum - <*> arbitrary -- sgMaxLovelaceSupply - <*> genPParams (Proxy @era) -- sgProtocolParams - <*> arbitrary -- sgGenDelegs - <*> arbitrary -- sgInitialFunds - <*> (ShelleyGenesisStaking <$> arbitrary <*> arbitrary) -- sgStaking + shrink _ = [] diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Address/CompactAddr.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Address/CompactAddr.hs index 425fab056df..86bad9a31df 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Address/CompactAddr.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Address/CompactAddr.hs @@ -13,13 +13,12 @@ import Shelley.Spec.Ledger.Address (Addr (..), serialiseAddr) import qualified Shelley.Spec.Ledger.CompactAddr as CA import Shelley.Spec.Ledger.Credential ( PaymentCredential, - StakeReference (..) + StakeReference (..), ) import Test.QuickCheck import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (Mock) -import Test.Shelley.Spec.Ledger.Serialisation.Generators - ( - ) +import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators () +import Test.Shelley.Spec.Ledger.Serialisation.Generators () propCompactAddrRoundTrip :: forall era. Era era => Addr era -> Bool propCompactAddrRoundTrip addr = @@ -48,13 +47,15 @@ propDecompactAddrLazy = do -- correct length that wasn't a valid hash, which doesn't seem possible. propDecompactShelleyLazyAddr :: forall era. - (Era era, Mock (Crypto era)) => + Era era => Gen Bool propDecompactShelleyLazyAddr = do - stakeRef <- oneof - [ StakeRefBase <$> arbitrary - , StakeRefPtr <$> arbitrary - ] :: Gen (StakeReference era) + stakeRef <- + oneof + [ StakeRefBase <$> arbitrary, + StakeRefPtr <$> arbitrary + ] :: + Gen (StakeReference era) addr <- Addr <$> arbitrary <*> arbitrary <*> pure stakeRef let keyHash0 = unsafeGetHash addr keyHash1 = unsafeGetHash . CA.decompactAddr . mangle . CA.compactAddr $ addr diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Tripping/CBOR.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Tripping/CBOR.hs index 8fe48e71ff4..a48d8782f19 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Tripping/CBOR.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Serialisation/Tripping/CBOR.hs @@ -50,6 +50,7 @@ import Shelley.Spec.Ledger.Genesis (ShelleyGenesis) import qualified Shelley.Spec.Ledger.STS.Ledgers as STS import qualified Shelley.Spec.Ledger.STS.Prtcl as STS (PrtclState) import qualified Test.Shelley.Spec.Ledger.ConcreteCryptoTypes as Mock +import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators () import Test.Shelley.Spec.Ledger.Serialisation.Generators () import Test.Tasty import Test.Tasty.QuickCheck (Property, counterexample, testProperty, (===)) diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ShelleyTranslation.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ShelleyTranslation.hs index a8ee66740ab..39a39da9807 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ShelleyTranslation.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ShelleyTranslation.hs @@ -4,6 +4,7 @@ import Cardano.Ledger.Shelley (ShelleyEra) import Shelley.Spec.Ledger.LedgerState (EpochState, returnRedeemAddrsToReserves) import Shelley.Spec.Ledger.STS.Chain (totalAdaES) import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (C_Crypto) +import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators () import Test.Shelley.Spec.Ledger.Serialisation.Generators () import Test.Tasty import Test.Tasty.QuickCheck diff --git a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ValProp.hs b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ValProp.hs index 07eac24eecf..cbcc804ab52 100644 --- a/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ValProp.hs +++ b/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/ValProp.hs @@ -29,6 +29,7 @@ import Shelley.Spec.Ledger.Coin (Coin (..)) import System.IO.Unsafe (unsafePerformIO) -- get: instance Era era => Arbitrary (ScriptHash era) import Test.Shelley.Spec.Ledger.ConcreteCryptoTypes (C) +import Test.Shelley.Spec.Ledger.Serialisation.EraIndepGenerators () import Test.Shelley.Spec.Ledger.Serialisation.Generators () import Test.Tasty import Test.Tasty.QuickCheck hiding (scale)