{-# 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.Strict
import qualified Data.Text as Text
import           Data.Void

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config.SupportsNode
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.Storage.Serialisation
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.SOP

import           Ouroboros.Consensus.HardFork.Combinator.Info
import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import           Ouroboros.Consensus.HardFork.Combinator.Util.Match

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

-- | Blocks from which we can assemble a hard fork
class ( LedgerSupportsProtocol blk
      , InspectLedger blk
      , LedgerSupportsMempool blk
      , HasTxId (GenTx blk)
      , QueryLedger blk
      , HasPartialConsensusConfig (BlockProtocol blk)
      , HasPartialLedgerConfig blk
      , ConvertRawHash blk
      , ReconstructNestedCtxt Header blk
      , CommonProtocolParams blk
      , LedgerSupportsPeerSelection blk
      , ConfigSupportsNode blk
      , NodeInitStorage blk
      , BlockSupportsMetrics 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
                      -> EraParams -- ^ Current era parameters
                      -> Bound     -- ^ Start of this era
                      -> LedgerState blk
                      -> 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 -> Maybe EpochNo
singleEraTransition' :: WrapPartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo
singleEraTransition' = PartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo
forall blk.
SingleEraBlock blk =>
PartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo
singleEraTransition (PartialLedgerConfig blk
 -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo)
-> (WrapPartialLedgerConfig blk -> PartialLedgerConfig blk)
-> WrapPartialLedgerConfig blk
-> EraParams
-> Bound
-> LedgerState blk
-> 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 {
      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
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 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 :: K () blk -> K String blk
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
singleEraInfo (Proxy blk
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
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 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 :: K () blk -> K String blk
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
singleEraInfo (Proxy blk
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 :: Decoder s (EraIndex xs)
decode = do
    Word8
idx <- Decoder s Word8
forall a s. Serialise a => Decoder s a
decode
    case Word8 -> Maybe (NS (K ()) xs)
forall k (xs :: [k]). SListI xs => Word8 -> Maybe (NS (K ()) xs)
nsFromIndex Word8
idx of
      Maybe (NS (K ()) xs)
Nothing       -> String -> Decoder s (EraIndex xs)
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 (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 :: 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 :: Index xs blk -> EraIndex xs
eraIndexFromIndex :: 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]).
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 :: 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 a (f :: a -> *) (x :: a) (xs :: [a]). f x -> NS f (x : xs)
Z (() -> K () x
forall k a (b :: k). a -> K a b
K ()))

eraIndexSucc :: EraIndex xs -> EraIndex (x ': xs)
eraIndexSucc :: 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 a (f :: a -> *) (xs :: [a]) (x :: a).
NS f xs -> NS f (x : xs)
S NS (K ()) xs
ix)

eraIndexToInt :: EraIndex xs -> Int
eraIndexToInt :: 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