Fix QSM tests (and make CI happy)

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs

@@ -39,7 +39,9 @@ import           Control.Monad (unless, void, when)
 import           Control.Monad.Except (runExcept)
 import           Control.ResourceRegistry
 import           Control.Tracer (Tracer (..), nullTracer, traceWith)
+#if __GLASGOW_HASKELL__ < 910
 import           Data.Foldable (foldl')
+#endif
 import           Data.Int (Int64)
 import           Data.List (intercalate)
 import qualified Data.Map.Strict as Map

ouroboros-consensus/ouroboros-consensus.cabal

@@ -592,6 +592,7 @@ test-suite consensus-test
     cardano-binary,
     cardano-crypto-class,
     cardano-crypto-tests,
+    cardano-ledger-core:testlib,
     cardano-slotting:{cardano-slotting, testlib},
     cardano-strict-containers,
     cborg,
@@ -605,6 +606,7 @@ test-suite consensus-test
     hashable,
     io-classes,
     io-sim,
+    measures,
     mtl,
     nonempty-containers,
     nothunks,
@@ -615,6 +617,7 @@ test-suite consensus-test
     ouroboros-network-protocols:{ouroboros-network-protocols, testlib},
     quickcheck-classes,
     quickcheck-monoid-subclasses,
+    quickcheck-state-machine:no-vendored-treediff,
     quiet,
     random,
     resource-registry,
@@ -631,6 +634,7 @@ test-suite consensus-test
     time,
     transformers,
     transformers-base,
+    tree-diff,
     typed-protocols ^>=0.3,
     typed-protocols-examples,
     typed-protocols-stateful,

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -32,7 +33,9 @@ import           Control.Monad.Except
 import           Data.ByteString.Short (ShortByteString)
 import           Data.Coerce (coerce)
 import           Data.DerivingVia (InstantiatedAt (..))
+#if __GLASGOW_HASKELL__ < 910
 import           Data.Foldable
+#endif
 import           Data.Kind (Type)
 import           Data.Measure (Measure)
 import qualified Data.Measure

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Capacity.hs

@@ -76,7 +76,9 @@ computeMempoolCapacity cfg st override =
         -- This calculation is happening at Word32. Thus overflow is silently
         -- accepted. Adding one less than the denominator to the numerator
         -- effectively rounds up instead of down.
-        max 1 $ (x + oneBlockBytes - 1) `div` oneBlockBytes
+        max 1 $ if x + oneBlockBytes < x
+                then x `div` oneBlockBytes
+                else (x + oneBlockBytes - 1) `div` oneBlockBytes
 
     SemigroupViaMeasure capacity =
       stimes blockCount (SemigroupViaMeasure oneBlock)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -36,7 +37,9 @@ import           Control.Concurrent.Class.MonadMVar (MVar, newMVar)
 import           Control.Concurrent.Class.MonadSTM.Strict.TMVar (newTMVarIO)
 import           Control.Monad.Trans.Except (runExcept)
 import           Control.Tracer
+#if __GLASGOW_HASKELL__ < 910
 import           Data.Foldable
+#endif
 import qualified Data.List.NonEmpty as NE
 import           Data.Set (Set)
 import qualified Data.Set as Set
@@ -335,8 +338,7 @@ revalidateTxsFor capacityOverride cfg slot st values lastTicketNo txTickets =
         | otherwise
         = filterTxTickets t1s t2ss
       filterTxTickets [] _ =
-        error "There are less transactions given to the revalidate function than \
-              \ transactions revalidated! This is unacceptable (and impossible)!"
+        error "There are less transactions given to the revalidate function than transactions revalidated! This is unacceptable (and impossible)!"
 
   in RevalidateTxsResult
       (IS {

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Query.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
@@ -7,7 +8,9 @@ module Ouroboros.Consensus.Mempool.Query (
   , pureGetSnapshotFor
   ) where
 
+#if __GLASGOW_HASKELL__ < 910
 import           Data.Foldable (foldl')
+#endif
 import           Ouroboros.Consensus.Block.Abstract
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Init.hs

@@ -19,7 +19,9 @@ import           Control.Monad
 import           Control.Monad.Base
 import           Control.ResourceRegistry
 import           Control.Tracer (nullTracer)
+#if __GLASGOW_HASKELL__ < 910
 import           Data.Foldable
+#endif
 import           Data.Functor.Contravariant ((>$<))
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (isJust)
@@ -69,7 +71,9 @@ mkInitDb ::
   , LedgerDbSerialiseConstraints blk
   , MonadBase m m
   , HasHardForkHistory blk
+#if __GLASGOW_HASKELL__ < 910
   , HasAnnTip blk
+#endif
   )
   => Complete LedgerDbArgs m blk
   -> Complete V1.LedgerDbFlavorArgs m
@@ -154,7 +158,9 @@ implMkLedgerDb ::
      , MonadBase m m
      , ApplyBlock l blk
      , l ~ ExtLedgerState blk
+#if __GLASGOW_HASKELL__ < 910
      , HasAnnTip blk
+#endif
      , HasHardForkHistory blk
      )
   => LedgerDBHandle m l blk

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Init.hs

@@ -19,7 +19,9 @@ import           Control.Monad.Base
 import qualified Control.RAWLock as RAWLock
 import           Control.ResourceRegistry
 import           Control.Tracer
+#if __GLASGOW_HASKELL__ < 910
 import           Data.Foldable
+#endif
 import           Data.Functor.Contravariant ((>$<))
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (isJust)
@@ -62,7 +64,9 @@ mkInitDb :: forall m blk.
             , MonadBase m m
             , LedgerDbSerialiseConstraints blk
             , HasHardForkHistory blk
+#if __GLASGOW_HASKELL__ < 910
             , HasAnnTip blk
+#endif
             )
          => Complete LedgerDbArgs m blk
          -> Complete V2.LedgerDbFlavorArgs m

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs

@@ -56,6 +56,7 @@ import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM
 import           Control.Monad.Class.MonadAsync
 import           Control.Monad.Class.MonadEventlog
 import           Control.Monad.Class.MonadFork
+import           Control.Monad.Class.MonadSay
 import           Control.Monad.Class.MonadST
 import           Control.Monad.Class.MonadThrow
 import           Control.Monad.Class.MonadTime.SI
@@ -88,9 +89,12 @@ class ( MonadAsync              m
       , MonadMask               m
       , MonadMonotonicTime      m
       , MonadEvaluate           m
+      , MonadTraceSTM           m
       , Alternative        (STM m)
       , MonadCatch         (STM m)
       , PrimMonad               m
+      , MonadSay                m
+      , MonadLabelledSTM        m
       , forall a. NoThunks (m a)
       , forall a. NoThunks a => NoThunks (StrictSTM.StrictTVar m a)
       , forall a. NoThunks a => NoThunks (StrictSVar m a)

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

@@ -1,10 +1,14 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE StandaloneDeriving #-}
+#if __GLASGOW_HASKELL__ <= 906
+{-# LANGUAGE TypeFamilies #-}
+#endif
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 

ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs

@@ -416,6 +416,11 @@ deriving anyclass instance ( SimpleCrypto c
                            , Typeable ext
                            )
                            => NoThunks (Ticked1 (LedgerState (SimpleBlock c ext)) TrackingMK)
+deriving instance ( SimpleCrypto c
+                  , Typeable ext
+                  , Show (LedgerState (SimpleBlock c ext) mk)
+                  )
+                  => Show (Ticked1 (LedgerState (SimpleBlock c ext)) mk)
 
 instance MockProtocolSpecific c ext => UpdateLedger (SimpleBlock c ext)
 

ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs

@@ -41,6 +41,7 @@ import           Control.Applicative (Alternative (..))
 import qualified Control.Concurrent.Class.MonadMVar.Strict as Strict
 import qualified Control.Concurrent.Class.MonadSTM.Strict as Strict
 import           Control.Monad (MonadPlus, when)
+import           Control.Monad.Class.MonadSay
 import qualified Control.Monad.Class.MonadSTM.Internal as LazySTM
 import           Control.Monad.Class.MonadTime
 import qualified Control.Monad.Class.MonadTimer as MonadTimer
@@ -598,6 +599,9 @@ instance (MonadAsync m, MonadMask m, MonadThrow (STM m)) => MonadAsync (Override
   waitCatchSTM = OverrideDelaySTM . lift . waitCatchSTM . unOverrideDelayAsync
   pollSTM      = OverrideDelaySTM . lift . pollSTM . unOverrideDelayAsync
 
+instance MonadSay m => MonadSay (OverrideDelay m) where
+  say = OverrideDelay . lift . say
+
 instance (IOLike m, MonadDelay (OverrideDelay m)) => IOLike (OverrideDelay m) where
   forgetSignKeyKES = OverrideDelay . lift . forgetSignKeyKES