{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
  ( -- * Single era block
    SingleEraBlock (..)
  , proxySingle
  , singleEraTransition'

    -- * Era index
  , EraIndex (..)
  , eraIndexEmpty
  , eraIndexFromIndex
  , eraIndexFromNS
  , eraIndexSucc
  , eraIndexToInt
  , eraIndexZero
  ) where

import Codec.Serialise
import Data.Either (isRight)
import Data.Proxy
import Data.SOP.BasicFunctors
import Data.SOP.Constraint
import Data.SOP.Index
import Data.SOP.Match
import Data.SOP.Strict
import qualified Data.Text as Text
import Data.Void
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config.SupportsNode
import Ouroboros.Consensus.HardFork.Combinator.Info
import Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import Ouroboros.Consensus.HardFork.History (Bound, EraParams)
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.CommonProtocolParams
import Ouroboros.Consensus.Ledger.Inspect
import Ouroboros.Consensus.Ledger.Query
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Ledger.SupportsPeerSelection
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Node.InitStorage
import Ouroboros.Consensus.Node.Serialisation
import Ouroboros.Consensus.Storage.Serialisation
import Ouroboros.Consensus.Ticked
import Ouroboros.Consensus.Util.Condense

{-------------------------------------------------------------------------------
  SingleEraBlock
-------------------------------------------------------------------------------}

-- | Blocks from which we can assemble a hard fork
class
  ( LedgerSupportsProtocol blk
  , InspectLedger blk
  , LedgerSupportsMempool blk
  , ConvertRawTxId (GenTx blk)
  , BlockSupportsLedgerQuery blk
  , HasPartialConsensusConfig (BlockProtocol blk)
  , HasPartialLedgerConfig blk
  , ConvertRawHash blk
  , ReconstructNestedCtxt Header blk
  , CommonProtocolParams blk
  , LedgerSupportsPeerSelection blk
  , ConfigSupportsNode blk
  , NodeInitStorage blk
  , BlockSupportsDiffusionPipelining blk
  , BlockSupportsMetrics blk
  , SerialiseNodeToClient blk (PartialLedgerConfig blk)
  , -- LedgerTables
    CanStowLedgerTables (LedgerState blk)
  , HasLedgerTables (LedgerState blk)
  , HasLedgerTables (Ticked (LedgerState blk))
  , -- Instances required to support testing
    Eq (GenTx blk)
  , Eq (Validated (GenTx blk))
  , Eq (ApplyTxErr blk)
  , Show blk
  , Show (Header blk)
  , Show (CannotForge blk)
  , Show (ForgeStateInfo blk)
  , Show (ForgeStateUpdateError blk)
  ) =>
  SingleEraBlock blk
  where
  -- | Era transition
  --
  -- This should only report the transition point once it is stable (rollback
  -- cannot affect it anymore).
  --
  -- Since we need this to construct the 'HardForkSummary' (and hence the
  -- 'EpochInfo'), this takes the /partial/ config, not the full config
  -- (or we'd end up with a catch-22).
  singleEraTransition ::
    PartialLedgerConfig blk ->
    -- | Current era parameters
    EraParams ->
    -- | Start of this era
    Bound ->
    LedgerState blk mk ->
    Maybe EpochNo

  -- | Era information (for use in error messages)
  singleEraInfo :: proxy blk -> SingleEraInfo blk

proxySingle :: Proxy SingleEraBlock
proxySingle :: Proxy SingleEraBlock
proxySingle = Proxy SingleEraBlock
forall {k} (t :: k). Proxy t
Proxy

singleEraTransition' ::
  SingleEraBlock blk =>
  WrapPartialLedgerConfig blk ->
  EraParams ->
  Bound ->
  LedgerState blk mk ->
  Maybe EpochNo
singleEraTransition' :: forall blk (mk :: MapKind).
SingleEraBlock blk =>
WrapPartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk mk -> Maybe EpochNo
singleEraTransition' = PartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk mk -> Maybe EpochNo
forall blk (mk :: MapKind).
SingleEraBlock blk =>
PartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk mk -> Maybe EpochNo
forall (mk :: MapKind).
PartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk mk -> Maybe EpochNo
singleEraTransition (PartialLedgerConfig blk
 -> EraParams -> Bound -> LedgerState blk mk -> Maybe EpochNo)
-> (WrapPartialLedgerConfig blk -> PartialLedgerConfig blk)
-> WrapPartialLedgerConfig blk
-> EraParams
-> Bound
-> LedgerState blk mk
-> Maybe EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk
forall blk. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk
unwrapPartialLedgerConfig

{-------------------------------------------------------------------------------
  Era index
-------------------------------------------------------------------------------}

newtype EraIndex xs = EraIndex
  { forall (xs :: [*]). EraIndex xs -> NS (K ()) xs
getEraIndex :: NS (K ()) xs
  }

instance Eq (EraIndex xs) where
  EraIndex NS (K ()) xs
era == :: EraIndex xs -> EraIndex xs -> Bool
== EraIndex NS (K ()) xs
era' = Either (Mismatch (K ()) (K ()) xs) (NS (Product (K ()) (K ())) xs)
-> Bool
forall a b. Either a b -> Bool
isRight (NS (K ()) xs
-> NS (K ()) xs
-> Either
     (Mismatch (K ()) (K ()) xs) (NS (Product (K ()) (K ())) xs)
forall {k} (f :: k -> *) (xs :: [k]) (g :: k -> *).
NS f xs
-> NS g xs -> Either (Mismatch f g xs) (NS (Product f g) xs)
matchNS NS (K ()) xs
era NS (K ()) xs
era')

instance All SingleEraBlock xs => Show (EraIndex xs) where
  show :: EraIndex xs -> String
show = NS (K String) xs -> String
NS (K String) xs -> CollapseTo NS String
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K String) xs -> String)
-> (EraIndex xs -> NS (K String) xs) -> EraIndex xs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a. SingleEraBlock a => K () a -> K String a)
-> NS (K ()) xs
-> NS (K String) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap Proxy SingleEraBlock
proxySingle K () a -> K String a
forall a. SingleEraBlock a => K () a -> K String a
getEraName (NS (K ()) xs -> NS (K String) xs)
-> (EraIndex xs -> NS (K ()) xs) -> EraIndex xs -> NS (K String) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraIndex xs -> NS (K ()) xs
forall (xs :: [*]). EraIndex xs -> NS (K ()) xs
getEraIndex
   where
    getEraName ::
      forall blk.
      SingleEraBlock blk =>
      K () blk -> K String blk
    getEraName :: forall a. SingleEraBlock a => K () a -> K String a
getEraName K () blk
_ =
      String -> K String blk
forall k a (b :: k). a -> K a b
K
        (String -> K String blk)
-> (SingleEraInfo blk -> String)
-> SingleEraInfo blk
-> K String blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\String
name -> String
"<EraIndex " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
">")
        ShowS
-> (SingleEraInfo blk -> String) -> SingleEraInfo blk -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
        (Text -> String)
-> (SingleEraInfo blk -> Text) -> SingleEraInfo blk -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleEraInfo blk -> Text
forall blk. SingleEraInfo blk -> Text
singleEraName
        (SingleEraInfo blk -> K String blk)
-> SingleEraInfo blk -> K String blk
forall a b. (a -> b) -> a -> b
$ Proxy blk -> SingleEraInfo blk
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy blk -> SingleEraInfo blk
singleEraInfo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)

instance All SingleEraBlock xs => Condense (EraIndex xs) where
  condense :: EraIndex xs -> String
condense = NS (K String) xs -> String
NS (K String) xs -> CollapseTo NS String
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K String) xs -> String)
-> (EraIndex xs -> NS (K String) xs) -> EraIndex xs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a. SingleEraBlock a => K () a -> K String a)
-> NS (K ()) xs
-> NS (K String) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap Proxy SingleEraBlock
proxySingle K () a -> K String a
forall a. SingleEraBlock a => K () a -> K String a
getEraName (NS (K ()) xs -> NS (K String) xs)
-> (EraIndex xs -> NS (K ()) xs) -> EraIndex xs -> NS (K String) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraIndex xs -> NS (K ()) xs
forall (xs :: [*]). EraIndex xs -> NS (K ()) xs
getEraIndex
   where
    getEraName ::
      forall blk.
      SingleEraBlock blk =>
      K () blk -> K String blk
    getEraName :: forall a. SingleEraBlock a => K () a -> K String a
getEraName K () blk
_ =
      String -> K String blk
forall k a (b :: k). a -> K a b
K
        (String -> K String blk)
-> (SingleEraInfo blk -> String)
-> SingleEraInfo blk
-> K String blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
        (Text -> String)
-> (SingleEraInfo blk -> Text) -> SingleEraInfo blk -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleEraInfo blk -> Text
forall blk. SingleEraInfo blk -> Text
singleEraName
        (SingleEraInfo blk -> K String blk)
-> SingleEraInfo blk -> K String blk
forall a b. (a -> b) -> a -> b
$ Proxy blk -> SingleEraInfo blk
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy blk -> SingleEraInfo blk
singleEraInfo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)

instance SListI xs => Serialise (EraIndex xs) where
  encode :: EraIndex xs -> Encoding
encode = Word8 -> Encoding
forall a. Serialise a => a -> Encoding
encode (Word8 -> Encoding)
-> (EraIndex xs -> Word8) -> EraIndex xs -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS (K ()) xs -> Word8
forall {k} (xs :: [k]) (f :: k -> *). SListI xs => NS f xs -> Word8
nsToIndex (NS (K ()) xs -> Word8)
-> (EraIndex xs -> NS (K ()) xs) -> EraIndex xs -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraIndex xs -> NS (K ()) xs
forall (xs :: [*]). EraIndex xs -> NS (K ()) xs
getEraIndex
  decode :: forall s. Decoder s (EraIndex xs)
decode = do
    idx <- Decoder s Word8
forall s. Decoder s Word8
forall a s. Serialise a => Decoder s a
decode
    case nsFromIndex idx of
      Maybe (NS (K ()) xs)
Nothing -> String -> Decoder s (EraIndex xs)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s (EraIndex xs))
-> String -> Decoder s (EraIndex xs)
forall a b. (a -> b) -> a -> b
$ String
"EraIndex: invalid index " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
idx
      Just NS (K ()) xs
eraIndex -> EraIndex xs -> Decoder s (EraIndex xs)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (NS (K ()) xs -> EraIndex xs
forall (xs :: [*]). NS (K ()) xs -> EraIndex xs
EraIndex NS (K ()) xs
eraIndex)

eraIndexEmpty :: EraIndex '[] -> Void
eraIndexEmpty :: EraIndex '[] -> Void
eraIndexEmpty (EraIndex NS (K ()) '[]
ns) = case NS (K ()) '[]
ns of {}

eraIndexFromNS :: SListI xs => NS f xs -> EraIndex xs
eraIndexFromNS :: forall (xs :: [*]) (f :: * -> *).
SListI xs =>
NS f xs -> EraIndex xs
eraIndexFromNS = NS (K ()) xs -> EraIndex xs
forall (xs :: [*]). NS (K ()) xs -> EraIndex xs
EraIndex (NS (K ()) xs -> EraIndex xs)
-> (NS f xs -> NS (K ()) xs) -> NS f xs -> EraIndex xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. f a -> K () a) -> NS f xs -> NS (K ()) 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 (K () a -> f a -> K () a
forall a b. a -> b -> a
const (() -> K () a
forall k a (b :: k). a -> K a b
K ()))

eraIndexFromIndex :: SListI xs => Index xs blk -> EraIndex xs
eraIndexFromIndex :: forall (xs :: [*]) blk. SListI xs => Index xs blk -> EraIndex xs
eraIndexFromIndex Index xs blk
index = NS (K ()) xs -> EraIndex xs
forall (xs :: [*]). NS (K ()) xs -> EraIndex xs
EraIndex (NS (K ()) xs -> EraIndex xs) -> NS (K ()) xs -> EraIndex xs
forall a b. (a -> b) -> a -> b
$ Index xs blk -> K () blk -> NS (K ()) xs
forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
All Top xs =>
Index xs x -> f x -> NS f xs
injectNS Index xs blk
index (() -> K () blk
forall k a (b :: k). a -> K a b
K ())

eraIndexZero :: EraIndex (x ': xs)
eraIndexZero :: forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero = NS (K ()) (x : xs) -> EraIndex (x : xs)
forall (xs :: [*]). NS (K ()) xs -> EraIndex xs
EraIndex (K () x -> NS (K ()) (x : xs)
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NS f (x : xs1)
Z (() -> K () x
forall k a (b :: k). a -> K a b
K ()))

eraIndexSucc :: EraIndex xs -> EraIndex (x ': xs)
eraIndexSucc :: forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc (EraIndex NS (K ()) xs
ix) = NS (K ()) (x : xs) -> EraIndex (x : xs)
forall (xs :: [*]). NS (K ()) xs -> EraIndex xs
EraIndex (NS (K ()) xs -> NS (K ()) (x : xs)
forall {k} (f :: k -> *) (xs1 :: [k]) (x :: k).
NS f xs1 -> NS f (x : xs1)
S NS (K ()) xs
ix)

eraIndexToInt :: EraIndex xs -> Int
eraIndexToInt :: forall (xs :: [*]). EraIndex xs -> Int
eraIndexToInt = NS (K ()) xs -> Int
forall {k} (f :: k -> *) (xs :: [k]). NS f xs -> Int
index_NS (NS (K ()) xs -> Int)
-> (EraIndex xs -> NS (K ()) xs) -> EraIndex xs -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraIndex xs -> NS (K ()) xs
forall (xs :: [*]). EraIndex xs -> NS (K ()) xs
getEraIndex