{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

module Ouroboros.Consensus.Protocol.MockChainSel
  ( selectChain
  , selectUnvalidatedChain
  ) where

import Data.List (sortOn)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Ord (Down (..))
import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView (..), WithEmptyFragment (..))
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Network.Mock.Chain (Chain)

{-------------------------------------------------------------------------------
  Chain selection
-------------------------------------------------------------------------------}

-- | Chain selection between our chain and list of candidates
--
-- This is only a /model/ of chain selection: in reality of course we will not
-- work with entire chains in memory. This function is intended as an
-- explanation of how chain selection should work conceptually.
--
-- The @l@ parameter here models the ledger state for each chain, and serves as
-- evidence that the chains we are selecting between have been validated. (It
-- would /not/ be  correct to run chain selection on unvalidated chains and then
-- somehow fail if the selected chain turns out to be invalid.)
--
-- Returns 'Nothing' if we stick with our current chain.
selectChain ::
  forall proxy p hdr l.
  ConsensusProtocol p =>
  proxy p ->
  ChainOrderConfig (WeightedSelectView p) ->
  -- | Compute the 'WeightedSelectView' of a chain.
  (Chain hdr -> WithEmptyFragment (WeightedSelectView p)) ->
  -- | Our chain
  Chain hdr ->
  -- | Upstream chains
  [(Chain hdr, l)] ->
  Maybe (Chain hdr, l)
selectChain :: forall (proxy :: * -> *) p hdr l.
ConsensusProtocol p =>
proxy p
-> ChainOrderConfig (WeightedSelectView p)
-> (Chain hdr -> WithEmptyFragment (WeightedSelectView p))
-> Chain hdr
-> [(Chain hdr, l)]
-> Maybe (Chain hdr, l)
selectChain proxy p
_ ChainOrderConfig (WeightedSelectView p)
cfg Chain hdr -> WithEmptyFragment (WeightedSelectView p)
view Chain hdr
ours =
  [(Chain hdr, l)] -> Maybe (Chain hdr, l)
forall a. [a] -> Maybe a
listToMaybe
    ([(Chain hdr, l)] -> Maybe (Chain hdr, l))
-> ([(Chain hdr, l)] -> [(Chain hdr, l)])
-> [(Chain hdr, l)]
-> Maybe (Chain hdr, l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
 -> (Chain hdr, l))
-> [(WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))]
-> [(Chain hdr, l)]
forall a b. (a -> b) -> [a] -> [b]
map (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
-> (Chain hdr, l)
forall a b. (a, b) -> b
snd
    ([(WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))]
 -> [(Chain hdr, l)])
-> ([(Chain hdr, l)]
    -> [(WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))])
-> [(Chain hdr, l)]
-> [(Chain hdr, l)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
 -> Down (WithEmptyFragment (WeightedSelectView p)))
-> [(WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))]
-> [(WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (WithEmptyFragment (WeightedSelectView p)
-> Down (WithEmptyFragment (WeightedSelectView p))
forall a. a -> Down a
Down (WithEmptyFragment (WeightedSelectView p)
 -> Down (WithEmptyFragment (WeightedSelectView p)))
-> ((WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
    -> WithEmptyFragment (WeightedSelectView p))
-> (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
-> Down (WithEmptyFragment (WeightedSelectView p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
-> WithEmptyFragment (WeightedSelectView p)
forall a b. (a, b) -> a
fst)
    ([(WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))]
 -> [(WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))])
-> ([(Chain hdr, l)]
    -> [(WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))])
-> [(Chain hdr, l)]
-> [(WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Chain hdr, l)
 -> Maybe
      (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l)))
-> [(Chain hdr, l)]
-> [(WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Chain hdr, l)
-> Maybe (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
selectPreferredCandidate
 where
  -- \| Only retain a candidate if it is preferred over the current chain. As
  -- only a non-empty chain can be preferred over the current chain, we can
  -- extract the 'SelectView' of the tip of the candidate.
  selectPreferredCandidate ::
    (Chain hdr, l) ->
    Maybe (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
  selectPreferredCandidate :: (Chain hdr, l)
-> Maybe (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
selectPreferredCandidate x :: (Chain hdr, l)
x@(Chain hdr
cand, l
_)
    | let candView :: WithEmptyFragment (WeightedSelectView p)
candView = Chain hdr -> WithEmptyFragment (WeightedSelectView p)
view Chain hdr
cand
    , ChainOrderConfig (WithEmptyFragment (WeightedSelectView p))
-> WithEmptyFragment (WeightedSelectView p)
-> WithEmptyFragment (WeightedSelectView p)
-> Bool
forall sv. ChainOrder sv => ChainOrderConfig sv -> sv -> sv -> Bool
preferCandidate ChainOrderConfig (WithEmptyFragment (WeightedSelectView p))
ChainOrderConfig (WeightedSelectView p)
cfg (Chain hdr -> WithEmptyFragment (WeightedSelectView p)
view Chain hdr
ours) WithEmptyFragment (WeightedSelectView p)
candView =
        (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
-> Maybe (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
forall a. a -> Maybe a
Just (WithEmptyFragment (WeightedSelectView p)
candView, (Chain hdr, l)
x)
    | Bool
otherwise = Maybe (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l))
forall a. Maybe a
Nothing

-- | Chain selection on unvalidated chains
selectUnvalidatedChain ::
  ConsensusProtocol p =>
  proxy p ->
  ChainOrderConfig (WeightedSelectView p) ->
  (Chain hdr -> WithEmptyFragment (WeightedSelectView p)) ->
  Chain hdr ->
  [Chain hdr] ->
  Maybe (Chain hdr)
selectUnvalidatedChain :: forall p (proxy :: * -> *) hdr.
ConsensusProtocol p =>
proxy p
-> ChainOrderConfig (WeightedSelectView p)
-> (Chain hdr -> WithEmptyFragment (WeightedSelectView p))
-> Chain hdr
-> [Chain hdr]
-> Maybe (Chain hdr)
selectUnvalidatedChain proxy p
p ChainOrderConfig (WeightedSelectView p)
cfg Chain hdr -> WithEmptyFragment (WeightedSelectView p)
view Chain hdr
ours =
  ((Chain hdr, ()) -> Chain hdr)
-> Maybe (Chain hdr, ()) -> Maybe (Chain hdr)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Chain hdr, ()) -> Chain hdr
forall a b. (a, b) -> a
fst
    (Maybe (Chain hdr, ()) -> Maybe (Chain hdr))
-> ([Chain hdr] -> Maybe (Chain hdr, ()))
-> [Chain hdr]
-> Maybe (Chain hdr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy p
-> ChainOrderConfig (WeightedSelectView p)
-> (Chain hdr -> WithEmptyFragment (WeightedSelectView p))
-> Chain hdr
-> [(Chain hdr, ())]
-> Maybe (Chain hdr, ())
forall (proxy :: * -> *) p hdr l.
ConsensusProtocol p =>
proxy p
-> ChainOrderConfig (WeightedSelectView p)
-> (Chain hdr -> WithEmptyFragment (WeightedSelectView p))
-> Chain hdr
-> [(Chain hdr, l)]
-> Maybe (Chain hdr, l)
selectChain proxy p
p ChainOrderConfig (WeightedSelectView p)
cfg Chain hdr -> WithEmptyFragment (WeightedSelectView p)
view Chain hdr
ours
    ([(Chain hdr, ())] -> Maybe (Chain hdr, ()))
-> ([Chain hdr] -> [(Chain hdr, ())])
-> [Chain hdr]
-> Maybe (Chain hdr, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chain hdr -> (Chain hdr, ())) -> [Chain hdr] -> [(Chain hdr, ())]
forall a b. (a -> b) -> [a] -> [b]
map (,())