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

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

import Data.Kind (Type)
import Data.SOP.Constraint
import Data.SOP.Strict
import Data.SOP.Tails (Tails (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.TypeFamilyWrappers

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

-- | How to compare chains of equal length across eras.
data AcrossEraTiebreaker :: Type -> Type -> Type where
  -- | No preference.
  NoTiebreakerAcrossEras :: AcrossEraTiebreaker x y
  -- | Two eras using the same 'TiebreakerView', so use the corresponding
  -- (identical) tiebreaker.
  --
  -- We use the 'ChainOrderConfig' of the 'TiebreakerView' in the newer era
  -- (with the intuition that newer eras are generally "preferred") when
  -- invoking 'compareChains'. However, this choice is arbitrary; we could also
  -- make it configurable here.
  SameTiebreakerAcrossEras ::
    TiebreakerView (BlockProtocol x) ~ TiebreakerView (BlockProtocol y) =>
    AcrossEraTiebreaker x y

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

-- | GADT indicating whether we are lifting 'compare' or 'preferCandidate' to
-- the HFC, together with the type of configuration we need for that and the
-- result type.
data AcrossEraMode cfg a where
  AcrossEraCompare :: AcrossEraMode Proxy Ordering
  AcrossEraPreferCandidate :: AcrossEraMode WrapChainOrderConfig Bool

applyAcrossEraMode ::
  ChainOrder tv =>
  cfg blk ->
  (WrapChainOrderConfig blk -> ChainOrderConfig tv) ->
  AcrossEraMode cfg a ->
  tv ->
  tv ->
  a
applyAcrossEraMode :: forall tv (cfg :: * -> *) blk a.
ChainOrder tv =>
cfg blk
-> (WrapChainOrderConfig blk -> ChainOrderConfig tv)
-> AcrossEraMode cfg a
-> tv
-> tv
-> a
applyAcrossEraMode cfg blk
cfg WrapChainOrderConfig blk -> ChainOrderConfig tv
f = \case
  AcrossEraMode cfg a
AcrossEraCompare -> tv -> tv -> a
tv -> tv -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
  AcrossEraMode cfg a
AcrossEraPreferCandidate -> ChainOrderConfig tv -> tv -> tv -> Bool
forall sv. ChainOrder sv => ChainOrderConfig sv -> sv -> sv -> Bool
preferCandidate (WrapChainOrderConfig blk -> ChainOrderConfig tv
f cfg blk
WrapChainOrderConfig blk
cfg)

data FlipArgs = KeepArgs | FlipArgs

acrossEras ::
  forall blk blk' cfg a.
  SingleEraBlock blk =>
  FlipArgs ->
  AcrossEraMode cfg a ->
  -- | The configuration corresponding to the later block/era, also see
  -- 'SameTiebreakerAcrossEras'.
  cfg blk' ->
  WrapTiebreakerView blk ->
  WrapTiebreakerView blk' ->
  AcrossEraTiebreaker blk blk' ->
  a
acrossEras :: forall blk blk' (cfg :: * -> *) a.
SingleEraBlock blk =>
FlipArgs
-> AcrossEraMode cfg a
-> cfg blk'
-> WrapTiebreakerView blk
-> WrapTiebreakerView blk'
-> AcrossEraTiebreaker blk blk'
-> a
acrossEras
  FlipArgs
flipArgs
  AcrossEraMode cfg a
mode
  cfg blk'
cfg
  (WrapTiebreakerView TiebreakerView (BlockProtocol blk)
l)
  (WrapTiebreakerView TiebreakerView (BlockProtocol blk')
r) = \case
    AcrossEraTiebreaker blk blk'
NoTiebreakerAcrossEras -> (NoTiebreaker -> NoTiebreaker -> a)
-> NoTiebreaker -> NoTiebreaker -> a
forall b. (b -> b -> a) -> b -> b -> a
maybeFlip NoTiebreaker -> NoTiebreaker -> a
cmp NoTiebreaker
NoTiebreaker NoTiebreaker
NoTiebreaker
     where
      cmp :: NoTiebreaker -> NoTiebreaker -> a
cmp = cfg blk'
-> (WrapChainOrderConfig blk' -> ChainOrderConfig NoTiebreaker)
-> AcrossEraMode cfg a
-> NoTiebreaker
-> NoTiebreaker
-> a
forall tv (cfg :: * -> *) blk a.
ChainOrder tv =>
cfg blk
-> (WrapChainOrderConfig blk -> ChainOrderConfig tv)
-> AcrossEraMode cfg a
-> tv
-> tv
-> a
applyAcrossEraMode cfg blk'
cfg (() -> WrapChainOrderConfig blk' -> ()
forall a b. a -> b -> a
const ()) AcrossEraMode cfg a
mode
    AcrossEraTiebreaker blk blk'
SameTiebreakerAcrossEras -> (TiebreakerView (BlockProtocol blk')
 -> TiebreakerView (BlockProtocol blk') -> a)
-> TiebreakerView (BlockProtocol blk')
-> TiebreakerView (BlockProtocol blk')
-> a
forall b. (b -> b -> a) -> b -> b -> a
maybeFlip TiebreakerView (BlockProtocol blk')
-> TiebreakerView (BlockProtocol blk') -> a
cmp TiebreakerView (BlockProtocol blk)
TiebreakerView (BlockProtocol blk')
l TiebreakerView (BlockProtocol blk')
r
     where
      cmp :: TiebreakerView (BlockProtocol blk')
-> TiebreakerView (BlockProtocol blk') -> a
cmp = cfg blk'
-> (WrapChainOrderConfig blk'
    -> ChainOrderConfig (TiebreakerView (BlockProtocol blk')))
-> AcrossEraMode cfg a
-> TiebreakerView (BlockProtocol blk')
-> TiebreakerView (BlockProtocol blk')
-> a
forall tv (cfg :: * -> *) blk a.
ChainOrder tv =>
cfg blk
-> (WrapChainOrderConfig blk -> ChainOrderConfig tv)
-> AcrossEraMode cfg a
-> tv
-> tv
-> a
applyAcrossEraMode cfg blk'
cfg WrapChainOrderConfig blk'
-> ChainOrderConfig (TiebreakerView (BlockProtocol blk'))
forall blk.
WrapChainOrderConfig blk
-> ChainOrderConfig (TiebreakerView (BlockProtocol blk))
unwrapChainOrderConfig AcrossEraMode cfg a
mode
   where
    maybeFlip :: (b -> b -> a) -> b -> b -> a
    maybeFlip :: forall b. (b -> b -> a) -> b -> b -> a
maybeFlip = case FlipArgs
flipArgs of
      FlipArgs
KeepArgs -> (b -> b -> a) -> b -> b -> a
forall a. a -> a
id
      FlipArgs
FlipArgs -> (b -> b -> a) -> b -> b -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip

acrossEraSelection ::
  forall xs cfg a.
  All SingleEraBlock xs =>
  AcrossEraMode cfg a ->
  NP cfg xs ->
  Tails AcrossEraTiebreaker xs ->
  NS WrapTiebreakerView xs ->
  NS WrapTiebreakerView xs ->
  a
acrossEraSelection :: forall (xs :: [*]) (cfg :: * -> *) a.
All SingleEraBlock xs =>
AcrossEraMode cfg a
-> NP cfg xs
-> Tails AcrossEraTiebreaker xs
-> NS WrapTiebreakerView xs
-> NS WrapTiebreakerView xs
-> a
acrossEraSelection AcrossEraMode cfg a
mode = \NP cfg xs
cfg Tails AcrossEraTiebreaker xs
ffs NS WrapTiebreakerView xs
l NS WrapTiebreakerView xs
r ->
  NP cfg xs
-> Tails AcrossEraTiebreaker xs
-> (NS WrapTiebreakerView xs, NS WrapTiebreakerView xs)
-> a
forall (xs' :: [*]).
All SingleEraBlock xs' =>
NP cfg xs'
-> Tails AcrossEraTiebreaker xs'
-> (NS WrapTiebreakerView xs', NS WrapTiebreakerView xs')
-> a
goBoth NP cfg xs
cfg Tails AcrossEraTiebreaker xs
ffs (NS WrapTiebreakerView xs
l, NS WrapTiebreakerView xs
r)
 where
  goBoth ::
    All SingleEraBlock xs' =>
    NP cfg xs' ->
    Tails AcrossEraTiebreaker xs' ->
    ( NS WrapTiebreakerView xs'
    , NS WrapTiebreakerView xs'
    ) ->
    a
  goBoth :: forall (xs' :: [*]).
All SingleEraBlock xs' =>
NP cfg xs'
-> Tails AcrossEraTiebreaker xs'
-> (NS WrapTiebreakerView xs', NS WrapTiebreakerView xs')
-> a
goBoth NP cfg xs'
_ Tails AcrossEraTiebreaker xs'
TNil = \(NS WrapTiebreakerView xs'
a, NS WrapTiebreakerView xs'
_) -> case NS WrapTiebreakerView xs'
a of {}
  goBoth (cfg x
cfg :* NP cfg xs1
cfgs) (TCons NP (AcrossEraTiebreaker x) xs1
fs Tails AcrossEraTiebreaker xs1
ffs') = \case
    (Z WrapTiebreakerView x
a, Z WrapTiebreakerView x
b) -> WrapTiebreakerView x -> WrapTiebreakerView x -> a
cmp WrapTiebreakerView x
a WrapTiebreakerView x
WrapTiebreakerView x
b
     where
      cmp :: WrapTiebreakerView x -> WrapTiebreakerView x -> a
cmp = cfg x
-> (WrapChainOrderConfig x
    -> ChainOrderConfig (WrapTiebreakerView x))
-> AcrossEraMode cfg a
-> WrapTiebreakerView x
-> WrapTiebreakerView x
-> a
forall tv (cfg :: * -> *) blk a.
ChainOrder tv =>
cfg blk
-> (WrapChainOrderConfig blk -> ChainOrderConfig tv)
-> AcrossEraMode cfg a
-> tv
-> tv
-> a
applyAcrossEraMode cfg x
cfg WrapChainOrderConfig x
-> ChainOrderConfig (TiebreakerView (BlockProtocol x))
WrapChainOrderConfig x -> ChainOrderConfig (WrapTiebreakerView x)
forall blk.
WrapChainOrderConfig blk
-> ChainOrderConfig (TiebreakerView (BlockProtocol blk))
unwrapChainOrderConfig AcrossEraMode cfg a
mode
    (Z WrapTiebreakerView x
a, S NS WrapTiebreakerView xs1
b) -> FlipArgs
-> WrapTiebreakerView x
-> NP cfg xs1
-> NP (AcrossEraTiebreaker x) xs1
-> NS WrapTiebreakerView xs1
-> a
forall x (xs' :: [*]).
(SingleEraBlock x, All SingleEraBlock xs') =>
FlipArgs
-> WrapTiebreakerView x
-> NP cfg xs'
-> NP (AcrossEraTiebreaker x) xs'
-> NS WrapTiebreakerView xs'
-> a
goOne FlipArgs
KeepArgs WrapTiebreakerView x
a NP cfg xs1
cfgs NP (AcrossEraTiebreaker x) xs1
NP (AcrossEraTiebreaker x) xs1
fs NS WrapTiebreakerView xs1
NS WrapTiebreakerView xs1
b
    (S NS WrapTiebreakerView xs1
a, Z WrapTiebreakerView x
b) -> FlipArgs
-> WrapTiebreakerView x
-> NP cfg xs1
-> NP (AcrossEraTiebreaker x) xs1
-> NS WrapTiebreakerView xs1
-> a
forall x (xs' :: [*]).
(SingleEraBlock x, All SingleEraBlock xs') =>
FlipArgs
-> WrapTiebreakerView x
-> NP cfg xs'
-> NP (AcrossEraTiebreaker x) xs'
-> NS WrapTiebreakerView xs'
-> a
goOne FlipArgs
FlipArgs WrapTiebreakerView x
b NP cfg xs1
cfgs NP (AcrossEraTiebreaker x) xs1
NP (AcrossEraTiebreaker x) xs1
fs NS WrapTiebreakerView xs1
NS WrapTiebreakerView xs1
a
    (S NS WrapTiebreakerView xs1
a, S NS WrapTiebreakerView xs1
b) -> NP cfg xs1
-> Tails AcrossEraTiebreaker xs1
-> (NS WrapTiebreakerView xs1, NS WrapTiebreakerView xs1)
-> a
forall (xs' :: [*]).
All SingleEraBlock xs' =>
NP cfg xs'
-> Tails AcrossEraTiebreaker xs'
-> (NS WrapTiebreakerView xs', NS WrapTiebreakerView xs')
-> a
goBoth NP cfg xs1
cfgs Tails AcrossEraTiebreaker xs1
Tails AcrossEraTiebreaker xs1
ffs' (NS WrapTiebreakerView xs1
NS WrapTiebreakerView xs1
a, NS WrapTiebreakerView xs1
NS WrapTiebreakerView xs1
b)

  goOne ::
    forall x xs'.
    (SingleEraBlock x, All SingleEraBlock xs') =>
    FlipArgs ->
    WrapTiebreakerView x ->
    NP cfg xs' ->
    NP (AcrossEraTiebreaker x) xs' ->
    NS WrapTiebreakerView xs' ->
    a
  goOne :: forall x (xs' :: [*]).
(SingleEraBlock x, All SingleEraBlock xs') =>
FlipArgs
-> WrapTiebreakerView x
-> NP cfg xs'
-> NP (AcrossEraTiebreaker x) xs'
-> NS WrapTiebreakerView xs'
-> a
goOne FlipArgs
flipArgs WrapTiebreakerView x
a = NP cfg xs'
-> NP (AcrossEraTiebreaker x) xs' -> NS WrapTiebreakerView xs' -> a
forall (xs'' :: [*]).
All SingleEraBlock xs'' =>
NP cfg xs''
-> NP (AcrossEraTiebreaker x) xs''
-> NS WrapTiebreakerView xs''
-> a
go
   where
    go ::
      forall xs''.
      All SingleEraBlock xs'' =>
      NP cfg xs'' ->
      NP (AcrossEraTiebreaker x) xs'' ->
      NS WrapTiebreakerView xs'' ->
      a
    go :: forall (xs'' :: [*]).
All SingleEraBlock xs'' =>
NP cfg xs''
-> NP (AcrossEraTiebreaker x) xs''
-> NS WrapTiebreakerView xs''
-> a
go NP cfg xs''
_ NP (AcrossEraTiebreaker x) xs''
Nil NS WrapTiebreakerView xs''
b = case NS WrapTiebreakerView xs''
b of {}
    go (cfg x
cfg :* NP cfg xs1
_) (AcrossEraTiebreaker x x
f :* NP (AcrossEraTiebreaker x) xs1
_) (Z WrapTiebreakerView x
b) = FlipArgs
-> AcrossEraMode cfg a
-> cfg x
-> WrapTiebreakerView x
-> WrapTiebreakerView x
-> AcrossEraTiebreaker x x
-> a
forall blk blk' (cfg :: * -> *) a.
SingleEraBlock blk =>
FlipArgs
-> AcrossEraMode cfg a
-> cfg blk'
-> WrapTiebreakerView blk
-> WrapTiebreakerView blk'
-> AcrossEraTiebreaker blk blk'
-> a
acrossEras FlipArgs
flipArgs AcrossEraMode cfg a
mode cfg x
cfg WrapTiebreakerView x
a WrapTiebreakerView x
WrapTiebreakerView x
b AcrossEraTiebreaker x x
AcrossEraTiebreaker x x
f
    go (cfg x
_ :* NP cfg xs1
cfgs) (AcrossEraTiebreaker x x
_ :* NP (AcrossEraTiebreaker x) xs1
fs) (S NS WrapTiebreakerView xs1
b) = NP cfg xs1
-> NP (AcrossEraTiebreaker x) xs1 -> NS WrapTiebreakerView xs1 -> a
forall (xs'' :: [*]).
All SingleEraBlock xs'' =>
NP cfg xs''
-> NP (AcrossEraTiebreaker x) xs''
-> NS WrapTiebreakerView xs''
-> a
go NP cfg xs1
cfgs NP (AcrossEraTiebreaker x) xs1
NP (AcrossEraTiebreaker x) xs1
fs NS WrapTiebreakerView xs1
NS WrapTiebreakerView xs1
b