{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Consensus.PointSchedule.Tests (tests) where

import           Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..),
                     withOrigin)
import           Control.Monad (forM, replicateM)
import           Control.Monad.Class.MonadTime.SI (Time (Time))
import           Data.Bifunctor (second)
import           Data.Coerce (coerce)
import           Data.List as List (foldl', group, isSuffixOf, partition, sort)
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Maybe (isNothing)
import           Data.Time.Clock (DiffTime, diffTimeToPicoseconds,
                     picosecondsToDiffTime)
import           GHC.Stack (HasCallStack)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (blockHash)
import           System.Random.Stateful (runSTGen_)
import           Test.Consensus.PointSchedule.SinglePeer
import           Test.Consensus.PointSchedule.SinglePeer.Indices
import qualified Test.QuickCheck as QC
import           Test.QuickCheck
import           Test.QuickCheck.Random
import           Test.Tasty
import           Test.Tasty.QuickCheck
import qualified Test.Util.QuickCheck as QC
import           Test.Util.TersePrinting (terseBlock, terseWithOrigin)
import           Test.Util.TestBlock (TestBlock, TestHash (unTestHash),
                     firstBlock, modifyFork, successorBlock, tbSlot)
import           Test.Util.TestEnv

tests :: TestTree
tests :: TestTree
tests =
    (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
    (QuickCheckMaxSize -> QuickCheckMaxSize) -> TestTree -> TestTree
forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (\(QuickCheckMaxSize Int
n) -> Int -> QuickCheckMaxSize
QuickCheckMaxSize (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10)) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestTree] -> TestTree
testGroup TestName
"PointSchedule"
      [ TestName -> ([[Int]] -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"zipMany" [[Int]] -> Property
prop_zipMany
      , TestName
-> (QCGen -> SingleJumpTipPointsInput -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"singleJumpTipPoints" QCGen -> SingleJumpTipPointsInput -> Property
prop_singleJumpTipPoints
      , TestName
-> (QCGen -> TipPointScheduleInput -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"tipPointSchedule" QCGen -> TipPointScheduleInput -> Property
prop_tipPointSchedule
      , TestName
-> (QCGen -> HeaderPointScheduleInput -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"headerPointSchedule" QCGen -> HeaderPointScheduleInput -> Property
prop_headerPointSchedule
      , TestName
-> (QCGen -> PeerScheduleFromTipPointsInput -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"peerScheduleFromTipPoints" QCGen -> PeerScheduleFromTipPointsInput -> Property
prop_peerScheduleFromTipPoints
      ]

prop_zipMany :: [[Int]] -> QC.Property
prop_zipMany :: [[Int]] -> Property
prop_zipMany [[Int]]
xss =
    let xs :: [Int]
        xs :: [Int]
xs = ([Int] -> [Int]) -> [[Int]] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) [[Int]]
xss
        ys :: [[(Int, Int)]]
        ys :: [[(Int, Int)]]
ys = [Int] -> [[Int]] -> [[(Int, Int)]]
forall a b. [a] -> [[b]] -> [[(a, b)]]
zipMany [Int]
xs [[Int]]
xss
     in
          [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
xss Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
QC.=== [[(Int, Int)]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[(Int, Int)]]
ys
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
          ([(Int, Int)] -> [Int]) -> [[(Int, Int)]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> b
snd) [[(Int, Int)]]
ys [[Int]] -> [[Int]] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
QC.=== [[Int]]
xss
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
          ([(Int, Int)] -> [Int]) -> [[(Int, Int)]] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst) [[(Int, Int)]]
ys [Int] -> [Int] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
QC.=== [Int]
xs

data SingleJumpTipPointsInput = SingleJumpTipPointsInput
  { SingleJumpTipPointsInput -> Int
sjtpMin :: Int
  , SingleJumpTipPointsInput -> Int
sjtpMax :: Int
  } deriving (Int -> SingleJumpTipPointsInput -> ShowS
[SingleJumpTipPointsInput] -> ShowS
SingleJumpTipPointsInput -> TestName
(Int -> SingleJumpTipPointsInput -> ShowS)
-> (SingleJumpTipPointsInput -> TestName)
-> ([SingleJumpTipPointsInput] -> ShowS)
-> Show SingleJumpTipPointsInput
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SingleJumpTipPointsInput -> ShowS
showsPrec :: Int -> SingleJumpTipPointsInput -> ShowS
$cshow :: SingleJumpTipPointsInput -> TestName
show :: SingleJumpTipPointsInput -> TestName
$cshowList :: [SingleJumpTipPointsInput] -> ShowS
showList :: [SingleJumpTipPointsInput] -> ShowS
Show)

instance QC.Arbitrary SingleJumpTipPointsInput where
  arbitrary :: Gen SingleJumpTipPointsInput
arbitrary = do
    QC.NonNegative a <- Gen (NonNegative Int)
forall a. Arbitrary a => Gen a
QC.arbitrary
    QC.NonNegative b <- QC.arbitrary
    pure $ SingleJumpTipPointsInput (min a b) (max a b)

prop_singleJumpTipPoints :: QCGen -> SingleJumpTipPointsInput -> QC.Property
prop_singleJumpTipPoints :: QCGen -> SingleJumpTipPointsInput -> Property
prop_singleJumpTipPoints QCGen
seed (SingleJumpTipPointsInput Int
m Int
n) =
    QCGen -> (forall s. STGenM QCGen s -> ST s Property) -> Property
forall g a.
RandomGen g =>
g -> (forall s. STGenM g s -> ST s a) -> a
runSTGen_ QCGen
seed ((forall s. STGenM QCGen s -> ST s Property) -> Property)
-> (forall s. STGenM QCGen s -> ST s Property) -> Property
forall a b. (a -> b) -> a -> b
$ \STGenM QCGen s
g -> do
      xs <- STGenM QCGen s -> Int -> Int -> ST s [Int]
forall g (m :: * -> *).
StatefulGen g m =>
g -> Int -> Int -> m [Int]
singleJumpTipPoints STGenM QCGen s
g Int
m Int
n
      pure $ isSorted QC.le xs
        QC..&&.
         (QC.counterexample ("length xs = " ++ show (length xs)) $
           length xs `QC.le` n - m + 1
         )
        QC..&&.
         (QC.counterexample ("head xs = " ++ show (headCallStack xs)) $
             headCallStack xs `QC.le` n
           QC..&&.
             m `QC.le` headCallStack xs
         )

data TipPointScheduleInput = TipPointScheduleInput
  { TipPointScheduleInput -> DiffTime
tpsSlotLength  :: DiffTime
  , TipPointScheduleInput -> (DiffTime, DiffTime)
tpsMsgInterval :: (DiffTime, DiffTime)
  , TipPointScheduleInput -> [SlotNo]
tpsSlots       :: [SlotNo]
  } deriving (Int -> TipPointScheduleInput -> ShowS
[TipPointScheduleInput] -> ShowS
TipPointScheduleInput -> TestName
(Int -> TipPointScheduleInput -> ShowS)
-> (TipPointScheduleInput -> TestName)
-> ([TipPointScheduleInput] -> ShowS)
-> Show TipPointScheduleInput
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TipPointScheduleInput -> ShowS
showsPrec :: Int -> TipPointScheduleInput -> ShowS
$cshow :: TipPointScheduleInput -> TestName
show :: TipPointScheduleInput -> TestName
$cshowList :: [TipPointScheduleInput] -> ShowS
showList :: [TipPointScheduleInput] -> ShowS
Show)

instance QC.Arbitrary TipPointScheduleInput where
  arbitrary :: Gen TipPointScheduleInput
arbitrary = do
    slotLength <- (DiffTime, DiffTime) -> Gen DiffTime
chooseDiffTime (DiffTime
1, DiffTime
20)
    msgInterval <- genTimeInterval (slotLength - 0.1)
    slots0 <- dedupSorted . map (SlotNo . QC.getNonNegative) <$> QC.orderedList
    slots1 <- dedupSorted . map (SlotNo . QC.getNonNegative) <$> QC.orderedList
    pure $ TipPointScheduleInput slotLength msgInterval (slots0 ++ slots1)

prop_tipPointSchedule :: QCGen -> TipPointScheduleInput -> QC.Property
prop_tipPointSchedule :: QCGen -> TipPointScheduleInput -> Property
prop_tipPointSchedule QCGen
seed (TipPointScheduleInput DiffTime
slotLength (DiffTime, DiffTime)
msgInterval [SlotNo]
slots) =
    QCGen -> (forall s. STGenM QCGen s -> ST s Property) -> Property
forall g a.
RandomGen g =>
g -> (forall s. STGenM g s -> ST s a) -> a
runSTGen_ QCGen
seed ((forall s. STGenM QCGen s -> ST s Property) -> Property)
-> (forall s. STGenM QCGen s -> ST s Property) -> Property
forall a b. (a -> b) -> a -> b
$ \STGenM QCGen s
g -> do
      ts <- STGenM QCGen s
-> DiffTime -> (DiffTime, DiffTime) -> [SlotNo] -> ST s [Time]
forall g (m :: * -> *).
StatefulGen g m =>
g -> DiffTime -> (DiffTime, DiffTime) -> [SlotNo] -> m [Time]
tipPointSchedule STGenM QCGen s
g DiffTime
slotLength (DiffTime, DiffTime)
msgInterval [SlotNo]
slots
      pure $
          (QC.counterexample ("length slots = " ++ show (length slots)) $
           QC.counterexample ("length ts = " ++ show (length ts)) $
             length slots QC.=== length ts
          )
        QC..&&.
          isSorted QC.le ts

data HeaderPointScheduleInput = HeaderPointScheduleInput
  { HeaderPointScheduleInput -> (DiffTime, DiffTime)
hpsMsgInterval :: (DiffTime, DiffTime)
  , HeaderPointScheduleInput -> [(Maybe Int, [(Time, Int)])]
hpsTipPoints   :: [(Maybe Int, [(Time, Int)])]
  } deriving (Int -> HeaderPointScheduleInput -> ShowS
[HeaderPointScheduleInput] -> ShowS
HeaderPointScheduleInput -> TestName
(Int -> HeaderPointScheduleInput -> ShowS)
-> (HeaderPointScheduleInput -> TestName)
-> ([HeaderPointScheduleInput] -> ShowS)
-> Show HeaderPointScheduleInput
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeaderPointScheduleInput -> ShowS
showsPrec :: Int -> HeaderPointScheduleInput -> ShowS
$cshow :: HeaderPointScheduleInput -> TestName
show :: HeaderPointScheduleInput -> TestName
$cshowList :: [HeaderPointScheduleInput] -> ShowS
showList :: [HeaderPointScheduleInput] -> ShowS
Show)

instance QC.Arbitrary HeaderPointScheduleInput where
  arbitrary :: Gen HeaderPointScheduleInput
arbitrary = do
    msgInterval <- DiffTime -> Gen (DiffTime, DiffTime)
genTimeInterval DiffTime
10
    branchTips <- genTipPoints
    let branchCount = [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
branchTips
        tpCount = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
branchTips
    ts <- coerce <$> scanl1 (+) . sort <$> replicateM tpCount (chooseDiffTime (7, 12))
    let tpts = [Time] -> [[Int]] -> [[(Time, Int)]]
forall a b. [a] -> [[b]] -> [[(a, b)]]
zipMany [Time]
ts [[Int]]
branchTips
    intersectionBlocks <- genIntersections branchCount
    maybes <- QC.infiniteList @(Maybe Int)
    let intersections = (Maybe Int -> Maybe Int -> Maybe Int)
-> [Maybe Int] -> [Maybe Int] -> [Maybe Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe Int -> Maybe Int -> Maybe Int
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) [Maybe Int]
maybes ([Maybe Int] -> [Maybe Int]) -> [Maybe Int] -> [Maybe Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe Int) -> [Int] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Maybe Int
forall a. a -> Maybe a
Just [Int]
intersectionBlocks
    pure $ HeaderPointScheduleInput msgInterval (zip intersections tpts)

prop_headerPointSchedule :: QCGen -> HeaderPointScheduleInput -> QC.Property
prop_headerPointSchedule :: QCGen -> HeaderPointScheduleInput -> Property
prop_headerPointSchedule QCGen
g (HeaderPointScheduleInput (DiffTime, DiffTime)
msgDelayInterval [(Maybe Int, [(Time, Int)])]
xs) =
    QCGen -> (forall s. STGenM QCGen s -> ST s Property) -> Property
forall g a.
RandomGen g =>
g -> (forall s. STGenM g s -> ST s a) -> a
runSTGen_ QCGen
g ((forall s. STGenM QCGen s -> ST s Property) -> Property)
-> (forall s. STGenM QCGen s -> ST s Property) -> Property
forall a b. (a -> b) -> a -> b
$ \STGenM QCGen s
g' -> do
      hpss <- STGenM QCGen s
-> (DiffTime, DiffTime)
-> [(Maybe Int, [(Time, Int)])]
-> ST s [HeaderPointSchedule]
forall g (m :: * -> *).
(HasCallStack, StatefulGen g m) =>
g
-> (DiffTime, DiffTime)
-> [(Maybe Int, [(Time, Int)])]
-> m [HeaderPointSchedule]
headerPointSchedule STGenM QCGen s
g' (DiffTime, DiffTime)
msgDelayInterval [(Maybe Int, [(Time, Int)])]
xs
      pure $
          (QC.counterexample ("length xs = " ++ show (length xs)) $
           QC.counterexample ("length hpss = " ++ show (length hpss)) $
            length xs QC.=== length hpss
          )
        QC..&&.
          (QC.counterexample ("header points are sorted in each branch") $
            foldr (QC..&&.) (QC.property True)
              [ QC.counterexample ("branch = " ++ show hps) $
                isSorted QC.lt (map snd trunk) QC..&&. isSorted QC.lt (map snd branch)
              | hps@(HeaderPointSchedule trunk branch) <- hpss
              ]
          )
         QC..&&.
          (QC.counterexample ("times are sorted accross branches") $
           QC.counterexample ("branches = " ++ show hpss) $
            isSorted QC.le $ concat
              [ map fst trunk ++ map fst branch
              | HeaderPointSchedule trunk branch <- hpss
              ]
          )
        QC..&&.
          (QC.counterexample ("trunk header points are sorted accross branches") $
           QC.counterexample ("branches = " ++ show hpss) $
            isSorted QC.lt $ concat
              [ map snd trunk | HeaderPointSchedule trunk _ <- hpss ]
          )
        QC..&&.
          (QC.counterexample "branch header points follow tip points" $
           QC.counterexample ("branches = " ++ show hpss) $
             foldr (QC..&&.) (QC.property True) $
               zipWith (\HeaderPointSchedule
hps (Maybe Int, [(Time, Int)])
x ->
                 case (Maybe Int, [(Time, Int)])
x of
                   (Just Int
_, [(Time, Int)]
b) -> (Int -> Int -> Maybe Ordering)
-> [(Time, Int)] -> [(Time, Int)] -> Property
forall a.
Show a =>
(a -> a -> Maybe Ordering)
-> [(Time, a)] -> [(Time, a)] -> Property
headerPointsFollowTipPoints Int -> Int -> Maybe Ordering
forall a. Ord a => a -> a -> Maybe Ordering
leMaybe (HeaderPointSchedule -> [(Time, Int)]
hpsBranch HeaderPointSchedule
hps) [(Time, Int)]
b
                   (Maybe Int, [(Time, Int)])
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property Bool
True
                ) hpss xs
          )
  where
    leMaybe :: Ord a => a -> a -> Maybe Ordering
    leMaybe :: forall a. Ord a => a -> a -> Maybe Ordering
leMaybe a
a a
b = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b

data PeerScheduleFromTipPointsInput = PeerScheduleFromTipPointsInput
       PeerScheduleParams
       [(IsTrunk, [Int])]
       (AF.AnchoredFragment TestBlock)
       [AF.AnchoredFragment TestBlock]

instance Show PeerScheduleFromTipPointsInput where
  show :: PeerScheduleFromTipPointsInput -> TestName
show (PeerScheduleFromTipPointsInput PeerScheduleParams
psp [(IsTrunk, [Int])]
tps AnchoredFragment TestBlock
trunk [AnchoredFragment TestBlock]
branches) =
    [TestName] -> TestName
unlines
      [ TestName
"PeerScheduleFromTipPointsInput"
      , TestName
"  params = "  TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ PeerScheduleParams -> TestName
forall a. Show a => a -> TestName
show PeerScheduleParams
psp
      , TestName
"  tipPoints = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [(IsTrunk, [Int])] -> TestName
forall a. Show a => a -> TestName
show [(IsTrunk, [Int])]
tps
      , TestName
"  trunk = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [TestBlock] -> TestName
forall a. Show a => a -> TestName
show (AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment TestBlock
trunk)
      , TestName
"  branches = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [(WithOrigin BlockNo, [TestBlock])] -> TestName
forall a. Show a => a -> TestName
show [ (AnchoredFragment TestBlock -> WithOrigin BlockNo
forall block. AnchoredFragment block -> WithOrigin BlockNo
AF.anchorBlockNo AnchoredFragment TestBlock
b, AnchoredFragment TestBlock -> [TestBlock]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment TestBlock
b) | AnchoredFragment TestBlock
b <- [AnchoredFragment TestBlock]
branches ]
      ]

instance QC.Arbitrary PeerScheduleFromTipPointsInput where
  arbitrary :: Gen PeerScheduleFromTipPointsInput
arbitrary = do
    slotLength <- (DiffTime, DiffTime) -> Gen DiffTime
chooseDiffTime (DiffTime
1, DiffTime
20)
    tipDelayInterval <- genTimeInterval (slotLength - 0.1)
    headerDelayInterval <- genTimeInterval (min 2 (slotLength - 0.1))
    blockDelayInterval <- genTimeInterval (min 2 (slotLength - 0.1))
    tipPoints <- genTipPoints
    isTrunks <- QC.infiniteList
    intersections <- genIntersections (length tipPoints)
    let tstps = [IsTrunk] -> [[Int]] -> [(IsTrunk, [Int])]
forall a b. [a] -> [b] -> [(a, b)]
zip [IsTrunk]
isTrunks [[Int]]
tipPoints
        tsi = [IsTrunk] -> [Int] -> [(IsTrunk, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [IsTrunk]
isTrunks [Int]
intersections
        -- The maximum block number in the tip points and the intersections.
        maxBlock =
          [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Int]
b | (IsTrunk
IsTrunk, [Int]
b) <- [(IsTrunk, [Int])]
tstps ] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++
                           [ Int
i | (IsTrunk
IsBranch, Int
i) <- [(IsTrunk, Int)]
tsi ]
    trunkSlots <- map SlotNo <$> genSortedVectorWithoutDuplicates (maxBlock + 1)
    let branchesTipPoints = [ [Int]
b | (IsTrunk
IsBranch, [Int]
b) <- [(IsTrunk, [Int])]
tstps ]
    branchesSlots <- forM branchesTipPoints $ \[Int]
b -> do
      let maxBranchBlock :: Int
maxBranchBlock = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
b
      (Word64 -> SlotNo) -> [Word64] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> SlotNo
SlotNo ([Word64] -> [SlotNo]) -> Gen [Word64] -> Gen [SlotNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [Word64]
forall a. (Arbitrary a, Num a, Ord a) => Int -> Gen [a]
genSortedVectorWithoutDuplicates (Int
maxBranchBlock Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    let trunk = WithOrigin TestBlock
-> [SlotNo] -> Int -> AnchoredFragment TestBlock
mkFragment WithOrigin TestBlock
forall t. WithOrigin t
Origin [SlotNo]
trunkSlots Int
0
        branchIntersections = [ Int
i | (IsTrunk
IsBranch, Int
i) <- [(IsTrunk, Int)]
tsi ]
        branches =
          [ AnchoredFragment TestBlock
-> Int -> Int -> [SlotNo] -> AnchoredFragment TestBlock
genAdversarialFragment AnchoredFragment TestBlock
trunk Int
fNo Int
i [SlotNo]
branchSlots
          | (Int
fNo, [SlotNo]
branchSlots, Int
i)  <- [Int] -> [[SlotNo]] -> [Int] -> [(Int, [SlotNo], Int)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
1..] [[SlotNo]]
branchesSlots [Int]
branchIntersections
          ]
        psp = PeerScheduleParams
          { pspSlotLength :: DiffTime
pspSlotLength = DiffTime
slotLength
          , pspTipDelayInterval :: (DiffTime, DiffTime)
pspTipDelayInterval = (DiffTime, DiffTime)
tipDelayInterval
          , pspHeaderDelayInterval :: (DiffTime, DiffTime)
pspHeaderDelayInterval = (DiffTime, DiffTime)
headerDelayInterval
          , pspBlockDelayInterval :: (DiffTime, DiffTime)
pspBlockDelayInterval = (DiffTime, DiffTime)
blockDelayInterval
          }

    pure $ PeerScheduleFromTipPointsInput psp tstps trunk branches

instance QC.Arbitrary IsTrunk where
  arbitrary :: Gen IsTrunk
arbitrary = [IsTrunk] -> Gen IsTrunk
forall a. HasCallStack => [a] -> Gen a
QC.elements [IsTrunk
IsTrunk, IsTrunk
IsBranch]

prop_peerScheduleFromTipPoints :: QCGen -> PeerScheduleFromTipPointsInput -> QC.Property
prop_peerScheduleFromTipPoints :: QCGen -> PeerScheduleFromTipPointsInput -> Property
prop_peerScheduleFromTipPoints QCGen
seed (PeerScheduleFromTipPointsInput PeerScheduleParams
psp [(IsTrunk, [Int])]
tps AnchoredFragment TestBlock
trunk [AnchoredFragment TestBlock]
branches) =
    QCGen -> (forall s. STGenM QCGen s -> ST s Property) -> Property
forall g a.
RandomGen g =>
g -> (forall s. STGenM g s -> ST s a) -> a
runSTGen_ QCGen
seed ((forall s. STGenM QCGen s -> ST s Property) -> Property)
-> (forall s. STGenM QCGen s -> ST s Property) -> Property
forall a b. (a -> b) -> a -> b
$ \STGenM QCGen s
g -> do
      ss <- STGenM QCGen s
-> PeerScheduleParams
-> [(IsTrunk, [Int])]
-> AnchoredFragment TestBlock
-> [AnchoredFragment TestBlock]
-> ST s [(Time, SchedulePoint TestBlock)]
forall g (m :: * -> *) blk.
(StatefulGen g m, HasHeader blk) =>
g
-> PeerScheduleParams
-> [(IsTrunk, [Int])]
-> AnchoredFragment blk
-> [AnchoredFragment blk]
-> m [(Time, SchedulePoint blk)]
peerScheduleFromTipPoints STGenM QCGen s
g PeerScheduleParams
psp [(IsTrunk, [Int])]
tps AnchoredFragment TestBlock
trunk [AnchoredFragment TestBlock]
branches
      let (tps', (hps, _bps)) =
            partition (isHeaderPoint . snd) <$> partition (isTipPoint . snd) ss
      pure $
          (QC.counterexample ("hps = " ++ show (map (second showPoint) hps)) $
           QC.counterexample ("tps' = " ++ show (map (second showPoint) tps')) $
             headerPointsFollowTipPoints isAncestorBlock'
               (map (second schedulePointToBlock) hps)
               (map (second schedulePointToBlock) tps')
          )
        QC..&&.
          (QC.counterexample ("schedule = " ++ show (map (second showPoint) ss)) $
            isSorted QC.le (map fst ss))
        QC..&&.
          (QC.counterexample ("schedule = " ++ show (map (second showPoint) ss)) $
           QC.counterexample ("header points don't decrease or repeat") $
            noReturnToAncestors (filter isHeaderPoint $ map snd ss)
          )
        QC..&&.
          (QC.counterexample ("schedule = " ++ show (map (second showPoint) ss)) $
           QC.counterexample ("block points don't decrease or repeat") $
            noReturnToAncestors (filter isBlockPoint $ map snd ss)
          )
  where
    showPoint :: SchedulePoint TestBlock -> String
    showPoint :: SchedulePoint TestBlock -> TestName
showPoint (ScheduleTipPoint WithOrigin TestBlock
b)    = TestName
"TP " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ (TestBlock -> TestName) -> WithOrigin TestBlock -> TestName
forall a. (a -> TestName) -> WithOrigin a -> TestName
terseWithOrigin TestBlock -> TestName
terseBlock WithOrigin TestBlock
b
    showPoint (ScheduleHeaderPoint WithOrigin TestBlock
b) = TestName
"HP " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ (TestBlock -> TestName) -> WithOrigin TestBlock -> TestName
forall a. (a -> TestName) -> WithOrigin a -> TestName
terseWithOrigin TestBlock -> TestName
terseBlock WithOrigin TestBlock
b
    showPoint (ScheduleBlockPoint WithOrigin TestBlock
b)  = TestName
"BP " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ (TestBlock -> TestName) -> WithOrigin TestBlock -> TestName
forall a. (a -> TestName) -> WithOrigin a -> TestName
terseWithOrigin TestBlock -> TestName
terseBlock WithOrigin TestBlock
b

    isTipPoint :: SchedulePoint blk -> Bool
    isTipPoint :: forall blk. SchedulePoint blk -> Bool
isTipPoint (ScheduleTipPoint WithOrigin blk
_) = Bool
True
    isTipPoint SchedulePoint blk
_                    = Bool
False

    isHeaderPoint :: SchedulePoint blk -> Bool
    isHeaderPoint :: forall blk. SchedulePoint blk -> Bool
isHeaderPoint (ScheduleHeaderPoint WithOrigin blk
_) = Bool
True
    isHeaderPoint SchedulePoint blk
_                       = Bool
False

    isBlockPoint :: SchedulePoint blk -> Bool
    isBlockPoint :: forall blk. SchedulePoint blk -> Bool
isBlockPoint (ScheduleBlockPoint WithOrigin blk
_) = Bool
True
    isBlockPoint SchedulePoint blk
_                      = Bool
False

isAncestorBlock :: TestBlock -> TestBlock -> Maybe Ordering
isAncestorBlock :: TestBlock -> TestBlock -> Maybe Ordering
isAncestorBlock TestBlock
b0 TestBlock
b1 =
    if [Word64] -> [Word64] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf
         (NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
NonEmpty.toList (TestHash -> NonEmpty Word64
unTestHash (TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
b0)))
         (NonEmpty Word64 -> [Word64]
forall a. NonEmpty a -> [a]
NonEmpty.toList (TestHash -> NonEmpty Word64
unTestHash (TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
b1)))
    then if TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
b0 TestHash -> TestHash -> Bool
forall a. Eq a => a -> a -> Bool
== TestBlock -> HeaderHash TestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash TestBlock
b1
      then Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
EQ
      else Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
LT
    else Maybe Ordering
forall a. Maybe a
Nothing

isAncestorBlock' :: WithOrigin TestBlock -> WithOrigin TestBlock -> Maybe Ordering
isAncestorBlock' :: WithOrigin TestBlock -> WithOrigin TestBlock -> Maybe Ordering
isAncestorBlock' WithOrigin TestBlock
Origin WithOrigin TestBlock
Origin   = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
EQ
isAncestorBlock' WithOrigin TestBlock
Origin WithOrigin TestBlock
_        = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
LT
isAncestorBlock' WithOrigin TestBlock
_ WithOrigin TestBlock
Origin        = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
GT
isAncestorBlock' (At TestBlock
b0) (At TestBlock
b1) = TestBlock -> TestBlock -> Maybe Ordering
isAncestorBlock TestBlock
b0 TestBlock
b1

noReturnToAncestors :: [SchedulePoint TestBlock] -> QC.Property
noReturnToAncestors :: [SchedulePoint TestBlock] -> Property
noReturnToAncestors = [WithOrigin TestBlock] -> [SchedulePoint TestBlock] -> Property
go []
  where
    go :: [WithOrigin TestBlock] -> [SchedulePoint TestBlock] -> Property
go [WithOrigin TestBlock]
_ [] = Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property Bool
True
    go [WithOrigin TestBlock]
ancestors (SchedulePoint TestBlock
p : [SchedulePoint TestBlock]
ss) =
      let b :: WithOrigin TestBlock
b = SchedulePoint TestBlock -> WithOrigin TestBlock
forall blk. SchedulePoint blk -> WithOrigin blk
schedulePointToBlock SchedulePoint TestBlock
p
       in   (Property -> Property -> Property)
-> Property -> [Property] -> Property
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
(QC..&&.) (Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property Bool
True)
              ((WithOrigin TestBlock -> Property)
-> [WithOrigin TestBlock] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map (WithOrigin TestBlock -> WithOrigin TestBlock -> Property
isNotAncestorOf' WithOrigin TestBlock
b) [WithOrigin TestBlock]
ancestors)
          Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
            [WithOrigin TestBlock] -> [SchedulePoint TestBlock] -> Property
go (WithOrigin TestBlock
b WithOrigin TestBlock
-> [WithOrigin TestBlock] -> [WithOrigin TestBlock]
forall a. a -> [a] -> [a]
: [WithOrigin TestBlock]
ancestors) [SchedulePoint TestBlock]
ss

    isNotAncestorOf' :: WithOrigin TestBlock -> WithOrigin TestBlock -> QC.Property
    isNotAncestorOf' :: WithOrigin TestBlock -> WithOrigin TestBlock -> Property
isNotAncestorOf' WithOrigin TestBlock
b0 WithOrigin TestBlock
b1 =
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"return to ancestor: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ (TestBlock -> TestName) -> WithOrigin TestBlock -> TestName
forall a. (a -> TestName) -> WithOrigin a -> TestName
terseWithOrigin TestBlock -> TestName
terseBlock WithOrigin TestBlock
b0 TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
" -> " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ (TestBlock -> TestName) -> WithOrigin TestBlock -> TestName
forall a. (a -> TestName) -> WithOrigin a -> TestName
terseWithOrigin TestBlock -> TestName
terseBlock WithOrigin TestBlock
b1) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Maybe Ordering -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Ordering -> Bool) -> Maybe Ordering -> Bool
forall a b. (a -> b) -> a -> b
$ WithOrigin TestBlock -> WithOrigin TestBlock -> Maybe Ordering
isAncestorBlock' WithOrigin TestBlock
b0 WithOrigin TestBlock
b1

genTimeInterval :: DiffTime -> QC.Gen (DiffTime, DiffTime)
genTimeInterval :: DiffTime -> Gen (DiffTime, DiffTime)
genTimeInterval DiffTime
trange = do
    a <- (DiffTime, DiffTime) -> Gen DiffTime
chooseDiffTime (DiffTime
1, DiffTime
trange)
    b <- chooseDiffTime (1, trange)
    pure (min a b, max a b)

genTipPoints :: QC.Gen [[Int]]
genTipPoints :: Gen [[Int]]
genTipPoints = do
    branchCount <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
1, Int
5)
    xss <- QC.vector branchCount
    pure $ map (dedupSorted . sort . map QC.getNonNegative . QC.getNonEmpty) xss

-- | @genIntersections n@ generates a list of @n@ intersections as block numbers.
genIntersections :: Int -> QC.Gen [Int]
genIntersections :: Int -> Gen [Int]
genIntersections Int
n =
    -- Intersection with the genesis block is represented by @Just (-1)@.
    (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([Int] -> [Int])
-> ([NonNegative Int] -> [Int]) -> [NonNegative Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int])
-> ([NonNegative Int] -> [Int]) -> [NonNegative Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonNegative Int -> Int) -> [NonNegative Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map NonNegative Int -> Int
forall a. NonNegative a -> a
QC.getNonNegative ([NonNegative Int] -> [Int]) -> Gen [NonNegative Int] -> Gen [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [NonNegative Int]
forall a. Arbitrary a => Int -> Gen [a]
QC.vector Int
n

isSorted :: Show a => (a -> a -> QC.Property) -> [a] -> QC.Property
isSorted :: forall a. Show a => (a -> a -> Property) -> [a] -> Property
isSorted a -> a -> Property
cmp [a]
xs =
    TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"isSorted " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> TestName
forall a. Show a => a -> TestName
show [a]
xs) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    (Property -> Property -> Property)
-> Property -> [Property] -> Property
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
(QC..&&.) (Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property Bool
True)
      [ a -> a -> Property
cmp a
a a
b | (a
a, a
b) <- [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 [a]
xs) ]

chooseDiffTime :: (DiffTime, DiffTime) -> QC.Gen DiffTime
chooseDiffTime :: (DiffTime, DiffTime) -> Gen DiffTime
chooseDiffTime (DiffTime
a, DiffTime
b) = do
    let aInt :: Integer
aInt = DiffTime -> Integer
diffTimeToPicoseconds DiffTime
a
        bInt :: Integer
bInt = DiffTime -> Integer
diffTimeToPicoseconds DiffTime
b
    Integer -> DiffTime
picosecondsToDiffTime (Integer -> DiffTime) -> Gen Integer -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
QC.chooseInteger (Integer
aInt, Integer
bInt)

dedupSorted :: Eq a => [a] -> [a]
dedupSorted :: forall a. Eq a => [a] -> [a]
dedupSorted = ([a] -> a) -> [[a]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> a
forall a. HasCallStack => [a] -> a
headCallStack ([[a]] -> [a]) -> ([a] -> [[a]]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
group

headCallStack :: HasCallStack => [a] -> a
headCallStack :: forall a. HasCallStack => [a] -> a
headCallStack = \case
  a
x:[a]
_ -> a
x
  [a]
_   -> TestName -> a
forall a. HasCallStack => TestName -> a
error TestName
"headCallStack: empty list"

headerPointsFollowTipPoints :: Show a => (a -> a -> Maybe Ordering) -> [(Time, a)] -> [(Time, a)] -> QC.Property
headerPointsFollowTipPoints :: forall a.
Show a =>
(a -> a -> Maybe Ordering)
-> [(Time, a)] -> [(Time, a)] -> Property
headerPointsFollowTipPoints a -> a -> Maybe Ordering
_ [] [] = Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property Bool
True
headerPointsFollowTipPoints a -> a -> Maybe Ordering
isAncestor ((Time
t0, a
i0) : [(Time, a)]
ss) ((Time
t1, a
i1) : [(Time, a)]
ps) =
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample TestName
"schedule times follow tip points" (Time -> Time -> Property
forall a. (Ord a, Show a) => a -> a -> Property
QC.ge Time
t0 Time
t1)
    Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
      (case a -> a -> Maybe Ordering
isAncestor a
i0 a
i1 of
         Just Ordering
LT -> (a -> a -> Maybe Ordering)
-> [(Time, a)] -> [(Time, a)] -> Property
forall a.
Show a =>
(a -> a -> Maybe Ordering)
-> [(Time, a)] -> [(Time, a)] -> Property
headerPointsFollowTipPoints a -> a -> Maybe Ordering
isAncestor [(Time, a)]
ss ((Time
t1, a
i1) (Time, a) -> [(Time, a)] -> [(Time, a)]
forall a. a -> [a] -> [a]
: [(Time, a)]
ps)
         Just Ordering
EQ -> (a -> a -> Maybe Ordering)
-> [(Time, a)] -> [(Time, a)] -> Property
forall a.
Show a =>
(a -> a -> Maybe Ordering)
-> [(Time, a)] -> [(Time, a)] -> Property
headerPointsFollowTipPoints a -> a -> Maybe Ordering
isAncestor [(Time, a)]
ss [(Time, a)]
ps
         Maybe Ordering
_       -> (a -> a -> Maybe Ordering)
-> [(Time, a)] -> [(Time, a)] -> Property
forall a.
Show a =>
(a -> a -> Maybe Ordering)
-> [(Time, a)] -> [(Time, a)] -> Property
headerPointsFollowTipPoints a -> a -> Maybe Ordering
isAncestor ((Time
t0, a
i0) (Time, a) -> [(Time, a)] -> [(Time, a)]
forall a. a -> [a] -> [a]
: [(Time, a)]
ss) [(Time, a)]
ps
      )
headerPointsFollowTipPoints a -> a -> Maybe Ordering
_ [] [(Time, a)]
_ps =
--      There can be unscheduled header points if they would be produced so
--      late that they would come after the tip point has moved to another branch.
--
--      QC.counterexample ("schedule times are sufficient for: " ++ show ps) $
--        QC.property False
      Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property Bool
True
headerPointsFollowTipPoints a -> a -> Maybe Ordering
_ [(Time, a)]
ss [] =
      TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"schedule times finish after last tip point: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Time, a)] -> TestName
forall a. Show a => a -> TestName
show [(Time, a)]
ss) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property Bool
False

-- | @genAdversarialFragment goodBlocks forkNo prefixCount slotsA@ generates
-- a fragment for a chain that forks off the given chain.
genAdversarialFragment :: AF.AnchoredFragment TestBlock -> Int -> Int -> [SlotNo] -> AF.AnchoredFragment TestBlock
genAdversarialFragment :: AnchoredFragment TestBlock
-> Int -> Int -> [SlotNo] -> AnchoredFragment TestBlock
genAdversarialFragment AnchoredFragment TestBlock
goodBlocks Int
forkNo Int
prefixCount [SlotNo]
slotsA
      = WithOrigin TestBlock
-> [SlotNo] -> Int -> AnchoredFragment TestBlock
mkFragment WithOrigin TestBlock
intersectionBlock [SlotNo]
slotsA Int
forkNo
  where
    -- blocks in the common prefix in reversed order
    intersectionBlock :: WithOrigin TestBlock
intersectionBlock = case AnchoredFragment TestBlock -> Either (Anchor TestBlock) TestBlock
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head (AnchoredFragment TestBlock -> Either (Anchor TestBlock) TestBlock)
-> AnchoredFragment TestBlock
-> Either (Anchor TestBlock) TestBlock
forall a b. (a -> b) -> a -> b
$ Int -> AnchoredFragment TestBlock -> AnchoredFragment TestBlock
forall v a b.
Anchorable v a b =>
Int -> AnchoredSeq v a b -> AnchoredSeq v a b
AF.takeOldest (Int
prefixCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) AnchoredFragment TestBlock
goodBlocks of
        Left Anchor TestBlock
_  -> WithOrigin TestBlock
forall t. WithOrigin t
Origin
        Right TestBlock
b -> TestBlock -> WithOrigin TestBlock
forall t. t -> WithOrigin t
At TestBlock
b

-- | @mkFragment pre active forkNo@ generates a list of blocks at the given slots.
mkFragment :: WithOrigin TestBlock -> [SlotNo] -> Int -> AF.AnchoredFragment TestBlock
mkFragment :: WithOrigin TestBlock
-> [SlotNo] -> Int -> AnchoredFragment TestBlock
mkFragment WithOrigin TestBlock
pre [SlotNo]
active Int
forkNo = Anchor TestBlock -> [TestBlock] -> AnchoredFragment TestBlock
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromNewestFirst Anchor TestBlock
anchor ([TestBlock] -> AnchoredFragment TestBlock)
-> [TestBlock] -> AnchoredFragment TestBlock
forall a b. (a -> b) -> a -> b
$ ([TestBlock] -> SlotNo -> [TestBlock])
-> [TestBlock] -> [SlotNo] -> [TestBlock]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' [TestBlock] -> SlotNo -> [TestBlock]
issue [] [SlotNo]
active
  where
    anchor :: Anchor TestBlock
anchor = Anchor TestBlock
-> (TestBlock -> Anchor TestBlock)
-> WithOrigin TestBlock
-> Anchor TestBlock
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin Anchor TestBlock
forall block. Anchor block
AF.AnchorGenesis TestBlock -> Anchor TestBlock
forall block. HasHeader block => block -> Anchor block
AF.anchorFromBlock WithOrigin TestBlock
pre
    issue :: [TestBlock] -> SlotNo -> [TestBlock]
issue (TestBlock
h : [TestBlock]
t) SlotNo
s = (TestBlock -> TestBlock
successorBlock TestBlock
h) {tbSlot = s} TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: TestBlock
h TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: [TestBlock]
t
    issue [] SlotNo
s | WithOrigin TestBlock
Origin <- WithOrigin TestBlock
pre = [(Word64 -> TestBlock
firstBlock (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
forkNo)) {tbSlot = s}]
               | At TestBlock
h <- WithOrigin TestBlock
pre = [((Word64 -> Word64) -> TestBlock -> TestBlock
modifyFork (Word64 -> Word64 -> Word64
forall a b. a -> b -> a
const (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
forkNo)) (TestBlock -> TestBlock
successorBlock TestBlock
h)) {tbSlot = s}]

-- | @genVectorWithoutDuplicates n@ generates a vector of length @n@
-- without duplicates.
genSortedVectorWithoutDuplicates :: (QC.Arbitrary a, Num a, Ord a) => Int -> QC.Gen [a]
genSortedVectorWithoutDuplicates :: forall a. (Arbitrary a, Num a, Ord a) => Int -> Gen [a]
genSortedVectorWithoutDuplicates Int
n = do
    x0 <- Gen a
forall a. Arbitrary a => Gen a
QC.arbitrary
    scanl (+) x0 . map ((+1) . QC.getNonNegative) <$> QC.vector (n - 1)