{-# 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 Ouroboros.Consensus.HardFork.History (Bound (..))
import qualified Ouroboros.Consensus.HardFork.History as HF
import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..))
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)
  -- we restrict Peras round length to divide the epoch size.
  -- for testing purposes, we include Peras round length in every era.
  eraPerasRoundLength <-
    HF.PerasEnabled . PerasRoundLength
      <$> choose (1, 10) `suchThat` (\Word64
x -> (EpochSize -> Word64
unEpochSize EpochSize
eraEpochSize) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
x Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0)
  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
PerasEnabled PerasRoundLength
eraPerasRoundLength :: EraParams -> PerasEnabled PerasRoundLength
eraGenesisWin :: EraParams -> GenesisWindow
eraSafeZone :: EraParams -> SafeZone
eraSlotLength :: EraParams -> SlotLength
eraEpochSize :: EraParams -> EpochSize
eraEpochSize :: EpochSize
eraSlotLength :: SlotLength
eraSafeZone :: SafeZone
eraGenesisWin :: GenesisWindow
eraPerasRoundLength :: PerasEnabled PerasRoundLength
..} =
  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
initBoundWithPeras
 where
  -- TODO(geo2a): revisit this hard-coding of enabling Peras when
  -- we're further into the integration process
  -- see https://github.com/tweag/cardano-peras/issues/112
  initBoundWithPeras :: Bound
initBoundWithPeras = Bound
HF.initBound{boundPerasRound = HF.PerasEnabled . PerasRoundNo $ 0}

  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