{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Intended for qualified import
--
-- > import Ouroboros.Consensus.HardFork.Combinator.State (HardForkState(..))
-- > import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
module Ouroboros.Consensus.HardFork.Combinator.State (
    module X
    -- * Support for defining instances
  , getTip
    -- * Serialisation support
  , recover
    -- * EpochInfo
  , epochInfoLedger
  , epochInfoPrecomputedTransitionInfo
  , mostRecentTransitionInfo
  , reconstructSummaryLedger
    -- * Ledger specific functionality
  , extendToSlot
  ) where

import           Prelude hiding (sequence)

import           Control.Monad (guard)
import           Data.Functor.Product
import           Data.Proxy
import           Data.SOP.Strict hiding (shape)

import           Ouroboros.Consensus.Block
import qualified Ouroboros.Consensus.HardFork.History as History
import           Ouroboros.Consensus.Ledger.Abstract hiding (getTip)
import           Ouroboros.Consensus.Util ((.:))
import           Ouroboros.Consensus.Util.Counting (getExactly)

import           Ouroboros.Consensus.HardFork.Combinator.Abstract
import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import           Ouroboros.Consensus.HardFork.Combinator.Basics
import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import           Ouroboros.Consensus.HardFork.Combinator.Translation
import           Ouroboros.Consensus.HardFork.Combinator.Util.InPairs (InPairs,
                     Requiring (..))
import qualified Ouroboros.Consensus.HardFork.Combinator.Util.InPairs as InPairs
import           Ouroboros.Consensus.HardFork.Combinator.Util.Telescope
                     (Extend (..), ScanNext (..), Telescope)
import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Telescope as Telescope

import           Ouroboros.Consensus.HardFork.Combinator.State.Infra as X
import           Ouroboros.Consensus.HardFork.Combinator.State.Instances as X ()
import           Ouroboros.Consensus.HardFork.Combinator.State.Types as X

{-------------------------------------------------------------------------------
  GetTip
-------------------------------------------------------------------------------}

getTip :: forall f xs. CanHardFork xs
       => (forall blk. SingleEraBlock blk => f blk -> Point blk)
       -> HardForkState f xs -> Point (HardForkBlock xs)
getTip :: (forall blk. SingleEraBlock blk => f blk -> Point blk)
-> HardForkState f xs -> Point (HardForkBlock xs)
getTip forall blk. SingleEraBlock blk => f blk -> Point blk
getLedgerTip =
      NS (K (Point (HardForkBlock xs))) xs -> Point (HardForkBlock xs)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
    (NS (K (Point (HardForkBlock xs))) xs -> Point (HardForkBlock xs))
-> (HardForkState f xs -> NS (K (Point (HardForkBlock xs))) xs)
-> HardForkState f xs
-> Point (HardForkBlock xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    f a -> K (Point (HardForkBlock xs)) a)
-> NS f xs
-> NS (K (Point (HardForkBlock xs))) 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 (Point (HardForkBlock xs) -> K (Point (HardForkBlock xs)) a
forall k a (b :: k). a -> K a b
K (Point (HardForkBlock xs) -> K (Point (HardForkBlock xs)) a)
-> (f a -> Point (HardForkBlock xs))
-> f a
-> K (Point (HardForkBlock xs)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point a -> Point (HardForkBlock xs)
forall blk.
SingleEraBlock blk =>
Point blk -> Point (HardForkBlock xs)
injPoint (Point a -> Point (HardForkBlock xs))
-> (f a -> Point a) -> f a -> Point (HardForkBlock xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Point a
forall blk. SingleEraBlock blk => f blk -> Point blk
getLedgerTip)
    (NS f xs -> NS (K (Point (HardForkBlock xs))) xs)
-> (HardForkState f xs -> NS f xs)
-> HardForkState f xs
-> NS (K (Point (HardForkBlock xs))) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkState f xs -> NS f xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
tip
  where
    injPoint :: forall blk. SingleEraBlock blk
             => Point blk -> Point (HardForkBlock xs)
    injPoint :: Point blk -> Point (HardForkBlock xs)
injPoint Point blk
GenesisPoint     = Point (HardForkBlock xs)
forall block. Point block
GenesisPoint
    injPoint (BlockPoint SlotNo
s HeaderHash blk
h) = SlotNo -> HeaderHash (HardForkBlock xs) -> Point (HardForkBlock xs)
forall block. SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
s (HeaderHash (HardForkBlock xs) -> Point (HardForkBlock xs))
-> HeaderHash (HardForkBlock xs) -> Point (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$ ShortByteString -> OneEraHash xs
forall k (xs :: [k]). ShortByteString -> OneEraHash xs
OneEraHash (ShortByteString -> OneEraHash xs)
-> ShortByteString -> OneEraHash xs
forall a b. (a -> b) -> a -> b
$
                                  Proxy blk -> HeaderHash blk -> ShortByteString
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ShortByteString
toShortRawHash (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) HeaderHash blk
h

{-------------------------------------------------------------------------------
  Recovery
-------------------------------------------------------------------------------}

-- | Recover 'HardForkState' from partial information
--
-- The primary goal of this is to make sure that for the /current/ state we
-- really only need to store the underlying @f@. It is not strictly essential
-- that this is possible but it helps with the unary hardfork case, and it may
-- in general help with binary compatibility.
recover :: forall f xs. CanHardFork xs
        => Telescope (K Past) f xs -> HardForkState f xs
recover :: Telescope (K Past) f xs -> HardForkState f xs
recover =
    case Proxy xs -> ProofNonEmpty xs
forall a (xs :: [a]) (proxy :: [a] -> *).
IsNonEmpty xs =>
proxy xs -> ProofNonEmpty xs
isNonEmpty (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs) of
      ProofNonEmpty {} ->
          Telescope (K Past) (Current f) (x : xs) -> HardForkState f (x : xs)
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState
        (Telescope (K Past) (Current f) (x : xs)
 -> HardForkState f (x : xs))
-> (Telescope (K Past) f (x : xs)
    -> Telescope (K Past) (Current f) (x : xs))
-> Telescope (K Past) f (x : xs)
-> HardForkState f (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Product (K Bound) (K Past) x -> K Past x)
-> (forall x. Product (K Bound) f x -> Current f x)
-> Telescope
     (Product (K Bound) (K Past)) (Product (K Bound) f) (x : xs)
-> Telescope (K Past) (Current f) (x : xs)
forall k (xs :: [k]) (g :: k -> *) (g' :: k -> *) (f :: k -> *)
       (f' :: k -> *).
SListI xs =>
(forall (x :: k). g x -> g' x)
-> (forall (x :: k). f x -> f' x)
-> Telescope g f xs
-> Telescope g' f' xs
Telescope.bihmap
            (\(Pair _ past) -> K Past x
past)
            forall x. Product (K Bound) f x -> Current f x
recoverCurrent
        (Telescope
   (Product (K Bound) (K Past)) (Product (K Bound) f) (x : xs)
 -> Telescope (K Past) (Current f) (x : xs))
-> (Telescope (K Past) f (x : xs)
    -> Telescope
         (Product (K Bound) (K Past)) (Product (K Bound) f) (x : xs))
-> Telescope (K Past) f (x : xs)
-> Telescope (K Past) (Current f) (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InPairs (ScanNext (K Bound) (K Past)) (x : xs)
-> K Bound x
-> Telescope (K Past) f (x : xs)
-> Telescope
     (Product (K Bound) (K Past)) (Product (K Bound) f) (x : xs)
forall a (h :: a -> *) (g :: a -> *) (x :: a) (xs :: [a])
       (f :: a -> *).
InPairs (ScanNext h g) (x : xs)
-> h x
-> Telescope g f (x : xs)
-> Telescope (Product h g) (Product h f) (x : xs)
Telescope.scanl
            ((forall x y. ScanNext (K Bound) (K Past) x y)
-> InPairs (ScanNext (K Bound) (K Past)) (x : xs)
forall k (xs :: [k]) (f :: k -> k -> *).
(SListI xs, IsNonEmpty xs) =>
(forall (x :: k) (y :: k). f x y) -> InPairs f xs
InPairs.hpure ((forall x y. ScanNext (K Bound) (K Past) x y)
 -> InPairs (ScanNext (K Bound) (K Past)) (x : xs))
-> (forall x y. ScanNext (K Bound) (K Past) x y)
-> InPairs (ScanNext (K Bound) (K Past)) (x : xs)
forall a b. (a -> b) -> a -> b
$ (K Bound x -> K Past x -> K Bound y)
-> ScanNext (K Bound) (K Past) x y
forall k (h :: k -> *) (g :: k -> *) (x :: k) (y :: k).
(h x -> g x -> h y) -> ScanNext h g x y
ScanNext ((K Bound x -> K Past x -> K Bound y)
 -> ScanNext (K Bound) (K Past) x y)
-> (K Bound x -> K Past x -> K Bound y)
-> ScanNext (K Bound) (K Past) x y
forall a b. (a -> b) -> a -> b
$ (K Past x -> K Bound y) -> K Bound x -> K Past x -> K Bound y
forall a b. a -> b -> a
const ((K Past x -> K Bound y) -> K Bound x -> K Past x -> K Bound y)
-> (K Past x -> K Bound y) -> K Bound x -> K Past x -> K Bound y
forall a b. (a -> b) -> a -> b
$ Bound -> K Bound y
forall k a (b :: k). a -> K a b
K (Bound -> K Bound y)
-> (K Past x -> Bound) -> K Past x -> K Bound y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Past -> Bound
pastEnd (Past -> Bound) -> (K Past x -> Past) -> K Past x -> Bound
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K Past x -> Past
forall k a (b :: k). K a b -> a
unK)
            (Bound -> K Bound x
forall k a (b :: k). a -> K a b
K Bound
History.initBound)
  where
    recoverCurrent :: Product (K History.Bound) f blk -> Current f blk
    recoverCurrent :: Product (K Bound) f blk -> Current f blk
recoverCurrent (Pair (K Bound
prevEnd) f blk
st) = Current :: forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current {
          currentStart :: Bound
currentStart = Bound
prevEnd
        , currentState :: f blk
currentState = f blk
st
        }

{-------------------------------------------------------------------------------
  Reconstruct EpochInfo
-------------------------------------------------------------------------------}

mostRecentTransitionInfo :: All SingleEraBlock xs
                         => HardForkLedgerConfig xs
                         -> HardForkState LedgerState xs
                         -> TransitionInfo
mostRecentTransitionInfo :: HardForkLedgerConfig xs
-> HardForkState LedgerState xs -> TransitionInfo
mostRecentTransitionInfo HardForkLedgerConfig{Shape xs
PerEraLedgerConfig xs
hardForkLedgerConfigPerEra :: forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs
hardForkLedgerConfigShape :: Shape xs
..} HardForkState LedgerState xs
st =
    NS (K TransitionInfo) xs -> CollapseTo NS TransitionInfo
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K TransitionInfo) xs -> CollapseTo NS TransitionInfo)
-> NS (K TransitionInfo) xs -> CollapseTo NS TransitionInfo
forall a b. (a -> b) -> a -> b
$
      Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialLedgerConfig a
    -> K EraParams a -> Current LedgerState a -> K TransitionInfo a)
-> Prod NS WrapPartialLedgerConfig xs
-> Prod NS (K EraParams) xs
-> NS (Current LedgerState) xs
-> NS (K TransitionInfo) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *) (f''' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a -> f''' a)
-> Prod h f xs
-> Prod h f' xs
-> h f'' xs
-> h f''' xs
hczipWith3
        Proxy SingleEraBlock
proxySingle
        forall a.
SingleEraBlock a =>
WrapPartialLedgerConfig a
-> K EraParams a -> Current LedgerState a -> K TransitionInfo a
getTransition
        Prod NS WrapPartialLedgerConfig xs
NP WrapPartialLedgerConfig xs
cfgs
        (Exactly xs EraParams -> NP (K EraParams) xs
forall (xs :: [*]) a. Exactly xs a -> NP (K a) xs
getExactly (Shape xs -> Exactly xs EraParams
forall (xs :: [*]). Shape xs -> Exactly xs EraParams
History.getShape Shape xs
hardForkLedgerConfigShape))
        (Telescope (K Past) (Current LedgerState) xs
-> NS (Current LedgerState) xs
forall k (g :: k -> *) (f :: k -> *) (xs :: [k]).
Telescope g f xs -> NS f xs
Telescope.tip (HardForkState LedgerState xs
-> Telescope (K Past) (Current LedgerState) xs
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState HardForkState LedgerState xs
st))
  where
    cfgs :: NP WrapPartialLedgerConfig xs
cfgs = PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
getPerEraLedgerConfig PerEraLedgerConfig xs
hardForkLedgerConfigPerEra

    getTransition :: SingleEraBlock          blk
                  => WrapPartialLedgerConfig blk
                  -> K History.EraParams     blk
                  -> Current LedgerState     blk
                  -> K TransitionInfo        blk
    getTransition :: WrapPartialLedgerConfig blk
-> K EraParams blk
-> Current LedgerState blk
-> K TransitionInfo blk
getTransition WrapPartialLedgerConfig blk
cfg (K EraParams
eraParams) Current{LedgerState blk
Bound
currentState :: LedgerState blk
currentStart :: Bound
currentState :: forall (f :: * -> *) blk. Current f blk -> f blk
currentStart :: forall (f :: * -> *) blk. Current f blk -> Bound
..} = TransitionInfo -> K TransitionInfo blk
forall k a (b :: k). a -> K a b
K (TransitionInfo -> K TransitionInfo blk)
-> TransitionInfo -> K TransitionInfo blk
forall a b. (a -> b) -> a -> b
$
        case WrapPartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo
forall blk.
SingleEraBlock blk =>
WrapPartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo
singleEraTransition' WrapPartialLedgerConfig blk
cfg EraParams
eraParams Bound
currentStart LedgerState blk
currentState of
          Maybe EpochNo
Nothing -> WithOrigin SlotNo -> TransitionInfo
TransitionUnknown (LedgerState blk -> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot LedgerState blk
currentState)
          Just EpochNo
e  -> EpochNo -> TransitionInfo
TransitionKnown EpochNo
e

reconstructSummaryLedger :: All SingleEraBlock xs
                         => HardForkLedgerConfig xs
                         -> HardForkState LedgerState xs
                         -> History.Summary xs
reconstructSummaryLedger :: HardForkLedgerConfig xs
-> HardForkState LedgerState xs -> Summary xs
reconstructSummaryLedger cfg :: HardForkLedgerConfig xs
cfg@HardForkLedgerConfig{Shape xs
PerEraLedgerConfig xs
hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs
hardForkLedgerConfigShape :: Shape xs
hardForkLedgerConfigPerEra :: forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
..} HardForkState LedgerState xs
st =
    Shape xs
-> TransitionInfo -> HardForkState LedgerState xs -> Summary xs
forall (xs :: [*]) (f :: * -> *).
Shape xs -> TransitionInfo -> HardForkState f xs -> Summary xs
reconstructSummary
      Shape xs
hardForkLedgerConfigShape
      (HardForkLedgerConfig xs
-> HardForkState LedgerState xs -> TransitionInfo
forall (xs :: [*]).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState LedgerState xs -> TransitionInfo
mostRecentTransitionInfo HardForkLedgerConfig xs
cfg HardForkState LedgerState xs
st)
      HardForkState LedgerState xs
st

-- | Construct 'EpochInfo' from the ledger state
--
-- NOTE: The resulting 'EpochInfo' is a snapshot only, with a limited range.
-- It should not be stored.
epochInfoLedger :: All SingleEraBlock xs
                => HardForkLedgerConfig xs
                -> HardForkState LedgerState xs
                -> EpochInfo (Except PastHorizonException)
epochInfoLedger :: HardForkLedgerConfig xs
-> HardForkState LedgerState xs
-> EpochInfo (Except PastHorizonException)
epochInfoLedger HardForkLedgerConfig xs
cfg HardForkState LedgerState xs
st =
    Summary xs -> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
Summary xs -> EpochInfo (Except PastHorizonException)
History.summaryToEpochInfo (Summary xs -> EpochInfo (Except PastHorizonException))
-> Summary xs -> EpochInfo (Except PastHorizonException)
forall a b. (a -> b) -> a -> b
$
      HardForkLedgerConfig xs
-> HardForkState LedgerState xs -> Summary xs
forall (xs :: [*]).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState LedgerState xs -> Summary xs
reconstructSummaryLedger HardForkLedgerConfig xs
cfg HardForkState LedgerState xs
st

-- | Construct 'EpochInfo' given precomputed 'TransitionInfo'
--
-- The transition and state arguments are acquired either from a ticked ledger
-- state or a ticked ledger view.
epochInfoPrecomputedTransitionInfo ::
     History.Shape xs
  -> TransitionInfo
  -> HardForkState f xs
  -> EpochInfo (Except PastHorizonException)
epochInfoPrecomputedTransitionInfo :: Shape xs
-> TransitionInfo
-> HardForkState f xs
-> EpochInfo (Except PastHorizonException)
epochInfoPrecomputedTransitionInfo Shape xs
shape TransitionInfo
transition HardForkState f xs
st =
    Summary xs -> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
Summary xs -> EpochInfo (Except PastHorizonException)
History.summaryToEpochInfo (Summary xs -> EpochInfo (Except PastHorizonException))
-> Summary xs -> EpochInfo (Except PastHorizonException)
forall a b. (a -> b) -> a -> b
$
      Shape xs -> TransitionInfo -> HardForkState f xs -> Summary xs
forall (xs :: [*]) (f :: * -> *).
Shape xs -> TransitionInfo -> HardForkState f xs -> Summary xs
reconstructSummary Shape xs
shape TransitionInfo
transition HardForkState f xs
st

{-------------------------------------------------------------------------------
  Extending
-------------------------------------------------------------------------------}

-- | Extend the telescope until the specified slot is within the era at the tip
extendToSlot :: forall xs. CanHardFork xs
             => HardForkLedgerConfig xs
             -> SlotNo
             -> HardForkState LedgerState xs -> HardForkState LedgerState xs
extendToSlot :: HardForkLedgerConfig xs
-> SlotNo
-> HardForkState LedgerState xs
-> HardForkState LedgerState xs
extendToSlot ledgerCfg :: HardForkLedgerConfig xs
ledgerCfg@HardForkLedgerConfig{Shape xs
PerEraLedgerConfig xs
hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs
hardForkLedgerConfigShape :: Shape xs
hardForkLedgerConfigPerEra :: forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
..} SlotNo
slot ledgerSt :: HardForkState LedgerState xs
ledgerSt@(HardForkState Telescope (K Past) (Current LedgerState) xs
st) =
      Telescope (K Past) (Current LedgerState) xs
-> HardForkState LedgerState xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current LedgerState) xs
 -> HardForkState LedgerState xs)
-> (Telescope (K Past) (Current LedgerState) xs
    -> Telescope (K Past) (Current LedgerState) xs)
-> Telescope (K Past) (Current LedgerState) xs
-> HardForkState LedgerState xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I (Telescope (K Past) (Current LedgerState) xs)
-> Telescope (K Past) (Current LedgerState) xs
forall a. I a -> a
unI
    (I (Telescope (K Past) (Current LedgerState) xs)
 -> Telescope (K Past) (Current LedgerState) xs)
-> (Telescope (K Past) (Current LedgerState) xs
    -> I (Telescope (K Past) (Current LedgerState) xs))
-> Telescope (K Past) (Current LedgerState) xs
-> Telescope (K Past) (Current LedgerState) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InPairs
  (Requiring (K Bound) (Extend I (K Past) (Current LedgerState))) xs
-> NP (Current LedgerState -.-> (Maybe :.: K Bound)) xs
-> Telescope (K Past) (Current LedgerState) xs
-> I (Telescope (K Past) (Current LedgerState) xs)
forall k (m :: * -> *) (h :: k -> *) (g :: k -> *) (f :: k -> *)
       (xs :: [k]).
Monad m =>
InPairs (Requiring h (Extend m g f)) xs
-> NP (f -.-> (Maybe :.: h)) xs
-> Telescope g f xs
-> m (Telescope g f xs)
Telescope.extend
        ( (forall x y.
 Translate LedgerState x y
 -> Requiring
      (K Bound) (Extend I (K Past) (Current LedgerState)) x y)
-> InPairs (Translate LedgerState) xs
-> InPairs
     (Requiring (K Bound) (Extend I (K Past) (Current LedgerState))) 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 (\Translate LedgerState x y
f -> (K Bound x -> Extend I (K Past) (Current LedgerState) x y)
-> Requiring
     (K Bound) (Extend I (K Past) (Current LedgerState)) x y
forall k k (h :: k -> *) (f :: k -> k -> *) (x :: k) (y :: k).
(h x -> f x y) -> Requiring h f x y
Require ((K Bound x -> Extend I (K Past) (Current LedgerState) x y)
 -> Requiring
      (K Bound) (Extend I (K Past) (Current LedgerState)) x y)
-> (K Bound x -> Extend I (K Past) (Current LedgerState) x y)
-> Requiring
     (K Bound) (Extend I (K Past) (Current LedgerState)) x y
forall a b. (a -> b) -> a -> b
$ \(K Bound
t)
                           -> (Current LedgerState x -> I (K Past x, Current LedgerState y))
-> Extend I (K Past) (Current LedgerState) x y
forall k (m :: * -> *) (g :: k -> *) (f :: k -> *) (x :: k)
       (y :: k).
(f x -> m (g x, f y)) -> Extend m g f x y
Extend  ((Current LedgerState x -> I (K Past x, Current LedgerState y))
 -> Extend I (K Past) (Current LedgerState) x y)
-> (Current LedgerState x -> I (K Past x, Current LedgerState y))
-> Extend I (K Past) (Current LedgerState) x y
forall a b. (a -> b) -> a -> b
$ \Current LedgerState x
cur
                           -> (K Past x, Current LedgerState y)
-> I (K Past x, Current LedgerState y)
forall a. a -> I a
I ((K Past x, Current LedgerState y)
 -> I (K Past x, Current LedgerState y))
-> (K Past x, Current LedgerState y)
-> I (K Past x, Current LedgerState y)
forall a b. (a -> b) -> a -> b
$ Translate LedgerState x y
-> Bound
-> Current LedgerState x
-> (K Past x, Current LedgerState y)
forall blk blk'.
Translate LedgerState blk blk'
-> Bound
-> Current LedgerState blk
-> (K Past blk, Current LedgerState blk')
howExtend Translate LedgerState x y
f Bound
t Current LedgerState x
cur)
        (InPairs (Translate LedgerState) xs
 -> InPairs
      (Requiring (K Bound) (Extend I (K Past) (Current LedgerState))) xs)
-> InPairs (Translate LedgerState) xs
-> InPairs
     (Requiring (K Bound) (Extend I (K Past) (Current LedgerState))) xs
forall a b. (a -> b) -> a -> b
$ InPairs (Translate LedgerState) xs
translate
        )
        (Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialLedgerConfig a
    -> K EraParams a
    -> (-.->) (Current LedgerState) (Maybe :.: K Bound) a)
-> Prod NP WrapPartialLedgerConfig xs
-> NP (K EraParams) xs
-> NP (Current LedgerState -.-> (Maybe :.: K Bound)) xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hczipWith
           Proxy SingleEraBlock
proxySingle
           ((Current LedgerState a -> (:.:) Maybe (K Bound) a)
-> (-.->) (Current LedgerState) (Maybe :.: K Bound) a
forall k (f :: k -> *) (a :: k) (f' :: k -> *).
(f a -> f' a) -> (-.->) f f' a
fn ((Current LedgerState a -> (:.:) Maybe (K Bound) a)
 -> (-.->) (Current LedgerState) (Maybe :.: K Bound) a)
-> (WrapPartialLedgerConfig a
    -> K EraParams a
    -> Current LedgerState a
    -> (:.:) Maybe (K Bound) a)
-> WrapPartialLedgerConfig a
-> K EraParams a
-> (-.->) (Current LedgerState) (Maybe :.: K Bound) a
forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: WrapPartialLedgerConfig a
-> K EraParams a
-> Current LedgerState a
-> (:.:) Maybe (K Bound) a
forall blk.
SingleEraBlock blk =>
WrapPartialLedgerConfig blk
-> K EraParams blk
-> Current LedgerState blk
-> (:.:) Maybe (K Bound) blk
whenExtend)
           Prod NP WrapPartialLedgerConfig xs
NP WrapPartialLedgerConfig xs
pcfgs
           (Exactly xs EraParams -> NP (K EraParams) xs
forall (xs :: [*]) a. Exactly xs a -> NP (K a) xs
getExactly (Shape xs -> Exactly xs EraParams
forall (xs :: [*]). Shape xs -> Exactly xs EraParams
History.getShape Shape xs
hardForkLedgerConfigShape)))
    (Telescope (K Past) (Current LedgerState) xs
 -> HardForkState LedgerState xs)
-> Telescope (K Past) (Current LedgerState) xs
-> HardForkState LedgerState xs
forall a b. (a -> b) -> a -> b
$ Telescope (K Past) (Current LedgerState) xs
st
  where
    pcfgs :: NP WrapPartialLedgerConfig xs
pcfgs = PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
getPerEraLedgerConfig PerEraLedgerConfig xs
hardForkLedgerConfigPerEra
    cfgs :: NP WrapLedgerConfig xs
cfgs  = Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialLedgerConfig a -> WrapLedgerConfig a)
-> NP WrapPartialLedgerConfig xs
-> NP WrapLedgerConfig 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 (EpochInfo (Except PastHorizonException)
-> WrapPartialLedgerConfig a -> WrapLedgerConfig a
forall blk.
HasPartialLedgerConfig blk =>
EpochInfo (Except PastHorizonException)
-> WrapPartialLedgerConfig blk -> WrapLedgerConfig blk
completeLedgerConfig'' EpochInfo (Except PastHorizonException)
ei) NP WrapPartialLedgerConfig xs
pcfgs
    ei :: EpochInfo (Except PastHorizonException)
ei    = HardForkLedgerConfig xs
-> HardForkState LedgerState xs
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState LedgerState xs
-> EpochInfo (Except PastHorizonException)
epochInfoLedger HardForkLedgerConfig xs
ledgerCfg HardForkState LedgerState xs
ledgerSt

    -- Return the end of this era if we should transition to the next
    whenExtend :: SingleEraBlock              blk
               => WrapPartialLedgerConfig     blk
               -> K History.EraParams         blk
               -> Current LedgerState         blk
               -> (Maybe :.: K History.Bound) blk
    whenExtend :: WrapPartialLedgerConfig blk
-> K EraParams blk
-> Current LedgerState blk
-> (:.:) Maybe (K Bound) blk
whenExtend WrapPartialLedgerConfig blk
pcfg (K EraParams
eraParams) Current LedgerState blk
cur = Maybe (K Bound blk) -> (:.:) Maybe (K Bound) blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (Maybe (K Bound blk) -> (:.:) Maybe (K Bound) blk)
-> Maybe (K Bound blk) -> (:.:) Maybe (K Bound) blk
forall a b. (a -> b) -> a -> b
$ Bound -> K Bound blk
forall k a (b :: k). a -> K a b
K (Bound -> K Bound blk) -> Maybe Bound -> Maybe (K Bound blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        EpochNo
transition <- WrapPartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo
forall blk.
SingleEraBlock blk =>
WrapPartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo
singleEraTransition'
                        WrapPartialLedgerConfig blk
pcfg
                        EraParams
eraParams
                        (Current LedgerState blk -> Bound
forall (f :: * -> *) blk. Current f blk -> Bound
currentStart Current LedgerState blk
cur)
                        (Current LedgerState blk -> LedgerState blk
forall (f :: * -> *) blk. Current f blk -> f blk
currentState Current LedgerState blk
cur)
        let endBound :: Bound
endBound = HasCallStack => EraParams -> Bound -> EpochNo -> Bound
EraParams -> Bound -> EpochNo -> Bound
History.mkUpperBound
                         EraParams
eraParams
                         (Current LedgerState blk -> Bound
forall (f :: * -> *) blk. Current f blk -> Bound
currentStart Current LedgerState blk
cur)
                         EpochNo
transition
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SlotNo
slot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= Bound -> SlotNo
History.boundSlot Bound
endBound)
        Bound -> Maybe Bound
forall (m :: * -> *) a. Monad m => a -> m a
return Bound
endBound

    howExtend :: Translate LedgerState blk blk'
              -> History.Bound
              -> Current LedgerState blk
              -> (K Past blk, Current LedgerState blk')
    howExtend :: Translate LedgerState blk blk'
-> Bound
-> Current LedgerState blk
-> (K Past blk, Current LedgerState blk')
howExtend Translate LedgerState blk blk'
f Bound
currentEnd Current LedgerState blk
cur = (
          Past -> K Past blk
forall k a (b :: k). a -> K a b
K Past :: Bound -> Bound -> Past
Past {
              pastStart :: Bound
pastStart    = Current LedgerState blk -> Bound
forall (f :: * -> *) blk. Current f blk -> Bound
currentStart Current LedgerState blk
cur
            , pastEnd :: Bound
pastEnd      = Bound
currentEnd
            }
        , Current :: forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current {
              currentStart :: Bound
currentStart = Bound
currentEnd
            , currentState :: LedgerState blk'
currentState = Translate LedgerState blk blk'
-> EpochNo -> LedgerState blk -> LedgerState blk'
forall (f :: * -> *) x y. Translate f x y -> EpochNo -> f x -> f y
translateWith Translate LedgerState blk blk'
f
                               (Bound -> EpochNo
History.boundEpoch Bound
currentEnd)
                               (Current LedgerState blk -> LedgerState blk
forall (f :: * -> *) blk. Current f blk -> f blk
currentState Current LedgerState blk
cur)
            }
        )

    translate :: InPairs (Translate LedgerState) xs
    translate :: InPairs (Translate LedgerState) xs
translate = NP WrapLedgerConfig xs
-> InPairs
     (RequiringBoth WrapLedgerConfig (Translate LedgerState)) xs
-> InPairs (Translate LedgerState) xs
forall k (h :: k -> *) (xs :: [k]) (f :: k -> k -> *).
NP h xs -> InPairs (RequiringBoth h f) xs -> InPairs f xs
InPairs.requiringBoth NP WrapLedgerConfig xs
cfgs (InPairs
   (RequiringBoth WrapLedgerConfig (Translate LedgerState)) xs
 -> InPairs (Translate LedgerState) xs)
-> InPairs
     (RequiringBoth WrapLedgerConfig (Translate LedgerState)) xs
-> InPairs (Translate LedgerState) xs
forall a b. (a -> b) -> a -> b
$
                  EraTranslation xs
-> InPairs
     (RequiringBoth WrapLedgerConfig (Translate LedgerState)) xs
forall (xs :: [*]).
EraTranslation xs
-> InPairs
     (RequiringBoth WrapLedgerConfig (Translate LedgerState)) xs
translateLedgerState EraTranslation xs
forall (xs :: [*]). CanHardFork xs => EraTranslation xs
hardForkEraTranslation