{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- | Utility functions on anchored fragments
--
-- Intended for qualified import
-- > import qualified Ouroboros.Consensus.Util.AnchoredFragment as AF
module Ouroboros.Consensus.Util.AnchoredFragment
  ( compareAnchoredFragments
  , compareHeadBlockNo
  , cross
  , forksAtMostKWeight
  , preferAnchoredCandidate
  , stripCommonPrefix
  , ReasonForSwitch'
  ) where

import Cardano.Slotting.Slot (WithOrigin (At))
import Control.Monad.Except (throwError)
import Data.Foldable (toList)
import qualified Data.Foldable1 as F1
import Data.Function (on)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)
import GHC.Stack
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Peras.SelectView
import Ouroboros.Consensus.Peras.Weight
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Util.Assert
import Ouroboros.Network.AnchoredFragment
  ( AnchoredFragment
  , AnchoredSeq (Empty, (:>))
  )
import qualified Ouroboros.Network.AnchoredFragment as AF

{-------------------------------------------------------------------------------
  Utility functions on anchored fragments
-------------------------------------------------------------------------------}

-- | Compare the 'headBlockNo', which is a measure of the length of the chain,
-- of two anchored fragments.
--
-- A fragment with a head is always \"greater\" than one without. When both
-- fragments have no head (i.e. are empty), they are 'EQ'.
--
-- Note that an EBB can share its @BlockNo@ with another regular block. If
-- such an EBB is the head of one fragment and the regular block with the same
-- @BlockNo@ is the head of the other fragment, then this function will say
-- they are 'EQ', while in fact one fragment should be preferred over the
-- other.
--
-- This is not a big deal as we won't be seeing new EBBs, so they will not be
-- the head of a fragment very often anyway, only when catching up. As soon as
-- a new block/header is added to the fragment, the right decision will be
-- made again ('GT' or 'LT').
compareHeadBlockNo ::
  HasHeader b =>
  AnchoredFragment b ->
  AnchoredFragment b ->
  Ordering
compareHeadBlockNo :: forall b.
HasHeader b =>
AnchoredFragment b -> AnchoredFragment b -> Ordering
compareHeadBlockNo = WithOrigin BlockNo -> WithOrigin BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (WithOrigin BlockNo -> WithOrigin BlockNo -> Ordering)
-> (AnchoredFragment b -> WithOrigin BlockNo)
-> AnchoredFragment b
-> AnchoredFragment b
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` AnchoredFragment b -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo

-- | Check that we can switch from @ours@ to @theirs@ by rolling back our chain
-- by at most @k@ weight.
--
-- If @ours@ and @cand@ do not intersect, this returns 'False'. If they do
-- intersect, then we check that the suffix of @ours@ after the intersection has
-- total weight at most @k@.
forksAtMostKWeight ::
  ( StandardHash blk
  , HasHeader b
  , HeaderHash blk ~ HeaderHash b
  ) =>
  PerasWeightSnapshot blk ->
  -- | By how much weight can we roll back our chain at most?
  PerasWeight ->
  -- | Our chain @ours@.
  AnchoredFragment b ->
  -- | Their chain @theirs@.
  AnchoredFragment b ->
  -- | Indicates whether their chain forks at most the given the amount of
  -- weight. Returns 'False' if the two fragments do not intersect.
  Bool
forksAtMostKWeight :: forall blk b.
(StandardHash blk, HasHeader b, HeaderHash blk ~ HeaderHash b) =>
PerasWeightSnapshot blk
-> PerasWeight -> AnchoredFragment b -> AnchoredFragment b -> Bool
forksAtMostKWeight PerasWeightSnapshot blk
weights PerasWeight
maxWeight AnchoredFragment b
ours AnchoredFragment b
theirs =
  case AnchoredFragment b
ours AnchoredFragment b
-> AnchoredFragment b
-> Maybe
     (AnchoredFragment b, AnchoredFragment b, AnchoredFragment b,
      AnchoredFragment b)
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2
-> Maybe
     (AnchoredFragment block1, AnchoredFragment block2,
      AnchoredFragment block1, AnchoredFragment block2)
`AF.intersect` AnchoredFragment b
theirs of
    Maybe
  (AnchoredFragment b, AnchoredFragment b, AnchoredFragment b,
   AnchoredFragment b)
Nothing -> Bool
False
    Just (AnchoredFragment b
_, AnchoredFragment b
_, AnchoredFragment b
ourSuffix, AnchoredFragment b
_) ->
      PerasWeightSnapshot blk -> AnchoredFragment b -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
totalWeightOfFragment PerasWeightSnapshot blk
weights AnchoredFragment b
ourSuffix PerasWeight -> PerasWeight -> Bool
forall a. Ord a => a -> a -> Bool
<= PerasWeight
maxWeight

-- | Compare two (potentially empty!) 'AnchoredFragment's.
--
-- PRECONDITION: The fragments must intersect.
--
-- Usage note: the primary user of this function is the chain database when
-- sorting fragments that are preferred over our selection. It establishes the
-- precondition in the following way: It will only compare candidate fragments
-- that it has previously verified are preferable to our current chain. Since
-- these fragments intersect with our current chain, we can enlarge them to all
-- be anchored in the immutable tip. Therefore, they intersect pairwise.
compareAnchoredFragments ::
  forall blk h.
  ( BlockSupportsProtocol blk
  , HasCallStack
  , GetHeader1 h
  , HasHeader (h blk)
  , HeaderHash (h blk) ~ HeaderHash blk
  ) =>
  BlockConfig blk ->
  PerasWeightSnapshot blk ->
  AnchoredFragment (h blk) ->
  AnchoredFragment (h blk) ->
  Ordering
compareAnchoredFragments :: forall blk (h :: * -> *).
(BlockSupportsProtocol blk, HasCallStack, GetHeader1 h,
 HasHeader (h blk), HeaderHash (h blk) ~ HeaderHash blk) =>
BlockConfig blk
-> PerasWeightSnapshot blk
-> AnchoredFragment (h blk)
-> AnchoredFragment (h blk)
-> Ordering
compareAnchoredFragments BlockConfig blk
cfg PerasWeightSnapshot blk
weights AnchoredFragment (h blk)
frag1 AnchoredFragment (h blk)
frag2
  -- Optimize the case where Peras is disabled.
  | PerasWeightSnapshot blk -> Bool
forall blk. PerasWeightSnapshot blk -> Bool
isEmptyPerasWeightSnapshot PerasWeightSnapshot blk
weights =
      Either String () -> Ordering -> Ordering
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (AnchoredFragment (h blk)
-> AnchoredFragment (h blk) -> Either String ()
forall (h :: * -> *) blk (h' :: * -> *).
(HeaderHash (h blk) ~ HeaderHash (h' blk), HasHeader (h blk),
 HasHeader (h' blk)) =>
AnchoredFragment (h blk)
-> AnchoredFragment (h' blk) -> Either String ()
precondition AnchoredFragment (h blk)
frag1 AnchoredFragment (h blk)
frag2) (Ordering -> Ordering) -> Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$
        case (AnchoredFragment (h blk)
frag1, AnchoredFragment (h blk)
frag2) of
          (Empty Anchor (h blk)
_, Empty Anchor (h blk)
_) ->
            -- The fragments intersect but are equal: their anchors must be equal,
            -- and hence the fragments represent the same chain. They are therefore
            -- equally preferable.
            Ordering
EQ
          (Empty Anchor (h blk)
anchor, AnchoredFragment (h blk)
_ :> h blk
tip') ->
            -- Since the fragments intersect, but the first one is empty, its anchor
            -- must lie somewhere along the the second. If it is the tip, the two
            -- fragments represent the same chain and are equally preferable. If
            -- not, the second chain is a strict extension of the first and is
            -- therefore strictly preferable.
            if h blk -> Point (h blk)
forall block. HasHeader block => block -> Point block
blockPoint h blk
tip' Point (h blk) -> Point (h blk) -> Bool
forall a. Eq a => a -> a -> Bool
== Point (h blk) -> Point (h blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
AF.castPoint (Anchor (h blk) -> Point (h blk)
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor (h blk)
anchor)
              then Ordering
EQ
              else Ordering
LT
          (AnchoredFragment (h blk)
_ :> h blk
tip, Empty Anchor (h blk)
anchor') ->
            -- This case is symmetric to the previous
            if h blk -> Point (h blk)
forall block. HasHeader block => block -> Point block
blockPoint h blk
tip Point (h blk) -> Point (h blk) -> Bool
forall a. Eq a => a -> a -> Bool
== Point (h blk) -> Point (h blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
AF.castPoint (Anchor (h blk) -> Point (h blk)
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor (h blk)
anchor')
              then Ordering
EQ
              else Ordering
GT
          (AnchoredFragment (h blk)
_ :> h blk
tip, AnchoredFragment (h blk)
_ :> h blk
tip') ->
            -- Case 4
            SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
              (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
cfg (h blk -> Header blk
forall blk. h blk -> Header blk
forall (t :: * -> *) blk. GetHeader1 t => t blk -> Header blk
getHeader1 h blk
tip))
              (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
cfg (h blk -> Header blk
forall blk. h blk -> Header blk
forall (t :: * -> *) blk. GetHeader1 t => t blk -> Header blk
getHeader1 h blk
tip'))
  | Bool
otherwise =
      case AnchoredFragment (h blk)
-> AnchoredFragment (h blk)
-> Maybe
     (AnchoredFragment (h blk), AnchoredFragment (h blk),
      AnchoredFragment (h blk), AnchoredFragment (h blk))
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2
-> Maybe
     (AnchoredFragment block1, AnchoredFragment block2,
      AnchoredFragment block1, AnchoredFragment block2)
AF.intersect AnchoredFragment (h blk)
frag1 AnchoredFragment (h blk)
frag2 of
        Maybe
  (AnchoredFragment (h blk), AnchoredFragment (h blk),
   AnchoredFragment (h blk), AnchoredFragment (h blk))
Nothing -> String -> Ordering
forall a. HasCallStack => String -> a
error String
"precondition violated: fragments must intersect"
        Just (AnchoredFragment (h blk)
_oursPrefix, AnchoredFragment (h blk)
_candPrefix, AnchoredFragment (h blk)
oursSuffix, AnchoredFragment (h blk)
candSuffix) ->
          WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
-> Ordering
forall a. Ord a => a -> a -> Ordering
compare
            (BlockConfig blk
-> PerasWeightSnapshot blk
-> AnchoredFragment (h blk)
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
forall (h :: * -> *) blk.
(GetHeader1 h, HasHeader (h blk),
 HeaderHash blk ~ HeaderHash (h blk), BlockSupportsProtocol blk) =>
BlockConfig blk
-> PerasWeightSnapshot blk
-> AnchoredFragment (h blk)
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
weightedSelectView BlockConfig blk
cfg PerasWeightSnapshot blk
weights AnchoredFragment (h blk)
oursSuffix)
            (BlockConfig blk
-> PerasWeightSnapshot blk
-> AnchoredFragment (h blk)
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
forall (h :: * -> *) blk.
(GetHeader1 h, HasHeader (h blk),
 HeaderHash blk ~ HeaderHash (h blk), BlockSupportsProtocol blk) =>
BlockConfig blk
-> PerasWeightSnapshot blk
-> AnchoredFragment (h blk)
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
weightedSelectView BlockConfig blk
cfg PerasWeightSnapshot blk
weights AnchoredFragment (h blk)
candSuffix)

-- | The combination of the reasons for switching when using Peras or not
type ReasonForSwitch' blk =
  Either
    (ReasonForSwitch (WithEmptyFragment (WeightedSelectView (BlockProtocol blk))))
    (ReasonForSwitch (SelectView (BlockProtocol blk)))

-- | Lift 'preferCandidate' to 'AnchoredFragment'
--
-- PRECONDITION: The fragments must intersect.
--
-- Usage note: the primary user of this function is the chain database. It
-- establishes the precondition when comparing a candidate fragment to our
-- current chain in the following way: The fragment is guaranteed (by the chain
-- sync client) to intersect with our chain (indeed, within at most @k@ blocks
-- from our tip, although the exact distance does not matter for
-- 'compareAnchoredFragments').
preferAnchoredCandidate ::
  forall blk h h'.
  ( BlockSupportsProtocol blk
  , HasCallStack
  , GetHeader1 h
  , GetHeader1 h'
  , HeaderHash (h blk) ~ HeaderHash blk
  , HeaderHash (h blk) ~ HeaderHash (h' blk)
  , HasHeader (h blk)
  , HasHeader (h' blk)
  ) =>
  BlockConfig blk ->
  -- | Peras weights used to judge this chain.
  PerasWeightSnapshot blk ->
  -- | Our chain
  AnchoredFragment (h blk) ->
  -- | Candidate
  AnchoredFragment (h' blk) ->
  ShouldSwitch (ReasonForSwitch' blk)
preferAnchoredCandidate :: forall blk (h :: * -> *) (h' :: * -> *).
(BlockSupportsProtocol blk, HasCallStack, GetHeader1 h,
 GetHeader1 h', HeaderHash (h blk) ~ HeaderHash blk,
 HeaderHash (h blk) ~ HeaderHash (h' blk), HasHeader (h blk),
 HasHeader (h' blk)) =>
BlockConfig blk
-> PerasWeightSnapshot blk
-> AnchoredFragment (h blk)
-> AnchoredFragment (h' blk)
-> ShouldSwitch (ReasonForSwitch' blk)
preferAnchoredCandidate BlockConfig blk
cfg PerasWeightSnapshot blk
weights AnchoredFragment (h blk)
ours AnchoredFragment (h' blk)
cand
  | PerasWeightSnapshot blk -> Bool
forall blk. PerasWeightSnapshot blk -> Bool
isEmptyPerasWeightSnapshot PerasWeightSnapshot blk
weights =
      Either String ()
-> ShouldSwitch (ReasonForSwitch' blk)
-> ShouldSwitch (ReasonForSwitch' blk)
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (AnchoredFragment (h blk)
-> AnchoredFragment (h' blk) -> Either String ()
forall (h :: * -> *) blk (h' :: * -> *).
(HeaderHash (h blk) ~ HeaderHash (h' blk), HasHeader (h blk),
 HasHeader (h' blk)) =>
AnchoredFragment (h blk)
-> AnchoredFragment (h' blk) -> Either String ()
precondition AnchoredFragment (h blk)
ours AnchoredFragment (h' blk)
cand) (ShouldSwitch (ReasonForSwitch' blk)
 -> ShouldSwitch (ReasonForSwitch' blk))
-> ShouldSwitch (ReasonForSwitch' blk)
-> ShouldSwitch (ReasonForSwitch' blk)
forall a b. (a -> b) -> a -> b
$
        case (AnchoredFragment (h blk)
ours, AnchoredFragment (h' blk)
cand) of
          (Empty Anchor (h blk)
_, Empty Anchor (h' blk)
_) -> Ordering
-> ShouldSwitch
     (Either
        (WithEmptyFragmentReasonForSwitch
           (WeightedSelectView (BlockProtocol blk)))
        (SelectViewReasonForSwitch (BlockProtocol blk)))
forall reason. Ordering -> ShouldSwitch reason
ShouldNotSwitch Ordering
EQ
          (AnchoredFragment (h blk)
_, Empty Anchor (h' blk)
_) -> Ordering
-> ShouldSwitch
     (Either
        (WithEmptyFragmentReasonForSwitch
           (WeightedSelectView (BlockProtocol blk)))
        (SelectViewReasonForSwitch (BlockProtocol blk)))
forall reason. Ordering -> ShouldSwitch reason
ShouldNotSwitch Ordering
GT
          (Empty Anchor (h blk)
ourAnchor, AnchoredFragment (h' blk)
_ :> h' blk
theirTip) ->
            if h' blk -> Point (h' blk)
forall block. HasHeader block => block -> Point block
blockPoint h' blk
theirTip Point (h' blk) -> Point (h' blk) -> Bool
forall a. Eq a => a -> a -> Bool
/= Point (h blk) -> Point (h' blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Anchor (h blk) -> Point (h blk)
forall block. Anchor block -> Point block
AF.anchorToPoint Anchor (h blk)
ourAnchor)
              then
                Either
  (WithEmptyFragmentReasonForSwitch
     (WeightedSelectView (BlockProtocol blk)))
  (SelectViewReasonForSwitch (BlockProtocol blk))
-> ShouldSwitch
     (Either
        (WithEmptyFragmentReasonForSwitch
           (WeightedSelectView (BlockProtocol blk)))
        (SelectViewReasonForSwitch (BlockProtocol blk)))
forall reason. reason -> ShouldSwitch reason
ShouldSwitch (SelectViewReasonForSwitch (BlockProtocol blk)
-> Either
     (WithEmptyFragmentReasonForSwitch
        (WeightedSelectView (BlockProtocol blk)))
     (SelectViewReasonForSwitch (BlockProtocol blk))
forall a b. b -> Either a b
Right (SelectViewReasonForSwitch (BlockProtocol blk)
 -> Either
      (WithEmptyFragmentReasonForSwitch
         (WeightedSelectView (BlockProtocol blk)))
      (SelectViewReasonForSwitch (BlockProtocol blk)))
-> SelectViewReasonForSwitch (BlockProtocol blk)
-> Either
     (WithEmptyFragmentReasonForSwitch
        (WeightedSelectView (BlockProtocol blk)))
     (SelectViewReasonForSwitch (BlockProtocol blk))
forall a b. (a -> b) -> a -> b
$ Comparing (WithOrigin BlockNo)
-> SelectViewReasonForSwitch (BlockProtocol blk)
forall p.
Comparing (WithOrigin BlockNo) -> SelectViewReasonForSwitch p
Longer (Comparing (WithOrigin BlockNo)
 -> SelectViewReasonForSwitch (BlockProtocol blk))
-> Comparing (WithOrigin BlockNo)
-> SelectViewReasonForSwitch (BlockProtocol blk)
forall a b. (a -> b) -> a -> b
$ WithOrigin BlockNo
-> WithOrigin BlockNo -> Comparing (WithOrigin BlockNo)
forall a. a -> a -> Comparing a
Comparing (Anchor (h blk) -> WithOrigin BlockNo
forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor (h blk)
ourAnchor) (BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At (h' blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo h' blk
theirTip)))
              else Ordering
-> ShouldSwitch
     (Either
        (WithEmptyFragmentReasonForSwitch
           (WeightedSelectView (BlockProtocol blk)))
        (SelectViewReasonForSwitch (BlockProtocol blk)))
forall reason. Ordering -> ShouldSwitch reason
ShouldNotSwitch Ordering
EQ
          (AnchoredFragment (h blk)
_ :> h blk
ourTip, AnchoredFragment (h' blk)
_ :> h' blk
theirTip) ->
            case ChainOrderConfig (SelectView (BlockProtocol blk))
-> SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk)
-> ShouldSwitch (ReasonForSwitch (SelectView (BlockProtocol blk)))
forall sv.
ChainOrder sv =>
ChainOrderConfig sv
-> sv -> sv -> ShouldSwitch (ReasonForSwitch sv)
preferCandidate
              (BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
projectChainOrderConfig BlockConfig blk
cfg)
              (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
cfg (h blk -> Header blk
forall blk. h blk -> Header blk
forall (t :: * -> *) blk. GetHeader1 t => t blk -> Header blk
getHeader1 h blk
ourTip))
              (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
cfg (h' blk -> Header blk
forall blk. h' blk -> Header blk
forall (t :: * -> *) blk. GetHeader1 t => t blk -> Header blk
getHeader1 h' blk
theirTip)) of
              ShouldSwitch ReasonForSwitch (SelectView (BlockProtocol blk))
r -> Either
  (WithEmptyFragmentReasonForSwitch
     (WeightedSelectView (BlockProtocol blk)))
  (SelectViewReasonForSwitch (BlockProtocol blk))
-> ShouldSwitch
     (Either
        (WithEmptyFragmentReasonForSwitch
           (WeightedSelectView (BlockProtocol blk)))
        (SelectViewReasonForSwitch (BlockProtocol blk)))
forall reason. reason -> ShouldSwitch reason
ShouldSwitch (SelectViewReasonForSwitch (BlockProtocol blk)
-> Either
     (WithEmptyFragmentReasonForSwitch
        (WeightedSelectView (BlockProtocol blk)))
     (SelectViewReasonForSwitch (BlockProtocol blk))
forall a b. b -> Either a b
Right SelectViewReasonForSwitch (BlockProtocol blk)
ReasonForSwitch (SelectView (BlockProtocol blk))
r)
              ShouldNotSwitch Ordering
o -> Ordering
-> ShouldSwitch
     (Either
        (WithEmptyFragmentReasonForSwitch
           (WeightedSelectView (BlockProtocol blk)))
        (SelectViewReasonForSwitch (BlockProtocol blk)))
forall reason. Ordering -> ShouldSwitch reason
ShouldNotSwitch Ordering
o
  | Bool
otherwise =
      case AnchoredFragment (h blk)
-> AnchoredFragment (h' blk)
-> Maybe
     (AnchoredFragment (h blk), AnchoredFragment (h' blk),
      AnchoredFragment (h blk), AnchoredFragment (h' blk))
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2
-> Maybe
     (AnchoredFragment block1, AnchoredFragment block2,
      AnchoredFragment block1, AnchoredFragment block2)
AF.intersect AnchoredFragment (h blk)
ours AnchoredFragment (h' blk)
cand of
        Maybe
  (AnchoredFragment (h blk), AnchoredFragment (h' blk),
   AnchoredFragment (h blk), AnchoredFragment (h' blk))
Nothing -> String
-> ShouldSwitch
     (Either
        (WithEmptyFragmentReasonForSwitch
           (WeightedSelectView (BlockProtocol blk)))
        (SelectViewReasonForSwitch (BlockProtocol blk)))
forall a. HasCallStack => String -> a
error String
"precondition violated: fragments must intersect"
        Just (AnchoredFragment (h blk)
_oursPrefix, AnchoredFragment (h' blk)
_candPrefix, AnchoredFragment (h blk)
oursSuffix, AnchoredFragment (h' blk)
candSuffix) ->
          case ChainOrderConfig
  (WithEmptyFragment (WeightedSelectView (BlockProtocol blk)))
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
-> ShouldSwitch
     (ReasonForSwitch
        (WithEmptyFragment (WeightedSelectView (BlockProtocol blk))))
forall sv.
ChainOrder sv =>
ChainOrderConfig sv
-> sv -> sv -> ShouldSwitch (ReasonForSwitch sv)
preferCandidate
            (BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
projectChainOrderConfig BlockConfig blk
cfg)
            (BlockConfig blk
-> PerasWeightSnapshot blk
-> AnchoredFragment (h blk)
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
forall (h :: * -> *) blk.
(GetHeader1 h, HasHeader (h blk),
 HeaderHash blk ~ HeaderHash (h blk), BlockSupportsProtocol blk) =>
BlockConfig blk
-> PerasWeightSnapshot blk
-> AnchoredFragment (h blk)
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
weightedSelectView BlockConfig blk
cfg PerasWeightSnapshot blk
weights AnchoredFragment (h blk)
oursSuffix)
            (BlockConfig blk
-> PerasWeightSnapshot blk
-> AnchoredFragment (h' blk)
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
forall (h :: * -> *) blk.
(GetHeader1 h, HasHeader (h blk),
 HeaderHash blk ~ HeaderHash (h blk), BlockSupportsProtocol blk) =>
BlockConfig blk
-> PerasWeightSnapshot blk
-> AnchoredFragment (h blk)
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
weightedSelectView BlockConfig blk
cfg PerasWeightSnapshot blk
weights AnchoredFragment (h' blk)
candSuffix) of
            ShouldSwitch ReasonForSwitch
  (WithEmptyFragment (WeightedSelectView (BlockProtocol blk)))
r -> Either
  (WithEmptyFragmentReasonForSwitch
     (WeightedSelectView (BlockProtocol blk)))
  (SelectViewReasonForSwitch (BlockProtocol blk))
-> ShouldSwitch
     (Either
        (WithEmptyFragmentReasonForSwitch
           (WeightedSelectView (BlockProtocol blk)))
        (SelectViewReasonForSwitch (BlockProtocol blk)))
forall reason. reason -> ShouldSwitch reason
ShouldSwitch (WithEmptyFragmentReasonForSwitch
  (WeightedSelectView (BlockProtocol blk))
-> Either
     (WithEmptyFragmentReasonForSwitch
        (WeightedSelectView (BlockProtocol blk)))
     (SelectViewReasonForSwitch (BlockProtocol blk))
forall a b. a -> Either a b
Left ReasonForSwitch
  (WithEmptyFragment (WeightedSelectView (BlockProtocol blk)))
WithEmptyFragmentReasonForSwitch
  (WeightedSelectView (BlockProtocol blk))
r)
            ShouldNotSwitch Ordering
o -> Ordering
-> ShouldSwitch
     (Either
        (WithEmptyFragmentReasonForSwitch
           (WeightedSelectView (BlockProtocol blk)))
        (SelectViewReasonForSwitch (BlockProtocol blk)))
forall reason. Ordering -> ShouldSwitch reason
ShouldNotSwitch Ordering
o

-- For 'compareAnchoredFragment' and 'preferAnchoredCandidate'.
precondition ::
  ( HeaderHash (h blk) ~ HeaderHash (h' blk)
  , HasHeader (h blk)
  , HasHeader (h' blk)
  ) =>
  AnchoredFragment (h blk) ->
  AnchoredFragment (h' blk) ->
  Either String ()
precondition :: forall (h :: * -> *) blk (h' :: * -> *).
(HeaderHash (h blk) ~ HeaderHash (h' blk), HasHeader (h blk),
 HasHeader (h' blk)) =>
AnchoredFragment (h blk)
-> AnchoredFragment (h' blk) -> Either String ()
precondition AnchoredFragment (h blk)
frag1 AnchoredFragment (h' blk)
frag2
  | Maybe (Point (h blk)) -> Bool
forall a. Maybe a -> Bool
isJust (AnchoredFragment (h blk)
-> AnchoredFragment (h' blk) -> Maybe (Point (h blk))
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2 -> Maybe (Point block1)
AF.intersectionPoint AnchoredFragment (h blk)
frag1 AnchoredFragment (h' blk)
frag2) =
      () -> Either String ()
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise =
      String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        String
"precondition violated: fragments should both be non-empty or they \
        \should intersect"

-- | If the two fragments `c1` and `c2` intersect, return the intersection
-- point and join the prefix of `c1` before the intersection with the suffix
-- of `c2` after the intersection. The resulting fragment has the same
-- anchor as `c1` and the same head as `c2`.
cross ::
  HasHeader block =>
  AnchoredFragment block ->
  AnchoredFragment block ->
  Maybe (Point block, AnchoredFragment block)
cross :: forall block.
HasHeader block =>
AnchoredFragment block
-> AnchoredFragment block
-> Maybe (Point block, AnchoredFragment block)
cross AnchoredFragment block
c1 AnchoredFragment block
c2 = do
  (p1, _p2, _s1, s2) <- AnchoredFragment block
-> AnchoredFragment block
-> Maybe
     (AnchoredFragment block, AnchoredFragment block,
      AnchoredFragment block, AnchoredFragment block)
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2
-> Maybe
     (AnchoredFragment block1, AnchoredFragment block2,
      AnchoredFragment block1, AnchoredFragment block2)
AF.intersect AnchoredFragment block
c1 AnchoredFragment block
c2
  -- Note that the head of `p1` and `_p2` is the intersection point, and
  -- `_s1` and `s2` are anchored in the intersection point.
  let crossed = case AnchoredFragment block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
forall block.
HasHeader block =>
AnchoredFragment block
-> AnchoredFragment block -> Maybe (AnchoredFragment block)
AF.join AnchoredFragment block
p1 AnchoredFragment block
s2 of
        Just AnchoredFragment block
c -> AnchoredFragment block
c
        Maybe (AnchoredFragment block)
Nothing -> String -> AnchoredFragment block
forall a. HasCallStack => String -> a
error String
"invariant violation of AF.intersect"
  pure (AF.anchorPoint s2, crossed)

-- | Strip the common prefix of multiple fragments.
--
-- PRECONDITION: all fragments have the given anchor as their anchor.
stripCommonPrefix ::
  forall f blk.
  (Functor f, Foldable f, HasHeader blk) => -- TODO: this uses the lazy 'map' for 'Map'...
  AF.Anchor blk ->
  f (AnchoredFragment blk) ->
  (AnchoredFragment blk, f (AnchoredFragment blk))
stripCommonPrefix :: forall (f :: * -> *) blk.
(Functor f, Foldable f, HasHeader blk) =>
Anchor blk
-> f (AnchoredFragment blk)
-> (AnchoredFragment blk, f (AnchoredFragment blk))
stripCommonPrefix Anchor blk
sharedAnchor f (AnchoredFragment blk)
frags
  | (AnchoredFragment blk -> Bool) -> f (AnchoredFragment blk) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Anchor blk
sharedAnchor Anchor blk -> Anchor blk -> Bool
forall a. Eq a => a -> a -> Bool
==) (Anchor blk -> Bool)
-> (AnchoredFragment blk -> Anchor blk)
-> AnchoredFragment blk
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment blk -> Anchor blk
forall v a b. AnchoredSeq v a b -> a
AF.anchor) f (AnchoredFragment blk)
frags =
      (AnchoredFragment blk
commonPrefix, AnchoredFragment blk -> AnchoredFragment blk
splitAfterCommonPrefix (AnchoredFragment blk -> AnchoredFragment blk)
-> f (AnchoredFragment blk) -> f (AnchoredFragment blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (AnchoredFragment blk)
frags)
  | Bool
otherwise =
      String -> (AnchoredFragment blk, f (AnchoredFragment blk))
forall a. HasCallStack => String -> a
error String
"Not all fragments are anchored in the given anchor"
 where
  -- Return the common prefix of two fragments with the same anchor
  -- 'sharedAnchor'.
  computeCommonPrefix ::
    AnchoredFragment blk ->
    AnchoredFragment blk ->
    AnchoredFragment blk
  computeCommonPrefix :: AnchoredFragment blk
-> AnchoredFragment blk -> AnchoredFragment blk
computeCommonPrefix AnchoredFragment blk
frag1 AnchoredFragment blk
frag2 = case AnchoredFragment blk
-> AnchoredFragment blk
-> Maybe
     (AnchoredFragment blk, AnchoredFragment blk, AnchoredFragment blk,
      AnchoredFragment blk)
forall block1 block2.
(HasHeader block1, HasHeader block2,
 HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> AnchoredFragment block2
-> Maybe
     (AnchoredFragment block1, AnchoredFragment block2,
      AnchoredFragment block1, AnchoredFragment block2)
AF.intersect AnchoredFragment blk
frag1 AnchoredFragment blk
frag2 of
    Just (AnchoredFragment blk
cp, AnchoredFragment blk
_, AnchoredFragment blk
_, AnchoredFragment blk
_) -> AnchoredFragment blk
cp
    Maybe
  (AnchoredFragment blk, AnchoredFragment blk, AnchoredFragment blk,
   AnchoredFragment blk)
Nothing -> String -> AnchoredFragment blk
forall a. HasCallStack => String -> a
error String
"unreachable"

  commonPrefix :: AnchoredFragment blk
commonPrefix = case [AnchoredFragment blk] -> Maybe (NonEmpty (AnchoredFragment blk))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([AnchoredFragment blk] -> Maybe (NonEmpty (AnchoredFragment blk)))
-> [AnchoredFragment blk]
-> Maybe (NonEmpty (AnchoredFragment blk))
forall a b. (a -> b) -> a -> b
$ f (AnchoredFragment blk) -> [AnchoredFragment blk]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (AnchoredFragment blk)
frags of
    Maybe (NonEmpty (AnchoredFragment blk))
Nothing -> Anchor blk -> AnchoredFragment blk
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor blk
sharedAnchor
    Just NonEmpty (AnchoredFragment blk)
fragsNE -> (AnchoredFragment blk
 -> AnchoredFragment blk -> AnchoredFragment blk)
-> NonEmpty (AnchoredFragment blk) -> AnchoredFragment blk
forall (t :: * -> *) a. Foldable1 t => (a -> a -> a) -> t a -> a
F1.foldl1' AnchoredFragment blk
-> AnchoredFragment blk -> AnchoredFragment blk
computeCommonPrefix NonEmpty (AnchoredFragment blk)
fragsNE

  splitAfterCommonPrefix :: AnchoredFragment blk -> AnchoredFragment blk
splitAfterCommonPrefix AnchoredFragment blk
frag =
    case AnchoredFragment blk
-> Point blk -> Maybe (AnchoredFragment blk, AnchoredFragment blk)
forall block1 block2.
(HasHeader block1, HeaderHash block1 ~ HeaderHash block2) =>
AnchoredFragment block1
-> Point block2
-> Maybe (AnchoredFragment block1, AnchoredFragment block1)
AF.splitAfterPoint AnchoredFragment blk
frag (AnchoredFragment blk -> Point blk
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment blk
commonPrefix) of
      Just (AnchoredFragment blk
_, AnchoredFragment blk
afterCommonPrefix) -> AnchoredFragment blk
afterCommonPrefix
      Maybe (AnchoredFragment blk, AnchoredFragment blk)
Nothing -> String -> AnchoredFragment blk
forall a. HasCallStack => String -> a
error String
"unreachable"