{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# 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 (..)
  , WithBlockNo (..)
  , acrossEraSelection
  , mapWithBlockNo
  ) where

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

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

import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)
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 @compareChains@ 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 ::
       (    SelectView (BlockProtocol x)
         -> SelectView (BlockProtocol y)
         -> Ordering
       )
    -> AcrossEraSelection x y

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

acrossEras ::
     forall blk blk'. SingleEraBlock blk
  => WithBlockNo WrapSelectView blk
  -> WithBlockNo WrapSelectView blk'
  -> AcrossEraSelection blk blk'
  -> Ordering
acrossEras :: WithBlockNo WrapSelectView blk
-> WithBlockNo WrapSelectView blk'
-> AcrossEraSelection blk blk'
-> Ordering
acrossEras (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 SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk') -> Ordering
f   -> SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk') -> Ordering
f SelectView (BlockProtocol blk)
l SelectView (BlockProtocol blk')
r
    AcrossEraSelection blk blk'
SelectSameProtocol -> SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare SelectView (BlockProtocol blk)
l SelectView (BlockProtocol blk)
SelectView (BlockProtocol blk')
r

acrossEraSelection ::
     All SingleEraBlock              xs
  => Tails AcrossEraSelection        xs
  -> WithBlockNo (NS WrapSelectView) xs
  -> WithBlockNo (NS WrapSelectView) xs
  -> Ordering
acrossEraSelection :: Tails AcrossEraSelection xs
-> WithBlockNo (NS WrapSelectView) xs
-> WithBlockNo (NS WrapSelectView) xs
-> Ordering
acrossEraSelection = \Tails AcrossEraSelection xs
ffs WithBlockNo (NS WrapSelectView) xs
l WithBlockNo (NS WrapSelectView) xs
r ->
    Tails AcrossEraSelection xs
-> (NS (WithBlockNo WrapSelectView) xs,
    NS (WithBlockNo WrapSelectView) xs)
-> Ordering
forall (xs :: [*]).
All SingleEraBlock xs =>
Tails AcrossEraSelection xs
-> (NS (WithBlockNo WrapSelectView) xs,
    NS (WithBlockNo WrapSelectView) xs)
-> Ordering
goLeft 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
      => Tails AcrossEraSelection          xs
      -> ( NS (WithBlockNo WrapSelectView) xs
         , NS (WithBlockNo WrapSelectView) xs
         )
      -> Ordering
    goLeft :: Tails AcrossEraSelection xs
-> (NS (WithBlockNo WrapSelectView) xs,
    NS (WithBlockNo WrapSelectView) xs)
-> Ordering
goLeft Tails AcrossEraSelection xs
TNil            = \(NS (WithBlockNo WrapSelectView) xs
a, NS (WithBlockNo WrapSelectView) xs
_) -> case NS (WithBlockNo WrapSelectView) xs
a of {}
    goLeft (TCons NP (AcrossEraSelection x) xs
fs Tails AcrossEraSelection xs
ffs') = \case
        (Z WithBlockNo WrapSelectView x
a, Z WithBlockNo WrapSelectView x
b) -> WrapSelectView x -> WrapSelectView x -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (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) ->          WithBlockNo WrapSelectView x
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
forall x (xs :: [*]).
(SingleEraBlock x, All SingleEraBlock xs) =>
WithBlockNo WrapSelectView x
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
goRight WithBlockNo WrapSelectView x
a 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
$ WithBlockNo WrapSelectView x
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
forall x (xs :: [*]).
(SingleEraBlock x, All SingleEraBlock xs) =>
WithBlockNo WrapSelectView x
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
goRight WithBlockNo WrapSelectView x
b 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) -> Tails AcrossEraSelection xs
-> (NS (WithBlockNo WrapSelectView) xs,
    NS (WithBlockNo WrapSelectView) xs)
-> Ordering
forall (xs :: [*]).
All SingleEraBlock xs =>
Tails AcrossEraSelection xs
-> (NS (WithBlockNo WrapSelectView) xs,
    NS (WithBlockNo WrapSelectView) xs)
-> Ordering
goLeft 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)
      => WithBlockNo WrapSelectView x
      -> NP (AcrossEraSelection     x)   xs
      -> NS (WithBlockNo WrapSelectView) xs
      -> Ordering
    goRight :: WithBlockNo WrapSelectView x
-> NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs
-> Ordering
goRight WithBlockNo WrapSelectView x
a = NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs -> Ordering
forall (xs' :: [*]).
All SingleEraBlock xs' =>
NP (AcrossEraSelection x) xs'
-> NS (WithBlockNo WrapSelectView) xs' -> Ordering
go
      where
        go :: forall xs'. All SingleEraBlock  xs'
           => NP (AcrossEraSelection x)       xs'
           -> NS (WithBlockNo WrapSelectView) xs'
           -> Ordering
        go :: NP (AcrossEraSelection x) xs'
-> NS (WithBlockNo WrapSelectView) xs' -> Ordering
go NP (AcrossEraSelection x) xs'
Nil          NS (WithBlockNo WrapSelectView) xs'
b  = case NS (WithBlockNo WrapSelectView) xs'
b of {}
        go (AcrossEraSelection x x
f :* NP (AcrossEraSelection x) xs
_)  (Z WithBlockNo WrapSelectView x
b) = WithBlockNo WrapSelectView x
-> WithBlockNo WrapSelectView x
-> AcrossEraSelection x x
-> Ordering
forall blk blk'.
SingleEraBlock blk =>
WithBlockNo WrapSelectView blk
-> WithBlockNo WrapSelectView blk'
-> AcrossEraSelection blk blk'
-> Ordering
acrossEras WithBlockNo WrapSelectView x
a WithBlockNo WrapSelectView x
b AcrossEraSelection x x
AcrossEraSelection x x
f
        go (AcrossEraSelection x x
_ :* NP (AcrossEraSelection x) xs
fs) (S NS (WithBlockNo WrapSelectView) xs
b) = NP (AcrossEraSelection x) xs
-> NS (WithBlockNo WrapSelectView) xs -> Ordering
forall (xs' :: [*]).
All SingleEraBlock xs' =>
NP (AcrossEraSelection x) xs'
-> NS (WithBlockNo WrapSelectView) xs' -> Ordering
go 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, WithBlockNo f a -> WithBlockNo f a -> Bool
(WithBlockNo f a -> WithBlockNo f a -> Bool)
-> (WithBlockNo f a -> WithBlockNo f a -> Bool)
-> Eq (WithBlockNo f a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (f :: k -> *) (a :: k).
Eq (f a) =>
WithBlockNo f a -> WithBlockNo f a -> Bool
/= :: WithBlockNo f a -> WithBlockNo f a -> Bool
$c/= :: forall k (f :: k -> *) (a :: k).
Eq (f a) =>
WithBlockNo f a -> WithBlockNo f a -> Bool
== :: WithBlockNo f a -> WithBlockNo f a -> Bool
$c== :: forall k (f :: k -> *) (a :: k).
Eq (f a) =>
WithBlockNo f a -> WithBlockNo f a -> Bool
Eq, (forall x. WithBlockNo f a -> Rep (WithBlockNo f a) x)
-> (forall x. Rep (WithBlockNo f a) x -> WithBlockNo f a)
-> Generic (WithBlockNo f a)
forall x. Rep (WithBlockNo f a) x -> WithBlockNo f a
forall x. WithBlockNo f a -> Rep (WithBlockNo f a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (f :: k -> *) (a :: k) x.
Rep (WithBlockNo f a) x -> WithBlockNo f a
forall k (f :: k -> *) (a :: k) x.
WithBlockNo f a -> Rep (WithBlockNo f a) x
$cto :: forall k (f :: k -> *) (a :: k) x.
Rep (WithBlockNo f a) x -> WithBlockNo f a
$cfrom :: forall k (f :: k -> *) (a :: k) x.
WithBlockNo f a -> Rep (WithBlockNo f a) x
Generic, Context -> WithBlockNo f a -> IO (Maybe ThunkInfo)
Proxy (WithBlockNo f a) -> String
(Context -> WithBlockNo f a -> IO (Maybe ThunkInfo))
-> (Context -> WithBlockNo f a -> IO (Maybe ThunkInfo))
-> (Proxy (WithBlockNo f a) -> String)
-> NoThunks (WithBlockNo f a)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall k (f :: k -> *) (a :: k).
NoThunks (f a) =>
Context -> WithBlockNo f a -> IO (Maybe ThunkInfo)
forall k (f :: k -> *) (a :: k).
NoThunks (f a) =>
Proxy (WithBlockNo f a) -> String
showTypeOf :: Proxy (WithBlockNo f a) -> String
$cshowTypeOf :: forall k (f :: k -> *) (a :: k).
NoThunks (f a) =>
Proxy (WithBlockNo f a) -> String
wNoThunks :: Context -> WithBlockNo f a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall k (f :: k -> *) (a :: k).
NoThunks (f a) =>
Context -> WithBlockNo f a -> IO (Maybe ThunkInfo)
noThunks :: Context -> WithBlockNo f a -> IO (Maybe ThunkInfo)
$cnoThunks :: forall k (f :: k -> *) (a :: k).
NoThunks (f a) =>
Context -> WithBlockNo f a -> IO (Maybe ThunkInfo)
NoThunks)

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