{-# 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.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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
..} ->
            let ArbitraryParams{Int
[Event]
NominalDiffTime
Shape xs
Eras xs
arbitraryChainEvents :: [Event]
arbitraryChainEras :: Eras xs
arbitraryChainShape :: Shape xs
arbitraryRawEventIx :: Int
arbitraryChainSplit :: Int
arbitraryDiffTime :: NominalDiffTime
arbitraryChainEvents :: forall (xs :: [*]). ArbitraryParams xs -> [Event]
arbitraryChainEras :: forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainShape :: forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryRawEventIx :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainSplit :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryDiffTime :: forall (xs :: [*]). ArbitraryParams xs -> 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 -> 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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
arbitraryChainEvents :: forall (xs :: [*]). ArbitraryParams xs -> [Event]
arbitraryChainEras :: forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainShape :: forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryRawEventIx :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainSplit :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryDiffTime :: forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
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
                => Bool -- ^ Are we expecting an exception?
                -> 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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
eventTimeSlot :: EventTime -> SlotNo
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeEpochSlot :: EventTime -> Word64
eventTimeRelative :: EventTime -> RelativeTime
..} = 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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
eventTimeSlot :: EventTime -> SlotNo
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeEpochSlot :: EventTime -> Word64
eventTimeRelative :: EventTime -> RelativeTime
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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
eventTimeSlot :: EventTime -> SlotNo
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeEpochSlot :: EventTime -> Word64
eventTimeRelative :: EventTime -> RelativeTime
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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
eventTimeSlot :: EventTime -> SlotNo
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeEpochSlot :: EventTime -> Word64
eventTimeRelative :: EventTime -> RelativeTime
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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
      RelativeTime
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
      RelativeTime
absTime2 <- Qry RelativeTime
-> Summary xs -> Either PastHorizonException RelativeTime
forall a (xs :: [*]).
HasCallStack =>
Qry a -> Summary xs -> Either PastHorizonException a
HF.runQuery (SlotNo -> Qry RelativeTime
q2 SlotNo
eventTimeSlot) Summary xs
arbitrarySummary
      Property -> Either PastHorizonException Property
forall a. a -> Either PastHorizonException a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> Either PastHorizonException Property)
-> Property -> Either PastHorizonException Property
forall a b. (a -> b) -> a -> b
$ RelativeTime
absTime1 RelativeTime -> RelativeTime -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== RelativeTime
absTime2
  where
    EventTime{Word64
EpochNo
SlotNo
RelativeTime
eventTimeSlot :: EventTime -> SlotNo
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeEpochSlot :: EventTime -> Word64
eventTimeRelative :: EventTime -> RelativeTime
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
        SlotInEra
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)
        TimeInEra
relTime <- (forall (f :: * -> *). Expr f TimeInEra) -> Qry TimeInEra
forall a. (forall (f :: * -> *). Expr f a) -> Qry a
HF.qryFromExpr ((forall (f :: * -> *). Expr f TimeInEra) -> Qry TimeInEra)
-> (forall (f :: * -> *). Expr f TimeInEra) -> Qry TimeInEra
forall a b. (a -> b) -> a -> b
$ Expr f SlotInEra -> Expr f TimeInEra
forall (f :: * -> *). Expr f SlotInEra -> Expr f TimeInEra
HF.ERelSlotToTime (SlotInEra -> Expr f SlotInEra
forall a (f :: * -> *). Show a => a -> Expr f a
HF.ELit SlotInEra
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.
        RelativeTime
absTime <- (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 TimeInEra -> Expr f RelativeTime
forall (f :: * -> *). Expr f TimeInEra -> Expr f RelativeTime
HF.ERelToAbsTime  (TimeInEra -> Expr f TimeInEra
forall a (f :: * -> *). Show a => a -> Expr f a
HF.ELit TimeInEra
relTime)
        RelativeTime -> Qry RelativeTime
forall a. a -> Qry a
forall (m :: * -> *) a. Monad m => a -> m a
return RelativeTime
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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
eventTimeSlot :: EventTime -> SlotNo
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeEpochSlot :: EventTime -> Word64
eventTimeRelative :: EventTime -> RelativeTime
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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
eventTimeSlot :: EventTime -> SlotNo
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeEpochSlot :: EventTime -> Word64
eventTimeRelative :: EventTime -> RelativeTime
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

      -- | Index into the events
      --
      -- > 0 <= arbitraryEventIx < length arbitraryChainEvents
      --
      -- The tests will use 'arbitraryEventIx' instead.
    , forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryRawEventIx  :: Int

      -- | Split of the prechain
      --
      -- > 0 <= arbitraryChainSplit < length arbitraryChainEvents
    , forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainSplit  :: Int

      -- | Arbitrary 'DiffTime'
      --
      -- Let @s@ be the slot length of the selected event. Then
      --
      -- 0 <= arbitraryDiffTime < s
    , forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
arbitraryDiffTime    :: NominalDiffTime
    }
  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 {
      -- | QuickCheck generated parameters
      --
      -- The rest of these values are derived
      ()
arbitraryParams      :: ArbitraryParams xs

      -- | Chain derived from a prefix of the prechain
    , ()
arbitraryChain       :: Chain xs

      -- | Transitions on the chain
    , ()
arbitraryTransitions :: HF.Transitions xs

      -- | Summary of the chain
    , ()
arbitrarySummary     :: HF.Summary xs

      -- | Active safe zone
    , ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitrarySafeZone    :: (Maybe EpochNo, HF.SafeZone)

      -- | Events after the chain, but within the safe zone
    , ArbitraryChain -> [Event]
arbitraryInSafeZone  :: [Event]

      -- | Events after the chain, no longer within the safe zone
    , ArbitraryChain -> [Event]
arbitraryPastHorizon :: [Event]

      -- | Event index into one of the three parts of the chain
    , ArbitraryChain -> EventIx
arbitraryEventIx     :: EventIx

      -- | Arbitrary event
      --
      -- This is equal to both of
      --
      -- > arbitraryChainEvents !! arbitraryRawEventIx
    , ArbitraryChain -> Event
arbitraryEvent       :: Event
    }

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
arbitraryChainEvents :: forall (xs :: [*]). ArbitraryParams xs -> [Event]
arbitraryChainEras :: forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainShape :: forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryRawEventIx :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainSplit :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryDiffTime :: forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
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 xs
shape  <- Eras xs -> Gen (Shape xs)
forall (xs :: [*]). Eras xs -> Gen (Shape xs)
genShape Eras xs
eras
      [Event]
events <- Eras xs -> Shape xs -> Gen [Event]
forall (xs :: [*]). Eras xs -> Shape xs -> Gen [Event]
genEvents Eras xs
eras Shape xs
shape Gen [Event] -> ([Event] -> Bool) -> Gen [Event]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
not (Bool -> Bool) -> ([Event] -> Bool) -> [Event] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
      Int
split  <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
events Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      Int
rawIx  <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, [Event] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Event]
events Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      NominalDiffTime
diff   <- SlotLength -> Gen NominalDiffTime
genDiffTime (SlotLength -> Gen NominalDiffTime)
-> SlotLength -> Gen NominalDiffTime
forall a b. (a -> b) -> a -> b
$ EraParams -> SlotLength
HF.eraSlotLength (Event -> EraParams
eventEraParams ([Event]
events [Event] -> Int -> Event
forall a. HasCallStack => [a] -> Int -> a
!! Int
rawIx))
      ArbitraryChain -> Gen ArbitraryChain
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArbitraryChain -> Gen ArbitraryChain)
-> ArbitraryChain -> Gen ArbitraryChain
forall a b. (a -> b) -> a -> b
$ 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 {
          arbitraryChainEvents :: [Event]
arbitraryChainEvents = [Event]
events
        , arbitraryChainEras :: Eras xs
arbitraryChainEras   = Eras xs
eras
        , arbitraryChainShape :: Shape xs
arbitraryChainShape  = Shape xs
shape
        , arbitraryRawEventIx :: Int
arbitraryRawEventIx  = Int
rawIx
        , arbitraryChainSplit :: Int
arbitraryChainSplit  = Int
split
        , arbitraryDiffTime :: NominalDiffTime
arbitraryDiffTime    = NominalDiffTime
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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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
arbitraryChainEvents :: forall (xs :: [*]). ArbitraryParams xs -> [Event]
arbitraryChainEras :: forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainShape :: forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryRawEventIx :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainSplit :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryDiffTime :: forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
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
eraSafeZone :: EraParams -> SafeZone
eraGenesisWin :: EraParams -> GenesisWindow
..} EventTime{Word64
EpochNo
SlotNo
RelativeTime
eventTimeSlot :: EventTime -> SlotNo
eventTimeEpochNo :: EventTime -> EpochNo
eventTimeEpochSlot :: EventTime -> Word64
eventTimeRelative :: EventTime -> RelativeTime
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
        EventType
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
event = Event {
                eventType :: EventType
eventType      = EventType
typ
              , eventTime :: EventTime
eventTime      = EventTime
timeEvent
              , eventEra :: Era
eventEra       = Era
era
              , eventEraParams :: EraParams
eventEraParams = EraParams
eraParams
              }
        (Event
eventEvent -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:) ([Event] -> [Event]) -> Gen [Event] -> Gen [Event]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Time -> Gen [Event]
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (EventType -> Time -> Time
stepTime EventType
typ Time
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 :: WithOrigin EpochNo
                 -- ^ Epoch at the tip of the chain
                 -- (Needed because transitions only happen at epoch boundaries)
              -> (Maybe EpochNo, HF.SafeZone)
                 -- ^ Active safe zone (see 'activeSafeZone')
              -> [Event]
                 -- ^ Events after the end of the chain
              -> ([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
eEvent -> [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
eEvent -> [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
eEvent -> [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
arbitraryParams :: ()
arbitraryChain :: ()
arbitraryTransitions :: ()
arbitrarySummary :: ()
arbitrarySafeZone :: ArbitraryChain -> (Maybe EpochNo, SafeZone)
arbitraryInSafeZone :: ArbitraryChain -> [Event]
arbitraryPastHorizon :: ArbitraryChain -> [Event]
arbitraryEventIx :: ArbitraryChain -> EventIx
arbitraryEvent :: ArbitraryChain -> Event
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. Exception e => e -> a
throw OutsideForecastRange
err
               , epochInfoFirst_ :: HasCallStack => EpochNo -> Identity SlotNo
epochInfoFirst_ = \EpochNo
_ -> OutsideForecastRange -> Identity SlotNo
forall a e. Exception e => e -> a
throw OutsideForecastRange
err
               , epochInfoEpoch_ :: HasCallStack => SlotNo -> Identity EpochNo
epochInfoEpoch_ = \SlotNo
_ -> OutsideForecastRange -> Identity EpochNo
forall a e. Exception e => e -> a
throw OutsideForecastRange
err

               , epochInfoSlotToRelativeTime_ :: HasCallStack => SlotNo -> Identity RelativeTime
epochInfoSlotToRelativeTime_ = \SlotNo
_ -> OutsideForecastRange -> Identity RelativeTime
forall a e. Exception e => e -> a
throw OutsideForecastRange
err
               , epochInfoSlotLength_ :: HasCallStack => SlotNo -> Identity SlotLength
epochInfoSlotLength_         = \SlotNo
_ -> OutsideForecastRange -> Identity SlotLength
forall a e. 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
hardForkLedgerViewTransition :: forall (f :: * -> *) (xs :: [*]).
HardForkLedgerView_ f xs -> TransitionInfo
hardForkLedgerViewPerEra :: forall (f :: * -> *) (xs :: [*]).
HardForkLedgerView_ f xs -> HardForkState f xs
..} ->
           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
arbitraryChainEvents :: forall (xs :: [*]). ArbitraryParams xs -> [Event]
arbitraryChainEras :: forall (xs :: [*]). ArbitraryParams xs -> Eras xs
arbitraryChainShape :: forall (xs :: [*]). ArbitraryParams xs -> Shape xs
arbitraryRawEventIx :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryChainSplit :: forall (xs :: [*]). ArbitraryParams xs -> Int
arbitraryDiffTime :: forall (xs :: [*]). ArbitraryParams xs -> NominalDiffTime
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 (K ()) (K ())) xs
-> HardForkState (AnnForecast (K ()) (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 (K ()) (K ()) x y)
-> InPairs (CrossEraForecaster (K ()) (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 (K ()) (K ()) x y)
 -> InPairs (CrossEraForecaster (K ()) (K ())) xs)
-> (forall x y. CrossEraForecaster (K ()) (K ()) x y)
-> InPairs (CrossEraForecaster (K ()) (K ())) xs
forall a b. (a -> b) -> a -> b
$ (Bound -> SlotNo -> K () x -> Except OutsideForecastRange (K () y))
-> CrossEraForecaster (K ()) (K ()) x y
forall (state :: * -> *) (view :: * -> *) x y.
(Bound
 -> SlotNo -> state x -> Except OutsideForecastRange (view y))
-> CrossEraForecaster state view x y
CrossEraForecaster ((Bound
  -> SlotNo -> K () x -> Except OutsideForecastRange (K () y))
 -> CrossEraForecaster (K ()) (K ()) x y)
-> (Bound
    -> SlotNo -> K () x -> Except OutsideForecastRange (K () y))
-> CrossEraForecaster (K ()) (K ()) x y
forall a b. (a -> b) -> a -> b
$ \Bound
_epoch SlotNo
_slot K () x
_ -> 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 (K ()) (K ()))) xs
-> HardForkState (AnnForecast (K ()) (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 (K ()) (K ()))) (x : xs)
forall x (xs :: [*]).
Bound
-> Exactly (x : xs) EraParams
-> AtMost xs EpochNo
-> NonEmpty (x : xs) [Event]
-> Telescope
     (K Past) (Current (AnnForecast (K ()) (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 (K ()) (K ()))) (x : xs)
    mockState :: forall x (xs :: [*]).
Bound
-> Exactly (x : xs) EraParams
-> AtMost xs EpochNo
-> NonEmpty (x : xs) [Event]
-> Telescope
     (K Past) (Current (AnnForecast (K ()) (K ()))) (x : xs)
mockState Bound
start (ExactlyCons EraParams
ps Exactly xs EraParams
_) AtMost xs EpochNo
ts (NonEmptyOne [Event]
es) =
        Current (AnnForecast (K ()) (K ())) x
-> Telescope
     (K Past) (Current (AnnForecast (K ()) (K ()))) (x : xs)
forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]).
f x -> Telescope g f (x : xs1)
TZ (Current (AnnForecast (K ()) (K ())) x
 -> Telescope
      (K Past) (Current (AnnForecast (K ()) (K ()))) (x : xs))
-> Current (AnnForecast (K ()) (K ())) x
-> Telescope
     (K Past) (Current (AnnForecast (K ()) (K ()))) (x : xs)
forall a b. (a -> b) -> a -> b
$ Bound
-> AnnForecast (K ()) (K ()) x
-> Current (AnnForecast (K ()) (K ())) x
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
start (AnnForecast (K ()) (K ()) x
 -> Current (AnnForecast (K ()) (K ())) x)
-> AnnForecast (K ()) (K ()) x
-> Current (AnnForecast (K ()) (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 :: K () x
annForecastState = () -> K () x
forall k a (b :: k). a -> K a b
K ()
          , 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 (K ()) (K ()))) xs
-> Telescope
     (K Past) (Current (AnnForecast (K ()) (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 (K ()) (K ()))) (x : xs1)
forall x (xs :: [*]).
Bound
-> Exactly (x : xs) EraParams
-> AtMost xs EpochNo
-> NonEmpty (x : xs) [Event]
-> Telescope
     (K Past) (Current (AnnForecast (K ()) (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 (K ()) (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)