{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Ouroboros.Consensus.Peras.SelectView
  ( -- * 'WeightedSelectView'
    WeightedSelectView (..)
  , wsvTotalWeight
  , weightedSelectView

    -- * Utility: 'WithEmptyFragment'
  , WithEmptyFragment (..)
  , withEmptyFragmentFromMaybe
  , withEmptyFragmentToMaybe
  ) where

import Data.Function (on)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Peras.Weight
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF

{-------------------------------------------------------------------------------
  Weighted select views
-------------------------------------------------------------------------------}

-- | Information from a non-empty chain fragment for a weighted chain comparison
-- against other fragments with the same anchor.
--
-- Comparisons of fragments with different anchors are not possible in general,
-- as the fragments might not intersect, and so some blocks after their
-- intersection (and hence their weight boost) are unknown.
data WeightedSelectView proto = WeightedSelectView
  { forall proto. WeightedSelectView proto -> BlockNo
wsvBlockNo :: !BlockNo
  -- ^ The 'BlockNo' at the tip of a fragment.
  , forall proto. WeightedSelectView proto -> PerasWeight
wsvWeightBoost :: !PerasWeight
  -- ^ The weight boost of a fragment (w.r.t. a particular anchor).
  , forall proto. WeightedSelectView proto -> TiebreakerView proto
wsvTiebreaker :: TiebreakerView proto
  -- ^ Lazy because it is only needed when 'wsvTotalWeight' is inconclusive.
  }

deriving stock instance Show (TiebreakerView proto) => Show (WeightedSelectView proto)
deriving stock instance Eq (TiebreakerView proto) => Eq (WeightedSelectView proto)

-- TODO: More type safety to prevent people from accidentally comparing
-- 'WeightedSelectView's obtained from fragments with different anchors?
-- Something ST-trick like?

-- | The total weight, ie the sum of 'wsvBlockNo' and 'wsvBoostedWeight'.
wsvTotalWeight :: WeightedSelectView proto -> PerasWeight
-- could be cached, but then we need to be careful to maintain the invariant
wsvTotalWeight :: forall proto. WeightedSelectView proto -> PerasWeight
wsvTotalWeight WeightedSelectView proto
wsv =
  Word64 -> PerasWeight
PerasWeight (BlockNo -> Word64
unBlockNo (WeightedSelectView proto -> BlockNo
forall proto. WeightedSelectView proto -> BlockNo
wsvBlockNo WeightedSelectView proto
wsv)) PerasWeight -> PerasWeight -> PerasWeight
forall a. Semigroup a => a -> a -> a
<> WeightedSelectView proto -> PerasWeight
forall proto. WeightedSelectView proto -> PerasWeight
wsvWeightBoost WeightedSelectView proto
wsv

instance Ord (TiebreakerView proto) => Ord (WeightedSelectView proto) where
  compare :: WeightedSelectView proto -> WeightedSelectView proto -> Ordering
compare =
    [WeightedSelectView proto -> WeightedSelectView proto -> Ordering]
-> WeightedSelectView proto -> WeightedSelectView proto -> Ordering
forall a. Monoid a => [a] -> a
mconcat
      [ PerasWeight -> PerasWeight -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (PerasWeight -> PerasWeight -> Ordering)
-> (WeightedSelectView proto -> PerasWeight)
-> WeightedSelectView proto
-> WeightedSelectView proto
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` WeightedSelectView proto -> PerasWeight
forall proto. WeightedSelectView proto -> PerasWeight
wsvTotalWeight
      , TiebreakerView proto -> TiebreakerView proto -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (TiebreakerView proto -> TiebreakerView proto -> Ordering)
-> (WeightedSelectView proto -> TiebreakerView proto)
-> WeightedSelectView proto
-> WeightedSelectView proto
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` WeightedSelectView proto -> TiebreakerView proto
forall proto. WeightedSelectView proto -> TiebreakerView proto
wsvTiebreaker
      ]

instance ChainOrder (TiebreakerView proto) => ChainOrder (WeightedSelectView proto) where
  type ChainOrderConfig (WeightedSelectView proto) = ChainOrderConfig (TiebreakerView proto)

  preferCandidate :: ChainOrderConfig (WeightedSelectView proto)
-> WeightedSelectView proto -> WeightedSelectView proto -> Bool
preferCandidate ChainOrderConfig (WeightedSelectView proto)
cfg WeightedSelectView proto
ours WeightedSelectView proto
cand =
    case PerasWeight -> PerasWeight -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (WeightedSelectView proto -> PerasWeight
forall proto. WeightedSelectView proto -> PerasWeight
wsvTotalWeight WeightedSelectView proto
ours) (WeightedSelectView proto -> PerasWeight
forall proto. WeightedSelectView proto -> PerasWeight
wsvTotalWeight WeightedSelectView proto
cand) of
      Ordering
LT -> Bool
True
      Ordering
EQ -> ChainOrderConfig (TiebreakerView proto)
-> TiebreakerView proto -> TiebreakerView proto -> Bool
forall sv. ChainOrder sv => ChainOrderConfig sv -> sv -> sv -> Bool
preferCandidate ChainOrderConfig (TiebreakerView proto)
ChainOrderConfig (WeightedSelectView proto)
cfg (WeightedSelectView proto -> TiebreakerView proto
forall proto. WeightedSelectView proto -> TiebreakerView proto
wsvTiebreaker WeightedSelectView proto
ours) (WeightedSelectView proto -> TiebreakerView proto
forall proto. WeightedSelectView proto -> TiebreakerView proto
wsvTiebreaker WeightedSelectView proto
cand)
      Ordering
GT -> Bool
False

-- | Get the 'WeightedSelectView' for a fragment using the given
-- 'PerasWeightSnapshot'. Note that this is only meanigful for comparisons
-- against other fragments /with the same anchor/.
--
-- Returns 'EmptyFragment' iff the input fragment is empty.
weightedSelectView ::
  ( GetHeader1 h
  , HasHeader (h blk)
  , HeaderHash blk ~ HeaderHash (h blk)
  , BlockSupportsProtocol blk
  ) =>
  BlockConfig blk ->
  PerasWeightSnapshot blk ->
  AnchoredFragment (h blk) ->
  WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
weightedSelectView :: 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
bcfg PerasWeightSnapshot blk
weights = \case
  AF.Empty{} -> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
forall a. WithEmptyFragment a
EmptyFragment
  frag :: AnchoredFragment (h blk)
frag@(AnchoredFragment (h blk)
_ AF.:> (h blk -> Header blk
forall blk. h blk -> Header blk
forall (t :: * -> *) blk. GetHeader1 t => t blk -> Header blk
getHeader1 -> Header blk
hdr)) ->
    WeightedSelectView (BlockProtocol blk)
-> WithEmptyFragment (WeightedSelectView (BlockProtocol blk))
forall a. a -> WithEmptyFragment a
NonEmptyFragment
      WeightedSelectView
        { wsvBlockNo :: BlockNo
wsvBlockNo = Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr
        , wsvWeightBoost :: PerasWeight
wsvWeightBoost = PerasWeightSnapshot blk -> AnchoredFragment (h blk) -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot blk
weights AnchoredFragment (h blk)
frag
        , wsvTiebreaker :: TiebreakerView (BlockProtocol blk)
wsvTiebreaker = BlockConfig blk -> Header blk -> TiebreakerView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> TiebreakerView (BlockProtocol blk)
tiebreakerView BlockConfig blk
bcfg Header blk
hdr
        }

{-------------------------------------------------------------------------------
  WithEmptyFragment
-------------------------------------------------------------------------------}

-- | Attach the possibility of an empty fragment to a type.
data WithEmptyFragment a = EmptyFragment | NonEmptyFragment !a
  deriving stock (Int -> WithEmptyFragment a -> ShowS
[WithEmptyFragment a] -> ShowS
WithEmptyFragment a -> String
(Int -> WithEmptyFragment a -> ShowS)
-> (WithEmptyFragment a -> String)
-> ([WithEmptyFragment a] -> ShowS)
-> Show (WithEmptyFragment a)
forall a. Show a => Int -> WithEmptyFragment a -> ShowS
forall a. Show a => [WithEmptyFragment a] -> ShowS
forall a. Show a => WithEmptyFragment a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> WithEmptyFragment a -> ShowS
showsPrec :: Int -> WithEmptyFragment a -> ShowS
$cshow :: forall a. Show a => WithEmptyFragment a -> String
show :: WithEmptyFragment a -> String
$cshowList :: forall a. Show a => [WithEmptyFragment a] -> ShowS
showList :: [WithEmptyFragment a] -> ShowS
Show, WithEmptyFragment a -> WithEmptyFragment a -> Bool
(WithEmptyFragment a -> WithEmptyFragment a -> Bool)
-> (WithEmptyFragment a -> WithEmptyFragment a -> Bool)
-> Eq (WithEmptyFragment a)
forall a.
Eq a =>
WithEmptyFragment a -> WithEmptyFragment a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
WithEmptyFragment a -> WithEmptyFragment a -> Bool
== :: WithEmptyFragment a -> WithEmptyFragment a -> Bool
$c/= :: forall a.
Eq a =>
WithEmptyFragment a -> WithEmptyFragment a -> Bool
/= :: WithEmptyFragment a -> WithEmptyFragment a -> Bool
Eq)

withEmptyFragmentToMaybe :: WithEmptyFragment a -> Maybe a
withEmptyFragmentToMaybe :: forall a. WithEmptyFragment a -> Maybe a
withEmptyFragmentToMaybe = \case
  WithEmptyFragment a
EmptyFragment -> Maybe a
forall a. Maybe a
Nothing
  NonEmptyFragment a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a

withEmptyFragmentFromMaybe :: Maybe a -> WithEmptyFragment a
withEmptyFragmentFromMaybe :: forall a. Maybe a -> WithEmptyFragment a
withEmptyFragmentFromMaybe = \case
  Maybe a
Nothing -> WithEmptyFragment a
forall a. WithEmptyFragment a
EmptyFragment
  Just a
a -> a -> WithEmptyFragment a
forall a. a -> WithEmptyFragment a
NonEmptyFragment a
a

-- | Prefer non-empty fragments to empty ones.
instance Ord a => Ord (WithEmptyFragment a) where
  compare :: WithEmptyFragment a -> WithEmptyFragment a -> Ordering
compare = \cases
    WithEmptyFragment a
EmptyFragment WithEmptyFragment a
EmptyFragment -> Ordering
EQ
    WithEmptyFragment a
EmptyFragment NonEmptyFragment{} -> Ordering
LT
    NonEmptyFragment{} WithEmptyFragment a
EmptyFragment -> Ordering
GT
    (NonEmptyFragment a
a) (NonEmptyFragment a
b) -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b

-- | Prefer non-empty fragments to empty ones. This instance assumes that the
-- underlying fragments all have the same anchor.
instance ChainOrder a => ChainOrder (WithEmptyFragment a) where
  type ChainOrderConfig (WithEmptyFragment a) = ChainOrderConfig a

  preferCandidate :: ChainOrderConfig (WithEmptyFragment a)
-> WithEmptyFragment a -> WithEmptyFragment a -> Bool
preferCandidate ChainOrderConfig (WithEmptyFragment a)
cfg = \cases
    -- We prefer any non-empty fragment to the empty fragment.
    WithEmptyFragment a
EmptyFragment NonEmptyFragment{} -> Bool
True
    -- We never prefer the empty fragment to our selection (even if it is also
    -- empty).
    WithEmptyFragment a
_ WithEmptyFragment a
EmptyFragment -> Bool
False
    -- Otherwise, defer to @'ChainOrder' a@.
    (NonEmptyFragment a
ours) (NonEmptyFragment a
cand) ->
      ChainOrderConfig a -> a -> a -> Bool
forall sv. ChainOrder sv => ChainOrderConfig sv -> sv -> sv -> Bool
preferCandidate ChainOrderConfig a
ChainOrderConfig (WithEmptyFragment a)
cfg a
ours a
cand