{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Test.Consensus.HardFork.Forecast (
    tests
    -- Quell ghc warning
  , LedgerView (..)
  ) where

import           Control.Exception (assert)
import           Control.Monad (forM, replicateM, unless, when)
import           Control.Monad.Except (Except, runExcept, throwError)
import           Data.Either (isRight)
import           Data.Foldable (toList)
import           Data.List (intercalate)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (catMaybes, listToMaybe)
import           Data.SOP.BasicFunctors
import           Data.SOP.Counting
import           Data.SOP.InPairs (InPairs (..))
import qualified Data.SOP.InPairs as InPairs
import           Data.SOP.NonEmpty
import           Data.SOP.Sing
import           Data.SOP.Strict
import           Data.SOP.Telescope (Telescope (..))
import           Data.Word
import           GHC.Stack
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Forecast
import           Ouroboros.Consensus.HardFork.Combinator.Ledger
                     (AnnForecast (..), mkHardForkForecast)
import           Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView
import           Ouroboros.Consensus.HardFork.Combinator.State.Types
import           Ouroboros.Consensus.HardFork.History (Bound (..), EraEnd (..),
                     EraParams (..), EraSummary (..), Summary (..))
import qualified Ouroboros.Consensus.HardFork.History as History
import           Ouroboros.Consensus.HardFork.History.Util
import           Ouroboros.Consensus.Util (Some (..), repeatedly, splits)
import           Test.Consensus.HardFork.Infra
import           Test.QuickCheck hiding (elements)
import           Test.Tasty
import           Test.Tasty.QuickCheck hiding (elements)
import           Test.Util.QuickCheck

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Forecast" [
      TestName -> [TestTree] -> TestTree
testGroup TestName
"Sanity" [
          TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"generator" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ (Some TestSetup -> Property) -> Property
forall a. (Arbitrary a, Show a) => (a -> Property) -> Property
checkGenerator Some TestSetup -> Property
prop_validTestSetup
        , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrinker"  (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ (Some TestSetup -> Property) -> Property
forall a. (Arbitrary a, Show a) => (a -> Property) -> Property
checkShrinker  Some TestSetup -> Property
prop_validTestSetup
        ]
    , TestName -> (Bool -> Some TestSetup -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"forecast" ((Bool -> Some TestSetup -> Property) -> TestTree)
-> (Bool -> Some TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ Bool -> Some TestSetup -> Property
prop_forecast
    ]

{-------------------------------------------------------------------------------
  Mock chain and ledger
-------------------------------------------------------------------------------}

newtype Chain era = Chain { forall era. Chain era -> [Block]
getBlocks :: [Block] }
  deriving (Int -> Chain era -> ShowS
[Chain era] -> ShowS
Chain era -> TestName
(Int -> Chain era -> ShowS)
-> (Chain era -> TestName)
-> ([Chain era] -> ShowS)
-> Show (Chain era)
forall era. Int -> Chain era -> ShowS
forall era. [Chain era] -> ShowS
forall era. Chain era -> TestName
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. Int -> Chain era -> ShowS
showsPrec :: Int -> Chain era -> ShowS
$cshow :: forall era. Chain era -> TestName
show :: Chain era -> TestName
$cshowList :: forall era. [Chain era] -> ShowS
showList :: [Chain era] -> ShowS
Show)

data Block = Block SlotNo Scheduled
  deriving (Int -> Block -> ShowS
[Block] -> ShowS
Block -> TestName
(Int -> Block -> ShowS)
-> (Block -> TestName) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Block -> ShowS
showsPrec :: Int -> Block -> ShowS
$cshow :: Block -> TestName
show :: Block -> TestName
$cshowList :: [Block] -> ShowS
showList :: [Block] -> ShowS
Show)

type Scheduled = Map SlotNo LedgerUpdate

newtype LedgerUpdate = IncreaseValueBy Word64
  deriving (Int -> LedgerUpdate -> ShowS
[LedgerUpdate] -> ShowS
LedgerUpdate -> TestName
(Int -> LedgerUpdate -> ShowS)
-> (LedgerUpdate -> TestName)
-> ([LedgerUpdate] -> ShowS)
-> Show LedgerUpdate
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerUpdate -> ShowS
showsPrec :: Int -> LedgerUpdate -> ShowS
$cshow :: LedgerUpdate -> TestName
show :: LedgerUpdate -> TestName
$cshowList :: [LedgerUpdate] -> ShowS
showList :: [LedgerUpdate] -> ShowS
Show, LedgerUpdate -> LedgerUpdate -> Bool
(LedgerUpdate -> LedgerUpdate -> Bool)
-> (LedgerUpdate -> LedgerUpdate -> Bool) -> Eq LedgerUpdate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LedgerUpdate -> LedgerUpdate -> Bool
== :: LedgerUpdate -> LedgerUpdate -> Bool
$c/= :: LedgerUpdate -> LedgerUpdate -> Bool
/= :: LedgerUpdate -> LedgerUpdate -> Bool
Eq, Integer -> LedgerUpdate
LedgerUpdate -> LedgerUpdate
LedgerUpdate -> LedgerUpdate -> LedgerUpdate
(LedgerUpdate -> LedgerUpdate -> LedgerUpdate)
-> (LedgerUpdate -> LedgerUpdate -> LedgerUpdate)
-> (LedgerUpdate -> LedgerUpdate -> LedgerUpdate)
-> (LedgerUpdate -> LedgerUpdate)
-> (LedgerUpdate -> LedgerUpdate)
-> (LedgerUpdate -> LedgerUpdate)
-> (Integer -> LedgerUpdate)
-> Num LedgerUpdate
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate
+ :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate
$c- :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate
- :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate
$c* :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate
* :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate
$cnegate :: LedgerUpdate -> LedgerUpdate
negate :: LedgerUpdate -> LedgerUpdate
$cabs :: LedgerUpdate -> LedgerUpdate
abs :: LedgerUpdate -> LedgerUpdate
$csignum :: LedgerUpdate -> LedgerUpdate
signum :: LedgerUpdate -> LedgerUpdate
$cfromInteger :: Integer -> LedgerUpdate
fromInteger :: Integer -> LedgerUpdate
Num)

{-------------------------------------------------------------------------------
  Ledger state
-------------------------------------------------------------------------------}

type LedgerValue = Word64

data LedgerState = LedgerState {
      LedgerState -> MaxLookahead
ledgerValue     :: LedgerValue
    , LedgerState -> Scheduled
ledgerScheduled :: Scheduled
    , LedgerState -> WithOrigin SlotNo
ledgerTip       :: WithOrigin SlotNo
    }
  deriving (Int -> LedgerState -> ShowS
[LedgerState] -> ShowS
LedgerState -> TestName
(Int -> LedgerState -> ShowS)
-> (LedgerState -> TestName)
-> ([LedgerState] -> ShowS)
-> Show LedgerState
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LedgerState -> ShowS
showsPrec :: Int -> LedgerState -> ShowS
$cshow :: LedgerState -> TestName
show :: LedgerState -> TestName
$cshowList :: [LedgerState] -> ShowS
showList :: [LedgerState] -> ShowS
Show)

data instance Ticked LedgerState = TickedLedgerState {
      Ticked LedgerState -> MaxLookahead
tickedValue     :: LedgerValue
    , Ticked LedgerState -> Scheduled
tickedScheduled :: Scheduled
    }
  deriving (Int -> Ticked LedgerState -> ShowS
[Ticked LedgerState] -> ShowS
Ticked LedgerState -> TestName
(Int -> Ticked LedgerState -> ShowS)
-> (Ticked LedgerState -> TestName)
-> ([Ticked LedgerState] -> ShowS)
-> Show (Ticked LedgerState)
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ticked LedgerState -> ShowS
showsPrec :: Int -> Ticked LedgerState -> ShowS
$cshow :: Ticked LedgerState -> TestName
show :: Ticked LedgerState -> TestName
$cshowList :: [Ticked LedgerState] -> ShowS
showList :: [Ticked LedgerState] -> ShowS
Show)

newtype LedgerView = LedgerView LedgerValue

initLedgerState :: LedgerState
initLedgerState :: LedgerState
initLedgerState = LedgerState {
      ledgerValue :: MaxLookahead
ledgerValue     = MaxLookahead
0
    , ledgerScheduled :: Scheduled
ledgerScheduled = Scheduled
forall k a. Map k a
Map.empty
    , ledgerTip :: WithOrigin SlotNo
ledgerTip       = WithOrigin SlotNo
forall t. WithOrigin t
Origin
    }

tickLedgerState :: SlotNo -> LedgerState -> Ticked LedgerState
tickLedgerState :: SlotNo -> LedgerState -> Ticked LedgerState
tickLedgerState SlotNo
sno = SlotNo -> Ticked LedgerState -> Ticked LedgerState
advanceTo SlotNo
sno (Ticked LedgerState -> Ticked LedgerState)
-> (LedgerState -> Ticked LedgerState)
-> LedgerState
-> Ticked LedgerState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState -> Ticked LedgerState
tickToTip

-- | "Tick to tip" just translates @LedgerState@ to @Ticked LedgerState@
-- without actually changing anything: after all, the ledger already /is/
-- at its tip.
tickToTip :: LedgerState -> Ticked LedgerState
tickToTip :: LedgerState -> Ticked LedgerState
tickToTip LedgerState{MaxLookahead
Scheduled
WithOrigin SlotNo
ledgerValue :: LedgerState -> MaxLookahead
ledgerScheduled :: LedgerState -> Scheduled
ledgerTip :: LedgerState -> WithOrigin SlotNo
ledgerValue :: MaxLookahead
ledgerScheduled :: Scheduled
ledgerTip :: WithOrigin SlotNo
..} = TickedLedgerState {
      tickedScheduled :: Scheduled
tickedScheduled = Scheduled
ledgerScheduled
    , tickedValue :: MaxLookahead
tickedValue     = MaxLookahead
ledgerValue
    }

-- | Advance the ticked ledger state to the given 'SlotNo'
advanceTo :: SlotNo -> Ticked LedgerState -> Ticked LedgerState
advanceTo :: SlotNo -> Ticked LedgerState -> Ticked LedgerState
advanceTo SlotNo
sno TickedLedgerState{MaxLookahead
Scheduled
tickedValue :: Ticked LedgerState -> MaxLookahead
tickedScheduled :: Ticked LedgerState -> Scheduled
tickedValue :: MaxLookahead
tickedScheduled :: Scheduled
..} = TickedLedgerState {
      tickedScheduled :: Scheduled
tickedScheduled = Scheduled
notYet
    , tickedValue :: MaxLookahead
tickedValue     = (LedgerUpdate -> MaxLookahead -> MaxLookahead)
-> [LedgerUpdate] -> MaxLookahead -> MaxLookahead
forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly
                          LedgerUpdate -> MaxLookahead -> MaxLookahead
applyLedgerUpdate
                          (Scheduled -> [LedgerUpdate]
forall k a. Map k a -> [a]
Map.elems Scheduled
toApply)
                          MaxLookahead
tickedValue
    }
  where
    toApply, notYet :: Scheduled
    (Scheduled
toApply, Scheduled
notYet) = (SlotNo -> LedgerUpdate -> Bool)
-> Scheduled -> (Scheduled, Scheduled)
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey
                          (\SlotNo
sno' LedgerUpdate
_ -> SlotNo
sno' SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
sno)
                          Scheduled
tickedScheduled

applyLedgerUpdate :: LedgerUpdate -> LedgerValue -> LedgerValue
applyLedgerUpdate :: LedgerUpdate -> MaxLookahead -> MaxLookahead
applyLedgerUpdate (IncreaseValueBy MaxLookahead
d) = (MaxLookahead -> MaxLookahead -> MaxLookahead
forall a. Num a => a -> a -> a
+ MaxLookahead
d)

-- | Advance ledger state to the next slot (without a block)
stepLedgerState :: LedgerState -> LedgerState
stepLedgerState :: LedgerState -> LedgerState
stepLedgerState LedgerState
ledgerState = LedgerState {
      ledgerScheduled :: Scheduled
ledgerScheduled = Scheduled
tickedScheduled
    , ledgerValue :: MaxLookahead
ledgerValue     = MaxLookahead
tickedValue
    , ledgerTip :: WithOrigin SlotNo
ledgerTip       = SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
nextSlot
    }
  where
    nextSlot :: SlotNo
    nextSlot :: SlotNo
nextSlot = case LedgerState -> WithOrigin SlotNo
ledgerTip LedgerState
ledgerState of
                 WithOrigin SlotNo
Origin      -> MaxLookahead -> SlotNo
SlotNo MaxLookahead
0
                 NotOrigin SlotNo
s -> SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s

    TickedLedgerState{MaxLookahead
Scheduled
tickedValue :: Ticked LedgerState -> MaxLookahead
tickedScheduled :: Ticked LedgerState -> Scheduled
tickedScheduled :: Scheduled
tickedValue :: MaxLookahead
..} = SlotNo -> LedgerState -> Ticked LedgerState
tickLedgerState SlotNo
nextSlot LedgerState
ledgerState

applyBlock :: Block -> Ticked LedgerState -> LedgerState
applyBlock :: Block -> Ticked LedgerState -> LedgerState
applyBlock (Block SlotNo
slot Scheduled
blockScheduled) TickedLedgerState{MaxLookahead
Scheduled
tickedValue :: Ticked LedgerState -> MaxLookahead
tickedScheduled :: Ticked LedgerState -> Scheduled
tickedValue :: MaxLookahead
tickedScheduled :: Scheduled
..} = LedgerState {
      ledgerScheduled :: Scheduled
ledgerScheduled = (LedgerUpdate -> LedgerUpdate -> LedgerUpdate)
-> Scheduled -> Scheduled -> Scheduled
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith LedgerUpdate -> LedgerUpdate -> LedgerUpdate
combineUpdates
                          Scheduled
tickedScheduled
                          Scheduled
notYet
    , ledgerValue :: MaxLookahead
ledgerValue     = (MaxLookahead -> MaxLookahead)
-> (LedgerUpdate -> MaxLookahead -> MaxLookahead)
-> Maybe LedgerUpdate
-> MaxLookahead
-> MaxLookahead
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaxLookahead -> MaxLookahead
forall a. a -> a
id LedgerUpdate -> MaxLookahead -> MaxLookahead
applyLedgerUpdate Maybe LedgerUpdate
mToApply (MaxLookahead -> MaxLookahead) -> MaxLookahead -> MaxLookahead
forall a b. (a -> b) -> a -> b
$ MaxLookahead
tickedValue
    , ledgerTip :: WithOrigin SlotNo
ledgerTip       = SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slot
    }
  where
    combineUpdates :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate
    combineUpdates :: LedgerUpdate -> LedgerUpdate -> LedgerUpdate
combineUpdates (IncreaseValueBy MaxLookahead
x) (IncreaseValueBy MaxLookahead
y) =
        MaxLookahead -> LedgerUpdate
IncreaseValueBy (MaxLookahead
x MaxLookahead -> MaxLookahead -> MaxLookahead
forall a. Num a => a -> a -> a
+ MaxLookahead
y)

    -- Immediately apply any changes scheduled for the block's own slot
    mToApply :: Maybe LedgerUpdate
    notYet   :: Scheduled
    (Maybe LedgerUpdate
mToApply, Scheduled
notYet) = (SlotNo -> LedgerUpdate -> Maybe LedgerUpdate)
-> SlotNo -> Scheduled -> (Maybe LedgerUpdate, Scheduled)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey
                           (\SlotNo
_ LedgerUpdate
_ -> Maybe LedgerUpdate
forall a. Maybe a
Nothing)
                           SlotNo
slot
                           Scheduled
blockScheduled

{-------------------------------------------------------------------------------
  Moving between eras
-------------------------------------------------------------------------------}

-- A value of @x@ in era @n@ corresponds to a value of @3x@ in era @n+1@
--
-- This means that the HFC translation functions have some work to do.
translateToNextEra :: LedgerState -> LedgerState
translateToNextEra :: LedgerState -> LedgerState
translateToNextEra LedgerState{MaxLookahead
Scheduled
WithOrigin SlotNo
ledgerValue :: LedgerState -> MaxLookahead
ledgerScheduled :: LedgerState -> Scheduled
ledgerTip :: LedgerState -> WithOrigin SlotNo
ledgerValue :: MaxLookahead
ledgerScheduled :: Scheduled
ledgerTip :: WithOrigin SlotNo
..} = LedgerState{
      ledgerTip :: WithOrigin SlotNo
ledgerTip       = WithOrigin SlotNo
ledgerTip
    , ledgerValue :: MaxLookahead
ledgerValue     = MaxLookahead -> MaxLookahead
forall a. Num a => a -> a
inflate MaxLookahead
ledgerValue
    , ledgerScheduled :: Scheduled
ledgerScheduled = LedgerUpdate -> LedgerUpdate
forall a. Num a => a -> a
inflate (LedgerUpdate -> LedgerUpdate) -> Scheduled -> Scheduled
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scheduled
ledgerScheduled
    }

inflate :: Num a => a -> a
inflate :: forall a. Num a => a -> a
inflate a
x = a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
3

{-------------------------------------------------------------------------------
  Forecasting within an era
-------------------------------------------------------------------------------}

withinEraForecast :: MaxLookahead -> LedgerState -> Forecast LedgerView
withinEraForecast :: MaxLookahead -> LedgerState -> Forecast LedgerView
withinEraForecast MaxLookahead
maxLookAhead LedgerState
st = Forecast{
      forecastAt :: WithOrigin SlotNo
forecastAt  = LedgerState -> WithOrigin SlotNo
ledgerTip LedgerState
st
    , forecastFor :: SlotNo -> Except OutsideForecastRange LedgerView
forecastFor = SlotNo -> Except OutsideForecastRange LedgerView
go
    }
  where
    go :: SlotNo -> Except OutsideForecastRange LedgerView
    go :: SlotNo -> Except OutsideForecastRange LedgerView
go SlotNo
for = do
        Bool
-> ExceptT OutsideForecastRange Identity ()
-> ExceptT OutsideForecastRange Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
upperBound) (ExceptT OutsideForecastRange Identity ()
 -> ExceptT OutsideForecastRange Identity ())
-> ExceptT OutsideForecastRange Identity ()
-> ExceptT OutsideForecastRange Identity ()
forall a b. (a -> b) -> a -> b
$
          OutsideForecastRange -> ExceptT OutsideForecastRange Identity ()
forall a.
OutsideForecastRange -> ExceptT OutsideForecastRange Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError OutsideForecastRange {
                  outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt     = LedgerState -> WithOrigin SlotNo
ledgerTip LedgerState
st
                , outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = SlotNo
upperBound
                , outsideForecastFor :: SlotNo
outsideForecastFor    = SlotNo
for
                }

        LedgerView -> Except OutsideForecastRange LedgerView
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerView -> Except OutsideForecastRange LedgerView)
-> LedgerView -> Except OutsideForecastRange LedgerView
forall a b. (a -> b) -> a -> b
$ MaxLookahead -> LedgerView
LedgerView (MaxLookahead -> LedgerView)
-> (Ticked LedgerState -> MaxLookahead)
-> Ticked LedgerState
-> LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked LedgerState -> MaxLookahead
tickedValue (Ticked LedgerState -> LedgerView)
-> Ticked LedgerState -> LedgerView
forall a b. (a -> b) -> a -> b
$ SlotNo -> LedgerState -> Ticked LedgerState
tickLedgerState SlotNo
for LedgerState
st
      where
        -- Exclusive upper bound
        upperBound :: SlotNo
        upperBound :: SlotNo
upperBound = case LedgerState -> WithOrigin SlotNo
ledgerTip LedgerState
st of
                       WithOrigin SlotNo
Origin      -> MaxLookahead -> SlotNo -> SlotNo
addSlots MaxLookahead
maxLookAhead (MaxLookahead -> SlotNo
SlotNo MaxLookahead
0)
                       NotOrigin SlotNo
s -> MaxLookahead -> SlotNo -> SlotNo
addSlots MaxLookahead
maxLookAhead (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s)

{-------------------------------------------------------------------------------
  Forecasting across eras
-------------------------------------------------------------------------------}

-- | Translations between eras
translations :: forall xs.
     TestSetup xs
  -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) xs
translations :: forall (xs :: [*]).
TestSetup xs
-> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) xs
translations TestSetup{NonEmpty xs TestEra
Exactly xs MaxLookahead
TestForecastParams
testLookahead :: Exactly xs MaxLookahead
testEras :: NonEmpty xs TestEra
testForecastParams :: TestForecastParams
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
..} =
    case Proxy xs -> ProofNonEmpty xs
forall {a} (xs :: [a]) (proxy :: [a] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
forall (proxy :: [*] -> *). proxy xs -> ProofNonEmpty xs
isNonEmpty (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @xs) of
      ProofNonEmpty{} -> Exactly (x : xs1) MaxLookahead
-> InPairs
     (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs1)
forall x (xs' :: [*]).
Exactly (x : xs') MaxLookahead
-> InPairs
     (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs')
go Exactly xs MaxLookahead
Exactly (x : xs1) MaxLookahead
testLookahead
  where
    go :: Exactly (x ': xs') MaxLookahead
       -> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) (x ': xs')
    go :: forall x (xs' :: [*]).
Exactly (x : xs') MaxLookahead
-> InPairs
     (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs')
go (ExactlyCons MaxLookahead
_ Exactly xs MaxLookahead
ExactlyNil) =
        InPairs
  (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs')
InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) '[x]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
InPairs.PNil
    go (ExactlyCons MaxLookahead
this rest :: Exactly xs MaxLookahead
rest@(ExactlyCons MaxLookahead
next Exactly xs MaxLookahead
_)) =
        CrossEraForecaster (K LedgerState) (K LedgerView) x x
-> InPairs
     (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs)
-> InPairs
     (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : x : xs)
forall {k} (f :: k -> k -> *) (x :: k) (y :: k) (zs :: [k]).
f x y -> InPairs f (y : zs) -> InPairs f (x : y : zs)
InPairs.PCons (MaxLookahead
-> MaxLookahead
-> CrossEraForecaster (K LedgerState) (K LedgerView) x x
forall era era'.
MaxLookahead
-> MaxLookahead
-> CrossEraForecaster (K LedgerState) (K LedgerView) era era'
tr MaxLookahead
this MaxLookahead
next) (Exactly (x : xs) MaxLookahead
-> InPairs
     (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs)
forall x (xs' :: [*]).
Exactly (x : xs') MaxLookahead
-> InPairs
     (CrossEraForecaster (K LedgerState) (K LedgerView)) (x : xs')
go Exactly xs MaxLookahead
Exactly (x : xs) MaxLookahead
rest)

    tr :: MaxLookahead -- ^ Look-ahead in the current era
       -> MaxLookahead -- ^ Look-ahead in the next era
       -> CrossEraForecaster (K LedgerState) (K LedgerView) era era'
    tr :: forall era era'.
MaxLookahead
-> MaxLookahead
-> CrossEraForecaster (K LedgerState) (K LedgerView) era era'
tr MaxLookahead
thisLookahead MaxLookahead
nextLookahead =
        (Bound
 -> SlotNo
 -> K LedgerState era
 -> Except OutsideForecastRange (K LedgerView era'))
-> CrossEraForecaster (K LedgerState) (K LedgerView) era era'
forall (state :: * -> *) (view :: * -> *) x y.
(Bound
 -> SlotNo -> state x -> Except OutsideForecastRange (view y))
-> CrossEraForecaster state view x y
CrossEraForecaster ((Bound
  -> SlotNo
  -> K LedgerState era
  -> Except OutsideForecastRange (K LedgerView era'))
 -> CrossEraForecaster (K LedgerState) (K LedgerView) era era')
-> (Bound
    -> SlotNo
    -> K LedgerState era
    -> Except OutsideForecastRange (K LedgerView era'))
-> CrossEraForecaster (K LedgerState) (K LedgerView) era era'
forall a b. (a -> b) -> a -> b
$ \Bound
transition SlotNo
sno (K LedgerState
st) ->
          Bool
-> Except OutsideForecastRange (K LedgerView era')
-> Except OutsideForecastRange (K LedgerView era')
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (SlotNo
sno SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= Bound -> SlotNo
boundSlot Bound
transition) (Except OutsideForecastRange (K LedgerView era')
 -> Except OutsideForecastRange (K LedgerView era'))
-> Except OutsideForecastRange (K LedgerView era')
-> Except OutsideForecastRange (K LedgerView era')
forall a b. (a -> b) -> a -> b
$ do
            let tip :: WithOrigin SlotNo
                tip :: WithOrigin SlotNo
tip = LedgerState -> WithOrigin SlotNo
ledgerTip LedgerState
st

                -- (Exclusive) upper bound for the forecast
                bound :: SlotNo
                bound :: SlotNo
bound = WithOrigin SlotNo
-> SlotNo -> MaxLookahead -> MaxLookahead -> SlotNo
crossEraForecastBound
                          WithOrigin SlotNo
tip
                          (Bound -> SlotNo
boundSlot Bound
transition)
                          MaxLookahead
thisLookahead
                          MaxLookahead
nextLookahead

            Bool
-> ExceptT OutsideForecastRange Identity ()
-> ExceptT OutsideForecastRange Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SlotNo
sno SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
bound) (ExceptT OutsideForecastRange Identity ()
 -> ExceptT OutsideForecastRange Identity ())
-> ExceptT OutsideForecastRange Identity ()
-> ExceptT OutsideForecastRange Identity ()
forall a b. (a -> b) -> a -> b
$
              OutsideForecastRange -> ExceptT OutsideForecastRange Identity ()
forall a.
OutsideForecastRange -> ExceptT OutsideForecastRange Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (OutsideForecastRange -> ExceptT OutsideForecastRange Identity ())
-> OutsideForecastRange -> ExceptT OutsideForecastRange Identity ()
forall a b. (a -> b) -> a -> b
$ OutsideForecastRange {
                  outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt     = WithOrigin SlotNo
tip
                , outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = SlotNo
bound
                , outsideForecastFor :: SlotNo
outsideForecastFor    = SlotNo
sno
                }

            -- We set things up so that we don't have to be too careful with
            -- the ordering of the operations here: @3x + 3y = 3(x + y)@.
            K LedgerView era'
-> Except OutsideForecastRange (K LedgerView era')
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (K LedgerView era'
 -> Except OutsideForecastRange (K LedgerView era'))
-> K LedgerView era'
-> Except OutsideForecastRange (K LedgerView era')
forall a b. (a -> b) -> a -> b
$ LedgerView -> K LedgerView era'
forall k a (b :: k). a -> K a b
K (LedgerView -> K LedgerView era')
-> LedgerView -> K LedgerView era'
forall a b. (a -> b) -> a -> b
$ MaxLookahead -> LedgerView
LedgerView (MaxLookahead -> LedgerView) -> MaxLookahead -> LedgerView
forall a b. (a -> b) -> a -> b
$
                MaxLookahead -> MaxLookahead
forall a. Num a => a -> a
inflate (MaxLookahead -> MaxLookahead) -> MaxLookahead -> MaxLookahead
forall a b. (a -> b) -> a -> b
$ Ticked LedgerState -> MaxLookahead
tickedValue (Ticked LedgerState -> MaxLookahead)
-> Ticked LedgerState -> MaxLookahead
forall a b. (a -> b) -> a -> b
$ SlotNo -> LedgerState -> Ticked LedgerState
tickLedgerState SlotNo
sno LedgerState
st

acrossErasForecast :: forall xs.
     TestSetup xs
  -> Map (WithOrigin SlotNo) LedgerState
  -> Forecast LedgerView
acrossErasForecast :: forall (xs :: [*]).
TestSetup xs
-> Map (WithOrigin SlotNo) LedgerState -> Forecast LedgerView
acrossErasForecast setup :: TestSetup xs
setup@TestSetup{NonEmpty xs TestEra
Exactly xs MaxLookahead
TestForecastParams
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testLookahead :: Exactly xs MaxLookahead
testEras :: NonEmpty xs TestEra
testForecastParams :: TestForecastParams
..} Map (WithOrigin SlotNo) LedgerState
ledgerStates =
    (HardForkLedgerView_ (K LedgerView) xs -> LedgerView)
-> Forecast (HardForkLedgerView_ (K LedgerView) xs)
-> Forecast LedgerView
forall a b. (a -> b) -> Forecast a -> Forecast b
mapForecast HardForkLedgerView_ (K LedgerView) xs -> LedgerView
aux (Forecast (HardForkLedgerView_ (K LedgerView) xs)
 -> Forecast LedgerView)
-> Forecast (HardForkLedgerView_ (K LedgerView) xs)
-> Forecast LedgerView
forall a b. (a -> b) -> a -> b
$
      InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) xs
-> HardForkState (AnnForecast (K LedgerState) (K LedgerView)) xs
-> Forecast (HardForkLedgerView_ (K LedgerView) xs)
forall (state :: * -> *) (view :: * -> *) (xs :: [*]).
SListI xs =>
InPairs (CrossEraForecaster state view) xs
-> HardForkState (AnnForecast state view) xs
-> Forecast (HardForkLedgerView_ view xs)
mkHardForkForecast (TestSetup xs
-> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) xs
forall (xs :: [*]).
TestSetup xs
-> InPairs (CrossEraForecaster (K LedgerState) (K LedgerView)) xs
translations TestSetup xs
setup) (Telescope
  (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs
-> HardForkState (AnnForecast (K LedgerState) (K LedgerView)) xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (NonEmpty xs TestEra
-> Telescope
     (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs
forall (xs' :: [*]).
NonEmpty xs' TestEra
-> Telescope
     (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs'
go NonEmpty xs TestEra
testEras))
  where
    TestForecastParams{WithOrigin SlotNo
SlotNo
testForecastAt :: WithOrigin SlotNo
testForecastWithinEra :: SlotNo
testForecastAcrossEras :: SlotNo
testForecastAt :: TestForecastParams -> WithOrigin SlotNo
testForecastWithinEra :: TestForecastParams -> SlotNo
testForecastAcrossEras :: TestForecastParams -> SlotNo
..} = TestForecastParams
testForecastParams

    aux :: HardForkLedgerView_ (K LedgerView) xs
        -> LedgerView
    aux :: HardForkLedgerView_ (K LedgerView) xs -> LedgerView
aux = HardForkState (K LedgerView) xs
-> CollapseTo HardForkState LedgerView
HardForkState (K LedgerView) xs -> LedgerView
forall (xs :: [*]) a.
SListIN HardForkState xs =>
HardForkState (K a) xs -> CollapseTo HardForkState a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
        (HardForkState (K LedgerView) xs -> LedgerView)
-> (HardForkLedgerView_ (K LedgerView) xs
    -> HardForkState (K LedgerView) xs)
-> HardForkLedgerView_ (K LedgerView) xs
-> LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkLedgerView_ (K LedgerView) xs
-> HardForkState (K LedgerView) xs
forall (f :: * -> *) (xs :: [*]).
HardForkLedgerView_ f xs -> HardForkState f xs
hardForkLedgerViewPerEra

    go :: NonEmpty xs' TestEra
       -> Telescope (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs'
    go :: forall (xs' :: [*]).
NonEmpty xs' TestEra
-> Telescope
     (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs'
go (NonEmptyOne TestEra
era) =
        Bool
-> Telescope
     (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs'
-> Telescope
     (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs'
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (WithOrigin SlotNo -> TestEra -> Bool
testEraContains WithOrigin SlotNo
testForecastAt TestEra
era) (Telescope
   (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs'
 -> Telescope
      (K Past)
      (Current (AnnForecast (K LedgerState) (K LedgerView)))
      xs')
-> Telescope
     (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs'
-> Telescope
     (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs'
forall a b. (a -> b) -> a -> b
$
        Current (AnnForecast (K LedgerState) (K LedgerView)) x
-> Telescope
     (K Past)
     (Current (AnnForecast (K LedgerState) (K LedgerView)))
     (x : xs1)
forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]).
f x -> Telescope g f (x : xs1)
TZ (Current (AnnForecast (K LedgerState) (K LedgerView)) x
 -> Telescope
      (K Past)
      (Current (AnnForecast (K LedgerState) (K LedgerView)))
      (x : xs1))
-> Current (AnnForecast (K LedgerState) (K LedgerView)) x
-> Telescope
     (K Past)
     (Current (AnnForecast (K LedgerState) (K LedgerView)))
     (x : xs1)
forall a b. (a -> b) -> a -> b
$ Current {
            currentStart :: Bound
currentStart = EraSummary -> Bound
eraStart (TestEra -> EraSummary
testEraSummary TestEra
era)
          , currentState :: AnnForecast (K LedgerState) (K LedgerView) x
currentState = AnnForecast {
                annForecast :: Forecast (K LedgerView x)
annForecast      = (LedgerView -> K LedgerView x)
-> Forecast LedgerView -> Forecast (K LedgerView x)
forall a b. (a -> b) -> Forecast a -> Forecast b
mapForecast LedgerView -> K LedgerView x
forall k a (b :: k). a -> K a b
K (Forecast LedgerView -> Forecast (K LedgerView x))
-> Forecast LedgerView -> Forecast (K LedgerView x)
forall a b. (a -> b) -> a -> b
$
                                     MaxLookahead -> LedgerState -> Forecast LedgerView
withinEraForecast
                                       (TestEra -> MaxLookahead
testEraMaxLookahead TestEra
era)
                                       LedgerState
st
              , annForecastState :: K LedgerState x
annForecastState = LedgerState -> K LedgerState x
forall k a (b :: k). a -> K a b
K LedgerState
st
              , annForecastTip :: WithOrigin SlotNo
annForecastTip   = WithOrigin SlotNo
testForecastAt
              , annForecastEnd :: Maybe Bound
annForecastEnd   = Maybe Bound
forall a. Maybe a
Nothing
              }
          }
        where
          st :: LedgerState
          st :: LedgerState
st = Map (WithOrigin SlotNo) LedgerState
ledgerStates Map (WithOrigin SlotNo) LedgerState
-> WithOrigin SlotNo -> LedgerState
forall k a.
(?callStack::CallStack, Show k, Show a, Ord k) =>
Map k a -> k -> a
`mapAt` WithOrigin SlotNo
testForecastAt
    go (NonEmptyCons TestEra
era NonEmpty xs1 TestEra
eras) =
        if WithOrigin SlotNo -> TestEra -> Bool
testEraContains WithOrigin SlotNo
testForecastAt TestEra
era then
          Current (AnnForecast (K LedgerState) (K LedgerView)) x
-> Telescope
     (K Past)
     (Current (AnnForecast (K LedgerState) (K LedgerView)))
     (x : xs1)
forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]).
f x -> Telescope g f (x : xs1)
TZ (Current (AnnForecast (K LedgerState) (K LedgerView)) x
 -> Telescope
      (K Past)
      (Current (AnnForecast (K LedgerState) (K LedgerView)))
      (x : xs1))
-> Current (AnnForecast (K LedgerState) (K LedgerView)) x
-> Telescope
     (K Past)
     (Current (AnnForecast (K LedgerState) (K LedgerView)))
     (x : xs1)
forall a b. (a -> b) -> a -> b
$ Current {
              currentStart :: Bound
currentStart = Bound
start
            , currentState :: AnnForecast (K LedgerState) (K LedgerView) x
currentState = AnnForecast {
                  annForecast :: Forecast (K LedgerView x)
annForecast      = (LedgerView -> K LedgerView x)
-> Forecast LedgerView -> Forecast (K LedgerView x)
forall a b. (a -> b) -> Forecast a -> Forecast b
mapForecast LedgerView -> K LedgerView x
forall k a (b :: k). a -> K a b
K (Forecast LedgerView -> Forecast (K LedgerView x))
-> Forecast LedgerView -> Forecast (K LedgerView x)
forall a b. (a -> b) -> a -> b
$
                                       MaxLookahead -> LedgerState -> Forecast LedgerView
withinEraForecast
                                         (TestEra -> MaxLookahead
testEraMaxLookahead TestEra
era)
                                         LedgerState
st
                , annForecastState :: K LedgerState x
annForecastState = LedgerState -> K LedgerState x
forall k a (b :: k). a -> K a b
K LedgerState
st
                , annForecastTip :: WithOrigin SlotNo
annForecastTip   = WithOrigin SlotNo
testForecastAt
                , annForecastEnd :: Maybe Bound
annForecastEnd   = Bound -> Maybe Bound
forall a. a -> Maybe a
Just Bound
end
                }
            }
        else
          K Past x
-> Telescope
     (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs1
-> Telescope
     (K Past)
     (Current (AnnForecast (K LedgerState) (K LedgerView)))
     (x : xs1)
forall {k} (g :: k -> *) (x :: k) (f :: k -> *) (xs1 :: [k]).
g x -> Telescope g f xs1 -> Telescope g f (x : xs1)
TS (Past -> K Past x
forall k a (b :: k). a -> K a b
K (Bound -> Bound -> Past
Past Bound
start Bound
end)) (NonEmpty xs1 TestEra
-> Telescope
     (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs1
forall (xs' :: [*]).
NonEmpty xs' TestEra
-> Telescope
     (K Past) (Current (AnnForecast (K LedgerState) (K LedgerView))) xs'
go NonEmpty xs1 TestEra
eras)
      where
        st :: LedgerState
        st :: LedgerState
st = Map (WithOrigin SlotNo) LedgerState
ledgerStates Map (WithOrigin SlotNo) LedgerState
-> WithOrigin SlotNo -> LedgerState
forall k a.
(?callStack::CallStack, Show k, Show a, Ord k) =>
Map k a -> k -> a
`mapAt` WithOrigin SlotNo
testForecastAt

        start, end :: Bound
        start :: Bound
start = EraSummary -> Bound
eraStart (TestEra -> EraSummary
testEraSummary TestEra
era)
        end :: Bound
end   = case EraSummary -> EraEnd
eraEnd (TestEra -> EraSummary
testEraSummary TestEra
era) of
                  EraEnd
EraUnbounded -> TestName -> Bound
forall a. (?callStack::CallStack) => TestName -> a
error TestName
"past eras cannot be unbounded"
                  EraEnd Bound
e     -> Bound
e

{-------------------------------------------------------------------------------
  Forecast validity
-------------------------------------------------------------------------------}

correctForecastOf :: LedgerView -> LedgerState -> Property
LedgerView MaxLookahead
forecasted correctForecastOf :: LedgerView -> LedgerState -> Property
`correctForecastOf` LedgerState
actual =
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"forecasted: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ MaxLookahead -> TestName
forall a. Show a => a -> TestName
show MaxLookahead
forecasted)
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"actual: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ LedgerState -> TestName
forall a. Show a => a -> TestName
show LedgerState
actual)
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ MaxLookahead
forecasted MaxLookahead -> MaxLookahead -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== LedgerState -> MaxLookahead
ledgerValue LedgerState
actual

{-------------------------------------------------------------------------------
  Sanity checks
-------------------------------------------------------------------------------}

prop_validTestSetup :: Some TestSetup -> Property
prop_validTestSetup :: Some TestSetup -> Property
prop_validTestSetup (Some setup :: TestSetup a
setup@TestSetup{NonEmpty a TestEra
Exactly a MaxLookahead
TestForecastParams
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testLookahead :: Exactly a MaxLookahead
testEras :: NonEmpty a TestEra
testForecastParams :: TestForecastParams
..}) = [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin [
        TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"strictlyIncreasing" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          [SlotNo] -> Property
forall a. (Show a, Ord a) => [a] -> Property
strictlyIncreasing ([SlotNo] -> Property) -> [SlotNo] -> Property
forall a b. (a -> b) -> a -> b
$ (Block -> SlotNo) -> [Block] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map (\(Block SlotNo
s Scheduled
_) -> SlotNo
s) ([Block] -> [SlotNo]) -> [Block] -> [SlotNo]
forall a b. (a -> b) -> a -> b
$ [[Block]] -> [Block]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Block]] -> [Block]) -> [[Block]] -> [Block]
forall a b. (a -> b) -> a -> b
$ TestSetup a -> [[Block]]
forall (xs :: [*]). TestSetup xs -> [[Block]]
blocksPerEra TestSetup a
setup
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"obeysMaxLookahead" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$ (TestEra -> Property) -> [TestEra] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map TestEra -> Property
checkLookahead (NonEmpty a TestEra -> [TestEra]
forall a. NonEmpty a a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty a TestEra
testEras)
      , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"validForecastParams" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          TestSetup a -> Either TestName ()
forall (xs :: [*]). TestSetup xs -> Either TestName ()
validForecastParams TestSetup a
setup Either TestName () -> Either TestName () -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== () -> Either TestName ()
forall a b. b -> Either a b
Right ()
      ]
  where
    checkLookahead :: TestEra -> Property
    checkLookahead :: TestEra -> Property
checkLookahead TestEra{[Block]
MaxLookahead
EraSummary
testEraSummary :: TestEra -> EraSummary
testEraMaxLookahead :: TestEra -> MaxLookahead
testEraSummary :: EraSummary
testEraMaxLookahead :: MaxLookahead
testEraBlocks :: [Block]
testEraBlocks :: TestEra -> [Block]
..} = [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin [
          SlotNo
slotChange SlotNo -> SlotNo -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`ge` MaxLookahead -> SlotNo -> SlotNo
addSlots MaxLookahead
testEraMaxLookahead SlotNo
slotBlock
        | (Block SlotNo
slotBlock Scheduled
scheduled) <- [Block]
testEraBlocks
        , (SlotNo
slotChange, LedgerUpdate
_update) <- Scheduled -> [(SlotNo, LedgerUpdate)]
forall k a. Map k a -> [(k, a)]
Map.toList Scheduled
scheduled
        ]

prop_forecast :: Bool -> Some TestSetup -> Property
prop_forecast :: Bool -> Some TestSetup -> Property
prop_forecast Bool
useWithinEra (Some setup :: TestSetup a
setup@TestSetup{NonEmpty a TestEra
Exactly a MaxLookahead
TestForecastParams
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testLookahead :: Exactly a MaxLookahead
testEras :: NonEmpty a TestEra
testForecastParams :: TestForecastParams
..}) =
      TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"(useWithinEra, isWithinEra, within range)" [TestName -> [TestName] -> TestName
forall a. [a] -> [[a]] -> [a]
intercalate TestName
"/" [
          Bool -> TestName
forall a. Show a => a -> TestName
show Bool
useWithinEra
        , Bool -> TestName
forall a. Show a => a -> TestName
show Bool
isWithinEra
        , Bool -> TestName
forall a. Show a => a -> TestName
show (Either OutsideForecastRange LedgerView -> Bool
forall a b. Either a b -> Bool
isRight Either OutsideForecastRange LedgerView
mForecastLedger)
        ]]
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"ledgerStates: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Map (WithOrigin SlotNo) LedgerState -> TestName
forall a. Show a => a -> TestName
show Map (WithOrigin SlotNo) LedgerState
ledgerStates)
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"markTransitions: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [Either Block EraTransition] -> TestName
forall a. Show a => a -> TestName
show (TestSetup a -> [Either Block EraTransition]
forall (xs :: [*]). TestSetup xs -> [Either Block EraTransition]
markTransitions TestSetup a
setup))
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ case Either OutsideForecastRange LedgerView
mForecastLedger of
        Left OutsideForecastRange
_outOfRange ->
          -- Ideally we would check that these out of ranges are justified.
          Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
        Right LedgerView
forecastLedger ->
          LedgerView
forecastLedger LedgerView -> LedgerState -> Property
`correctForecastOf` LedgerState
actualLedger
  where
    TestForecastParams{WithOrigin SlotNo
SlotNo
testForecastAt :: TestForecastParams -> WithOrigin SlotNo
testForecastWithinEra :: TestForecastParams -> SlotNo
testForecastAcrossEras :: TestForecastParams -> SlotNo
testForecastAt :: WithOrigin SlotNo
testForecastWithinEra :: SlotNo
testForecastAcrossEras :: SlotNo
..} = TestForecastParams
testForecastParams

    ledgerStates :: Map (WithOrigin SlotNo) LedgerState
    ledgerStates :: Map (WithOrigin SlotNo) LedgerState
ledgerStates = TestSetup a -> Map (WithOrigin SlotNo) LedgerState
forall (xs :: [*]).
TestSetup xs -> Map (WithOrigin SlotNo) LedgerState
interpretChain TestSetup a
setup

    forecast :: Forecast LedgerView
    forecast :: Forecast LedgerView
forecast
      | Bool
useWithinEra =
          MaxLookahead -> LedgerState -> Forecast LedgerView
withinEraForecast
            (TestSetup a -> WithOrigin SlotNo -> MaxLookahead
forall (xs :: [*]).
TestSetup xs -> WithOrigin SlotNo -> MaxLookahead
slotMaxLookahead TestSetup a
setup WithOrigin SlotNo
testForecastAt)
            (Map (WithOrigin SlotNo) LedgerState
ledgerStates Map (WithOrigin SlotNo) LedgerState
-> WithOrigin SlotNo -> LedgerState
forall k a.
(?callStack::CallStack, Show k, Show a, Ord k) =>
Map k a -> k -> a
`mapAt` WithOrigin SlotNo
testForecastAt)
      | Bool
otherwise =
          TestSetup a
-> Map (WithOrigin SlotNo) LedgerState -> Forecast LedgerView
forall (xs :: [*]).
TestSetup xs
-> Map (WithOrigin SlotNo) LedgerState -> Forecast LedgerView
acrossErasForecast TestSetup a
setup Map (WithOrigin SlotNo) LedgerState
ledgerStates

    for :: SlotNo
    for :: SlotNo
for | Bool
useWithinEra = SlotNo
testForecastWithinEra
        | Bool
otherwise    = SlotNo
testForecastAcrossEras

    isWithinEra :: Bool
    isWithinEra :: Bool
isWithinEra = TestSetup a -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall (xs :: [*]).
TestSetup xs -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
slotSameEra TestSetup a
setup WithOrigin SlotNo
testForecastAt (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
for)

    mForecastLedger :: Either OutsideForecastRange LedgerView
    mForecastLedger :: Either OutsideForecastRange LedgerView
mForecastLedger = Except OutsideForecastRange LedgerView
-> Either OutsideForecastRange LedgerView
forall e a. Except e a -> Either e a
runExcept (Except OutsideForecastRange LedgerView
 -> Either OutsideForecastRange LedgerView)
-> Except OutsideForecastRange LedgerView
-> Either OutsideForecastRange LedgerView
forall a b. (a -> b) -> a -> b
$ Forecast LedgerView
-> SlotNo -> Except OutsideForecastRange LedgerView
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor Forecast LedgerView
forecast SlotNo
for

    actualLedger :: LedgerState
    actualLedger :: LedgerState
actualLedger = Map (WithOrigin SlotNo) LedgerState
ledgerStates Map (WithOrigin SlotNo) LedgerState
-> WithOrigin SlotNo -> LedgerState
forall k a.
(?callStack::CallStack, Show k, Show a, Ord k) =>
Map k a -> k -> a
`mapAt` SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
for

{-------------------------------------------------------------------------------
  Valued derived from the 'TestSetup'
-------------------------------------------------------------------------------}

-- | Mark era transitions
--
-- This is an auxiliary type used in 'interpretChain'. It records the start of
-- end of the current era (equals start of the next)
data EraTransition = EraTransition SlotNo
  deriving (Int -> EraTransition -> ShowS
[EraTransition] -> ShowS
EraTransition -> TestName
(Int -> EraTransition -> ShowS)
-> (EraTransition -> TestName)
-> ([EraTransition] -> ShowS)
-> Show EraTransition
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EraTransition -> ShowS
showsPrec :: Int -> EraTransition -> ShowS
$cshow :: EraTransition -> TestName
show :: EraTransition -> TestName
$cshowList :: [EraTransition] -> ShowS
showList :: [EraTransition] -> ShowS
Show)

markTransitions :: TestSetup xs -> [Either Block EraTransition]
markTransitions :: forall (xs :: [*]). TestSetup xs -> [Either Block EraTransition]
markTransitions =
    (Either [Block] EraTransition -> [Either Block EraTransition])
-> [Either [Block] EraTransition] -> [Either Block EraTransition]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Block] -> [Either Block EraTransition])
-> (EraTransition -> [Either Block EraTransition])
-> Either [Block] EraTransition
-> [Either Block EraTransition]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Block -> Either Block EraTransition)
-> [Block] -> [Either Block EraTransition]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Either Block EraTransition
forall a b. a -> Either a b
Left) ((Either Block EraTransition
-> [Either Block EraTransition] -> [Either Block EraTransition]
forall a. a -> [a] -> [a]
:[]) (Either Block EraTransition -> [Either Block EraTransition])
-> (EraTransition -> Either Block EraTransition)
-> EraTransition
-> [Either Block EraTransition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraTransition -> Either Block EraTransition
forall a b. b -> Either a b
Right)) ([Either [Block] EraTransition] -> [Either Block EraTransition])
-> (TestSetup xs -> [Either [Block] EraTransition])
-> TestSetup xs
-> [Either Block EraTransition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestEra] -> [Either [Block] EraTransition]
go ([TestEra] -> [Either [Block] EraTransition])
-> (TestSetup xs -> [TestEra])
-> TestSetup xs
-> [Either [Block] EraTransition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty xs TestEra -> [TestEra]
forall a. NonEmpty xs a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty xs TestEra -> [TestEra])
-> (TestSetup xs -> NonEmpty xs TestEra)
-> TestSetup xs
-> [TestEra]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup xs -> NonEmpty xs TestEra
forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testEras
  where
    go :: [TestEra] -> [Either [Block] EraTransition]
    go :: [TestEra] -> [Either [Block] EraTransition]
go []        = []
    go [TestEra
e]       = [[Block] -> Either [Block] EraTransition
forall a b. a -> Either a b
Left (TestEra -> [Block]
testEraBlocks TestEra
e)]
    go (TestEra
e:TestEra
e':[TestEra]
es) = [Block] -> Either [Block] EraTransition
forall a b. a -> Either a b
Left (TestEra -> [Block]
testEraBlocks TestEra
e)
                 Either [Block] EraTransition
-> [Either [Block] EraTransition] -> [Either [Block] EraTransition]
forall a. a -> [a] -> [a]
: EraTransition -> Either [Block] EraTransition
forall a b. b -> Either a b
Right (SlotNo -> EraTransition
EraTransition (Bound -> SlotNo
boundSlot (EraSummary -> Bound
eraStart (TestEra -> EraSummary
testEraSummary TestEra
e'))))
                 Either [Block] EraTransition
-> [Either [Block] EraTransition] -> [Either [Block] EraTransition]
forall a. a -> [a] -> [a]
: [TestEra] -> [Either [Block] EraTransition]
go (TestEra
e' TestEra -> [TestEra] -> [TestEra]
forall a. a -> [a] -> [a]
: [TestEra]
es)

-- | The ledger state at every 'SlotNo'
interpretChain :: TestSetup xs -> Map (WithOrigin SlotNo) LedgerState
interpretChain :: forall (xs :: [*]).
TestSetup xs -> Map (WithOrigin SlotNo) LedgerState
interpretChain setup :: TestSetup xs
setup@TestSetup{NonEmpty xs TestEra
Exactly xs MaxLookahead
TestForecastParams
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testLookahead :: Exactly xs MaxLookahead
testEras :: NonEmpty xs TestEra
testForecastParams :: TestForecastParams
..} =
    [(WithOrigin SlotNo, LedgerState)]
-> Map (WithOrigin SlotNo) LedgerState
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(WithOrigin SlotNo, LedgerState)]
 -> Map (WithOrigin SlotNo) LedgerState)
-> [(WithOrigin SlotNo, LedgerState)]
-> Map (WithOrigin SlotNo) LedgerState
forall a b. (a -> b) -> a -> b
$
        (WithOrigin SlotNo
forall t. WithOrigin t
Origin, LedgerState
initLedgerState)
      (WithOrigin SlotNo, LedgerState)
-> [(WithOrigin SlotNo, LedgerState)]
-> [(WithOrigin SlotNo, LedgerState)]
forall a. a -> [a] -> [a]
: SlotNo
-> LedgerState
-> [Either Block EraTransition]
-> [(WithOrigin SlotNo, LedgerState)]
go SlotNo
startSlot LedgerState
initLedgerState (TestSetup xs -> [Either Block EraTransition]
forall (xs :: [*]). TestSetup xs -> [Either Block EraTransition]
markTransitions TestSetup xs
setup)
  where
    -- The 'endSlot' is the max 'SlotNo' we might need a ledger state for
    startSlot, endSlot :: SlotNo
    startSlot :: SlotNo
startSlot = MaxLookahead -> SlotNo
SlotNo MaxLookahead
0
    endSlot :: SlotNo
endSlot   = SlotNo -> SlotNo -> SlotNo
forall a. Ord a => a -> a -> a
max (TestForecastParams -> SlotNo
testForecastWithinEra  TestForecastParams
testForecastParams)
                    (TestForecastParams -> SlotNo
testForecastAcrossEras TestForecastParams
testForecastParams)

    go :: SlotNo       -- Next expected slot
       -> LedgerState  -- Previous state
       -> [Either Block EraTransition]
       -> [(WithOrigin SlotNo, LedgerState)]
    go :: SlotNo
-> LedgerState
-> [Either Block EraTransition]
-> [(WithOrigin SlotNo, LedgerState)]
go SlotNo
curSlot LedgerState
prevLedger [] =
        SlotNo -> LedgerState -> [(WithOrigin SlotNo, LedgerState)]
pad SlotNo
curSlot LedgerState
prevLedger
    go SlotNo
curSlot LedgerState
prevLedger xs :: [Either Block EraTransition]
xs@(Left blk :: Block
blk@(Block SlotNo
s Scheduled
_):[Either Block EraTransition]
xs')
      | SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
curSlot = (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
curSlot, LedgerState
stepped) (WithOrigin SlotNo, LedgerState)
-> [(WithOrigin SlotNo, LedgerState)]
-> [(WithOrigin SlotNo, LedgerState)]
forall a. a -> [a] -> [a]
: SlotNo
-> LedgerState
-> [Either Block EraTransition]
-> [(WithOrigin SlotNo, LedgerState)]
go (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
curSlot) LedgerState
stepped [Either Block EraTransition]
xs
      | Bool
otherwise   = (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
curSlot, LedgerState
applied) (WithOrigin SlotNo, LedgerState)
-> [(WithOrigin SlotNo, LedgerState)]
-> [(WithOrigin SlotNo, LedgerState)]
forall a. a -> [a] -> [a]
: SlotNo
-> LedgerState
-> [Either Block EraTransition]
-> [(WithOrigin SlotNo, LedgerState)]
go (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
curSlot) LedgerState
applied [Either Block EraTransition]
xs'
      where
        stepped :: LedgerState
stepped = LedgerState -> LedgerState
stepLedgerState LedgerState
prevLedger
        ticked :: Ticked LedgerState
ticked  = SlotNo -> LedgerState -> Ticked LedgerState
tickLedgerState SlotNo
curSlot LedgerState
prevLedger
        applied :: LedgerState
applied = Block -> Ticked LedgerState -> LedgerState
applyBlock Block
blk Ticked LedgerState
ticked
    -- Applying the transition itself does not advance the slot
    -- (there might be a block in the very first slot in the next era)
    go SlotNo
curSlot LedgerState
prevLedger xs :: [Either Block EraTransition]
xs@(Right (EraTransition SlotNo
s):[Either Block EraTransition]
xs')
      | SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
curSlot = (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
curSlot, LedgerState
stepped) (WithOrigin SlotNo, LedgerState)
-> [(WithOrigin SlotNo, LedgerState)]
-> [(WithOrigin SlotNo, LedgerState)]
forall a. a -> [a] -> [a]
: SlotNo
-> LedgerState
-> [Either Block EraTransition]
-> [(WithOrigin SlotNo, LedgerState)]
go (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
curSlot) LedgerState
stepped [Either Block EraTransition]
xs
      | Bool
otherwise   =                                SlotNo
-> LedgerState
-> [Either Block EraTransition]
-> [(WithOrigin SlotNo, LedgerState)]
go       SlotNo
curSlot  LedgerState
doubled [Either Block EraTransition]
xs'
      where
        stepped :: LedgerState
stepped = LedgerState -> LedgerState
stepLedgerState    LedgerState
prevLedger
        doubled :: LedgerState
doubled = LedgerState -> LedgerState
translateToNextEra LedgerState
prevLedger

    -- After we have applied the final block, keep ticking the ledger state
    -- until we have reached the required 'SlotNo'
    pad :: SlotNo -> LedgerState -> [(WithOrigin SlotNo, LedgerState)]
    pad :: SlotNo -> LedgerState -> [(WithOrigin SlotNo, LedgerState)]
pad SlotNo
curSlot LedgerState
prevLedger
      | SlotNo
curSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
endSlot = []
      | Bool
otherwise         = (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
curSlot, LedgerState
stepped) (WithOrigin SlotNo, LedgerState)
-> [(WithOrigin SlotNo, LedgerState)]
-> [(WithOrigin SlotNo, LedgerState)]
forall a. a -> [a] -> [a]
: SlotNo -> LedgerState -> [(WithOrigin SlotNo, LedgerState)]
pad (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
curSlot) LedgerState
stepped
      where
        stepped :: LedgerState
stepped = LedgerState -> LedgerState
stepLedgerState LedgerState
prevLedger

{-------------------------------------------------------------------------------
  Test setup
-------------------------------------------------------------------------------}

data TestEra = TestEra {
      -- | Era summary (the 'EraParams' and bounds)
      --
      -- NOTE: The 'EraParams' (including associated safe zone) are independent
      -- from the lookahead, which is a property of the ledger ("how far into
      -- the future can we look and still know the ledger state"). The safe
      -- zones of the 'EraParams' only provide guarantees about when we can
      -- expect era transitions.
      TestEra -> EraSummary
testEraSummary      :: EraSummary

      -- | The maximum look ahead
      --
      -- The HFC itself does not impose any restrictions on the relation between
      -- the max lookahead of various eras. If the max lookahead in era B is
      -- smaller than the max lookahead in era A, this " merely " poses a
      -- problem for the translation function.
    , TestEra -> MaxLookahead
testEraMaxLookahead :: MaxLookahead

      -- | Blocks on the chain in this era
    , TestEra -> [Block]
testEraBlocks       :: [Block]
    }
  deriving (Int -> TestEra -> ShowS
[TestEra] -> ShowS
TestEra -> TestName
(Int -> TestEra -> ShowS)
-> (TestEra -> TestName) -> ([TestEra] -> ShowS) -> Show TestEra
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestEra -> ShowS
showsPrec :: Int -> TestEra -> ShowS
$cshow :: TestEra -> TestName
show :: TestEra -> TestName
$cshowList :: [TestEra] -> ShowS
showList :: [TestEra] -> ShowS
Show)

-- | The parameters for the forecast we construct
--
-- The forecast is constructed in a single era. The HFC combinator is
-- responsible for extending it across eras (that's precisely what we're
-- testing in this module, of course).
data TestForecastParams = TestForecastParams {
      -- | Anchor of the forecast
      TestForecastParams -> WithOrigin SlotNo
testForecastAt         :: WithOrigin SlotNo

      -- | An arbitrary slot number within the forecast's era
      --
      -- This is used as a sanity check to make sure that within-era
      -- forecasting works as expected.
      --
      -- Must be at or after 'testForecastAt'.
    , TestForecastParams -> SlotNo
testForecastWithinEra  :: SlotNo

      -- | An arbitrary slot after (or equal to) 'testForecastAt'
      --
      -- This is used to test the general case (across eras).
      -- Invariant: ahead of testForecastAt but not ahead by more than one era.
    , TestForecastParams -> SlotNo
testForecastAcrossEras :: SlotNo
    }
  deriving (Int -> TestForecastParams -> ShowS
[TestForecastParams] -> ShowS
TestForecastParams -> TestName
(Int -> TestForecastParams -> ShowS)
-> (TestForecastParams -> TestName)
-> ([TestForecastParams] -> ShowS)
-> Show TestForecastParams
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestForecastParams -> ShowS
showsPrec :: Int -> TestForecastParams -> ShowS
$cshow :: TestForecastParams -> TestName
show :: TestForecastParams -> TestName
$cshowList :: [TestForecastParams] -> ShowS
showList :: [TestForecastParams] -> ShowS
Show)

data TestSetup xs = (SListI xs, IsNonEmpty xs) => TestSetup {
      -- | The maximum lookahead in each era
      --
      -- We record this separately because the chain might terminate early
      -- (we might not have reached all eras yet), but these parameters /are/
      -- known for all eras (similar to how the HFC wants to know the era
      -- parameters for all eras)
      forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testLookahead      :: Exactly xs MaxLookahead

      -- | The test eras themselves
    , forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testEras           :: NonEmpty xs TestEra

      -- | The forecast we're constructing
    , forall (xs :: [*]). TestSetup xs -> TestForecastParams
testForecastParams :: TestForecastParams
    }

type MaxLookahead = Word64

deriving instance Show (TestSetup xs)
deriving instance Show (Some TestSetup)

{-------------------------------------------------------------------------------
  Invariant
-------------------------------------------------------------------------------}

validForecastParams :: TestSetup xs -> Either String ()
validForecastParams :: forall (xs :: [*]). TestSetup xs -> Either TestName ()
validForecastParams setup :: TestSetup xs
setup@TestSetup{NonEmpty xs TestEra
Exactly xs MaxLookahead
TestForecastParams
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testLookahead :: Exactly xs MaxLookahead
testEras :: NonEmpty xs TestEra
testForecastParams :: TestForecastParams
..} = Except TestName () -> Either TestName ()
forall e a. Except e a -> Either e a
runExcept (Except TestName () -> Either TestName ())
-> Except TestName () -> Either TestName ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> Except TestName () -> Except TestName ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WithOrigin SlotNo
testForecastAt WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
testForecastWithinEra) (Except TestName () -> Except TestName ())
-> Except TestName () -> Except TestName ()
forall a b. (a -> b) -> a -> b
$
      TestName -> Except TestName ()
forall a. TestName -> ExceptT TestName Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestName -> Except TestName ()) -> TestName -> Except TestName ()
forall a b. (a -> b) -> a -> b
$ [TestName] -> TestName
forall a. Monoid a => [a] -> a
mconcat [
          TestName
"'testForecastWithinEra' == "
        , SlotNo -> TestName
forall a. Show a => a -> TestName
show SlotNo
testForecastWithinEra
        , TestName
" not after 'testForecastAt' == "
        , WithOrigin SlotNo -> TestName
forall a. Show a => a -> TestName
show WithOrigin SlotNo
testForecastAt
        ]

    Bool -> Except TestName () -> Except TestName ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WithOrigin SlotNo
testForecastAt WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
testForecastAcrossEras) (Except TestName () -> Except TestName ())
-> Except TestName () -> Except TestName ()
forall a b. (a -> b) -> a -> b
$
      TestName -> Except TestName ()
forall a. TestName -> ExceptT TestName Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestName -> Except TestName ()) -> TestName -> Except TestName ()
forall a b. (a -> b) -> a -> b
$ [TestName] -> TestName
forall a. Monoid a => [a] -> a
mconcat [
          TestName
"'testForecastAcrossEras' == "
        , SlotNo -> TestName
forall a. Show a => a -> TestName
show SlotNo
testForecastAcrossEras
        , TestName
" not after 'testForecastAt' == "
        , WithOrigin SlotNo -> TestName
forall a. Show a => a -> TestName
show WithOrigin SlotNo
testForecastAt
        ]

    TestEra
era <- case TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra
forall (xs :: [*]).
TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra
slotEra' TestSetup xs
setup WithOrigin SlotNo
testForecastAt of
             Just TestEra
era -> TestEra -> ExceptT TestName Identity TestEra
forall a. a -> ExceptT TestName Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return TestEra
era
             Maybe TestEra
Nothing  -> TestName -> ExceptT TestName Identity TestEra
forall a. TestName -> ExceptT TestName Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestName -> ExceptT TestName Identity TestEra)
-> TestName -> ExceptT TestName Identity TestEra
forall a b. (a -> b) -> a -> b
$ [TestName] -> TestName
forall a. Monoid a => [a] -> a
mconcat [
                 TestName
"No era known for 'testForecastAt' == "
               , WithOrigin SlotNo -> TestName
forall a. Show a => a -> TestName
show WithOrigin SlotNo
testForecastAt
               ]

    Bool -> Except TestName () -> Except TestName ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WithOrigin SlotNo -> TestEra -> Bool
testEraContains (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
testForecastWithinEra) TestEra
era) (Except TestName () -> Except TestName ())
-> Except TestName () -> Except TestName ()
forall a b. (a -> b) -> a -> b
$
      TestName -> Except TestName ()
forall a. TestName -> ExceptT TestName Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestName -> Except TestName ()) -> TestName -> Except TestName ()
forall a b. (a -> b) -> a -> b
$ [TestName] -> TestName
forall a. Monoid a => [a] -> a
mconcat [
          TestName
"'testForecastWithinEra' == "
        , SlotNo -> TestName
forall a. Show a => a -> TestName
show SlotNo
testForecastWithinEra
        , TestName
" not in same era as 'testForecastAt' == "
        , WithOrigin SlotNo -> TestName
forall a. Show a => a -> TestName
show WithOrigin SlotNo
testForecastAt
        ]

    case TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra
forall (xs :: [*]).
TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra
slotEra' TestSetup xs
setup (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
testForecastAcrossEras) of
      Just TestEra
_  -> () -> Except TestName ()
forall a. a -> ExceptT TestName Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Maybe TestEra
Nothing -> TestName -> Except TestName ()
forall a. TestName -> ExceptT TestName Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TestName -> Except TestName ()) -> TestName -> Except TestName ()
forall a b. (a -> b) -> a -> b
$ [TestName] -> TestName
forall a. Monoid a => [a] -> a
mconcat [
          TestName
"No era known for 'testForecastAcrossEras' == "
        , SlotNo -> TestName
forall a. Show a => a -> TestName
show SlotNo
testForecastAcrossEras
        ]

    -- It would be nice to check that the "across eras" isn't ahead by more than
    -- one era (but that's a little tricky to do right now so we omit this
    -- check).
  where
    TestForecastParams{WithOrigin SlotNo
SlotNo
testForecastAt :: TestForecastParams -> WithOrigin SlotNo
testForecastWithinEra :: TestForecastParams -> SlotNo
testForecastAcrossEras :: TestForecastParams -> SlotNo
testForecastAt :: WithOrigin SlotNo
testForecastWithinEra :: SlotNo
testForecastAcrossEras :: SlotNo
..} = TestForecastParams
testForecastParams

{-------------------------------------------------------------------------------
  Query 'TestEra'
-------------------------------------------------------------------------------}

testEraContains :: WithOrigin SlotNo -> TestEra -> Bool
testEraContains :: WithOrigin SlotNo -> TestEra -> Bool
testEraContains WithOrigin SlotNo
mSlot TestEra{[Block]
MaxLookahead
EraSummary
testEraSummary :: TestEra -> EraSummary
testEraMaxLookahead :: TestEra -> MaxLookahead
testEraBlocks :: TestEra -> [Block]
testEraSummary :: EraSummary
testEraMaxLookahead :: MaxLookahead
testEraBlocks :: [Block]
..} = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [
      Bound -> SlotNo
boundSlot Bound
eraStart SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin (MaxLookahead -> SlotNo
SlotNo MaxLookahead
0) WithOrigin SlotNo
mSlot
    , case (WithOrigin SlotNo
mSlot, EraEnd
eraEnd) of
        (NotOrigin SlotNo
s, EraEnd Bound
end) -> SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< Bound -> SlotNo
boundSlot Bound
end
        (WithOrigin SlotNo, EraEnd)
_otherwise                -> Bool
True
    ]
  where
    EraSummary{EraParams
EraEnd
Bound
eraStart :: EraSummary -> Bound
eraEnd :: EraSummary -> EraEnd
eraStart :: Bound
eraEnd :: EraEnd
eraParams :: EraParams
eraParams :: EraSummary -> EraParams
..} = EraSummary
testEraSummary

{-------------------------------------------------------------------------------
  Query the 'TestSetup'
-------------------------------------------------------------------------------}

blocksPerEra :: TestSetup xs -> [[Block]]
blocksPerEra :: forall (xs :: [*]). TestSetup xs -> [[Block]]
blocksPerEra = (TestEra -> [Block]) -> [TestEra] -> [[Block]]
forall a b. (a -> b) -> [a] -> [b]
map TestEra -> [Block]
testEraBlocks ([TestEra] -> [[Block]])
-> (TestSetup xs -> [TestEra]) -> TestSetup xs -> [[Block]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty xs TestEra -> [TestEra]
forall a. NonEmpty xs a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty xs TestEra -> [TestEra])
-> (TestSetup xs -> NonEmpty xs TestEra)
-> TestSetup xs
-> [TestEra]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup xs -> NonEmpty xs TestEra
forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testEras

-- | Era containing the given slot, if any
slotEra' :: TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra
slotEra' :: forall (xs :: [*]).
TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra
slotEra' TestSetup{NonEmpty xs TestEra
Exactly xs MaxLookahead
TestForecastParams
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testLookahead :: Exactly xs MaxLookahead
testEras :: NonEmpty xs TestEra
testForecastParams :: TestForecastParams
..} WithOrigin SlotNo
mSlot =
    [TestEra] -> Maybe TestEra
forall a. [a] -> Maybe a
listToMaybe ([TestEra] -> Maybe TestEra) -> [TestEra] -> Maybe TestEra
forall a b. (a -> b) -> a -> b
$ (TestEra -> Bool) -> [TestEra] -> [TestEra]
forall a. (a -> Bool) -> [a] -> [a]
filter (WithOrigin SlotNo -> TestEra -> Bool
testEraContains WithOrigin SlotNo
mSlot) (NonEmpty xs TestEra -> [TestEra]
forall a. NonEmpty xs a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty xs TestEra
testEras)

-- | Wrapper around 'slotEra' to be used when the era should exist
slotEra :: HasCallStack => TestSetup xs -> WithOrigin SlotNo -> TestEra
slotEra :: forall (xs :: [*]).
(?callStack::CallStack) =>
TestSetup xs -> WithOrigin SlotNo -> TestEra
slotEra TestSetup xs
setup WithOrigin SlotNo
mSlot =
    case TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra
forall (xs :: [*]).
TestSetup xs -> WithOrigin SlotNo -> Maybe TestEra
slotEra' TestSetup xs
setup WithOrigin SlotNo
mSlot of
      Maybe TestEra
Nothing  -> TestName -> TestEra
forall a. (?callStack::CallStack) => TestName -> a
error (TestName -> TestEra) -> TestName -> TestEra
forall a b. (a -> b) -> a -> b
$ TestName
"slotEra: unknown slot " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ WithOrigin SlotNo -> TestName
forall a. Show a => a -> TestName
show WithOrigin SlotNo
mSlot
      Just TestEra
era -> TestEra
era

-- | Maximum lookahead of the ledger in the era containing the slot
slotMaxLookahead :: TestSetup xs -> WithOrigin SlotNo -> MaxLookahead
slotMaxLookahead :: forall (xs :: [*]).
TestSetup xs -> WithOrigin SlotNo -> MaxLookahead
slotMaxLookahead TestSetup xs
setup = TestEra -> MaxLookahead
testEraMaxLookahead (TestEra -> MaxLookahead)
-> (WithOrigin SlotNo -> TestEra)
-> WithOrigin SlotNo
-> MaxLookahead
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup xs -> WithOrigin SlotNo -> TestEra
forall (xs :: [*]).
(?callStack::CallStack) =>
TestSetup xs -> WithOrigin SlotNo -> TestEra
slotEra TestSetup xs
setup

-- | Check if two slots are in the same era
slotSameEra :: TestSetup xs -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
slotSameEra :: forall (xs :: [*]).
TestSetup xs -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
slotSameEra TestSetup xs
setup WithOrigin SlotNo
otherSlot = WithOrigin SlotNo -> TestEra -> Bool
testEraContains WithOrigin SlotNo
otherSlot (TestEra -> Bool)
-> (WithOrigin SlotNo -> TestEra) -> WithOrigin SlotNo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSetup xs -> WithOrigin SlotNo -> TestEra
forall (xs :: [*]).
(?callStack::CallStack) =>
TestSetup xs -> WithOrigin SlotNo -> TestEra
slotEra TestSetup xs
setup

{-------------------------------------------------------------------------------
  Generator
-------------------------------------------------------------------------------}

instance Arbitrary (Some TestSetup) where
  arbitrary :: Gen (Some TestSetup)
arbitrary = (forall (xs :: [*]).
 (SListI xs, IsNonEmpty xs) =>
 Eras xs -> Gen (Some TestSetup))
-> Gen (Some TestSetup)
forall r.
(forall (xs :: [*]).
 (SListI xs, IsNonEmpty xs) =>
 Eras xs -> Gen r)
-> Gen r
chooseEras ((forall (xs :: [*]).
  (SListI xs, IsNonEmpty xs) =>
  Eras xs -> Gen (Some TestSetup))
 -> Gen (Some TestSetup))
-> (forall (xs :: [*]).
    (SListI xs, IsNonEmpty xs) =>
    Eras xs -> Gen (Some TestSetup))
-> Gen (Some TestSetup)
forall a b. (a -> b) -> a -> b
$ \Eras xs
ixs -> do
      ProofNonEmpty{} <- ProofNonEmpty xs -> Gen (ProofNonEmpty xs)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProofNonEmpty xs -> Gen (ProofNonEmpty xs))
-> ProofNonEmpty xs -> Gen (ProofNonEmpty xs)
forall a b. (a -> b) -> a -> b
$ Eras xs -> ProofNonEmpty xs
forall {a} (xs :: [a]) (proxy :: [a] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
forall (proxy :: [*] -> *). proxy xs -> ProofNonEmpty xs
isNonEmpty Eras xs
ixs
      NonEmpty xs EraSummary
summary   <- Summary xs -> NonEmpty xs EraSummary
forall (xs :: [*]). Summary xs -> NonEmpty xs EraSummary
getSummary (Summary xs -> NonEmpty xs EraSummary)
-> Gen (Summary xs) -> Gen (NonEmpty xs EraSummary)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eras xs -> Gen (Summary xs)
forall (xs :: [*]). Eras xs -> Gen (Summary xs)
genSummary Eras xs
ixs
      Exactly xs MaxLookahead
lookahead <- NP (K Era) xs
-> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead)
forall era (xs :: [*]).
NP (K era) xs
-> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead)
genMaxLookahead (Eras xs -> NP (K Era) xs
forall (xs :: [*]). Eras xs -> NP (K Era) xs
eraIndices Eras xs
ixs) (NonEmpty xs EraSummary -> AtMost xs EraSummary
forall (xs :: [*]) a. NonEmpty xs a -> AtMost xs a
atMostFromNonEmpty NonEmpty xs EraSummary
summary)
      NonEmpty xs TestEra
eras      <- NonEmpty xs (Gen TestEra) -> Gen (NonEmpty xs TestEra)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a.
Monad m =>
NonEmpty xs (m a) -> m (NonEmpty xs a)
sequence (NonEmpty xs (Gen TestEra) -> Gen (NonEmpty xs TestEra))
-> NonEmpty xs (Gen TestEra) -> Gen (NonEmpty xs TestEra)
forall a b. (a -> b) -> a -> b
$
                      EraSummary -> MaxLookahead -> Gen TestEra
genTestEra (EraSummary -> MaxLookahead -> Gen TestEra)
-> NonEmpty xs EraSummary
-> NonEmpty xs (MaxLookahead -> Gen TestEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty xs EraSummary
summary
                                 NonEmpty xs (MaxLookahead -> Gen TestEra)
-> NonEmpty xs MaxLookahead -> NonEmpty xs (Gen TestEra)
forall a b. NonEmpty xs (a -> b) -> NonEmpty xs a -> NonEmpty xs b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exactly (x : xs1) MaxLookahead -> NonEmpty (x : xs1) MaxLookahead
forall x (xs :: [*]) a. Exactly (x : xs) a -> NonEmpty (x : xs) a
exactlyWeakenNonEmpty Exactly xs MaxLookahead
Exactly (x : xs1) MaxLookahead
lookahead
      TestForecastParams
forecast  <- [TestEra] -> Gen TestForecastParams
genForecastParams (NonEmpty xs TestEra -> [TestEra]
forall a. NonEmpty xs a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty xs TestEra
eras)
      Some TestSetup -> Gen (Some TestSetup)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Some TestSetup -> Gen (Some TestSetup))
-> Some TestSetup -> Gen (Some TestSetup)
forall a b. (a -> b) -> a -> b
$ TestSetup xs -> Some TestSetup
forall {k} (f :: k -> *) (a :: k). f a -> Some f
Some TestSetup{
          testLookahead :: Exactly xs MaxLookahead
testLookahead      = Exactly xs MaxLookahead
lookahead
        , testEras :: NonEmpty xs TestEra
testEras           = NonEmpty xs TestEra
eras
        , testForecastParams :: TestForecastParams
testForecastParams = TestForecastParams
forecast
        }
    where
      genMaxLookahead ::
           NP (K era) xs
        -> AtMost xs EraSummary
        -> Gen (Exactly xs MaxLookahead)
      genMaxLookahead :: forall era (xs :: [*]).
NP (K era) xs
-> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead)
genMaxLookahead NP (K era) xs
Nil AtMost xs EraSummary
_ =
          Exactly xs MaxLookahead -> Gen (Exactly xs MaxLookahead)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Exactly xs MaxLookahead
forall (xs :: [*]) a. (xs ~ '[]) => Exactly xs a
ExactlyNil
      genMaxLookahead (K era x
_ :* NP (K era) xs1
es) (AtMostCons EraSummary
s AtMost xs1 EraSummary
ss) = (MaxLookahead -> Gen (Exactly xs MaxLookahead))
-> Gen (Exactly xs MaxLookahead)
forall a. (MaxLookahead -> Gen a) -> Gen a
sized' ((MaxLookahead -> Gen (Exactly xs MaxLookahead))
 -> Gen (Exactly xs MaxLookahead))
-> (MaxLookahead -> Gen (Exactly xs MaxLookahead))
-> Gen (Exactly xs MaxLookahead)
forall a b. (a -> b) -> a -> b
$ \MaxLookahead
sz -> do
          MaxLookahead
l  <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead
forall a. Random a => (a, a) -> Gen a
choose (MaxLookahead
0, MaxLookahead
sz)

          -- Suppose an era lasts 10 slots
          --
          -- >           ~             ~
          -- > previous  ~  10 ... 19  ~  next
          -- >           ~             ~
          --
          -- If the maximum lookahead is 0, then if we are the last block
          -- of the previous era, we can't even forecast the ledger state for
          -- slot 10. If it's 1, we can forecast to 10; if it's 10, we can
          -- forecast to 19; but if it's 11, we can forecast to 20, which is
          -- the /next next/ era. We don't currently support this, and so
          -- we avoid generating this edge case.

          let l' :: MaxLookahead
l' = case EraSummary -> EraEnd
eraEnd EraSummary
s of
                     EraEnd
EraUnbounded -> MaxLookahead
l
                     EraEnd Bound
end   -> MaxLookahead -> MaxLookahead -> MaxLookahead
forall a. Ord a => a -> a -> a
min MaxLookahead
l (MaxLookahead -> MaxLookahead) -> MaxLookahead -> MaxLookahead
forall a b. (a -> b) -> a -> b
$
                         (?callStack::CallStack) => SlotNo -> SlotNo -> MaxLookahead
SlotNo -> SlotNo -> MaxLookahead
countSlots
                           (Bound -> SlotNo
boundSlot Bound
end)
                           (Bound -> SlotNo
boundSlot (EraSummary -> Bound
eraStart EraSummary
s))

          Exactly xs1 MaxLookahead
ls <- NP (K era) xs1
-> AtMost xs1 EraSummary -> Gen (Exactly xs1 MaxLookahead)
forall era (xs :: [*]).
NP (K era) xs
-> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead)
genMaxLookahead NP (K era) xs1
es AtMost xs1 EraSummary
AtMost xs1 EraSummary
ss
          Exactly xs MaxLookahead -> Gen (Exactly xs MaxLookahead)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaxLookahead -> Exactly xs1 MaxLookahead -> Exactly xs MaxLookahead
forall (xs' :: [*]) a x (xs :: [*]).
(xs' ~ (x : xs)) =>
a -> Exactly xs a -> Exactly xs' a
ExactlyCons MaxLookahead
l' Exactly xs1 MaxLookahead
ls)
      genMaxLookahead (K era x
_ :* NP (K era) xs1
es) AtMost xs EraSummary
AtMostNil = (MaxLookahead -> Gen (Exactly xs MaxLookahead))
-> Gen (Exactly xs MaxLookahead)
forall a. (MaxLookahead -> Gen a) -> Gen a
sized' ((MaxLookahead -> Gen (Exactly xs MaxLookahead))
 -> Gen (Exactly xs MaxLookahead))
-> (MaxLookahead -> Gen (Exactly xs MaxLookahead))
-> Gen (Exactly xs MaxLookahead)
forall a b. (a -> b) -> a -> b
$ \MaxLookahead
sz -> do
          MaxLookahead
l  <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead
forall a. Random a => (a, a) -> Gen a
choose (MaxLookahead
0, MaxLookahead
sz)
          Exactly xs1 MaxLookahead
ls <- NP (K era) xs1
-> AtMost xs1 EraSummary -> Gen (Exactly xs1 MaxLookahead)
forall era (xs :: [*]).
NP (K era) xs
-> AtMost xs EraSummary -> Gen (Exactly xs MaxLookahead)
genMaxLookahead NP (K era) xs1
es AtMost xs1 EraSummary
forall (xs :: [*]) a. AtMost xs a
AtMostNil
          Exactly xs MaxLookahead -> Gen (Exactly xs MaxLookahead)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaxLookahead -> Exactly xs1 MaxLookahead -> Exactly xs MaxLookahead
forall (xs' :: [*]) a x (xs :: [*]).
(xs' ~ (x : xs)) =>
a -> Exactly xs a -> Exactly xs' a
ExactlyCons MaxLookahead
l Exactly xs1 MaxLookahead
ls)

      genTestEra :: EraSummary -> MaxLookahead -> Gen TestEra
      genTestEra :: EraSummary -> MaxLookahead -> Gen TestEra
genTestEra summary :: EraSummary
summary@EraSummary{EraParams
EraEnd
Bound
eraStart :: EraSummary -> Bound
eraEnd :: EraSummary -> EraEnd
eraParams :: EraSummary -> EraParams
eraStart :: Bound
eraEnd :: EraEnd
eraParams :: EraParams
..} MaxLookahead
maxLookahead = (MaxLookahead -> Gen TestEra) -> Gen TestEra
forall a. (MaxLookahead -> Gen a) -> Gen a
sized' ((MaxLookahead -> Gen TestEra) -> Gen TestEra)
-> (MaxLookahead -> Gen TestEra) -> Gen TestEra
forall a b. (a -> b) -> a -> b
$ \MaxLookahead
sz -> do
          Bound
upperBound   <- case EraEnd
eraEnd of
            EraEnd Bound
bound -> Bound -> Gen Bound
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Bound
bound
            EraEnd
EraUnbounded -> EraParams -> Bound -> MaxLookahead -> Bound
mkUpperBound EraParams
eraParams Bound
eraStart (MaxLookahead -> Bound) -> Gen MaxLookahead -> Gen Bound
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MaxLookahead, MaxLookahead) -> Gen MaxLookahead
forall a. Random a => (a, a) -> Gen a
choose (MaxLookahead
0, MaxLookahead
sz)
          [Maybe Block]
mBlocks <- [SlotNo] -> (SlotNo -> Gen (Maybe Block)) -> Gen [Maybe Block]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (SlotNo -> SlotNo -> [SlotNo]
forall a. (Ord a, Enum a) => a -> a -> [a]
enumIncExc (Bound -> SlotNo
boundSlot Bound
eraStart) (Bound -> SlotNo
boundSlot Bound
upperBound)) ((SlotNo -> Gen (Maybe Block)) -> Gen [Maybe Block])
-> (SlotNo -> Gen (Maybe Block)) -> Gen [Maybe Block]
forall a b. (a -> b) -> a -> b
$ \SlotNo
slot -> do
            Bool
slotFilled <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
            if Bool
slotFilled then do
              Scheduled
scheduled <- MaxLookahead -> SlotNo -> Gen Scheduled
genScheduled MaxLookahead
maxLookahead SlotNo
slot
              Maybe Block -> Gen (Maybe Block)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Block -> Gen (Maybe Block))
-> Maybe Block -> Gen (Maybe Block)
forall a b. (a -> b) -> a -> b
$ Block -> Maybe Block
forall a. a -> Maybe a
Just (SlotNo -> Scheduled -> Block
Block SlotNo
slot Scheduled
scheduled)
            else
              Maybe Block -> Gen (Maybe Block)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Block
forall a. Maybe a
Nothing
          TestEra -> Gen TestEra
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return TestEra {
              testEraSummary :: EraSummary
testEraSummary      = EraSummary
summary
            , testEraMaxLookahead :: MaxLookahead
testEraMaxLookahead = MaxLookahead
maxLookahead
            , testEraBlocks :: [Block]
testEraBlocks       = [Maybe Block] -> [Block]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Block]
mBlocks
            }

      genScheduled :: MaxLookahead -> SlotNo -> Gen Scheduled
      genScheduled :: MaxLookahead -> SlotNo -> Gen Scheduled
genScheduled MaxLookahead
maxLookahead SlotNo
slotBlock = do
          Int
numChanges <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
2)
          ([(SlotNo, LedgerUpdate)] -> Scheduled)
-> Gen [(SlotNo, LedgerUpdate)] -> Gen Scheduled
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(SlotNo, LedgerUpdate)] -> Scheduled
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Gen [(SlotNo, LedgerUpdate)] -> Gen Scheduled)
-> Gen [(SlotNo, LedgerUpdate)] -> Gen Scheduled
forall a b. (a -> b) -> a -> b
$
            Int -> Gen (SlotNo, LedgerUpdate) -> Gen [(SlotNo, LedgerUpdate)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numChanges (Gen (SlotNo, LedgerUpdate) -> Gen [(SlotNo, LedgerUpdate)])
-> Gen (SlotNo, LedgerUpdate) -> Gen [(SlotNo, LedgerUpdate)]
forall a b. (a -> b) -> a -> b
$ MaxLookahead -> SlotNo -> Gen (SlotNo, LedgerUpdate)
genChange MaxLookahead
maxLookahead SlotNo
slotBlock

      genChange :: MaxLookahead -> SlotNo -> Gen (SlotNo, LedgerUpdate)
      genChange :: MaxLookahead -> SlotNo -> Gen (SlotNo, LedgerUpdate)
genChange MaxLookahead
maxLookahead SlotNo
slotBlock = (MaxLookahead -> Gen (SlotNo, LedgerUpdate))
-> Gen (SlotNo, LedgerUpdate)
forall a. (MaxLookahead -> Gen a) -> Gen a
sized' ((MaxLookahead -> Gen (SlotNo, LedgerUpdate))
 -> Gen (SlotNo, LedgerUpdate))
-> (MaxLookahead -> Gen (SlotNo, LedgerUpdate))
-> Gen (SlotNo, LedgerUpdate)
forall a b. (a -> b) -> a -> b
$ \MaxLookahead
sz -> do
          MaxLookahead
skip     <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead
forall a. Random a => (a, a) -> Gen a
choose (MaxLookahead
0, MaxLookahead
sz)
          MaxLookahead
increase <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead
forall a. Random a => (a, a) -> Gen a
choose (MaxLookahead
0, MaxLookahead
2)
          -- If the maxLookahead is zero (no look ahead possible), the change
          -- is applied when we apply the block (i.e., in the same slot).
          let slotChange :: SlotNo
slotChange = MaxLookahead -> SlotNo -> SlotNo
addSlots (MaxLookahead
maxLookahead MaxLookahead -> MaxLookahead -> MaxLookahead
forall a. Num a => a -> a -> a
+ MaxLookahead
skip) SlotNo
slotBlock
          (SlotNo, LedgerUpdate) -> Gen (SlotNo, LedgerUpdate)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo
slotChange, MaxLookahead -> LedgerUpdate
IncreaseValueBy MaxLookahead
increase)

      -- Construct an upper bound for an era, given number of epochs
      mkUpperBound :: EraParams -> Bound -> Word64 -> Bound
      mkUpperBound :: EraParams -> Bound -> MaxLookahead -> Bound
mkUpperBound EraParams
eraParams Bound
eraStart =
            (?callStack::CallStack) => EraParams -> Bound -> EpochNo -> Bound
EraParams -> Bound -> EpochNo -> Bound
History.mkUpperBound EraParams
eraParams Bound
eraStart
          (EpochNo -> Bound)
-> (MaxLookahead -> EpochNo) -> MaxLookahead -> Bound
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MaxLookahead -> EpochNo -> EpochNo)
-> EpochNo -> MaxLookahead -> EpochNo
forall a b c. (a -> b -> c) -> b -> a -> c
flip MaxLookahead -> EpochNo -> EpochNo
addEpochs (Bound -> EpochNo
boundEpoch Bound
eraStart)

      genForecastParams :: [TestEra] -> Gen TestForecastParams
      genForecastParams :: [TestEra] -> Gen TestForecastParams
genForecastParams [TestEra]
eras = (MaxLookahead -> Gen TestForecastParams) -> Gen TestForecastParams
forall a. (MaxLookahead -> Gen a) -> Gen a
sized' ((MaxLookahead -> Gen TestForecastParams)
 -> Gen TestForecastParams)
-> (MaxLookahead -> Gen TestForecastParams)
-> Gen TestForecastParams
forall a b. (a -> b) -> a -> b
$ \MaxLookahead
sz -> do
          -- Pick an era for the forecast
          (Bool
isFirstEra, TestEra
anchorEra) <- [(Bool, TestEra)] -> Gen (Bool, TestEra)
forall a. (?callStack::CallStack) => [a] -> Gen a
elements ([(Bool, TestEra)] -> Gen (Bool, TestEra))
-> [(Bool, TestEra)] -> Gen (Bool, TestEra)
forall a b. (a -> b) -> a -> b
$ [Bool] -> [TestEra] -> [(Bool, TestEra)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False) [TestEra]
eras

          let anchorEraStart :: Bound
anchorEraStart = EraSummary -> Bound
eraStart (EraSummary -> Bound) -> EraSummary -> Bound
forall a b. (a -> b) -> a -> b
$ TestEra -> EraSummary
testEraSummary TestEra
anchorEra
              anchorEraEnd :: EraEnd
anchorEraEnd   = EraSummary -> EraEnd
eraEnd   (EraSummary -> EraEnd) -> EraSummary -> EraEnd
forall a b. (a -> b) -> a -> b
$ TestEra -> EraSummary
testEraSummary TestEra
anchorEra

          -- Pick an anchor
          WithOrigin SlotNo
at <- [Gen (WithOrigin SlotNo)] -> Gen (WithOrigin SlotNo)
forall a. [Gen a] -> Gen a
oneof ([Gen (WithOrigin SlotNo)] -> Gen (WithOrigin SlotNo))
-> [Gen (WithOrigin SlotNo)] -> Gen (WithOrigin SlotNo)
forall a b. (a -> b) -> a -> b
$ [[Gen (WithOrigin SlotNo)]] -> [Gen (WithOrigin SlotNo)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
              [ (SlotNo -> WithOrigin SlotNo)
-> Gen SlotNo -> Gen (WithOrigin SlotNo)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin (Gen SlotNo -> Gen (WithOrigin SlotNo))
-> Gen SlotNo -> Gen (WithOrigin SlotNo)
forall a b. (a -> b) -> a -> b
$ [SlotNo] -> Gen SlotNo
forall a. (?callStack::CallStack) => [a] -> Gen a
elements ([SlotNo] -> Gen SlotNo) -> [SlotNo] -> Gen SlotNo
forall a b. (a -> b) -> a -> b
$
                  SlotNo -> SlotNo -> [SlotNo]
forall a. (Ord a, Enum a) => a -> a -> [a]
enumIncExc
                    (Bound -> SlotNo
boundSlot Bound
anchorEraStart)
                    (Bound -> SlotNo
boundSlot Bound
end)
              | EraEnd Bound
end <- [EraEnd
anchorEraEnd]
              ]

            , [ do MaxLookahead
upperBound <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead
forall a. Random a => (a, a) -> Gen a
choose (MaxLookahead
1, MaxLookahead
1 MaxLookahead -> MaxLookahead -> MaxLookahead
forall a. Num a => a -> a -> a
+ MaxLookahead
sz) -- upper bound is exclusive
                   (SlotNo -> WithOrigin SlotNo)
-> Gen SlotNo -> Gen (WithOrigin SlotNo)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin (Gen SlotNo -> Gen (WithOrigin SlotNo))
-> Gen SlotNo -> Gen (WithOrigin SlotNo)
forall a b. (a -> b) -> a -> b
$ [SlotNo] -> Gen SlotNo
forall a. (?callStack::CallStack) => [a] -> Gen a
elements ([SlotNo] -> Gen SlotNo) -> [SlotNo] -> Gen SlotNo
forall a b. (a -> b) -> a -> b
$
                     SlotNo -> SlotNo -> [SlotNo]
forall a. (Ord a, Enum a) => a -> a -> [a]
enumIncExc
                       (Bound -> SlotNo
boundSlot Bound
anchorEraStart)
                       (MaxLookahead -> SlotNo -> SlotNo
addSlots MaxLookahead
upperBound (Bound -> SlotNo
boundSlot Bound
anchorEraStart))
              | EraEnd
EraUnbounded <- [EraEnd
anchorEraEnd]
              ]

            , [ WithOrigin SlotNo -> Gen (WithOrigin SlotNo)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return WithOrigin SlotNo
forall t. WithOrigin t
Origin
              | Bool
isFirstEra
              ]
            ]

          -- Pick a slot within the same era
          -- (for within-era forecast sanity check)
          let at' :: SlotNo
at' = SlotNo -> WithOrigin SlotNo -> SlotNo
forall t. t -> WithOrigin t -> t
fromWithOrigin (MaxLookahead -> SlotNo
SlotNo MaxLookahead
0) WithOrigin SlotNo
at
          SlotNo
withinEra <- SlotNo -> EraEnd -> Gen SlotNo
pickSlotBetween SlotNo
at' EraEnd
anchorEraEnd

          -- For any slot after the anchor
          let finalEra :: TestEra
finalEra    = [TestEra] -> TestEra
forall a. (?callStack::CallStack) => [a] -> a
last [TestEra]
eras
              finalEraEnd :: EraEnd
finalEraEnd = EraSummary -> EraEnd
eraEnd (EraSummary -> EraEnd) -> EraSummary -> EraEnd
forall a b. (a -> b) -> a -> b
$ TestEra -> EraSummary
testEraSummary TestEra
finalEra
          SlotNo
acrossEras <- SlotNo -> EraEnd -> Gen SlotNo
pickSlotBetween SlotNo
at' EraEnd
finalEraEnd

          TestForecastParams -> Gen TestForecastParams
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return TestForecastParams {
              testForecastAt :: WithOrigin SlotNo
testForecastAt         = WithOrigin SlotNo
at
            , testForecastWithinEra :: SlotNo
testForecastWithinEra  = SlotNo
withinEra
            , testForecastAcrossEras :: SlotNo
testForecastAcrossEras = SlotNo
acrossEras
            }

      pickSlotBetween :: SlotNo -> EraEnd -> Gen SlotNo
      pickSlotBetween :: SlotNo -> EraEnd -> Gen SlotNo
pickSlotBetween SlotNo
lo EraEnd
hi = (MaxLookahead -> Gen SlotNo) -> Gen SlotNo
forall a. (MaxLookahead -> Gen a) -> Gen a
sized' ((MaxLookahead -> Gen SlotNo) -> Gen SlotNo)
-> (MaxLookahead -> Gen SlotNo) -> Gen SlotNo
forall a b. (a -> b) -> a -> b
$ \MaxLookahead
sz -> [Gen SlotNo] -> Gen SlotNo
forall a. [Gen a] -> Gen a
oneof ([Gen SlotNo] -> Gen SlotNo) -> [Gen SlotNo] -> Gen SlotNo
forall a b. (a -> b) -> a -> b
$ [[Gen SlotNo]] -> [Gen SlotNo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
            [ [SlotNo] -> Gen SlotNo
forall a. (?callStack::CallStack) => [a] -> Gen a
elements ([SlotNo] -> Gen SlotNo) -> [SlotNo] -> Gen SlotNo
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> [SlotNo]
forall a. (Ord a, Enum a) => a -> a -> [a]
enumIncExc SlotNo
lo (Bound -> SlotNo
boundSlot Bound
end)
            | EraEnd Bound
end <- [EraEnd
hi]
            ]

          , [ do MaxLookahead
upperBound <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead
forall a. Random a => (a, a) -> Gen a
choose (MaxLookahead
1, MaxLookahead
1 MaxLookahead -> MaxLookahead -> MaxLookahead
forall a. Num a => a -> a -> a
+ MaxLookahead
sz) -- upper bound is exclusive
                 [SlotNo] -> Gen SlotNo
forall a. (?callStack::CallStack) => [a] -> Gen a
elements ([SlotNo] -> Gen SlotNo) -> [SlotNo] -> Gen SlotNo
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> [SlotNo]
forall a. (Ord a, Enum a) => a -> a -> [a]
enumIncExc SlotNo
lo (MaxLookahead -> SlotNo -> SlotNo
addSlots MaxLookahead
upperBound SlotNo
lo)
            | EraEnd
EraUnbounded <- [EraEnd
hi]
            ]
          ]

  -- We make some effort towards a good shrinker, but there is a lot we could
  -- still do to improve it:
  --
  -- o We could drop some eras entirely
  -- o We could shift the era bounds
  -- o We could shrink the maximum lookahead in the individual eras
  --
  -- The tricky part is to do this without violating some of the invariants
  -- that we established in the generator:
  --
  -- o The era of the forecast anchor might not exist anymore
  -- o Due to reducing the bounds of an era, the within-era 'at' might not
  --   actually be within-era anymore
  -- o Due to a reduction in the max lookahead, a forecast might now exceed the
  --   maximum.
  -- o Due to shrinking an era's size, the lookahead might now exceed the
  --   era length (see comment above regarding forecasting across multiple eras)
  -- o By shrinking the anchor of the forecast, it might not be in the same era
  --   as the within-era 'at' anymore.
  shrink :: Some TestSetup -> [Some TestSetup]
shrink (Some setup :: TestSetup a
setup@TestSetup{NonEmpty a TestEra
Exactly a MaxLookahead
TestForecastParams
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testLookahead :: Exactly a MaxLookahead
testEras :: NonEmpty a TestEra
testForecastParams :: TestForecastParams
..}) = [[Some TestSetup]] -> [Some TestSetup]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
        -- Shrink the eras
        [ TestSetup a -> Some TestSetup
forall {k} (f :: k -> *) (a :: k). f a -> Some f
Some TestSetup a
setup'
        | NonEmpty a TestEra
eras' <- NonEmpty a TestEra -> [NonEmpty a TestEra]
forall (xs :: [*]). NonEmpty xs TestEra -> [NonEmpty xs TestEra]
shrinkEras NonEmpty a TestEra
testEras
        , let setup' :: TestSetup a
setup' = TestSetup a
setup { testEras = eras' }
        ]

        -- Shrink the forecast params
      , [ TestSetup a -> Some TestSetup
forall {k} (f :: k -> *) (a :: k). f a -> Some f
Some TestSetup a
setup'
        | TestForecastParams
params' <- TestForecastParams -> [TestForecastParams]
shrinkForecastParams TestForecastParams
testForecastParams
        , let setup' :: TestSetup a
setup' = TestSetup a
setup { testForecastParams = params' }
        ]
      ]
    where
      shrinkEras :: NonEmpty xs TestEra -> [NonEmpty xs TestEra]
      shrinkEras :: forall (xs :: [*]). NonEmpty xs TestEra -> [NonEmpty xs TestEra]
shrinkEras NonEmpty xs TestEra
eras = [[NonEmpty xs TestEra]] -> [NonEmpty xs TestEra]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
            -- Shrink one era
            (TestEra -> [TestEra])
-> NonEmpty xs TestEra -> [NonEmpty xs TestEra]
forall (m :: * -> *) (xs :: [*]) a.
Alternative m =>
(a -> m a) -> NonEmpty xs a -> m (NonEmpty xs a)
nonEmptyMapOne TestEra -> [TestEra]
shrinkEra NonEmpty xs TestEra
eras
          ]

      shrinkEra :: TestEra -> [TestEra]
      shrinkEra :: TestEra -> [TestEra]
shrinkEra era :: TestEra
era@TestEra{[Block]
MaxLookahead
EraSummary
testEraSummary :: TestEra -> EraSummary
testEraMaxLookahead :: TestEra -> MaxLookahead
testEraBlocks :: TestEra -> [Block]
testEraSummary :: EraSummary
testEraMaxLookahead :: MaxLookahead
testEraBlocks :: [Block]
..} = [[TestEra]] -> [TestEra]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
            -- Drop some blocks
            [ TestEra
era'
            | [Block]
blocks' <- (Block -> [Block]) -> [Block] -> [[Block]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([Block] -> Block -> [Block]
forall a b. a -> b -> a
const []) [Block]
testEraBlocks
            , let era' :: TestEra
era' = TestEra
era { testEraBlocks = blocks' }
            ]

            -- Shrink blocks
            --
            -- We don't use shrinkList for this, because we need some context
          , [ TestEra
era'
            | ([Block]
xs, Block
y, [Block]
zs) <- [Block] -> [([Block], Block, [Block])]
forall a. [a] -> [([a], a, [a])]
splits [Block]
testEraBlocks
            , let prev :: Maybe Block
prev | [Block] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
xs   = Maybe Block
forall a. Maybe a
Nothing
                       | Bool
otherwise = Block -> Maybe Block
forall a. a -> Maybe a
Just ([Block] -> Block
forall a. (?callStack::CallStack) => [a] -> a
last [Block]
xs)
            , Block
y' <- EraSummary -> MaxLookahead -> Maybe Block -> Block -> [Block]
shrinkBlock EraSummary
testEraSummary MaxLookahead
testEraMaxLookahead Maybe Block
prev Block
y
            , let era' :: TestEra
era' = TestEra
era { testEraBlocks = xs ++ [y'] ++ zs }
            ]
          ]

      shrinkBlock :: EraSummary -> MaxLookahead -> Maybe Block -> Block -> [Block]
      shrinkBlock :: EraSummary -> MaxLookahead -> Maybe Block -> Block -> [Block]
shrinkBlock EraSummary
summary MaxLookahead
maxLookahead Maybe Block
mPrev (Block (SlotNo MaxLookahead
slot) Scheduled
scheduled) = [[Block]] -> [Block]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
            -- Move the block earlier into the era
            --
            -- NOTE: Moving a block _earlier_ into the chain can't violate
            -- the max-lookahead, as the distance between the block and the
            -- change can only _increase_
            [ SlotNo -> Scheduled -> Block
Block SlotNo
slot' Scheduled
scheduled
            | SlotNo
slot' <- (MaxLookahead -> SlotNo) -> [MaxLookahead] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map MaxLookahead -> SlotNo
SlotNo ([MaxLookahead] -> [SlotNo]) -> [MaxLookahead] -> [SlotNo]
forall a b. (a -> b) -> a -> b
$ MaxLookahead -> [MaxLookahead]
forall a. Arbitrary a => a -> [a]
shrink MaxLookahead
slot
              -- Don't clash with the previous block
            , case Maybe Block
mPrev of
                Just (Block SlotNo
prevSlot Scheduled
_) -> SlotNo
slot' SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
prevSlot
                Maybe Block
Nothing                 -> Bool
True
              -- Don't move block out of this era
            , SlotNo
slot' SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= Bound -> SlotNo
boundSlot (EraSummary -> Bound
eraStart EraSummary
summary)
            ]

            -- Shrink the block body
          , [ SlotNo -> Scheduled -> Block
Block (MaxLookahead -> SlotNo
SlotNo MaxLookahead
slot) Scheduled
scheduled'
            | Scheduled
scheduled' <- MaxLookahead -> SlotNo -> Scheduled -> [Scheduled]
shrinkScheduled MaxLookahead
maxLookahead (MaxLookahead -> SlotNo
SlotNo MaxLookahead
slot) Scheduled
scheduled
            ]
          ]

      shrinkScheduled :: MaxLookahead -> SlotNo -> Scheduled -> [Scheduled]
      shrinkScheduled :: MaxLookahead -> SlotNo -> Scheduled -> [Scheduled]
shrinkScheduled MaxLookahead
maxLookahead SlotNo
slotBlock =
            ([(SlotNo, LedgerUpdate)] -> Scheduled)
-> [[(SlotNo, LedgerUpdate)]] -> [Scheduled]
forall a b. (a -> b) -> [a] -> [b]
map [(SlotNo, LedgerUpdate)] -> Scheduled
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          ([[(SlotNo, LedgerUpdate)]] -> [Scheduled])
-> (Scheduled -> [[(SlotNo, LedgerUpdate)]])
-> Scheduled
-> [Scheduled]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SlotNo, LedgerUpdate) -> [(SlotNo, LedgerUpdate)])
-> [(SlotNo, LedgerUpdate)] -> [[(SlotNo, LedgerUpdate)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (SlotNo, LedgerUpdate) -> [(SlotNo, LedgerUpdate)]
shrinkUpdate
          ([(SlotNo, LedgerUpdate)] -> [[(SlotNo, LedgerUpdate)]])
-> (Scheduled -> [(SlotNo, LedgerUpdate)])
-> Scheduled
-> [[(SlotNo, LedgerUpdate)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scheduled -> [(SlotNo, LedgerUpdate)]
forall k a. Map k a -> [(k, a)]
Map.toList
        where
          shrinkUpdate :: (SlotNo, LedgerUpdate) -> [(SlotNo, LedgerUpdate)]
          shrinkUpdate :: (SlotNo, LedgerUpdate) -> [(SlotNo, LedgerUpdate)]
shrinkUpdate (SlotNo MaxLookahead
slotUpdate, update :: LedgerUpdate
update@(IncreaseValueBy MaxLookahead
newLedgerValue)) = [[(SlotNo, LedgerUpdate)]] -> [(SlotNo, LedgerUpdate)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                -- Shrink the ledger value (complicated ledger values distract)
                [ (MaxLookahead -> SlotNo
SlotNo MaxLookahead
slotUpdate, MaxLookahead -> LedgerUpdate
IncreaseValueBy MaxLookahead
newLedgerValue')
                | MaxLookahead
newLedgerValue' <- MaxLookahead -> [MaxLookahead]
forall a. Arbitrary a => a -> [a]
shrink MaxLookahead
newLedgerValue
                ]

                -- Try to do the update sooner
              , [ (SlotNo
slotUpdate', LedgerUpdate
update)
                | SlotNo
slotUpdate' <- (MaxLookahead -> SlotNo) -> [MaxLookahead] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map MaxLookahead -> SlotNo
SlotNo ([MaxLookahead] -> [SlotNo]) -> [MaxLookahead] -> [SlotNo]
forall a b. (a -> b) -> a -> b
$ MaxLookahead -> [MaxLookahead]
forall a. Arbitrary a => a -> [a]
shrink MaxLookahead
slotUpdate
                  -- The earliest it can change is the very next slot
                , SlotNo
slotUpdate' SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
slotBlock
                  -- We must still obey the maxLookahead though
                , (?callStack::CallStack) => SlotNo -> SlotNo -> MaxLookahead
SlotNo -> SlotNo -> MaxLookahead
countSlots SlotNo
slotUpdate' SlotNo
slotBlock MaxLookahead -> MaxLookahead -> Bool
forall a. Ord a => a -> a -> Bool
> MaxLookahead
maxLookahead
                ]
              ]

      shrinkForecastParams :: TestForecastParams -> [TestForecastParams]
      shrinkForecastParams :: TestForecastParams -> [TestForecastParams]
shrinkForecastParams params :: TestForecastParams
params@TestForecastParams{WithOrigin SlotNo
SlotNo
testForecastAt :: TestForecastParams -> WithOrigin SlotNo
testForecastWithinEra :: TestForecastParams -> SlotNo
testForecastAcrossEras :: TestForecastParams -> SlotNo
testForecastAt :: WithOrigin SlotNo
testForecastWithinEra :: SlotNo
testForecastAcrossEras :: SlotNo
..} = [[TestForecastParams]] -> [TestForecastParams]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
            [ TestForecastParams
params'
            | WithOrigin SlotNo
at' <- WithOrigin SlotNo -> [WithOrigin SlotNo]
shrinkSlotNo' WithOrigin SlotNo
testForecastAt
            , TestSetup a -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall (xs :: [*]).
TestSetup xs -> WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
slotSameEra TestSetup a
setup WithOrigin SlotNo
at' (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
testForecastWithinEra)
            , let params' :: TestForecastParams
params' = TestForecastParams
params { testForecastAt = at' }
            ]

          , [ TestForecastParams
params'
            | SlotNo
withinEra' <- SlotNo -> [SlotNo]
shrinkSlotNo SlotNo
testForecastWithinEra
            , SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
withinEra' WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= WithOrigin SlotNo
testForecastAt
            , let params' :: TestForecastParams
params' = TestForecastParams
params { testForecastWithinEra = withinEra' }
            ]

          , [ TestForecastParams
params'
            | SlotNo
acrossEras' <- SlotNo -> [SlotNo]
shrinkSlotNo SlotNo
testForecastAcrossEras
            , SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
acrossEras' WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= WithOrigin SlotNo
testForecastAt
            , let params' :: TestForecastParams
params' = TestForecastParams
params { testForecastAcrossEras = acrossEras' }
            ]
          ]

      shrinkSlotNo' :: WithOrigin SlotNo -> [WithOrigin SlotNo]
      shrinkSlotNo' :: WithOrigin SlotNo -> [WithOrigin SlotNo]
shrinkSlotNo' WithOrigin SlotNo
Origin        = []
      shrinkSlotNo' (NotOrigin SlotNo
s) = WithOrigin SlotNo
forall t. WithOrigin t
Origin WithOrigin SlotNo -> [WithOrigin SlotNo] -> [WithOrigin SlotNo]
forall a. a -> [a] -> [a]
: (SlotNo -> WithOrigin SlotNo) -> [SlotNo] -> [WithOrigin SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin (SlotNo -> [SlotNo]
shrinkSlotNo SlotNo
s)

      shrinkSlotNo :: SlotNo -> [SlotNo]
      shrinkSlotNo :: SlotNo -> [SlotNo]
shrinkSlotNo (SlotNo MaxLookahead
s) = (MaxLookahead -> SlotNo) -> [MaxLookahead] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map MaxLookahead -> SlotNo
SlotNo (MaxLookahead -> [MaxLookahead]
forall a. Arbitrary a => a -> [a]
shrink MaxLookahead
s)

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Like 'enumFromTo', but with an exclusive upper bound
enumIncExc :: forall a. (Ord a, Enum a) => a -> a -> [a]
enumIncExc :: forall a. (Ord a, Enum a) => a -> a -> [a]
enumIncExc a
lo a
hi = a -> [a]
go a
lo
  where
    go :: a -> [a]
    go :: a -> [a]
go a
x | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
hi   = []
         | Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a]
go (a -> a
forall a. Enum a => a -> a
succ a
x)

sized' :: (Word64 -> Gen a) -> Gen a
sized' :: forall a. (MaxLookahead -> Gen a) -> Gen a
sized' MaxLookahead -> Gen a
f = (Int -> Gen a) -> Gen a
forall a. (Int -> Gen a) -> Gen a
sized (MaxLookahead -> Gen a
f (MaxLookahead -> Gen a) -> (Int -> MaxLookahead) -> Int -> Gen a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> MaxLookahead
forall a b. (Integral a, Num b) => a -> b
fromIntegral)

mapAt :: (HasCallStack, Show k, Show a, Ord k) => Map k a -> k -> a
Map k a
m mapAt :: forall k a.
(?callStack::CallStack, Show k, Show a, Ord k) =>
Map k a -> k -> a
`mapAt` k
k =
    a -> k -> Map k a -> a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault
      (TestName -> a
forall a. (?callStack::CallStack) => TestName -> a
error (TestName -> a) -> TestName -> a
forall a b. (a -> b) -> a -> b
$ [TestName] -> TestName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
           TestName
"at: key "
         , k -> TestName
forall a. Show a => a -> TestName
show k
k
         , TestName
" not found in "
         , Map k a -> TestName
forall a. Show a => a -> TestName
show Map k a
m
         ])
      k
k
      Map k a
m