Add deforestBlockTree

An important in-progress task is to make more test code
block-polymorphic; right now it is largely hardcoded to use test blocks
but this will not work for running conformance tests against live
implementations of the protocol.

We do not know the exact motivation behind making these tests monomorphic;
regardless it seems the only thing the tests require is the ability to
compute where a block is on the block tree.

Here we add a helper function to make generalize this by constructing a map
from each block hash in the tree to the `AnchoredFragment` from it to the
anchor. That fragment is a prefix of the trunk if and only if the block
is on the trunk.

The deforested block tree is used to check for block membership, and
to prevent its unnecessary regeneration many thousands of times per test,
it is implemented by adding a `DeforestedBlockTree` field to `BlockTree` to
cache it and a smart constructor that populates it correctly at definition time
and makes it possible to deconstruct a block tree into its trunk and branches
without giving access to the cached deforestation.

GHC's pattern match checker [assumes that any case expression involving
a pattern synonym is
incomplete](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/pragmas.html#complete-pragmas);
with either `-Wincomplete-patterns` or `-Wall`, GHC will report usage of
such patterns an incomplete pattern match like this:

```
    Pattern match(es) are non-exhaustive
    In an equation for ‘mkProperty’:
        Patterns of type ‘GenesisTestFull blk’,
                         ‘StateView blk’ not matched:
            (GenesisTest _ _ _ _ (Test.Consensus.BlockTree.RawBlockTree _ _ _)
             _ _ _ _ _ _ _)
            _
```

For this reason we add a `COMPLETE` pragma to let GHC know that `BlockTree` is
in fact a complete set of patterns for deconstructing a block tree.

Author: nbloomf

ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal

@@ -222,6 +222,7 @@ test-suite consensus-test
   main-is: Main.hs
   other-modules:
     Test.Consensus.BlockTree
+    Test.Consensus.BlockTree.Tests
     Test.Consensus.GSM
     Test.Consensus.Genesis.Setup
     Test.Consensus.Genesis.Setup.Classifiers

ouroboros-consensus-diffusion/test/consensus-test/Main.hs

@@ -1,5 +1,6 @@
 module Main (main) where
 
+import qualified Test.Consensus.BlockTree.Tests (tests)
 import qualified Test.Consensus.GSM (tests)
 import qualified Test.Consensus.Genesis.Tests (tests)
 import qualified Test.Consensus.HardFork.Combinator (tests)
@@ -33,4 +34,5 @@ tests =
     , Test.Consensus.PeerSimulator.Tests.tests
     , Test.Consensus.PointSchedule.Shrinking.Tests.tests
     , Test.Consensus.PointSchedule.Tests.tests
+    , Test.Consensus.BlockTree.Tests.tests
     ]

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/BlockTree.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 
 #if __GLASGOW_HASKELL__ >= 908
@@ -11,28 +11,40 @@
 -- duplication.
 
 module Test.Consensus.BlockTree
-  ( BlockTree (..)
+  ( BlockTree (BlockTree, btTrunk, btBranches)
   , BlockTreeBranch (..)
   , PathAnchoredAtSource (..)
   , addBranch
   , addBranch'
   , allFragments
+  , deforestBlockTree
   , findFragment
   , findPath
+  , isAncestorOf
+  , isStrictAncestorOf
   , mkTrunk
+  , nonemptyPrefixesOf
+  , onTrunk
   , prettyBlockTree
   ) where
 
-import Cardano.Slotting.Slot (SlotNo (unSlotNo))
-import Data.Foldable (asum)
+import Cardano.Slotting.Slot (SlotNo (unSlotNo), WithOrigin (..))
+import Data.Foldable (asum, fold)
 import Data.Function ((&))
 import Data.Functor ((<&>))
-import Data.List (sortOn)
+import Data.List (inits, sortOn)
+import qualified Data.Map.Strict as M
 import Data.Maybe (fromJust, fromMaybe)
 import Data.Ord (Down (Down))
 import qualified Data.Vector as Vector
 import Ouroboros.Consensus.Block.Abstract
-  ( blockNo
+  ( GetHeader (..)
+  , HasHeader
+  , Header
+  , HeaderHash
+  , Point
+  , blockHash
+  , blockNo
   , blockSlot
   , fromWithOrigin
   , pointSlot
@@ -72,17 +84,35 @@ data BlockTreeBranch blk = BlockTreeBranch
 -- INVARIANT: for all @BlockTreeBranch{..}@ in the tree, @btTrunk == fromJust $
 -- AF.join btbPrefix btbTrunkSuffix@.
 --
+-- INVARIANT: In @RawBlockTree trunk branches deforested@, we must have
+-- @deforested == deforestRawBlockTree trunk branches@.
+--
 -- REVIEW: Find another name so as not to clash with 'BlockTree' from
 -- `unstable-consensus-testlib/Test/Util/TestBlock.hs`.
-data BlockTree blk = BlockTree
-  { btTrunk :: AF.AnchoredFragment blk
-  , btBranches :: [BlockTreeBranch blk]
+data BlockTree blk = RawBlockTree
+  { btTrunk' :: AF.AnchoredFragment blk
+  , btBranches' :: [BlockTreeBranch blk]
+  , -- Cached deforestation of the block tree. This gets queried
+    -- many times and there's no reason to rebuild the tree every time.
+    btDeforested :: DeforestedBlockTree blk
   }
   deriving Show
 
+pattern BlockTree :: AF.AnchoredFragment blk -> [BlockTreeBranch blk] -> BlockTree blk
+pattern BlockTree{btTrunk, btBranches} <- RawBlockTree btTrunk btBranches _
+
+{-# COMPLETE BlockTree #-}
+
+deforestBlockTree :: BlockTree blk -> DeforestedBlockTree blk
+deforestBlockTree = btDeforested
+
+-- Smart constructor to cache the deforested block tree at creation time.
+mkBlockTree :: HasHeader blk => AF.AnchoredFragment blk -> [BlockTreeBranch blk] -> BlockTree blk
+mkBlockTree trunk branches = RawBlockTree trunk branches (deforestRawBlockTree trunk branches)
+
 -- | Make a block tree made of only a trunk.
-mkTrunk :: AF.AnchoredFragment blk -> BlockTree blk
-mkTrunk btTrunk = BlockTree{btTrunk, btBranches = []}
+mkTrunk :: HasHeader blk => AF.AnchoredFragment blk -> BlockTree blk
+mkTrunk btTrunk = mkBlockTree btTrunk []
 
 -- | Add a branch to an existing block tree.
 --
@@ -99,7 +129,7 @@ addBranch branch bt = do
   -- NOTE: We could use the monadic bind for @Maybe@ here but we would rather
   -- catch bugs quicker.
   let btbFull = fromJust $ AF.join btbPrefix btbSuffix
-  pure $ bt{btBranches = BlockTreeBranch{..} : btBranches bt}
+  pure $ mkBlockTree (btTrunk bt) (BlockTreeBranch{..} : btBranches bt)
 
 -- | Same as @addBranch@ but calls to 'error' if the former yields 'Nothing'.
 addBranch' :: AF.HasHeader blk => AF.AnchoredFragment blk -> BlockTree blk -> BlockTree blk
@@ -229,3 +259,79 @@ prettyBlockTree blockTree =
     case AF.anchor frag of
       AF.AnchorGenesis -> 0
       AF.Anchor slotNo _ _ -> slotNo + 1
+
+-- | An 'AF.AnchoredFragment' is a list where the last element (the anchor) is a ghost.
+-- Here they represent the partial ancestry of a block, where the anchor is either
+-- @Genesis@ (start of the chain, not itself an actual block) or the hash of a block.
+-- Say we have blocks B1 through B5 (each succeeded by the next) and anchor A. You
+-- can think of the chain as growing __from left to right__ like this:
+--
+-- >                    A :> B1 :> B2 :> B3 :> B4 :> B5
+--
+-- 'nonemptyPrefixesOf' builds the list of prefixes of an 'AF.AnchoredFragment' with at
+-- least one non-anchor entry. The name is a little confusing because the way we
+-- usually think of cons-lists these would be suffixes:
+--
+-- >            A :> B1     A :> B1 :> B2     A :> B1 :> B2 :> B3
+-- >      A :> B1 :> B2 :> B3 :> B4     A :> B1 :> B2 :> B3 :> B4 :> B5
+--
+-- However this is consistent with 'Ouroboros.Network.AnchoredSeq.isPrefixOf'.
+nonemptyPrefixesOf ::
+  AF.HasHeader blk => AF.AnchoredFragment blk -> [AF.AnchoredFragment blk]
+nonemptyPrefixesOf frag =
+  fmap (AF.fromOldestFirst (AF.anchor frag)) . drop 1 . inits . AF.toOldestFirst $ frag
+
+type DeforestedBlockTree blk = M.Map (HeaderHash blk) (AF.AnchoredFragment blk)
+
+deforestRawBlockTree ::
+  HasHeader blk =>
+  AF.AnchoredFragment blk ->
+  [BlockTreeBranch blk] ->
+  DeforestedBlockTree blk
+deforestRawBlockTree trunk branches =
+  let folder = foldMap $ \af -> either (const mempty) (flip M.singleton af . blockHash) $ AF.head af
+   in fold $
+        folder (prefixes (AF.Empty AF.AnchorGenesis) $ AF.toOldestFirst trunk)
+          : fmap (\btb -> folder $ prefixes (btbPrefix btb) $ AF.toOldestFirst $ btbSuffix btb) branches
+
+prefixes :: AF.HasHeader blk => AF.AnchoredFragment blk -> [blk] -> [AF.AnchoredFragment blk]
+prefixes = scanl (AF.:>)
+
+-- | A check used in some of the handlers, determining whether the first argument
+-- is on the chain that ends in the second argument.
+--
+-- REVIEW: Using 'AF.withinFragmentBounds' for this might be cheaper.
+--
+-- TODO: Unify with 'Test.Util.TestBlock.isAncestorOf' which basically does the
+-- same thing except not on 'WithOrigin'.
+isAncestorOf ::
+  (HasHeader blk, Eq blk) =>
+  BlockTree blk ->
+  WithOrigin blk ->
+  WithOrigin blk ->
+  Bool
+isAncestorOf tree (At ancestor) (At descendant) =
+  let deforested = btDeforested tree
+   in fromMaybe False $ do
+        afD <- M.lookup (blockHash descendant) deforested
+        afA <- M.lookup (blockHash ancestor) deforested
+        pure $ AF.isPrefixOf afA afD
+isAncestorOf _ (At _) Origin = False
+isAncestorOf _ Origin _ = True
+
+-- | Variant of 'isAncestorOf' that returns @False@ when the two blocks are
+-- equal.
+--
+-- TODO: Unify with 'Test.Util.TestBlock.isStrictAncestorOf' which basically does the
+-- same thing except not on 'WithOrigin'.
+isStrictAncestorOf ::
+  (HasHeader blk, Eq blk) =>
+  BlockTree blk ->
+  WithOrigin blk ->
+  WithOrigin blk ->
+  Bool
+isStrictAncestorOf bt b1 b2 = b1 /= b2 && isAncestorOf bt b1 b2
+
+-- | Check if a block (represented by its header 'Point') is on the 'BlockTree' trunk.
+onTrunk :: GetHeader blk => BlockTree blk -> Point (Header blk) -> Bool
+onTrunk blockTree = flip AF.withinFragmentBounds (AF.mapAnchoredFragment getHeader $ btTrunk blockTree)

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/BlockTree/Tests.hs

@@ -0,0 +1,173 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.Consensus.BlockTree.Tests (tests) where
+
+import Data.Function (on)
+import qualified Data.List as L
+import qualified Data.Map as M
+import Ouroboros.Consensus.Block.Abstract (HasHeader, HeaderHash)
+import qualified Ouroboros.Network.AnchoredFragment as AF
+import Ouroboros.Network.Block (blockHash)
+import Test.Consensus.BlockTree
+import Test.Consensus.Genesis.Setup.GenChains
+  ( GenesisTest (..)
+  , genChains
+  )
+import Test.QuickCheck
+import qualified Test.QuickCheck as QC
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.Util.TestBlock (TestBlock)
+
+genTestBlockTree :: QC.Gen Word -> QC.Gen (BlockTree TestBlock)
+genTestBlockTree = fmap gtBlockTree . genChains
+
+genTestAnchoredFragment :: QC.Gen (AF.AnchoredFragment TestBlock)
+genTestAnchoredFragment = fmap btTrunk $ genTestBlockTree (pure 0)
+
+tests :: TestTree
+tests =
+  let branchFactor = pure 4
+   in testGroup
+        "BlockTree"
+        [ testGroup
+            "nonemptyPrefixesOf"
+            [ testProperty "nonemptyPrefixesArePrefixes" $
+                forAll genTestAnchoredFragment $
+                  prop_nonemptyPrefixesOf_nonemptyPrefixesArePrefixes
+            , testProperty "nonemptyPrefixesAreNonempty" $
+                forAll genTestAnchoredFragment $
+                  prop_nonemptyPrefixesOf_nonemptyPrefixesAreNonempty
+            , testProperty "nonemptyPrefixesAreUnique" $
+                forAll genTestAnchoredFragment $
+                  prop_nonemptyPrefixesOf_nonemptyPrefixesAreUnique
+            , testProperty "allShareInputAnchor" $
+                forAll genTestAnchoredFragment $
+                  prop_nonemptyPrefixesOf_allShareInputAnchor
+            ]
+        , testGroup
+            "deforestBlockTree"
+            [ testProperty "headPointsAreDistinct" $
+                forAll (genTestBlockTree branchFactor) $
+                  prop_deforestBlockTree_headPointsAreDistinct
+            , testProperty "imagesAreNonempty" $
+                forAll (genTestBlockTree branchFactor) $
+                  prop_deforestBlockTree_imagesAreNonempty
+            , testProperty "allShareTrunkAnchor" $
+                forAll (genTestBlockTree branchFactor) $
+                  prop_deforestBlockTree_allShareTrunkAnchor
+            , testProperty "fullBranchesAreBranches" $
+                forAll (genTestBlockTree branchFactor) $
+                  prop_deforestBlockTree_fullBranchesAreBranches
+            , testProperty "everyHeaderHashIsInTheMap" $
+                forAll (genTestBlockTree branchFactor) $
+                  prop_deforestBlockTree_everyHeaderHashIsInTheMap
+            , testProperty "prefixMaximalPrefixesAreBranches" $
+                forAll (genTestBlockTree branchFactor) $
+                  prop_deforestBlockTree_prefixMaximalPrefixesAreBranches
+            ]
+        ]
+
+-- | The nonempty prefixes of an `AF.AnchoredFragment` are in fact prefixes.
+prop_nonemptyPrefixesOf_nonemptyPrefixesArePrefixes ::
+  (Eq blk, HasHeader blk) => AF.AnchoredFragment blk -> QC.Property
+prop_nonemptyPrefixesOf_nonemptyPrefixesArePrefixes fragment =
+  QC.property . all (flip AF.isPrefixOf fragment) . nonemptyPrefixesOf $ fragment
+
+-- | The nonempty prefixes of an `AF.AnchoredFragment` are in fact nonempty.
+prop_nonemptyPrefixesOf_nonemptyPrefixesAreNonempty ::
+  HasHeader blk => AF.AnchoredFragment blk -> QC.Property
+prop_nonemptyPrefixesOf_nonemptyPrefixesAreNonempty fragment =
+  QC.property . all (not . AF.null) . nonemptyPrefixesOf $ fragment
+
+-- | The nonempty prefixes of an `AF.AnchoredFragment` are unique.
+prop_nonemptyPrefixesOf_nonemptyPrefixesAreUnique ::
+  forall blk. HasHeader blk => AF.AnchoredFragment blk -> QC.Property
+prop_nonemptyPrefixesOf_nonemptyPrefixesAreUnique =
+  QC.property . noDuplicates . fmap (fmap blockHash . AF.toOldestFirst) . nonemptyPrefixesOf
+
+noDuplicates :: Ord a => [a] -> Bool
+noDuplicates =
+  let tally k = M.insertWith (+) k (1 :: Int)
+   in all (== 1) . M.elems . foldr tally mempty
+
+-- | All the nonempty prefixes should share the original fragment's anchor.
+prop_nonemptyPrefixesOf_allShareInputAnchor ::
+  HasHeader blk => AF.AnchoredFragment blk -> QC.Property
+prop_nonemptyPrefixesOf_allShareInputAnchor fragment =
+  let sharesTrunkAnchor = ((==) `on` AF.anchor) fragment
+   in QC.property . all sharesTrunkAnchor . nonemptyPrefixesOf $ fragment
+
+-- | The head points of all the branches are distinct.
+-- (Points uniquely determine positions in the tree.)
+prop_deforestBlockTree_headPointsAreDistinct ::
+  HasHeader blk => BlockTree blk -> QC.Property
+prop_deforestBlockTree_headPointsAreDistinct =
+  QC.property . noDuplicates . fmap AF.headPoint . M.elems . deforestBlockTree
+
+-- | The deforested branches are all populated.
+prop_deforestBlockTree_imagesAreNonempty ::
+  BlockTree blk -> QC.Property
+prop_deforestBlockTree_imagesAreNonempty =
+  QC.property . all (not . AF.null) . deforestBlockTree
+
+-- | All the deforested branches share the trunk's anchor.
+prop_deforestBlockTree_allShareTrunkAnchor ::
+  HasHeader blk => BlockTree blk -> QC.Property
+prop_deforestBlockTree_allShareTrunkAnchor tree =
+  let sharesTrunkAnchor = ((==) `on` AF.anchor) (btTrunk tree)
+   in QC.property . all sharesTrunkAnchor . deforestBlockTree $ tree
+
+-- | Full branches are in the deforestation.
+prop_deforestBlockTree_fullBranchesAreBranches ::
+  (Eq blk, HasHeader blk) => BlockTree blk -> QC.Property
+prop_deforestBlockTree_fullBranchesAreBranches tree =
+  let inDeforestation = flip elem (deforestBlockTree tree)
+   in QC.property . all inDeforestation . fmap btbFull . btBranches $ tree
+
+-- | Every block header from the `BlockTree` is in the deforestation map.
+prop_deforestBlockTree_everyHeaderHashIsInTheMap ::
+  forall blk. HasHeader blk => BlockTree blk -> QC.Property
+prop_deforestBlockTree_everyHeaderHashIsInTheMap tree@(BlockTree trunk branches) =
+  let
+    allBranchHeaderHashes :: BlockTreeBranch blk -> [HeaderHash blk]
+    allBranchHeaderHashes (BlockTreeBranch prefix suffix restOfTrunk full) =
+      fmap blockHash $ concatMap AF.toOldestFirst [prefix, suffix, restOfTrunk, full]
+
+    allHeaderHashes :: [HeaderHash blk]
+    allHeaderHashes =
+      fmap blockHash (AF.toOldestFirst trunk)
+        <> concatMap allBranchHeaderHashes branches
+   in
+    QC.property $ all (flip M.member $ deforestBlockTree tree) allHeaderHashes
+
+-- | An `AF.AnchoredFragment` is /prefix maximal/ in a list if it is not a nontrivial
+-- prefix of another fragment in the list. After deforesting a tree, the maximal
+-- prefixes in the result are precisely the trunk and branches of the tree in
+-- some order.
+prop_deforestBlockTree_prefixMaximalPrefixesAreBranches ::
+  forall blk. (Ord blk, HasHeader blk) => BlockTree blk -> QC.Property
+prop_deforestBlockTree_prefixMaximalPrefixesAreBranches tree@(BlockTree trunk branches) =
+  QC.property $
+    ((==) `on` (L.sort . fmap AF.toOldestFirst))
+      (foldr (insertIfMaximalBy AF.isPrefixOf) [] $ deforestBlockTree tree)
+      (trunk : fmap btbFull branches)
+
+-- | If @u@ is smaller than any of the elements of @xs@, return @xs@.
+-- Otherwise, remove any elements of @xs@ smaller than @u@ and append @u@ to
+-- the remainder on the right.
+insertIfMaximalBy :: forall u. (u -> u -> Bool) -> u -> [u] -> [u]
+insertIfMaximalBy lessThan u =
+  let
+    go xs = case xs of
+      [] -> [u]
+      x : rest -> case x `lessThan` u of
+        True -> go rest
+        False ->
+          x
+            : case u `lessThan` x of
+              True -> rest
+              False -> go rest
+   in
+    go