{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Test.Consensus.HardFork.Forecast ( tests -- Quell ghc warning , LedgerView (..) ) where import Control.Exception (assert) import Control.Monad (forM, replicateM, unless, when) import Control.Monad.Except (Except, runExcept, throwError) import Data.Either (isRight) import Data.Foldable (toList) import Data.List (intercalate) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, listToMaybe) import Data.SOP.BasicFunctors import Data.SOP.Counting import Data.SOP.InPairs (InPairs (..)) import qualified Data.SOP.InPairs as InPairs import Data.SOP.NonEmpty import Data.SOP.Sing import Data.SOP.Strict import Data.SOP.Telescope (Telescope (..)) import Data.Word import GHC.Stack import Ouroboros.Consensus.Block import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HardFork.Combinator.Ledger (AnnForecast (..), mkHardForkForecast) import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.History (Bound (..), EraEnd (..), EraParams (..), EraSummary (..), Summary (..)) import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HardFork.History.Util import Ouroboros.Consensus.Util (Some (..), repeatedly, splits) import Test.Consensus.HardFork.Infra import Test.QuickCheck hiding (elements) import Test.Tasty import Test.Tasty.QuickCheck hiding (elements) import Test.Util.QuickCheck tests :: TestTree tests :: TestTree tests = TestName -> [TestTree] -> TestTree testGroup TestName "Forecast" [ TestName -> [TestTree] -> TestTree testGroup TestName "Sanity" [ TestName -> Property -> TestTree forall a. Testable a => TestName -> a -> TestTree testProperty TestName "generator" (Property -> TestTree) -> Property -> TestTree forall a b. (a -> b) -> a -> b $ (Some TestSetup -> Property) -> Property forall a. (Arbitrary a, Show a) => (a -> Property) -> Property checkGenerator Some TestSetup -> Property prop_validTestSetup , TestName -> Property -> TestTree forall a. Testable a => TestName -> a -> TestTree testProperty TestName "shrinker" (Property -> TestTree) -> Property -> TestTree forall a b. (a -> b) -> a -> b $ (Some TestSetup -> Property) -> Property forall a. (Arbitrary a, Show a) => (a -> Property) -> Property checkShrinker Some TestSetup -> Property prop_validTestSetup ] , TestName -> (Bool -> Some TestSetup -> Property) -> TestTree forall a. Testable a => TestName -> a -> TestTree testProperty TestName "forecast" ((Bool -> Some TestSetup -> Property) -> TestTree) -> (Bool -> Some TestSetup -> Property) -> TestTree forall a b. (a -> b) -> a -> b $ Bool -> Some TestSetup -> Property prop_forecast ] {------------------------------------------------------------------------------- Mock chain and ledger -------------------------------------------------------------------------------} newtype Chain era = Chain { forall era. Chain era -> [Block] getBlocks :: [Block] } deriving (Int -> Chain era -> ShowS [Chain era] -> ShowS Chain era -> TestName (Int -> Chain era -> ShowS) -> (Chain era -> TestName) -> ([Chain era] -> ShowS) -> Show (Chain era) forall era. Int -> Chain era -> ShowS forall era. [Chain era] -> ShowS forall era. Chain era -> TestName forall a. (Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a $cshowsPrec :: forall era. Int -> Chain era -> ShowS showsPrec :: Int -> Chain era -> ShowS $cshow :: forall era. Chain era -> TestName show :: Chain era -> TestName $cshowList :: forall era. [Chain era] -> ShowS showList :: [Chain era] -> ShowS Show) data Block = Block SlotNo Scheduled deriving (Int -> Block -> ShowS [Block] -> ShowS Block -> TestName (Int -> Block -> ShowS) -> (Block -> TestName) -> ([Block] -> ShowS) -> Show Block forall a. (Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> Block -> ShowS showsPrec :: Int -> Block -> ShowS $cshow :: Block -> TestName show :: Block -> TestName $cshowList :: [Block] -> ShowS showList :: [Block] -> ShowS Show) type Scheduled = Map SlotNo LedgerUpdate newtype LedgerUpdate = IncreaseValueBy Word64 deriving (Int -> LedgerUpdate -> ShowS [LedgerUpdate] -> ShowS LedgerUpdate -> TestName (Int -> LedgerUpdate -> ShowS) -> (LedgerUpdate -> TestName) -> ([LedgerUpdate] -> ShowS) -> Show LedgerUpdate forall a. (Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> LedgerUpdate -> ShowS showsPrec :: Int -> LedgerUpdate -> ShowS $cshow :: LedgerUpdate -> TestName show :: LedgerUpdate -> TestName $cshowList :: [LedgerUpdate] -> ShowS showList :: [LedgerUpdate] -> ShowS Show, LedgerUpdate -> LedgerUpdate -> Bool (LedgerUpdate -> LedgerUpdate -> Bool) -> (LedgerUpdate -> LedgerUpdate -> Bool) -> Eq LedgerUpdate forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: LedgerUpdate -> LedgerUpdate -> Bool == :: LedgerUpdate -> LedgerUpdate -> Bool $c/= :: LedgerUpdate -> LedgerUpdate -> Bool /= :: LedgerUpdate -> LedgerUpdate -> Bool Eq, Integer -> LedgerUpdate LedgerUpdate -> LedgerUpdate LedgerUpdate -> LedgerUpdate -> LedgerUpdate (LedgerUpdate -> LedgerUpdate -> LedgerUpdate) -> (LedgerUpdate -> LedgerUpdate -> LedgerUpdate) -> (LedgerUpdate -> LedgerUpdate -> LedgerUpdate) -> (LedgerUpdate -> LedgerUpdate) -> (LedgerUpdate -> LedgerUpdate) -> (LedgerUpdate -> LedgerUpdate) -> (Integer -> LedgerUpdate) -> Num LedgerUpdate forall a. (a -> a -> a) -> (a -> a -> a) -> (a -> a -> a) -> (a -> a) -> (a -> a) -> (a -> a) -> (Integer -> a) -> Num a $c+ :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate + :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate $c- :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate - :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate $c* :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate * :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate $cnegate :: LedgerUpdate -> LedgerUpdate negate :: LedgerUpdate -> LedgerUpdate $cabs :: LedgerUpdate -> LedgerUpdate abs :: LedgerUpdate -> LedgerUpdate $csignum :: LedgerUpdate -> LedgerUpdate signum :: LedgerUpdate -> LedgerUpdate $cfromInteger :: Integer -> LedgerUpdate fromInteger :: Integer -> LedgerUpdate Num) {------------------------------------------------------------------------------- Ledger state -------------------------------------------------------------------------------} type LedgerValue = Word64 data LedgerState = LedgerState { LedgerState -> MaxLookahead ledgerValue :: LedgerValue , LedgerState -> Scheduled ledgerScheduled :: Scheduled , LedgerState -> WithOrigin SlotNo ledgerTip :: WithOrigin SlotNo } deriving (Int -> LedgerState -> ShowS [LedgerState] -> ShowS LedgerState -> TestName (Int -> LedgerState -> ShowS) -> (LedgerState -> TestName) -> ([LedgerState] -> ShowS) -> Show LedgerState forall a. (Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> LedgerState -> ShowS showsPrec :: Int -> LedgerState -> ShowS $cshow :: LedgerState -> TestName show :: LedgerState -> TestName $cshowList :: [LedgerState] -> ShowS showList :: [LedgerState] -> ShowS Show) data instance Ticked LedgerState = TickedLedgerState { Ticked LedgerState -> MaxLookahead tickedValue :: LedgerValue , Ticked LedgerState -> Scheduled tickedScheduled :: Scheduled } deriving (Int -> Ticked LedgerState -> ShowS [Ticked LedgerState] -> ShowS Ticked LedgerState -> TestName (Int -> Ticked LedgerState -> ShowS) -> (Ticked LedgerState -> TestName) -> ([Ticked LedgerState] -> ShowS) -> Show (Ticked LedgerState) forall a. (Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> Ticked LedgerState -> ShowS showsPrec :: Int -> Ticked LedgerState -> ShowS $cshow :: Ticked LedgerState -> TestName show :: Ticked LedgerState -> TestName $cshowList :: [Ticked LedgerState] -> ShowS showList :: [Ticked LedgerState] -> ShowS Show) newtype LedgerView = LedgerView LedgerValue initLedgerState :: LedgerState initLedgerState :: LedgerState initLedgerState = LedgerState { ledgerValue :: MaxLookahead ledgerValue = MaxLookahead 0 , ledgerScheduled :: Scheduled ledgerScheduled = Scheduled forall k a. Map k a Map.empty , ledgerTip :: WithOrigin SlotNo ledgerTip = WithOrigin SlotNo forall t. WithOrigin t Origin } tickLedgerState :: SlotNo -> LedgerState -> Ticked LedgerState tickLedgerState :: SlotNo -> LedgerState -> Ticked LedgerState tickLedgerState SlotNo sno = SlotNo -> Ticked LedgerState -> Ticked LedgerState advanceTo SlotNo sno (Ticked LedgerState -> Ticked LedgerState) -> (LedgerState -> Ticked LedgerState) -> LedgerState -> Ticked LedgerState forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerState -> Ticked LedgerState tickToTip -- | "Tick to tip" just translates @LedgerState@ to @Ticked LedgerState@ -- without actually changing anything: after all, the ledger already /is/ -- at its tip. tickToTip :: LedgerState -> Ticked LedgerState tickToTip :: LedgerState -> Ticked LedgerState tickToTip LedgerState{MaxLookahead Scheduled WithOrigin SlotNo ledgerValue :: LedgerState -> MaxLookahead ledgerScheduled :: LedgerState -> Scheduled ledgerTip :: LedgerState -> WithOrigin SlotNo ledgerValue :: MaxLookahead ledgerScheduled :: Scheduled ledgerTip :: WithOrigin SlotNo ..} = TickedLedgerState { tickedScheduled :: Scheduled tickedScheduled = Scheduled ledgerScheduled , tickedValue :: MaxLookahead tickedValue = MaxLookahead ledgerValue } -- | Advance the ticked ledger state to the given 'SlotNo' advanceTo :: SlotNo -> Ticked LedgerState -> Ticked LedgerState advanceTo :: SlotNo -> Ticked LedgerState -> Ticked LedgerState advanceTo SlotNo sno TickedLedgerState{MaxLookahead Scheduled tickedValue :: Ticked LedgerState -> MaxLookahead tickedScheduled :: Ticked LedgerState -> Scheduled tickedValue :: MaxLookahead tickedScheduled :: Scheduled ..} = TickedLedgerState { tickedScheduled :: Scheduled tickedScheduled = Scheduled notYet , tickedValue :: MaxLookahead tickedValue = (LedgerUpdate -> MaxLookahead -> MaxLookahead) -> [LedgerUpdate] -> MaxLookahead -> MaxLookahead forall a b. (a -> b -> b) -> [a] -> b -> b repeatedly LedgerUpdate -> MaxLookahead -> MaxLookahead applyLedgerUpdate (Scheduled -> [LedgerUpdate] forall k a. Map k a -> [a] Map.elems Scheduled toApply) MaxLookahead tickedValue } where toApply, notYet :: Scheduled (Scheduled toApply, Scheduled notYet) = (SlotNo -> LedgerUpdate -> Bool) -> Scheduled -> (Scheduled, Scheduled) forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a) Map.partitionWithKey (\SlotNo sno' LedgerUpdate _ -> SlotNo sno' SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool <= SlotNo sno) Scheduled tickedScheduled applyLedgerUpdate :: LedgerUpdate -> LedgerValue -> LedgerValue applyLedgerUpdate :: LedgerUpdate -> MaxLookahead -> MaxLookahead applyLedgerUpdate (IncreaseValueBy MaxLookahead d) = (MaxLookahead -> MaxLookahead -> MaxLookahead forall a. Num a => a -> a -> a + MaxLookahead d) -- | Advance ledger state to the next slot (without a block) stepLedgerState :: LedgerState -> LedgerState stepLedgerState :: LedgerState -> LedgerState stepLedgerState LedgerState ledgerState = LedgerState { ledgerScheduled :: Scheduled ledgerScheduled = Scheduled tickedScheduled , ledgerValue :: MaxLookahead ledgerValue = MaxLookahead tickedValue , ledgerTip :: WithOrigin SlotNo ledgerTip = SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo nextSlot } where nextSlot :: SlotNo nextSlot :: SlotNo nextSlot = case LedgerState -> WithOrigin SlotNo ledgerTip LedgerState ledgerState of WithOrigin SlotNo Origin -> MaxLookahead -> SlotNo SlotNo MaxLookahead 0 NotOrigin SlotNo s -> SlotNo -> SlotNo forall a. Enum a => a -> a succ SlotNo s TickedLedgerState{MaxLookahead Scheduled tickedValue :: Ticked LedgerState -> MaxLookahead tickedScheduled :: Ticked LedgerState -> Scheduled tickedScheduled :: Scheduled tickedValue :: MaxLookahead ..} = SlotNo -> LedgerState -> Ticked LedgerState tickLedgerState SlotNo nextSlot LedgerState ledgerState applyBlock :: Block -> Ticked LedgerState -> LedgerState applyBlock :: Block -> Ticked LedgerState -> LedgerState applyBlock (Block SlotNo slot Scheduled blockScheduled) TickedLedgerState{MaxLookahead Scheduled tickedValue :: Ticked LedgerState -> MaxLookahead tickedScheduled :: Ticked LedgerState -> Scheduled tickedValue :: MaxLookahead tickedScheduled :: Scheduled ..} = LedgerState { ledgerScheduled :: Scheduled ledgerScheduled = (LedgerUpdate -> LedgerUpdate -> LedgerUpdate) -> Scheduled -> Scheduled -> Scheduled forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a Map.unionWith LedgerUpdate -> LedgerUpdate -> LedgerUpdate combineUpdates Scheduled tickedScheduled Scheduled notYet , ledgerValue :: MaxLookahead ledgerValue = (MaxLookahead -> MaxLookahead) -> (LedgerUpdate -> MaxLookahead -> MaxLookahead) -> Maybe LedgerUpdate -> MaxLookahead -> MaxLookahead forall b a. b -> (a -> b) -> Maybe a -> b maybe MaxLookahead -> MaxLookahead forall a. a -> a id LedgerUpdate -> MaxLookahead -> MaxLookahead applyLedgerUpdate Maybe LedgerUpdate mToApply (MaxLookahead -> MaxLookahead) -> MaxLookahead -> MaxLookahead forall a b. (a -> b) -> a -> b $ MaxLookahead tickedValue , ledgerTip :: WithOrigin SlotNo ledgerTip = SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo slot } where combineUpdates :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate combineUpdates :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate combineUpdates (IncreaseValueBy MaxLookahead x) (IncreaseValueBy MaxLookahead y) = MaxLookahead -> LedgerUpdate IncreaseValueBy (MaxLookahead x MaxLookahead -> MaxLookahead -> MaxLookahead forall a. Num a => a -> a -> a + MaxLookahead y) -- Immediately apply any changes scheduled for the block's own slot mToApply :: Maybe LedgerUpdate notYet :: Scheduled (Maybe LedgerUpdate mToApply, Scheduled notYet) = (SlotNo -> LedgerUpdate -> Maybe LedgerUpdate) -> SlotNo -> Scheduled -> (Maybe LedgerUpdate, Scheduled) forall k a. Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a) Map.updateLookupWithKey (\SlotNo _ LedgerUpdate _ -> Maybe LedgerUpdate forall a. Maybe a Nothing) SlotNo slot Scheduled blockScheduled {------------------------------------------------------------------------------- Moving between eras -------------------------------------------------------------------------------} -- A value of @x@ in era @n@ corresponds to a value of @3x@ in era @n+1@ -- -- This means that the HFC translation functions have some work to do. translateToNextEra :: LedgerState -> LedgerState translateToNextEra :: LedgerState -> LedgerState translateToNextEra LedgerState{MaxLookahead Scheduled WithOrigin SlotNo ledgerValue :: LedgerState -> MaxLookahead ledgerScheduled :: LedgerState -> Scheduled ledgerTip :: LedgerState -> WithOrigin SlotNo ledgerValue :: MaxLookahead ledgerScheduled :: Scheduled ledgerTip :: WithOrigin SlotNo ..} = LedgerState{ ledgerTip :: WithOrigin SlotNo ledgerTip = WithOrigin SlotNo ledgerTip , ledgerValue :: MaxLookahead ledgerValue = MaxLookahead -> MaxLookahead forall a. Num a => a -> a inflate MaxLookahead ledgerValue , ledgerScheduled :: Scheduled ledgerScheduled = LedgerUpdate -> LedgerUpdate forall a. Num a => a -> a inflate (LedgerUpdate -> LedgerUpdate) -> Scheduled -> Scheduled forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Scheduled ledgerScheduled } inflate :: Num a => a -> a inflate :: forall a. Num a => a -> a inflate a x = a x a -> a -> a forall a. Num a => a -> a -> a * a 3 {------------------------------------------------------------------------------- Forecasting within an era -------------------------------------------------------------------------------} withinEraForecast :: MaxLookahead -> LedgerState -> Forecast LedgerView withinEraForecast :: MaxLookahead -> LedgerState -> Forecast LedgerView withinEraForecast MaxLookahead maxLookAhead LedgerState st = Forecast{ forecastAt :: WithOrigin SlotNo forecastAt = LedgerState -> WithOrigin SlotNo ledgerTip LedgerState st , forecastFor :: SlotNo -> Except OutsideForecastRange LedgerView forecastFor = SlotNo -> Except OutsideForecastRange LedgerView go } where go :: SlotNo -> Except OutsideForecastRange LedgerView go :: SlotNo -> Except OutsideForecastRange LedgerView go SlotNo for = do Bool -> ExceptT OutsideForecastRange Identity () -> ExceptT OutsideForecastRange Identity () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (SlotNo for SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool >= SlotNo upperBound) (ExceptT OutsideForecastRange Identity () -> ExceptT OutsideForecastRange Identity ()) -> ExceptT OutsideForecastRange Identity () -> ExceptT OutsideForecastRange Identity () forall a b. (a -> b) -> a -> b $ OutsideForecastRange -> ExceptT OutsideForecastRange Identity () forall a. OutsideForecastRange -> ExceptT OutsideForecastRange Identity a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError OutsideForecastRange { outsideForecastAt :: WithOrigin SlotNo outsideForecastAt = LedgerState -> WithOrigin SlotNo ledgerTip LedgerState st , outsideForecastMaxFor :: SlotNo outsideForecastMaxFor = SlotNo upperBound , outsideForecastFor :: SlotNo outsideForecastFor = SlotNo for } LedgerView -> Except OutsideForecastRange LedgerView forall a. a -> ExceptT OutsideForecastRange Identity a forall (m :: * -> *) a. Monad m => a -> m a return (LedgerView -> Except OutsideForecastRange LedgerView) -> LedgerView -> Except OutsideForecastRange LedgerView forall a b. (a -> b) -> a -> b $ MaxLookahead -> LedgerView LedgerView (MaxLookahead -> LedgerView) -> (Ticked LedgerState -> MaxLookahead) -> Ticked LedgerState -> LedgerView forall b c a. (b -> c) -> (a -> b) -> a -> c . Ticked LedgerState -> MaxLookahead tickedValue (Ticked LedgerState -> LedgerView) -> Ticked LedgerState -> LedgerView forall a b. (a -> b) -> a -> b $ SlotNo -> LedgerState -> Ticked LedgerState tickLedgerState SlotNo for LedgerState st where -- Exclusive upper bound upperBound :: SlotNo upperBound :: SlotNo upperBound = case LedgerState -> WithOrigin SlotNo ledgerTip LedgerState st of WithOrigin SlotNo Origin -> MaxLookahead -> SlotNo -> SlotNo addSlots MaxLookahead maxLookAhead (MaxLookahead -> SlotNo SlotNo MaxLookahead 0) NotOrigin SlotNo s -> MaxLookahead -> SlotNo -> SlotNo addSlots MaxLookahead maxLookAhead (SlotNo -> SlotNo forall a. Enum a => a -> a succ SlotNo s) {------------------------------------------------------------------------------- Forecasting across eras -------------------------------------------------------------------------------} -- | Translations between eras translations :: forall xs. TestSetup xs -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) xs translations :: forall (xs :: [*]). TestSetup xs -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) xs translations TestSetup{NonEmpty xs TestEra Exactly xs MaxLookahead TestForecastParams testLookahead :: Exactly xs MaxLookahead testEras :: NonEmpty xs TestEra testForecastParams :: TestForecastParams testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams ..} = case Proxy xs -> ProofNonEmpty xs forall {a} (xs :: [a]) (proxy :: [a] -> *). IsNonEmpty xs => proxy xs -> ProofNonEmpty xs forall (proxy :: [*] -> *). proxy xs -> ProofNonEmpty xs isNonEmpty (forall (t :: [*]). Proxy t forall {k} (t :: k). Proxy t Proxy @xs) of ProofNonEmpty{} -> Exactly (x : xs1) MaxLookahead -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs1) forall x (xs' :: [*]). Exactly (x : xs') MaxLookahead -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs') go Exactly xs MaxLookahead Exactly (x : xs1) MaxLookahead testLookahead where go :: Exactly (x ': xs') MaxLookahead -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) (x ': xs') go :: forall x (xs' :: [*]). Exactly (x : xs') MaxLookahead -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs') go (ExactlyCons MaxLookahead _ Exactly xs MaxLookahead ExactlyNil) = InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs') InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) '[x] forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x] InPairs.PNil go (ExactlyCons MaxLookahead this rest :: Exactly xs MaxLookahead rest@(ExactlyCons MaxLookahead next Exactly xs MaxLookahead _)) = CrossEraForecaster (K LedgerState) (K LedgerView) x x -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs) -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : x : xs) forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (zs :: [k]). f x y -> InPairs f (y : zs) -> InPairs f (x : y : zs) InPairs.PCons (MaxLookahead -> MaxLookahead -> CrossEraForecaster (K LedgerState) (K LedgerView) x x forall era era'. MaxLookahead -> MaxLookahead -> CrossEraForecaster (K LedgerState) (K LedgerView) era era' tr MaxLookahead this MaxLookahead next) (Exactly (x : xs) MaxLookahead -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs) forall x (xs' :: [*]). Exactly (x : xs') MaxLookahead -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs') go Exactly xs MaxLookahead Exactly (x : xs) MaxLookahead rest) tr :: MaxLookahead -- ^ Look-ahead in the current era -> MaxLookahead -- ^ Look-ahead in the next era -> CrossEraForecaster (K LedgerState) (K LedgerView) era era' tr :: forall era era'. MaxLookahead -> MaxLookahead -> CrossEraForecaster (K LedgerState) (K LedgerView) era era' tr MaxLookahead thisLookahead MaxLookahead nextLookahead = (Bound -> SlotNo -> K LedgerState era -> Except OutsideForecastRange (K LedgerView era')) -> CrossEraForecaster (K LedgerState) (K LedgerView) era era' forall (state :: * -> *) (view :: * -> *) x y. (Bound -> SlotNo -> state x -> Except OutsideForecastRange (view y)) -> CrossEraForecaster state view x y CrossEraForecaster ((Bound -> SlotNo -> K LedgerState era -> Except OutsideForecastRange (K LedgerView era')) -> CrossEraForecaster (K LedgerState) (K LedgerView) era era') -> (Bound -> SlotNo -> K LedgerState era -> Except OutsideForecastRange (K LedgerView era')) -> CrossEraForecaster (K LedgerState) (K LedgerView) era era' forall a b. (a -> b) -> a -> b $ \Bound transition SlotNo sno (K LedgerState st) -> Bool -> Except OutsideForecastRange (K LedgerView era') -> Except OutsideForecastRange (K LedgerView era') forall a. (?callStack::CallStack) => Bool -> a -> a assert (SlotNo sno SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool >= Bound -> SlotNo boundSlot Bound transition) (Except OutsideForecastRange (K LedgerView era') -> Except OutsideForecastRange (K LedgerView era')) -> Except OutsideForecastRange (K LedgerView era') -> Except OutsideForecastRange (K LedgerView era') forall a b. (a -> b) -> a -> b $ do let tip :: WithOrigin SlotNo tip :: WithOrigin SlotNo tip = LedgerState -> WithOrigin SlotNo ledgerTip LedgerState st -- (Exclusive) upper bound for the forecast bound :: SlotNo bound :: SlotNo bound = WithOrigin SlotNo -> SlotNo -> MaxLookahead -> MaxLookahead -> SlotNo crossEraForecastBound WithOrigin SlotNo tip (Bound -> SlotNo boundSlot Bound transition) MaxLookahead thisLookahead MaxLookahead nextLookahead Bool -> ExceptT OutsideForecastRange Identity () -> ExceptT OutsideForecastRange Identity () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (SlotNo sno SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool >= SlotNo bound) (ExceptT OutsideForecastRange Identity () -> ExceptT OutsideForecastRange Identity ()) -> ExceptT OutsideForecastRange Identity () -> ExceptT OutsideForecastRange Identity () forall a b. (a -> b) -> a -> b $ OutsideForecastRange -> ExceptT OutsideForecastRange Identity () forall a. OutsideForecastRange -> ExceptT OutsideForecastRange Identity a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (OutsideForecastRange -> ExceptT OutsideForecastRange Identity ()) -> OutsideForecastRange -> ExceptT OutsideForecastRange Identity () forall a b. (a -> b) -> a -> b $ OutsideForecastRange { outsideForecastAt :: WithOrigin SlotNo outsideForecastAt = WithOrigin SlotNo tip , outsideForecastMaxFor :: SlotNo outsideForecastMaxFor = SlotNo bound , outsideForecastFor :: SlotNo outsideForecastFor = SlotNo sno } -- We set things up so that we don't have to be too careful with -- the ordering of the operations here: @3x + 3y = 3(x + y)@. K LedgerView era' -> Except OutsideForecastRange (K LedgerView era') forall a. a -> ExceptT OutsideForecastRange Identity a forall (m :: * -> *) a. Monad m => a -> m a return (K LedgerView era' -> Except OutsideForecastRange (K LedgerView era')) -> K LedgerView era' -> Except OutsideForecastRange (K LedgerView era') forall a b. (a -> b) -> a -> b $ LedgerView -> K LedgerView era' forall k a (b :: k). a -> K a b K (LedgerView -> K LedgerView era') -> LedgerView -> K LedgerView era' forall a b. (a -> b) -> a -> b $ MaxLookahead -> LedgerView LedgerView (MaxLookahead -> LedgerView) -> MaxLookahead -> LedgerView forall a b. (a -> b) -> a -> b $ MaxLookahead -> MaxLookahead forall a. Num a => a -> a inflate (MaxLookahead -> MaxLookahead) -> MaxLookahead -> MaxLookahead forall a b. (a -> b) -> a -> b $ Ticked LedgerState -> MaxLookahead tickedValue (Ticked LedgerState -> MaxLookahead) -> Ticked LedgerState -> MaxLookahead forall a b. (a -> b) -> a -> b $ SlotNo -> LedgerState -> Ticked LedgerState tickLedgerState SlotNo sno LedgerState st acrossErasForecast :: forall xs. TestSetup xs -> Map (WithOrigin SlotNo) LedgerState -> Forecast LedgerView acrossErasForecast :: forall (xs :: [*]). TestSetup xs -> Map (WithOrigin SlotNo) LedgerState -> Forecast LedgerView acrossErasForecast setup :: TestSetup xs setup@TestSetup{NonEmpty xs TestEra Exactly xs MaxLookahead TestForecastParams testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams testLookahead :: Exactly xs MaxLookahead testEras :: NonEmpty xs TestEra testForecastParams :: TestForecastParams ..} Map (WithOrigin SlotNo) LedgerState ledgerStates = (HardForkLedgerView_ (K LedgerView) xs -> LedgerView) -> Forecast (HardForkLedgerView_ (K LedgerView) xs) -> Forecast LedgerView forall a b. (a -> b) -> Forecast a -> Forecast b mapForecast HardForkLedgerView_ (K LedgerView) xs -> LedgerView aux (Forecast (HardForkLedgerView_ (K LedgerView) xs) -> Forecast LedgerView) -> Forecast (HardForkLedgerView_ (K LedgerView) xs) -> Forecast LedgerView forall a b. (a -> b) -> a -> b $ InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) xs -> HardForkState (AnnForecast (K LedgerState) (K LedgerView)) xs -> Forecast (HardForkLedgerView_ (K LedgerView) xs) forall (state :: * -> *) (view :: * -> *) (xs :: [*]). SListI xs => InPairs (CrossEraForecaster state view) xs -> HardForkState (AnnForecast state view) xs -> Forecast (HardForkLedgerView_ view xs) mkHardForkForecast (TestSetup xs -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) xs forall (xs :: [*]). TestSetup xs -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) xs translations TestSetup xs setup) (Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs -> HardForkState (AnnForecast (K LedgerState) (K LedgerView)) xs forall (f :: * -> *) (xs :: [*]). Telescope (K Past) (Current f) xs -> HardForkState f xs HardForkState (NonEmpty xs TestEra -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs forall (xs' :: [*]). NonEmpty xs' TestEra -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs' go NonEmpty xs TestEra testEras)) where TestForecastParams{WithOrigin SlotNo SlotNo testForecastAt :: WithOrigin SlotNo testForecastWithinEra :: SlotNo testForecastAcrossEras :: SlotNo testForecastAt :: TestForecastParams -> WithOrigin SlotNo testForecastWithinEra :: TestForecastParams -> SlotNo testForecastAcrossEras :: TestForecastParams -> SlotNo ..} = TestForecastParams testForecastParams aux :: HardForkLedgerView_ (K LedgerView) xs -> LedgerView aux :: HardForkLedgerView_ (K LedgerView) xs -> LedgerView aux = HardForkState (K LedgerView) xs -> CollapseTo HardForkState LedgerView HardForkState (K LedgerView) xs -> LedgerView forall (xs :: [*]) a. SListIN HardForkState xs => HardForkState (K a) xs -> CollapseTo HardForkState a forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (HardForkState (K LedgerView) xs -> LedgerView) -> (HardForkLedgerView_ (K LedgerView) xs -> HardForkState (K LedgerView) xs) -> HardForkLedgerView_ (K LedgerView) xs -> LedgerView forall b c a. (b -> c) -> (a -> b) -> a -> c . HardForkLedgerView_ (K LedgerView) xs -> HardForkState (K LedgerView) xs forall (f :: * -> *) (xs :: [*]). HardForkLedgerView_ f xs -> HardForkState f xs hardForkLedgerViewPerEra go :: NonEmpty xs' TestEra -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs' go :: forall (xs' :: [*]). NonEmpty xs' TestEra -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs' go (NonEmptyOne TestEra era) = Bool -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs' -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs' forall a. (?callStack::CallStack) => Bool -> a -> a assert (WithOrigin SlotNo -> TestEra -> Bool testEraContains WithOrigin SlotNo testForecastAt TestEra era) (Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs' -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs') -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs' -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs' forall a b. (a -> b) -> a -> b $ Current (AnnForecast (K LedgerState) (K LedgerView)) x -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) (x : xs1) forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]). f x -> Telescope g f (x : xs1) TZ (Current (AnnForecast (K LedgerState) (K LedgerView)) x -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) (x : xs1)) -> Current (AnnForecast (K LedgerState) (K LedgerView)) x -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) (x : xs1) forall a b. (a -> b) -> a -> b $ Current { currentStart :: Bound currentStart = EraSummary -> Bound eraStart (TestEra -> EraSummary testEraSummary TestEra era) , currentState :: AnnForecast (K LedgerState) (K LedgerView) x currentState = AnnForecast { annForecast :: Forecast (K LedgerView x) annForecast = (LedgerView -> K LedgerView x) -> Forecast LedgerView -> Forecast (K LedgerView x) forall a b. (a -> b) -> Forecast a -> Forecast b mapForecast LedgerView -> K LedgerView x forall k a (b :: k). a -> K a b K (Forecast LedgerView -> Forecast (K LedgerView x)) -> Forecast LedgerView -> Forecast (K LedgerView x) forall a b. (a -> b) -> a -> b $ MaxLookahead -> LedgerState -> Forecast LedgerView withinEraForecast (TestEra -> MaxLookahead testEraMaxLookahead TestEra era) LedgerState st , annForecastState :: K LedgerState x annForecastState = LedgerState -> K LedgerState x forall k a (b :: k). a -> K a b K LedgerState st , annForecastTip :: WithOrigin SlotNo annForecastTip = WithOrigin SlotNo testForecastAt , annForecastEnd :: Maybe Bound annForecastEnd = Maybe Bound forall a. Maybe a Nothing } } where st :: LedgerState st :: LedgerState st = Map (WithOrigin SlotNo) LedgerState ledgerStates Map (WithOrigin SlotNo) LedgerState -> WithOrigin SlotNo -> LedgerState forall k a. (?callStack::CallStack, Show k, Show a, Ord k) => Map k a -> k -> a `mapAt` WithOrigin SlotNo testForecastAt go (NonEmptyCons TestEra era NonEmpty xs1 TestEra eras) = if WithOrigin SlotNo -> TestEra -> Bool testEraContains WithOrigin SlotNo testForecastAt TestEra era then Current (AnnForecast (K LedgerState) (K LedgerView)) x -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) (x : xs1) forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]). f x -> Telescope g f (x : xs1) TZ (Current (AnnForecast (K LedgerState) (K LedgerView)) x -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) (x : xs1)) -> Current (AnnForecast (K LedgerState) (K LedgerView)) x -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) (x : xs1) forall a b. (a -> b) -> a -> b $ Current { currentStart :: Bound currentStart = Bound start , currentState :: AnnForecast (K LedgerState) (K LedgerView) x currentState = AnnForecast { annForecast :: Forecast (K LedgerView x) annForecast = (LedgerView -> K LedgerView x) -> Forecast LedgerView -> Forecast (K LedgerView x) forall a b. (a -> b) -> Forecast a -> Forecast b mapForecast LedgerView -> K LedgerView x forall k a (b :: k). a -> K a b K (Forecast LedgerView -> Forecast (K LedgerView x)) -> Forecast LedgerView -> Forecast (K LedgerView x) forall a b. (a -> b) -> a -> b $ MaxLookahead -> LedgerState -> Forecast LedgerView withinEraForecast (TestEra -> MaxLookahead testEraMaxLookahead TestEra era) LedgerState st , annForecastState :: K LedgerState x annForecastState = LedgerState -> K LedgerState x forall k a (b :: k). a -> K a b K LedgerState st , annForecastTip :: WithOrigin SlotNo annForecastTip = WithOrigin SlotNo testForecastAt , annForecastEnd :: Maybe Bound annForecastEnd = Bound -> Maybe Bound forall a. a -> Maybe a Just Bound end } } else K Past x -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs1 -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) (x : xs1) forall {k} (g :: k -> *) (x :: k) (f :: k -> *) (xs1 :: [k]). g x -> Telescope g f xs1 -> Telescope g f (x : xs1) TS (Past -> K Past x forall k a (b :: k). a -> K a b K (Bound -> Bound -> Past Past Bound start Bound end)) (NonEmpty xs1 TestEra -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs1 forall (xs' :: [*]). NonEmpty xs' TestEra -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs' go NonEmpty xs1 TestEra eras) where st :: LedgerState st :: LedgerState st = Map (WithOrigin SlotNo) LedgerState ledgerStates Map (WithOrigin SlotNo) LedgerState -> WithOrigin SlotNo -> LedgerState forall k a. (?callStack::CallStack, Show k, Show a, Ord k) => Map k a -> k -> a `mapAt` WithOrigin SlotNo testForecastAt start, end :: Bound start :: Bound start = EraSummary -> Bound eraStart (TestEra -> EraSummary testEraSummary TestEra era) end :: Bound end = case EraSummary -> EraEnd eraEnd (TestEra -> EraSummary testEraSummary TestEra era) of EraEnd EraUnbounded -> TestName -> Bound forall a. (?callStack::CallStack) => TestName -> a error TestName "past eras cannot be unbounded" EraEnd Bound e -> Bound e {------------------------------------------------------------------------------- Forecast validity -------------------------------------------------------------------------------} correctForecastOf :: LedgerView -> LedgerState -> Property LedgerView MaxLookahead forecasted correctForecastOf :: LedgerView -> LedgerState -> Property `correctForecastOf` LedgerState actual = TestName -> Property -> Property forall prop. Testable prop => TestName -> prop -> Property counterexample (TestName "forecasted: " TestName -> ShowS forall a. [a] -> [a] -> [a] ++ MaxLookahead -> TestName forall a. Show a => a -> TestName show MaxLookahead forecasted) (Property -> Property) -> Property -> Property forall a b. (a -> b) -> a -> b $ TestName -> Property -> Property forall prop. Testable prop => TestName -> prop -> Property counterexample (TestName "actual: " TestName -> ShowS forall a. [a] -> [a] -> [a] ++ LedgerState -> TestName forall a. Show a => a -> TestName show LedgerState actual) (Property -> Property) -> Property -> Property forall a b. (a -> b) -> a -> b $ MaxLookahead forecasted MaxLookahead -> MaxLookahead -> Property forall a. (Eq a, Show a) => a -> a -> Property === LedgerState -> MaxLookahead ledgerValue LedgerState actual {------------------------------------------------------------------------------- Sanity checks -------------------------------------------------------------------------------} prop_validTestSetup :: Some TestSetup -> Property prop_validTestSetup :: Some TestSetup -> Property prop_validTestSetup (Some setup :: TestSetup a setup@TestSetup{NonEmpty a TestEra Exactly a MaxLookahead TestForecastParams testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams testLookahead :: Exactly a MaxLookahead testEras :: NonEmpty a TestEra testForecastParams :: TestForecastParams ..}) = [Property] -> Property forall prop. Testable prop => [prop] -> Property conjoin [ TestName -> Property -> Property forall prop. Testable prop => TestName -> prop -> Property counterexample TestName "strictlyIncreasing" (Property -> Property) -> Property -> Property forall a b. (a -> b) -> a -> b $ [SlotNo] -> Property forall a. (Show a, Ord a) => [a] -> Property strictlyIncreasing ([SlotNo] -> Property) -> [SlotNo] -> Property forall a b. (a -> b) -> a -> b $ (Block -> SlotNo) -> [Block] -> [SlotNo] forall a b. (a -> b) -> [a] -> [b] map (\(Block SlotNo s Scheduled _) -> SlotNo s) ([Block] -> [SlotNo]) -> [Block] -> [SlotNo] forall a b. (a -> b) -> a -> b $ [[Block]] -> [Block] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat ([[Block]] -> [Block]) -> [[Block]] -> [Block] forall a b. (a -> b) -> a -> b $ TestSetup a -> [[Block]] forall (xs :: [*]). TestSetup xs -> [[Block]] blocksPerEra TestSetup a setup , TestName -> Property -> Property forall prop. Testable prop => TestName -> prop -> Property counterexample TestName "obeysMaxLookahead" (Property -> Property) -> Property -> Property forall a b. (a -> b) -> a -> b $ [Property] -> Property forall prop. Testable prop => [prop] -> Property conjoin ([Property] -> Property) -> [Property] -> Property forall a b. (a -> b) -> a -> b $ (TestEra -> Property) -> [TestEra] -> [Property] forall a b. (a -> b) -> [a] -> [b] map TestEra -> Property checkLookahead (NonEmpty a TestEra -> [TestEra] forall a. NonEmpty a a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList NonEmpty a TestEra testEras) , TestName -> Property -> Property forall prop. Testable prop => TestName -> prop -> Property counterexample TestName "validForecastParams" (Property -> Property) -> Property -> Property forall a b. (a -> b) -> a -> b $ TestSetup a -> Either TestName () forall (xs :: [*]). TestSetup xs -> Either TestName () validForecastParams TestSetup a setup Either TestName () -> Either TestName () -> Property forall a. (Eq a, Show a) => a -> a -> Property === () -> Either TestName () forall a b. b -> Either a b Right () ] where checkLookahead :: TestEra -> Property checkLookahead :: TestEra -> Property checkLookahead TestEra{[Block] MaxLookahead EraSummary testEraSummary :: TestEra -> EraSummary testEraMaxLookahead :: TestEra -> MaxLookahead testEraSummary :: EraSummary testEraMaxLookahead :: MaxLookahead testEraBlocks :: [Block] testEraBlocks :: TestEra -> [Block] ..} = [Property] -> Property forall prop. Testable prop => [prop] -> Property conjoin [ SlotNo slotChange SlotNo -> SlotNo -> Property forall a. (Ord a, Show a) => a -> a -> Property `ge` MaxLookahead -> SlotNo -> SlotNo addSlots MaxLookahead testEraMaxLookahead SlotNo slotBlock | (Block SlotNo slotBlock Scheduled scheduled) <- [Block] testEraBlocks , (SlotNo slotChange, LedgerUpdate _update) <- Scheduled -> [(SlotNo, LedgerUpdate)] forall k a. Map k a -> [(k, a)] Map.toList Scheduled scheduled ] prop_forecast :: Bool -> Some TestSetup -> Property prop_forecast :: Bool -> Some TestSetup -> Property prop_forecast Bool useWithinEra (Some setup :: TestSetup a setup@TestSetup{NonEmpty a TestEra Exactly a MaxLookahead TestForecastParams testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams testLookahead :: Exactly a MaxLookahead testEras :: NonEmpty a TestEra testForecastParams :: TestForecastParams ..}) = TestName -> [TestName] -> Property -> Property forall prop. Testable prop => TestName -> [TestName] -> prop -> Property tabulate TestName "(useWithinEra, isWithinEra, within range)" [TestName -> [TestName] -> TestName forall a. [a] -> [[a]] -> [a] intercalate TestName "/" [ Bool -> TestName forall a. Show a => a -> TestName show Bool useWithinEra , Bool -> TestName forall a. Show a => a -> TestName show Bool isWithinEra , Bool -> TestName forall a. Show a => a -> TestName show (Either OutsideForecastRange LedgerView -> Bool forall a b. Either a b -> Bool isRight Either OutsideForecastRange LedgerView mForecastLedger) ]] (Property -> Property) -> Property -> Property forall a b. (a -> b) -> a -> b $ TestName -> Property -> Property forall prop. Testable prop => TestName -> prop -> Property counterexample (TestName "ledgerStates: " TestName -> ShowS forall a. [a] -> [a] -> [a] ++ Map (WithOrigin SlotNo) LedgerState -> TestName forall a. Show a => a -> TestName show Map (WithOrigin SlotNo) LedgerState ledgerStates) (Property -> Property) -> Property -> Property forall a b. (a -> b) -> a -> b $ TestName -> Property -> Property forall prop. Testable prop => TestName -> prop -> Property counterexample (TestName "markTransitions: " TestName -> ShowS forall a. [a] -> [a] -> [a] ++ [Either Block EraTransition] -> TestName forall a. Show a => a -> TestName show (TestSetup a -> [Either Block EraTransition] forall (xs :: [*]). TestSetup xs -> [Either Block EraTransition] markTransitions TestSetup a setup)) (Property -> Property) -> Property -> Property forall a b. (a -> b) -> a -> b $ case Either OutsideForecastRange LedgerView mForecastLedger of Left OutsideForecastRange _outOfRange -> -- Ideally we would check that these out of ranges are justified. Bool -> Property forall prop. Testable prop => prop -> Property property Bool True Right LedgerView forecastLedger -> LedgerView forecastLedger LedgerView -> LedgerState -> Property `correctForecastOf` LedgerState actualLedger where TestForecastParams{WithOrigin SlotNo SlotNo testForecastAt :: TestForecastParams -> WithOrigin SlotNo testForecastWithinEra :: TestForecastParams -> SlotNo testForecastAcrossEras :: TestForecastParams -> SlotNo testForecastAt :: WithOrigin SlotNo testForecastWithinEra :: SlotNo testForecastAcrossEras :: SlotNo ..} = TestForecastParams testForecastParams ledgerStates :: Map (WithOrigin SlotNo) LedgerState ledgerStates :: Map (WithOrigin SlotNo) LedgerState ledgerStates = TestSetup a -> Map (WithOrigin SlotNo) LedgerState forall (xs :: [*]). TestSetup xs -> Map (WithOrigin SlotNo) LedgerState interpretChain TestSetup a setup forecast :: Forecast LedgerView forecast :: Forecast LedgerView forecast | Bool useWithinEra = MaxLookahead -> LedgerState -> Forecast LedgerView withinEraForecast (TestSetup a -> WithOrigin SlotNo -> MaxLookahead forall (xs :: [*]). TestSetup xs -> WithOrigin SlotNo -> MaxLookahead slotMaxLookahead TestSetup a setup WithOrigin SlotNo testForecastAt) (Map (WithOrigin SlotNo) LedgerState ledgerStates Map (WithOrigin SlotNo) LedgerState -> WithOrigin SlotNo -> LedgerState forall k a. (?callStack::CallStack, Show k, Show a, Ord k) => Map k a -> k -> a `mapAt` WithOrigin SlotNo testForecastAt) | Bool otherwise = TestSetup a -> Map (WithOrigin SlotNo) LedgerState -> Forecast LedgerView forall (xs :: [*]). TestSetup xs -> Map (WithOrigin SlotNo) LedgerState -> Forecast LedgerView acrossErasForecast TestSetup a setup Map (WithOrigin SlotNo) LedgerState ledgerStates for :: SlotNo for :: SlotNo for | Bool useWithinEra = SlotNo testForecastWithinEra | Bool otherwise = SlotNo testForecastAcrossEras isWithinEra :: Bool isWithinEra :: Bool isWithinEra = TestSetup a -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool forall (xs :: [*]). TestSetup xs -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool slotSameEra TestSetup a setup WithOrigin SlotNo testForecastAt (SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo for) mForecastLedger :: Either OutsideForecastRange LedgerView mForecastLedger :: Either OutsideForecastRange LedgerView mForecastLedger = Except OutsideForecastRange LedgerView -> Either OutsideForecastRange LedgerView forall e a. Except e a -> Either e a runExcept (Except OutsideForecastRange LedgerView -> Either OutsideForecastRange LedgerView) -> Except OutsideForecastRange LedgerView -> Either OutsideForecastRange LedgerView forall a b. (a -> b) -> a -> b $ Forecast LedgerView -> SlotNo -> Except OutsideForecastRange LedgerView forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a forecastFor Forecast LedgerView forecast SlotNo for actualLedger :: LedgerState actualLedger :: LedgerState actualLedger = Map (WithOrigin SlotNo) LedgerState ledgerStates Map (WithOrigin SlotNo) LedgerState -> WithOrigin SlotNo -> LedgerState forall k a. (?callStack::CallStack, Show k, Show a, Ord k) => Map k a -> k -> a `mapAt` SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo for {------------------------------------------------------------------------------- Valued derived from the 'TestSetup' -------------------------------------------------------------------------------} -- | Mark era transitions -- -- This is an auxiliary type used in 'interpretChain'. It records the start of -- end of the current era (equals start of the next) data EraTransition = EraTransition SlotNo deriving (Int -> EraTransition -> ShowS [EraTransition] -> ShowS EraTransition -> TestName (Int -> EraTransition -> ShowS) -> (EraTransition -> TestName) -> ([EraTransition] -> ShowS) -> Show EraTransition forall a. (Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> EraTransition -> ShowS showsPrec :: Int -> EraTransition -> ShowS $cshow :: EraTransition -> TestName show :: EraTransition -> TestName $cshowList :: [EraTransition] -> ShowS showList :: [EraTransition] -> ShowS Show) markTransitions :: TestSetup xs -> [Either Block EraTransition] markTransitions :: forall (xs :: [*]). TestSetup xs -> [Either Block EraTransition] markTransitions = (Either [Block] EraTransition -> [Either Block EraTransition]) -> [Either [Block] EraTransition] -> [Either Block EraTransition] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap (([Block] -> [Either Block EraTransition]) -> (EraTransition -> [Either Block EraTransition]) -> Either [Block] EraTransition -> [Either Block EraTransition] forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either ((Block -> Either Block EraTransition) -> [Block] -> [Either Block EraTransition] forall a b. (a -> b) -> [a] -> [b] map Block -> Either Block EraTransition forall a b. a -> Either a b Left) ((Either Block EraTransition -> [Either Block EraTransition] -> [Either Block EraTransition] forall a. a -> [a] -> [a] :[]) (Either Block EraTransition -> [Either Block EraTransition]) -> (EraTransition -> Either Block EraTransition) -> EraTransition -> [Either Block EraTransition] forall b c a. (b -> c) -> (a -> b) -> a -> c . EraTransition -> Either Block EraTransition forall a b. b -> Either a b Right)) ([Either [Block] EraTransition] -> [Either Block EraTransition]) -> (TestSetup xs -> [Either [Block] EraTransition]) -> TestSetup xs -> [Either Block EraTransition] forall b c a. (b -> c) -> (a -> b) -> a -> c . [TestEra] -> [Either [Block] EraTransition] go ([TestEra] -> [Either [Block] EraTransition]) -> (TestSetup xs -> [TestEra]) -> TestSetup xs -> [Either [Block] EraTransition] forall b c a. (b -> c) -> (a -> b) -> a -> c . NonEmpty xs TestEra -> [TestEra] forall a. NonEmpty xs a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList (NonEmpty xs TestEra -> [TestEra]) -> (TestSetup xs -> NonEmpty xs TestEra) -> TestSetup xs -> [TestEra] forall b c a. (b -> c) -> (a -> b) -> a -> c . TestSetup xs -> NonEmpty xs TestEra forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testEras where go :: [TestEra] -> [Either [Block] EraTransition] go :: [TestEra] -> [Either [Block] EraTransition] go [] = [] go [TestEra e] = [[Block] -> Either [Block] EraTransition forall a b. a -> Either a b Left (TestEra -> [Block] testEraBlocks TestEra e)] go (TestEra e:TestEra e':[TestEra] es) = [Block] -> Either [Block] EraTransition forall a b. a -> Either a b Left (TestEra -> [Block] testEraBlocks TestEra e) Either [Block] EraTransition -> [Either [Block] EraTransition] -> [Either [Block] EraTransition] forall a. a -> [a] -> [a] : EraTransition -> Either [Block] EraTransition forall a b. b -> Either a b Right (SlotNo -> EraTransition EraTransition (Bound -> SlotNo boundSlot (EraSummary -> Bound eraStart (TestEra -> EraSummary testEraSummary TestEra e')))) Either [Block] EraTransition -> [Either [Block] EraTransition] -> [Either [Block] EraTransition] forall a. a -> [a] -> [a] : [TestEra] -> [Either [Block] EraTransition] go (TestEra e' TestEra -> [TestEra] -> [TestEra] forall a. a -> [a] -> [a] : [TestEra] es) -- | The ledger state at every 'SlotNo' interpretChain :: TestSetup xs -> Map (WithOrigin SlotNo) LedgerState interpretChain :: forall (xs :: [*]). TestSetup xs -> Map (WithOrigin SlotNo) LedgerState interpretChain setup :: TestSetup xs setup@TestSetup{NonEmpty xs TestEra Exactly xs MaxLookahead TestForecastParams testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams testLookahead :: Exactly xs MaxLookahead testEras :: NonEmpty xs TestEra testForecastParams :: TestForecastParams ..} = [(WithOrigin SlotNo, LedgerState)] -> Map (WithOrigin SlotNo) LedgerState forall k a. Ord k => [(k, a)] -> Map k a Map.fromList ([(WithOrigin SlotNo, LedgerState)] -> Map (WithOrigin SlotNo) LedgerState) -> [(WithOrigin SlotNo, LedgerState)] -> Map (WithOrigin SlotNo) LedgerState forall a b. (a -> b) -> a -> b $ (WithOrigin SlotNo forall t. WithOrigin t Origin, LedgerState initLedgerState) (WithOrigin SlotNo, LedgerState) -> [(WithOrigin SlotNo, LedgerState)] -> [(WithOrigin SlotNo, LedgerState)] forall a. a -> [a] -> [a] : SlotNo -> LedgerState -> [Either Block EraTransition] -> [(WithOrigin SlotNo, LedgerState)] go SlotNo startSlot LedgerState initLedgerState (TestSetup xs -> [Either Block EraTransition] forall (xs :: [*]). TestSetup xs -> [Either Block EraTransition] markTransitions TestSetup xs setup) where -- The 'endSlot' is the max 'SlotNo' we might need a ledger state for startSlot, endSlot :: SlotNo startSlot :: SlotNo startSlot = MaxLookahead -> SlotNo SlotNo MaxLookahead 0 endSlot :: SlotNo endSlot = SlotNo -> SlotNo -> SlotNo forall a. Ord a => a -> a -> a max (TestForecastParams -> SlotNo testForecastWithinEra TestForecastParams testForecastParams) (TestForecastParams -> SlotNo testForecastAcrossEras TestForecastParams testForecastParams) go :: SlotNo -- Next expected slot -> LedgerState -- Previous state -> [Either Block EraTransition] -> [(WithOrigin SlotNo, LedgerState)] go :: SlotNo -> LedgerState -> [Either Block EraTransition] -> [(WithOrigin SlotNo, LedgerState)] go SlotNo curSlot LedgerState prevLedger [] = SlotNo -> LedgerState -> [(WithOrigin SlotNo, LedgerState)] pad SlotNo curSlot LedgerState prevLedger go SlotNo curSlot LedgerState prevLedger xs :: [Either Block EraTransition] xs@(Left blk :: Block blk@(Block SlotNo s Scheduled _):[Either Block EraTransition] xs') | SlotNo s SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool > SlotNo curSlot = (SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo curSlot, LedgerState stepped) (WithOrigin SlotNo, LedgerState) -> [(WithOrigin SlotNo, LedgerState)] -> [(WithOrigin SlotNo, LedgerState)] forall a. a -> [a] -> [a] : SlotNo -> LedgerState -> [Either Block EraTransition] -> [(WithOrigin SlotNo, LedgerState)] go (SlotNo -> SlotNo forall a. Enum a => a -> a succ SlotNo curSlot) LedgerState stepped [Either Block EraTransition] xs | Bool otherwise = (SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo curSlot, LedgerState applied) (WithOrigin SlotNo, LedgerState) -> [(WithOrigin SlotNo, LedgerState)] -> [(WithOrigin SlotNo, LedgerState)] forall a. a -> [a] -> [a] : SlotNo -> LedgerState -> [Either Block EraTransition] -> [(WithOrigin SlotNo, LedgerState)] go (SlotNo -> SlotNo forall a. Enum a => a -> a succ SlotNo curSlot) LedgerState applied [Either Block EraTransition] xs' where stepped :: LedgerState stepped = LedgerState -> LedgerState stepLedgerState LedgerState prevLedger ticked :: Ticked LedgerState ticked = SlotNo -> LedgerState -> Ticked LedgerState tickLedgerState SlotNo curSlot LedgerState prevLedger applied :: LedgerState applied = Block -> Ticked LedgerState -> LedgerState applyBlock Block blk Ticked LedgerState ticked -- Applying the transition itself does not advance the slot -- (there might be a block in the very first slot in the next era) go SlotNo curSlot LedgerState prevLedger xs :: [Either Block EraTransition] xs@(Right (EraTransition SlotNo s):[Either Block EraTransition] xs') | SlotNo s SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool > SlotNo curSlot = (SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo curSlot, LedgerState stepped) (WithOrigin SlotNo, LedgerState) -> [(WithOrigin SlotNo, LedgerState)] -> [(WithOrigin SlotNo, LedgerState)] forall a. a -> [a] -> [a] : SlotNo -> LedgerState -> [Either Block EraTransition] -> [(WithOrigin SlotNo, LedgerState)] go (SlotNo -> SlotNo forall a. Enum a => a -> a succ SlotNo curSlot) LedgerState stepped [Either Block EraTransition] xs | Bool otherwise = SlotNo -> LedgerState -> [Either Block EraTransition] -> [(WithOrigin SlotNo, LedgerState)] go SlotNo curSlot LedgerState doubled [Either Block EraTransition] xs' where stepped :: LedgerState stepped = LedgerState -> LedgerState stepLedgerState LedgerState prevLedger doubled :: LedgerState doubled = LedgerState -> LedgerState translateToNextEra LedgerState prevLedger -- After we have applied the final block, keep ticking the ledger state -- until we have reached the required 'SlotNo' pad :: SlotNo -> LedgerState -> [(WithOrigin SlotNo, LedgerState)] pad :: SlotNo -> LedgerState -> [(WithOrigin SlotNo, LedgerState)] pad SlotNo curSlot LedgerState prevLedger | SlotNo curSlot SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool > SlotNo endSlot = [] | Bool otherwise = (SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo curSlot, LedgerState stepped) (WithOrigin SlotNo, LedgerState) -> [(WithOrigin SlotNo, LedgerState)] -> [(WithOrigin SlotNo, LedgerState)] forall a. a -> [a] -> [a] : SlotNo -> LedgerState -> [(WithOrigin SlotNo, LedgerState)] pad (SlotNo -> SlotNo forall a. Enum a => a -> a succ SlotNo curSlot) LedgerState stepped where stepped :: LedgerState stepped = LedgerState -> LedgerState stepLedgerState LedgerState prevLedger {------------------------------------------------------------------------------- Test setup -------------------------------------------------------------------------------} data TestEra = TestEra { -- | Era summary (the 'EraParams' and bounds) -- -- NOTE: The 'EraParams' (including associated safe zone) are independent -- from the lookahead, which is a property of the ledger ("how far into -- the future can we look and still know the ledger state"). The safe -- zones of the 'EraParams' only provide guarantees about when we can -- expect era transitions. TestEra -> EraSummary testEraSummary :: EraSummary -- | The maximum look ahead -- -- The HFC itself does not impose any restrictions on the relation between -- the max lookahead of various eras. If the max lookahead in era B is -- smaller than the max lookahead in era A, this " merely " poses a -- problem for the translation function. , TestEra -> MaxLookahead testEraMaxLookahead :: MaxLookahead -- | Blocks on the chain in this era , TestEra -> [Block] testEraBlocks :: [Block] } deriving (Int -> TestEra -> ShowS [TestEra] -> ShowS TestEra -> TestName (Int -> TestEra -> ShowS) -> (TestEra -> TestName) -> ([TestEra] -> ShowS) -> Show TestEra forall a. (Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> TestEra -> ShowS showsPrec :: Int -> TestEra -> ShowS $cshow :: TestEra -> TestName show :: TestEra -> TestName $cshowList :: [TestEra] -> ShowS showList :: [TestEra] -> ShowS Show) -- | The parameters for the forecast we construct -- -- The forecast is constructed in a single era. The HFC combinator is -- responsible for extending it across eras (that's precisely what we're -- testing in this module, of course). data TestForecastParams = TestForecastParams { -- | Anchor of the forecast TestForecastParams -> WithOrigin SlotNo testForecastAt :: WithOrigin SlotNo -- | An arbitrary slot number within the forecast's era -- -- This is used as a sanity check to make sure that within-era -- forecasting works as expected. -- -- Must be at or after 'testForecastAt'. , TestForecastParams -> SlotNo testForecastWithinEra :: SlotNo -- | An arbitrary slot after (or equal to) 'testForecastAt' -- -- This is used to test the general case (across eras). -- Invariant: ahead of testForecastAt but not ahead by more than one era. , TestForecastParams -> SlotNo testForecastAcrossEras :: SlotNo } deriving (Int -> TestForecastParams -> ShowS [TestForecastParams] -> ShowS TestForecastParams -> TestName (Int -> TestForecastParams -> ShowS) -> (TestForecastParams -> TestName) -> ([TestForecastParams] -> ShowS) -> Show TestForecastParams forall a. (Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> TestForecastParams -> ShowS showsPrec :: Int -> TestForecastParams -> ShowS $cshow :: TestForecastParams -> TestName show :: TestForecastParams -> TestName $cshowList :: [TestForecastParams] -> ShowS showList :: [TestForecastParams] -> ShowS Show) data TestSetup xs = (SListI xs, IsNonEmpty xs) => TestSetup { -- | The maximum lookahead in each era -- -- We record this separately because the chain might terminate early -- (we might not have reached all eras yet), but these parameters /are/ -- known for all eras (similar to how the HFC wants to know the era -- parameters for all eras) forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead testLookahead :: Exactly xs MaxLookahead -- | The test eras themselves , forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testEras :: NonEmpty xs TestEra -- | The forecast we're constructing , forall (xs :: [*]). TestSetup xs -> TestForecastParams testForecastParams :: TestForecastParams } type MaxLookahead = Word64 deriving instance Show (TestSetup xs) deriving instance Show (Some TestSetup) {------------------------------------------------------------------------------- Invariant -------------------------------------------------------------------------------} validForecastParams :: TestSetup xs -> Either String () validForecastParams :: forall (xs :: [*]). TestSetup xs -> Either TestName () validForecastParams setup :: TestSetup xs setup@TestSetup{NonEmpty xs TestEra Exactly xs MaxLookahead TestForecastParams testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams testLookahead :: Exactly xs MaxLookahead testEras :: NonEmpty xs TestEra testForecastParams :: TestForecastParams ..} = Except TestName () -> Either TestName () forall e a. Except e a -> Either e a runExcept (Except TestName () -> Either TestName ()) -> Except TestName () -> Either TestName () forall a b. (a -> b) -> a -> b $ do Bool -> Except TestName () -> Except TestName () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (WithOrigin SlotNo testForecastAt WithOrigin SlotNo -> WithOrigin SlotNo -> Bool forall a. Ord a => a -> a -> Bool <= SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo testForecastWithinEra) (Except TestName () -> Except TestName ()) -> Except TestName () -> Except TestName () forall a b. (a -> b) -> a -> b $ TestName -> Except TestName () forall a. TestName -> ExceptT TestName Identity a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (TestName -> Except TestName ()) -> TestName -> Except TestName () forall a b. (a -> b) -> a -> b $ [TestName] -> TestName forall a. Monoid a => [a] -> a mconcat [ TestName "'testForecastWithinEra' == " , SlotNo -> TestName forall a. Show a => a -> TestName show SlotNo testForecastWithinEra , TestName " not after 'testForecastAt' == " , WithOrigin SlotNo -> TestName forall a. Show a => a -> TestName show WithOrigin SlotNo testForecastAt ] Bool -> Except TestName () -> Except TestName () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (WithOrigin SlotNo testForecastAt WithOrigin SlotNo -> WithOrigin SlotNo -> Bool forall a. Ord a => a -> a -> Bool <= SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo testForecastAcrossEras) (Except TestName () -> Except TestName ()) -> Except TestName () -> Except TestName () forall a b. (a -> b) -> a -> b $ TestName -> Except TestName () forall a. TestName -> ExceptT TestName Identity a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (TestName -> Except TestName ()) -> TestName -> Except TestName () forall a b. (a -> b) -> a -> b $ [TestName] -> TestName forall a. Monoid a => [a] -> a mconcat [ TestName "'testForecastAcrossEras' == " , SlotNo -> TestName forall a. Show a => a -> TestName show SlotNo testForecastAcrossEras , TestName " not after 'testForecastAt' == " , WithOrigin SlotNo -> TestName forall a. Show a => a -> TestName show WithOrigin SlotNo testForecastAt ] TestEra era <- case TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra forall (xs :: [*]). TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra slotEra' TestSetup xs setup WithOrigin SlotNo testForecastAt of Just TestEra era -> TestEra -> ExceptT TestName Identity TestEra forall a. a -> ExceptT TestName Identity a forall (m :: * -> *) a. Monad m => a -> m a return TestEra era Maybe TestEra Nothing -> TestName -> ExceptT TestName Identity TestEra forall a. TestName -> ExceptT TestName Identity a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (TestName -> ExceptT TestName Identity TestEra) -> TestName -> ExceptT TestName Identity TestEra forall a b. (a -> b) -> a -> b $ [TestName] -> TestName forall a. Monoid a => [a] -> a mconcat [ TestName "No era known for 'testForecastAt' == " , WithOrigin SlotNo -> TestName forall a. Show a => a -> TestName show WithOrigin SlotNo testForecastAt ] Bool -> Except TestName () -> Except TestName () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (WithOrigin SlotNo -> TestEra -> Bool testEraContains (SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo testForecastWithinEra) TestEra era) (Except TestName () -> Except TestName ()) -> Except TestName () -> Except TestName () forall a b. (a -> b) -> a -> b $ TestName -> Except TestName () forall a. TestName -> ExceptT TestName Identity a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (TestName -> Except TestName ()) -> TestName -> Except TestName () forall a b. (a -> b) -> a -> b $ [TestName] -> TestName forall a. Monoid a => [a] -> a mconcat [ TestName "'testForecastWithinEra' == " , SlotNo -> TestName forall a. Show a => a -> TestName show SlotNo testForecastWithinEra , TestName " not in same era as 'testForecastAt' == " , WithOrigin SlotNo -> TestName forall a. Show a => a -> TestName show WithOrigin SlotNo testForecastAt ] case TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra forall (xs :: [*]). TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra slotEra' TestSetup xs setup (SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo testForecastAcrossEras) of Just TestEra _ -> () -> Except TestName () forall a. a -> ExceptT TestName Identity a forall (m :: * -> *) a. Monad m => a -> m a return () Maybe TestEra Nothing -> TestName -> Except TestName () forall a. TestName -> ExceptT TestName Identity a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (TestName -> Except TestName ()) -> TestName -> Except TestName () forall a b. (a -> b) -> a -> b $ [TestName] -> TestName forall a. Monoid a => [a] -> a mconcat [ TestName "No era known for 'testForecastAcrossEras' == " , SlotNo -> TestName forall a. Show a => a -> TestName show SlotNo testForecastAcrossEras ] -- It would be nice to check that the "across eras" isn't ahead by more than -- one era (but that's a little tricky to do right now so we omit this -- check). where TestForecastParams{WithOrigin SlotNo SlotNo testForecastAt :: TestForecastParams -> WithOrigin SlotNo testForecastWithinEra :: TestForecastParams -> SlotNo testForecastAcrossEras :: TestForecastParams -> SlotNo testForecastAt :: WithOrigin SlotNo testForecastWithinEra :: SlotNo testForecastAcrossEras :: SlotNo ..} = TestForecastParams testForecastParams {------------------------------------------------------------------------------- Query 'TestEra' -------------------------------------------------------------------------------} testEraContains :: WithOrigin SlotNo -> TestEra -> Bool testEraContains :: WithOrigin SlotNo -> TestEra -> Bool testEraContains WithOrigin SlotNo mSlot TestEra{[Block] MaxLookahead EraSummary testEraSummary :: TestEra -> EraSummary testEraMaxLookahead :: TestEra -> MaxLookahead testEraBlocks :: TestEra -> [Block] testEraSummary :: EraSummary testEraMaxLookahead :: MaxLookahead testEraBlocks :: [Block] ..} = [Bool] -> Bool forall (t :: * -> *). Foldable t => t Bool -> Bool and [ Bound -> SlotNo boundSlot Bound eraStart SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool <= SlotNo -> WithOrigin SlotNo -> SlotNo forall t. t -> WithOrigin t -> t fromWithOrigin (MaxLookahead -> SlotNo SlotNo MaxLookahead 0) WithOrigin SlotNo mSlot , case (WithOrigin SlotNo mSlot, EraEnd eraEnd) of (NotOrigin SlotNo s, EraEnd Bound end) -> SlotNo s SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool < Bound -> SlotNo boundSlot Bound end (WithOrigin SlotNo, EraEnd) _otherwise -> Bool True ] where EraSummary{EraParams EraEnd Bound eraStart :: EraSummary -> Bound eraEnd :: EraSummary -> EraEnd eraStart :: Bound eraEnd :: EraEnd eraParams :: EraParams eraParams :: EraSummary -> EraParams ..} = EraSummary testEraSummary {------------------------------------------------------------------------------- Query the 'TestSetup' -------------------------------------------------------------------------------} blocksPerEra :: TestSetup xs -> [[Block]] blocksPerEra :: forall (xs :: [*]). TestSetup xs -> [[Block]] blocksPerEra = (TestEra -> [Block]) -> [TestEra] -> [[Block]] forall a b. (a -> b) -> [a] -> [b] map TestEra -> [Block] testEraBlocks ([TestEra] -> [[Block]]) -> (TestSetup xs -> [TestEra]) -> TestSetup xs -> [[Block]] forall b c a. (b -> c) -> (a -> b) -> a -> c . NonEmpty xs TestEra -> [TestEra] forall a. NonEmpty xs a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList (NonEmpty xs TestEra -> [TestEra]) -> (TestSetup xs -> NonEmpty xs TestEra) -> TestSetup xs -> [TestEra] forall b c a. (b -> c) -> (a -> b) -> a -> c . TestSetup xs -> NonEmpty xs TestEra forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testEras -- | Era containing the given slot, if any slotEra' :: TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra slotEra' :: forall (xs :: [*]). TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra slotEra' TestSetup{NonEmpty xs TestEra Exactly xs MaxLookahead TestForecastParams testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams testLookahead :: Exactly xs MaxLookahead testEras :: NonEmpty xs TestEra testForecastParams :: TestForecastParams ..} WithOrigin SlotNo mSlot = [TestEra] -> Maybe TestEra forall a. [a] -> Maybe a listToMaybe ([TestEra] -> Maybe TestEra) -> [TestEra] -> Maybe TestEra forall a b. (a -> b) -> a -> b $ (TestEra -> Bool) -> [TestEra] -> [TestEra] forall a. (a -> Bool) -> [a] -> [a] filter (WithOrigin SlotNo -> TestEra -> Bool testEraContains WithOrigin SlotNo mSlot) (NonEmpty xs TestEra -> [TestEra] forall a. NonEmpty xs a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList NonEmpty xs TestEra testEras) -- | Wrapper around 'slotEra' to be used when the era should exist slotEra :: HasCallStack => TestSetup xs -> WithOrigin SlotNo -> TestEra slotEra :: forall (xs :: [*]). (?callStack::CallStack) => TestSetup xs -> WithOrigin SlotNo -> TestEra slotEra TestSetup xs setup WithOrigin SlotNo mSlot = case TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra forall (xs :: [*]). TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra slotEra' TestSetup xs setup WithOrigin SlotNo mSlot of Maybe TestEra Nothing -> TestName -> TestEra forall a. (?callStack::CallStack) => TestName -> a error (TestName -> TestEra) -> TestName -> TestEra forall a b. (a -> b) -> a -> b $ TestName "slotEra: unknown slot " TestName -> ShowS forall a. [a] -> [a] -> [a] ++ WithOrigin SlotNo -> TestName forall a. Show a => a -> TestName show WithOrigin SlotNo mSlot Just TestEra era -> TestEra era -- | Maximum lookahead of the ledger in the era containing the slot slotMaxLookahead :: TestSetup xs -> WithOrigin SlotNo -> MaxLookahead slotMaxLookahead :: forall (xs :: [*]). TestSetup xs -> WithOrigin SlotNo -> MaxLookahead slotMaxLookahead TestSetup xs setup = TestEra -> MaxLookahead testEraMaxLookahead (TestEra -> MaxLookahead) -> (WithOrigin SlotNo -> TestEra) -> WithOrigin SlotNo -> MaxLookahead forall b c a. (b -> c) -> (a -> b) -> a -> c . TestSetup xs -> WithOrigin SlotNo -> TestEra forall (xs :: [*]). (?callStack::CallStack) => TestSetup xs -> WithOrigin SlotNo -> TestEra slotEra TestSetup xs setup -- | Check if two slots are in the same era slotSameEra :: TestSetup xs -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool slotSameEra :: forall (xs :: [*]). TestSetup xs -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool slotSameEra TestSetup xs setup WithOrigin SlotNo otherSlot = WithOrigin SlotNo -> TestEra -> Bool testEraContains WithOrigin SlotNo otherSlot (TestEra -> Bool) -> (WithOrigin SlotNo -> TestEra) -> WithOrigin SlotNo -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . TestSetup xs -> WithOrigin SlotNo -> TestEra forall (xs :: [*]). (?callStack::CallStack) => TestSetup xs -> WithOrigin SlotNo -> TestEra slotEra TestSetup xs setup {------------------------------------------------------------------------------- Generator -------------------------------------------------------------------------------} instance Arbitrary (Some TestSetup) where arbitrary :: Gen (Some TestSetup) arbitrary = (forall (xs :: [*]). (SListI xs, IsNonEmpty xs) => Eras xs -> Gen (Some TestSetup)) -> Gen (Some TestSetup) forall r. (forall (xs :: [*]). (SListI xs, IsNonEmpty xs) => Eras xs -> Gen r) -> Gen r chooseEras ((forall (xs :: [*]). (SListI xs, IsNonEmpty xs) => Eras xs -> Gen (Some TestSetup)) -> Gen (Some TestSetup)) -> (forall (xs :: [*]). (SListI xs, IsNonEmpty xs) => Eras xs -> Gen (Some TestSetup)) -> Gen (Some TestSetup) forall a b. (a -> b) -> a -> b $ \Eras xs ixs -> do ProofNonEmpty{} <- ProofNonEmpty xs -> Gen (ProofNonEmpty xs) forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return (ProofNonEmpty xs -> Gen (ProofNonEmpty xs)) -> ProofNonEmpty xs -> Gen (ProofNonEmpty xs) forall a b. (a -> b) -> a -> b $ Eras xs -> ProofNonEmpty xs forall {a} (xs :: [a]) (proxy :: [a] -> *). IsNonEmpty xs => proxy xs -> ProofNonEmpty xs forall (proxy :: [*] -> *). proxy xs -> ProofNonEmpty xs isNonEmpty Eras xs ixs NonEmpty xs EraSummary summary <- Summary xs -> NonEmpty xs EraSummary forall (xs :: [*]). Summary xs -> NonEmpty xs EraSummary getSummary (Summary xs -> NonEmpty xs EraSummary) -> Gen (Summary xs) -> Gen (NonEmpty xs EraSummary) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Eras xs -> Gen (Summary xs) forall (xs :: [*]). Eras xs -> Gen (Summary xs) genSummary Eras xs ixs Exactly xs MaxLookahead lookahead <- NP (K Era) xs -> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead) forall era (xs :: [*]). NP (K era) xs -> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead) genMaxLookahead (Eras xs -> NP (K Era) xs forall (xs :: [*]). Eras xs -> NP (K Era) xs eraIndices Eras xs ixs) (NonEmpty xs EraSummary -> AtMost xs EraSummary forall (xs :: [*]) a. NonEmpty xs a -> AtMost xs a atMostFromNonEmpty NonEmpty xs EraSummary summary) NonEmpty xs TestEra eras <- NonEmpty xs (Gen TestEra) -> Gen (NonEmpty xs TestEra) forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) forall (m :: * -> *) a. Monad m => NonEmpty xs (m a) -> m (NonEmpty xs a) sequence (NonEmpty xs (Gen TestEra) -> Gen (NonEmpty xs TestEra)) -> NonEmpty xs (Gen TestEra) -> Gen (NonEmpty xs TestEra) forall a b. (a -> b) -> a -> b $ EraSummary -> MaxLookahead -> Gen TestEra genTestEra (EraSummary -> MaxLookahead -> Gen TestEra) -> NonEmpty xs EraSummary -> NonEmpty xs (MaxLookahead -> Gen TestEra) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> NonEmpty xs EraSummary summary NonEmpty xs (MaxLookahead -> Gen TestEra) -> NonEmpty xs MaxLookahead -> NonEmpty xs (Gen TestEra) forall a b. NonEmpty xs (a -> b) -> NonEmpty xs a -> NonEmpty xs b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Exactly (x : xs1) MaxLookahead -> NonEmpty (x : xs1) MaxLookahead forall x (xs :: [*]) a. Exactly (x : xs) a -> NonEmpty (x : xs) a exactlyWeakenNonEmpty Exactly xs MaxLookahead Exactly (x : xs1) MaxLookahead lookahead TestForecastParams forecast <- [TestEra] -> Gen TestForecastParams genForecastParams (NonEmpty xs TestEra -> [TestEra] forall a. NonEmpty xs a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList NonEmpty xs TestEra eras) Some TestSetup -> Gen (Some TestSetup) forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return (Some TestSetup -> Gen (Some TestSetup)) -> Some TestSetup -> Gen (Some TestSetup) forall a b. (a -> b) -> a -> b $ TestSetup xs -> Some TestSetup forall {k} (f :: k -> *) (a :: k). f a -> Some f Some TestSetup{ testLookahead :: Exactly xs MaxLookahead testLookahead = Exactly xs MaxLookahead lookahead , testEras :: NonEmpty xs TestEra testEras = NonEmpty xs TestEra eras , testForecastParams :: TestForecastParams testForecastParams = TestForecastParams forecast } where genMaxLookahead :: NP (K era) xs -> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead) genMaxLookahead :: forall era (xs :: [*]). NP (K era) xs -> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead) genMaxLookahead NP (K era) xs Nil AtMost xs EraSummary _ = Exactly xs MaxLookahead -> Gen (Exactly xs MaxLookahead) forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return Exactly xs MaxLookahead forall (xs :: [*]) a. (xs ~ '[]) => Exactly xs a ExactlyNil genMaxLookahead (K era x _ :* NP (K era) xs1 es) (AtMostCons EraSummary s AtMost xs1 EraSummary ss) = (MaxLookahead -> Gen (Exactly xs MaxLookahead)) -> Gen (Exactly xs MaxLookahead) forall a. (MaxLookahead -> Gen a) -> Gen a sized' ((MaxLookahead -> Gen (Exactly xs MaxLookahead)) -> Gen (Exactly xs MaxLookahead)) -> (MaxLookahead -> Gen (Exactly xs MaxLookahead)) -> Gen (Exactly xs MaxLookahead) forall a b. (a -> b) -> a -> b $ \MaxLookahead sz -> do MaxLookahead l <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead forall a. Random a => (a, a) -> Gen a choose (MaxLookahead 0, MaxLookahead sz) -- Suppose an era lasts 10 slots -- -- > ~ ~ -- > previous ~ 10 ... 19 ~ next -- > ~ ~ -- -- If the maximum lookahead is 0, then if we are the last block -- of the previous era, we can't even forecast the ledger state for -- slot 10. If it's 1, we can forecast to 10; if it's 10, we can -- forecast to 19; but if it's 11, we can forecast to 20, which is -- the /next next/ era. We don't currently support this, and so -- we avoid generating this edge case. let l' :: MaxLookahead l' = case EraSummary -> EraEnd eraEnd EraSummary s of EraEnd EraUnbounded -> MaxLookahead l EraEnd Bound end -> MaxLookahead -> MaxLookahead -> MaxLookahead forall a. Ord a => a -> a -> a min MaxLookahead l (MaxLookahead -> MaxLookahead) -> MaxLookahead -> MaxLookahead forall a b. (a -> b) -> a -> b $ (?callStack::CallStack) => SlotNo -> SlotNo -> MaxLookahead SlotNo -> SlotNo -> MaxLookahead countSlots (Bound -> SlotNo boundSlot Bound end) (Bound -> SlotNo boundSlot (EraSummary -> Bound eraStart EraSummary s)) Exactly xs1 MaxLookahead ls <- NP (K era) xs1 -> AtMost xs1 EraSummary -> Gen (Exactly xs1 MaxLookahead) forall era (xs :: [*]). NP (K era) xs -> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead) genMaxLookahead NP (K era) xs1 es AtMost xs1 EraSummary AtMost xs1 EraSummary ss Exactly xs MaxLookahead -> Gen (Exactly xs MaxLookahead) forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return (MaxLookahead -> Exactly xs1 MaxLookahead -> Exactly xs MaxLookahead forall (xs' :: [*]) a x (xs :: [*]). (xs' ~ (x : xs)) => a -> Exactly xs a -> Exactly xs' a ExactlyCons MaxLookahead l' Exactly xs1 MaxLookahead ls) genMaxLookahead (K era x _ :* NP (K era) xs1 es) AtMost xs EraSummary AtMostNil = (MaxLookahead -> Gen (Exactly xs MaxLookahead)) -> Gen (Exactly xs MaxLookahead) forall a. (MaxLookahead -> Gen a) -> Gen a sized' ((MaxLookahead -> Gen (Exactly xs MaxLookahead)) -> Gen (Exactly xs MaxLookahead)) -> (MaxLookahead -> Gen (Exactly xs MaxLookahead)) -> Gen (Exactly xs MaxLookahead) forall a b. (a -> b) -> a -> b $ \MaxLookahead sz -> do MaxLookahead l <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead forall a. Random a => (a, a) -> Gen a choose (MaxLookahead 0, MaxLookahead sz) Exactly xs1 MaxLookahead ls <- NP (K era) xs1 -> AtMost xs1 EraSummary -> Gen (Exactly xs1 MaxLookahead) forall era (xs :: [*]). NP (K era) xs -> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead) genMaxLookahead NP (K era) xs1 es AtMost xs1 EraSummary forall (xs :: [*]) a. AtMost xs a AtMostNil Exactly xs MaxLookahead -> Gen (Exactly xs MaxLookahead) forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return (MaxLookahead -> Exactly xs1 MaxLookahead -> Exactly xs MaxLookahead forall (xs' :: [*]) a x (xs :: [*]). (xs' ~ (x : xs)) => a -> Exactly xs a -> Exactly xs' a ExactlyCons MaxLookahead l Exactly xs1 MaxLookahead ls) genTestEra :: EraSummary -> MaxLookahead -> Gen TestEra genTestEra :: EraSummary -> MaxLookahead -> Gen TestEra genTestEra summary :: EraSummary summary@EraSummary{EraParams EraEnd Bound eraStart :: EraSummary -> Bound eraEnd :: EraSummary -> EraEnd eraParams :: EraSummary -> EraParams eraStart :: Bound eraEnd :: EraEnd eraParams :: EraParams ..} MaxLookahead maxLookahead = (MaxLookahead -> Gen TestEra) -> Gen TestEra forall a. (MaxLookahead -> Gen a) -> Gen a sized' ((MaxLookahead -> Gen TestEra) -> Gen TestEra) -> (MaxLookahead -> Gen TestEra) -> Gen TestEra forall a b. (a -> b) -> a -> b $ \MaxLookahead sz -> do Bound upperBound <- case EraEnd eraEnd of EraEnd Bound bound -> Bound -> Gen Bound forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return Bound bound EraEnd EraUnbounded -> EraParams -> Bound -> MaxLookahead -> Bound mkUpperBound EraParams eraParams Bound eraStart (MaxLookahead -> Bound) -> Gen MaxLookahead -> Gen Bound forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (MaxLookahead, MaxLookahead) -> Gen MaxLookahead forall a. Random a => (a, a) -> Gen a choose (MaxLookahead 0, MaxLookahead sz) [Maybe Block] mBlocks <- [SlotNo] -> (SlotNo -> Gen (Maybe Block)) -> Gen [Maybe Block] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM (SlotNo -> SlotNo -> [SlotNo] forall a. (Ord a, Enum a) => a -> a -> [a] enumIncExc (Bound -> SlotNo boundSlot Bound eraStart) (Bound -> SlotNo boundSlot Bound upperBound)) ((SlotNo -> Gen (Maybe Block)) -> Gen [Maybe Block]) -> (SlotNo -> Gen (Maybe Block)) -> Gen [Maybe Block] forall a b. (a -> b) -> a -> b $ \SlotNo slot -> do Bool slotFilled <- Gen Bool forall a. Arbitrary a => Gen a arbitrary if Bool slotFilled then do Scheduled scheduled <- MaxLookahead -> SlotNo -> Gen Scheduled genScheduled MaxLookahead maxLookahead SlotNo slot Maybe Block -> Gen (Maybe Block) forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return (Maybe Block -> Gen (Maybe Block)) -> Maybe Block -> Gen (Maybe Block) forall a b. (a -> b) -> a -> b $ Block -> Maybe Block forall a. a -> Maybe a Just (SlotNo -> Scheduled -> Block Block SlotNo slot Scheduled scheduled) else Maybe Block -> Gen (Maybe Block) forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return Maybe Block forall a. Maybe a Nothing TestEra -> Gen TestEra forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return TestEra { testEraSummary :: EraSummary testEraSummary = EraSummary summary , testEraMaxLookahead :: MaxLookahead testEraMaxLookahead = MaxLookahead maxLookahead , testEraBlocks :: [Block] testEraBlocks = [Maybe Block] -> [Block] forall a. [Maybe a] -> [a] catMaybes [Maybe Block] mBlocks } genScheduled :: MaxLookahead -> SlotNo -> Gen Scheduled genScheduled :: MaxLookahead -> SlotNo -> Gen Scheduled genScheduled MaxLookahead maxLookahead SlotNo slotBlock = do Int numChanges <- (Int, Int) -> Gen Int forall a. Random a => (a, a) -> Gen a choose (Int 0, Int 2) ([(SlotNo, LedgerUpdate)] -> Scheduled) -> Gen [(SlotNo, LedgerUpdate)] -> Gen Scheduled forall a b. (a -> b) -> Gen a -> Gen b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [(SlotNo, LedgerUpdate)] -> Scheduled forall k a. Ord k => [(k, a)] -> Map k a Map.fromList (Gen [(SlotNo, LedgerUpdate)] -> Gen Scheduled) -> Gen [(SlotNo, LedgerUpdate)] -> Gen Scheduled forall a b. (a -> b) -> a -> b $ Int -> Gen (SlotNo, LedgerUpdate) -> Gen [(SlotNo, LedgerUpdate)] forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a] replicateM Int numChanges (Gen (SlotNo, LedgerUpdate) -> Gen [(SlotNo, LedgerUpdate)]) -> Gen (SlotNo, LedgerUpdate) -> Gen [(SlotNo, LedgerUpdate)] forall a b. (a -> b) -> a -> b $ MaxLookahead -> SlotNo -> Gen (SlotNo, LedgerUpdate) genChange MaxLookahead maxLookahead SlotNo slotBlock genChange :: MaxLookahead -> SlotNo -> Gen (SlotNo, LedgerUpdate) genChange :: MaxLookahead -> SlotNo -> Gen (SlotNo, LedgerUpdate) genChange MaxLookahead maxLookahead SlotNo slotBlock = (MaxLookahead -> Gen (SlotNo, LedgerUpdate)) -> Gen (SlotNo, LedgerUpdate) forall a. (MaxLookahead -> Gen a) -> Gen a sized' ((MaxLookahead -> Gen (SlotNo, LedgerUpdate)) -> Gen (SlotNo, LedgerUpdate)) -> (MaxLookahead -> Gen (SlotNo, LedgerUpdate)) -> Gen (SlotNo, LedgerUpdate) forall a b. (a -> b) -> a -> b $ \MaxLookahead sz -> do MaxLookahead skip <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead forall a. Random a => (a, a) -> Gen a choose (MaxLookahead 0, MaxLookahead sz) MaxLookahead increase <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead forall a. Random a => (a, a) -> Gen a choose (MaxLookahead 0, MaxLookahead 2) -- If the maxLookahead is zero (no look ahead possible), the change -- is applied when we apply the block (i.e., in the same slot). let slotChange :: SlotNo slotChange = MaxLookahead -> SlotNo -> SlotNo addSlots (MaxLookahead maxLookahead MaxLookahead -> MaxLookahead -> MaxLookahead forall a. Num a => a -> a -> a + MaxLookahead skip) SlotNo slotBlock (SlotNo, LedgerUpdate) -> Gen (SlotNo, LedgerUpdate) forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return (SlotNo slotChange, MaxLookahead -> LedgerUpdate IncreaseValueBy MaxLookahead increase) -- Construct an upper bound for an era, given number of epochs mkUpperBound :: EraParams -> Bound -> Word64 -> Bound mkUpperBound :: EraParams -> Bound -> MaxLookahead -> Bound mkUpperBound EraParams eraParams Bound eraStart = (?callStack::CallStack) => EraParams -> Bound -> EpochNo -> Bound EraParams -> Bound -> EpochNo -> Bound History.mkUpperBound EraParams eraParams Bound eraStart (EpochNo -> Bound) -> (MaxLookahead -> EpochNo) -> MaxLookahead -> Bound forall b c a. (b -> c) -> (a -> b) -> a -> c . (MaxLookahead -> EpochNo -> EpochNo) -> EpochNo -> MaxLookahead -> EpochNo forall a b c. (a -> b -> c) -> b -> a -> c flip MaxLookahead -> EpochNo -> EpochNo addEpochs (Bound -> EpochNo boundEpoch Bound eraStart) genForecastParams :: [TestEra] -> Gen TestForecastParams genForecastParams :: [TestEra] -> Gen TestForecastParams genForecastParams [TestEra] eras = (MaxLookahead -> Gen TestForecastParams) -> Gen TestForecastParams forall a. (MaxLookahead -> Gen a) -> Gen a sized' ((MaxLookahead -> Gen TestForecastParams) -> Gen TestForecastParams) -> (MaxLookahead -> Gen TestForecastParams) -> Gen TestForecastParams forall a b. (a -> b) -> a -> b $ \MaxLookahead sz -> do -- Pick an era for the forecast (Bool isFirstEra, TestEra anchorEra) <- [(Bool, TestEra)] -> Gen (Bool, TestEra) forall a. (?callStack::CallStack) => [a] -> Gen a elements ([(Bool, TestEra)] -> Gen (Bool, TestEra)) -> [(Bool, TestEra)] -> Gen (Bool, TestEra) forall a b. (a -> b) -> a -> b $ [Bool] -> [TestEra] -> [(Bool, TestEra)] forall a b. [a] -> [b] -> [(a, b)] zip (Bool True Bool -> [Bool] -> [Bool] forall a. a -> [a] -> [a] : Bool -> [Bool] forall a. a -> [a] repeat Bool False) [TestEra] eras let anchorEraStart :: Bound anchorEraStart = EraSummary -> Bound eraStart (EraSummary -> Bound) -> EraSummary -> Bound forall a b. (a -> b) -> a -> b $ TestEra -> EraSummary testEraSummary TestEra anchorEra anchorEraEnd :: EraEnd anchorEraEnd = EraSummary -> EraEnd eraEnd (EraSummary -> EraEnd) -> EraSummary -> EraEnd forall a b. (a -> b) -> a -> b $ TestEra -> EraSummary testEraSummary TestEra anchorEra -- Pick an anchor WithOrigin SlotNo at <- [Gen (WithOrigin SlotNo)] -> Gen (WithOrigin SlotNo) forall a. [Gen a] -> Gen a oneof ([Gen (WithOrigin SlotNo)] -> Gen (WithOrigin SlotNo)) -> [Gen (WithOrigin SlotNo)] -> Gen (WithOrigin SlotNo) forall a b. (a -> b) -> a -> b $ [[Gen (WithOrigin SlotNo)]] -> [Gen (WithOrigin SlotNo)] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ [ (SlotNo -> WithOrigin SlotNo) -> Gen SlotNo -> Gen (WithOrigin SlotNo) forall a b. (a -> b) -> Gen a -> Gen b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin (Gen SlotNo -> Gen (WithOrigin SlotNo)) -> Gen SlotNo -> Gen (WithOrigin SlotNo) forall a b. (a -> b) -> a -> b $ [SlotNo] -> Gen SlotNo forall a. (?callStack::CallStack) => [a] -> Gen a elements ([SlotNo] -> Gen SlotNo) -> [SlotNo] -> Gen SlotNo forall a b. (a -> b) -> a -> b $ SlotNo -> SlotNo -> [SlotNo] forall a. (Ord a, Enum a) => a -> a -> [a] enumIncExc (Bound -> SlotNo boundSlot Bound anchorEraStart) (Bound -> SlotNo boundSlot Bound end) | EraEnd Bound end <- [EraEnd anchorEraEnd] ] , [ do MaxLookahead upperBound <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead forall a. Random a => (a, a) -> Gen a choose (MaxLookahead 1, MaxLookahead 1 MaxLookahead -> MaxLookahead -> MaxLookahead forall a. Num a => a -> a -> a + MaxLookahead sz) -- upper bound is exclusive (SlotNo -> WithOrigin SlotNo) -> Gen SlotNo -> Gen (WithOrigin SlotNo) forall a b. (a -> b) -> Gen a -> Gen b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin (Gen SlotNo -> Gen (WithOrigin SlotNo)) -> Gen SlotNo -> Gen (WithOrigin SlotNo) forall a b. (a -> b) -> a -> b $ [SlotNo] -> Gen SlotNo forall a. (?callStack::CallStack) => [a] -> Gen a elements ([SlotNo] -> Gen SlotNo) -> [SlotNo] -> Gen SlotNo forall a b. (a -> b) -> a -> b $ SlotNo -> SlotNo -> [SlotNo] forall a. (Ord a, Enum a) => a -> a -> [a] enumIncExc (Bound -> SlotNo boundSlot Bound anchorEraStart) (MaxLookahead -> SlotNo -> SlotNo addSlots MaxLookahead upperBound (Bound -> SlotNo boundSlot Bound anchorEraStart)) | EraEnd EraUnbounded <- [EraEnd anchorEraEnd] ] , [ WithOrigin SlotNo -> Gen (WithOrigin SlotNo) forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return WithOrigin SlotNo forall t. WithOrigin t Origin | Bool isFirstEra ] ] -- Pick a slot within the same era -- (for within-era forecast sanity check) let at' :: SlotNo at' = SlotNo -> WithOrigin SlotNo -> SlotNo forall t. t -> WithOrigin t -> t fromWithOrigin (MaxLookahead -> SlotNo SlotNo MaxLookahead 0) WithOrigin SlotNo at SlotNo withinEra <- SlotNo -> EraEnd -> Gen SlotNo pickSlotBetween SlotNo at' EraEnd anchorEraEnd -- For any slot after the anchor let finalEra :: TestEra finalEra = [TestEra] -> TestEra forall a. (?callStack::CallStack) => [a] -> a last [TestEra] eras finalEraEnd :: EraEnd finalEraEnd = EraSummary -> EraEnd eraEnd (EraSummary -> EraEnd) -> EraSummary -> EraEnd forall a b. (a -> b) -> a -> b $ TestEra -> EraSummary testEraSummary TestEra finalEra SlotNo acrossEras <- SlotNo -> EraEnd -> Gen SlotNo pickSlotBetween SlotNo at' EraEnd finalEraEnd TestForecastParams -> Gen TestForecastParams forall a. a -> Gen a forall (m :: * -> *) a. Monad m => a -> m a return TestForecastParams { testForecastAt :: WithOrigin SlotNo testForecastAt = WithOrigin SlotNo at , testForecastWithinEra :: SlotNo testForecastWithinEra = SlotNo withinEra , testForecastAcrossEras :: SlotNo testForecastAcrossEras = SlotNo acrossEras } pickSlotBetween :: SlotNo -> EraEnd -> Gen SlotNo pickSlotBetween :: SlotNo -> EraEnd -> Gen SlotNo pickSlotBetween SlotNo lo EraEnd hi = (MaxLookahead -> Gen SlotNo) -> Gen SlotNo forall a. (MaxLookahead -> Gen a) -> Gen a sized' ((MaxLookahead -> Gen SlotNo) -> Gen SlotNo) -> (MaxLookahead -> Gen SlotNo) -> Gen SlotNo forall a b. (a -> b) -> a -> b $ \MaxLookahead sz -> [Gen SlotNo] -> Gen SlotNo forall a. [Gen a] -> Gen a oneof ([Gen SlotNo] -> Gen SlotNo) -> [Gen SlotNo] -> Gen SlotNo forall a b. (a -> b) -> a -> b $ [[Gen SlotNo]] -> [Gen SlotNo] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ [ [SlotNo] -> Gen SlotNo forall a. (?callStack::CallStack) => [a] -> Gen a elements ([SlotNo] -> Gen SlotNo) -> [SlotNo] -> Gen SlotNo forall a b. (a -> b) -> a -> b $ SlotNo -> SlotNo -> [SlotNo] forall a. (Ord a, Enum a) => a -> a -> [a] enumIncExc SlotNo lo (Bound -> SlotNo boundSlot Bound end) | EraEnd Bound end <- [EraEnd hi] ] , [ do MaxLookahead upperBound <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead forall a. Random a => (a, a) -> Gen a choose (MaxLookahead 1, MaxLookahead 1 MaxLookahead -> MaxLookahead -> MaxLookahead forall a. Num a => a -> a -> a + MaxLookahead sz) -- upper bound is exclusive [SlotNo] -> Gen SlotNo forall a. (?callStack::CallStack) => [a] -> Gen a elements ([SlotNo] -> Gen SlotNo) -> [SlotNo] -> Gen SlotNo forall a b. (a -> b) -> a -> b $ SlotNo -> SlotNo -> [SlotNo] forall a. (Ord a, Enum a) => a -> a -> [a] enumIncExc SlotNo lo (MaxLookahead -> SlotNo -> SlotNo addSlots MaxLookahead upperBound SlotNo lo) | EraEnd EraUnbounded <- [EraEnd hi] ] ] -- We make some effort towards a good shrinker, but there is a lot we could -- still do to improve it: -- -- o We could drop some eras entirely -- o We could shift the era bounds -- o We could shrink the maximum lookahead in the individual eras -- -- The tricky part is to do this without violating some of the invariants -- that we established in the generator: -- -- o The era of the forecast anchor might not exist anymore -- o Due to reducing the bounds of an era, the within-era 'at' might not -- actually be within-era anymore -- o Due to a reduction in the max lookahead, a forecast might now exceed the -- maximum. -- o Due to shrinking an era's size, the lookahead might now exceed the -- era length (see comment above regarding forecasting across multiple eras) -- o By shrinking the anchor of the forecast, it might not be in the same era -- as the within-era 'at' anymore. shrink :: Some TestSetup -> [Some TestSetup] shrink (Some setup :: TestSetup a setup@TestSetup{NonEmpty a TestEra Exactly a MaxLookahead TestForecastParams testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams testLookahead :: Exactly a MaxLookahead testEras :: NonEmpty a TestEra testForecastParams :: TestForecastParams ..}) = [[Some TestSetup]] -> [Some TestSetup] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ -- Shrink the eras [ TestSetup a -> Some TestSetup forall {k} (f :: k -> *) (a :: k). f a -> Some f Some TestSetup a setup' | NonEmpty a TestEra eras' <- NonEmpty a TestEra -> [NonEmpty a TestEra] forall (xs :: [*]). NonEmpty xs TestEra -> [NonEmpty xs TestEra] shrinkEras NonEmpty a TestEra testEras , let setup' :: TestSetup a setup' = TestSetup a setup { testEras = eras' } ] -- Shrink the forecast params , [ TestSetup a -> Some TestSetup forall {k} (f :: k -> *) (a :: k). f a -> Some f Some TestSetup a setup' | TestForecastParams params' <- TestForecastParams -> [TestForecastParams] shrinkForecastParams TestForecastParams testForecastParams , let setup' :: TestSetup a setup' = TestSetup a setup { testForecastParams = params' } ] ] where shrinkEras :: NonEmpty xs TestEra -> [NonEmpty xs TestEra] shrinkEras :: forall (xs :: [*]). NonEmpty xs TestEra -> [NonEmpty xs TestEra] shrinkEras NonEmpty xs TestEra eras = [[NonEmpty xs TestEra]] -> [NonEmpty xs TestEra] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ -- Shrink one era (TestEra -> [TestEra]) -> NonEmpty xs TestEra -> [NonEmpty xs TestEra] forall (m :: * -> *) (xs :: [*]) a. Alternative m => (a -> m a) -> NonEmpty xs a -> m (NonEmpty xs a) nonEmptyMapOne TestEra -> [TestEra] shrinkEra NonEmpty xs TestEra eras ] shrinkEra :: TestEra -> [TestEra] shrinkEra :: TestEra -> [TestEra] shrinkEra era :: TestEra era@TestEra{[Block] MaxLookahead EraSummary testEraSummary :: TestEra -> EraSummary testEraMaxLookahead :: TestEra -> MaxLookahead testEraBlocks :: TestEra -> [Block] testEraSummary :: EraSummary testEraMaxLookahead :: MaxLookahead testEraBlocks :: [Block] ..} = [[TestEra]] -> [TestEra] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ -- Drop some blocks [ TestEra era' | [Block] blocks' <- (Block -> [Block]) -> [Block] -> [[Block]] forall a. (a -> [a]) -> [a] -> [[a]] shrinkList ([Block] -> Block -> [Block] forall a b. a -> b -> a const []) [Block] testEraBlocks , let era' :: TestEra era' = TestEra era { testEraBlocks = blocks' } ] -- Shrink blocks -- -- We don't use shrinkList for this, because we need some context , [ TestEra era' | ([Block] xs, Block y, [Block] zs) <- [Block] -> [([Block], Block, [Block])] forall a. [a] -> [([a], a, [a])] splits [Block] testEraBlocks , let prev :: Maybe Block prev | [Block] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Block] xs = Maybe Block forall a. Maybe a Nothing | Bool otherwise = Block -> Maybe Block forall a. a -> Maybe a Just ([Block] -> Block forall a. (?callStack::CallStack) => [a] -> a last [Block] xs) , Block y' <- EraSummary -> MaxLookahead -> Maybe Block -> Block -> [Block] shrinkBlock EraSummary testEraSummary MaxLookahead testEraMaxLookahead Maybe Block prev Block y , let era' :: TestEra era' = TestEra era { testEraBlocks = xs ++ [y'] ++ zs } ] ] shrinkBlock :: EraSummary -> MaxLookahead -> Maybe Block -> Block -> [Block] shrinkBlock :: EraSummary -> MaxLookahead -> Maybe Block -> Block -> [Block] shrinkBlock EraSummary summary MaxLookahead maxLookahead Maybe Block mPrev (Block (SlotNo MaxLookahead slot) Scheduled scheduled) = [[Block]] -> [Block] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ -- Move the block earlier into the era -- -- NOTE: Moving a block _earlier_ into the chain can't violate -- the max-lookahead, as the distance between the block and the -- change can only _increase_ [ SlotNo -> Scheduled -> Block Block SlotNo slot' Scheduled scheduled | SlotNo slot' <- (MaxLookahead -> SlotNo) -> [MaxLookahead] -> [SlotNo] forall a b. (a -> b) -> [a] -> [b] map MaxLookahead -> SlotNo SlotNo ([MaxLookahead] -> [SlotNo]) -> [MaxLookahead] -> [SlotNo] forall a b. (a -> b) -> a -> b $ MaxLookahead -> [MaxLookahead] forall a. Arbitrary a => a -> [a] shrink MaxLookahead slot -- Don't clash with the previous block , case Maybe Block mPrev of Just (Block SlotNo prevSlot Scheduled _) -> SlotNo slot' SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool > SlotNo prevSlot Maybe Block Nothing -> Bool True -- Don't move block out of this era , SlotNo slot' SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool >= Bound -> SlotNo boundSlot (EraSummary -> Bound eraStart EraSummary summary) ] -- Shrink the block body , [ SlotNo -> Scheduled -> Block Block (MaxLookahead -> SlotNo SlotNo MaxLookahead slot) Scheduled scheduled' | Scheduled scheduled' <- MaxLookahead -> SlotNo -> Scheduled -> [Scheduled] shrinkScheduled MaxLookahead maxLookahead (MaxLookahead -> SlotNo SlotNo MaxLookahead slot) Scheduled scheduled ] ] shrinkScheduled :: MaxLookahead -> SlotNo -> Scheduled -> [Scheduled] shrinkScheduled :: MaxLookahead -> SlotNo -> Scheduled -> [Scheduled] shrinkScheduled MaxLookahead maxLookahead SlotNo slotBlock = ([(SlotNo, LedgerUpdate)] -> Scheduled) -> [[(SlotNo, LedgerUpdate)]] -> [Scheduled] forall a b. (a -> b) -> [a] -> [b] map [(SlotNo, LedgerUpdate)] -> Scheduled forall k a. Ord k => [(k, a)] -> Map k a Map.fromList ([[(SlotNo, LedgerUpdate)]] -> [Scheduled]) -> (Scheduled -> [[(SlotNo, LedgerUpdate)]]) -> Scheduled -> [Scheduled] forall b c a. (b -> c) -> (a -> b) -> a -> c . ((SlotNo, LedgerUpdate) -> [(SlotNo, LedgerUpdate)]) -> [(SlotNo, LedgerUpdate)] -> [[(SlotNo, LedgerUpdate)]] forall a. (a -> [a]) -> [a] -> [[a]] shrinkList (SlotNo, LedgerUpdate) -> [(SlotNo, LedgerUpdate)] shrinkUpdate ([(SlotNo, LedgerUpdate)] -> [[(SlotNo, LedgerUpdate)]]) -> (Scheduled -> [(SlotNo, LedgerUpdate)]) -> Scheduled -> [[(SlotNo, LedgerUpdate)]] forall b c a. (b -> c) -> (a -> b) -> a -> c . Scheduled -> [(SlotNo, LedgerUpdate)] forall k a. Map k a -> [(k, a)] Map.toList where shrinkUpdate :: (SlotNo, LedgerUpdate) -> [(SlotNo, LedgerUpdate)] shrinkUpdate :: (SlotNo, LedgerUpdate) -> [(SlotNo, LedgerUpdate)] shrinkUpdate (SlotNo MaxLookahead slotUpdate, update :: LedgerUpdate update@(IncreaseValueBy MaxLookahead newLedgerValue)) = [[(SlotNo, LedgerUpdate)]] -> [(SlotNo, LedgerUpdate)] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ -- Shrink the ledger value (complicated ledger values distract) [ (MaxLookahead -> SlotNo SlotNo MaxLookahead slotUpdate, MaxLookahead -> LedgerUpdate IncreaseValueBy MaxLookahead newLedgerValue') | MaxLookahead newLedgerValue' <- MaxLookahead -> [MaxLookahead] forall a. Arbitrary a => a -> [a] shrink MaxLookahead newLedgerValue ] -- Try to do the update sooner , [ (SlotNo slotUpdate', LedgerUpdate update) | SlotNo slotUpdate' <- (MaxLookahead -> SlotNo) -> [MaxLookahead] -> [SlotNo] forall a b. (a -> b) -> [a] -> [b] map MaxLookahead -> SlotNo SlotNo ([MaxLookahead] -> [SlotNo]) -> [MaxLookahead] -> [SlotNo] forall a b. (a -> b) -> a -> b $ MaxLookahead -> [MaxLookahead] forall a. Arbitrary a => a -> [a] shrink MaxLookahead slotUpdate -- The earliest it can change is the very next slot , SlotNo slotUpdate' SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool > SlotNo slotBlock -- We must still obey the maxLookahead though , (?callStack::CallStack) => SlotNo -> SlotNo -> MaxLookahead SlotNo -> SlotNo -> MaxLookahead countSlots SlotNo slotUpdate' SlotNo slotBlock MaxLookahead -> MaxLookahead -> Bool forall a. Ord a => a -> a -> Bool > MaxLookahead maxLookahead ] ] shrinkForecastParams :: TestForecastParams -> [TestForecastParams] shrinkForecastParams :: TestForecastParams -> [TestForecastParams] shrinkForecastParams params :: TestForecastParams params@TestForecastParams{WithOrigin SlotNo SlotNo testForecastAt :: TestForecastParams -> WithOrigin SlotNo testForecastWithinEra :: TestForecastParams -> SlotNo testForecastAcrossEras :: TestForecastParams -> SlotNo testForecastAt :: WithOrigin SlotNo testForecastWithinEra :: SlotNo testForecastAcrossEras :: SlotNo ..} = [[TestForecastParams]] -> [TestForecastParams] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ [ TestForecastParams params' | WithOrigin SlotNo at' <- WithOrigin SlotNo -> [WithOrigin SlotNo] shrinkSlotNo' WithOrigin SlotNo testForecastAt , TestSetup a -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool forall (xs :: [*]). TestSetup xs -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool slotSameEra TestSetup a setup WithOrigin SlotNo at' (SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo testForecastWithinEra) , let params' :: TestForecastParams params' = TestForecastParams params { testForecastAt = at' } ] , [ TestForecastParams params' | SlotNo withinEra' <- SlotNo -> [SlotNo] shrinkSlotNo SlotNo testForecastWithinEra , SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo withinEra' WithOrigin SlotNo -> WithOrigin SlotNo -> Bool forall a. Ord a => a -> a -> Bool >= WithOrigin SlotNo testForecastAt , let params' :: TestForecastParams params' = TestForecastParams params { testForecastWithinEra = withinEra' } ] , [ TestForecastParams params' | SlotNo acrossEras' <- SlotNo -> [SlotNo] shrinkSlotNo SlotNo testForecastAcrossEras , SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin SlotNo acrossEras' WithOrigin SlotNo -> WithOrigin SlotNo -> Bool forall a. Ord a => a -> a -> Bool >= WithOrigin SlotNo testForecastAt , let params' :: TestForecastParams params' = TestForecastParams params { testForecastAcrossEras = acrossEras' } ] ] shrinkSlotNo' :: WithOrigin SlotNo -> [WithOrigin SlotNo] shrinkSlotNo' :: WithOrigin SlotNo -> [WithOrigin SlotNo] shrinkSlotNo' WithOrigin SlotNo Origin = [] shrinkSlotNo' (NotOrigin SlotNo s) = WithOrigin SlotNo forall t. WithOrigin t Origin WithOrigin SlotNo -> [WithOrigin SlotNo] -> [WithOrigin SlotNo] forall a. a -> [a] -> [a] : (SlotNo -> WithOrigin SlotNo) -> [SlotNo] -> [WithOrigin SlotNo] forall a b. (a -> b) -> [a] -> [b] map SlotNo -> WithOrigin SlotNo forall t. t -> WithOrigin t NotOrigin (SlotNo -> [SlotNo] shrinkSlotNo SlotNo s) shrinkSlotNo :: SlotNo -> [SlotNo] shrinkSlotNo :: SlotNo -> [SlotNo] shrinkSlotNo (SlotNo MaxLookahead s) = (MaxLookahead -> SlotNo) -> [MaxLookahead] -> [SlotNo] forall a b. (a -> b) -> [a] -> [b] map MaxLookahead -> SlotNo SlotNo (MaxLookahead -> [MaxLookahead] forall a. Arbitrary a => a -> [a] shrink MaxLookahead s) {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} -- | Like 'enumFromTo', but with an exclusive upper bound enumIncExc :: forall a. (Ord a, Enum a) => a -> a -> [a] enumIncExc :: forall a. (Ord a, Enum a) => a -> a -> [a] enumIncExc a lo a hi = a -> [a] go a lo where go :: a -> [a] go :: a -> [a] go a x | a x a -> a -> Bool forall a. Ord a => a -> a -> Bool >= a hi = [] | Bool otherwise = a x a -> [a] -> [a] forall a. a -> [a] -> [a] : a -> [a] go (a -> a forall a. Enum a => a -> a succ a x) sized' :: (Word64 -> Gen a) -> Gen a sized' :: forall a. (MaxLookahead -> Gen a) -> Gen a sized' MaxLookahead -> Gen a f = (Int -> Gen a) -> Gen a forall a. (Int -> Gen a) -> Gen a sized (MaxLookahead -> Gen a f (MaxLookahead -> Gen a) -> (Int -> MaxLookahead) -> Int -> Gen a forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> MaxLookahead forall a b. (Integral a, Num b) => a -> b fromIntegral) mapAt :: (HasCallStack, Show k, Show a, Ord k) => Map k a -> k -> a Map k a m mapAt :: forall k a. (?callStack::CallStack, Show k, Show a, Ord k) => Map k a -> k -> a `mapAt` k k = a -> k -> Map k a -> a forall k a. Ord k => a -> k -> Map k a -> a Map.findWithDefault (TestName -> a forall a. (?callStack::CallStack) => TestName -> a error (TestName -> a) -> TestName -> a forall a b. (a -> b) -> a -> b $ [TestName] -> TestName forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ TestName "at: key " , k -> TestName forall a. Show a => a -> TestName show k k , TestName " not found in " , Map k a -> TestName forall a. Show a => a -> TestName show Map k a m ]) k k Map k a m