{-# 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

{-------------------------------------------------------------------------------
  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
    n <- (Word, Word) -> Gen Word
forall a. Random a => (a, a) -> Gen a
choose (Word
1, Word
4)
    exactlyReplicate n () $ 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, s') <- Era -> s -> m (a, s)
f Era
x s
s
        (ExactlyCons a) <$> go xs 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, ms) <- Era -> Bound -> m (a, EraEnd)
f Era
e Bound
s
        case 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
    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)
    eraSlotLength <- slotLengthFromSec <$> choose (1, 5)
    eraSafeZone   <- genSafeZone
    eraGenesisWin <- GenesisWindow     <$> choose (1, 10)
    return HF.EraParams{..}
  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
eraGenesisWin :: EraParams -> GenesisWindow
eraSafeZone :: EraParams -> SafeZone
eraSlotLength :: EraParams -> SlotLength
eraEpochSize :: EraParams -> EpochSize
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
        params      <- Gen EraParams
genEraParams
        startOfNext <- genStartOfNextEra startOfThis 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.
        return (params, fromMaybe (succ startOfThis) 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
        params <- Gen EraParams
genEraParams
        hi     <- genUpperBound lo params
        return (HF.EraSummary lo hi params, hi)

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