Skip to content

Commit 98dbae0

Browse files
jasagredojasagredo
authored
Move ToExpr orphan to Orphans.ToExpr (#1088)
Closes #686.
2 parents f99051a + 0315920 commit 98dbae0

File tree

13 files changed

+159
-131
lines changed

13 files changed

+159
-131
lines changed

‎ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Orphans.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
{-# LANGUAGE GADTs #-}
22
{-# LANGUAGE OverloadedStrings #-}
33

4-
{-# OPTIONS_GHC -fno-warn-orphans #-}
4+
{-# OPTIONS_GHC -Wno-orphans #-}
55

66
module Cardano.Tools.DBSynthesizer.Orphans () where
77

‎ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM/Model.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Test.QuickCheck (choose, elements, shrink)
2929
import qualified Test.StateMachine as QSM
3030
import Test.StateMachine (Concrete, Symbolic)
3131
import qualified Test.StateMachine.Types.Rank2 as QSM
32+
import Test.Util.Orphans.ToExpr ()
3233

3334
----- the QSM model
3435

@@ -590,8 +591,6 @@ instance TD.ToExpr Notable where toExpr = TD.defaultExprViaShow
590591

591592
----- orphans
592593

593-
instance TD.ToExpr SI.Time where toExpr = TD.defaultExprViaShow
594-
595594
deriving instance Read LedgerStateJudgement
596595

597596
instance QC.Arbitrary LedgerStateJudgement where

‎ouroboros-consensus/ouroboros-consensus.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -409,6 +409,7 @@ library unstable-consensus-testlib
409409
quiet,
410410
random,
411411
serialise,
412+
si-timers,
412413
sop-core,
413414
sop-extras,
414415
strict-checked-vars,

‎ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE FlexibleInstances #-}
55
{-# LANGUAGE GADTs #-}
66
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
7+
{-# LANGUAGE NamedFieldPuns #-}
78
{-# LANGUAGE NumericUnderscores #-}
89
{-# LANGUAGE ScopedTypeVariables #-}
910
{-# LANGUAGE StandaloneDeriving #-}
@@ -54,6 +55,7 @@ import Ouroboros.Consensus.Protocol.Abstract (ChainDepState)
5455
import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal
5556
(ChunkNo (..), ChunkSize (..), RelativeSlot (..))
5657
import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Layout
58+
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index as Index
5759
import Ouroboros.Consensus.TypeFamilyWrappers
5860
import Ouroboros.Network.SizeInBytes
5961
import Test.Cardano.Slotting.Arbitrary ()
@@ -391,3 +393,16 @@ instance Arbitrary (SomeSecond BlockQuery blk)
391393
arbitrary = do
392394
SomeSecond someBlockQuery <- arbitrary
393395
return (SomeSecond (BlockQuery someBlockQuery))
396+
397+
398+
instance Arbitrary Index.CacheConfig where
399+
arbitrary = do
400+
pastChunksToCache <- frequency
401+
-- Pick small values so that we exercise cache eviction
402+
[ (1, return 1)
403+
, (1, return 2)
404+
, (1, choose (3, 10))
405+
]
406+
-- TODO create a Cmd that advances time, so this is being exercised too.
407+
expireUnusedAfter <- (fromIntegral :: Int -> DiffTime) <$> choose (1, 100)
408+
return Index.CacheConfig {Index.pastChunksToCache, Index.expireUnusedAfter}

‎ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs‎

Lines changed: 67 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,33 @@
11
{-# LANGUAGE FlexibleContexts #-}
22
{-# LANGUAGE UndecidableInstances #-}
33

4-
{-# OPTIONS_GHC -fno-warn-orphans #-}
4+
{-# LANGUAGE DeriveAnyClass #-}
5+
{-# LANGUAGE DeriveGeneric #-}
6+
{-# LANGUAGE DerivingStrategies #-}
7+
{-# LANGUAGE StandaloneDeriving #-}
8+
{-# OPTIONS_GHC -Wno-orphans #-}
59

610
module Test.Util.Orphans.ToExpr () where
711

12+
import qualified Control.Monad.Class.MonadTime.SI as SI
813
import Data.TreeDiff
14+
import GHC.Generics (Generic)
915
import Ouroboros.Consensus.Block
1016
import Ouroboros.Consensus.HeaderValidation
1117
import Ouroboros.Consensus.Ledger.Abstract
1218
import Ouroboros.Consensus.Ledger.Extended
1319
import Ouroboros.Consensus.Protocol.Abstract
20+
import Ouroboros.Consensus.Storage.ChainDB (InvalidBlockReason)
21+
import Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB
22+
import Ouroboros.Consensus.Storage.ImmutableDB
23+
import Ouroboros.Consensus.Util.STM (Fingerprint, WithFingerprint)
24+
import Ouroboros.Network.Block (MaxSlotNo)
25+
import Ouroboros.Network.Mock.Chain
26+
import Ouroboros.Network.Mock.ProducerState
1427
import Ouroboros.Network.Point
28+
import System.FS.API
1529
import Test.Cardano.Slotting.TreeDiff ()
30+
import Test.Util.ToExpr ()
1631

1732
{-------------------------------------------------------------------------------
1833
ouroboros-network
@@ -37,3 +52,54 @@ instance ( ToExpr (ChainDepState (BlockProtocol blk))
3752

3853
instance ( ToExpr (TipInfo blk)
3954
) => ToExpr (AnnTip blk)
55+
56+
instance ToExpr SecurityParam
57+
instance ToExpr DiskSnapshot
58+
59+
instance ToExpr ChunkSize
60+
instance ToExpr ChunkNo
61+
instance ToExpr ChunkSlot
62+
instance ToExpr RelativeSlot
63+
instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d, ToExpr e, ToExpr f, ToExpr g,
64+
ToExpr h, ToExpr i, ToExpr j)
65+
=> ToExpr (a, b, c, d, e, f, g, h, i, j) where
66+
toExpr (a, b, c, d, e, f, g, h, i, j) = App "_×_×_×_×_×_×_×_×_x_"
67+
[ toExpr a, toExpr b, toExpr c, toExpr d, toExpr e, toExpr f, toExpr g
68+
, toExpr h, toExpr i, toExpr j
69+
]
70+
71+
instance ToExpr ChunkInfo where
72+
toExpr = defaultExprViaShow
73+
instance ToExpr FsError where
74+
toExpr fsError = App (show fsError) []
75+
76+
77+
{-------------------------------------------------------------------------------
78+
si-timers
79+
--------------------------------------------------------------------------------}
80+
81+
instance ToExpr SI.Time where toExpr = defaultExprViaShow
82+
83+
84+
deriving anyclass instance ToExpr Fingerprint
85+
deriving anyclass instance ToExpr FollowerNext
86+
deriving anyclass instance ToExpr MaxSlotNo
87+
88+
deriving instance ToExpr (HeaderHash blk) => ToExpr (ChainHash blk)
89+
deriving instance ToExpr (HeaderHash blk) => ToExpr (FollowerState blk)
90+
91+
deriving instance Generic FollowerNext
92+
deriving instance Generic (Chain blk)
93+
deriving instance Generic (ChainProducerState blk)
94+
deriving instance Generic (FollowerState blk)
95+
96+
deriving instance ToExpr blk => ToExpr (Chain blk)
97+
deriving instance ( ToExpr blk
98+
, ToExpr (HeaderHash blk)
99+
)
100+
=> ToExpr (ChainProducerState blk)
101+
deriving instance ToExpr a => ToExpr (WithFingerprint a)
102+
deriving instance ( ToExpr (HeaderHash blk)
103+
, ToExpr (ExtValidationError blk)
104+
)
105+
=> ToExpr (InvalidBlockReason blk)

‎ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE DefaultSignatures #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
23
{-# LANGUAGE DeriveGeneric #-}
34
{-# LANGUAGE FlexibleContexts #-}
45
{-# LANGUAGE LambdaCase #-}
@@ -92,13 +93,16 @@ import Data.Maybe (fromMaybe, isJust)
9293
import Data.Proxy
9394
import Data.Set (Set)
9495
import qualified Data.Set as Set
96+
import Data.TreeDiff
9597
import Data.Word (Word64)
9698
import GHC.Generics (Generic)
9799
import Ouroboros.Consensus.Block
98100
import Ouroboros.Consensus.Config
101+
import Ouroboros.Consensus.HeaderValidation
99102
import Ouroboros.Consensus.Ledger.Abstract
100103
import Ouroboros.Consensus.Ledger.Extended
101104
import Ouroboros.Consensus.Ledger.SupportsProtocol
105+
import Ouroboros.Consensus.Protocol.Abstract
102106
import Ouroboros.Consensus.Protocol.MockChainSel
103107
import Ouroboros.Consensus.Storage.ChainDB.API (AddBlockPromise (..),
104108
AddBlockResult (..), BlockComponent (..),
@@ -115,7 +119,10 @@ import qualified Ouroboros.Network.AnchoredFragment as Fragment
115119
import Ouroboros.Network.Block (MaxSlotNo (..))
116120
import Ouroboros.Network.Mock.Chain (Chain (..), ChainUpdate)
117121
import qualified Ouroboros.Network.Mock.Chain as Chain
122+
import Ouroboros.Network.Mock.ProducerState (ChainProducerState)
118123
import qualified Ouroboros.Network.Mock.ProducerState as CPS
124+
import Test.Cardano.Slotting.TreeDiff ()
125+
119126

120127
type IteratorId = Int
121128

@@ -142,6 +149,19 @@ data Model blk = Model {
142149
}
143150
deriving (Generic)
144151

152+
deriving instance ( ToExpr blk
153+
, ToExpr (HeaderHash blk)
154+
, ToExpr (ChainDepState (BlockProtocol blk))
155+
, ToExpr (TipInfo blk)
156+
, ToExpr (LedgerState blk)
157+
, ToExpr (ExtValidationError blk)
158+
, ToExpr (Chain blk)
159+
, ToExpr (ChainProducerState blk)
160+
, ToExpr (ExtLedgerState blk)
161+
, ToExpr (InvalidBlockReason blk)
162+
)
163+
=> ToExpr (Model blk)
164+
145165
deriving instance (LedgerSupportsProtocol blk, Show blk) => Show (Model blk)
146166

147167
{-------------------------------------------------------------------------------

‎ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs‎

Lines changed: 0 additions & 58 deletions
Original file line numberDiff line numberDiff line change
@@ -112,7 +112,6 @@ import Ouroboros.Consensus.Ledger.Extended
112112
import Ouroboros.Consensus.Ledger.Inspect
113113
import Ouroboros.Consensus.Ledger.SupportsProtocol
114114
import Ouroboros.Consensus.Protocol.Abstract
115-
import Ouroboros.Consensus.Protocol.BFT
116115
import Ouroboros.Consensus.Storage.ChainDB hiding
117116
(TraceFollowerEvent (..))
118117
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
@@ -131,16 +130,10 @@ import Ouroboros.Consensus.Util.Condense (condense)
131130
import Ouroboros.Consensus.Util.Enclose
132131
import Ouroboros.Consensus.Util.IOLike hiding (invariant)
133132
import Ouroboros.Consensus.Util.ResourceRegistry
134-
import Ouroboros.Consensus.Util.STM (Fingerprint (..),
135-
WithFingerprint (..))
136133
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
137134
import qualified Ouroboros.Network.AnchoredFragment as AF
138135
import Ouroboros.Network.Block (ChainUpdate, MaxSlotNo)
139-
import Ouroboros.Network.Mock.Chain (Chain (..))
140136
import qualified Ouroboros.Network.Mock.Chain as Chain
141-
import Ouroboros.Network.Mock.ProducerState (ChainProducerState,
142-
FollowerNext, FollowerState)
143-
import qualified Ouroboros.Network.Mock.ProducerState as CPS
144137
import qualified System.FS.Sim.MockFS as Mock
145138
import System.FS.Sim.MockFS (MockFS)
146139
import qualified Test.Ouroboros.Storage.ChainDB.Model as Model
@@ -1220,35 +1213,6 @@ instance CommandNames (At Cmd blk m) where
12201213
cmdNames (_ :: Proxy (At Cmd blk m r)) =
12211214
constrNames (Proxy @(Cmd blk () ()))
12221215

1223-
deriving instance Generic FollowerNext
1224-
deriving instance Generic IteratorId
1225-
deriving instance Generic (Chain blk)
1226-
deriving instance Generic (ChainProducerState blk)
1227-
deriving instance Generic (FollowerState blk)
1228-
1229-
deriving anyclass instance ToExpr Fingerprint
1230-
deriving anyclass instance ToExpr FollowerNext
1231-
deriving anyclass instance ToExpr MaxSlotNo
1232-
deriving instance ToExpr (HeaderHash blk) => ToExpr (ChainHash blk)
1233-
deriving instance ToExpr (HeaderHash blk) => ToExpr (FollowerState blk)
1234-
deriving instance ToExpr blk => ToExpr (Chain blk)
1235-
deriving instance ( ToExpr blk
1236-
, ToExpr (HeaderHash blk)
1237-
)
1238-
=> ToExpr (ChainProducerState blk)
1239-
deriving instance ToExpr a => ToExpr (WithFingerprint a)
1240-
deriving instance ( ToExpr (HeaderHash blk)
1241-
, ToExpr (ExtValidationError blk)
1242-
)
1243-
=> ToExpr (InvalidBlockReason blk)
1244-
deriving instance ( ToExpr blk
1245-
, ToExpr (HeaderHash blk)
1246-
, ToExpr (ChainDepState (BlockProtocol blk))
1247-
, ToExpr (TipInfo blk)
1248-
, ToExpr (LedgerState blk)
1249-
, ToExpr (ExtValidationError blk)
1250-
)
1251-
=> ToExpr (DBModel blk)
12521216
deriving instance ( ToExpr blk
12531217
, ToExpr (HeaderHash blk)
12541218
, ToExpr (ChainDepState (BlockProtocol blk))
@@ -1258,26 +1222,6 @@ deriving instance ( ToExpr blk
12581222
)
12591223
=> ToExpr (Model blk IO Concrete)
12601224

1261-
-- Blk specific instances
1262-
1263-
deriving anyclass instance ToExpr ChainLength
1264-
deriving anyclass instance ToExpr TestHeaderHash
1265-
deriving anyclass instance ToExpr TestBodyHash
1266-
1267-
deriving instance ToExpr EBB
1268-
deriving instance ToExpr IsEBB
1269-
deriving instance ToExpr TestHeader
1270-
deriving instance ToExpr TestBody
1271-
deriving instance ToExpr TestBlockError
1272-
deriving instance ToExpr Blk
1273-
deriving instance ToExpr (TipInfoIsEBB Blk)
1274-
deriving instance ToExpr (LedgerState Blk)
1275-
deriving instance ToExpr (HeaderError Blk)
1276-
deriving instance ToExpr TestBlockOtherHeaderEnvelopeError
1277-
deriving instance ToExpr (HeaderEnvelopeError Blk)
1278-
deriving instance ToExpr BftValidationErr
1279-
deriving instance ToExpr (ExtValidationError Blk)
1280-
12811225
{-------------------------------------------------------------------------------
12821226
Labelling
12831227
-------------------------------------------------------------------------------}
@@ -1373,8 +1317,6 @@ execCmds model = \(QSM.Commands cs) -> go model cs
13731317

13741318
type Blk = TestBlock
13751319

1376-
instance ModelSupportsBlock TestBlock
1377-
13781320
-- | Note that the 'Blk = TestBlock' is general enough to be used by both the
13791321
-- ChainDB /and/ the ImmutableDB, its generators cannot. For example, in the
13801322
-- ChainDB, blocks are added /out of order/, while in the ImmutableDB, they

‎ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ImmutableDB/Model.hs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
1+
{-# LANGUAGE DeriveAnyClass #-}
12
{-# LANGUAGE DeriveGeneric #-}
23
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE FlexibleInstances #-}
35
{-# LANGUAGE GADTs #-}
46
{-# LANGUAGE LambdaCase #-}
57
{-# LANGUAGE NamedFieldPuns #-}
@@ -44,6 +46,7 @@ import qualified Data.List.NonEmpty as NE
4446
import Data.Map.Strict (Map)
4547
import qualified Data.Map.Strict as Map
4648
import qualified Data.Text as Text
49+
import Data.TreeDiff
4750
import Data.Word (Word64)
4851
import GHC.Generics (Generic)
4952
import Ouroboros.Consensus.Block
@@ -57,6 +60,7 @@ import Ouroboros.Consensus.Util (lastMaybe, takeUntil)
5760
import Ouroboros.Consensus.Util.CallStack
5861
import System.FS.API.Types (FsPath, fsPathSplit)
5962
import Test.Ouroboros.Storage.TestBlock hiding (EBB)
63+
import Test.Util.Orphans.ToExpr ()
6064

6165
data InSlot blk =
6266
-- | This slot contains only a regular block
@@ -156,6 +160,10 @@ type IteratorId = Int
156160
newtype IteratorModel blk = IteratorModel [blk]
157161
deriving (Show, Eq, Generic)
158162

163+
instance ToExpr (IteratorModel TestBlock)
164+
instance ToExpr (DBModel TestBlock)
165+
instance ToExpr (InSlot TestBlock)
166+
159167
{------------------------------------------------------------------------------
160168
Helpers
161169
------------------------------------------------------------------------------}

0 commit comments

Comments
 (0)