{-# 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.Protocol.Abstract
import           Ouroboros.Network.Mock.Chain (Chain)
import qualified Ouroboros.Network.Mock.Chain as 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 (SelectView p)
            -> (hdr -> SelectView p)
            -> Chain hdr           -- ^ Our chain
            -> [(Chain hdr, l)]    -- ^ Upstream chains
            -> Maybe (Chain hdr, l)
selectChain :: forall (proxy :: * -> *) p hdr l.
ConsensusProtocol p =>
proxy p
-> ChainOrderConfig (SelectView p)
-> (hdr -> SelectView p)
-> Chain hdr
-> [(Chain hdr, l)]
-> Maybe (Chain hdr, l)
selectChain proxy p
_ ChainOrderConfig (SelectView p)
cfg hdr -> SelectView 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
. ((SelectView p, (Chain hdr, l)) -> (Chain hdr, l))
-> [(SelectView p, (Chain hdr, l))] -> [(Chain hdr, l)]
forall a b. (a -> b) -> [a] -> [b]
map (SelectView p, (Chain hdr, l)) -> (Chain hdr, l)
forall a b. (a, b) -> b
snd
    ([(SelectView p, (Chain hdr, l))] -> [(Chain hdr, l)])
-> ([(Chain hdr, l)] -> [(SelectView p, (Chain hdr, l))])
-> [(Chain hdr, l)]
-> [(Chain hdr, l)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SelectView p, (Chain hdr, l)) -> Down (SelectView p))
-> [(SelectView p, (Chain hdr, l))]
-> [(SelectView p, (Chain hdr, l))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (SelectView p -> Down (SelectView p)
forall a. a -> Down a
Down (SelectView p -> Down (SelectView p))
-> ((SelectView p, (Chain hdr, l)) -> SelectView p)
-> (SelectView p, (Chain hdr, l))
-> Down (SelectView p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SelectView p, (Chain hdr, l)) -> SelectView p
forall a b. (a, b) -> a
fst)
    ([(SelectView p, (Chain hdr, l))]
 -> [(SelectView p, (Chain hdr, l))])
-> ([(Chain hdr, l)] -> [(SelectView p, (Chain hdr, l))])
-> [(Chain hdr, l)]
-> [(SelectView p, (Chain hdr, l))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Chain hdr, l) -> Maybe (SelectView p, (Chain hdr, l)))
-> [(Chain hdr, l)] -> [(SelectView p, (Chain hdr, l))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Chain hdr, l) -> Maybe (SelectView 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 (SelectView p, (Chain hdr, l))
    selectPreferredCandidate :: (Chain hdr, l) -> Maybe (SelectView p, (Chain hdr, l))
selectPreferredCandidate x :: (Chain hdr, l)
x@(Chain hdr
cand, l
_) =
        case (Chain hdr -> Maybe hdr
forall b. Chain b -> Maybe b
Chain.head Chain hdr
ours, Chain hdr -> Maybe hdr
forall b. Chain b -> Maybe b
Chain.head Chain hdr
cand) of
          (Maybe hdr
Nothing, Just hdr
candTip)
            -> (SelectView p, (Chain hdr, l))
-> Maybe (SelectView p, (Chain hdr, l))
forall a. a -> Maybe a
Just (hdr -> SelectView p
view hdr
candTip, (Chain hdr, l)
x)
          (Just hdr
ourTip, Just hdr
candTip)
            | let candView :: SelectView p
candView = hdr -> SelectView p
view hdr
candTip
            , ChainOrderConfig (SelectView p)
-> SelectView p -> SelectView p -> Bool
forall sv. ChainOrder sv => ChainOrderConfig sv -> sv -> sv -> Bool
preferCandidate ChainOrderConfig (SelectView p)
cfg (hdr -> SelectView p
view hdr
ourTip) SelectView p
candView
            -> (SelectView p, (Chain hdr, l))
-> Maybe (SelectView p, (Chain hdr, l))
forall a. a -> Maybe a
Just (SelectView p
candView, (Chain hdr, l)
x)
          (Maybe hdr, Maybe hdr)
_otherwise
            -> Maybe (SelectView p, (Chain hdr, l))
forall a. Maybe a
Nothing

-- | Chain selection on unvalidated chains
selectUnvalidatedChain :: ConsensusProtocol p
                       => proxy p
                       -> ChainOrderConfig (SelectView p)
                       -> (hdr -> SelectView p)
                       -> Chain hdr
                       -> [Chain hdr]
                       -> Maybe (Chain hdr)
selectUnvalidatedChain :: forall p (proxy :: * -> *) hdr.
ConsensusProtocol p =>
proxy p
-> ChainOrderConfig (SelectView p)
-> (hdr -> SelectView p)
-> Chain hdr
-> [Chain hdr]
-> Maybe (Chain hdr)
selectUnvalidatedChain proxy p
p ChainOrderConfig (SelectView p)
cfg hdr -> SelectView 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 (SelectView p)
-> (hdr -> SelectView p)
-> Chain hdr
-> [(Chain hdr, ())]
-> Maybe (Chain hdr, ())
forall (proxy :: * -> *) p hdr l.
ConsensusProtocol p =>
proxy p
-> ChainOrderConfig (SelectView p)
-> (hdr -> SelectView p)
-> Chain hdr
-> [(Chain hdr, l)]
-> Maybe (Chain hdr, l)
selectChain proxy p
p ChainOrderConfig (SelectView p)
cfg hdr -> SelectView 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 (, ())