{-# 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 hiding (elements)
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 Int
a <- Gen (NonNegative Int)
forall a. Arbitrary a => Gen a
QC.arbitrary
    QC.NonNegative Int
b <- Gen (NonNegative Int)
forall a. Arbitrary a => Gen a
QC.arbitrary
    SingleJumpTipPointsInput -> Gen SingleJumpTipPointsInput
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SingleJumpTipPointsInput -> Gen SingleJumpTipPointsInput)
-> SingleJumpTipPointsInput -> Gen SingleJumpTipPointsInput
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SingleJumpTipPointsInput
SingleJumpTipPointsInput (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
a Int
b) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
a Int
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
      [Int]
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
      Property -> ST s Property
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> ST s Property) -> Property -> ST s Property
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Property) -> [Int] -> Property
forall a. Show a => (a -> a -> Property) -> [a] -> Property
isSorted Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
QC.le [Int]
xs
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
         (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"length xs = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`QC.le` Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
         )
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
         (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"head xs = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show ([Int] -> Int
forall a. HasCallStack => [a] -> a
headCallStack [Int]
xs)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
             [Int] -> Int
forall a. HasCallStack => [a] -> a
headCallStack [Int]
xs Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`QC.le` Int
n
           Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
             Int
m Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
`QC.le` [Int] -> Int
forall a. HasCallStack => [a] -> a
headCallStack [Int]
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
    DiffTime
slotLength <- (DiffTime, DiffTime) -> Gen DiffTime
chooseDiffTime (DiffTime
1, DiffTime
20)
    (DiffTime, DiffTime)
msgInterval <- DiffTime -> Gen (DiffTime, DiffTime)
genTimeInterval (DiffTime
slotLength DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
0.1)
    [SlotNo]
slots0 <- [SlotNo] -> [SlotNo]
forall a. Eq a => [a] -> [a]
dedupSorted ([SlotNo] -> [SlotNo])
-> ([NonNegative Word64] -> [SlotNo])
-> [NonNegative Word64]
-> [SlotNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonNegative Word64 -> SlotNo) -> [NonNegative Word64] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map (Word64 -> SlotNo
SlotNo (Word64 -> SlotNo)
-> (NonNegative Word64 -> Word64) -> NonNegative Word64 -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonNegative Word64 -> Word64
forall a. NonNegative a -> a
QC.getNonNegative) ([NonNegative Word64] -> [SlotNo])
-> Gen [NonNegative Word64] -> Gen [SlotNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [NonNegative Word64]
forall a. (Ord a, Arbitrary a) => Gen [a]
QC.orderedList
    [SlotNo]
slots1 <- [SlotNo] -> [SlotNo]
forall a. Eq a => [a] -> [a]
dedupSorted ([SlotNo] -> [SlotNo])
-> ([NonNegative Word64] -> [SlotNo])
-> [NonNegative Word64]
-> [SlotNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonNegative Word64 -> SlotNo) -> [NonNegative Word64] -> [SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map (Word64 -> SlotNo
SlotNo (Word64 -> SlotNo)
-> (NonNegative Word64 -> Word64) -> NonNegative Word64 -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonNegative Word64 -> Word64
forall a. NonNegative a -> a
QC.getNonNegative) ([NonNegative Word64] -> [SlotNo])
-> Gen [NonNegative Word64] -> Gen [SlotNo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [NonNegative Word64]
forall a. (Ord a, Arbitrary a) => Gen [a]
QC.orderedList
    TipPointScheduleInput -> Gen TipPointScheduleInput
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TipPointScheduleInput -> Gen TipPointScheduleInput)
-> TipPointScheduleInput -> Gen TipPointScheduleInput
forall a b. (a -> b) -> a -> b
$ DiffTime
-> (DiffTime, DiffTime) -> [SlotNo] -> TipPointScheduleInput
TipPointScheduleInput DiffTime
slotLength (DiffTime, DiffTime)
msgInterval ([SlotNo]
slots0 [SlotNo] -> [SlotNo] -> [SlotNo]
forall a. [a] -> [a] -> [a]
++ [SlotNo]
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
      [Time]
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
      Property -> ST s Property
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> ST s Property) -> Property -> ST s Property
forall a b. (a -> b) -> a -> b
$
          (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"length slots = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show ([SlotNo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SlotNo]
slots)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"length ts = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show ([Time] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Time]
ts)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
             [SlotNo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SlotNo]
slots Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
QC.=== [Time] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Time]
ts
          )
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
          (Time -> Time -> Property) -> [Time] -> Property
forall a. Show a => (a -> a -> Property) -> [a] -> Property
isSorted Time -> Time -> Property
forall a. (Ord a, Show a) => a -> a -> Property
QC.le [Time]
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
    (DiffTime, DiffTime)
msgInterval <- DiffTime -> Gen (DiffTime, DiffTime)
genTimeInterval DiffTime
10
    [[Int]]
branchTips <- Gen [[Int]]
genTipPoints
    let branchCount :: Int
branchCount = [[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
branchTips
        tpCount :: Int
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
    [Time]
ts <- [DiffTime] -> [Time]
forall a b. Coercible a b => a -> b
coerce ([DiffTime] -> [Time])
-> ([DiffTime] -> [DiffTime]) -> [DiffTime] -> [Time]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DiffTime -> DiffTime -> DiffTime) -> [DiffTime] -> [DiffTime]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
(+) ([DiffTime] -> [DiffTime])
-> ([DiffTime] -> [DiffTime]) -> [DiffTime] -> [DiffTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DiffTime] -> [DiffTime]
forall a. Ord a => [a] -> [a]
sort ([DiffTime] -> [Time]) -> Gen [DiffTime] -> Gen [Time]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen DiffTime -> Gen [DiffTime]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
tpCount ((DiffTime, DiffTime) -> Gen DiffTime
chooseDiffTime (DiffTime
7, DiffTime
12))
    let tpts :: [[(Time, Int)]]
tpts = [Time] -> [[Int]] -> [[(Time, Int)]]
forall a b. [a] -> [[b]] -> [[(a, b)]]
zipMany [Time]
ts [[Int]]
branchTips
    [Int]
intersectionBlocks <- Int -> Gen [Int]
genIntersections Int
branchCount
    [Maybe Int]
maybes <- forall a. Arbitrary a => Gen [a]
QC.infiniteList @(Maybe Int)
    let intersections :: [Maybe Int]
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
    HeaderPointScheduleInput -> Gen HeaderPointScheduleInput
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeaderPointScheduleInput -> Gen HeaderPointScheduleInput)
-> HeaderPointScheduleInput -> Gen HeaderPointScheduleInput
forall a b. (a -> b) -> a -> b
$ (DiffTime, DiffTime)
-> [(Maybe Int, [(Time, Int)])] -> HeaderPointScheduleInput
HeaderPointScheduleInput (DiffTime, DiffTime)
msgInterval ([Maybe Int] -> [[(Time, Int)]] -> [(Maybe Int, [(Time, Int)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe Int]
intersections [[(Time, Int)]]
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
      [HeaderPointSchedule]
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
      Property -> ST s Property
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> ST s Property) -> Property -> ST s Property
forall a b. (a -> b) -> a -> b
$
          (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"length xs = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show ([(Maybe Int, [(Time, Int)])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Int, [(Time, Int)])]
xs)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"length hpss = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show ([HeaderPointSchedule] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HeaderPointSchedule]
hpss)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            [(Maybe Int, [(Time, Int)])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Int, [(Time, Int)])]
xs Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
QC.=== [HeaderPointSchedule] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HeaderPointSchedule]
hpss
          )
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
          (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"header points are sorted in each branch") (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)
              [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"branch = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ HeaderPointSchedule -> TestName
forall a. Show a => a -> TestName
show HeaderPointSchedule
hps) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                (Int -> Int -> Property) -> [Int] -> Property
forall a. Show a => (a -> a -> Property) -> [a] -> Property
isSorted Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
QC.lt (((Time, Int) -> Int) -> [(Time, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Time, Int) -> Int
forall a b. (a, b) -> b
snd [(Time, Int)]
trunk) Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&. (Int -> Int -> Property) -> [Int] -> Property
forall a. Show a => (a -> a -> Property) -> [a] -> Property
isSorted Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
QC.lt (((Time, Int) -> Int) -> [(Time, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Time, Int) -> Int
forall a b. (a, b) -> b
snd [(Time, Int)]
branch)
              | hps :: HeaderPointSchedule
hps@(HeaderPointSchedule [(Time, Int)]
trunk [(Time, Int)]
branch) <- [HeaderPointSchedule]
hpss
              ]
          )
         Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
          (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"times are sorted accross branches") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"branches = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [HeaderPointSchedule] -> TestName
forall a. Show a => a -> TestName
show [HeaderPointSchedule]
hpss) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            (Time -> Time -> Property) -> [Time] -> Property
forall a. Show a => (a -> a -> Property) -> [a] -> Property
isSorted Time -> Time -> Property
forall a. (Ord a, Show a) => a -> a -> Property
QC.le ([Time] -> Property) -> [Time] -> Property
forall a b. (a -> b) -> a -> b
$ [[Time]] -> [Time]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ ((Time, Int) -> Time) -> [(Time, Int)] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (Time, Int) -> Time
forall a b. (a, b) -> a
fst [(Time, Int)]
trunk [Time] -> [Time] -> [Time]
forall a. [a] -> [a] -> [a]
++ ((Time, Int) -> Time) -> [(Time, Int)] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (Time, Int) -> Time
forall a b. (a, b) -> a
fst [(Time, Int)]
branch
              | HeaderPointSchedule [(Time, Int)]
trunk [(Time, Int)]
branch <- [HeaderPointSchedule]
hpss
              ]
          )
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
          (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"trunk header points are sorted accross branches") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"branches = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [HeaderPointSchedule] -> TestName
forall a. Show a => a -> TestName
show [HeaderPointSchedule]
hpss) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            (Int -> Int -> Property) -> [Int] -> Property
forall a. Show a => (a -> a -> Property) -> [a] -> Property
isSorted Int -> Int -> Property
forall a. (Ord a, Show a) => a -> a -> Property
QC.lt ([Int] -> Property) -> [Int] -> Property
forall a b. (a -> b) -> a -> b
$ [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ ((Time, Int) -> Int) -> [(Time, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Time, Int) -> Int
forall a b. (a, b) -> b
snd [(Time, Int)]
trunk | HeaderPointSchedule [(Time, Int)]
trunk [(Time, Int)]
_ <- [HeaderPointSchedule]
hpss ]
          )
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
          (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample TestName
"branch header points follow tip points" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"branches = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [HeaderPointSchedule] -> TestName
forall a. Show a => a -> TestName
show [HeaderPointSchedule]
hpss) (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) ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
               (HeaderPointSchedule -> (Maybe Int, [(Time, Int)]) -> Property)
-> [HeaderPointSchedule]
-> [(Maybe Int, [(Time, Int)])]
-> [Property]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
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
                ) [HeaderPointSchedule]
hpss [(Maybe Int, [(Time, Int)])]
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
    DiffTime
slotLength <- (DiffTime, DiffTime) -> Gen DiffTime
chooseDiffTime (DiffTime
1, DiffTime
20)
    (DiffTime, DiffTime)
tipDelayInterval <- DiffTime -> Gen (DiffTime, DiffTime)
genTimeInterval (DiffTime
slotLength DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
0.1)
    (DiffTime, DiffTime)
headerDelayInterval <- DiffTime -> Gen (DiffTime, DiffTime)
genTimeInterval (DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
min DiffTime
2 (DiffTime
slotLength DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
0.1))
    (DiffTime, DiffTime)
blockDelayInterval <- DiffTime -> Gen (DiffTime, DiffTime)
genTimeInterval (DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
min DiffTime
2 (DiffTime
slotLength DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
0.1))
    [[Int]]
tipPoints <- Gen [[Int]]
genTipPoints
    [IsTrunk]
isTrunks <- Gen [IsTrunk]
forall a. Arbitrary a => Gen [a]
QC.infiniteList
    [Int]
intersections <- Int -> Gen [Int]
genIntersections ([[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
tipPoints)
    let tstps :: [(IsTrunk, [Int])]
tstps = [IsTrunk] -> [[Int]] -> [(IsTrunk, [Int])]
forall a b. [a] -> [b] -> [(a, b)]
zip [IsTrunk]
isTrunks [[Int]]
tipPoints
        tsi :: [(IsTrunk, Int)]
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
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 ]
    [SlotNo]
trunkSlots <- (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
maxBlock Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    let branchesTipPoints :: [[Int]]
branchesTipPoints = [ [Int]
b | (IsTrunk
IsBranch, [Int]
b) <- [(IsTrunk, [Int])]
tstps ]
    [[SlotNo]]
branchesSlots <- [[Int]] -> ([Int] -> Gen [SlotNo]) -> Gen [[SlotNo]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Int]]
branchesTipPoints (([Int] -> Gen [SlotNo]) -> Gen [[SlotNo]])
-> ([Int] -> Gen [SlotNo]) -> Gen [[SlotNo]]
forall a b. (a -> b) -> a -> b
$ \[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 :: AnchoredFragment TestBlock
trunk = WithOrigin TestBlock
-> [SlotNo] -> Int -> AnchoredFragment TestBlock
mkFragment WithOrigin TestBlock
forall t. WithOrigin t
Origin [SlotNo]
trunkSlots Int
0
        branchIntersections :: [Int]
branchIntersections = [ Int
i | (IsTrunk
IsBranch, Int
i) <- [(IsTrunk, Int)]
tsi ]
        branches :: [AnchoredFragment TestBlock]
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
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
          }

    PeerScheduleFromTipPointsInput
-> Gen PeerScheduleFromTipPointsInput
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PeerScheduleFromTipPointsInput
 -> Gen PeerScheduleFromTipPointsInput)
-> PeerScheduleFromTipPointsInput
-> Gen PeerScheduleFromTipPointsInput
forall a b. (a -> b) -> a -> b
$ PeerScheduleParams
-> [(IsTrunk, [Int])]
-> AnchoredFragment TestBlock
-> [AnchoredFragment TestBlock]
-> PeerScheduleFromTipPointsInput
PeerScheduleFromTipPointsInput PeerScheduleParams
psp [(IsTrunk, [Int])]
tstps AnchoredFragment TestBlock
trunk [AnchoredFragment TestBlock]
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
      [(Time, SchedulePoint TestBlock)]
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 ([(Time, SchedulePoint TestBlock)]
tps', ([(Time, SchedulePoint TestBlock)]
hps, [(Time, SchedulePoint TestBlock)]
_bps)) =
            ((Time, SchedulePoint TestBlock) -> Bool)
-> [(Time, SchedulePoint TestBlock)]
-> ([(Time, SchedulePoint TestBlock)],
    [(Time, SchedulePoint TestBlock)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (SchedulePoint TestBlock -> Bool
forall blk. SchedulePoint blk -> Bool
isHeaderPoint (SchedulePoint TestBlock -> Bool)
-> ((Time, SchedulePoint TestBlock) -> SchedulePoint TestBlock)
-> (Time, SchedulePoint TestBlock)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, SchedulePoint TestBlock) -> SchedulePoint TestBlock
forall a b. (a, b) -> b
snd) ([(Time, SchedulePoint TestBlock)]
 -> ([(Time, SchedulePoint TestBlock)],
     [(Time, SchedulePoint TestBlock)]))
-> ([(Time, SchedulePoint TestBlock)],
    [(Time, SchedulePoint TestBlock)])
-> ([(Time, SchedulePoint TestBlock)],
    ([(Time, SchedulePoint TestBlock)],
     [(Time, SchedulePoint TestBlock)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Time, SchedulePoint TestBlock) -> Bool)
-> [(Time, SchedulePoint TestBlock)]
-> ([(Time, SchedulePoint TestBlock)],
    [(Time, SchedulePoint TestBlock)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (SchedulePoint TestBlock -> Bool
forall blk. SchedulePoint blk -> Bool
isTipPoint (SchedulePoint TestBlock -> Bool)
-> ((Time, SchedulePoint TestBlock) -> SchedulePoint TestBlock)
-> (Time, SchedulePoint TestBlock)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, SchedulePoint TestBlock) -> SchedulePoint TestBlock
forall a b. (a, b) -> b
snd) [(Time, SchedulePoint TestBlock)]
ss
      Property -> ST s Property
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> ST s Property) -> Property -> ST s Property
forall a b. (a -> b) -> a -> b
$
          (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"hps = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Time, TestName)] -> TestName
forall a. Show a => a -> TestName
show (((Time, SchedulePoint TestBlock) -> (Time, TestName))
-> [(Time, SchedulePoint TestBlock)] -> [(Time, TestName)]
forall a b. (a -> b) -> [a] -> [b]
map ((SchedulePoint TestBlock -> TestName)
-> (Time, SchedulePoint TestBlock) -> (Time, TestName)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SchedulePoint TestBlock -> TestName
showPoint) [(Time, SchedulePoint TestBlock)]
hps)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"tps' = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Time, TestName)] -> TestName
forall a. Show a => a -> TestName
show (((Time, SchedulePoint TestBlock) -> (Time, TestName))
-> [(Time, SchedulePoint TestBlock)] -> [(Time, TestName)]
forall a b. (a -> b) -> [a] -> [b]
map ((SchedulePoint TestBlock -> TestName)
-> (Time, SchedulePoint TestBlock) -> (Time, TestName)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SchedulePoint TestBlock -> TestName
showPoint) [(Time, SchedulePoint TestBlock)]
tps')) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
             (WithOrigin TestBlock -> WithOrigin TestBlock -> Maybe Ordering)
-> [(Time, WithOrigin TestBlock)]
-> [(Time, WithOrigin TestBlock)]
-> Property
forall a.
Show a =>
(a -> a -> Maybe Ordering)
-> [(Time, a)] -> [(Time, a)] -> Property
headerPointsFollowTipPoints WithOrigin TestBlock -> WithOrigin TestBlock -> Maybe Ordering
isAncestorBlock'
               (((Time, SchedulePoint TestBlock) -> (Time, WithOrigin TestBlock))
-> [(Time, SchedulePoint TestBlock)]
-> [(Time, WithOrigin TestBlock)]
forall a b. (a -> b) -> [a] -> [b]
map ((SchedulePoint TestBlock -> WithOrigin TestBlock)
-> (Time, SchedulePoint TestBlock) -> (Time, WithOrigin TestBlock)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SchedulePoint TestBlock -> WithOrigin TestBlock
forall blk. SchedulePoint blk -> WithOrigin blk
schedulePointToBlock) [(Time, SchedulePoint TestBlock)]
hps)
               (((Time, SchedulePoint TestBlock) -> (Time, WithOrigin TestBlock))
-> [(Time, SchedulePoint TestBlock)]
-> [(Time, WithOrigin TestBlock)]
forall a b. (a -> b) -> [a] -> [b]
map ((SchedulePoint TestBlock -> WithOrigin TestBlock)
-> (Time, SchedulePoint TestBlock) -> (Time, WithOrigin TestBlock)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SchedulePoint TestBlock -> WithOrigin TestBlock
forall blk. SchedulePoint blk -> WithOrigin blk
schedulePointToBlock) [(Time, SchedulePoint TestBlock)]
tps')
          )
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
          (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"schedule = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Time, TestName)] -> TestName
forall a. Show a => a -> TestName
show (((Time, SchedulePoint TestBlock) -> (Time, TestName))
-> [(Time, SchedulePoint TestBlock)] -> [(Time, TestName)]
forall a b. (a -> b) -> [a] -> [b]
map ((SchedulePoint TestBlock -> TestName)
-> (Time, SchedulePoint TestBlock) -> (Time, TestName)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SchedulePoint TestBlock -> TestName
showPoint) [(Time, SchedulePoint TestBlock)]
ss)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            (Time -> Time -> Property) -> [Time] -> Property
forall a. Show a => (a -> a -> Property) -> [a] -> Property
isSorted Time -> Time -> Property
forall a. (Ord a, Show a) => a -> a -> Property
QC.le (((Time, SchedulePoint TestBlock) -> Time)
-> [(Time, SchedulePoint TestBlock)] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (Time, SchedulePoint TestBlock) -> Time
forall a b. (a, b) -> a
fst [(Time, SchedulePoint TestBlock)]
ss))
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
          (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"schedule = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Time, TestName)] -> TestName
forall a. Show a => a -> TestName
show (((Time, SchedulePoint TestBlock) -> (Time, TestName))
-> [(Time, SchedulePoint TestBlock)] -> [(Time, TestName)]
forall a b. (a -> b) -> [a] -> [b]
map ((SchedulePoint TestBlock -> TestName)
-> (Time, SchedulePoint TestBlock) -> (Time, TestName)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SchedulePoint TestBlock -> TestName
showPoint) [(Time, SchedulePoint TestBlock)]
ss)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"header points don't decrease or repeat") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            [SchedulePoint TestBlock] -> Property
noReturnToAncestors ((SchedulePoint TestBlock -> Bool)
-> [SchedulePoint TestBlock] -> [SchedulePoint TestBlock]
forall a. (a -> Bool) -> [a] -> [a]
filter SchedulePoint TestBlock -> Bool
forall blk. SchedulePoint blk -> Bool
isHeaderPoint ([SchedulePoint TestBlock] -> [SchedulePoint TestBlock])
-> [SchedulePoint TestBlock] -> [SchedulePoint TestBlock]
forall a b. (a -> b) -> a -> b
$ ((Time, SchedulePoint TestBlock) -> SchedulePoint TestBlock)
-> [(Time, SchedulePoint TestBlock)] -> [SchedulePoint TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map (Time, SchedulePoint TestBlock) -> SchedulePoint TestBlock
forall a b. (a, b) -> b
snd [(Time, SchedulePoint TestBlock)]
ss)
          )
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
          (TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"schedule = " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Time, TestName)] -> TestName
forall a. Show a => a -> TestName
show (((Time, SchedulePoint TestBlock) -> (Time, TestName))
-> [(Time, SchedulePoint TestBlock)] -> [(Time, TestName)]
forall a b. (a -> b) -> [a] -> [b]
map ((SchedulePoint TestBlock -> TestName)
-> (Time, SchedulePoint TestBlock) -> (Time, TestName)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second SchedulePoint TestBlock -> TestName
showPoint) [(Time, SchedulePoint TestBlock)]
ss)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
QC.counterexample (TestName
"block points don't decrease or repeat") (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            [SchedulePoint TestBlock] -> Property
noReturnToAncestors ((SchedulePoint TestBlock -> Bool)
-> [SchedulePoint TestBlock] -> [SchedulePoint TestBlock]
forall a. (a -> Bool) -> [a] -> [a]
filter SchedulePoint TestBlock -> Bool
forall blk. SchedulePoint blk -> Bool
isBlockPoint ([SchedulePoint TestBlock] -> [SchedulePoint TestBlock])
-> [SchedulePoint TestBlock] -> [SchedulePoint TestBlock]
forall a b. (a -> b) -> a -> b
$ ((Time, SchedulePoint TestBlock) -> SchedulePoint TestBlock)
-> [(Time, SchedulePoint TestBlock)] -> [SchedulePoint TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map (Time, SchedulePoint TestBlock) -> SchedulePoint TestBlock
forall a b. (a, b) -> b
snd [(Time, SchedulePoint TestBlock)]
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
    DiffTime
a <- (DiffTime, DiffTime) -> Gen DiffTime
chooseDiffTime (DiffTime
1, DiffTime
trange)
    DiffTime
b <- (DiffTime, DiffTime) -> Gen DiffTime
chooseDiffTime (DiffTime
1, DiffTime
trange)
    (DiffTime, DiffTime) -> Gen (DiffTime, DiffTime)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
min DiffTime
a DiffTime
b, DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
max DiffTime
a DiffTime
b)

genTipPoints :: QC.Gen [[Int]]
genTipPoints :: Gen [[Int]]
genTipPoints = do
    Int
branchCount <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
1, Int
5)
    [NonEmptyList (NonNegative Int)]
xss <- Int -> Gen [NonEmptyList (NonNegative Int)]
forall a. Arbitrary a => Int -> Gen [a]
QC.vector Int
branchCount
    [[Int]] -> Gen [[Int]]
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Int]] -> Gen [[Int]]) -> [[Int]] -> Gen [[Int]]
forall a b. (a -> b) -> a -> b
$ (NonEmptyList (NonNegative Int) -> [Int])
-> [NonEmptyList (NonNegative Int)] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
dedupSorted ([Int] -> [Int])
-> (NonEmptyList (NonNegative Int) -> [Int])
-> NonEmptyList (NonNegative Int)
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int])
-> (NonEmptyList (NonNegative Int) -> [Int])
-> NonEmptyList (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])
-> (NonEmptyList (NonNegative Int) -> [NonNegative Int])
-> NonEmptyList (NonNegative Int)
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmptyList (NonNegative Int) -> [NonNegative Int]
forall a. NonEmptyList a -> [a]
QC.getNonEmpty) [NonEmptyList (NonNegative Int)]
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
    a
x0 <- Gen a
forall a. Arbitrary a => Gen a
QC.arbitrary
    (a -> a -> a) -> a -> [a] -> [a]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl a -> a -> a
forall a. Num a => a -> a -> a
(+) a
x0 ([a] -> [a]) -> ([NonNegative a] -> [a]) -> [NonNegative a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonNegative a -> a) -> [NonNegative a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a -> a
forall a. Num a => a -> a -> a
+a
1) (a -> a) -> (NonNegative a -> a) -> NonNegative a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonNegative a -> a
forall a. NonNegative a -> a
QC.getNonNegative) ([NonNegative a] -> [a]) -> Gen [NonNegative a] -> Gen [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [NonNegative a]
forall a. Arbitrary a => Int -> Gen [a]
QC.vector (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)