{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Protocol.Abstract
  ( -- * Abstract definition of the Ouroboros protocol
    ConsensusConfig
  , ConsensusProtocol (..)

    -- * Chain order
  , SelectView (..)
  , ChainOrder (..)
  , SimpleChainOrder (..)
  , NoTiebreaker (..)

    -- * Translation
  , TranslateProto (..)

    -- * Reasons for switching to a fork
  , ShouldSwitch (..)
  , SelectViewReasonForSwitch (..)
  , shouldSwitch
  , shouldSwitchToMaybe
  , Comparing (..)

    -- * Convenience re-exports
  , SecurityParam (..)
  ) where

import Cardano.Slotting.Slot (WithOrigin (At))
import Control.Monad.Except
import Data.Function (on)
import Data.Kind (Type)
import Data.Proxy (Proxy)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import GHC.Stack
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block.Abstract
import Ouroboros.Consensus.Config.SecurityParam
import Ouroboros.Consensus.Ticked

-- | Static configuration required to run the consensus protocol
--
-- Every method in the 'ConsensusProtocol' class takes the consensus
-- configuration as a parameter, so having this as a data family rather than a
-- type family resolves most ambiguity.
--
-- Defined out of the class so that protocols can define this type without
-- having to define the entire protocol at the same time (or indeed in the same
-- module).
data family ConsensusConfig p :: Type

-- | The (open) universe of Ouroboros protocols
--
-- This class encodes the part that is independent from any particular
-- block representation.
class
  ( Show (ChainDepState p)
  , Show (ValidationErr p)
  , Show (TiebreakerView p)
  , Show (LedgerView p)
  , Eq (ChainDepState p)
  , Eq (ValidationErr p)
  , ChainOrder (TiebreakerView p)
  , NoThunks (ConsensusConfig p)
  , NoThunks (ChainDepState p)
  , NoThunks (ValidationErr p)
  , NoThunks (TiebreakerView p)
  , Typeable p -- so that p can appear in exceptions
  ) =>
  ConsensusProtocol p
  where
  -- | Protocol-specific state
  --
  -- NOTE: This chain is blockchain dependent, i.e., updated when new blocks
  -- come in (more precisely, new /headers/), and subject to rollback.
  type ChainDepState p :: Type

  -- | Evidence that a node /is/ the leader
  type IsLeader p :: Type

  -- | Evidence that we /can/ be a leader
  type CanBeLeader p :: Type

  -- | View on a header required for tiebreaking between chains of equal length.
  --
  -- Chain selection is implemented by the chain database, which takes care of
  -- two things independent of a choice of consensus protocol: we never switch
  -- to chains that fork off more than @k@ blocks ago, and we never adopt an
  -- invalid chain. We always prefer longer chains to shorter chains. The
  -- comparison of chains A and B of equal length however depends on the chain
  -- selection protocol: chain A is strictly preferred over chain B whenever A's
  -- tiebreaker view is preferred over B's tiebreaker view according to the
  -- 'ChainOrder' instance.
  type TiebreakerView p :: Type

  type TiebreakerView p = NoTiebreaker

  -- | Projection of the ledger state the Ouroboros protocol needs access to
  --
  -- The 'LedgerView' is a summary of the state of the ledger that the consensus
  -- algorithm requires to do its job. Under certain circumstances the consensus
  -- algorithm may require the 'LedgerView' for slots in the past (before the
  -- current tip of the chain) or in the (near) future (beyond the tip of the
  -- current chain, without having seen those future blocks yet).
  --
  -- This puts limitations on what the 'LedgerView' can be. For example, it
  -- cannot be the "current stake distribution", since it is of course
  -- impossible to compute the current stake distibution for a slot in the
  -- future. This means that for a consensus algorithm that requires the
  -- stake distribution such as Praos, the 'LedgerView' for a particular slot
  -- must be the "stake distribution for the purpose of leader selection".
  -- This "relevant" stake distribution /can/ be computed for slots in the
  -- (near) future because it is based on historical stake, not current.
  --
  -- A somewhat unfortunate consequence of this is that some decisions that
  -- ought to live in the consensus layer (such as the decision precisely which
  -- historical stake to sample to determine the relevant stake distribution)
  -- instead live in the ledger layer. It is difficult to disentangle this,
  -- because the ledger may indeed /depend/ on those sampling decisions (for
  -- example, reward calculations /must/ be based on that same stake
  -- distribution).
  --
  -- There are also some /advantages/ to moving these sorts of decisions to the
  -- ledger layer. It means that the consensus algorithm can continue to
  -- function without modifications if we decide that the stake distribution for
  -- leader selection should be based on something else instead (for example,
  -- for some bespoke version of the blockchain we may wish to use a committee
  -- instead of a decentralized blockchain). Having sampling decisions in the
  -- ledger layer rather than the consensus layer means that these decisions can
  -- be made without modifying the consensus algorithm.
  --
  -- Note that for the specific case of Praos, whilst the ledger layer provides
  -- the relevant stake distribution, the precise leader election must still live
  -- in the consensus layer since that depends on the computation (and sampling)
  -- of entropy, which is done consensus side, not ledger side (the reward
  -- calculation does not depend on this).
  type LedgerView p :: Type

  -- | Validation errors
  type ValidationErr p :: Type

  -- | View on a header required to validate it
  type ValidateView p :: Type

  -- | Check if a node is the leader
  checkIsLeader ::
    HasCallStack =>
    ConsensusConfig p ->
    CanBeLeader p ->
    SlotNo ->
    Ticked (ChainDepState p) ->
    Maybe (IsLeader p)

  -- | Tick the 'ChainDepState'
  --
  -- We pass the 'LedgerView' to 'tickChainDepState'. Functions that /take/ a
  -- ticked 'ChainDepState' are not separately passed a ledger view; protocols
  -- that require it, can include it in their ticked 'ChainDepState' type.
  tickChainDepState ::
    ConsensusConfig p ->
    LedgerView p ->
    SlotNo ->
    ChainDepState p ->
    Ticked (ChainDepState p)

  -- | Apply a header
  updateChainDepState ::
    HasCallStack =>
    ConsensusConfig p ->
    ValidateView p ->
    SlotNo ->
    Ticked (ChainDepState p) ->
    Except (ValidationErr p) (ChainDepState p)

  -- | Re-apply a header to the same 'ChainDepState' we have been able to
  -- successfully apply to before.
  --
  -- Since a header can only be applied to a single, specific,
  -- 'ChainDepState', if we apply a previously applied header again it will be
  -- applied in the very same 'ChainDepState', and therefore can't possibly
  -- fail.
  --
  -- It is worth noting that since we already know that the header is valid
  -- w.r.t. the provided 'ChainDepState', no validation checks should be
  -- performed.
  reupdateChainDepState ::
    HasCallStack =>
    ConsensusConfig p ->
    ValidateView p ->
    SlotNo ->
    Ticked (ChainDepState p) ->
    ChainDepState p

  -- | We require that protocols support a @k@ security parameter
  protocolSecurityParam :: ConsensusConfig p -> SecurityParam

-- | Translate across protocols
class TranslateProto protoFrom protoTo where
  -- | Translate the ledger view.
  translateLedgerView ::
    Proxy (protoFrom, protoTo) -> LedgerView protoFrom -> LedgerView protoTo

  translateChainDepState ::
    Proxy (protoFrom, protoTo) -> ChainDepState protoFrom -> ChainDepState protoTo

-- | Degenerate instance - we may always translate from a protocol to itself.
instance TranslateProto singleProto singleProto where
  translateLedgerView :: Proxy (singleProto, singleProto)
-> LedgerView singleProto -> LedgerView singleProto
translateLedgerView Proxy (singleProto, singleProto)
_ = LedgerView singleProto -> LedgerView singleProto
forall a. a -> a
id
  translateChainDepState :: Proxy (singleProto, singleProto)
-> ChainDepState singleProto -> ChainDepState singleProto
translateChainDepState Proxy (singleProto, singleProto)
_ = ChainDepState singleProto -> ChainDepState singleProto
forall a. a -> a
id

-- | The chain order of some type; in the Consensus layer, this will always be
-- the 'SelectView'/'TiebreakerView' of some 'ConsensusProtocol'. Namely, the
-- 'ChainOrder' instance of 'SelectView' primarily compares block numbers, but
-- refers to the 'ChainOrder' instance of 'TiebreakerView' in case of a tie.
--
-- See 'preferCandidate' for the primary documentation.
--
-- Additionally, we require a total order on this type, such that eg different
-- candidate chains that are preferred over our current selection can be sorted
-- for prioritization. For example, this is used in ChainSel during initial
-- chain selection or when blocks arrive out of order (not the case when the
-- node is caught up), or in the BlockFetch decision logic. Future work could
-- include also recording\/storing arrival information and using that instead
-- of\/in addition to the 'Ord' instance.
class Ord sv => ChainOrder sv where
  type ChainOrderConfig sv :: Type

  type ReasonForSwitch sv :: Type

  -- | Compare a candidate chain to our own.
  --
  -- This method defines when a candidate chain is /strictly/ preferable to our
  -- current chain. If both chains are equally preferable, the Ouroboros class
  -- of consensus protocols /always/ sticks with the current chain.
  --
  -- === Requirements
  --
  -- Write @ours ⊏ cand@ for @'shouldSwitch' 'preferCandidate' cfg ours cand@
  -- for brevity.
  --
  --  [__Consistency with 'Ord'__]: When @ours ⊏ cand@, then @ours < cand@.
  --
  --      This means that @cand@ can only be preferred over @ours@ when @cand@
  --      is greater than @ours@ according to the 'Ord' instance.
  --
  --      However, this is not necessarily a sufficient condition; a concrete
  --      implementation may decide to not have @ours ⊏ cand@ despite @ours <
  --      cand@ for some pairs @ours, can@. However, it is recommended to think
  --      about this carefully and rather use 'SimpleChainOrder' if possible,
  --      which defines @ours ⊏ cand@ as @ours < cand@, as it simplifies
  --      reasoning about the chain ordering.
  --
  --      However, forgoing 'SimpleChainOrder' can enable more sophisticated
  --      tiebreaking rules that eg exhibit desirable incentive behavior.
  preferCandidate ::
    ChainOrderConfig sv ->
    -- | Tip of our chain
    sv ->
    -- | Tip of the candidate
    sv ->
    ShouldSwitch (ReasonForSwitch sv)

data ShouldSwitch reason = ShouldNotSwitch Ordering | ShouldSwitch reason

data Comparing a = Comparing {forall a. Comparing a -> a
compareToThat :: a, forall a. Comparing a -> a
compareThis :: a}
  deriving Int -> Comparing a -> ShowS
[Comparing a] -> ShowS
Comparing a -> String
(Int -> Comparing a -> ShowS)
-> (Comparing a -> String)
-> ([Comparing a] -> ShowS)
-> Show (Comparing a)
forall a. Show a => Int -> Comparing a -> ShowS
forall a. Show a => [Comparing a] -> ShowS
forall a. Show a => Comparing a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Comparing a -> ShowS
showsPrec :: Int -> Comparing a -> ShowS
$cshow :: forall a. Show a => Comparing a -> String
show :: Comparing a -> String
$cshowList :: forall a. Show a => [Comparing a] -> ShowS
showList :: [Comparing a] -> ShowS
Show

shouldSwitch :: ShouldSwitch reason -> Bool
shouldSwitch :: forall reason. ShouldSwitch reason -> Bool
shouldSwitch ShouldSwitch{} = Bool
True
shouldSwitch ShouldNotSwitch{} = Bool
False

shouldSwitchToMaybe :: ShouldSwitch reason -> Maybe reason
shouldSwitchToMaybe :: forall reason. ShouldSwitch reason -> Maybe reason
shouldSwitchToMaybe (ShouldSwitch reason
reason) = reason -> Maybe reason
forall a. a -> Maybe a
Just reason
reason
shouldSwitchToMaybe ShouldNotSwitch{} = Maybe reason
forall a. Maybe a
Nothing

-- | A @DerivingVia@ helper to implement 'preferCandidate' in terms of the 'Ord'
-- instance.
newtype SimpleChainOrder sv = SimpleChainOrder sv
  deriving newtype (SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
(SimpleChainOrder sv -> SimpleChainOrder sv -> Bool)
-> (SimpleChainOrder sv -> SimpleChainOrder sv -> Bool)
-> Eq (SimpleChainOrder sv)
forall sv.
Eq sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall sv.
Eq sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
== :: SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
$c/= :: forall sv.
Eq sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
/= :: SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
Eq, Eq (SimpleChainOrder sv)
Eq (SimpleChainOrder sv) =>
(SimpleChainOrder sv -> SimpleChainOrder sv -> Ordering)
-> (SimpleChainOrder sv -> SimpleChainOrder sv -> Bool)
-> (SimpleChainOrder sv -> SimpleChainOrder sv -> Bool)
-> (SimpleChainOrder sv -> SimpleChainOrder sv -> Bool)
-> (SimpleChainOrder sv -> SimpleChainOrder sv -> Bool)
-> (SimpleChainOrder sv
    -> SimpleChainOrder sv -> SimpleChainOrder sv)
-> (SimpleChainOrder sv
    -> SimpleChainOrder sv -> SimpleChainOrder sv)
-> Ord (SimpleChainOrder sv)
SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
SimpleChainOrder sv -> SimpleChainOrder sv -> Ordering
SimpleChainOrder sv -> SimpleChainOrder sv -> SimpleChainOrder sv
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall sv. Ord sv => Eq (SimpleChainOrder sv)
forall sv.
Ord sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
forall sv.
Ord sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> Ordering
forall sv.
Ord sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> SimpleChainOrder sv
$ccompare :: forall sv.
Ord sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> Ordering
compare :: SimpleChainOrder sv -> SimpleChainOrder sv -> Ordering
$c< :: forall sv.
Ord sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
< :: SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
$c<= :: forall sv.
Ord sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
<= :: SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
$c> :: forall sv.
Ord sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
> :: SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
$c>= :: forall sv.
Ord sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
>= :: SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
$cmax :: forall sv.
Ord sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> SimpleChainOrder sv
max :: SimpleChainOrder sv -> SimpleChainOrder sv -> SimpleChainOrder sv
$cmin :: forall sv.
Ord sv =>
SimpleChainOrder sv -> SimpleChainOrder sv -> SimpleChainOrder sv
min :: SimpleChainOrder sv -> SimpleChainOrder sv -> SimpleChainOrder sv
Ord)

instance Ord sv => ChainOrder (SimpleChainOrder sv) where
  type ChainOrderConfig (SimpleChainOrder sv) = ()

  -- All interesting protocols (PBFT, TPraos, Praos, HardForkProtocol) use a
  -- proper TiebreakerView, so this is only for tests with Bft (or other testing
  -- protocols), therefore we don't really elaborate the reasons.
  type ReasonForSwitch (SimpleChainOrder sv) = ()

  preferCandidate :: ChainOrderConfig (SimpleChainOrder sv)
-> SimpleChainOrder sv
-> SimpleChainOrder sv
-> ShouldSwitch (ReasonForSwitch (SimpleChainOrder sv))
preferCandidate ChainOrderConfig (SimpleChainOrder sv)
_cfg SimpleChainOrder sv
ours SimpleChainOrder sv
cand =
    if SimpleChainOrder sv
ours SimpleChainOrder sv -> SimpleChainOrder sv -> Bool
forall a. Ord a => a -> a -> Bool
< SimpleChainOrder sv
cand
      then () -> ShouldSwitch ()
forall reason. reason -> ShouldSwitch reason
ShouldSwitch ()
      else Ordering -> ShouldSwitch ()
forall reason. Ordering -> ShouldSwitch reason
ShouldNotSwitch (SimpleChainOrder sv -> SimpleChainOrder sv -> Ordering
forall a. Ord a => a -> a -> Ordering
compare SimpleChainOrder sv
ours SimpleChainOrder sv
cand)

-- | Use no tiebreaker to decide between chains of equal length, cf
-- 'TiebreakerView' and 'ChainOrder'.
data NoTiebreaker = NoTiebreaker
  deriving stock (Int -> NoTiebreaker -> ShowS
[NoTiebreaker] -> ShowS
NoTiebreaker -> String
(Int -> NoTiebreaker -> ShowS)
-> (NoTiebreaker -> String)
-> ([NoTiebreaker] -> ShowS)
-> Show NoTiebreaker
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoTiebreaker -> ShowS
showsPrec :: Int -> NoTiebreaker -> ShowS
$cshow :: NoTiebreaker -> String
show :: NoTiebreaker -> String
$cshowList :: [NoTiebreaker] -> ShowS
showList :: [NoTiebreaker] -> ShowS
Show, NoTiebreaker -> NoTiebreaker -> Bool
(NoTiebreaker -> NoTiebreaker -> Bool)
-> (NoTiebreaker -> NoTiebreaker -> Bool) -> Eq NoTiebreaker
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NoTiebreaker -> NoTiebreaker -> Bool
== :: NoTiebreaker -> NoTiebreaker -> Bool
$c/= :: NoTiebreaker -> NoTiebreaker -> Bool
/= :: NoTiebreaker -> NoTiebreaker -> Bool
Eq, Eq NoTiebreaker
Eq NoTiebreaker =>
(NoTiebreaker -> NoTiebreaker -> Ordering)
-> (NoTiebreaker -> NoTiebreaker -> Bool)
-> (NoTiebreaker -> NoTiebreaker -> Bool)
-> (NoTiebreaker -> NoTiebreaker -> Bool)
-> (NoTiebreaker -> NoTiebreaker -> Bool)
-> (NoTiebreaker -> NoTiebreaker -> NoTiebreaker)
-> (NoTiebreaker -> NoTiebreaker -> NoTiebreaker)
-> Ord NoTiebreaker
NoTiebreaker -> NoTiebreaker -> Bool
NoTiebreaker -> NoTiebreaker -> Ordering
NoTiebreaker -> NoTiebreaker -> NoTiebreaker
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NoTiebreaker -> NoTiebreaker -> Ordering
compare :: NoTiebreaker -> NoTiebreaker -> Ordering
$c< :: NoTiebreaker -> NoTiebreaker -> Bool
< :: NoTiebreaker -> NoTiebreaker -> Bool
$c<= :: NoTiebreaker -> NoTiebreaker -> Bool
<= :: NoTiebreaker -> NoTiebreaker -> Bool
$c> :: NoTiebreaker -> NoTiebreaker -> Bool
> :: NoTiebreaker -> NoTiebreaker -> Bool
$c>= :: NoTiebreaker -> NoTiebreaker -> Bool
>= :: NoTiebreaker -> NoTiebreaker -> Bool
$cmax :: NoTiebreaker -> NoTiebreaker -> NoTiebreaker
max :: NoTiebreaker -> NoTiebreaker -> NoTiebreaker
$cmin :: NoTiebreaker -> NoTiebreaker -> NoTiebreaker
min :: NoTiebreaker -> NoTiebreaker -> NoTiebreaker
Ord, (forall x. NoTiebreaker -> Rep NoTiebreaker x)
-> (forall x. Rep NoTiebreaker x -> NoTiebreaker)
-> Generic NoTiebreaker
forall x. Rep NoTiebreaker x -> NoTiebreaker
forall x. NoTiebreaker -> Rep NoTiebreaker x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NoTiebreaker -> Rep NoTiebreaker x
from :: forall x. NoTiebreaker -> Rep NoTiebreaker x
$cto :: forall x. Rep NoTiebreaker x -> NoTiebreaker
to :: forall x. Rep NoTiebreaker x -> NoTiebreaker
Generic)
  deriving anyclass Context -> NoTiebreaker -> IO (Maybe ThunkInfo)
Proxy NoTiebreaker -> String
(Context -> NoTiebreaker -> IO (Maybe ThunkInfo))
-> (Context -> NoTiebreaker -> IO (Maybe ThunkInfo))
-> (Proxy NoTiebreaker -> String)
-> NoThunks NoTiebreaker
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> NoTiebreaker -> IO (Maybe ThunkInfo)
noThunks :: Context -> NoTiebreaker -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> NoTiebreaker -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> NoTiebreaker -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy NoTiebreaker -> String
showTypeOf :: Proxy NoTiebreaker -> String
NoThunks
  deriving Ord NoTiebreaker
Ord NoTiebreaker =>
(ChainOrderConfig NoTiebreaker
 -> NoTiebreaker
 -> NoTiebreaker
 -> ShouldSwitch (ReasonForSwitch NoTiebreaker))
-> ChainOrder NoTiebreaker
ChainOrderConfig NoTiebreaker
-> NoTiebreaker
-> NoTiebreaker
-> ShouldSwitch (ReasonForSwitch NoTiebreaker)
forall sv.
Ord sv =>
(ChainOrderConfig sv
 -> sv -> sv -> ShouldSwitch (ReasonForSwitch sv))
-> ChainOrder sv
$cpreferCandidate :: ChainOrderConfig NoTiebreaker
-> NoTiebreaker
-> NoTiebreaker
-> ShouldSwitch (ReasonForSwitch NoTiebreaker)
preferCandidate :: ChainOrderConfig NoTiebreaker
-> NoTiebreaker
-> NoTiebreaker
-> ShouldSwitch (ReasonForSwitch NoTiebreaker)
ChainOrder via SimpleChainOrder NoTiebreaker

{-------------------------------------------------------------------------------
  Helpers
-------------------------------------------------------------------------------}

-- | Information from the tip of a chain required to compare it to other chains
-- using its 'Ord' and 'ChainOrder' instance.
--
-- As the abstract Consensus layer targets longest chain protocols, the primary
-- measure for comparing chains is the block number. However, in case of chains
-- of equal length, we use the 'TiebreakerView' which is customizable by the
-- particular @'ConsensusProtocol' p@.
data SelectView p = SelectView
  { forall p. SelectView p -> BlockNo
svBlockNo :: !BlockNo
  , forall p. SelectView p -> TiebreakerView p
svTiebreakerView :: !(TiebreakerView p)
  }
  deriving stock (forall x. SelectView p -> Rep (SelectView p) x)
-> (forall x. Rep (SelectView p) x -> SelectView p)
-> Generic (SelectView p)
forall x. Rep (SelectView p) x -> SelectView p
forall x. SelectView p -> Rep (SelectView p) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall p x. Rep (SelectView p) x -> SelectView p
forall p x. SelectView p -> Rep (SelectView p) x
$cfrom :: forall p x. SelectView p -> Rep (SelectView p) x
from :: forall x. SelectView p -> Rep (SelectView p) x
$cto :: forall p x. Rep (SelectView p) x -> SelectView p
to :: forall x. Rep (SelectView p) x -> SelectView p
Generic

deriving stock instance Show (TiebreakerView p) => Show (SelectView p)
deriving stock instance Eq (TiebreakerView p) => Eq (SelectView p)

instance NoThunks (TiebreakerView p) => NoThunks (SelectView p)

-- | First compare block numbers, then compare the 'TiebreakerView'.
instance Ord (TiebreakerView p) => Ord (SelectView p) where
  compare :: SelectView p -> SelectView p -> Ordering
compare =
    [SelectView p -> SelectView p -> Ordering]
-> SelectView p -> SelectView p -> Ordering
forall a. Monoid a => [a] -> a
mconcat
      [ BlockNo -> BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (BlockNo -> BlockNo -> Ordering)
-> (SelectView p -> BlockNo)
-> SelectView p
-> SelectView p
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` SelectView p -> BlockNo
forall p. SelectView p -> BlockNo
svBlockNo
      , TiebreakerView p -> TiebreakerView p -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (TiebreakerView p -> TiebreakerView p -> Ordering)
-> (SelectView p -> TiebreakerView p)
-> SelectView p
-> SelectView p
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` SelectView p -> TiebreakerView p
forall p. SelectView p -> TiebreakerView p
svTiebreakerView
      ]

data SelectViewReasonForSwitch p
  = Longer (Comparing (WithOrigin BlockNo))
  | SelectViewTiebreak (ReasonForSwitch (TiebreakerView p))

deriving instance Show (ReasonForSwitch (TiebreakerView p)) => Show (SelectViewReasonForSwitch p)

-- | @cand@ is preferred to @ours@ if either @cand@ is longer than @ours@, or
-- @cand@ and @ours@ are of equal length and we have
--
-- > preferCandidate cfg ourTiebreaker candTiebreaker
instance ChainOrder (TiebreakerView p) => ChainOrder (SelectView p) where
  type ChainOrderConfig (SelectView p) = ChainOrderConfig (TiebreakerView p)
  type ReasonForSwitch (SelectView p) = SelectViewReasonForSwitch p

  preferCandidate :: ChainOrderConfig (SelectView p)
-> SelectView p
-> SelectView p
-> ShouldSwitch (ReasonForSwitch (SelectView p))
preferCandidate ChainOrderConfig (SelectView p)
cfg SelectView p
ours SelectView p
cand = case BlockNo -> BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SelectView p -> BlockNo
forall p. SelectView p -> BlockNo
svBlockNo SelectView p
ours) (SelectView p -> BlockNo
forall p. SelectView p -> BlockNo
svBlockNo SelectView p
cand) of
    Ordering
LT -> SelectViewReasonForSwitch p
-> ShouldSwitch (SelectViewReasonForSwitch p)
forall reason. reason -> ShouldSwitch reason
ShouldSwitch (Comparing (WithOrigin BlockNo) -> SelectViewReasonForSwitch p
forall p.
Comparing (WithOrigin BlockNo) -> SelectViewReasonForSwitch p
Longer (WithOrigin BlockNo
-> WithOrigin BlockNo -> Comparing (WithOrigin BlockNo)
forall a. a -> a -> Comparing a
Comparing (BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At (SelectView p -> BlockNo
forall p. SelectView p -> BlockNo
svBlockNo SelectView p
ours)) (BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At (SelectView p -> BlockNo
forall p. SelectView p -> BlockNo
svBlockNo SelectView p
cand))))
    Ordering
EQ -> case ChainOrderConfig (TiebreakerView p)
-> TiebreakerView p
-> TiebreakerView p
-> ShouldSwitch (ReasonForSwitch (TiebreakerView p))
forall sv.
ChainOrder sv =>
ChainOrderConfig sv
-> sv -> sv -> ShouldSwitch (ReasonForSwitch sv)
preferCandidate ChainOrderConfig (SelectView p)
ChainOrderConfig (TiebreakerView p)
cfg (SelectView p -> TiebreakerView p
forall p. SelectView p -> TiebreakerView p
svTiebreakerView SelectView p
ours) (SelectView p -> TiebreakerView p
forall p. SelectView p -> TiebreakerView p
svTiebreakerView SelectView p
cand) of
      ShouldSwitch ReasonForSwitch (TiebreakerView p)
r -> SelectViewReasonForSwitch p
-> ShouldSwitch (SelectViewReasonForSwitch p)
forall reason. reason -> ShouldSwitch reason
ShouldSwitch (ReasonForSwitch (TiebreakerView p) -> SelectViewReasonForSwitch p
forall p.
ReasonForSwitch (TiebreakerView p) -> SelectViewReasonForSwitch p
SelectViewTiebreak ReasonForSwitch (TiebreakerView p)
r)
      ShouldNotSwitch Ordering
e -> Ordering -> ShouldSwitch (SelectViewReasonForSwitch p)
forall reason. Ordering -> ShouldSwitch reason
ShouldNotSwitch Ordering
e
    Ordering
GT -> Ordering -> ShouldSwitch (SelectViewReasonForSwitch p)
forall reason. Ordering -> ShouldSwitch reason
ShouldNotSwitch Ordering
GT