diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Orphans.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Orphans.hs index d8492c3078..5b68129574 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Orphans.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Orphans.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Tools.DBSynthesizer.Orphans () where diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM/Model.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM/Model.hs index b50cabfe90..4e8f2a4375 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM/Model.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM/Model.hs @@ -29,6 +29,7 @@ import Test.QuickCheck (choose, elements, shrink) import qualified Test.StateMachine as QSM import Test.StateMachine (Concrete, Symbolic) import qualified Test.StateMachine.Types.Rank2 as QSM +import Test.Util.Orphans.ToExpr () ----- the QSM model @@ -590,8 +591,6 @@ instance TD.ToExpr Notable where toExpr = TD.defaultExprViaShow ----- orphans -instance TD.ToExpr SI.Time where toExpr = TD.defaultExprViaShow - deriving instance Read LedgerStateJudgement instance QC.Arbitrary LedgerStateJudgement where diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 7253ed09cf..6b933d1112 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -409,6 +409,7 @@ library unstable-consensus-testlib quiet, random, serialise, + si-timers, sop-core, sop-extras, strict-checked-vars, diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs index aae022207b..6aaab22688 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -54,6 +55,7 @@ import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal (ChunkNo (..), ChunkSize (..), RelativeSlot (..)) import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Layout +import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index as Index import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Network.SizeInBytes import Test.Cardano.Slotting.Arbitrary () @@ -391,3 +393,16 @@ instance Arbitrary (SomeSecond BlockQuery blk) arbitrary = do SomeSecond someBlockQuery <- arbitrary return (SomeSecond (BlockQuery someBlockQuery)) + + +instance Arbitrary Index.CacheConfig where + arbitrary = do + pastChunksToCache <- frequency + -- Pick small values so that we exercise cache eviction + [ (1, return 1) + , (1, return 2) + , (1, choose (3, 10)) + ] + -- TODO create a Cmd that advances time, so this is being exercised too. + expireUnusedAfter <- (fromIntegral :: Int -> DiffTime) <$> choose (1, 100) + return Index.CacheConfig {Index.pastChunksToCache, Index.expireUnusedAfter} diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index c2d97b5eef..ef4628a713 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -1,18 +1,33 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Test.Util.Orphans.ToExpr () where +import qualified Control.Monad.Class.MonadTime.SI as SI import Data.TreeDiff +import GHC.Generics (Generic) import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Storage.ChainDB (InvalidBlockReason) +import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB +import Ouroboros.Consensus.Storage.ImmutableDB +import Ouroboros.Consensus.Util.STM (Fingerprint, WithFingerprint) +import Ouroboros.Network.Block (MaxSlotNo) +import Ouroboros.Network.Mock.Chain +import Ouroboros.Network.Mock.ProducerState import Ouroboros.Network.Point +import System.FS.API import Test.Cardano.Slotting.TreeDiff () +import Test.Util.ToExpr () {------------------------------------------------------------------------------- ouroboros-network @@ -37,3 +52,54 @@ instance ( ToExpr (ChainDepState (BlockProtocol blk)) instance ( ToExpr (TipInfo blk) ) => ToExpr (AnnTip blk) + +instance ToExpr SecurityParam +instance ToExpr DiskSnapshot + +instance ToExpr ChunkSize +instance ToExpr ChunkNo +instance ToExpr ChunkSlot +instance ToExpr RelativeSlot +instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d, ToExpr e, ToExpr f, ToExpr g, + ToExpr h, ToExpr i, ToExpr j) + => ToExpr (a, b, c, d, e, f, g, h, i, j) where + toExpr (a, b, c, d, e, f, g, h, i, j) = App "_×_×_×_×_×_×_×_×_x_" + [ toExpr a, toExpr b, toExpr c, toExpr d, toExpr e, toExpr f, toExpr g + , toExpr h, toExpr i, toExpr j + ] + +instance ToExpr ChunkInfo where + toExpr = defaultExprViaShow +instance ToExpr FsError where + toExpr fsError = App (show fsError) [] + + +{------------------------------------------------------------------------------- + si-timers +--------------------------------------------------------------------------------} + +instance ToExpr SI.Time where toExpr = defaultExprViaShow + + +deriving anyclass instance ToExpr Fingerprint +deriving anyclass instance ToExpr FollowerNext +deriving anyclass instance ToExpr MaxSlotNo + +deriving instance ToExpr (HeaderHash blk) => ToExpr (ChainHash blk) +deriving instance ToExpr (HeaderHash blk) => ToExpr (FollowerState blk) + +deriving instance Generic FollowerNext +deriving instance Generic (Chain blk) +deriving instance Generic (ChainProducerState blk) +deriving instance Generic (FollowerState blk) + +deriving instance ToExpr blk => ToExpr (Chain blk) +deriving instance ( ToExpr blk + , ToExpr (HeaderHash blk) + ) + => ToExpr (ChainProducerState blk) +deriving instance ToExpr a => ToExpr (WithFingerprint a) +deriving instance ( ToExpr (HeaderHash blk) + , ToExpr (ExtValidationError blk) + ) + => ToExpr (InvalidBlockReason blk) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index d7fac62ee2..82d7a1bd2a 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} @@ -92,13 +93,16 @@ import Data.Maybe (fromMaybe, isJust) import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set +import Data.TreeDiff import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config +import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.MockChainSel import Ouroboros.Consensus.Storage.ChainDB.API (AddBlockPromise (..), AddBlockResult (..), BlockComponent (..), @@ -115,7 +119,10 @@ import qualified Ouroboros.Network.AnchoredFragment as Fragment import Ouroboros.Network.Block (MaxSlotNo (..)) import Ouroboros.Network.Mock.Chain (Chain (..), ChainUpdate) import qualified Ouroboros.Network.Mock.Chain as Chain +import Ouroboros.Network.Mock.ProducerState (ChainProducerState) import qualified Ouroboros.Network.Mock.ProducerState as CPS +import Test.Cardano.Slotting.TreeDiff () + type IteratorId = Int @@ -142,6 +149,19 @@ data Model blk = Model { } deriving (Generic) +deriving instance ( ToExpr blk + , ToExpr (HeaderHash blk) + , ToExpr (ChainDepState (BlockProtocol blk)) + , ToExpr (TipInfo blk) + , ToExpr (LedgerState blk) + , ToExpr (ExtValidationError blk) + , ToExpr (Chain blk) + , ToExpr (ChainProducerState blk) + , ToExpr (ExtLedgerState blk) + , ToExpr (InvalidBlockReason blk) + ) + => ToExpr (Model blk) + deriving instance (LedgerSupportsProtocol blk, Show blk) => Show (Model blk) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 051051a415..9ca672dfb4 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -112,7 +112,6 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Protocol.BFT import Ouroboros.Consensus.Storage.ChainDB hiding (TraceFollowerEvent (..)) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB @@ -131,16 +130,10 @@ import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike hiding (invariant) import Ouroboros.Consensus.Util.ResourceRegistry -import Ouroboros.Consensus.Util.STM (Fingerprint (..), - WithFingerprint (..)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (ChainUpdate, MaxSlotNo) -import Ouroboros.Network.Mock.Chain (Chain (..)) import qualified Ouroboros.Network.Mock.Chain as Chain -import Ouroboros.Network.Mock.ProducerState (ChainProducerState, - FollowerNext, FollowerState) -import qualified Ouroboros.Network.Mock.ProducerState as CPS import qualified System.FS.Sim.MockFS as Mock import System.FS.Sim.MockFS (MockFS) import qualified Test.Ouroboros.Storage.ChainDB.Model as Model @@ -1220,35 +1213,6 @@ instance CommandNames (At Cmd blk m) where cmdNames (_ :: Proxy (At Cmd blk m r)) = constrNames (Proxy @(Cmd blk () ())) -deriving instance Generic FollowerNext -deriving instance Generic IteratorId -deriving instance Generic (Chain blk) -deriving instance Generic (ChainProducerState blk) -deriving instance Generic (FollowerState blk) - -deriving anyclass instance ToExpr Fingerprint -deriving anyclass instance ToExpr FollowerNext -deriving anyclass instance ToExpr MaxSlotNo -deriving instance ToExpr (HeaderHash blk) => ToExpr (ChainHash blk) -deriving instance ToExpr (HeaderHash blk) => ToExpr (FollowerState blk) -deriving instance ToExpr blk => ToExpr (Chain blk) -deriving instance ( ToExpr blk - , ToExpr (HeaderHash blk) - ) - => ToExpr (ChainProducerState blk) -deriving instance ToExpr a => ToExpr (WithFingerprint a) -deriving instance ( ToExpr (HeaderHash blk) - , ToExpr (ExtValidationError blk) - ) - => ToExpr (InvalidBlockReason blk) -deriving instance ( ToExpr blk - , ToExpr (HeaderHash blk) - , ToExpr (ChainDepState (BlockProtocol blk)) - , ToExpr (TipInfo blk) - , ToExpr (LedgerState blk) - , ToExpr (ExtValidationError blk) - ) - => ToExpr (DBModel blk) deriving instance ( ToExpr blk , ToExpr (HeaderHash blk) , ToExpr (ChainDepState (BlockProtocol blk)) @@ -1258,26 +1222,6 @@ deriving instance ( ToExpr blk ) => ToExpr (Model blk IO Concrete) --- Blk specific instances - -deriving anyclass instance ToExpr ChainLength -deriving anyclass instance ToExpr TestHeaderHash -deriving anyclass instance ToExpr TestBodyHash - -deriving instance ToExpr EBB -deriving instance ToExpr IsEBB -deriving instance ToExpr TestHeader -deriving instance ToExpr TestBody -deriving instance ToExpr TestBlockError -deriving instance ToExpr Blk -deriving instance ToExpr (TipInfoIsEBB Blk) -deriving instance ToExpr (LedgerState Blk) -deriving instance ToExpr (HeaderError Blk) -deriving instance ToExpr TestBlockOtherHeaderEnvelopeError -deriving instance ToExpr (HeaderEnvelopeError Blk) -deriving instance ToExpr BftValidationErr -deriving instance ToExpr (ExtValidationError Blk) - {------------------------------------------------------------------------------- Labelling -------------------------------------------------------------------------------} @@ -1373,8 +1317,6 @@ execCmds model = \(QSM.Commands cs) -> go model cs type Blk = TestBlock -instance ModelSupportsBlock TestBlock - -- | Note that the 'Blk = TestBlock' is general enough to be used by both the -- ChainDB /and/ the ImmutableDB, its generators cannot. For example, in the -- ChainDB, blocks are added /out of order/, while in the ImmutableDB, they diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs index 8274fb3154..470f4c390a 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -44,6 +46,7 @@ import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Text as Text +import Data.TreeDiff import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Block @@ -57,6 +60,7 @@ import Ouroboros.Consensus.Util (lastMaybe, takeUntil) import Ouroboros.Consensus.Util.CallStack import System.FS.API.Types (FsPath, fsPathSplit) import Test.Ouroboros.Storage.TestBlock hiding (EBB) +import Test.Util.Orphans.ToExpr () data InSlot blk = -- | This slot contains only a regular block @@ -156,6 +160,10 @@ type IteratorId = Int newtype IteratorModel blk = IteratorModel [blk] deriving (Show, Eq, Generic) +instance ToExpr (IteratorModel TestBlock) +instance ToExpr (DBModel TestBlock) +instance ToExpr (InSlot TestBlock) + {------------------------------------------------------------------------------ Helpers ------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs index 3772e890fb..65194d3d99 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs @@ -15,7 +15,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} -- | Model-based tests for the immutable DB. -- -- This is the main test for the immutable DB. As in any model based, we have a @@ -59,7 +58,7 @@ import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe) -import Data.TreeDiff (Expr (App), ToExpr (..), defaultExprViaShow) +import Data.TreeDiff (ToExpr (..)) import Data.Typeable (Typeable) import Data.Word (Word16, Word64) import qualified Generics.SOP as SOP @@ -79,7 +78,7 @@ import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.ResourceRegistry import Prelude hiding (elem, notElem) import System.FS.API (HasFS (..), SomeHasFS (..)) -import System.FS.API.Types (FsError (..), FsPath, mkFsPath) +import System.FS.API.Types (FsPath, mkFsPath) import System.FS.Sim.Error (Errors, emptyErrors, mkSimErrorHasFS, withErrors) import qualified System.FS.Sim.MockFS as Mock @@ -1108,38 +1107,6 @@ instance CommandNames (At CmdErr m) where cmdNames (_ :: Proxy (At CmdErr m r)) = constrNames (Proxy @(Cmd (IterRef m r))) -instance ToExpr ChunkSize -instance ToExpr ChunkNo -instance ToExpr ChunkSlot -instance ToExpr RelativeSlot -instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d, ToExpr e, ToExpr f, ToExpr g, - ToExpr h, ToExpr i, ToExpr j) - => ToExpr (a, b, c, d, e, f, g, h, i, j) where - toExpr (a, b, c, d, e, f, g, h, i, j) = App "_×_×_×_×_×_×_×_×_x_" - [ toExpr a, toExpr b, toExpr c, toExpr d, toExpr e, toExpr f, toExpr g - , toExpr h, toExpr i, toExpr j - ] -instance ToExpr (IteratorModel TestBlock) -instance ToExpr EBB -instance ToExpr IsEBB -instance ToExpr ChainLength -instance ToExpr TestHeaderHash -instance ToExpr TestBodyHash -instance ToExpr (ChainHash TestHeader) -instance ToExpr TestHeader -instance ToExpr TestBody -instance ToExpr TestBlock -instance ToExpr (Tip TestBlock) -instance ToExpr (InSlot TestBlock) -instance ToExpr (CodecConfig TestBlock) -instance ToExpr (DBModel TestBlock) - -instance ToExpr FsError where - toExpr fsError = App (show fsError) [] - -instance ToExpr ChunkInfo where - toExpr = defaultExprViaShow - instance ToExpr (Model m Concrete) {------------------------------------------------------------------------------- @@ -1266,15 +1233,3 @@ tests = testGroup "ImmutableDB q-s-m" unusedEnv :: ImmutableDBEnv unusedEnv = error "ImmutableDBEnv used during command generation" - -instance Arbitrary Index.CacheConfig where - arbitrary = do - pastChunksToCache <- frequency - -- Pick small values so that we exercise cache eviction - [ (1, return 1) - , (1, return 2) - , (1, choose (3, 10)) - ] - -- TODO create a Cmd that advances time, so this is being exercised too. - expireUnusedAfter <- (fromIntegral :: Int -> DiffTime) <$> choose (1, 100) - return Index.CacheConfig {..} diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs index 9cda7820a5..a50c8b0931 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs @@ -24,7 +24,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} #if __GLASGOW_HASKELL__ >= 908 {-# OPTIONS_GHC -Wno-x-partial #-} #endif @@ -1027,8 +1026,6 @@ instance Traversable t => Rank2.Traversable (At t) where lift f (QSM.Reference x) = QSM.Reference <$> f x instance ToExpr (Model Concrete) -instance ToExpr SecurityParam -instance ToExpr DiskSnapshot {------------------------------------------------------------------------------- Final state machine diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs index 7ffeb6c885..d8bf72d8b8 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs @@ -14,7 +14,9 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_GHC -Wno-orphans #-} + module Test.Ouroboros.Storage.TestBlock ( -- * Test block BlockConfig (..) @@ -76,6 +78,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (maybeToList) +import Data.TreeDiff import Data.Typeable (Typeable) import Data.Word import GHC.Generics (Generic) @@ -101,16 +104,21 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT import Ouroboros.Consensus.Protocol.ModChainSel import Ouroboros.Consensus.Protocol.Signed +import Ouroboros.Consensus.Storage.ImmutableDB (Tip) import Ouroboros.Consensus.Storage.ImmutableDB.Chunks import Ouroboros.Consensus.Storage.Serialisation +import Ouroboros.Consensus.Storage.VolatileDB import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () import qualified Ouroboros.Network.Mock.Chain as Chain import System.FS.API.Lazy import Test.Cardano.Slotting.Numeric () +import Test.Cardano.Slotting.TreeDiff () +import Test.Ouroboros.Storage.ChainDB.Model import Test.QuickCheck import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.SignableRepresentation () +import Test.Util.Orphans.ToExpr () {------------------------------------------------------------------------------- TestBlock @@ -834,3 +842,30 @@ instance Hashable IsEBB instance (StandardHash b, Hashable (HeaderHash b)) => Hashable (ChainHash b) -- use generic instance + +instance ToExpr EBB +instance ToExpr IsEBB +instance ToExpr ChainLength +instance ToExpr TestHeaderHash +instance ToExpr TestBodyHash +instance ToExpr TestHeader +instance ToExpr TestBody +instance ToExpr TestBlock +instance ToExpr (CodecConfig TestBlock) +instance ToExpr (Tip TestBlock) + + +deriving instance ToExpr TestBlockError +deriving instance ToExpr (TipInfoIsEBB TestBlock) +deriving instance ToExpr (LedgerState TestBlock) +deriving instance ToExpr (HeaderError TestBlock) +deriving instance ToExpr TestBlockOtherHeaderEnvelopeError +deriving instance ToExpr (HeaderEnvelopeError TestBlock) +deriving instance ToExpr BftValidationErr +deriving instance ToExpr (ExtValidationError TestBlock) + +instance ModelSupportsBlock TestBlock + +deriving anyclass instance ToExpr FsPath +deriving anyclass instance ToExpr BlocksPerFile +deriving instance ToExpr BinaryBlockInfo diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs index 42d97f6b16..580c9cbac5 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/Model.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -41,6 +42,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as Set +import Data.TreeDiff import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Block @@ -76,6 +78,10 @@ data DBModel blk = DBModel { } deriving (Generic) +deriving instance ( ToExpr blk + , ToExpr (CodecConfig blk) + ) => ToExpr (DBModel blk) + deriving instance (Show blk, Show (CodecConfig blk)) => Show (DBModel blk) initDBModel :: BlocksPerFile -> CodecConfig blk -> DBModel blk @@ -158,6 +164,8 @@ newtype BlocksInFile blk = BlocksInFile { } deriving (Show, Generic) +instance ToExpr blk => ToExpr (BlocksInFile blk) + emptyFile :: BlocksInFile blk emptyFile = BlocksInFile [] diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs index dd2e69b291..8088619c8e 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs @@ -9,7 +9,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wno-orphans #-} + -- | Tests for the volatile DB -- -- The set of commands for the volatile DB is similar to the immutable DB, @@ -175,25 +175,7 @@ deriving instance Generic1 (At Resp) deriving instance Rank2.Foldable (At Resp) deriving instance Show1 r => Show (Resp :@ r) -deriving instance ToExpr FsPath -deriving instance ToExpr MaxSlotNo -deriving instance ToExpr IsEBB -deriving instance ToExpr BlocksPerFile -deriving instance ToExpr (ChainHash Block) -deriving instance ToExpr (BlockInfo Block) -deriving instance ToExpr (BlocksInFile Block) -deriving instance ToExpr (CodecConfig Block) -deriving instance ToExpr (DBModel Block) deriving instance ToExpr (Model r) -deriving instance ToExpr TestHeaderHash -deriving instance ToExpr TestBodyHash -deriving instance ToExpr EBB -deriving instance ToExpr ChainLength -deriving instance ToExpr TestHeader -deriving instance ToExpr TestBody -deriving instance ToExpr TestBlock -deriving instance ToExpr BinaryBlockInfo -deriving instance ToExpr (ChainHash TestHeader) instance CommandNames (At Cmd) where cmdName (At cmd) = constrName cmd