Skip to content

Commit

Permalink
Fix QSM tests (and make CI happy)
Browse files Browse the repository at this point in the history
  • Loading branch information
jasagredo committed Oct 23, 2024
1 parent 82298ee commit 152b837
Show file tree
Hide file tree
Showing 15 changed files with 308 additions and 268 deletions.
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -149,6 +149,7 @@ library unstable-diffusion-testlib
ouroboros-network-framework,
ouroboros-network-mock,
ouroboros-network-protocols,
ouroboros-network-testing,
quiet ^>=0.2,
random,
resource-registry,
Expand Down
4 changes: 4 additions & 0 deletions ouroboros-consensus/ouroboros-consensus.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand All @@ -605,6 +606,7 @@ test-suite consensus-test
hashable,
io-classes,
io-sim,
measures,
mtl,
nonempty-containers,
nothunks,
Expand All @@ -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,
Expand All @@ -631,6 +634,7 @@ test-suite consensus-test
time,
transformers,
transformers-base,
tree-diff,
typed-protocols ^>=0.3,
typed-protocols-examples,
typed-protocols-stateful,
Expand Down
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
Expand Down Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
Expand Down Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}

Expand All @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down
Original file line number Diff line number Diff line change
@@ -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 #-}

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down
Loading

0 comments on commit 152b837

Please sign in to comment.