{-# LANGUAGE EmptyCase           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

-- | Infrastructure for doing chain selection across eras
module Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel (
    AcrossEraSelection(..)
  , acrossEraSelection
  , WithBlockNo(..)
  , mapWithBlockNo
  ) where

import           Data.Kind (Type)
import           Data.SOP.Strict

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.TypeFamilyWrappers
import           Ouroboros.Consensus.Util.Assert

import           Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
import           Ouroboros.Consensus.HardFork.Combinator.Util.Tails (Tails (..))

{-------------------------------------------------------------------------------
  Configuration
-------------------------------------------------------------------------------}

data AcrossEraSelection :: Type -> Type -> Type where
  -- | Just compare block numbers
  --
  -- This is a useful default when two eras run totally different consensus
  -- protocols, and we just want to choose the longer chain.
  CompareBlockNo :: AcrossEraSelection x y

  -- | Two eras running the same protocol
  --
  -- In this case, we can just call @compareCandidates@ even across eras.
  -- (The 'ChainSelConfig' must also be the same in both eras: we assert this
  -- at the value level.)
  --
  -- NOTE: We require that the eras have the same /protocol/, not merely the
  -- same 'SelectView', because if we have two eras with different protocols
  -- that happen to use the same 'SelectView' but a different way to compare
  -- chains, it's not clear how to do cross-era selection.
  SelectSameProtocol ::
       BlockProtocol x ~ BlockProtocol y
    => AcrossEraSelection x y

  -- | Custom chain selection
  --
  -- This is the most general form, and allows to override chain selection for
  -- the specific combination of two eras with a custom comparison function.
  CustomChainSel ::
       (    ChainSelConfig (BlockProtocol x)
         -> ChainSelConfig (BlockProtocol y)
         -> SelectView (BlockProtocol x)
         -> SelectView (BlockProtocol y)
         -> Ordering
       )
    -> AcrossEraSelection x y

{-------------------------------------------------------------------------------
  Compare two eras
-------------------------------------------------------------------------------}

withinEra ::
     forall blk. SingleEraBlock blk
  => WrapChainSelConfig blk
  -> WrapSelectView blk
  -> WrapSelectView blk
  -> Ordering
withinEra :: WrapChainSelConfig blk
-> WrapSelectView blk -> WrapSelectView blk -> Ordering
withinEra (WrapChainSelConfig ChainSelConfig (BlockProtocol blk)
cfg) (WrapSelectView SelectView (BlockProtocol blk)
l) (WrapSelectView SelectView (BlockProtocol blk)
r) =
    Proxy (BlockProtocol blk)
-> ChainSelConfig (BlockProtocol blk)
-> SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk)
-> Ordering
forall p (proxy :: * -> *).
ChainSelection p =>
proxy p
-> ChainSelConfig p -> SelectView p -> SelectView p -> Ordering
compareCandidates (Proxy (BlockProtocol blk)
forall k (t :: k). Proxy t
Proxy @(BlockProtocol blk)) ChainSelConfig (BlockProtocol blk)
cfg SelectView (BlockProtocol blk)
l SelectView (BlockProtocol blk)
r

acrossEras ::
     forall blk blk'. SingleEraBlock blk
  => WrapChainSelConfig blk
  -> WrapChainSelConfig blk'
  -> WithBlockNo WrapSelectView blk
  -> WithBlockNo WrapSelectView blk'
  -> AcrossEraSelection blk blk'
  -> Ordering
acrossEras :: WrapChainSelConfig blk
-> WrapChainSelConfig blk'
-> WithBlockNo WrapSelectView blk
-> WithBlockNo WrapSelectView blk'
-> AcrossEraSelection blk blk'
-> Ordering
acrossEras (WrapChainSelConfig ChainSelConfig (BlockProtocol blk)
cfgL)
           (WrapChainSelConfig ChainSelConfig (BlockProtocol blk')
cfgR)
           (WithBlockNo BlockNo
bnoL (WrapSelectView SelectView (BlockProtocol blk)
l))
           (WithBlockNo BlockNo
bnoR (WrapSelectView SelectView (BlockProtocol blk')
r)) = \case
    AcrossEraSelection blk blk'
CompareBlockNo     -> BlockNo -> BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare BlockNo
bnoL BlockNo
bnoR
    CustomChainSel ChainSelConfig (BlockProtocol blk)
-> ChainSelConfig (BlockProtocol blk')
-> SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk')
-> Ordering
f   -> ChainSelConfig (BlockProtocol blk)
-> ChainSelConfig (BlockProtocol blk')
-> SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk')
-> Ordering
f ChainSelConfig (BlockProtocol blk)
cfgL ChainSelConfig (BlockProtocol blk')
cfgR SelectView (BlockProtocol blk)
l SelectView (BlockProtocol blk')
r
    AcrossEraSelection blk blk'
SelectSameProtocol -> (ChainSelConfig (BlockProtocol blk),
 ChainSelConfig (BlockProtocol blk))
-> Ordering -> Ordering
forall b a. (Eq b, Show b, HasCallStack) => (b, b) -> a -> a
assertEqWithMsg (ChainSelConfig (BlockProtocol blk)
cfgL, ChainSelConfig (BlockProtocol blk)
ChainSelConfig (BlockProtocol blk')
cfgR) (Ordering -> Ordering) -> Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$
                            Proxy (BlockProtocol blk)
-> ChainSelConfig (BlockProtocol blk)
-> SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk)
-> Ordering
forall p (proxy :: * -> *).
ChainSelection p =>
proxy p
-> ChainSelConfig p -> SelectView p -> SelectView p -> Ordering
compareCandidates
                              (Proxy (BlockProtocol blk)
forall k (t :: k). Proxy t
Proxy @(BlockProtocol blk))
                              ChainSelConfig (BlockProtocol blk)
cfgL
                              SelectView (BlockProtocol blk)
l
                              SelectView (BlockProtocol blk)
SelectView (BlockProtocol blk')
r

acrossEraSelection ::
     All SingleEraBlock              xs
  => NP WrapChainSelConfig           xs
  -> Tails AcrossEraSelection        xs
  -> WithBlockNo (NS WrapSelectView) xs
  -> WithBlockNo (NS WrapSelectView) xs
  -> Ordering
acrossEraSelection :: NP WrapChainSelConfig xs
-> Tails AcrossEraSelection xs
-> WithBlockNo (NS WrapSelectView) xs
-> WithBlockNo (NS WrapSelectView) xs
-> Ordering
acrossEraSelection = \NP WrapChainSelConfig xs
cfgs Tails AcrossEraSelection xs
ffs WithBlockNo (NS WrapSelectView) xs
l WithBlockNo (NS WrapSelectView) xs
r ->
    NP WrapChainSelConfig xs
-> Tails AcrossEraSelection xs
-> (NS (WithBlockNo WrapSelectView) xs,
    NS (WithBlockNo WrapSelectView) xs)
-> Ordering
forall (xs :: [*]).
All SingleEraBlock xs =>
NP WrapChainSelConfig xs
-> Tails AcrossEraSelection xs
-> (NS (WithBlockNo WrapSelectView) xs,
    NS (WithBlockNo WrapSelectView) xs)
-> Ordering
goLeft NP WrapChainSelConfig xs
cfgs Tails AcrossEraSelection xs
ffs (WithBlockNo (NS WrapSelectView) xs
-> NS (WithBlockNo WrapSelectView) xs
forall k (xs :: [k]) (f :: k -> *).
SListI xs =>
WithBlockNo (NS f) xs -> NS (WithBlockNo f) xs
distribBlockNo WithBlockNo (NS WrapSelectView) xs
l, WithBlockNo (NS WrapSelectView) xs
-> NS (WithBlockNo WrapSelectView) xs
forall k (xs :: [k]) (f :: k -> *).
SListI xs =>
WithBlockNo (NS f) xs -> NS (WithBlockNo f) xs
distribBlockNo WithBlockNo (NS WrapSelectView) xs
r)
  where
    goLeft ::
         All SingleEraBlock                xs
      => NP WrapChainSelConfig             xs
      -> Tails AcrossEraSelection          xs
      -> ( NS (WithBlockNo WrapSelectView) xs
         , NS (WithBlockNo WrapSelectView) xs
         )
      -> Ordering
    goLeft :: NP WrapChainSelConfig xs
-> Tails AcrossEraSelection xs
-> (NS (WithBlockNo WrapSelectView) xs,
    NS (WithBlockNo WrapSelectView) xs)
-> Ordering
goLeft NP WrapChainSelConfig xs
_         Tails AcrossEraSelection xs
TNil            = \(NS (WithBlockNo WrapSelectView) xs
a, NS (WithBlockNo WrapSelectView) xs
_) -> case NS (WithBlockNo WrapSelectView) xs
a of {}
    goLeft (WrapChainSelConfig x
c :* NP WrapChainSelConfig xs
cs) (TCons NP (AcrossEraSelection x) xs
fs Tails AcrossEraSelection xs
ffs') = \case
        (Z WithBlockNo WrapSelectView x
a, Z WithBlockNo WrapSelectView x
b) -> WrapChainSelConfig x
-> WrapSelectView x -> WrapSelectView x -> Ordering
forall blk.
SingleEraBlock blk =>
WrapChainSelConfig blk
-> WrapSelectView blk -> WrapSelectView blk -> Ordering
withinEra WrapChainSelConfig x
c (WithBlockNo WrapSelectView x -> WrapSelectView x
forall k (f :: k -> *) (a :: k). WithBlockNo f a -> f a
dropBlockNo WithBlockNo WrapSelectView x
a) (WithBlockNo WrapSelectView x -> WrapSelectView x
forall k (f :: k -> *) (a :: k). WithBlockNo f a -> f a
dropBlockNo WithBlockNo WrapSelectView x
b)
        (Z WithBlockNo WrapSelectView x
a, S NS (WithBlockNo WrapSelectView) xs
b) ->          WrapChainSelConfig x
-> WithBlockNo WrapSelectView x
-> NP WrapChainSelConfig xs
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
forall x (xs :: [*]).
(SingleEraBlock x, All SingleEraBlock xs) =>
WrapChainSelConfig x
-> WithBlockNo WrapSelectView x
-> NP WrapChainSelConfig xs
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
goRight WrapChainSelConfig x
c WithBlockNo WrapSelectView x
WithBlockNo WrapSelectView x
a NP WrapChainSelConfig xs
cs NP (AcrossEraSelection x) xs
NP (AcrossEraSelection x) xs
fs NS (WithBlockNo WrapSelectView) xs
NS (WithBlockNo WrapSelectView) xs
b
        (S NS (WithBlockNo WrapSelectView) xs
a, Z WithBlockNo WrapSelectView x
b) -> Ordering -> Ordering
invert (Ordering -> Ordering) -> Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$ WrapChainSelConfig x
-> WithBlockNo WrapSelectView x
-> NP WrapChainSelConfig xs
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
forall x (xs :: [*]).
(SingleEraBlock x, All SingleEraBlock xs) =>
WrapChainSelConfig x
-> WithBlockNo WrapSelectView x
-> NP WrapChainSelConfig xs
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
goRight WrapChainSelConfig x
c WithBlockNo WrapSelectView x
WithBlockNo WrapSelectView x
b NP WrapChainSelConfig xs
cs NP (AcrossEraSelection x) xs
NP (AcrossEraSelection x) xs
fs NS (WithBlockNo WrapSelectView) xs
NS (WithBlockNo WrapSelectView) xs
a
        (S NS (WithBlockNo WrapSelectView) xs
a, S NS (WithBlockNo WrapSelectView) xs
b) -> NP WrapChainSelConfig xs
-> Tails AcrossEraSelection xs
-> (NS (WithBlockNo WrapSelectView) xs,
    NS (WithBlockNo WrapSelectView) xs)
-> Ordering
forall (xs :: [*]).
All SingleEraBlock xs =>
NP WrapChainSelConfig xs
-> Tails AcrossEraSelection xs
-> (NS (WithBlockNo WrapSelectView) xs,
    NS (WithBlockNo WrapSelectView) xs)
-> Ordering
goLeft NP WrapChainSelConfig xs
cs Tails AcrossEraSelection xs
Tails AcrossEraSelection xs
ffs' (NS (WithBlockNo WrapSelectView) xs
NS (WithBlockNo WrapSelectView) xs
a, NS (WithBlockNo WrapSelectView) xs
NS (WithBlockNo WrapSelectView) xs
b)

    goRight ::
         forall x xs. (SingleEraBlock x, All SingleEraBlock xs)
      => WrapChainSelConfig         x
      -> WithBlockNo WrapSelectView x
      -> NP WrapChainSelConfig           xs
      -> NP (AcrossEraSelection     x)   xs
      -> NS (WithBlockNo WrapSelectView) xs
      -> Ordering
    goRight :: WrapChainSelConfig x
-> WithBlockNo WrapSelectView x
-> NP WrapChainSelConfig xs
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
goRight WrapChainSelConfig x
cfgL WithBlockNo WrapSelectView x
a = NP WrapChainSelConfig xs
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
forall (xs' :: [*]).
All SingleEraBlock xs' =>
NP WrapChainSelConfig xs'
-> NP (AcrossEraSelection x) xs'
-> NS (WithBlockNo WrapSelectView) xs'
-> Ordering
go
      where
        go :: forall xs'. All SingleEraBlock  xs'
           => NP WrapChainSelConfig           xs'
           -> NP (AcrossEraSelection x)       xs'
           -> NS (WithBlockNo WrapSelectView) xs'
           -> Ordering
        go :: NP WrapChainSelConfig xs'
-> NP (AcrossEraSelection x) xs'
-> NS (WithBlockNo WrapSelectView) xs'
-> Ordering
go NP WrapChainSelConfig xs'
_         NP (AcrossEraSelection x) xs'
Nil          NS (WithBlockNo WrapSelectView) xs'
b  = case NS (WithBlockNo WrapSelectView) xs'
b of {}
        go (WrapChainSelConfig x
c :* NP WrapChainSelConfig xs
_)  (AcrossEraSelection x x
f :* NP (AcrossEraSelection x) xs
_)  (Z WithBlockNo WrapSelectView x
b) = WrapChainSelConfig x
-> WrapChainSelConfig x
-> WithBlockNo WrapSelectView x
-> WithBlockNo WrapSelectView x
-> AcrossEraSelection x x
-> Ordering
forall blk blk'.
SingleEraBlock blk =>
WrapChainSelConfig blk
-> WrapChainSelConfig blk'
-> WithBlockNo WrapSelectView blk
-> WithBlockNo WrapSelectView blk'
-> AcrossEraSelection blk blk'
-> Ordering
acrossEras WrapChainSelConfig x
cfgL WrapChainSelConfig x
c WithBlockNo WrapSelectView x
a WithBlockNo WrapSelectView x
WithBlockNo WrapSelectView x
b AcrossEraSelection x x
AcrossEraSelection x x
f
        go (WrapChainSelConfig x
_ :* NP WrapChainSelConfig xs
cs) (AcrossEraSelection x x
_ :* NP (AcrossEraSelection x) xs
fs) (S NS (WithBlockNo WrapSelectView) xs
b) = NP WrapChainSelConfig xs
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
forall (xs' :: [*]).
All SingleEraBlock xs' =>
NP WrapChainSelConfig xs'
-> NP (AcrossEraSelection x) xs'
-> NS (WithBlockNo WrapSelectView) xs'
-> Ordering
go NP WrapChainSelConfig xs
cs NP (AcrossEraSelection x) xs
NP (AcrossEraSelection x) xs
fs NS (WithBlockNo WrapSelectView) xs
NS (WithBlockNo WrapSelectView) xs
b

{-------------------------------------------------------------------------------
  WithBlockNo
-------------------------------------------------------------------------------}

data WithBlockNo (f :: k -> Type) (a :: k) = WithBlockNo {
      WithBlockNo f a -> BlockNo
getBlockNo  :: BlockNo
    , WithBlockNo f a -> f a
dropBlockNo :: f a
    }
  deriving (Int -> WithBlockNo f a -> ShowS
[WithBlockNo f a] -> ShowS
WithBlockNo f a -> String
(Int -> WithBlockNo f a -> ShowS)
-> (WithBlockNo f a -> String)
-> ([WithBlockNo f a] -> ShowS)
-> Show (WithBlockNo f a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (f :: k -> *) (a :: k).
Show (f a) =>
Int -> WithBlockNo f a -> ShowS
forall k (f :: k -> *) (a :: k).
Show (f a) =>
[WithBlockNo f a] -> ShowS
forall k (f :: k -> *) (a :: k).
Show (f a) =>
WithBlockNo f a -> String
showList :: [WithBlockNo f a] -> ShowS
$cshowList :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
[WithBlockNo f a] -> ShowS
show :: WithBlockNo f a -> String
$cshow :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
WithBlockNo f a -> String
showsPrec :: Int -> WithBlockNo f a -> ShowS
$cshowsPrec :: forall k (f :: k -> *) (a :: k).
Show (f a) =>
Int -> WithBlockNo f a -> ShowS
Show)

mapWithBlockNo :: (f x -> g y) -> WithBlockNo f x -> WithBlockNo g y
mapWithBlockNo :: (f x -> g y) -> WithBlockNo f x -> WithBlockNo g y
mapWithBlockNo f x -> g y
f (WithBlockNo BlockNo
bno f x
fx) = BlockNo -> g y -> WithBlockNo g y
forall k (f :: k -> *) (a :: k). BlockNo -> f a -> WithBlockNo f a
WithBlockNo BlockNo
bno (f x -> g y
f f x
fx)

distribBlockNo :: SListI xs => WithBlockNo (NS f) xs -> NS (WithBlockNo f) xs
distribBlockNo :: WithBlockNo (NS f) xs -> NS (WithBlockNo f) xs
distribBlockNo (WithBlockNo BlockNo
b NS f xs
ns) = (forall (a :: k). f a -> WithBlockNo f a)
-> NS f xs -> NS (WithBlockNo f) xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (BlockNo -> f a -> WithBlockNo f a
forall k (f :: k -> *) (a :: k). BlockNo -> f a -> WithBlockNo f a
WithBlockNo BlockNo
b) NS f xs
ns

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

invert :: Ordering -> Ordering
invert :: Ordering -> Ordering
invert Ordering
LT = Ordering
GT
invert Ordering
GT = Ordering
LT
invert Ordering
EQ = Ordering
EQ