ChainGenerators.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE TypeOperators     #-}

{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif

-- | Arbitrary generators for chains, headers and blocks
--
module Test.ChainGenerators
  ( -- * Arbitrary chains generators
    -- These generators are used to test various scenarios that require
    -- a chain: e.g. appending a block to chain, arbitrary updates
    -- (rollforwards \/ backwards), chain forks.
    TestAddBlock (..)
  , TestBlockChainAndUpdates (..)
  , TestBlockChain (..)
  , TestHeaderChain (..)
  , TestChainAndPoint (..)
  , TestChainAndRange (..)
  , TestChainAndPoints (..)
  , TestChainFork (..)
    -- * Utility functions
  , genNonNegative
  , genSlotGap
  , addSlotGap
  , genChainAnchor
  , mkPartialBlock
  , mkRollbackPoint
    -- * Tests of the generators
  , tests
  ) where

import Data.ByteString.Char8 qualified as BSC
import Data.List qualified as L
import Data.Maybe (catMaybes, listToMaybe)

import Ouroboros.Network.AnchoredFragment (Anchor (..))
import Ouroboros.Network.AnchoredFragment qualified as AF
import Ouroboros.Network.Block
import Ouroboros.Network.Mock.Chain (Chain (..))
import Ouroboros.Network.Mock.Chain qualified as Chain
import Ouroboros.Network.Mock.ConcreteBlock
import Ouroboros.Network.Point (WithOrigin (..), block, blockPointHash,
           blockPointSlot, fromWithOrigin, origin)
import Ouroboros.Network.Protocol.BlockFetch.Type (ChainRange (..))

import Data.List (scanl')
import Test.Cardano.Slotting.Arbitrary ()
import Test.QuickCheck
import Test.QuickCheck.Instances.ByteString ()
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)


--
-- The tests for the generators themselves
--

tests :: TestTree
tests = testGroup "Chain"
  [ testProperty "arbitrary for TestBlockChain" $
    -- It's important we don't generate too many trivial test cases here
    -- so check the coverage to enforce it.
                 checkCoverage prop_arbitrary_TestBlockChain
  , testProperty "shrink for TestBlockChain"     prop_shrink_TestBlockChain

  , testProperty "arbitrary for TestHeaderChain" prop_arbitrary_TestHeaderChain
  , testProperty "shrink for TestHeaderChain"    prop_shrink_TestHeaderChain

  , testProperty "arbitrary for TestAddBlock" prop_arbitrary_TestAddBlock
  , testProperty "shrink for TestAddBlock"    prop_shrink_TestAddBlock

  , testProperty "arbitrary for TestBlockChainAndUpdates" $
    -- Same deal here applies here with generating trivial test cases.
                 checkCoverage prop_arbitrary_TestBlockChainAndUpdates

  , testProperty "arbitrary for TestChainAndPoint" $
                                     checkCoverage prop_arbitrary_TestChainAndPoint
  , testProperty "shrink for TestChainAndPoint"    prop_shrink_TestChainAndPoint

  , testProperty "arbitrary for TestChainAndRange" $
                                     checkCoverage prop_arbitrary_TestChainAndRange
  , testProperty "shrink for TestChainAndRange"    prop_shrink_TestChainAndRange

  , testProperty "arbitrary for TestChainAndPoints" $
                                      checkCoverage prop_arbitrary_TestChainAndPoints
  , testProperty "shrink for TestChainAndPoints"    prop_shrink_TestChainAndPoints

  , testProperty "arbitrary for TestChainFork" prop_arbitrary_TestChainFork
  , testProperty "shrink for TestChainFork"
                             (mapSize (min 40) prop_shrink_TestChainFork)
  ]

instance Arbitrary ConcreteHeaderHash where
  arbitrary = HeaderHash <$> arbitrary

instance Arbitrary (Point BlockHeader) where
  arbitrary =
      -- Sometimes pick the genesis point
      frequency [ (1, pure (Point Origin))
                , (4, Point <$> (block <$> arbitrary <*> arbitrary)) ]
  shrink (Point Origin)   = []
  shrink (Point (At blk)) =
      Point origin
    : [ Point (block s' h') | (s', h') <- shrink (s, h), s > SlotNo 0 ]
    where
    h = blockPointHash blk
    s = blockPointSlot blk

instance Arbitrary (Point Block) where
  arbitrary = (castPoint :: Point BlockHeader -> Point Block) <$> arbitrary

  shrink = map (castPoint :: Point BlockHeader -> Point Block)
         . shrink
         .     (castPoint :: Point Block -> Point BlockHeader)

instance Arbitrary (ChainRange (Point Block)) where
  arbitrary = do
    low  <- arbitrary
    high <- arbitrary `suchThat` (\high -> pointSlot low <= pointSlot high)
    return (ChainRange low high)

  shrink (ChainRange low high) = [ ChainRange low' high'
                                 | (low', high') <- shrink (low, high)
                                 , pointSlot low <= pointSlot high ]

instance Arbitrary BlockBody where
    arbitrary =
      BlockBody <$>
        -- Sometimes pick a common block so some are equal
        frequency [ (1, pure $ BSC.pack "EMPTY")
                  , (4, BSC.pack <$> vectorOf 4 (choose ('A', 'Z'))) ]
    -- probably no need for shrink, the content is arbitrary and opaque
    -- if we add one, it might be to shrink to an empty block

instance Arbitrary Block where
    arbitrary = do
      body    <- arbitrary
      slotGap <- genSlotGap
      anchor  <- genChainAnchor
      let slot = addSlotGap slotGap (AF.anchorToSlotNo anchor)
          b    = fixupBlock anchor (mkPartialBlock slot body)
      return b

genSlotGap :: Gen Int
genSlotGap = frequency
    [ (25, pure 1)
      -- EBBs have the same SlotNo as the block after it, so the gap is 0 in
      -- that case.
    , (5,  pure 0)
    , (5,  pure 2)
    , (1,  pure 3)
    ]

-- | Special case: adding a 0-sized gap to 'Origin' results in @'SlotNo' 0@, not
-- 'Origin'. We do this because we use the result of this function to create a
-- block, and blocks must have a slot number.
addSlotGap :: Int -> WithOrigin SlotNo -> SlotNo
addSlotGap 0 Origin          = SlotNo 0
addSlotGap g Origin          = SlotNo (fromIntegral g - 1)
addSlotGap g (At (SlotNo n)) = SlotNo (n + fromIntegral g)

-- | A starting anchor for a chain fragment: either the 'AnchorGenesis' or
-- an arbitrary anchor
--
genChainAnchor :: Gen (Anchor Block)
genChainAnchor = oneof [ pure AnchorGenesis, genArbitraryChainAnchor ]

genArbitraryChainAnchor :: Gen (Anchor Block)
genArbitraryChainAnchor = Anchor <$> arbitrary <*> arbitrary <*> arbitrary

instance Arbitrary BlockHeader where
    arbitrary = blockHeader <$> arbitrary

-- We provide CoArbitrary instances, for (Block -> _) functions
-- We use default implementations using generics.
instance CoArbitrary Block
instance CoArbitrary BlockHeader
instance CoArbitrary SlotNo
instance CoArbitrary BlockNo
instance CoArbitrary BodyHash
instance CoArbitrary BlockBody
instance CoArbitrary (ChainHash BlockHeader)
instance CoArbitrary ConcreteHeaderHash

-- | The 'NonNegative' generator produces a large proportion of 0s, so we use
-- this one instead for now.
--
-- https://github.com/nick8325/quickcheck/issues/229
--
genNonNegative :: Gen Int
genNonNegative = (abs . getSmall <$> arbitrary) `suchThat` (>= 0)

--
-- Generators for chains
--

-- | A test generator for a valid chain of blocks.
--
newtype TestBlockChain = TestBlockChain { getTestBlockChain :: Chain Block }
    deriving (Eq, Show)

-- | A test generator for a valid chain of block headers.
--
newtype TestHeaderChain = TestHeaderChain (Chain BlockHeader)
    deriving (Eq, Show)

instance Arbitrary TestBlockChain where
    arbitrary = do
        n <- genNonNegative
        bodies <- vector n
        slots  <- mkSlots <$> vectorOf n genSlotGap
        let chain = mkChain (zip slots bodies)
        return (TestBlockChain chain)
      where
        mkSlots :: [Int] -> [SlotNo]
        mkSlots = map toEnum . tail . scanl' (+) 0

    shrink (TestBlockChain c) =
        [ TestBlockChain (fixupChain fixupBlock c')
        | c' <- shrinkList (const []) (Chain.toNewestFirst c) ]

instance Arbitrary TestHeaderChain where
    arbitrary = do
        TestBlockChain chain <- arbitrary
        let headerchain = fmap blockHeader chain
        return (TestHeaderChain headerchain)

    shrink (TestHeaderChain c) =
        [ TestHeaderChain (fixupChain fixupBlockHeader c')
        | c' <- shrinkList (const []) (Chain.toNewestFirst c) ]

prop_arbitrary_TestBlockChain :: TestBlockChain -> Property
prop_arbitrary_TestBlockChain (TestBlockChain c) =
    -- check we get some but not too many zero-length chains
    cover 95   (not (Chain.null c)) "non-null" $
    cover 1.5       (Chain.null c)  "null"     $
    Chain.valid c

prop_arbitrary_TestHeaderChain :: TestHeaderChain -> Bool
prop_arbitrary_TestHeaderChain (TestHeaderChain c) =
    Chain.valid c

prop_shrink_TestBlockChain :: TestBlockChain -> Bool
prop_shrink_TestBlockChain c =
    and [ Chain.valid c' | TestBlockChain c' <- shrink c ]

prop_shrink_TestHeaderChain :: TestHeaderChain -> Bool
prop_shrink_TestHeaderChain c =
    and [ Chain.valid c' | TestHeaderChain c' <- shrink c ]


--
-- Generator for chain and single block
--

-- | A test generator for a chain and a block that can be appended to it.
--
data TestAddBlock = TestAddBlock (Chain Block) Block
  deriving Show

instance Arbitrary TestAddBlock where
  arbitrary = do
    TestBlockChain chain <- arbitrary
    blk <- genAddBlock chain
    return (TestAddBlock chain blk)

  shrink (TestAddBlock c b) =
    [ TestAddBlock c' b'
    | TestBlockChain c' <- shrink (TestBlockChain c)
    , let b' = fixupBlock (Chain.headAnchor c') b
    ]

genAddBlock :: (HasHeader block, HeaderHash block ~ ConcreteHeaderHash)
            => Chain block -> Gen Block
genAddBlock chain = do
    slotGap <- genSlotGap
    body    <- arbitrary
    let nextSlotNo = addSlotGap slotGap (Chain.headSlot chain)
        pb = mkPartialBlock nextSlotNo body
        b  = fixupBlock (Chain.headAnchor chain) pb
    return b

prop_arbitrary_TestAddBlock :: TestAddBlock -> Bool
prop_arbitrary_TestAddBlock (TestAddBlock c b) =
    Chain.valid (c :> b)

prop_shrink_TestAddBlock :: TestAddBlock -> Bool
prop_shrink_TestAddBlock t =
    and [ Chain.valid (c :> b) | TestAddBlock c b <- shrink t ]


--
-- Generator for chain updates
--

-- | The Ouroboros K paramater. This is also the maximum rollback length.
--
k :: Int
k = 5

-- | A test generator for a chain and a sequence of updates that can be applied
-- to it.
--
data TestBlockChainAndUpdates =
       TestBlockChainAndUpdates (Chain Block) [ChainUpdate Block Block]
  deriving Show

instance Arbitrary TestBlockChainAndUpdates where
  arbitrary = do
    TestBlockChain chain <- arbitrary
    m <- genNonNegative
    updates <- genChainUpdates chain m
    return (TestBlockChainAndUpdates chain updates)

genChainUpdate :: Chain Block
               -> Gen (ChainUpdate Block Block)
genChainUpdate chain =
    frequency $
      -- To ensure we make progress on average w must ensure the weight of
      -- adding one block is more than the expected rollback length. If we
      -- used expectedRollbackLength then we would on average make no
      -- progress. We slightly arbitrarily weight 2:1 for forward progress.
      [ (expectedRollbackLength * 2, AddBlock <$> genAddBlock chain) ]
   ++ L.take (Chain.length chain)
        [ (freq, pure (RollBack (mkRollbackPoint chain len)))
        | (freq, len) <- rollbackLengthDistribution
        ]
  where
    -- This is the un-normalised expected value since the 'frequency'
    -- combinator normalises everything anyway.
    expectedRollbackLength :: Int
    expectedRollbackLength =
        sum [ freq * n | (freq, n) <- rollbackLengthDistribution ]

    rollbackLengthDistribution :: [(Int,Int)]
    rollbackLengthDistribution =
      (1, 0) :
      [ let freq = (k+1-n); len = n
         in (freq, len)
      | n <- [1..k] ]

mkRollbackPoint :: HasHeader block => Chain block -> Int -> Point block
mkRollbackPoint chain n = Chain.headPoint $ Chain.drop n chain

genChainUpdates :: Chain Block
                -> Int
                -> Gen [ChainUpdate Block Block]
genChainUpdates _     0 = return []
genChainUpdates chain n = do
    update  <- genChainUpdate chain
    let Just chain' = Chain.applyChainUpdate update chain
    updates <- genChainUpdates chain' (n-1)
    return (update : updates)

prop_arbitrary_TestBlockChainAndUpdates :: TestBlockChainAndUpdates -> Property
prop_arbitrary_TestBlockChainAndUpdates (TestBlockChainAndUpdates c us) =
    cover 1.5 (     null us ) "empty updates"     $
    cover 95  (not (null us)) "non-empty updates" $
    tabulate "ChainUpdate" (map updateKind us) $
    tabulate "Growth" [hist (countChainUpdateNetProgress c us)] $

    Chain.valid c
 && case Chain.applyChainUpdates us c of
      Nothing -> False
      Just c' -> Chain.valid c'
  where
    hist n = show lower ++ " to " ++ show upper
      where
        lower = (n `div` 10)     * 10
        upper = (n `div` 10 + 1) * 10 - 1

    updateKind AddBlock{} = "AddBlock"
    updateKind RollBack{} = "RollBack"

-- | Count the number of blocks forward - the number of blocks backward.
--
countChainUpdateNetProgress :: HasHeader block
                            => Chain block
                            -> [ChainUpdate block block]
                            -> Int
countChainUpdateNetProgress = go 0
  where
    go n _c []     = n
    go n c  (u:us) = go n' c' us
      where
        Just c' = Chain.applyChainUpdate u c
        n'      = n + fromEnum (fromWithOrigin 0 (Chain.headBlockNo c'))
                    - fromEnum (fromWithOrigin 0 (Chain.headBlockNo c))


--
-- Generator for chain and single point on the chain
--

-- | A test generator for a chain and a points. In most cases the point is
-- on the chain, but it also covers at least 5% of cases where the point is
-- not on the chain.
--
data TestChainAndPoint = TestChainAndPoint (Chain Block) (Point Block)
  deriving Show

instance Arbitrary TestChainAndPoint where
  arbitrary = do
    TestBlockChain chain <- arbitrary
    -- either choose point from the chain or a few off the chain!
    point <- frequency [ (10, genPointOnChain chain), (1, arbitrary) ]
    return (TestChainAndPoint chain point)

  shrink (TestChainAndPoint c p) =
    [ TestChainAndPoint c' (if p `Chain.pointOnChain` c then fixupPoint c' p else p)
    | TestBlockChain c' <- shrink (TestBlockChain c) ]

genPointOnChain :: HasHeader block => Chain block -> Gen (Point block)
genPointOnChain chain =
    frequency
      [ (1, return (Chain.headPoint chain))
      , (1, return (mkRollbackPoint chain len))
      , (8, mkRollbackPoint chain <$> choose (1, len - 1))
      ]
  where
    len = Chain.length chain

fixupPoint :: HasHeader block => Chain block -> Point block -> Point block
fixupPoint c GenesisPoint         = Chain.headPoint c
fixupPoint c (BlockPoint bslot _) =
  case L.find ((== bslot) . blockSlot) (Chain.chainToList c) of
    Just b  -> Chain.blockPoint b
    Nothing -> Chain.headPoint c

prop_arbitrary_TestChainAndPoint :: TestChainAndPoint -> Property
prop_arbitrary_TestChainAndPoint (TestChainAndPoint c p) =
  let onChain = Chain.pointOnChain p c in
  cover  85 onChain       "point on chain" $
  cover   5 (not onChain) "point not on chain" $
    Chain.valid c

prop_shrink_TestChainAndPoint :: TestChainAndPoint -> Bool
prop_shrink_TestChainAndPoint cp@(TestChainAndPoint c _) =
  and [     Chain.valid c'
        && (Chain.pointOnChain p c `implies` Chain.pointOnChain p c')
      | TestChainAndPoint c' p <- shrink cp ]

implies :: Bool -> Bool -> Bool
a `implies` b = not a || b

infix 1 `implies`


--
-- Generator for chain and range on the chain
--

-- | A test generator for a chain and a range defined by a pair of points.
-- In most cases the range is on the chain, but it also covers at least 5% of
-- cases where the point is not on the chain.
--
data TestChainAndRange = TestChainAndRange (Chain Block) (Point Block) (Point Block)
  deriving Show

instance Arbitrary TestChainAndRange where
  arbitrary = do
    TestBlockChain chain <- arbitrary
    -- either choose range from the chain or a few off the chain!
    (point1, point2) <- frequency [ (10, genRangeOnChain chain)
                                  , (1, (,) <$> arbitrary <*> arbitrary) ]
    return (TestChainAndRange chain point1 point2)

  shrink (TestChainAndRange c p1 p2) =
    [ TestChainAndRange
        c'
        (if p1 `Chain.pointOnChain` c then fixupPoint c' p1 else p1)
        (if p2 `Chain.pointOnChain` c then fixupPoint c' p2 else p2)
    | TestBlockChain c' <- shrink (TestBlockChain c) ]

genRangeOnChain :: HasHeader block
                => Chain block
                -> Gen (Point block, Point block)
genRangeOnChain chain = do
    point1 <- genPointOnChain chain
    let Just point1Depth = (\c -> Chain.length chain - Chain.length c) <$>
                           Chain.rollback point1 chain
    point2 <- frequency $
        [ (1, return (Chain.headPoint chain))
        , (1, return (mkRollbackPoint chain point1Depth))
        , (8, mkRollbackPoint chain <$> choose (0, point1Depth))
        ]
    return (point1, point2)

prop_arbitrary_TestChainAndRange :: TestChainAndRange -> Property
prop_arbitrary_TestChainAndRange (TestChainAndRange c p1 p2) =
  let onChain = Chain.pointOnChain p1 c && Chain.pointOnChain p2 c in
  cover 85 onChain               "points on chain" $
  cover  5 (onChain && p1 == p2) "empty range" $
  cover  5 (not onChain)         "points not on chain" $
    Chain.valid c
 && onChain `implies` pointSlot p2 >= pointSlot p1

prop_shrink_TestChainAndRange :: TestChainAndRange -> Bool
prop_shrink_TestChainAndRange cp@(TestChainAndRange c _ _) =
  and [    Chain.valid c'
        && (Chain.pointOnChain p1 c && Chain.pointOnChain p2 c
            `implies`
            Chain.pointOnChain p1 c' && Chain.pointOnChain p2 c')
      | TestChainAndRange c' p1 p2 <- shrink cp ]


-- | A test generator for a chain and a list of points, some of which may not be
-- on the chain.  Only 50% of the blocks are selected, one fifth of selected
-- ones are not on the chain.  Points which come from the chain are given in the
-- newest to oldest order, but the intermediate points which are not in the
-- chain might break the order.
--
data TestChainAndPoints = TestChainAndPoints (Chain Block) [Point Block]
  deriving Show

instance Arbitrary TestChainAndPoints where
  arbitrary = do
    TestBlockChain chain <- arbitrary
    let fn p = frequency
          [ (4, return $ Just p)
          , (1, Just <$> arbitrary)
          , (5, return Nothing)
          ]
        points = map Chain.blockPoint (Chain.chainToList chain)
                  ++ [genesisPoint]
    points' <- catMaybes <$> mapM fn points
    return $ TestChainAndPoints chain points'

  shrink (TestChainAndPoints chain points) =
    [ TestChainAndPoints chain' points'
    | TestBlockChain chain' <- shrink (TestBlockChain chain)
      -- Leave only points that are on the @chain'@ or the ones that where not on the
      -- original @chain@.
    , let points' = filter (\p ->        p `Chain.pointOnChain` chain'
                                 || not (p `Chain.pointOnChain` chain)) points
    ] ++
    [ TestChainAndPoints chain points'
    | points' <- shrinkList shrinkNothing points
    ]

prop_arbitrary_TestChainAndPoints :: TestChainAndPoints -> Property
prop_arbitrary_TestChainAndPoints (TestChainAndPoints c ps) =
  cover 85 (any (`Chain.pointOnChain` c) ps)       "any points on chain"     $
  cover 65 (not (all (`Chain.pointOnChain` c) ps)) "not all points on chain" $
  cover 90 (not (null ps))                         "some points"             $
    Chain.valid c

prop_shrink_TestChainAndPoints :: TestChainAndPoints -> Bool
prop_shrink_TestChainAndPoints cps@(TestChainAndPoints c _) =
  -- can't really say much about the points without duplicating the logic above
  and [    Chain.valid c'
        && all (\p ->      p `Chain.pointOnChain` c'
                   || not (p `Chain.pointOnChain` c)) ps'
      | TestChainAndPoints c' ps' <- shrink cps ]


--
-- Generator for chain forks sharing a common prefix
--

-- | A test generator for two chains sharing a common prefix.
--
data TestChainFork = TestChainFork (Chain Block) -- common prefix
                                   (Chain Block) -- left fork
                                   (Chain Block) -- right fork

instance Show TestChainFork where
  show (TestChainFork c f1 f2)
    = let nl  = "\n    "
          nnl = "\n" ++ nl
      in "TestChainFork" ++ nl ++
      Chain.prettyPrintChain nl show c  ++ nnl ++
      Chain.prettyPrintChain nl show f1 ++ nnl ++
      Chain.prettyPrintChain nl show f2

instance Arbitrary TestChainFork where
  arbitrary = do
    TestBlockChain chain <- arbitrary
    -- at least 5% of forks should be equal
    equalChains <- frequency [(1, pure True), (19, pure False)]
    if equalChains
      then return (TestChainFork chain chain chain)
      else do
        l <- genNonNegative
        r <- genNonNegative
        chainL <- genAddBlocks l chain Nothing
        let exL = L.drop (Chain.length chain) (Chain.toOldestFirst chainL)
        chainR <- genAddBlocks r chain (listToMaybe exL)
        return (TestChainFork chain chainL chainR)

    where
      genAddBlocks :: Int
                   -> Chain Block
                   -> Maybe Block
                   -> Gen (Chain Block)
      genAddBlocks 0 c _       = return c
      genAddBlocks n c Nothing = do
          b <- genAddBlock c
          genAddBlocks (n-1) (Chain.addBlock b c) Nothing

      -- But we want to avoid the extensions starting off equal which would
      -- mean the longest common prefix was not the declared common prefix.
      -- So we optionally take the first block to avoid and use that in the
      -- second fork we generate.
      genAddBlocks n c (Just forbiddenBlock) = do
          b <- genAddBlock c `suchThat` (/= forbiddenBlock)
          genAddBlocks (n-1) (Chain.addBlock b c) Nothing


  shrink (TestChainFork common l r) =
        -- shrink the common prefix
      [ TestChainFork (fixupChain fixupBlock common')
                      (fixupChain fixupBlock (exl ++ common'))
                      (fixupChain fixupBlock (exr ++ common'))
      | let exl = extensionFragment common l
            exr = extensionFragment common r
      , common' <- shrinkList (const []) (Chain.toNewestFirst common)
      ]
        -- shrink the left fork
   ++ [ TestChainFork common l' r
      | let exl = extensionFragment common l
      , exl' <- shrinkList (const []) exl
      , let l' = fixupChain fixupBlock (exl' ++ Chain.toNewestFirst common)
      , isLongestCommonPrefix l' r
      ]
        -- shrink the right fork
   ++ [ TestChainFork common l r'
      | let exr = extensionFragment common r
      , exr' <- shrinkList (const []) exr
      , let r' = fixupChain fixupBlock (exr' ++ Chain.toNewestFirst common)
      , isLongestCommonPrefix l r'
      ]
    where
      extensionFragment :: Chain Block -> Chain Block -> [Block]
      extensionFragment c = reverse . L.drop (Chain.length c) . Chain.toOldestFirst

      -- Need to make sure that when we shrink that we don't make the longest
      -- common prefix be a strict extension of the original common prefix.
      isLongestCommonPrefix l' r' =
        case (L.drop (Chain.length common) (Chain.toOldestFirst l'),
              L.drop (Chain.length common) (Chain.toOldestFirst r')) of
          (lhead : _, rhead : _) -> lhead /= rhead
          _                      -> True


prop_arbitrary_TestChainFork :: TestChainFork -> Bool
prop_arbitrary_TestChainFork (TestChainFork c l r) =
    Chain.valid c && Chain.valid l && Chain.valid r
 && c `Chain.isPrefixOf` l
 && c `Chain.isPrefixOf` r
    -- And c is not just a common prefix, but the maximum common prefix
 && case (L.drop (Chain.length c) (Chain.toOldestFirst l),
          L.drop (Chain.length c) (Chain.toOldestFirst r)) of
      (lhead : _, rhead : _) -> lhead /= rhead
      _                      -> True


prop_shrink_TestChainFork :: TestChainFork -> Bool
prop_shrink_TestChainFork forks =
  and [    prop_arbitrary_TestChainFork forks'
        && measure forks' < mforks
      | let mforks = measure forks
      , forks' <- shrink forks ]
  where
    measure (TestChainFork c l r) = Chain.length c
                                  + Chain.length l
                                  + Chain.length r