{-# 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
, 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
]
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)
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
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
}
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)
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)
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
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
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
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)
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
-> MaxLookahead
-> 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
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
}
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
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
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 ->
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
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)
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
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
-> LedgerState
-> [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
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
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
data TestEra = TestEra {
TestEra -> EraSummary
testEraSummary :: EraSummary
, TestEra -> MaxLookahead
testEraMaxLookahead :: MaxLookahead
, 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)
data TestForecastParams = TestForecastParams {
TestForecastParams -> WithOrigin SlotNo
testForecastAt :: WithOrigin SlotNo
, TestForecastParams -> SlotNo
testForecastWithinEra :: SlotNo
, 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 {
forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testLookahead :: Exactly xs MaxLookahead
, forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testEras :: NonEmpty xs TestEra
, forall (xs :: [*]). TestSetup xs -> TestForecastParams
testForecastParams :: TestForecastParams
}
type MaxLookahead = Word64
deriving instance Show (TestSetup xs)
deriving instance Show (Some TestSetup)
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
]
where
TestForecastParams{WithOrigin SlotNo
SlotNo
testForecastAt :: TestForecastParams -> WithOrigin SlotNo
testForecastWithinEra :: TestForecastParams -> SlotNo
testForecastAcrossEras :: TestForecastParams -> SlotNo
testForecastAt :: WithOrigin SlotNo
testForecastWithinEra :: SlotNo
testForecastAcrossEras :: SlotNo
..} = TestForecastParams
testForecastParams
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
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
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)
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
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
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
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)
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)
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)
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
(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
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)
(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
]
]
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
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)
[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]
]
]
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 [
[ 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' }
]
, [ 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 [
(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 [
[ 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' }
]
, [ 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 [
[ 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
, 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
, SlotNo
slot' SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= Bound -> SlotNo
boundSlot (EraSummary -> Bound
eraStart EraSummary
summary)
]
, [ 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 [
[ (MaxLookahead -> SlotNo
SlotNo MaxLookahead
slotUpdate, MaxLookahead -> LedgerUpdate
IncreaseValueBy MaxLookahead
newLedgerValue')
| MaxLookahead
newLedgerValue' <- MaxLookahead -> [MaxLookahead]
forall a. Arbitrary a => a -> [a]
shrink MaxLookahead
newLedgerValue
]
, [ (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
, SlotNo
slotUpdate' SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
slotBlock
, (?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)
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