{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}

-- | Hard fork history tests.
--
-- This is the more interesting test of the hard fork history. We construct a
-- mock chain, consisting of events (events are roughly, but not quite,
-- "blocks"). For every event we record its slot number, epoch number, wall
-- clock, etc. Since we are constructing this chain as a whole, from genesis to
-- its tip, constructing these events is trivial. We then split this chain in
-- half, and construct a @Summary@ from the first half. We then use that summary
-- to do conversions for any event on the chain. Since every event records all
-- information, we can easily verify whether the answers we are getting back are
-- correct. Moreover, since the summary is constructed from only the first part
-- of the chain, but is used to do conversions across the entire chain, we
-- verify that predictions about the "future" also work as correctly (including
-- that the conversions say "outside range" if and only if the model expects
-- them to be).
module Test.Consensus.HardFork.History (tests) where

import Cardano.Slotting.EpochInfo
import Control.Exception (throw)
import Control.Monad.Except
import Data.Bifunctor
import Data.Foldable (toList)
import Data.Function (on)
import Data.Functor.Identity
import qualified Data.List as L
import Data.Maybe (catMaybes, fromMaybe)
import Data.SOP.BasicFunctors
import Data.SOP.Counting
import qualified Data.SOP.InPairs as InPairs
import Data.SOP.NonEmpty
import Data.SOP.Sing hiding (shape)
import Data.SOP.Telescope (Telescope (..))
import Data.Time
import Data.Word
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.Forecast
import Ouroboros.Consensus.HardFork.Combinator.Ledger
import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import Ouroboros.Consensus.HardFork.Combinator.State.Types
import qualified Ouroboros.Consensus.HardFork.History as HF
import Ouroboros.Consensus.Ledger.Tables.Combinators
import Ouroboros.Consensus.Util (nTimes)
import Test.Cardano.Slotting.Numeric ()
import Test.Consensus.HardFork.Infra
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.Orphans.Arbitrary ()
import Test.Util.QuickCheck

-- | Tests for 'summarize'
--
-- General approach:
--
-- * Generate a chain of events
-- * Each event records its own 'RelativeTime', 'SlotNo', and 'EpochNo'
-- * We then construct a 'HF.Summary' from a /prefix/ of this chain
-- * We then pick an arbitrary event from the (full) chain:
--   a. If that event is on the prefix of the chain, or within the safe zone, we
--      expect to be able to do any slot/epoch or slot/time conversion, and we
--      can easily verify the result by comparing it to the values the 'Event'
--      itself reports.
--   b. If the event is outside of safe zone, we expect the conversion to throw
--      a 'PastHorizonException'.
tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Chain"
    [ 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
$ (ArbitraryChain -> Property) -> Property
forall a. (Arbitrary a, Show a) => (a -> Property) -> Property
checkGenerator ((ArbitraryChain -> Property) -> Property)
-> (ArbitraryChain -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
..} ->
            let ArbitraryParams{Int
[Event]
NominalDiffTime
Shape xs
Eras xs
arbitraryChainEvents :: [Event]
arbitraryChainEras :: Eras xs
arbitraryChainShape :: Shape xs
arbitraryRawEventIx :: Int
arbitraryChainSplit :: Int
arbitraryDiffTime :: NominalDiffTime
arbitraryDiffTime :: forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
arbitraryChainSplit :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryRawEventIx :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainShape :: forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryChainEras :: forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainEvents :: forall (xs :: [*]). ArbitraryParams xs -> [Event]
..} = ArbitraryParams xs
arbitraryParams
             in (Shape xs -> Except TestName ()) -> Shape xs -> Property
forall a. (a -> Except TestName ()) -> a -> Property
checkInvariant Shape xs -> Except TestName ()
forall (xs :: [*]). Shape xs -> Except TestName ()
HF.invariantShape Shape xs
arbitraryChainShape
        , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrinker" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ (ArbitraryChain -> Property) -> Property
forall a. (Arbitrary a, Show a) => (a -> Property) -> Property
checkShrinker ((ArbitraryChain -> Property) -> Property)
-> (ArbitraryChain -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} ->
            let ArbitraryParams{Int
[Event]
NominalDiffTime
Shape xs
Eras xs
arbitraryDiffTime :: forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
arbitraryChainSplit :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryRawEventIx :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainShape :: forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryChainEras :: forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainEvents :: forall (xs :: [*]). ArbitraryParams xs -> [Event]
arbitraryChainEvents :: [Event]
arbitraryChainEras :: Eras xs
arbitraryChainShape :: Shape xs
arbitraryRawEventIx :: Int
arbitraryChainSplit :: Int
arbitraryDiffTime :: NominalDiffTime
..} = ArbitraryParams xs
arbitraryParams
             in (Shape xs -> Except TestName ()) -> Shape xs -> Property
forall a. (a -> Except TestName ()) -> a -> Property
checkInvariant Shape xs -> Except TestName ()
forall (xs :: [*]). Shape xs -> Except TestName ()
HF.invariantShape Shape xs
arbitraryChainShape
        ]
    , TestName -> [TestTree] -> TestTree
testGroup
        TestName
"Conversions"
        [ TestName -> (ArbitraryChain -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"summarizeInvariant" ArbitraryChain -> Property
summarizeInvariant
        , TestName -> (ArbitraryChain -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"eventSlotToEpoch" ArbitraryChain -> Property
eventSlotToEpoch
        , TestName -> (ArbitraryChain -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"eventEpochToSlot" ArbitraryChain -> Property
eventEpochToSlot
        , TestName -> (ArbitraryChain -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"eventSlotToWallclock" ArbitraryChain -> Property
eventSlotToWallclock
        , TestName -> (ArbitraryChain -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"eventWallclockToSlot" ArbitraryChain -> Property
eventWallclockToSlot
        , TestName -> (ArbitraryChain -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"epochInfoSlotToEpoch" ArbitraryChain -> Property
epochInfoSlotToEpoch
        , TestName -> (ArbitraryChain -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"epochInfoEpochToSlot" ArbitraryChain -> Property
epochInfoEpochToSlot
        , TestName -> (ArbitraryChain -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"query vs expr" ArbitraryChain -> Property
queryVsExprConsistency
        ]
    ]

{-------------------------------------------------------------------------------
  Dealing with the 'PastHorizonException'
-------------------------------------------------------------------------------}

isPastHorizonIf ::
  Show a =>
  -- | Are we expecting an exception?
  Bool ->
  Either HF.PastHorizonException a ->
  (a -> Property) ->
  Property
isPastHorizonIf :: forall a.
Show a =>
Bool
-> Either PastHorizonException a -> (a -> Property) -> Property
isPastHorizonIf Bool
True (Left PastHorizonException
_) a -> Property
_ = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
isPastHorizonIf Bool
False (Right a
a) a -> Property
p = a -> Property
p a
a
isPastHorizonIf Bool
False (Left PastHorizonException
ex) a -> Property
_ =
  TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Unexpected exception " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ PastHorizonException -> TestName
forall a. Show a => a -> TestName
show PastHorizonException
ex) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
isPastHorizonIf Bool
True (Right a
a) a -> Property
_ =
  TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample
    ( TestName
"Unexpected value "
        TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ a -> TestName
forall a. Show a => a -> TestName
show a
a
        TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" (expected PastHorizonException)"
    )
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False

{-------------------------------------------------------------------------------
  Properties of summarize

  TODO: We should strengten these tests: at the moment, the summary is
  constructed from the /entire/ blockchain, and then applied to any of the
  events in the blockchain. That is good, but we should additionally construct
  the summary from a /prefix/ of the blockchain and then verify that we can
  still convert events /after/ that prefix (up to the safe zone).
-------------------------------------------------------------------------------}

-- | Check that 'summarize' establishes 'invariantSummary'
summarizeInvariant :: ArbitraryChain -> Property
summarizeInvariant :: ArbitraryChain -> Property
summarizeInvariant ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} =
  (Summary xs -> Except TestName ()) -> Summary xs -> Property
forall a. (a -> Except TestName ()) -> a -> Property
checkInvariant Summary xs -> Except TestName ()
forall (xs :: [*]). Summary xs -> Except TestName ()
HF.invariantSummary Summary xs
arbitrarySummary

testSkeleton ::
  Show a =>
  ArbitraryChain ->
  HF.Qry a ->
  (a -> Property) ->
  Property
testSkeleton :: forall a.
Show a =>
ArbitraryChain -> Qry a -> (a -> Property) -> Property
testSkeleton ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} Qry a
q =
  TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"arbitraryEventIx" [EventIx -> TestName
eventIxType EventIx
arbitraryEventIx]
    (Property -> Property)
-> ((a -> Property) -> Property) -> (a -> Property) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> Either PastHorizonException a -> (a -> Property) -> Property
forall a.
Show a =>
Bool
-> Either PastHorizonException a -> (a -> Property) -> Property
isPastHorizonIf
      (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ EventIx -> Bool
eventIsPreHorizon EventIx
arbitraryEventIx)
      (Qry a -> Summary xs -> Either PastHorizonException a
forall a (xs :: [*]).
HasCallStack =>
Qry a -> Summary xs -> Either PastHorizonException a
HF.runQuery Qry a
q Summary xs
arbitrarySummary)

eventSlotToEpoch :: ArbitraryChain -> Property
eventSlotToEpoch :: ArbitraryChain -> Property
eventSlotToEpoch chain :: ArbitraryChain
chain@ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} =
  ArbitraryChain
-> Qry (EpochNo, Word64, Word64)
-> ((EpochNo, Word64, Word64) -> Property)
-> Property
forall a.
Show a =>
ArbitraryChain -> Qry a -> (a -> Property) -> Property
testSkeleton ArbitraryChain
chain (SlotNo -> Qry (EpochNo, Word64, Word64)
HF.slotToEpoch SlotNo
eventTimeSlot) (((EpochNo, Word64, Word64) -> Property) -> Property)
-> ((EpochNo, Word64, Word64) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
    \(EpochNo
epochNo, Word64
epochSlot, Word64
slotsLeft) ->
      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ EpochNo
epochNo EpochNo -> EpochNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== EpochNo
eventTimeEpochNo
        , Word64
epochSlot Word64 -> Word64 -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Word64
eventTimeEpochSlot
        , Word64
epochSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
slotsLeft
            Word64 -> Word64 -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ( EpochSize -> Word64
unEpochSize (EpochSize -> Word64)
-> (EraParams -> EpochSize) -> EraParams -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraParams -> EpochSize
HF.eraEpochSize (EraParams -> Word64) -> EraParams -> Word64
forall a b. (a -> b) -> a -> b
$
                    Event -> EraParams
eventEraParams Event
arbitraryEvent
                )
        ]
 where
  EventTime{Word64
EpochNo
SlotNo
RelativeTime
eventTimeSlot :: SlotNo
eventTimeEpochNo :: EpochNo
eventTimeEpochSlot :: Word64
eventTimeRelative :: RelativeTime
eventTimeRelative :: EventTime -> RelativeTime
eventTimeEpochSlot :: EventTime -> Word64
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeSlot :: EventTime -> SlotNo
..} = Event -> EventTime
eventTime Event
arbitraryEvent

eventEpochToSlot :: ArbitraryChain -> Property
eventEpochToSlot :: ArbitraryChain -> Property
eventEpochToSlot chain :: ArbitraryChain
chain@ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} =
  ArbitraryChain
-> Qry (SlotNo, EpochSize)
-> ((SlotNo, EpochSize) -> Property)
-> Property
forall a.
Show a =>
ArbitraryChain -> Qry a -> (a -> Property) -> Property
testSkeleton ArbitraryChain
chain (EpochNo -> Qry (SlotNo, EpochSize)
HF.epochToSlot EpochNo
eventTimeEpochNo) (((SlotNo, EpochSize) -> Property) -> Property)
-> ((SlotNo, EpochSize) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
    \(SlotNo
startOfEpoch, EpochSize
epochSize) ->
      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ SlotNo
eventTimeSlot SlotNo -> SlotNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Word64 -> SlotNo -> SlotNo
HF.addSlots Word64
eventTimeEpochSlot SlotNo
startOfEpoch
        , Word64
eventTimeEpochSlot Word64 -> Word64 -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`lt` EpochSize -> Word64
unEpochSize EpochSize
epochSize
        ]
 where
  EventTime{Word64
EpochNo
SlotNo
RelativeTime
eventTimeRelative :: EventTime -> RelativeTime
eventTimeEpochSlot :: EventTime -> Word64
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeSlot :: EventTime -> SlotNo
eventTimeEpochNo :: EpochNo
eventTimeSlot :: SlotNo
eventTimeEpochSlot :: Word64
eventTimeRelative :: RelativeTime
..} = Event -> EventTime
eventTime Event
arbitraryEvent

eventSlotToWallclock :: ArbitraryChain -> Property
eventSlotToWallclock :: ArbitraryChain -> Property
eventSlotToWallclock chain :: ArbitraryChain
chain@ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} =
  ArbitraryChain
-> Qry (RelativeTime, SlotLength)
-> ((RelativeTime, SlotLength) -> Property)
-> Property
forall a.
Show a =>
ArbitraryChain -> Qry a -> (a -> Property) -> Property
testSkeleton ArbitraryChain
chain (SlotNo -> Qry (RelativeTime, SlotLength)
HF.slotToWallclock SlotNo
eventTimeSlot) (((RelativeTime, SlotLength) -> Property) -> Property)
-> ((RelativeTime, SlotLength) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
    \(RelativeTime
time, SlotLength
_slotLen) ->
      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ RelativeTime
time RelativeTime -> RelativeTime -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== RelativeTime
eventTimeRelative
        ]
 where
  EventTime{Word64
EpochNo
SlotNo
RelativeTime
eventTimeRelative :: EventTime -> RelativeTime
eventTimeEpochSlot :: EventTime -> Word64
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeSlot :: EventTime -> SlotNo
eventTimeSlot :: SlotNo
eventTimeRelative :: RelativeTime
eventTimeEpochNo :: EpochNo
eventTimeEpochSlot :: Word64
..} = Event -> EventTime
eventTime Event
arbitraryEvent

eventWallclockToSlot :: ArbitraryChain -> Property
eventWallclockToSlot :: ArbitraryChain -> Property
eventWallclockToSlot chain :: ArbitraryChain
chain@ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} =
  ArbitraryChain
-> Qry (SlotNo, NominalDiffTime, NominalDiffTime)
-> ((SlotNo, NominalDiffTime, NominalDiffTime) -> Property)
-> Property
forall a.
Show a =>
ArbitraryChain -> Qry a -> (a -> Property) -> Property
testSkeleton ArbitraryChain
chain (RelativeTime -> Qry (SlotNo, NominalDiffTime, NominalDiffTime)
HF.wallclockToSlot RelativeTime
time) (((SlotNo, NominalDiffTime, NominalDiffTime) -> Property)
 -> Property)
-> ((SlotNo, NominalDiffTime, NominalDiffTime) -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
    \(SlotNo
slot, NominalDiffTime
inSlot, NominalDiffTime
timeSpent) ->
      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ SlotNo
slot SlotNo -> SlotNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== SlotNo
eventTimeSlot
        , NominalDiffTime
inSlot NominalDiffTime -> NominalDiffTime -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== NominalDiffTime
diff
        , NominalDiffTime
inSlot NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
timeSpent
            NominalDiffTime -> NominalDiffTime -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ( SlotLength -> NominalDiffTime
getSlotLength (SlotLength -> NominalDiffTime)
-> (EraParams -> SlotLength) -> EraParams -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraParams -> SlotLength
HF.eraSlotLength (EraParams -> NominalDiffTime) -> EraParams -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$
                    Event -> EraParams
eventEraParams Event
arbitraryEvent
                )
        ]
 where
  EventTime{Word64
EpochNo
SlotNo
RelativeTime
eventTimeRelative :: EventTime -> RelativeTime
eventTimeEpochSlot :: EventTime -> Word64
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeSlot :: EventTime -> SlotNo
eventTimeSlot :: SlotNo
eventTimeEpochNo :: EpochNo
eventTimeEpochSlot :: Word64
eventTimeRelative :: RelativeTime
..} = Event -> EventTime
eventTime Event
arbitraryEvent

  time :: RelativeTime
  time :: RelativeTime
time = NominalDiffTime -> RelativeTime -> RelativeTime
addRelTime NominalDiffTime
diff RelativeTime
eventTimeRelative

  diff :: NominalDiffTime
  diff :: NominalDiffTime
diff = ArbitraryParams xs -> NominalDiffTime
forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
arbitraryDiffTime ArbitraryParams xs
arbitraryParams

-- | Composing queries should be equivalent to composing expressions.
--
-- This is a regression test. Each expression in a query should be evaluated in
-- the same era, not each in the first era that yields a result, otherwise we
-- get inconsistent results.
queryVsExprConsistency :: ArbitraryChain -> Property
queryVsExprConsistency :: ArbitraryChain -> Property
queryVsExprConsistency ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} =
  (PastHorizonException -> Property)
-> Either PastHorizonException Property -> Property
forall e a. (e -> a) -> Either e a -> a
fromEither (Property -> PastHorizonException -> Property
forall a b. a -> b -> a
const (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)) (Either PastHorizonException Property -> Property)
-> Either PastHorizonException Property -> Property
forall a b. (a -> b) -> a -> b
$ do
    absTime1 <- Qry RelativeTime
-> Summary xs -> Either PastHorizonException RelativeTime
forall a (xs :: [*]).
HasCallStack =>
Qry a -> Summary xs -> Either PastHorizonException a
HF.runQuery (SlotNo -> Qry RelativeTime
q1 SlotNo
eventTimeSlot) Summary xs
arbitrarySummary
    absTime2 <- HF.runQuery (q2 eventTimeSlot) arbitrarySummary
    return $ absTime1 === absTime2
 where
  EventTime{Word64
EpochNo
SlotNo
RelativeTime
eventTimeRelative :: EventTime -> RelativeTime
eventTimeEpochSlot :: EventTime -> Word64
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeSlot :: EventTime -> SlotNo
eventTimeSlot :: SlotNo
eventTimeEpochNo :: EpochNo
eventTimeEpochSlot :: Word64
eventTimeRelative :: RelativeTime
..} = Event -> EventTime
eventTime Event
arbitraryEvent

  fromEither :: (e -> a) -> Either e a -> a
  fromEither :: forall e a. (e -> a) -> Either e a -> a
fromEither e -> a
f (Left e
e) = e -> a
f e
e
  fromEither e -> a
_ (Right a
a) = a
a

  -- \| We compose multiple expressions into one query. Each of these
  -- expressions should be evaluated in the same era.
  q1 :: SlotNo -> HF.Qry RelativeTime
  q1 :: SlotNo -> Qry RelativeTime
q1 SlotNo
absSlot = do
    relSlot <- (forall (f :: * -> *). Expr f SlotInEra) -> Qry SlotInEra
forall a. (forall (f :: * -> *). Expr f a) -> Qry a
HF.qryFromExpr ((forall (f :: * -> *). Expr f SlotInEra) -> Qry SlotInEra)
-> (forall (f :: * -> *). Expr f SlotInEra) -> Qry SlotInEra
forall a b. (a -> b) -> a -> b
$ Expr f SlotNo -> Expr f SlotInEra
forall (f :: * -> *). Expr f SlotNo -> Expr f SlotInEra
HF.EAbsToRelSlot (SlotNo -> Expr f SlotNo
forall a (f :: * -> *). Show a => a -> Expr f a
HF.ELit SlotNo
absSlot)
    relTime <- HF.qryFromExpr $ HF.ERelSlotToTime (HF.ELit relSlot)
    -- If we don't evaluate each expression in the same era, the next
    -- expression will be evaluated in the first era in which it succeeds,
    -- even if one of the above queries was evaluated in a later era.
    absTime <- HF.qryFromExpr $ HF.ERelToAbsTime (HF.ELit relTime)
    return absTime

  -- \| We build one big expression and turn that into one query. An expression
  -- is always evaluated in a single era.
  q2 :: SlotNo -> HF.Qry RelativeTime
  q2 :: SlotNo -> Qry RelativeTime
q2 SlotNo
absSlot = (forall (f :: * -> *). Expr f RelativeTime) -> Qry RelativeTime
forall a. (forall (f :: * -> *). Expr f a) -> Qry a
HF.qryFromExpr ((forall (f :: * -> *). Expr f RelativeTime) -> Qry RelativeTime)
-> (forall (f :: * -> *). Expr f RelativeTime) -> Qry RelativeTime
forall a b. (a -> b) -> a -> b
$
    Expr f SlotInEra
-> (f SlotInEra -> Expr f RelativeTime) -> Expr f RelativeTime
forall (f :: * -> *) a1 a.
Expr f a1 -> (f a1 -> Expr f a) -> Expr f a
HF.ELet (Expr f SlotNo -> Expr f SlotInEra
forall (f :: * -> *). Expr f SlotNo -> Expr f SlotInEra
HF.EAbsToRelSlot (SlotNo -> Expr f SlotNo
forall a (f :: * -> *). Show a => a -> Expr f a
HF.ELit SlotNo
absSlot)) ((f SlotInEra -> Expr f RelativeTime) -> Expr f RelativeTime)
-> (f SlotInEra -> Expr f RelativeTime) -> Expr f RelativeTime
forall a b. (a -> b) -> a -> b
$ \f SlotInEra
relSlot ->
      Expr f TimeInEra
-> (f TimeInEra -> Expr f RelativeTime) -> Expr f RelativeTime
forall (f :: * -> *) a1 a.
Expr f a1 -> (f a1 -> Expr f a) -> Expr f a
HF.ELet (Expr f SlotInEra -> Expr f TimeInEra
forall (f :: * -> *). Expr f SlotInEra -> Expr f TimeInEra
HF.ERelSlotToTime (f SlotInEra -> Expr f SlotInEra
forall (f :: * -> *) a. f a -> Expr f a
HF.EVar f SlotInEra
relSlot)) ((f TimeInEra -> Expr f RelativeTime) -> Expr f RelativeTime)
-> (f TimeInEra -> Expr f RelativeTime) -> Expr f RelativeTime
forall a b. (a -> b) -> a -> b
$ \f TimeInEra
relTime ->
        Expr f RelativeTime
-> (f RelativeTime -> Expr f RelativeTime) -> Expr f RelativeTime
forall (f :: * -> *) a1 a.
Expr f a1 -> (f a1 -> Expr f a) -> Expr f a
HF.ELet (Expr f TimeInEra -> Expr f RelativeTime
forall (f :: * -> *). Expr f TimeInEra -> Expr f RelativeTime
HF.ERelToAbsTime (f TimeInEra -> Expr f TimeInEra
forall (f :: * -> *) a. f a -> Expr f a
HF.EVar f TimeInEra
relTime)) ((f RelativeTime -> Expr f RelativeTime) -> Expr f RelativeTime)
-> (f RelativeTime -> Expr f RelativeTime) -> Expr f RelativeTime
forall a b. (a -> b) -> a -> b
$ \f RelativeTime
absTime ->
          f RelativeTime -> Expr f RelativeTime
forall (f :: * -> *) a. f a -> Expr f a
HF.EVar f RelativeTime
absTime

{-------------------------------------------------------------------------------
  Tests using EpochInfo

  NOTE: We have two degrees of freedom here: we can ask for an 'EpochInfo' for a
  particular slot, and then we can use that 'EpochInfo' for another slot. We
  don't try to be exhaustive here: we use the 'SlotNo' of the event that we
  choose for both.

  TODO: Given time, we should make these tests more thorough.
-------------------------------------------------------------------------------}

epochInfoSlotToEpoch :: ArbitraryChain -> Property
epochInfoSlotToEpoch :: ArbitraryChain -> Property
epochInfoSlotToEpoch chain :: ArbitraryChain
chain@ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} =
  TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"view: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
view) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"reconstructed: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
reconstructed) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      EventIx -> Bool
eventIsPreHorizon EventIx
arbitraryEventIx Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
        Identity EpochNo -> EpochNo
forall a. Identity a -> a
runIdentity (EpochInfo Identity -> SlotNo -> Identity EpochNo
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> SlotNo -> m EpochNo
epochInfoEpoch EpochInfo Identity
epochInfo SlotNo
eventTimeSlot)
          EpochNo -> EpochNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== EpochNo
eventTimeEpochNo
 where
  EventTime{Word64
EpochNo
SlotNo
RelativeTime
eventTimeRelative :: EventTime -> RelativeTime
eventTimeEpochSlot :: EventTime -> Word64
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeSlot :: EventTime -> SlotNo
eventTimeSlot :: SlotNo
eventTimeEpochNo :: EpochNo
eventTimeEpochSlot :: Word64
eventTimeRelative :: RelativeTime
..} = Event -> EventTime
eventTime Event
arbitraryEvent
  (EpochInfo Identity
epochInfo, TestName
view, TestName
reconstructed) = ArbitraryChain
-> SlotNo -> (EpochInfo Identity, TestName, TestName)
hardForkEpochInfo ArbitraryChain
chain SlotNo
eventTimeSlot

epochInfoEpochToSlot :: ArbitraryChain -> Property
epochInfoEpochToSlot :: ArbitraryChain -> Property
epochInfoEpochToSlot chain :: ArbitraryChain
chain@ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} =
  TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"view: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
view) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"reconstructed: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
reconstructed) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      EventIx -> Bool
eventIsPreHorizon EventIx
arbitraryEventIx Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
        let startOfEpoch :: SlotNo
startOfEpoch = Identity SlotNo -> SlotNo
forall a. Identity a -> a
runIdentity (EpochInfo Identity -> EpochNo -> Identity SlotNo
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m SlotNo
epochInfoFirst EpochInfo Identity
epochInfo EpochNo
eventTimeEpochNo)
         in TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"startOfEpoch: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ SlotNo -> TestName
forall a. Show a => a -> TestName
show SlotNo
startOfEpoch) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
              Word64 -> SlotNo -> SlotNo
HF.addSlots Word64
eventTimeEpochSlot SlotNo
startOfEpoch
                SlotNo -> SlotNo -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== SlotNo
eventTimeSlot
 where
  EventTime{Word64
EpochNo
SlotNo
RelativeTime
eventTimeRelative :: EventTime -> RelativeTime
eventTimeEpochSlot :: EventTime -> Word64
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeSlot :: EventTime -> SlotNo
eventTimeEpochNo :: EpochNo
eventTimeEpochSlot :: Word64
eventTimeSlot :: SlotNo
eventTimeRelative :: RelativeTime
..} = Event -> EventTime
eventTime Event
arbitraryEvent
  (EpochInfo Identity
epochInfo, TestName
view, TestName
reconstructed) = ArbitraryChain
-> SlotNo -> (EpochInfo Identity, TestName, TestName)
hardForkEpochInfo ArbitraryChain
chain SlotNo
eventTimeSlot

{-------------------------------------------------------------------------------
  Arbitrary chain
-------------------------------------------------------------------------------}

data ArbitraryParams xs = ArbitraryParams
  { forall (xs :: [*]). ArbitraryParams xs -> [Event]
arbitraryChainEvents :: [Event]
  , forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainEras :: Eras xs
  , forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryChainShape :: HF.Shape xs
  , forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryRawEventIx :: Int
  -- ^ Index into the events
  --
  -- > 0 <= arbitraryEventIx < length arbitraryChainEvents
  --
  -- The tests will use 'arbitraryEventIx' instead.
  , forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainSplit :: Int
  -- ^ Split of the prechain
  --
  -- > 0 <= arbitraryChainSplit < length arbitraryChainEvents
  , forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
arbitraryDiffTime :: NominalDiffTime
  -- ^ Arbitrary 'DiffTime'
  --
  -- Let @s@ be the slot length of the selected event. Then
  --
  -- 0 <= arbitraryDiffTime < s
  }
  deriving Int -> ArbitraryParams xs -> TestName -> TestName
[ArbitraryParams xs] -> TestName -> TestName
ArbitraryParams xs -> TestName
(Int -> ArbitraryParams xs -> TestName -> TestName)
-> (ArbitraryParams xs -> TestName)
-> ([ArbitraryParams xs] -> TestName -> TestName)
-> Show (ArbitraryParams xs)
forall (xs :: [*]).
Int -> ArbitraryParams xs -> TestName -> TestName
forall (xs :: [*]). [ArbitraryParams xs] -> TestName -> TestName
forall (xs :: [*]). ArbitraryParams xs -> TestName
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: forall (xs :: [*]).
Int -> ArbitraryParams xs -> TestName -> TestName
showsPrec :: Int -> ArbitraryParams xs -> TestName -> TestName
$cshow :: forall (xs :: [*]). ArbitraryParams xs -> TestName
show :: ArbitraryParams xs -> TestName
$cshowList :: forall (xs :: [*]). [ArbitraryParams xs] -> TestName -> TestName
showList :: [ArbitraryParams xs] -> TestName -> TestName
Show

data ArbitraryChain = forall xs. (SListI xs, IsNonEmpty xs) => ArbitraryChain
  { ()
arbitraryParams :: ArbitraryParams xs
  -- ^ QuickCheck generated parameters
  --
  -- The rest of these values are derived
  , ()
arbitraryChain :: Chain xs
  -- ^ Chain derived from a prefix of the prechain
  , ()
arbitraryTransitions :: HF.Transitions xs
  -- ^ Transitions on the chain
  , ()
arbitrarySummary :: HF.Summary xs
  -- ^ Summary of the chain
  , ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySafeZone :: (Maybe EpochNo, HF.SafeZone)
  -- ^ Active safe zone
  , ArbitraryChain -> [Event]
arbitraryInSafeZone :: [Event]
  -- ^ Events after the chain, but within the safe zone
  , ArbitraryChain -> [Event]
arbitraryPastHorizon :: [Event]
  -- ^ Events after the chain, no longer within the safe zone
  , ArbitraryChain -> EventIx
arbitraryEventIx :: EventIx
  -- ^ Event index into one of the three parts of the chain
  , ArbitraryChain -> Event
arbitraryEvent :: Event
  -- ^ Arbitrary event
  --
  -- This is equal to both of
  --
  -- > arbitraryChainEvents !! arbitraryRawEventIx
  }

data EventIx
  = -- > 0 <= n < length (concat (toList arbitraryChain))
    EventOnChain Int
  | -- > 0 <= n < length arbitrarySafeZone
    -- The 'Bool' indicates if this is the very last entry in the safe zone
    EventInSafeZone Int Bool
  | -- > 0 <= n < length arbitraryPastHorizon
    EventPastHorizon Int
  deriving Int -> EventIx -> TestName -> TestName
[EventIx] -> TestName -> TestName
EventIx -> TestName
(Int -> EventIx -> TestName -> TestName)
-> (EventIx -> TestName)
-> ([EventIx] -> TestName -> TestName)
-> Show EventIx
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> EventIx -> TestName -> TestName
showsPrec :: Int -> EventIx -> TestName -> TestName
$cshow :: EventIx -> TestName
show :: EventIx -> TestName
$cshowList :: [EventIx] -> TestName -> TestName
showList :: [EventIx] -> TestName -> TestName
Show

eventIxType :: EventIx -> String
eventIxType :: EventIx -> TestName
eventIxType (EventOnChain Int
_) = TestName
"on chain"
eventIxType (EventInSafeZone Int
_ Bool
False) = TestName
"in safe zone"
eventIxType (EventInSafeZone Int
_ Bool
True) = TestName
"last in safe zone"
eventIxType (EventPastHorizon Int
_) = TestName
"past horizon"

eventIsPreHorizon :: EventIx -> Bool
eventIsPreHorizon :: EventIx -> Bool
eventIsPreHorizon (EventOnChain Int
_) = Bool
True
eventIsPreHorizon (EventInSafeZone Int
_ Bool
_) = Bool
True
eventIsPreHorizon (EventPastHorizon Int
_) = Bool
False

-- | Fill in the derived parts of the 'ArbitraryChain'
mkArbitraryChain ::
  forall xs.
  (SListI xs, IsNonEmpty xs) =>
  ArbitraryParams xs -> ArbitraryChain
mkArbitraryChain :: forall (xs :: [*]).
(SListI xs, IsNonEmpty xs) =>
ArbitraryParams xs -> ArbitraryChain
mkArbitraryChain params :: ArbitraryParams xs
params@ArbitraryParams{Int
[Event]
NominalDiffTime
Shape xs
Eras xs
arbitraryDiffTime :: forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
arbitraryChainSplit :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryRawEventIx :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainShape :: forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryChainEras :: forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainEvents :: forall (xs :: [*]). ArbitraryParams xs -> [Event]
arbitraryChainEvents :: [Event]
arbitraryChainEras :: Eras xs
arbitraryChainShape :: Shape xs
arbitraryRawEventIx :: Int
arbitraryChainSplit :: Int
arbitraryDiffTime :: NominalDiffTime
..} =
  ArbitraryChain
    { arbitraryParams :: ArbitraryParams xs
arbitraryParams = ArbitraryParams xs
params
    , arbitraryChain :: Chain xs
arbitraryChain = Chain xs
chain
    , arbitraryTransitions :: Transitions xs
arbitraryTransitions = Transitions xs
transitions
    , arbitrarySummary :: Summary xs
arbitrarySummary = Summary xs
summary
    , arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitrarySafeZone = (Maybe EpochNo, SafeZone)
safeZone
    , arbitraryInSafeZone :: [Event]
arbitraryInSafeZone = [Event]
inSafeZone
    , arbitraryPastHorizon :: [Event]
arbitraryPastHorizon = [Event]
pastHorizon
    , arbitraryEventIx :: EventIx
arbitraryEventIx = Int -> EventIx
mkEventIx Int
arbitraryRawEventIx
    , arbitraryEvent :: Event
arbitraryEvent = [Event]
arbitraryChainEvents [Event] -> Int -> Event
forall a. HasCallStack => [a] -> Int -> a
!! Int
arbitraryRawEventIx
    }
 where
  ([Event]
beforeSplit, [Event]
afterSplit) = Int -> [Event] -> ([Event], [Event])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
arbitraryChainSplit [Event]
arbitraryChainEvents
  safeZone :: (Maybe EpochNo, SafeZone)
safeZone =
    Shape xs -> Chain xs -> Transitions xs -> (Maybe EpochNo, SafeZone)
forall (xs :: [*]).
Shape xs -> Chain xs -> Transitions xs -> (Maybe EpochNo, SafeZone)
activeSafeZone
      Shape xs
arbitraryChainShape
      Chain xs
chain
      Transitions xs
transitions
  ([Event]
inSafeZone, [Event]
pastHorizon) =
    WithOrigin EpochNo
-> (Maybe EpochNo, SafeZone) -> [Event] -> ([Event], [Event])
splitSafeZone
      ((EpochNo, SlotNo) -> EpochNo
forall a b. (a, b) -> a
fst ((EpochNo, SlotNo) -> EpochNo)
-> WithOrigin (EpochNo, SlotNo) -> WithOrigin EpochNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chain xs -> WithOrigin (EpochNo, SlotNo)
forall (xs :: [*]). Chain xs -> WithOrigin (EpochNo, SlotNo)
chainTip Chain xs
chain)
      (Maybe EpochNo, SafeZone)
safeZone
      [Event]
afterSplit

  chain :: Chain xs
  chain :: Chain xs
chain = Eras xs -> [Event] -> Chain xs
forall (xs :: [*]). Eras xs -> [Event] -> Chain xs
fromEvents Eras xs
arbitraryChainEras [Event]
beforeSplit

  transitions :: HF.Transitions xs
  transitions :: Transitions xs
transitions = Eras xs -> Chain xs -> Transitions xs
forall (xs :: [*]). Eras xs -> Chain xs -> Transitions xs
chainTransitions Eras xs
arbitraryChainEras Chain xs
chain

  summary :: HF.Summary xs
  summary :: Summary xs
summary =
    WithOrigin SlotNo -> Shape xs -> Transitions xs -> Summary xs
forall (xs :: [*]).
WithOrigin SlotNo -> Shape xs -> Transitions xs -> Summary xs
HF.summarize
      ((EpochNo, SlotNo) -> SlotNo
forall a b. (a, b) -> b
snd ((EpochNo, SlotNo) -> SlotNo)
-> WithOrigin (EpochNo, SlotNo) -> WithOrigin SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chain xs -> WithOrigin (EpochNo, SlotNo)
forall (xs :: [*]). Chain xs -> WithOrigin (EpochNo, SlotNo)
chainTip Chain xs
chain)
      Shape xs
arbitraryChainShape
      Transitions xs
transitions

  mkEventIx :: Int -> EventIx
  mkEventIx :: Int -> EventIx
mkEventIx Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
beforeSplit = Int -> EventIx
EventOnChain Int
n
    | Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
inSafeZone = Int -> Bool -> EventIx
EventInSafeZone Int
n' (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
inSafeZone)
    | Int
n'' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
pastHorizon = Int -> EventIx
EventPastHorizon Int
n''
    | Bool
otherwise =
        TestName -> EventIx
forall a. HasCallStack => TestName -> a
error (TestName -> EventIx) -> TestName -> EventIx
forall a b. (a -> b) -> a -> b
$
          [TestName] -> TestName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ TestName
"mkEventIx: index "
            , Int -> TestName
forall a. Show a => a -> TestName
show Int
n
            , TestName
" out of bounds "
            , (Int, Int, Int) -> TestName
forall a. Show a => a -> TestName
show ([Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
beforeSplit, [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
inSafeZone, [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
pastHorizon)
            , TestName
"\nparameters:  " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ ArbitraryParams xs -> TestName
forall a. Show a => a -> TestName
show ArbitraryParams xs
params
            , TestName
"\nbeforeSplit: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ [Event] -> TestName
forall a. Show a => a -> TestName
show [Event]
beforeSplit
            , TestName
"\nafterSplit:  " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ [Event] -> TestName
forall a. Show a => a -> TestName
show [Event]
afterSplit
            , TestName
"\nsafeZone:    " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ (Maybe EpochNo, SafeZone) -> TestName
forall a. Show a => a -> TestName
show (Maybe EpochNo, SafeZone)
safeZone
            , TestName
"\ninSafeZone:  " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ [Event] -> TestName
forall a. Show a => a -> TestName
show [Event]
inSafeZone
            , TestName
"\npastHorizon: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ [Event] -> TestName
forall a. Show a => a -> TestName
show [Event]
pastHorizon
            ]
   where
    n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
beforeSplit
    n'' :: Int
n'' = Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
inSafeZone

deriving instance Show ArbitraryChain

instance Arbitrary ArbitraryChain where
  arbitrary :: Gen ArbitraryChain
arbitrary = (forall (xs :: [*]).
 (SListI xs, IsNonEmpty xs) =>
 Eras xs -> Gen ArbitraryChain)
-> Gen ArbitraryChain
forall r.
(forall (xs :: [*]).
 (SListI xs, IsNonEmpty xs) =>
 Eras xs -> Gen r)
-> Gen r
chooseEras ((forall (xs :: [*]).
  (SListI xs, IsNonEmpty xs) =>
  Eras xs -> Gen ArbitraryChain)
 -> Gen ArbitraryChain)
-> (forall (xs :: [*]).
    (SListI xs, IsNonEmpty xs) =>
    Eras xs -> Gen ArbitraryChain)
-> Gen ArbitraryChain
forall a b. (a -> b) -> a -> b
$ \Eras xs
eras -> do
    shape <- Eras xs -> Gen (Shape xs)
forall (xs :: [*]). Eras xs -> Gen (Shape xs)
genShape Eras xs
eras
    events <- genEvents eras shape `suchThat` (not . null)
    split <- choose (0, length events - 1)
    rawIx <- choose (0, length events - 1)
    diff <- genDiffTime $ HF.eraSlotLength (eventEraParams (events !! rawIx))
    return $
      mkArbitraryChain $
        ArbitraryParams
          { arbitraryChainEvents = events
          , arbitraryChainEras = eras
          , arbitraryChainShape = shape
          , arbitraryRawEventIx = rawIx
          , arbitraryChainSplit = split
          , arbitraryDiffTime = diff
          }
   where
    genDiffTime :: SlotLength -> Gen NominalDiffTime
    genDiffTime :: SlotLength -> Gen NominalDiffTime
genDiffTime SlotLength
s = Double -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> NominalDiffTime) -> Gen Double -> Gen NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0, Double
s') Gen Double -> (Double -> Bool) -> Gen Double
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
s')
     where
      s' :: Double
      s' :: Double
s' = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Double) -> Integer -> Double
forall a b. (a -> b) -> a -> b
$ SlotLength -> Integer
slotLengthToSec SlotLength
s

  shrink :: ArbitraryChain -> [ArbitraryChain]
shrink ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} =
    [[ArbitraryChain]] -> [ArbitraryChain]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ -- Pick an earlier event
        [ ArbitraryParams xs -> ArbitraryChain
forall (xs :: [*]).
(SListI xs, IsNonEmpty xs) =>
ArbitraryParams xs -> ArbitraryChain
mkArbitraryChain (ArbitraryParams xs -> ArbitraryChain)
-> ArbitraryParams xs -> ArbitraryChain
forall a b. (a -> b) -> a -> b
$ ArbitraryParams xs
arbitraryParams{arbitraryRawEventIx = rawIx'}
        | Int
rawIx' <- Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int
arbitraryRawEventIx
        ]
      , -- Pick an earlier split
        [ ArbitraryParams xs -> ArbitraryChain
forall (xs :: [*]).
(SListI xs, IsNonEmpty xs) =>
ArbitraryParams xs -> ArbitraryChain
mkArbitraryChain (ArbitraryParams xs -> ArbitraryChain)
-> ArbitraryParams xs -> ArbitraryChain
forall a b. (a -> b) -> a -> b
$ ArbitraryParams xs
arbitraryParams{arbitraryChainSplit = split'}
        | Int
split' <- Int -> [Int]
forall a. Arbitrary a => a -> [a]
shrink Int
arbitraryChainSplit
        ]
      , -- Shrink the chain by taking a prefix
        -- (The standard shrinker for lists does not make sense for chains)
        [ ArbitraryParams xs -> ArbitraryChain
forall (xs :: [*]).
(SListI xs, IsNonEmpty xs) =>
ArbitraryParams xs -> ArbitraryChain
mkArbitraryChain (ArbitraryParams xs -> ArbitraryChain)
-> ArbitraryParams xs -> ArbitraryChain
forall a b. (a -> b) -> a -> b
$ ArbitraryParams xs
arbitraryParams{arbitraryChainEvents = events'}
        | [Event]
events' <- [[Event]] -> [[Event]]
forall a. HasCallStack => [a] -> [a]
init ([Event] -> [[Event]]
forall a. [a] -> [[a]]
L.inits [Event]
arbitraryChainEvents)
        , Int
arbitraryRawEventIx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
events'
        , Int
arbitraryChainSplit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
events'
        ]
      ]
   where
    ArbitraryParams{Int
[Event]
NominalDiffTime
Shape xs
Eras xs
arbitraryDiffTime :: forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
arbitraryChainSplit :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryRawEventIx :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainShape :: forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryChainEras :: forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainEvents :: forall (xs :: [*]). ArbitraryParams xs -> [Event]
arbitraryRawEventIx :: Int
arbitraryChainSplit :: Int
arbitraryChainEvents :: [Event]
arbitraryChainEras :: Eras xs
arbitraryChainShape :: Shape xs
arbitraryDiffTime :: NominalDiffTime
..} = ArbitraryParams xs
arbitraryParams

{-------------------------------------------------------------------------------
  Chain model: Events
-------------------------------------------------------------------------------}

-- | We don't model a chain as a list of blocks, but rather as a list of events
--
-- Unlike blocks, events are not subject to rollback.
data Event = Event
  { Event -> EventType
eventType :: EventType
  , Event -> EventTime
eventTime :: EventTime
  , Event -> Era
eventEra :: Era
  , Event -> EraParams
eventEraParams :: HF.EraParams
  }
  deriving Int -> Event -> TestName -> TestName
[Event] -> TestName -> TestName
Event -> TestName
(Int -> Event -> TestName -> TestName)
-> (Event -> TestName)
-> ([Event] -> TestName -> TestName)
-> Show Event
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> Event -> TestName -> TestName
showsPrec :: Int -> Event -> TestName -> TestName
$cshow :: Event -> TestName
show :: Event -> TestName
$cshowList :: [Event] -> TestName -> TestName
showList :: [Event] -> TestName -> TestName
Show

data EventType
  = -- | Nothing of interest happens, time just ticks
    Tick
  | -- | A new hard fork transition is confirmed
    --
    -- "Confirmed" here is taken to mean "no longer subject to rollback",
    -- which is the concept that the hard fork history depends on.
    Confirm EpochNo
  deriving Int -> EventType -> TestName -> TestName
[EventType] -> TestName -> TestName
EventType -> TestName
(Int -> EventType -> TestName -> TestName)
-> (EventType -> TestName)
-> ([EventType] -> TestName -> TestName)
-> Show EventType
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> EventType -> TestName -> TestName
showsPrec :: Int -> EventType -> TestName -> TestName
$cshow :: EventType -> TestName
show :: EventType -> TestName
$cshowList :: [EventType] -> TestName -> TestName
showList :: [EventType] -> TestName -> TestName
Show

-- | When did an event occur?
--
-- NOTE: We don't care about 'BlockNo' here. Our events don't record necessarily
-- whether a block is actually present in a given slot or not.
data EventTime = EventTime
  { EventTime -> SlotNo
eventTimeSlot :: SlotNo
  , EventTime -> EpochNo
eventTimeEpochNo :: EpochNo
  , EventTime -> Word64
eventTimeEpochSlot :: Word64
  , EventTime -> RelativeTime
eventTimeRelative :: RelativeTime
  }
  deriving Int -> EventTime -> TestName -> TestName
[EventTime] -> TestName -> TestName
EventTime -> TestName
(Int -> EventTime -> TestName -> TestName)
-> (EventTime -> TestName)
-> ([EventTime] -> TestName -> TestName)
-> Show EventTime
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Int -> EventTime -> TestName -> TestName
showsPrec :: Int -> EventTime -> TestName -> TestName
$cshow :: EventTime -> TestName
show :: EventTime -> TestName
$cshowList :: [EventTime] -> TestName -> TestName
showList :: [EventTime] -> TestName -> TestName
Show

initEventTime :: EventTime
initEventTime :: EventTime
initEventTime =
  EventTime
    { eventTimeSlot :: SlotNo
eventTimeSlot = Word64 -> SlotNo
SlotNo Word64
0
    , eventTimeEpochNo :: EpochNo
eventTimeEpochNo = Word64 -> EpochNo
EpochNo Word64
0
    , eventTimeEpochSlot :: Word64
eventTimeEpochSlot = Word64
0
    , eventTimeRelative :: RelativeTime
eventTimeRelative = NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
0
    }

-- | Next time slot
stepEventTime :: HF.EraParams -> EventTime -> EventTime
stepEventTime :: EraParams -> EventTime -> EventTime
stepEventTime HF.EraParams{EpochSize
SlotLength
GenesisWindow
SafeZone
eraEpochSize :: EraParams -> EpochSize
eraSlotLength :: EraParams -> SlotLength
eraEpochSize :: EpochSize
eraSlotLength :: SlotLength
eraSafeZone :: SafeZone
eraGenesisWin :: GenesisWindow
eraGenesisWin :: EraParams -> GenesisWindow
eraSafeZone :: EraParams -> SafeZone
..} EventTime{Word64
EpochNo
SlotNo
RelativeTime
eventTimeRelative :: EventTime -> RelativeTime
eventTimeEpochSlot :: EventTime -> Word64
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeSlot :: EventTime -> SlotNo
eventTimeSlot :: SlotNo
eventTimeEpochNo :: EpochNo
eventTimeEpochSlot :: Word64
eventTimeRelative :: RelativeTime
..} =
  EventTime
    { eventTimeSlot :: SlotNo
eventTimeSlot = SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
eventTimeSlot
    , eventTimeEpochNo :: EpochNo
eventTimeEpochNo = EpochNo
epoch'
    , eventTimeEpochSlot :: Word64
eventTimeEpochSlot = Word64
relSlot'
    , eventTimeRelative :: RelativeTime
eventTimeRelative =
        NominalDiffTime -> RelativeTime -> RelativeTime
addRelTime (SlotLength -> NominalDiffTime
getSlotLength SlotLength
eraSlotLength) (RelativeTime -> RelativeTime) -> RelativeTime -> RelativeTime
forall a b. (a -> b) -> a -> b
$
          RelativeTime
eventTimeRelative
    }
 where
  epoch' :: EpochNo
  relSlot' :: Word64
  (EpochNo
epoch', Word64
relSlot') =
    if Word64 -> Word64
forall a. Enum a => a -> a
succ Word64
eventTimeEpochSlot Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== EpochSize -> Word64
unEpochSize EpochSize
eraEpochSize
      then (EpochNo -> EpochNo
forall a. Enum a => a -> a
succ EpochNo
eventTimeEpochNo, Word64
0)
      else (EpochNo
eventTimeEpochNo, Word64 -> Word64
forall a. Enum a => a -> a
succ Word64
eventTimeEpochSlot)

{-------------------------------------------------------------------------------
  Chain model
-----------------------------------------------------------------------------}

-- | Chain divided into eras
--
-- Like 'Summary', we might not have blocks in the chain for all eras.
-- The chain might be empty, but we must at least have one era.
newtype Chain xs = Chain (NonEmpty xs [Event])
  deriving Int -> Chain xs -> TestName -> TestName
[Chain xs] -> TestName -> TestName
Chain xs -> TestName
(Int -> Chain xs -> TestName -> TestName)
-> (Chain xs -> TestName)
-> ([Chain xs] -> TestName -> TestName)
-> Show (Chain xs)
forall (xs :: [*]). Int -> Chain xs -> TestName -> TestName
forall (xs :: [*]). [Chain xs] -> TestName -> TestName
forall (xs :: [*]). Chain xs -> TestName
forall a.
(Int -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: forall (xs :: [*]). Int -> Chain xs -> TestName -> TestName
showsPrec :: Int -> Chain xs -> TestName -> TestName
$cshow :: forall (xs :: [*]). Chain xs -> TestName
show :: Chain xs -> TestName
$cshowList :: forall (xs :: [*]). [Chain xs] -> TestName -> TestName
showList :: [Chain xs] -> TestName -> TestName
Show

-- | Slot at the tip of the chain
chainTip :: Chain xs -> WithOrigin (EpochNo, SlotNo)
chainTip :: forall (xs :: [*]). Chain xs -> WithOrigin (EpochNo, SlotNo)
chainTip (Chain NonEmpty xs [Event]
xs) = [Event] -> WithOrigin (EpochNo, SlotNo)
tip ([Event] -> WithOrigin (EpochNo, SlotNo))
-> (NonEmpty xs [Event] -> [Event])
-> NonEmpty xs [Event]
-> WithOrigin (EpochNo, SlotNo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> [Event]
forall a. [a] -> [a]
reverse ([Event] -> [Event])
-> (NonEmpty xs [Event] -> [Event])
-> NonEmpty xs [Event]
-> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Event]] -> [Event]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Event]] -> [Event])
-> (NonEmpty xs [Event] -> [[Event]])
-> NonEmpty xs [Event]
-> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty xs [Event] -> [[Event]]
forall a. NonEmpty xs a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty xs [Event] -> WithOrigin (EpochNo, SlotNo))
-> NonEmpty xs [Event] -> WithOrigin (EpochNo, SlotNo)
forall a b. (a -> b) -> a -> b
$ NonEmpty xs [Event]
xs
 where
  tip :: [Event] -> WithOrigin (EpochNo, SlotNo)
  tip :: [Event] -> WithOrigin (EpochNo, SlotNo)
tip [] = WithOrigin (EpochNo, SlotNo)
forall t. WithOrigin t
Origin
  tip (Event
e : [Event]
_) = (EpochNo, SlotNo) -> WithOrigin (EpochNo, SlotNo)
forall t. t -> WithOrigin t
NotOrigin (EventTime -> EpochNo
eventTimeEpochNo (Event -> EventTime
eventTime Event
e), EventTime -> SlotNo
eventTimeSlot (Event -> EventTime
eventTime Event
e))

-- | Find all confirmed transitions in the chain
chainTransitions :: Eras xs -> Chain xs -> HF.Transitions xs
chainTransitions :: forall (xs :: [*]). Eras xs -> Chain xs -> Transitions xs
chainTransitions = \(Eras Exactly (x : xs) Era
eras) (Chain NonEmpty xs [Event]
chain) ->
  AtMost xs EpochNo -> Transitions (x : xs)
forall (xs :: [*]) x. AtMost xs EpochNo -> Transitions (x : xs)
HF.Transitions (AtMost xs EpochNo -> Transitions (x : xs))
-> AtMost xs EpochNo -> Transitions (x : xs)
forall a b. (a -> b) -> a -> b
$
    Exactly (x : xs) Era
-> AtMost (x : xs) (Maybe EpochNo) -> AtMost xs EpochNo
forall x (xs :: [*]).
Exactly (x : xs) Era
-> AtMost (x : xs) (Maybe EpochNo) -> AtMost xs EpochNo
shift Exactly (x : xs) Era
eras ((Era -> [Event] -> Maybe EpochNo)
-> (Era, [Event]) -> Maybe EpochNo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Era -> [Event] -> Maybe EpochNo
findTransition ((Era, [Event]) -> Maybe EpochNo)
-> AtMost (x : xs) (Era, [Event])
-> AtMost (x : xs) (Maybe EpochNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exactly (x : xs) Era
-> NonEmpty xs [Event] -> AtMost (x : xs) (Era, [Event])
forall (t :: * -> *) (xs :: [*]) a b.
Foldable t =>
Exactly xs a -> t b -> AtMost xs (a, b)
exactlyZipFoldable Exactly (x : xs) Era
eras NonEmpty xs [Event]
chain)
 where
  -- After mapping 'findTransition', for each era on the chain we have
  -- 'Maybe' a transition point. Those transition points have structure that
  -- we must recover here:
  --
  -- \* The last era cannot have a transition point (i)
  -- \* Unless it is the last era, the last era /on chain/ may or may
  --   not have a transition point (ii)
  -- \* All other eras on chain /must/ have a transition point (iii)
  --
  -- We must also shift the type-level indices: we find the transition points
  -- in the eras that they occur /in/, but they must be associated with the
  -- eras that they transition /to/.
  shift ::
    Exactly (x ': xs) Era ->
    AtMost (x ': xs) (Maybe EpochNo) ->
    AtMost xs EpochNo
  shift :: forall x (xs :: [*]).
Exactly (x : xs) Era
-> AtMost (x : xs) (Maybe EpochNo) -> AtMost xs EpochNo
shift Exactly (x : xs) Era
_ AtMost (x : xs) (Maybe EpochNo)
AtMostNil =
    -- No more transitions on the chain
    AtMost xs EpochNo
forall (xs :: [*]) a. AtMost xs a
AtMostNil
  shift (ExactlyCons Era
era Exactly xs Era
ExactlyNil) (AtMostCons Maybe EpochNo
transition AtMost xs1 (Maybe EpochNo)
AtMostNil) =
    -- case (i)
    case Maybe EpochNo
transition of
      Maybe EpochNo
Nothing -> AtMost xs EpochNo
forall (xs :: [*]) a. AtMost xs a
AtMostNil
      Just EpochNo
t ->
        TestName -> AtMost xs EpochNo
forall a. HasCallStack => TestName -> a
error (TestName -> AtMost xs EpochNo) -> TestName -> AtMost xs EpochNo
forall a b. (a -> b) -> a -> b
$
          [TestName] -> TestName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ TestName
"Unexpected transition "
            , EpochNo -> TestName
forall a. Show a => a -> TestName
show EpochNo
t
            , TestName
" in final era "
            , Era -> TestName
forall a. Show a => a -> TestName
show Era
era
            ]
  shift (ExactlyCons Era
_ (ExactlyCons Era
_ Exactly xs Era
_)) (AtMostCons Maybe EpochNo
transition AtMost xs1 (Maybe EpochNo)
AtMostNil) =
    -- case (ii)
    case Maybe EpochNo
transition of
      Maybe EpochNo
Nothing -> AtMost xs EpochNo
forall (xs :: [*]) a. AtMost xs a
AtMostNil
      Just EpochNo
t -> EpochNo -> AtMost xs EpochNo -> AtMost (x : xs) EpochNo
forall a (xs1 :: [*]) x. a -> AtMost xs1 a -> AtMost (x : xs1) a
AtMostCons EpochNo
t AtMost xs EpochNo
forall (xs :: [*]) a. AtMost xs a
AtMostNil
  shift (ExactlyCons Era
era eras :: Exactly xs Era
eras@(ExactlyCons Era
_ Exactly xs Era
_)) (AtMostCons Maybe EpochNo
transition AtMost xs1 (Maybe EpochNo)
ts) =
    -- case (iii)
    case Maybe EpochNo
transition of
      Maybe EpochNo
Nothing ->
        TestName -> AtMost xs EpochNo
forall a. HasCallStack => TestName -> a
error (TestName -> AtMost xs EpochNo) -> TestName -> AtMost xs EpochNo
forall a b. (a -> b) -> a -> b
$
          [TestName] -> TestName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ TestName
"Missing transition in era "
            , Era -> TestName
forall a. Show a => a -> TestName
show Era
era
            ]
      Just EpochNo
t -> EpochNo -> AtMost xs EpochNo -> AtMost (x : xs) EpochNo
forall a (xs1 :: [*]) x. a -> AtMost xs1 a -> AtMost (x : xs1) a
AtMostCons EpochNo
t (Exactly (x : xs) Era
-> AtMost (x : xs) (Maybe EpochNo) -> AtMost xs EpochNo
forall x (xs :: [*]).
Exactly (x : xs) Era
-> AtMost (x : xs) (Maybe EpochNo) -> AtMost xs EpochNo
shift Exactly xs Era
Exactly (x : xs) Era
eras AtMost xs1 (Maybe EpochNo)
AtMost (x : xs) (Maybe EpochNo)
ts)

-- | Locate transition point in a list of events
findTransition :: Era -> [Event] -> Maybe EpochNo
findTransition :: Era -> [Event] -> Maybe EpochNo
findTransition Era
era =
  [EpochNo] -> Maybe EpochNo
mustBeUnique ([EpochNo] -> Maybe EpochNo)
-> ([Event] -> [EpochNo]) -> [Event] -> Maybe EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe EpochNo] -> [EpochNo]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe EpochNo] -> [EpochNo])
-> ([Event] -> [Maybe EpochNo]) -> [Event] -> [EpochNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event -> Maybe EpochNo) -> [Event] -> [Maybe EpochNo]
forall a b. (a -> b) -> [a] -> [b]
map (EventType -> Maybe EpochNo
isTransition (EventType -> Maybe EpochNo)
-> (Event -> EventType) -> Event -> Maybe EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> EventType
eventType)
 where
  mustBeUnique :: [EpochNo] -> Maybe EpochNo
  mustBeUnique :: [EpochNo] -> Maybe EpochNo
mustBeUnique [] = Maybe EpochNo
forall a. Maybe a
Nothing
  mustBeUnique [EpochNo
e] = EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
e
  mustBeUnique [EpochNo]
_ = TestName -> Maybe EpochNo
forall a. HasCallStack => TestName -> a
error (TestName -> Maybe EpochNo) -> TestName -> Maybe EpochNo
forall a b. (a -> b) -> a -> b
$ TestName
"multiple transition points in " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Era -> TestName
forall a. Show a => a -> TestName
show Era
era

  isTransition :: EventType -> Maybe EpochNo
  isTransition :: EventType -> Maybe EpochNo
isTransition (Confirm EpochNo
e) = EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
e
  isTransition EventType
Tick = Maybe EpochNo
forall a. Maybe a
Nothing

fromEvents :: Eras xs -> [Event] -> Chain xs
fromEvents :: forall (xs :: [*]). Eras xs -> [Event] -> Chain xs
fromEvents (Eras Exactly (x : xs) Era
eras) [Event]
events =
  NonEmpty xs [Event] -> Chain xs
forall (xs :: [*]). NonEmpty xs [Event] -> Chain xs
Chain (NonEmpty xs [Event] -> Chain xs)
-> NonEmpty xs [Event] -> Chain xs
forall a b. (a -> b) -> a -> b
$
    NonEmpty xs [Event]
-> Maybe (NonEmpty xs [Event]) -> NonEmpty xs [Event]
forall a. a -> Maybe a -> a
fromMaybe ([Event] -> NonEmpty (x : xs) [Event]
forall a x (xs1 :: [*]). a -> NonEmpty (x : xs1) a
NonEmptyOne []) (Maybe (NonEmpty xs [Event]) -> NonEmpty xs [Event])
-> (AtMost (x : xs) (Era, [Event]) -> Maybe (NonEmpty xs [Event]))
-> AtMost (x : xs) (Era, [Event])
-> NonEmpty xs [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AtMost (x : xs) [Event] -> Maybe (NonEmpty xs [Event])
AtMost (x : xs) [Event] -> Maybe (NonEmpty (x : xs) [Event])
forall x (xs :: [*]) a.
AtMost (x : xs) a -> Maybe (NonEmpty (x : xs) a)
atMostNonEmpty (AtMost (x : xs) [Event] -> Maybe (NonEmpty xs [Event]))
-> (AtMost (x : xs) (Era, [Event]) -> AtMost (x : xs) [Event])
-> AtMost (x : xs) (Era, [Event])
-> Maybe (NonEmpty xs [Event])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Era, [Event]) -> [Event])
-> AtMost (x : xs) (Era, [Event]) -> AtMost (x : xs) [Event]
forall a b. (a -> b) -> AtMost (x : xs) a -> AtMost (x : xs) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Era, [Event]) -> [Event]
forall a b. (a, b) -> b
snd (AtMost (x : xs) (Era, [Event]) -> NonEmpty xs [Event])
-> AtMost (x : xs) (Era, [Event]) -> NonEmpty xs [Event]
forall a b. (a -> b) -> a -> b
$
      Exactly (x : xs) Era -> [[Event]] -> AtMost (x : xs) (Era, [Event])
forall (t :: * -> *) (xs :: [*]) a b.
Foldable t =>
Exactly xs a -> t b -> AtMost xs (a, b)
exactlyZipFoldable Exactly (x : xs) Era
eras [[Event]]
grouped
 where
  grouped :: [[Event]]
  grouped :: [[Event]]
grouped = (Event -> Event -> Bool) -> [Event] -> [[Event]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy (Era -> Era -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Era -> Era -> Bool) -> (Event -> Era) -> Event -> Event -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Event -> Era
eventEra) [Event]
events

{-------------------------------------------------------------------------------
  Generate events
-------------------------------------------------------------------------------}

-- | Time used during event generation
data Time = forall x xs. Time
  { Time -> EventTime
timeEvent :: EventTime
  , Time -> Maybe EpochNo
timeNextEra :: Maybe EpochNo
  -- ^ Start of the epoch (if already decided)
  , ()
timeEras :: Exactly (x ': xs) (Era, HF.EraParams)
  }

stepTime :: EventType -> Time -> Time
stepTime :: EventType -> Time -> Time
stepTime EventType
typ Time{Maybe EpochNo
Exactly (x : xs) (Era, EraParams)
EventTime
timeEvent :: Time -> EventTime
timeNextEra :: Time -> Maybe EpochNo
timeEras :: ()
timeEvent :: EventTime
timeNextEra :: Maybe EpochNo
timeEras :: Exactly (x : xs) (Era, EraParams)
..} =
  case (EventType
typ, Maybe EpochNo
timeNextEra, Exactly (x : xs) (Era, EraParams) -> Exactly xs (Era, EraParams)
forall x (xs :: [*]) a. Exactly (x : xs) a -> Exactly xs a
exactlyTail Exactly (x : xs) (Era, EraParams)
timeEras) of
    (EventType
Tick, Maybe EpochNo
Nothing, Exactly xs (Era, EraParams)
_) ->
      EventTime
-> Maybe EpochNo -> Exactly (x : xs) (Era, EraParams) -> Time
forall x (xs :: [*]).
EventTime
-> Maybe EpochNo -> Exactly (x : xs) (Era, EraParams) -> Time
Time EventTime
timeEvent' Maybe EpochNo
forall a. Maybe a
Nothing Exactly (x : xs) (Era, EraParams)
timeEras
    (EventType
Tick, Just EpochNo
e, timeEras' :: Exactly xs (Era, EraParams)
timeEras'@(ExactlyCons (Era, EraParams)
_ Exactly xs (Era, EraParams)
_))
      | EpochNo -> Bool
reachedNextEra EpochNo
e ->
          EventTime
-> Maybe EpochNo -> Exactly (x : xs) (Era, EraParams) -> Time
forall x (xs :: [*]).
EventTime
-> Maybe EpochNo -> Exactly (x : xs) (Era, EraParams) -> Time
Time EventTime
timeEvent' Maybe EpochNo
forall a. Maybe a
Nothing Exactly xs (Era, EraParams)
Exactly (x : xs) (Era, EraParams)
timeEras'
    (EventType
Tick, Just EpochNo
e, Exactly xs (Era, EraParams)
ExactlyNil)
      | EpochNo -> Bool
reachedNextEra EpochNo
e ->
          TestName -> Time
forall a. HasCallStack => TestName -> a
error TestName
"stepTime: unexpected confirmation in final era"
    (EventType
Tick, Just EpochNo
e, Exactly xs (Era, EraParams)
_) ->
      -- not (reachedNextEra e)
      EventTime
-> Maybe EpochNo -> Exactly (x : xs) (Era, EraParams) -> Time
forall x (xs :: [*]).
EventTime
-> Maybe EpochNo -> Exactly (x : xs) (Era, EraParams) -> Time
Time EventTime
timeEvent' (EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
e) Exactly (x : xs) (Era, EraParams)
timeEras
    (Confirm EpochNo
_, Just EpochNo
_, Exactly xs (Era, EraParams)
_) ->
      TestName -> Time
forall a. HasCallStack => TestName -> a
error TestName
"stepTime: unexpected double confirmation"
    (Confirm EpochNo
e, Maybe EpochNo
Nothing, Exactly xs (Era, EraParams)
_) ->
      EventTime
-> Maybe EpochNo -> Exactly (x : xs) (Era, EraParams) -> Time
forall x (xs :: [*]).
EventTime
-> Maybe EpochNo -> Exactly (x : xs) (Era, EraParams) -> Time
Time EventTime
timeEvent' (EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
e) Exactly (x : xs) (Era, EraParams)
timeEras
 where
  timeEvent' :: EventTime
  timeEvent' :: EventTime
timeEvent' = EraParams -> EventTime -> EventTime
stepEventTime ((Era, EraParams) -> EraParams
forall a b. (a, b) -> b
snd (Exactly (x : xs) (Era, EraParams) -> (Era, EraParams)
forall x (xs :: [*]) a. Exactly (x : xs) a -> a
exactlyHead Exactly (x : xs) (Era, EraParams)
timeEras)) EventTime
timeEvent

  reachedNextEra :: EpochNo -> Bool
  reachedNextEra :: EpochNo -> Bool
reachedNextEra EpochNo
e = EventTime -> EpochNo
eventTimeEpochNo EventTime
timeEvent' EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
== EpochNo
e

genEvents :: Eras xs -> HF.Shape xs -> Gen [Event]
genEvents :: forall (xs :: [*]). Eras xs -> Shape xs -> Gen [Event]
genEvents = \(Eras Exactly (x : xs) Era
eras) (HF.Shape Exactly xs EraParams
shape) -> (Int -> Gen [Event]) -> Gen [Event]
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen [Event]) -> Gen [Event])
-> (Int -> Gen [Event]) -> Gen [Event]
forall a b. (a -> b) -> a -> b
$ \Int
sz -> do
  Int -> Time -> Gen [Event]
go
    Int
sz
    Time
      { timeEvent :: EventTime
timeEvent = EventTime
initEventTime
      , timeNextEra :: Maybe EpochNo
timeNextEra = Maybe EpochNo
forall a. Maybe a
Nothing
      , timeEras :: Exactly (x : xs) (Era, EraParams)
timeEras = Exactly (x : xs) Era
-> Exactly (x : xs) EraParams -> Exactly (x : xs) (Era, EraParams)
forall (xs :: [*]) a b.
Exactly xs a -> Exactly xs b -> Exactly xs (a, b)
exactlyZip Exactly (x : xs) Era
eras Exactly xs EraParams
Exactly (x : xs) EraParams
shape
      }
 where
  go :: Int -> Time -> Gen [Event]
  go :: Int -> Time -> Gen [Event]
go Int
0 Time
_ = [Event] -> Gen [Event]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  go Int
n time :: Time
time@Time{Maybe EpochNo
Exactly (x : xs) (Era, EraParams)
EventTime
timeEvent :: Time -> EventTime
timeNextEra :: Time -> Maybe EpochNo
timeEras :: ()
timeEvent :: EventTime
timeNextEra :: Maybe EpochNo
timeEras :: Exactly (x : xs) (Era, EraParams)
..} = do
    typ <-
      [(Int, Gen EventType)] -> Gen EventType
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency ([(Int, Gen EventType)] -> Gen EventType)
-> [(Int, Gen EventType)] -> Gen EventType
forall a b. (a -> b) -> a -> b
$
        [[(Int, Gen EventType)]] -> [(Int, Gen EventType)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [(Int
2, EventType -> Gen EventType
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return EventType
Tick)]
          , case Maybe (Gen EpochNo)
canTransition of
              Maybe (Gen EpochNo)
Nothing -> []
              Just Gen EpochNo
pickStart -> [(Int
1, EpochNo -> EventType
Confirm (EpochNo -> EventType) -> Gen EpochNo -> Gen EventType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen EpochNo
pickStart)]
          ]
    let event =
          Event
            { eventType :: EventType
eventType = EventType
typ
            , eventTime :: EventTime
eventTime = EventTime
timeEvent
            , eventEra :: Era
eventEra = Era
era
            , eventEraParams :: EraParams
eventEraParams = EraParams
eraParams
            }
    (event :) <$> go (n - 1) (stepTime typ time)
   where
    era :: Era
    eraParams :: HF.EraParams
    (Era
era, EraParams
eraParams) = Exactly (x : xs) (Era, EraParams) -> (Era, EraParams)
forall x (xs :: [*]) a. Exactly (x : xs) a -> a
exactlyHead Exactly (x : xs) (Era, EraParams)
timeEras

    canTransition :: Maybe (Gen EpochNo)
    canTransition :: Maybe (Gen EpochNo)
canTransition
      | Just EpochNo
_ <- Maybe EpochNo
timeNextEra =
          -- We already generated a transition
          Maybe (Gen EpochNo)
forall a. Maybe a
Nothing
      | Exactly xs (Era, EraParams)
ExactlyNil <- Exactly (x : xs) (Era, EraParams) -> Exactly xs (Era, EraParams)
forall x (xs :: [*]) a. Exactly (x : xs) a -> Exactly xs a
exactlyTail Exactly (x : xs) (Era, EraParams)
timeEras =
          -- We are in the final era
          Maybe (Gen EpochNo)
forall a. Maybe a
Nothing
      | Maybe EpochNo
Nothing <- Maybe EpochNo
mNextLo =
          -- This era is 'UnsafeIndefiniteSafeZone'
          Maybe (Gen EpochNo)
forall a. Maybe a
Nothing
      | Just EpochNo
lo <- Maybe EpochNo
mNextLo =
          Gen EpochNo -> Maybe (Gen EpochNo)
forall a. a -> Maybe a
Just (EpochNo -> Gen EpochNo
pickStartOfNextEra EpochNo
lo)

    -- Lower bound on the start of the next era
    mNextLo :: Maybe EpochNo
    mNextLo :: Maybe EpochNo
mNextLo =
      case EraParams -> SafeZone
HF.eraSafeZone EraParams
eraParams of
        SafeZone
HF.UnsafeIndefiniteSafeZone -> Maybe EpochNo
forall a. Maybe a
Nothing
        HF.StandardSafeZone Word64
safeFromTip ->
          EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just (EpochNo -> Maybe EpochNo) -> EpochNo -> Maybe EpochNo
forall a b. (a -> b) -> a -> b
$
            -- The 'EventTime' of the first event after the safe zone
            -- (The @+ 1@ here is required because the first step is to skip
            -- over the 'Confirm' itself)
            let afterSafeZone :: EventTime
                afterSafeZone :: EventTime
afterSafeZone =
                  (EventTime -> EventTime) -> Word64 -> EventTime -> EventTime
forall a. (a -> a) -> Word64 -> a -> a
nTimes
                    (EraParams -> EventTime -> EventTime
stepEventTime EraParams
eraParams)
                    (Word64
safeFromTip Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
                    EventTime
timeEvent
             in if EventTime -> Word64
eventTimeEpochSlot EventTime
afterSafeZone Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
                  then EventTime -> EpochNo
eventTimeEpochNo EventTime
afterSafeZone
                  else EventTime -> EpochNo
eventTimeEpochNo EventTime
afterSafeZone EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1

    pickStartOfNextEra :: EpochNo -> Gen EpochNo
    pickStartOfNextEra :: EpochNo -> Gen EpochNo
pickStartOfNextEra EpochNo
lo = (\Word64
d -> Word64 -> EpochNo -> EpochNo
HF.addEpochs Word64
d EpochNo
lo) (Word64 -> EpochNo) -> Gen Word64 -> Gen EpochNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
10)

{-------------------------------------------------------------------------------
  Safe zone
-------------------------------------------------------------------------------}

-- | The safe zone active at the end of the chain
--
-- If the transition to the next era is known, we specify the epoch number of
-- the start of the next era and the safe zone in that next era; otherwise we
-- give the safe zone in the current era.
activeSafeZone ::
  HF.Shape xs ->
  Chain xs ->
  HF.Transitions xs ->
  (Maybe EpochNo, HF.SafeZone)
activeSafeZone :: forall (xs :: [*]).
Shape xs -> Chain xs -> Transitions xs -> (Maybe EpochNo, SafeZone)
activeSafeZone (HF.Shape Exactly xs EraParams
shape) (Chain NonEmpty xs [Event]
chain) (HF.Transitions AtMost xs EpochNo
transitions) =
  Exactly (x : xs) EraParams
-> NonEmpty (x : xs) [Event]
-> AtMost xs EpochNo
-> (Maybe EpochNo, SafeZone)
forall x (xs :: [*]).
Exactly (x : xs) EraParams
-> NonEmpty (x : xs) [Event]
-> AtMost xs EpochNo
-> (Maybe EpochNo, SafeZone)
go Exactly xs EraParams
Exactly (x : xs) EraParams
shape NonEmpty xs [Event]
NonEmpty (x : xs) [Event]
chain AtMost xs EpochNo
transitions
 where
  go ::
    Exactly (x ': xs) HF.EraParams ->
    NonEmpty (x ': xs) [Event] ->
    AtMost xs EpochNo ->
    (Maybe EpochNo, HF.SafeZone)
  -- No transition is yet known for the last era on the chain
  go :: forall x (xs :: [*]).
Exactly (x : xs) EraParams
-> NonEmpty (x : xs) [Event]
-> AtMost xs EpochNo
-> (Maybe EpochNo, SafeZone)
go (ExactlyCons EraParams
ps Exactly xs EraParams
_) (NonEmptyOne [Event]
_) AtMost xs EpochNo
AtMostNil =
    (Maybe EpochNo
forall a. Maybe a
Nothing, EraParams -> SafeZone
HF.eraSafeZone EraParams
ps)
  -- Transition /is/ known for the last era on the chain
  go (ExactlyCons EraParams
_ Exactly xs EraParams
pss) (NonEmptyOne [Event]
_) (AtMostCons EpochNo
t AtMost xs1 EpochNo
AtMostNil) =
    (EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
t, EraParams -> SafeZone
HF.eraSafeZone (Exactly (x : xs1) EraParams -> EraParams
forall x (xs :: [*]) a. Exactly (x : xs) a -> a
exactlyHead Exactly xs EraParams
Exactly (x : xs1) EraParams
pss))
  -- Find the last era on chain
  go (ExactlyCons EraParams
_ Exactly xs EraParams
pss) (NonEmptyCons [Event]
_ NonEmpty xs1 [Event]
ess) AtMost xs EpochNo
AtMostNil =
    -- We need to convince ghc there is another era
    case NonEmpty xs1 [Event]
ess of
      NonEmptyCons{} -> Exactly (x : xs1) EraParams
-> NonEmpty (x : xs1) [Event]
-> AtMost xs1 EpochNo
-> (Maybe EpochNo, SafeZone)
forall x (xs :: [*]).
Exactly (x : xs) EraParams
-> NonEmpty (x : xs) [Event]
-> AtMost xs EpochNo
-> (Maybe EpochNo, SafeZone)
go Exactly xs EraParams
Exactly (x : xs1) EraParams
pss NonEmpty xs1 [Event]
NonEmpty (x : xs1) [Event]
ess AtMost xs1 EpochNo
forall (xs :: [*]) a. AtMost xs a
AtMostNil
      NonEmptyOne{} -> Exactly (x : xs1) EraParams
-> NonEmpty (x : xs1) [Event]
-> AtMost xs1 EpochNo
-> (Maybe EpochNo, SafeZone)
forall x (xs :: [*]).
Exactly (x : xs) EraParams
-> NonEmpty (x : xs) [Event]
-> AtMost xs EpochNo
-> (Maybe EpochNo, SafeZone)
go Exactly xs EraParams
Exactly (x : xs1) EraParams
pss NonEmpty xs1 [Event]
NonEmpty (x : xs1) [Event]
ess AtMost xs1 EpochNo
forall (xs :: [*]) a. AtMost xs a
AtMostNil
  go (ExactlyCons EraParams
_ Exactly xs EraParams
pss) (NonEmptyCons [Event]
_ NonEmpty xs1 [Event]
ess) (AtMostCons EpochNo
_ AtMost xs1 EpochNo
ts) =
    Exactly (x : xs1) EraParams
-> NonEmpty (x : xs1) [Event]
-> AtMost xs1 EpochNo
-> (Maybe EpochNo, SafeZone)
forall x (xs :: [*]).
Exactly (x : xs) EraParams
-> NonEmpty (x : xs) [Event]
-> AtMost xs EpochNo
-> (Maybe EpochNo, SafeZone)
go Exactly xs EraParams
Exactly (x : xs1) EraParams
pss NonEmpty xs1 [Event]
NonEmpty (x : xs1) [Event]
ess AtMost xs1 EpochNo
ts
  -- Impossible cases

  -- If this is the final era on the chain, we might know the transition to
  -- the next era, but we certainly couldn't know the next transition
  go Exactly (x : xs) EraParams
_ (NonEmptyOne [Event]
_) (AtMostCons EpochNo
_ (AtMostCons{})) =
    TestName -> (Maybe EpochNo, SafeZone)
forall a. HasCallStack => TestName -> a
error TestName
"activeSafeZone: impossible"

-- | Return the events within and outside of the safe zone
splitSafeZone ::
  -- | Epoch at the tip of the chain
  -- (Needed because transitions only happen at epoch boundaries)
  WithOrigin EpochNo ->
  -- | Active safe zone (see 'activeSafeZone')
  (Maybe EpochNo, HF.SafeZone) ->
  -- | Events after the end of the chain
  [Event] ->
  ([Event], [Event])
splitSafeZone :: WithOrigin EpochNo
-> (Maybe EpochNo, SafeZone) -> [Event] -> ([Event], [Event])
splitSafeZone WithOrigin EpochNo
tipEpoch = \(Maybe EpochNo
mTransition, SafeZone
safeZone) [Event]
events ->
  let ([Event]
definitelySafe, [Event]
rest) =
        case Maybe EpochNo
mTransition of
          Maybe EpochNo
Nothing -> ([], [Event]
events)
          Just EpochNo
t -> (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (EpochNo -> Event -> Bool
beforeEpoch EpochNo
t) [Event]
events
   in ([Event] -> [Event]) -> ([Event], [Event]) -> ([Event], [Event])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Event]
definitelySafe [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++) (([Event], [Event]) -> ([Event], [Event]))
-> ([Event], [Event]) -> ([Event], [Event])
forall a b. (a -> b) -> a -> b
$ [Event] -> SafeZone -> [Event] -> ([Event], [Event])
go [] SafeZone
safeZone [Event]
rest
 where
  beforeEpoch :: EpochNo -> Event -> Bool
  beforeEpoch :: EpochNo -> Event -> Bool
beforeEpoch EpochNo
t Event
e = EventTime -> EpochNo
eventTimeEpochNo (Event -> EventTime
eventTime Event
e) EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
< EpochNo
t

  go ::
    [Event] -> -- Accumulated events in the safe zone
    HF.SafeZone -> -- Remaining safe zone
    [Event] -> -- Remaining events to be processed
    ([Event], [Event])
  go :: [Event] -> SafeZone -> [Event] -> ([Event], [Event])
go [Event]
acc SafeZone
_ [] =
    ([Event] -> [Event]
forall a. [a] -> [a]
reverse [Event]
acc, [])
  go [Event]
acc (HF.StandardSafeZone Word64
safeFromTip) (Event
e : [Event]
es)
    -- Interpret the 'SafeZone' parameters
    | Word64
safeFromTip Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0 =
        [Event] -> SafeZone -> [Event] -> ([Event], [Event])
go (Event
e Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
acc) (Word64 -> SafeZone
HF.StandardSafeZone (Word64 -> Word64
forall a. Enum a => a -> a
pred Word64
safeFromTip)) [Event]
es
    | Bool
otherwise =
        let ([Event]
sameEpoch, [Event]
rest) = (Event -> Bool) -> [Event] -> ([Event], [Event])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Event -> Bool
inLastEpoch (Event
e Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
es)
         in ([Event] -> [Event]
forall a. [a] -> [a]
reverse [Event]
acc [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++ [Event]
sameEpoch, [Event]
rest)
   where
    lastEpoch :: EpochNo
    lastEpoch :: EpochNo
lastEpoch = case [Event]
acc of
      [] -> EpochNo -> WithOrigin EpochNo -> EpochNo
forall t. t -> WithOrigin t -> t
fromWithOrigin (Word64 -> EpochNo
EpochNo Word64
0) WithOrigin EpochNo
tipEpoch
      Event
e' : [Event]
_ -> EventTime -> EpochNo
eventTimeEpochNo (Event -> EventTime
eventTime Event
e')

    inLastEpoch :: Event -> Bool
    inLastEpoch :: Event -> Bool
inLastEpoch Event
e' = EventTime -> EpochNo
eventTimeEpochNo (Event -> EventTime
eventTime Event
e') EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
== EpochNo
lastEpoch
  go [Event]
acc SafeZone
HF.UnsafeIndefiniteSafeZone (Event
e : [Event]
es) =
    [Event] -> SafeZone -> [Event] -> ([Event], [Event])
go (Event
e Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
: [Event]
acc) SafeZone
HF.UnsafeIndefiniteSafeZone [Event]
es

{-------------------------------------------------------------------------------
  Relation to the HardForkLedgerView
-------------------------------------------------------------------------------}

-- | Construct 'EpochInfo' through the forecast
--
-- We also 'Show' the 'HardForkLedgerView' and the reconstructed 'Summary',
-- for the benefit of 'counterexample'.
hardForkEpochInfo :: ArbitraryChain -> SlotNo -> (EpochInfo Identity, String, String)
hardForkEpochInfo :: ArbitraryChain
-> SlotNo -> (EpochInfo Identity, TestName, TestName)
hardForkEpochInfo ArbitraryChain{[Event]
(Maybe EpochNo, SafeZone)
Transitions xs
Summary xs
Chain xs
Event
EventIx
ArbitraryParams xs
arbitraryEvent :: ArbitraryChain -> Event
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySummary :: ()
arbitraryTransitions :: ()
arbitraryChain :: ()
arbitraryParams :: ()
arbitraryParams :: ArbitraryParams xs
arbitraryChain :: Chain xs
arbitraryTransitions :: Transitions xs
arbitrarySummary :: Summary xs
arbitrarySafeZone :: (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: [Event]
arbitraryPastHorizon :: [Event]
arbitraryEventIx :: EventIx
arbitraryEvent :: Event
..} SlotNo
for =
  let forecast :: Forecast (HardForkLedgerView_ (K ()) xs)
forecast =
        Shape xs
-> Transitions xs
-> Chain xs
-> Forecast (HardForkLedgerView_ (K ()) xs)
forall (xs :: [*]).
SListI xs =>
Shape xs
-> Transitions xs
-> Chain xs
-> Forecast (HardForkLedgerView_ (K ()) xs)
mockHardForkLedgerView
          Shape xs
arbitraryChainShape
          Transitions xs
arbitraryTransitions
          Chain xs
arbitraryChain
   in case Except OutsideForecastRange (HardForkLedgerView_ (K ()) xs)
-> Either OutsideForecastRange (HardForkLedgerView_ (K ()) xs)
forall e a. Except e a -> Either e a
runExcept (Except OutsideForecastRange (HardForkLedgerView_ (K ()) xs)
 -> Either OutsideForecastRange (HardForkLedgerView_ (K ()) xs))
-> Except OutsideForecastRange (HardForkLedgerView_ (K ()) xs)
-> Either OutsideForecastRange (HardForkLedgerView_ (K ()) xs)
forall a b. (a -> b) -> a -> b
$ Forecast (HardForkLedgerView_ (K ()) xs)
-> SlotNo
-> Except OutsideForecastRange (HardForkLedgerView_ (K ()) xs)
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor Forecast (HardForkLedgerView_ (K ()) xs)
forecast SlotNo
for of
        Left OutsideForecastRange
err ->
          ( EpochInfo
              { epochInfoSize_ :: HasCallStack => EpochNo -> Identity EpochSize
epochInfoSize_ = \EpochNo
_ -> OutsideForecastRange -> Identity EpochSize
forall a e. (HasCallStack, Exception e) => e -> a
throw OutsideForecastRange
err
              , epochInfoFirst_ :: HasCallStack => EpochNo -> Identity SlotNo
epochInfoFirst_ = \EpochNo
_ -> OutsideForecastRange -> Identity SlotNo
forall a e. (HasCallStack, Exception e) => e -> a
throw OutsideForecastRange
err
              , epochInfoEpoch_ :: HasCallStack => SlotNo -> Identity EpochNo
epochInfoEpoch_ = \SlotNo
_ -> OutsideForecastRange -> Identity EpochNo
forall a e. (HasCallStack, Exception e) => e -> a
throw OutsideForecastRange
err
              , epochInfoSlotToRelativeTime_ :: HasCallStack => SlotNo -> Identity RelativeTime
epochInfoSlotToRelativeTime_ = \SlotNo
_ -> OutsideForecastRange -> Identity RelativeTime
forall a e. (HasCallStack, Exception e) => e -> a
throw OutsideForecastRange
err
              , epochInfoSlotLength_ :: HasCallStack => SlotNo -> Identity SlotLength
epochInfoSlotLength_ = \SlotNo
_ -> OutsideForecastRange -> Identity SlotLength
forall a e. (HasCallStack, Exception e) => e -> a
throw OutsideForecastRange
err
              }
          , TestName
"<out of range>"
          , TestName
"<out of range>"
          )
        Right view :: HardForkLedgerView_ (K ()) xs
view@HardForkLedgerView{TransitionInfo
HardForkState (K ()) xs
hardForkLedgerViewTransition :: TransitionInfo
hardForkLedgerViewPerEra :: HardForkState (K ()) xs
hardForkLedgerViewPerEra :: forall (f :: * -> *) (xs :: [*]).
HardForkLedgerView_ f xs -> HardForkState f xs
hardForkLedgerViewTransition :: forall (f :: * -> *) (xs :: [*]).
HardForkLedgerView_ f xs -> TransitionInfo
..} ->
          let reconstructed :: Summary xs
reconstructed =
                Shape xs -> TransitionInfo -> HardForkState (K ()) xs -> Summary xs
forall (xs :: [*]) (f :: * -> *).
Shape xs -> TransitionInfo -> HardForkState f xs -> Summary xs
State.reconstructSummary
                  Shape xs
arbitraryChainShape
                  TransitionInfo
hardForkLedgerViewTransition
                  HardForkState (K ()) xs
hardForkLedgerViewPerEra
           in ( EpochInfo (Except PastHorizonException) -> EpochInfo Identity
HF.toPureEpochInfo (Summary xs -> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
Summary xs -> EpochInfo (Except PastHorizonException)
HF.summaryToEpochInfo Summary xs
reconstructed)
              , HardForkLedgerView_ (K ()) xs -> TestName
forall a. Show a => a -> TestName
show HardForkLedgerView_ (K ()) xs
view
              , Summary xs -> TestName
forall a. Show a => a -> TestName
show Summary xs
reconstructed
              )
 where
  ArbitraryParams{Int
[Event]
NominalDiffTime
Shape xs
Eras xs
arbitraryDiffTime :: forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
arbitraryChainSplit :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryRawEventIx :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainShape :: forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryChainEras :: forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainEvents :: forall (xs :: [*]). ArbitraryParams xs -> [Event]
arbitraryChainShape :: Shape xs
arbitraryChainEvents :: [Event]
arbitraryChainEras :: Eras xs
arbitraryRawEventIx :: Int
arbitraryChainSplit :: Int
arbitraryDiffTime :: NominalDiffTime
..} = ArbitraryParams xs
arbitraryParams

mockHardForkLedgerView ::
  SListI xs =>
  HF.Shape xs ->
  HF.Transitions xs ->
  Chain xs ->
  Forecast (HardForkLedgerView_ (K ()) xs)
mockHardForkLedgerView :: forall (xs :: [*]).
SListI xs =>
Shape xs
-> Transitions xs
-> Chain xs
-> Forecast (HardForkLedgerView_ (K ()) xs)
mockHardForkLedgerView = \(HF.Shape Exactly xs EraParams
pss) (HF.Transitions AtMost xs EpochNo
ts) (Chain NonEmpty xs [Event]
ess) ->
  InPairs (CrossEraForecaster (K2 ()) (K ())) xs
-> HardForkState (AnnForecast (K2 ()) (K ())) xs
-> Forecast (HardForkLedgerView_ (K ()) xs)
forall (state :: * -> (* -> * -> *) -> *) (view :: * -> *)
       (xs :: [*]).
SListI xs =>
InPairs (CrossEraForecaster state view) xs
-> HardForkState (AnnForecast state view) xs
-> Forecast (HardForkLedgerView_ view xs)
mkHardForkForecast
    ((forall x y. CrossEraForecaster (K2 ()) (K ()) x y)
-> InPairs (CrossEraForecaster (K2 ()) (K ())) xs
forall {k} (xs :: [k]) (f :: k -> k -> *).
(SListI xs, IsNonEmpty xs) =>
(forall (x :: k) (y :: k). f x y) -> InPairs f xs
InPairs.hpure ((forall x y. CrossEraForecaster (K2 ()) (K ()) x y)
 -> InPairs (CrossEraForecaster (K2 ()) (K ())) xs)
-> (forall x y. CrossEraForecaster (K2 ()) (K ()) x y)
-> InPairs (CrossEraForecaster (K2 ()) (K ())) xs
forall a b. (a -> b) -> a -> b
$ (Bound
 -> SlotNo
 -> K2 () x EmptyMK
 -> Except OutsideForecastRange (K () y))
-> CrossEraForecaster (K2 ()) (K ()) x y
forall (state :: * -> (* -> * -> *) -> *) (view :: * -> *) x y.
(Bound
 -> SlotNo
 -> state x EmptyMK
 -> Except OutsideForecastRange (view y))
-> CrossEraForecaster state view x y
CrossEraForecaster ((Bound
  -> SlotNo
  -> K2 () x EmptyMK
  -> Except OutsideForecastRange (K () y))
 -> CrossEraForecaster (K2 ()) (K ()) x y)
-> (Bound
    -> SlotNo
    -> K2 () x EmptyMK
    -> Except OutsideForecastRange (K () y))
-> CrossEraForecaster (K2 ()) (K ()) x y
forall a b. (a -> b) -> a -> b
$ \Bound
_epoch SlotNo
_slot K2 () x EmptyMK
_ -> K () y -> Except OutsideForecastRange (K () y)
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (K () y -> Except OutsideForecastRange (K () y))
-> K () y -> Except OutsideForecastRange (K () y)
forall a b. (a -> b) -> a -> b
$ () -> K () y
forall k a (b :: k). a -> K a b
K ())
    (Telescope (K Past) (Current (AnnForecast (K2 ()) (K ()))) xs
-> HardForkState (AnnForecast (K2 ()) (K ())) xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Bound
-> Exactly (x : xs) EraParams
-> AtMost xs EpochNo
-> NonEmpty (x : xs) [Event]
-> Telescope
     (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs)
forall x (xs :: [*]).
Bound
-> Exactly (x : xs) EraParams
-> AtMost xs EpochNo
-> NonEmpty (x : xs) [Event]
-> Telescope
     (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs)
mockState Bound
HF.initBound Exactly xs EraParams
Exactly (x : xs) EraParams
pss AtMost xs EpochNo
ts NonEmpty xs [Event]
NonEmpty (x : xs) [Event]
ess))
 where
  mockState ::
    HF.Bound ->
    Exactly (x ': xs) HF.EraParams ->
    AtMost xs EpochNo ->
    NonEmpty (x ': xs) [Event] ->
    Telescope (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs)
  mockState :: forall x (xs :: [*]).
Bound
-> Exactly (x : xs) EraParams
-> AtMost xs EpochNo
-> NonEmpty (x : xs) [Event]
-> Telescope
     (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs)
mockState Bound
start (ExactlyCons EraParams
ps Exactly xs EraParams
_) AtMost xs EpochNo
ts (NonEmptyOne [Event]
es) =
    Current (AnnForecast (K2 ()) (K ())) x
-> Telescope
     (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs)
forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]).
f x -> Telescope g f (x : xs1)
TZ (Current (AnnForecast (K2 ()) (K ())) x
 -> Telescope
      (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs))
-> Current (AnnForecast (K2 ()) (K ())) x
-> Telescope
     (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs)
forall a b. (a -> b) -> a -> b
$
      Bound
-> AnnForecast (K2 ()) (K ()) x
-> Current (AnnForecast (K2 ()) (K ())) x
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
start (AnnForecast (K2 ()) (K ()) x
 -> Current (AnnForecast (K2 ()) (K ())) x)
-> AnnForecast (K2 ()) (K ()) x
-> Current (AnnForecast (K2 ()) (K ())) x
forall a b. (a -> b) -> a -> b
$
        AnnForecast
          { annForecast :: Forecast (K () x)
annForecast =
              Forecast
                { forecastAt :: WithOrigin SlotNo
forecastAt = [Event] -> WithOrigin SlotNo
tip [Event]
es -- forecast at tip of ledger
                , forecastFor :: SlotNo -> Except OutsideForecastRange (K () x)
forecastFor = \SlotNo
_for -> K () x -> Except OutsideForecastRange (K () x)
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (K () x -> Except OutsideForecastRange (K () x))
-> K () x -> Except OutsideForecastRange (K () x)
forall a b. (a -> b) -> a -> b
$ () -> K () x
forall k a (b :: k). a -> K a b
K ()
                }
          , annForecastState :: K2 () x EmptyMK
annForecastState = () -> K2 () x EmptyMK
forall k1 k2 a (b :: k1) (c :: k2). a -> K2 a b c
K2 ()
          , annForecastTip :: WithOrigin SlotNo
annForecastTip = [Event] -> WithOrigin SlotNo
tip [Event]
es
          , annForecastEnd :: Maybe Bound
annForecastEnd = HasCallStack => EraParams -> Bound -> EpochNo -> Bound
EraParams -> Bound -> EpochNo -> Bound
HF.mkUpperBound EraParams
ps Bound
start (EpochNo -> Bound) -> Maybe EpochNo -> Maybe Bound
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AtMost xs EpochNo -> Maybe EpochNo
forall (xs :: [*]) a. AtMost xs a -> Maybe a
atMostHead AtMost xs EpochNo
ts
          }
  mockState Bound
start (ExactlyCons EraParams
ps Exactly xs EraParams
pss) (AtMostCons EpochNo
t AtMost xs1 EpochNo
ts) (NonEmptyCons [Event]
_ NonEmpty xs1 [Event]
ess) =
    K Past x
-> Telescope (K Past) (Current (AnnForecast (K2 ()) (K ()))) xs
-> Telescope
     (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs)
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)) (Bound
-> Exactly (x : xs1) EraParams
-> AtMost xs1 EpochNo
-> NonEmpty (x : xs1) [Event]
-> Telescope
     (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs1)
forall x (xs :: [*]).
Bound
-> Exactly (x : xs) EraParams
-> AtMost xs EpochNo
-> NonEmpty (x : xs) [Event]
-> Telescope
     (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs)
mockState Bound
end Exactly xs EraParams
Exactly (x : xs1) EraParams
pss AtMost xs1 EpochNo
ts NonEmpty xs1 [Event]
NonEmpty (x : xs1) [Event]
ess)
   where
    end :: HF.Bound
    end :: Bound
end = HasCallStack => EraParams -> Bound -> EpochNo -> Bound
EraParams -> Bound -> EpochNo -> Bound
HF.mkUpperBound EraParams
ps Bound
start EpochNo
t
  mockState Bound
_ Exactly (x : xs) EraParams
_ AtMost xs EpochNo
AtMostNil (NonEmptyCons [Event]
_ NonEmpty xs1 [Event]
_) =
    TestName
-> Telescope
     (K Past) (Current (AnnForecast (K2 ()) (K ()))) (x : xs)
forall a. HasCallStack => TestName -> a
error TestName
"mockState: next era without transition"

  tip :: [Event] -> WithOrigin SlotNo
  tip :: [Event] -> WithOrigin SlotNo
tip [] = WithOrigin SlotNo
forall t. WithOrigin t
Origin
  tip [Event]
es = SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin (SlotNo -> WithOrigin SlotNo) -> SlotNo -> WithOrigin SlotNo
forall a b. (a -> b) -> a -> b
$ EventTime -> SlotNo
eventTimeSlot (EventTime -> SlotNo) -> EventTime -> SlotNo
forall a b. (a -> b) -> a -> b
$ Event -> EventTime
eventTime ([Event] -> Event
forall a. HasCallStack => [a] -> a
last [Event]
es)