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

-- | Infrastructure shared by the various 'HardFork' tests
module Test.Consensus.HardFork.Infra (
    -- * Generate HardFork shape
    Era (..)
  , Eras (..)
  , chooseEras
  , eraIndices
  , erasMapStateM
  , erasUnfoldAtMost
    -- * Era-specified generators
  , genEraParams
  , genShape
  , genStartOfNextEra
  , genSummary
  ) where

import           Data.Kind (Type)
import           Data.Maybe (fromMaybe)
import           Data.SOP.BasicFunctors
import           Data.SOP.Counting
import           Data.SOP.NonEmpty
import           Data.SOP.Sing
import           Data.SOP.Strict
import           Data.Word
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import qualified Ouroboros.Consensus.HardFork.History as HF
import           Test.QuickCheck hiding (elements)

{-------------------------------------------------------------------------------
  Generate hard fork shape
-------------------------------------------------------------------------------}

data Era = Era {
       Era -> Word64
eraIndex  :: Word64
     , Era -> Bool
eraIsLast :: Bool
     }
  deriving (Int -> Era -> ShowS
[Era] -> ShowS
Era -> String
(Int -> Era -> ShowS)
-> (Era -> String) -> ([Era] -> ShowS) -> Show Era
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Era -> ShowS
showsPrec :: Int -> Era -> ShowS
$cshow :: Era -> String
show :: Era -> String
$cshowList :: [Era] -> ShowS
showList :: [Era] -> ShowS
Show, Era -> Era -> Bool
(Era -> Era -> Bool) -> (Era -> Era -> Bool) -> Eq Era
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Era -> Era -> Bool
== :: Era -> Era -> Bool
$c/= :: Era -> Era -> Bool
/= :: Era -> Era -> Bool
Eq, Eq Era
Eq Era =>
(Era -> Era -> Ordering)
-> (Era -> Era -> Bool)
-> (Era -> Era -> Bool)
-> (Era -> Era -> Bool)
-> (Era -> Era -> Bool)
-> (Era -> Era -> Era)
-> (Era -> Era -> Era)
-> Ord Era
Era -> Era -> Bool
Era -> Era -> Ordering
Era -> Era -> Era
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Era -> Era -> Ordering
compare :: Era -> Era -> Ordering
$c< :: Era -> Era -> Bool
< :: Era -> Era -> Bool
$c<= :: Era -> Era -> Bool
<= :: Era -> Era -> Bool
$c> :: Era -> Era -> Bool
> :: Era -> Era -> Bool
$c>= :: Era -> Era -> Bool
>= :: Era -> Era -> Bool
$cmax :: Era -> Era -> Era
max :: Era -> Era -> Era
$cmin :: Era -> Era -> Era
min :: Era -> Era -> Era
Ord)

data Eras :: [Type] -> Type where
    -- We guarantee to have at least one era
    Eras :: Exactly (x ': xs) Era -> Eras (x ': xs)

eraIndices :: Eras xs -> NP (K Era) xs
eraIndices :: forall (xs :: [*]). Eras xs -> NP (K Era) xs
eraIndices (Eras Exactly (x : xs) Era
eras) = Exactly xs Era -> NP (K Era) xs
forall (xs :: [*]) a. Exactly xs a -> NP (K a) xs
getExactly Exactly xs Era
Exactly (x : xs) Era
eras

deriving instance Show (Eras xs)

chooseEras :: forall r. (forall xs. (SListI xs, IsNonEmpty xs) => Eras xs -> Gen r) -> Gen r
chooseEras :: forall r.
(forall (xs :: [*]).
 (SListI xs, IsNonEmpty xs) =>
 Eras xs -> Gen r)
-> Gen r
chooseEras forall (xs :: [*]). (SListI xs, IsNonEmpty xs) => Eras xs -> Gen r
k = do
    Word
n <- (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1, Word
4)
    Word -> () -> (forall {xs :: [*]}. Exactly xs () -> Gen r) -> Gen r
forall a r.
Word -> a -> (forall (xs :: [*]). Exactly xs a -> r) -> r
exactlyReplicate Word
n () ((forall {xs :: [*]}. Exactly xs () -> Gen r) -> Gen r)
-> (forall {xs :: [*]}. Exactly xs () -> Gen r) -> Gen r
forall a b. (a -> b) -> a -> b
$ Exactly xs () -> Gen r
forall {xs :: [*]}. Exactly xs () -> Gen r
renumber
  where
    renumber :: Exactly xs () -> Gen r
    renumber :: forall {xs :: [*]}. Exactly xs () -> Gen r
renumber Exactly xs ()
ExactlyNil           = String -> Gen r
forall a. HasCallStack => String -> a
error String
"renumber: empty list of eras"
    renumber e :: Exactly xs ()
e@(ExactlyCons ()
_ Exactly xs ()
_) =
        NP (K ()) xs -> (SListI xs => Gen r) -> Gen r
forall {k} (a :: k -> *) (xs :: [k]) r.
NP a xs -> (SListI xs => r) -> r
npToSListI (Exactly xs () -> NP (K ()) xs
forall (xs :: [*]) a. Exactly xs a -> NP (K a) xs
getExactly Exactly xs ()
e) ((SListI xs => Gen r) -> Gen r) -> (SListI xs => Gen r) -> Gen r
forall a b. (a -> b) -> a -> b
$
          Eras (x : xs) -> Gen r
forall (xs :: [*]). (SListI xs, IsNonEmpty xs) => Eras xs -> Gen r
k (Exactly (x : xs) Era -> Eras (x : xs)
forall x (xs :: [*]). Exactly (x : xs) Era -> Eras (x : xs)
Eras (Exactly (x : xs) Era -> Eras (x : xs))
-> Exactly (x : xs) Era -> Eras (x : xs)
forall a b. (a -> b) -> a -> b
$ Word64 -> Exactly (x : xs) () -> Exactly (x : xs) Era
forall x (xs :: [*]).
Word64 -> Exactly (x : xs) () -> Exactly (x : xs) Era
go Word64
0 Exactly xs ()
Exactly (x : xs) ()
e)
      where
        go :: Word64 -> Exactly (x ': xs) () -> Exactly (x ': xs) Era
        go :: forall x (xs :: [*]).
Word64 -> Exactly (x : xs) () -> Exactly (x : xs) Era
go Word64
n (ExactlyCons () Exactly xs ()
ExactlyNil)           = Era -> Exactly '[] Era -> Exactly (x : xs) Era
forall (xs' :: [*]) a x (xs :: [*]).
(xs' ~ (x : xs)) =>
a -> Exactly xs a -> Exactly xs' a
ExactlyCons (Word64 -> Bool -> Era
Era Word64
n Bool
True)  Exactly '[] Era
forall (xs :: [*]) a. (xs ~ '[]) => Exactly xs a
ExactlyNil
        go Word64
n (ExactlyCons () e' :: Exactly xs ()
e'@(ExactlyCons ()
_ Exactly xs ()
_)) = Era -> Exactly (x : xs) Era -> Exactly (x : xs) Era
forall (xs' :: [*]) a x (xs :: [*]).
(xs' ~ (x : xs)) =>
a -> Exactly xs a -> Exactly xs' a
ExactlyCons (Word64 -> Bool -> Era
Era Word64
n Bool
False) (Word64 -> Exactly (x : xs) () -> Exactly (x : xs) Era
forall x (xs :: [*]).
Word64 -> Exactly (x : xs) () -> Exactly (x : xs) Era
go (Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) Exactly xs ()
Exactly (x : xs) ()
e')

erasMapStateM :: forall m s a xs. Monad m
              => (Era -> s -> m (a, s))
              -> Eras xs -> s -> m (Exactly xs a)
erasMapStateM :: forall (m :: * -> *) s a (xs :: [*]).
Monad m =>
(Era -> s -> m (a, s)) -> Eras xs -> s -> m (Exactly xs a)
erasMapStateM Era -> s -> m (a, s)
f (Eras Exactly (x : xs) Era
eras) = Exactly xs Era -> s -> m (Exactly xs a)
forall (xs' :: [*]). Exactly xs' Era -> s -> m (Exactly xs' a)
go Exactly xs Era
Exactly (x : xs) Era
eras
  where
    go :: Exactly xs' Era -> s -> m (Exactly xs' a)
    go :: forall (xs' :: [*]). Exactly xs' Era -> s -> m (Exactly xs' a)
go Exactly xs' Era
ExactlyNil         s
_ = Exactly xs' a -> m (Exactly xs' a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Exactly xs' a
forall (xs :: [*]) a. (xs ~ '[]) => Exactly xs a
ExactlyNil
    go (ExactlyCons Era
x Exactly xs Era
xs) s
s = do
        (a
a, s
s') <- Era -> s -> m (a, s)
f Era
x s
s
        (a -> Exactly xs a -> Exactly xs' a
forall (xs' :: [*]) a x (xs :: [*]).
(xs' ~ (x : xs)) =>
a -> Exactly xs a -> Exactly xs' a
ExactlyCons a
a) (Exactly xs a -> Exactly xs' a)
-> m (Exactly xs a) -> m (Exactly xs' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exactly xs Era -> s -> m (Exactly xs a)
forall (xs' :: [*]). Exactly xs' Era -> s -> m (Exactly xs' a)
go Exactly xs Era
xs s
s'

erasUnfoldAtMost :: forall m xs a. Monad m
                 => (Era -> HF.Bound -> m (a, HF.EraEnd))
                 -> Eras xs -> HF.Bound -> m (NonEmpty xs a)
erasUnfoldAtMost :: forall (m :: * -> *) (xs :: [*]) a.
Monad m =>
(Era -> Bound -> m (a, EraEnd))
-> Eras xs -> Bound -> m (NonEmpty xs a)
erasUnfoldAtMost Era -> Bound -> m (a, EraEnd)
f (Eras Exactly (x : xs) Era
eras) = Exactly (x : xs) Era -> Bound -> m (NonEmpty (x : xs) a)
forall x (xs' :: [*]).
Exactly (x : xs') Era -> Bound -> m (NonEmpty (x : xs') a)
go Exactly (x : xs) Era
eras
  where
    go :: forall x xs'.
          Exactly (x ': xs') Era
       -> HF.Bound
       -> m (NonEmpty (x ': xs') a)
    go :: forall x (xs' :: [*]).
Exactly (x : xs') Era -> Bound -> m (NonEmpty (x : xs') a)
go (ExactlyCons Era
e Exactly xs Era
es) Bound
s = do
        (a
a, EraEnd
ms) <- Era -> Bound -> m (a, EraEnd)
f Era
e Bound
s
        case EraEnd
ms of
          EraEnd
HF.EraUnbounded -> NonEmpty (x : xs') a -> m (NonEmpty (x : xs') a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty (x : xs') a -> m (NonEmpty (x : xs') a))
-> NonEmpty (x : xs') a -> m (NonEmpty (x : xs') a)
forall a b. (a -> b) -> a -> b
$ a -> NonEmpty (x : xs') a
forall a x (xs1 :: [*]). a -> NonEmpty (x : xs1) a
NonEmptyOne a
a
          HF.EraEnd Bound
s'    ->
            case Exactly xs Era
es of
              ExactlyCons Era
_ Exactly xs Era
_ -> a -> NonEmpty xs' a -> NonEmpty (x : xs') a
forall a (xs1 :: [*]) x.
a -> NonEmpty xs1 a -> NonEmpty (x : xs1) a
NonEmptyCons a
a (NonEmpty xs' a -> NonEmpty (x : xs') a)
-> m (NonEmpty xs' a) -> m (NonEmpty (x : xs') a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exactly (x : xs) Era -> Bound -> m (NonEmpty (x : xs) a)
forall x (xs' :: [*]).
Exactly (x : xs') Era -> Bound -> m (NonEmpty (x : xs') a)
go Exactly xs Era
Exactly (x : xs) Era
es Bound
s'
              Exactly xs Era
ExactlyNil      -> NonEmpty (x : xs') a -> m (NonEmpty (x : xs') a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty (x : xs') a -> m (NonEmpty (x : xs') a))
-> NonEmpty (x : xs') a -> m (NonEmpty (x : xs') a)
forall a b. (a -> b) -> a -> b
$ a -> NonEmpty (x : xs') a
forall a x (xs1 :: [*]). a -> NonEmpty (x : xs1) a
NonEmptyOne a
a

{-------------------------------------------------------------------------------
  Era-specific generators
-------------------------------------------------------------------------------}

-- | Generate era parameters
genEraParams :: Gen HF.EraParams
genEraParams :: Gen EraParams
genEraParams = do
    EpochSize
eraEpochSize  <- Word64 -> EpochSize
EpochSize         (Word64 -> EpochSize) -> Gen Word64 -> Gen EpochSize
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
1, Word64
10)
    SlotLength
eraSlotLength <- Integer -> SlotLength
slotLengthFromSec (Integer -> SlotLength) -> Gen Integer -> Gen SlotLength
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
5)
    SafeZone
eraSafeZone   <- Gen SafeZone
genSafeZone
    GenesisWindow
eraGenesisWin <- Word64 -> GenesisWindow
GenesisWindow     (Word64 -> GenesisWindow) -> Gen Word64 -> Gen GenesisWindow
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
1, Word64
10)
    EraParams -> Gen EraParams
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return HF.EraParams{EpochSize
SlotLength
GenesisWindow
SafeZone
eraEpochSize :: EpochSize
eraSlotLength :: SlotLength
eraSafeZone :: SafeZone
eraGenesisWin :: GenesisWindow
eraEpochSize :: EpochSize
eraSlotLength :: SlotLength
eraSafeZone :: SafeZone
eraGenesisWin :: GenesisWindow
..}
  where
    genSafeZone :: Gen HF.SafeZone
    genSafeZone :: Gen SafeZone
genSafeZone = [Gen SafeZone] -> Gen SafeZone
forall a. HasCallStack => [Gen a] -> Gen a
oneof [
          Word64 -> SafeZone
HF.StandardSafeZone (Word64 -> SafeZone) -> Gen Word64 -> Gen SafeZone
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
1, Word64
10)
        , SafeZone -> Gen SafeZone
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return SafeZone
HF.UnsafeIndefiniteSafeZone
        ]

-- | Generate 'EpochNo' for the start of the next era
genStartOfNextEra :: EpochNo ->  HF.EraParams -> Gen (Maybe EpochNo)
genStartOfNextEra :: EpochNo -> EraParams -> Gen (Maybe EpochNo)
genStartOfNextEra EpochNo
startOfEra HF.EraParams{EpochSize
SlotLength
GenesisWindow
SafeZone
eraEpochSize :: EraParams -> EpochSize
eraSlotLength :: EraParams -> SlotLength
eraSafeZone :: EraParams -> SafeZone
eraGenesisWin :: EraParams -> GenesisWindow
eraEpochSize :: EpochSize
eraSlotLength :: SlotLength
eraSafeZone :: SafeZone
eraGenesisWin :: GenesisWindow
..} =
    case SafeZone
eraSafeZone of
      SafeZone
HF.UnsafeIndefiniteSafeZone -> Maybe EpochNo -> Gen (Maybe EpochNo)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EpochNo
forall a. Maybe a
Nothing
      HF.StandardSafeZone Word64
_       ->
        EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just (EpochNo -> Maybe EpochNo)
-> (Word64 -> EpochNo) -> Word64 -> Maybe EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Word64
n -> Word64 -> EpochNo -> EpochNo
HF.addEpochs Word64
n EpochNo
startOfEra) (Word64 -> Maybe EpochNo) -> Gen Word64 -> Gen (Maybe 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
1, Word64
10)

genShape :: Eras xs -> Gen (HF.Shape xs)
genShape :: forall (xs :: [*]). Eras xs -> Gen (Shape xs)
genShape Eras xs
eras = Exactly xs EraParams -> Shape xs
forall (xs :: [*]). Exactly xs EraParams -> Shape xs
HF.Shape (Exactly xs EraParams -> Shape xs)
-> Gen (Exactly xs EraParams) -> Gen (Shape xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Era -> EpochNo -> Gen (EraParams, EpochNo))
-> Eras xs -> EpochNo -> Gen (Exactly xs EraParams)
forall (m :: * -> *) s a (xs :: [*]).
Monad m =>
(Era -> s -> m (a, s)) -> Eras xs -> s -> m (Exactly xs a)
erasMapStateM Era -> EpochNo -> Gen (EraParams, EpochNo)
genParams Eras xs
eras (Word64 -> EpochNo
EpochNo Word64
0)
  where
    genParams :: Era -> EpochNo -> Gen (HF.EraParams, EpochNo)
    genParams :: Era -> EpochNo -> Gen (EraParams, EpochNo)
genParams Era
_era EpochNo
startOfThis = do
        EraParams
params      <- Gen EraParams
genEraParams
        Maybe EpochNo
startOfNext <- EpochNo -> EraParams -> Gen (Maybe EpochNo)
genStartOfNextEra EpochNo
startOfThis EraParams
params
        -- If startOfNext is 'Nothing', we used 'UnsafeIndefiniteSafeZone' for
        -- this era. This means we should not be generating any events for any
        -- succeeding eras, but to determine the /shape/ of the eras, and set
        -- subsequent lower bounds, we just need to make sure that we generate a
        -- valid shape: the next era must start after this one.
        (EraParams, EpochNo) -> Gen (EraParams, EpochNo)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (EraParams
params, EpochNo -> Maybe EpochNo -> EpochNo
forall a. a -> Maybe a -> a
fromMaybe (EpochNo -> EpochNo
forall a. Enum a => a -> a
succ EpochNo
startOfThis) Maybe EpochNo
startOfNext)

genSummary :: Eras xs -> Gen (HF.Summary xs)
genSummary :: forall (xs :: [*]). Eras xs -> Gen (Summary xs)
genSummary Eras xs
is =
    NonEmpty xs EraSummary -> Summary xs
forall (xs :: [*]). NonEmpty xs EraSummary -> Summary xs
HF.Summary (NonEmpty xs EraSummary -> Summary xs)
-> Gen (NonEmpty xs EraSummary) -> Gen (Summary xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Era -> Bound -> Gen (EraSummary, EraEnd))
-> Eras xs -> Bound -> Gen (NonEmpty xs EraSummary)
forall (m :: * -> *) (xs :: [*]) a.
Monad m =>
(Era -> Bound -> m (a, EraEnd))
-> Eras xs -> Bound -> m (NonEmpty xs a)
erasUnfoldAtMost Era -> Bound -> Gen (EraSummary, EraEnd)
genEraSummary Eras xs
is Bound
HF.initBound
  where
    genEraSummary :: Era -> HF.Bound -> Gen (HF.EraSummary, HF.EraEnd)
    genEraSummary :: Era -> Bound -> Gen (EraSummary, EraEnd)
genEraSummary Era
_era Bound
lo = do
        EraParams
params <- Gen EraParams
genEraParams
        EraEnd
hi     <- Bound -> EraParams -> Gen EraEnd
genUpperBound Bound
lo EraParams
params
        (EraSummary, EraEnd) -> Gen (EraSummary, EraEnd)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bound -> EraEnd -> EraParams -> EraSummary
HF.EraSummary Bound
lo EraEnd
hi EraParams
params, EraEnd
hi)

    genUpperBound :: HF.Bound -> HF.EraParams -> Gen HF.EraEnd
    genUpperBound :: Bound -> EraParams -> Gen EraEnd
genUpperBound Bound
lo EraParams
params = do
        Maybe EpochNo
startOfNextEra <- EpochNo -> EraParams -> Gen (Maybe EpochNo)
genStartOfNextEra (Bound -> EpochNo
HF.boundEpoch Bound
lo) EraParams
params
        EraEnd -> Gen EraEnd
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (EraEnd -> Gen EraEnd) -> EraEnd -> Gen EraEnd
forall a b. (a -> b) -> a -> b
$ EraParams -> Bound -> Maybe EpochNo -> EraEnd
HF.mkEraEnd EraParams
params Bound
lo Maybe EpochNo
startOfNextEra