{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}

module Ouroboros.Consensus.HardFork.Combinator.Translation (
    -- * Translate from one era to the next
    EraTranslation (..)
  , ipTranslateTxOut
  , trivialEraTranslation
  ) where

import           Data.SOP.Constraint
import           Data.SOP.InPairs (InPairs (..), RequiringBoth (..))
import qualified Data.SOP.InPairs as InPairs
import           NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
import           Ouroboros.Consensus.HardFork.Combinator.State.Types
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.TypeFamilyWrappers

{-------------------------------------------------------------------------------
  Translate from one era to the next
-------------------------------------------------------------------------------}

data EraTranslation xs = EraTranslation {
      forall (xs :: [*]).
EraTranslation xs
-> InPairs (RequiringBoth WrapLedgerConfig TranslateLedgerState) xs
translateLedgerState   :: !(InPairs (RequiringBoth WrapLedgerConfig     TranslateLedgerState        ) xs)
    , forall (xs :: [*]).
EraTranslation xs -> InPairs TranslateLedgerTables xs
translateLedgerTables  :: !(InPairs                                     TranslateLedgerTables         xs)
    , forall (xs :: [*]).
EraTranslation xs
-> InPairs
     (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
     xs
translateChainDepState :: !(InPairs (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState)) xs)
    , forall (xs :: [*]).
EraTranslation xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
     xs
crossEraForecast       :: !(InPairs (RequiringBoth WrapLedgerConfig    (CrossEraForecaster LedgerState WrapLedgerView)) xs)
    }
  deriving Context -> EraTranslation xs -> IO (Maybe ThunkInfo)
Proxy (EraTranslation xs) -> String
(Context -> EraTranslation xs -> IO (Maybe ThunkInfo))
-> (Context -> EraTranslation xs -> IO (Maybe ThunkInfo))
-> (Proxy (EraTranslation xs) -> String)
-> NoThunks (EraTranslation xs)
forall (xs :: [*]).
Context -> EraTranslation xs -> IO (Maybe ThunkInfo)
forall (xs :: [*]). Proxy (EraTranslation xs) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall (xs :: [*]).
Context -> EraTranslation xs -> IO (Maybe ThunkInfo)
noThunks :: Context -> EraTranslation xs -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
Context -> EraTranslation xs -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> EraTranslation xs -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]). Proxy (EraTranslation xs) -> String
showTypeOf :: Proxy (EraTranslation xs) -> String
NoThunks
       via OnlyCheckWhnfNamed "EraTranslation" (EraTranslation xs)

ipTranslateTxOut ::
     All Top xs
  => EraTranslation xs
  -> InPairs TranslateTxOut xs
ipTranslateTxOut :: forall (xs :: [*]).
All Top xs =>
EraTranslation xs -> InPairs TranslateTxOut xs
ipTranslateTxOut = (forall x y. TranslateLedgerTables x y -> TranslateTxOut x y)
-> InPairs TranslateLedgerTables xs -> InPairs TranslateTxOut xs
forall {k} (xs :: [k]) (f :: k -> k -> *) (g :: k -> k -> *).
SListI xs =>
(forall (x :: k) (y :: k). f x y -> g x y)
-> InPairs f xs -> InPairs g xs
InPairs.hmap ((TxOut (LedgerState x) -> TxOut (LedgerState y))
-> TranslateTxOut x y
forall x y.
(TxOut (LedgerState x) -> TxOut (LedgerState y))
-> TranslateTxOut x y
TranslateTxOut ((TxOut (LedgerState x) -> TxOut (LedgerState y))
 -> TranslateTxOut x y)
-> (TranslateLedgerTables x y
    -> TxOut (LedgerState x) -> TxOut (LedgerState y))
-> TranslateLedgerTables x y
-> TranslateTxOut x y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslateLedgerTables x y
-> TxOut (LedgerState x) -> TxOut (LedgerState y)
forall x y.
TranslateLedgerTables x y
-> TxOut (LedgerState x) -> TxOut (LedgerState y)
translateTxOutWith) (InPairs TranslateLedgerTables xs -> InPairs TranslateTxOut xs)
-> (EraTranslation xs -> InPairs TranslateLedgerTables xs)
-> EraTranslation xs
-> InPairs TranslateTxOut xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraTranslation xs -> InPairs TranslateLedgerTables xs
forall (xs :: [*]).
EraTranslation xs -> InPairs TranslateLedgerTables xs
translateLedgerTables

trivialEraTranslation :: EraTranslation '[blk]
trivialEraTranslation :: forall blk. EraTranslation '[blk]
trivialEraTranslation = EraTranslation {
      translateLedgerState :: InPairs
  (RequiringBoth WrapLedgerConfig TranslateLedgerState) '[blk]
translateLedgerState   = InPairs
  (RequiringBoth WrapLedgerConfig TranslateLedgerState) '[blk]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
    , translateLedgerTables :: InPairs TranslateLedgerTables '[blk]
translateLedgerTables  = InPairs TranslateLedgerTables '[blk]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
    , crossEraForecast :: InPairs
  (RequiringBoth
     WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
  '[blk]
crossEraForecast       = InPairs
  (RequiringBoth
     WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
  '[blk]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
    , translateChainDepState :: InPairs
  (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
  '[blk]
translateChainDepState = InPairs
  (RequiringBoth WrapConsensusConfig (Translate WrapChainDepState))
  '[blk]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
PNil
    }