Move ToExpr orphan to Orphans.ToExpr (#1088)

Closes #686.

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
 

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

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,

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}

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)

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)
 
 {-------------------------------------------------------------------------------

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

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