Merge #1888

1888: Cleanup hard fork history tests r=edsko a=edsko



Co-authored-by: Edsko de Vries <[email protected]>

Author: iohk-bors[bot]

ouroboros-consensus/ouroboros-consensus.cabal

@@ -261,6 +261,8 @@ test-suite test-consensus
                        Test.Consensus.BlockchainTime.SlotLengths
                        Test.Consensus.BlockchainTime.WallClock
                        Test.Consensus.HardFork.History
+                       Test.Consensus.HardFork.Infra
+                       Test.Consensus.HardFork.Summary
                        Test.Consensus.MiniProtocol.ChainSync.Client
                        Test.Consensus.MiniProtocol.LocalStateQuery.Server
                        Test.Consensus.Mempool

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveFunctor       #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE KindSignatures      #-}
+{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving  #-}
 {-# LANGUAGE TypeOperators       #-}
@@ -11,14 +12,17 @@
 module Ouroboros.Consensus.Util.Counting (
     Exactly(..)
   , AtMost(..)
-    -- * Working with 'AtMost'
-  , atMostOne
-  , atMostInit
     -- * Working with 'Exactly'
   , exactlyOne
   , exactlyHead
   , exactlyZip
   , exactlyZipAtMost
+  , exactlyWeaken
+  , exactlyMapStateM
+  , exactlyN
+    -- * Working with 'AtMost'
+  , atMostOne
+  , atMostInit
   ) where
 
 import qualified Data.Foldable as Foldable
@@ -75,6 +79,33 @@ exactlyZipAtMost = \as bs -> go as (Foldable.toList bs)
     go ExactlyNil _              = AtMostNil
     go (ExactlyCons a as) (b:bs) = AtMostCons (a, b) $ go as bs
 
+exactlyWeaken :: Exactly xs a -> AtMost xs a
+exactlyWeaken = go
+  where
+    go :: Exactly xs a -> AtMost xs a
+    go ExactlyNil         = AtMostNil
+    go (ExactlyCons x xs) = AtMostCons x (go xs)
+
+exactlyMapStateM :: forall m xs s a b. Monad m
+                 => (s -> a -> m (s, b))
+                 -> s
+                 -> Exactly xs a -> m (Exactly xs b)
+exactlyMapStateM f = go
+  where
+    go :: forall xs'. s -> Exactly xs' a -> m (Exactly xs' b)
+    go _ ExactlyNil         = return ExactlyNil
+    go s (ExactlyCons a as) = do
+        (s', b) <- f s a
+        bs      <- go s' as
+        return $ ExactlyCons b bs
+
+exactlyN :: Word -> (forall xs. Exactly xs () -> a) -> a
+exactlyN = go
+  where
+    go :: Word -> (forall xs. Exactly xs () -> a) -> a
+    go 0 k = k ExactlyNil
+    go n k = go (n - 1) $ \xs -> k (ExactlyCons () xs)
+
 {-------------------------------------------------------------------------------
   Working with 'AtMost'
 -------------------------------------------------------------------------------}

ouroboros-consensus/test-consensus/Main.hs

@@ -5,6 +5,7 @@ import           Test.Tasty
 import qualified Test.Consensus.BlockchainTime.SlotLengths (tests)
 import qualified Test.Consensus.BlockchainTime.WallClock (tests)
 import qualified Test.Consensus.HardFork.History (tests)
+import qualified Test.Consensus.HardFork.Summary (tests)
 import qualified Test.Consensus.Mempool (tests)
 import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests)
 import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests)
@@ -28,5 +29,6 @@ tests =
   , Test.Consensus.Protocol.PBFT.tests
   , Test.Consensus.ResourceRegistry.tests
   , Test.Consensus.Util.Versioned.tests
+  , Test.Consensus.HardFork.Summary.tests
   , Test.Consensus.HardFork.History.tests
   ]