{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Util.TentativeState (
    TentativeState (..)
  , preferToLastInvalidTentative
  ) where

import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Ledger.SupportsProtocol
                     (LedgerSupportsProtocol)
import           Ouroboros.Consensus.Protocol.Abstract (SelectView,
                     preferCandidate)

-- | Tentative header state in the context of diffusion pipelining. This is used
-- to check/enforce the monotonicity requirement on invalid tentative block
-- bodies.
--
--  * During chain selection, we maintain the last invalid tentative header to
--    ensure that the stream of tentative headers we sent downstream whose
--    blocks turned out to be invalid are strictly improving.
--  * In the BlockFetch client, we use it to enforce this property for each
--    upstream peer.
data TentativeState blk =
    LastInvalidTentative !(SelectView (BlockProtocol blk))
  | NoLastInvalidTentative
  deriving stock ((forall x. TentativeState blk -> Rep (TentativeState blk) x)
-> (forall x. Rep (TentativeState blk) x -> TentativeState blk)
-> Generic (TentativeState blk)
forall x. Rep (TentativeState blk) x -> TentativeState blk
forall x. TentativeState blk -> Rep (TentativeState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (TentativeState blk) x -> TentativeState blk
forall blk x. TentativeState blk -> Rep (TentativeState blk) x
$cto :: forall blk x. Rep (TentativeState blk) x -> TentativeState blk
$cfrom :: forall blk x. TentativeState blk -> Rep (TentativeState blk) x
Generic)

deriving stock    instance Show     (SelectView (BlockProtocol blk)) => Show     (TentativeState blk)
deriving stock    instance Eq       (SelectView (BlockProtocol blk)) => Eq       (TentativeState blk)
deriving anyclass instance NoThunks (SelectView (BlockProtocol blk)) => NoThunks (TentativeState blk)

preferToLastInvalidTentative ::
     forall blk.
     LedgerSupportsProtocol blk
  => BlockConfig blk
  -> TentativeState blk
  -> Header blk
  -> Bool
preferToLastInvalidTentative :: BlockConfig blk -> TentativeState blk -> Header blk -> Bool
preferToLastInvalidTentative BlockConfig blk
bcfg TentativeState blk
ts Header blk
hdr = case TentativeState blk
ts of
    LastInvalidTentative SelectView (BlockProtocol blk)
lastInvalid ->
      Proxy (BlockProtocol blk)
-> SelectView (BlockProtocol blk)
-> SelectView (BlockProtocol blk)
-> Bool
forall p (proxy :: * -> *).
ConsensusProtocol p =>
proxy p -> SelectView p -> SelectView p -> Bool
preferCandidate
        (Proxy (BlockProtocol blk)
forall k (t :: k). Proxy t
Proxy @(BlockProtocol blk))
        SelectView (BlockProtocol blk)
lastInvalid
        (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
bcfg Header blk
hdr)
    TentativeState blk
NoLastInvalidTentative -> Bool
True