IntersectMBO · uroboros · Nov 7, 2020 · Nov 6, 2020
@@ -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,
@@ -1,51 +1,150 @@
-{-# 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
 
 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
@@ -1,45 +1,51 @@
 {-# 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,
  MultiSig,
  )
 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,29 +60,29 @@ 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
 -- to the current era. We arbitrarily set the TestEra to be its own
 -- 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
- ]
+ ]
@@ -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

@@ -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