{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
{-# 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.Ledger.Tables.Combinators (K2 (..))
import Ouroboros.Consensus.Util (Some (..), repeatedly, splits)
import Test.Consensus.HardFork.Infra
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
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 {k} (era :: k). 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 a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
forall k (era :: k). Int -> Chain era -> ShowS
forall k (era :: k). [Chain era] -> ShowS
forall k (era :: k). Chain era -> TestName
$cshowsPrec :: forall k (era :: k). Int -> Chain era -> ShowS
showsPrec :: Int -> Chain era -> ShowS
$cshow :: forall k (era :: k). Chain era -> TestName
show :: Chain era -> TestName
$cshowList :: forall k (era :: k). [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 (K2 LedgerState) (K LedgerView)) xs
translations :: forall (xs :: [*]).
TestSetup xs
-> InPairs (CrossEraForecaster (K2 LedgerState) (K LedgerView)) xs
translations TestSetup{NonEmpty xs TestEra
Exactly xs MaxLookahead
TestForecastParams
testLookahead :: Exactly xs MaxLookahead
testEras :: NonEmpty xs TestEra
testForecastParams :: TestForecastParams
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
..} =
  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 (K2 LedgerState) (K LedgerView)) (x : xs1)
forall x (xs' :: [*]).
Exactly (x : xs') MaxLookahead
-> InPairs
     (CrossEraForecaster (K2 LedgerState) (K LedgerView)) (x : xs')
go Exactly xs MaxLookahead
Exactly (x : xs1) MaxLookahead
testLookahead
 where
  go ::
    Exactly (x ': xs') MaxLookahead ->
    InPairs (CrossEraForecaster (K2 LedgerState) (K LedgerView)) (x ': xs')
  go :: forall x (xs' :: [*]).
Exactly (x : xs') MaxLookahead
-> InPairs
     (CrossEraForecaster (K2 LedgerState) (K LedgerView)) (x : xs')
go (ExactlyCons MaxLookahead
_ Exactly xs MaxLookahead
ExactlyNil) =
    InPairs
  (CrossEraForecaster (K2 LedgerState) (K LedgerView)) (x : xs')
InPairs (CrossEraForecaster (K2 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 (K2 LedgerState) (K LedgerView) x x
-> InPairs
     (CrossEraForecaster (K2 LedgerState) (K LedgerView)) (x : xs)
-> InPairs
     (CrossEraForecaster (K2 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 (K2 LedgerState) (K LedgerView) x x
forall era era'.
MaxLookahead
-> MaxLookahead
-> CrossEraForecaster (K2 LedgerState) (K LedgerView) era era'
tr MaxLookahead
this MaxLookahead
next) (Exactly (x : xs) MaxLookahead
-> InPairs
     (CrossEraForecaster (K2 LedgerState) (K LedgerView)) (x : xs)
forall x (xs' :: [*]).
Exactly (x : xs') MaxLookahead
-> InPairs
     (CrossEraForecaster (K2 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 (K2 LedgerState) (K LedgerView) era era'
  tr :: forall era era'.
MaxLookahead
-> MaxLookahead
-> CrossEraForecaster (K2 LedgerState) (K LedgerView) era era'
tr MaxLookahead
thisLookahead MaxLookahead
nextLookahead =
    (Bound
 -> SlotNo
 -> K2 LedgerState era EmptyMK
 -> Except OutsideForecastRange (K LedgerView era'))
-> CrossEraForecaster (K2 LedgerState) (K LedgerView) era era'
forall (state :: * -> (* -> * -> *) -> *) (view :: * -> *) x y.
(Bound
 -> SlotNo
 -> state x EmptyMK
 -> Except OutsideForecastRange (view y))
-> CrossEraForecaster state view x y
CrossEraForecaster ((Bound
  -> SlotNo
  -> K2 LedgerState era EmptyMK
  -> Except OutsideForecastRange (K LedgerView era'))
 -> CrossEraForecaster (K2 LedgerState) (K LedgerView) era era')
-> (Bound
    -> SlotNo
    -> K2 LedgerState era EmptyMK
    -> Except OutsideForecastRange (K LedgerView era'))
-> CrossEraForecaster (K2 LedgerState) (K LedgerView) era era'
forall a b. (a -> b) -> a -> b
$ \Bound
transition SlotNo
sno (K2 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
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
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 (K2 LedgerState) (K LedgerView)) xs
-> HardForkState (AnnForecast (K2 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 (K2 LedgerState) (K LedgerView)) xs
forall (xs :: [*]).
TestSetup xs
-> InPairs (CrossEraForecaster (K2 LedgerState) (K LedgerView)) xs
translations TestSetup xs
setup) (Telescope
  (K Past) (Current (AnnForecast (K2 LedgerState) (K LedgerView))) xs
-> HardForkState (AnnForecast (K2 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 (K2 LedgerState) (K LedgerView))) xs
forall (xs' :: [*]).
NonEmpty xs' TestEra
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 LedgerState) (K LedgerView)))
     xs'
go NonEmpty xs TestEra
testEras))
 where
  TestForecastParams{WithOrigin SlotNo
SlotNo
testForecastAt :: WithOrigin SlotNo
testForecastWithinEra :: SlotNo
testForecastAcrossEras :: SlotNo
testForecastAcrossEras :: TestForecastParams -> SlotNo
testForecastWithinEra :: TestForecastParams -> SlotNo
testForecastAt :: TestForecastParams -> WithOrigin 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 (K2 LedgerState) (K LedgerView))) xs'
  go :: forall (xs' :: [*]).
NonEmpty xs' TestEra
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 LedgerState) (K LedgerView)))
     xs'
go (NonEmptyOne TestEra
era) =
    Bool
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 LedgerState) (K LedgerView)))
     xs'
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 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 (K2 LedgerState) (K LedgerView)))
   xs'
 -> Telescope
      (K Past)
      (Current (AnnForecast (K2 LedgerState) (K LedgerView)))
      xs')
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 LedgerState) (K LedgerView)))
     xs'
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 LedgerState) (K LedgerView)))
     xs'
forall a b. (a -> b) -> a -> b
$
      Current (AnnForecast (K2 LedgerState) (K LedgerView)) x
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 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 (K2 LedgerState) (K LedgerView)) x
 -> Telescope
      (K Past)
      (Current (AnnForecast (K2 LedgerState) (K LedgerView)))
      (x : xs1))
-> Current (AnnForecast (K2 LedgerState) (K LedgerView)) x
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 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 (K2 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 :: K2 LedgerState x EmptyMK
annForecastState = LedgerState -> K2 LedgerState x EmptyMK
forall k1 k2 a (b :: k1) (c :: k2). a -> K2 a b c
K2 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 (K2 LedgerState) (K LedgerView)) x
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 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 (K2 LedgerState) (K LedgerView)) x
 -> Telescope
      (K Past)
      (Current (AnnForecast (K2 LedgerState) (K LedgerView)))
      (x : xs1))
-> Current (AnnForecast (K2 LedgerState) (K LedgerView)) x
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 LedgerState) (K LedgerView)))
     (x : xs1)
forall a b. (a -> b) -> a -> b
$
          Current
            { currentStart :: Bound
currentStart = Bound
start
            , currentState :: AnnForecast (K2 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 :: K2 LedgerState x EmptyMK
annForecastState = LedgerState -> K2 LedgerState x EmptyMK
forall k1 k2 a (b :: k1) (c :: k2). a -> K2 a b c
K2 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 (K2 LedgerState) (K LedgerView)))
     xs1
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 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 (K2 LedgerState) (K LedgerView)))
     xs1
forall (xs' :: [*]).
NonEmpty xs' TestEra
-> Telescope
     (K Past)
     (Current (AnnForecast (K2 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
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
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
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
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
testForecastAcrossEras :: TestForecastParams -> SlotNo
testForecastWithinEra :: TestForecastParams -> SlotNo
testForecastAt :: TestForecastParams -> WithOrigin 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
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
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
  { TestEra -> EraSummary
testEraSummary :: EraSummary
  -- ^ 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 -> MaxLookahead
testEraMaxLookahead :: MaxLookahead
  -- ^ 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 -> [Block]
testEraBlocks :: [Block]
  -- ^ Blocks on the chain in this era
  }
  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
  { TestForecastParams -> WithOrigin SlotNo
testForecastAt :: WithOrigin SlotNo
  -- ^ Anchor of the forecast
  , TestForecastParams -> SlotNo
testForecastWithinEra :: 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
testForecastAcrossEras :: 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.
  }
  deriving Int -> TestForecastParams -> ShowS
[TestForecastParams] -> ShowS
TestForecastParams -> TestName
(Int -> TestForecastParams -> ShowS)
-> (TestForecastParams -> TestName)
-> ([TestForecastParams] -> ShowS)
-> Show TestForecastParams
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestForecastParams -> ShowS
showsPrec :: Int -> TestForecastParams -> ShowS
$cshow :: TestForecastParams -> TestName
show :: TestForecastParams -> TestName
$cshowList :: [TestForecastParams] -> ShowS
showList :: [TestForecastParams] -> ShowS
Show

data TestSetup xs = (SListI xs, IsNonEmpty xs) => TestSetup
  { forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
testLookahead :: Exactly xs MaxLookahead
  -- ^ 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 -> NonEmpty xs TestEra
testEras :: NonEmpty xs TestEra
  -- ^ The test eras themselves
  , forall (xs :: [*]). TestSetup xs -> TestForecastParams
testForecastParams :: TestForecastParams
  -- ^ The forecast we're constructing
  }

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
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
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
        ]

  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
          ]

  unless (testEraContains (NotOrigin testForecastWithinEra) era) $
    throwError $
      mconcat
        [ "'testForecastWithinEra' == "
        , show testForecastWithinEra
        , " not in same era as 'testForecastAt' == "
        , show testForecastAt
        ]

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

  TestForecastParams{WithOrigin SlotNo
SlotNo
testForecastAcrossEras :: TestForecastParams -> SlotNo
testForecastWithinEra :: TestForecastParams -> SlotNo
testForecastAt :: TestForecastParams -> WithOrigin 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
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
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
    summary <- getSummary <$> genSummary ixs
    lookahead <- genMaxLookahead (eraIndices ixs) (atMostFromNonEmpty summary)
    eras <-
      sequence $
        genTestEra
          <$> summary
          <*> exactlyWeakenNonEmpty lookahead
    forecast <- genForecastParams (toList eras)
    return $
      Some
        TestSetup
          { testLookahead = lookahead
          , testEras = eras
          , 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
      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' = 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))

      ls <- genMaxLookahead es ss
      return (ExactlyCons l' 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
      l <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead
forall a. Random a => (a, a) -> Gen a
choose (MaxLookahead
0, MaxLookahead
sz)
      ls <- genMaxLookahead es AtMostNil
      return (ExactlyCons l 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
      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)
      mBlocks <- forM (enumIncExc (boundSlot eraStart) (boundSlot upperBound)) $ \SlotNo
slot -> do
        slotFilled <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
        if slotFilled
          then do
            scheduled <- genScheduled maxLookahead slot
            return $ Just (Block slot scheduled)
          else
            return Nothing
      return
        TestEra
          { testEraSummary = summary
          , testEraMaxLookahead = maxLookahead
          , testEraBlocks = catMaybes mBlocks
          }

    genScheduled :: MaxLookahead -> SlotNo -> Gen Scheduled
    genScheduled :: MaxLookahead -> SlotNo -> Gen Scheduled
genScheduled MaxLookahead
maxLookahead SlotNo
slotBlock = do
      numChanges <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
2)
      fmap Map.fromList $
        replicateM numChanges $
          genChange maxLookahead 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
      skip <- (MaxLookahead, MaxLookahead) -> Gen MaxLookahead
forall a. Random a => (a, a) -> Gen a
choose (MaxLookahead
0, MaxLookahead
sz)
      increase <- choose (0, 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 = MaxLookahead -> SlotNo -> SlotNo
addSlots (MaxLookahead
maxLookahead MaxLookahead -> MaxLookahead -> MaxLookahead
forall a. Num a => a -> a -> a
+ MaxLookahead
skip) SlotNo
slotBlock
      return (slotChange, IncreaseValueBy 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
      (isFirstEra, 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 = EraSummary -> Bound
eraStart (EraSummary -> Bound) -> EraSummary -> Bound
forall a b. (a -> b) -> a -> b
$ TestEra -> EraSummary
testEraSummary TestEra
anchorEra
          anchorEraEnd = EraSummary -> EraEnd
eraEnd (EraSummary -> EraEnd) -> EraSummary -> EraEnd
forall a b. (a -> b) -> a -> b
$ TestEra -> EraSummary
testEraSummary TestEra
anchorEra

      -- Pick an anchor
      at <-
        oneof $
          concat
            [ [ fmap NotOrigin $
                  elements $
                    enumIncExc
                      (boundSlot anchorEraStart)
                      (boundSlot end)
              | EraEnd end <- [anchorEraEnd]
              ]
            , [ do
                  upperBound <- choose (1, 1 + sz) -- upper bound is exclusive
                  fmap NotOrigin $
                    elements $
                      enumIncExc
                        (boundSlot anchorEraStart)
                        (addSlots upperBound (boundSlot anchorEraStart))
              | EraUnbounded <- [anchorEraEnd]
              ]
            , [ return Origin
              | isFirstEra
              ]
            ]

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

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

      return
        TestForecastParams
          { testForecastAt = at
          , testForecastWithinEra = withinEra
          , testForecastAcrossEras = 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. (?callStack::CallStack) => [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
                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
                elements $ enumIncExc lo (addSlots upperBound 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
testForecastParams :: forall (xs :: [*]). TestSetup xs -> TestForecastParams
testEras :: forall (xs :: [*]). TestSetup xs -> NonEmpty xs TestEra
testLookahead :: forall (xs :: [*]). TestSetup xs -> Exactly xs MaxLookahead
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
testForecastAcrossEras :: TestForecastParams -> SlotNo
testForecastWithinEra :: TestForecastParams -> SlotNo
testForecastAt :: TestForecastParams -> WithOrigin 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