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

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

import           Data.Function (on)
import           Data.List (sortBy)
import           Data.Maybe (listToMaybe)

import           Ouroboros.Network.MockChain.Chain (Chain)
import qualified Ouroboros.Network.MockChain.Chain as Chain

import           Ouroboros.Consensus.Protocol.Abstract

{-------------------------------------------------------------------------------
  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. ChainSelection p
            => proxy p
            -> (hdr -> SelectView p)
            -> ChainSelConfig p
            -> Chain hdr           -- ^ Our chain
            -> [(Chain hdr, l)]    -- ^ Upstream chains
            -> Maybe (Chain hdr, l)
selectChain :: proxy p
-> (hdr -> SelectView p)
-> ChainSelConfig p
-> Chain hdr
-> [(Chain hdr, l)]
-> Maybe (Chain hdr, l)
selectChain proxy p
p hdr -> SelectView p
view ChainSelConfig p
cfg Chain hdr
ours [(Chain hdr, l)]
candidates =
    [(Chain hdr, l)] -> Maybe (Chain hdr, l)
forall a. [a] -> Maybe a
listToMaybe ([(Chain hdr, l)] -> Maybe (Chain hdr, l))
-> [(Chain hdr, l)] -> Maybe (Chain hdr, l)
forall a b. (a -> b) -> a -> b
$
      ((Chain hdr, l) -> (Chain hdr, l) -> Ordering)
-> [(Chain hdr, l)] -> [(Chain hdr, l)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Chain hdr, l) -> (Chain hdr, l) -> Ordering)
-> (Chain hdr, l) -> (Chain hdr, l) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Chain hdr -> Chain hdr -> Ordering
compareCandidates' (Chain hdr -> Chain hdr -> Ordering)
-> ((Chain hdr, l) -> Chain hdr)
-> (Chain hdr, l)
-> (Chain hdr, l)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Chain hdr, l) -> Chain hdr
forall a b. (a, b) -> a
fst)) [(Chain hdr, l)]
preferredCandidates
  where
    preferredCandidates :: [(Chain hdr, l)]
    preferredCandidates :: [(Chain hdr, l)]
preferredCandidates = ((Chain hdr, l) -> Bool) -> [(Chain hdr, l)] -> [(Chain hdr, l)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Chain hdr -> Bool
preferCandidate' (Chain hdr -> Bool)
-> ((Chain hdr, l) -> Chain hdr) -> (Chain hdr, l) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chain hdr, l) -> Chain hdr
forall a b. (a, b) -> a
fst) [(Chain hdr, l)]
candidates

    -- A non-empty chain is always preferred over an empty one

    preferCandidate' :: Chain hdr -> Bool
    preferCandidate' :: Chain hdr -> Bool
preferCandidate' Chain hdr
theirs =
        Maybe hdr -> Maybe hdr -> Bool
go (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
theirs)
      where
        go :: Maybe hdr -> Maybe hdr -> Bool
        go :: Maybe hdr -> Maybe hdr -> Bool
go Maybe hdr
Nothing  Maybe hdr
Nothing  = Bool
False
        go Maybe hdr
Nothing  (Just hdr
_) = Bool
True
        go (Just hdr
_) Maybe hdr
Nothing  = Bool
False
        go (Just hdr
a) (Just hdr
b) = proxy p -> ChainSelConfig p -> SelectView p -> SelectView p -> Bool
forall p (proxy :: * -> *).
ChainSelection p =>
proxy p -> ChainSelConfig p -> SelectView p -> SelectView p -> Bool
preferCandidate proxy p
p ChainSelConfig p
cfg (hdr -> SelectView p
view hdr
a) (hdr -> SelectView p
view hdr
b)

    compareCandidates' :: Chain hdr -> Chain hdr -> Ordering
    compareCandidates' :: Chain hdr -> Chain hdr -> Ordering
compareCandidates' = Maybe hdr -> Maybe hdr -> Ordering
go (Maybe hdr -> Maybe hdr -> Ordering)
-> (Chain hdr -> Maybe hdr) -> Chain hdr -> Chain hdr -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Chain hdr -> Maybe hdr
forall b. Chain b -> Maybe b
Chain.head
      where
        go :: Maybe hdr -> Maybe hdr -> Ordering
        go :: Maybe hdr -> Maybe hdr -> Ordering
go Maybe hdr
Nothing  Maybe hdr
Nothing  = Ordering
EQ
        go Maybe hdr
Nothing  (Just hdr
_) = Ordering
LT
        go (Just hdr
_) Maybe hdr
Nothing  = Ordering
GT
        go (Just hdr
a) (Just hdr
b) = proxy p
-> ChainSelConfig p -> SelectView p -> SelectView p -> Ordering
forall p (proxy :: * -> *).
ChainSelection p =>
proxy p
-> ChainSelConfig p -> SelectView p -> SelectView p -> Ordering
compareCandidates proxy p
p ChainSelConfig p
cfg (hdr -> SelectView p
view hdr
a) (hdr -> SelectView p
view hdr
b)

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