{-# LANGUAGE NamedFieldPuns #-}

-- | Helpers to access particular parts of trees and schedules
-- Those functions are partial, and are designed to only be used in tests.
-- We know they won't fail there, because we generated the structures
-- with the correct properties.
module Test.Util.PartialAccessors (
    getHonestPeer
  , getOnlyBranch
  , getOnlyBranchTip
  , getTrunkTip
  ) where

import qualified Data.Map as Map
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (HasHeader)
import           Test.Consensus.BlockTree

getOnlyBranch :: BlockTree blk -> BlockTreeBranch blk
getOnlyBranch :: forall blk. BlockTree blk -> BlockTreeBranch blk
getOnlyBranch BlockTree {[BlockTreeBranch blk]
btBranches :: [BlockTreeBranch blk]
btBranches :: forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches} = case [BlockTreeBranch blk]
btBranches of
  [BlockTreeBranch blk
branch] -> BlockTreeBranch blk
branch
  [BlockTreeBranch blk]
_        -> [Char] -> BlockTreeBranch blk
forall a. HasCallStack => [Char] -> a
error [Char]
"tree must have exactly one alternate branch"

getTrunkTip :: HasHeader blk => BlockTree blk -> blk
getTrunkTip :: forall blk. HasHeader blk => BlockTree blk -> blk
getTrunkTip BlockTree blk
tree = case BlockTree blk -> AnchoredFragment blk
forall blk. BlockTree blk -> AnchoredFragment blk
btTrunk BlockTree blk
tree of
  (AF.Empty Anchor blk
_)       -> [Char] -> blk
forall a. HasCallStack => [Char] -> a
error [Char]
"tree must have at least one block"
  (AnchoredFragment blk
_ AF.:> blk
tipBlock) -> blk
tipBlock

getOnlyBranchTip :: HasHeader blk => BlockTree blk -> blk
getOnlyBranchTip :: forall blk. HasHeader blk => BlockTree blk -> blk
getOnlyBranchTip BlockTree {[BlockTreeBranch blk]
btBranches :: forall blk. BlockTree blk -> [BlockTreeBranch blk]
btBranches :: [BlockTreeBranch blk]
btBranches} = case [BlockTreeBranch blk]
btBranches of
  [BlockTreeBranch blk
branch] -> case BlockTreeBranch blk -> AnchoredFragment blk
forall blk. BlockTreeBranch blk -> AnchoredFragment blk
btbFull BlockTreeBranch blk
branch of
    (AF.Empty Anchor blk
_)       -> [Char] -> blk
forall a. HasCallStack => [Char] -> a
error [Char]
"alternate branch must have at least one block"
    (AnchoredFragment blk
_ AF.:> blk
tipBlock) -> blk
tipBlock
  [BlockTreeBranch blk]
_ -> [Char] -> blk
forall a. HasCallStack => [Char] -> a
error [Char]
"tree must have exactly one alternate branch"

getHonestPeer :: Map.Map Int a -> a
getHonestPeer :: forall a. Map Int a -> a
getHonestPeer Map Int a
honests =
  if Map Int a -> Int
forall k a. Map k a -> Int
Map.size Map Int a
honests Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
    then [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"there must be exactly one honest peer"
    else case Int -> Map Int a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
1 Map Int a
honests of
      Maybe a
Nothing -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"the only honest peer must have id 1"
      Just a
p  -> a
p