{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Ledger.Extended (
    -- * Extended ledger state
    ExtLedgerCfg (..)
  , ExtLedgerState (..)
  , ExtValidationError (..)
    -- * Serialisation
  , decodeDiskExtLedgerState
  , decodeExtLedgerState
  , encodeDiskExtLedgerState
  , encodeExtLedgerState
    -- * Casts
  , castExtLedgerState
    -- * Type family instances
  , Ticked (..)
  ) where

import           Codec.CBOR.Decoding (Decoder, decodeListLenOf)
import           Codec.CBOR.Encoding (Encoding, encodeListLen)
import           Control.Monad.Except
import           Data.Coerce
import           Data.Functor ((<&>))
import           Data.Proxy
import           Data.Typeable
import           GHC.Generics (Generic)
import           GHC.Stack (HasCallStack)
import           NoThunks.Class (NoThunks (..))
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Protocol.Abstract
import           Ouroboros.Consensus.Storage.Serialisation

{-------------------------------------------------------------------------------
  Extended ledger state
-------------------------------------------------------------------------------}

-- | Extended ledger state
--
-- This is the combination of the header state and the ledger state proper.
data ExtLedgerState blk = ExtLedgerState {
      forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState :: !(LedgerState blk)
    , forall blk. ExtLedgerState blk -> HeaderState blk
headerState :: !(HeaderState blk)
    }
  deriving ((forall x. ExtLedgerState blk -> Rep (ExtLedgerState blk) x)
-> (forall x. Rep (ExtLedgerState blk) x -> ExtLedgerState blk)
-> Generic (ExtLedgerState blk)
forall x. Rep (ExtLedgerState blk) x -> ExtLedgerState blk
forall x. ExtLedgerState blk -> Rep (ExtLedgerState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (ExtLedgerState blk) x -> ExtLedgerState blk
forall blk x. ExtLedgerState blk -> Rep (ExtLedgerState blk) x
$cfrom :: forall blk x. ExtLedgerState blk -> Rep (ExtLedgerState blk) x
from :: forall x. ExtLedgerState blk -> Rep (ExtLedgerState blk) x
$cto :: forall blk x. Rep (ExtLedgerState blk) x -> ExtLedgerState blk
to :: forall x. Rep (ExtLedgerState blk) x -> ExtLedgerState blk
Generic)

data ExtValidationError blk =
    ExtValidationErrorLedger !(LedgerError blk)
  | ExtValidationErrorHeader !(HeaderError blk)
  deriving ((forall x.
 ExtValidationError blk -> Rep (ExtValidationError blk) x)
-> (forall x.
    Rep (ExtValidationError blk) x -> ExtValidationError blk)
-> Generic (ExtValidationError blk)
forall x. Rep (ExtValidationError blk) x -> ExtValidationError blk
forall x. ExtValidationError blk -> Rep (ExtValidationError blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (ExtValidationError blk) x -> ExtValidationError blk
forall blk x.
ExtValidationError blk -> Rep (ExtValidationError blk) x
$cfrom :: forall blk x.
ExtValidationError blk -> Rep (ExtValidationError blk) x
from :: forall x. ExtValidationError blk -> Rep (ExtValidationError blk) x
$cto :: forall blk x.
Rep (ExtValidationError blk) x -> ExtValidationError blk
to :: forall x. Rep (ExtValidationError blk) x -> ExtValidationError blk
Generic)

instance LedgerSupportsProtocol blk => NoThunks (ExtValidationError blk)

deriving instance LedgerSupportsProtocol blk => Show (ExtLedgerState     blk)
deriving instance LedgerSupportsProtocol blk => Show (ExtValidationError blk)
deriving instance LedgerSupportsProtocol blk => Eq   (ExtValidationError blk)

-- | We override 'showTypeOf' to show the type of the block
--
-- This makes debugging a bit easier, as the block gets used to resolve all
-- kinds of type families.
instance LedgerSupportsProtocol blk => NoThunks (ExtLedgerState blk) where
  showTypeOf :: Proxy (ExtLedgerState blk) -> String
showTypeOf Proxy (ExtLedgerState blk)
_ = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy (ExtLedgerState blk) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ExtLedgerState blk))

deriving instance ( LedgerSupportsProtocol blk
                  ) => Eq (ExtLedgerState blk)

{-------------------------------------------------------------------------------
  The extended ledger can behave like a ledger
-------------------------------------------------------------------------------}

data instance Ticked (ExtLedgerState blk) = TickedExtLedgerState {
      forall blk. Ticked (ExtLedgerState blk) -> Ticked (LedgerState blk)
tickedLedgerState :: Ticked (LedgerState blk)
    , forall blk.
Ticked (ExtLedgerState blk) -> LedgerView (BlockProtocol blk)
ledgerView        :: LedgerView (BlockProtocol blk)
    , forall blk. Ticked (ExtLedgerState blk) -> Ticked (HeaderState blk)
tickedHeaderState :: Ticked (HeaderState blk)
    }

-- | " Ledger " configuration for the extended ledger
--
-- Since the extended ledger also does the consensus protocol validation, we
-- also need the consensus config.
newtype ExtLedgerCfg blk = ExtLedgerCfg {
      forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg :: TopLevelConfig blk
    }
  deriving ((forall x. ExtLedgerCfg blk -> Rep (ExtLedgerCfg blk) x)
-> (forall x. Rep (ExtLedgerCfg blk) x -> ExtLedgerCfg blk)
-> Generic (ExtLedgerCfg blk)
forall x. Rep (ExtLedgerCfg blk) x -> ExtLedgerCfg blk
forall x. ExtLedgerCfg blk -> Rep (ExtLedgerCfg blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (ExtLedgerCfg blk) x -> ExtLedgerCfg blk
forall blk x. ExtLedgerCfg blk -> Rep (ExtLedgerCfg blk) x
$cfrom :: forall blk x. ExtLedgerCfg blk -> Rep (ExtLedgerCfg blk) x
from :: forall x. ExtLedgerCfg blk -> Rep (ExtLedgerCfg blk) x
$cto :: forall blk x. Rep (ExtLedgerCfg blk) x -> ExtLedgerCfg blk
to :: forall x. Rep (ExtLedgerCfg blk) x -> ExtLedgerCfg blk
Generic)

instance ( ConsensusProtocol (BlockProtocol blk)
         , NoThunks (BlockConfig   blk)
         , NoThunks (CodecConfig   blk)
         , NoThunks (LedgerConfig  blk)
         , NoThunks (StorageConfig blk)
         , NoThunks (HeaderHash    blk)
         ) => NoThunks (ExtLedgerCfg blk)

type instance LedgerCfg (ExtLedgerState blk) = ExtLedgerCfg blk

type instance HeaderHash (ExtLedgerState blk) = HeaderHash (LedgerState blk)

instance IsLedger (LedgerState blk) => GetTip (ExtLedgerState blk) where
  getTip :: ExtLedgerState blk -> Point (ExtLedgerState blk)
getTip = Point (LedgerState blk) -> Point (ExtLedgerState blk)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (LedgerState blk) -> Point (ExtLedgerState blk))
-> (ExtLedgerState blk -> Point (LedgerState blk))
-> ExtLedgerState blk
-> Point (ExtLedgerState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState blk -> Point (LedgerState blk)
forall l. GetTip l => l -> Point l
getTip (LedgerState blk -> Point (LedgerState blk))
-> (ExtLedgerState blk -> LedgerState blk)
-> ExtLedgerState blk
-> Point (LedgerState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState

instance IsLedger (LedgerState blk) => GetTip (Ticked (ExtLedgerState blk)) where
  getTip :: Ticked (ExtLedgerState blk) -> Point (Ticked (ExtLedgerState blk))
getTip = Point (Ticked (LedgerState blk))
-> Point (Ticked (ExtLedgerState blk))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Ticked (LedgerState blk))
 -> Point (Ticked (ExtLedgerState blk)))
-> (Ticked (ExtLedgerState blk)
    -> Point (Ticked (LedgerState blk)))
-> Ticked (ExtLedgerState blk)
-> Point (Ticked (ExtLedgerState blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState blk) -> Point (Ticked (LedgerState blk))
forall l. GetTip l => l -> Point l
getTip (Ticked (LedgerState blk) -> Point (Ticked (LedgerState blk)))
-> (Ticked (ExtLedgerState blk) -> Ticked (LedgerState blk))
-> Ticked (ExtLedgerState blk)
-> Point (Ticked (LedgerState blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (ExtLedgerState blk) -> Ticked (LedgerState blk)
forall blk. Ticked (ExtLedgerState blk) -> Ticked (LedgerState blk)
tickedLedgerState

instance LedgerSupportsProtocol blk
      => IsLedger (ExtLedgerState blk) where
  type LedgerErr (ExtLedgerState blk) = ExtValidationError blk

  type AuxLedgerEvent (ExtLedgerState blk) = AuxLedgerEvent (LedgerState blk)

  applyChainTickLedgerResult :: ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> SlotNo
-> ExtLedgerState blk
-> LedgerResult (ExtLedgerState blk) (Ticked (ExtLedgerState blk))
applyChainTickLedgerResult ComputeLedgerEvents
evs LedgerCfg (ExtLedgerState blk)
cfg SlotNo
slot (ExtLedgerState LedgerState blk
ledger HeaderState blk
header) =
      LedgerResult (LedgerState blk) (Ticked (LedgerState blk))
-> LedgerResult (ExtLedgerState blk) (Ticked (LedgerState blk))
forall l l' a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult (LedgerState blk) (Ticked (LedgerState blk))
ledgerResult LedgerResult (ExtLedgerState blk) (Ticked (LedgerState blk))
-> (Ticked (LedgerState blk) -> Ticked (ExtLedgerState blk))
-> LedgerResult (ExtLedgerState blk) (Ticked (ExtLedgerState blk))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Ticked (LedgerState blk)
tickedLedgerState ->
      let ledgerView :: LedgerView (BlockProtocol blk)
          ledgerView :: LedgerView (BlockProtocol blk)
ledgerView = LedgerCfg (LedgerState blk)
-> Ticked (LedgerState blk) -> LedgerView (BlockProtocol blk)
forall blk.
LedgerSupportsProtocol blk =>
LedgerConfig blk
-> Ticked (LedgerState blk) -> LedgerView (BlockProtocol blk)
protocolLedgerView LedgerCfg (LedgerState blk)
lcfg Ticked (LedgerState blk)
tickedLedgerState

          tickedHeaderState :: Ticked (HeaderState blk)
          tickedHeaderState :: Ticked (HeaderState blk)
tickedHeaderState =
              ConsensusConfig (BlockProtocol blk)
-> LedgerView (BlockProtocol blk)
-> SlotNo
-> HeaderState blk
-> Ticked (HeaderState blk)
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
ConsensusConfig (BlockProtocol blk)
-> LedgerView (BlockProtocol blk)
-> SlotNo
-> HeaderState blk
-> Ticked (HeaderState blk)
tickHeaderState
                (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk))
-> TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg LedgerCfg (ExtLedgerState blk)
ExtLedgerCfg blk
cfg)
                LedgerView (BlockProtocol blk)
ledgerView
                SlotNo
slot
                HeaderState blk
header
      in TickedExtLedgerState {Ticked (LedgerState blk)
Ticked (HeaderState blk)
LedgerView (BlockProtocol blk)
tickedLedgerState :: Ticked (LedgerState blk)
ledgerView :: LedgerView (BlockProtocol blk)
tickedHeaderState :: Ticked (HeaderState blk)
tickedLedgerState :: Ticked (LedgerState blk)
ledgerView :: LedgerView (BlockProtocol blk)
tickedHeaderState :: Ticked (HeaderState blk)
..}
    where
      lcfg :: LedgerConfig blk
      lcfg :: LedgerCfg (LedgerState blk)
lcfg = TopLevelConfig blk -> LedgerCfg (LedgerState blk)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger (TopLevelConfig blk -> LedgerCfg (LedgerState blk))
-> TopLevelConfig blk -> LedgerCfg (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg LedgerCfg (ExtLedgerState blk)
ExtLedgerCfg blk
cfg

      ledgerResult :: LedgerResult (LedgerState blk) (Ticked (LedgerState blk))
ledgerResult = ComputeLedgerEvents
-> LedgerCfg (LedgerState blk)
-> SlotNo
-> LedgerState blk
-> LedgerResult (LedgerState blk) (Ticked (LedgerState blk))
forall l.
IsLedger l =>
ComputeLedgerEvents
-> LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l)
applyChainTickLedgerResult ComputeLedgerEvents
evs LedgerCfg (LedgerState blk)
lcfg SlotNo
slot LedgerState blk
ledger

applyHelper ::
     forall blk.
     (HasCallStack, LedgerSupportsProtocol blk)
  => (   HasCallStack
      => ComputeLedgerEvents
      -> LedgerCfg (LedgerState blk)
      -> blk
      -> Ticked (LedgerState blk)
      -> Except
           (LedgerErr (LedgerState blk))
           (LedgerResult (LedgerState blk) (LedgerState blk))
     )
  -> ComputeLedgerEvents
  -> LedgerCfg (ExtLedgerState blk)
  -> blk
  -> Ticked (ExtLedgerState blk)
  -> Except
       (LedgerErr (ExtLedgerState blk))
       (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
applyHelper :: forall blk.
(HasCallStack, LedgerSupportsProtocol blk) =>
(HasCallStack =>
 ComputeLedgerEvents
 -> LedgerCfg (LedgerState blk)
 -> blk
 -> Ticked (LedgerState blk)
 -> Except
      (LedgerErr (LedgerState blk))
      (LedgerResult (LedgerState blk) (LedgerState blk)))
-> ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> Ticked (ExtLedgerState blk)
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
applyHelper HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (LedgerState blk)
-> blk
-> Ticked (LedgerState blk)
-> Except
     (LedgerErr (LedgerState blk))
     (LedgerResult (LedgerState blk) (LedgerState blk))
f ComputeLedgerEvents
opts LedgerCfg (ExtLedgerState blk)
cfg blk
blk TickedExtLedgerState{Ticked (LedgerState blk)
Ticked (HeaderState blk)
LedgerView (BlockProtocol blk)
tickedLedgerState :: forall blk. Ticked (ExtLedgerState blk) -> Ticked (LedgerState blk)
ledgerView :: forall blk.
Ticked (ExtLedgerState blk) -> LedgerView (BlockProtocol blk)
tickedHeaderState :: forall blk. Ticked (ExtLedgerState blk) -> Ticked (HeaderState blk)
tickedLedgerState :: Ticked (LedgerState blk)
ledgerView :: LedgerView (BlockProtocol blk)
tickedHeaderState :: Ticked (HeaderState blk)
..} = do
    LedgerResult (LedgerState blk) (LedgerState blk)
ledgerResult <-
        (LedgerErr (LedgerState blk) -> ExtValidationError blk)
-> Except
     (LedgerErr (LedgerState blk))
     (LedgerResult (LedgerState blk) (LedgerState blk))
-> Except
     (ExtValidationError blk)
     (LedgerResult (LedgerState blk) (LedgerState blk))
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept LedgerErr (LedgerState blk) -> ExtValidationError blk
forall blk. LedgerError blk -> ExtValidationError blk
ExtValidationErrorLedger
      (Except
   (LedgerErr (LedgerState blk))
   (LedgerResult (LedgerState blk) (LedgerState blk))
 -> Except
      (ExtValidationError blk)
      (LedgerResult (LedgerState blk) (LedgerState blk)))
-> Except
     (LedgerErr (LedgerState blk))
     (LedgerResult (LedgerState blk) (LedgerState blk))
-> Except
     (ExtValidationError blk)
     (LedgerResult (LedgerState blk) (LedgerState blk))
forall a b. (a -> b) -> a -> b
$ HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (LedgerState blk)
-> blk
-> Ticked (LedgerState blk)
-> Except
     (LedgerErr (LedgerState blk))
     (LedgerResult (LedgerState blk) (LedgerState blk))
ComputeLedgerEvents
-> LedgerCfg (LedgerState blk)
-> blk
-> Ticked (LedgerState blk)
-> Except
     (LedgerErr (LedgerState blk))
     (LedgerResult (LedgerState blk) (LedgerState blk))
f ComputeLedgerEvents
opts
          (TopLevelConfig blk -> LedgerCfg (LedgerState blk)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger (TopLevelConfig blk -> LedgerCfg (LedgerState blk))
-> TopLevelConfig blk -> LedgerCfg (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg LedgerCfg (ExtLedgerState blk)
ExtLedgerCfg blk
cfg)
          blk
blk
          Ticked (LedgerState blk)
tickedLedgerState
    HeaderState blk
hdr <-
        (HeaderError blk -> ExtValidationError blk)
-> Except (HeaderError blk) (HeaderState blk)
-> Except (ExtValidationError blk) (HeaderState blk)
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept HeaderError blk -> ExtValidationError blk
forall blk. HeaderError blk -> ExtValidationError blk
ExtValidationErrorHeader
      (Except (HeaderError blk) (HeaderState blk)
 -> Except (ExtValidationError blk) (HeaderState blk))
-> Except (HeaderError blk) (HeaderState blk)
-> Except (ExtValidationError blk) (HeaderState blk)
forall a b. (a -> b) -> a -> b
$ forall blk.
(BlockSupportsProtocol blk, ValidateEnvelope blk) =>
TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Ticked (HeaderState blk)
-> Except (HeaderError blk) (HeaderState blk)
validateHeader @blk
          (ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg LedgerCfg (ExtLedgerState blk)
ExtLedgerCfg blk
cfg)
          LedgerView (BlockProtocol blk)
ledgerView
          (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk)
          Ticked (HeaderState blk)
tickedHeaderState
    LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)
-> ExceptT
     (ExtValidationError blk)
     Identity
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
forall a. a -> ExceptT (ExtValidationError blk) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)
 -> ExceptT
      (ExtValidationError blk)
      Identity
      (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)))
-> LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)
-> ExceptT
     (ExtValidationError blk)
     Identity
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ (\LedgerState blk
l -> LedgerState blk -> HeaderState blk -> ExtLedgerState blk
forall blk.
LedgerState blk -> HeaderState blk -> ExtLedgerState blk
ExtLedgerState LedgerState blk
l HeaderState blk
hdr) (LedgerState blk -> ExtLedgerState blk)
-> LedgerResult (ExtLedgerState blk) (LedgerState blk)
-> LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerResult (LedgerState blk) (LedgerState blk)
-> LedgerResult (ExtLedgerState blk) (LedgerState blk)
forall l l' a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult (LedgerState blk) (LedgerState blk)
ledgerResult

instance LedgerSupportsProtocol blk => ApplyBlock (ExtLedgerState blk) blk where
  applyBlockLedgerResultWithValidation :: HasCallStack =>
ValidationPolicy
-> ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> Ticked (ExtLedgerState blk)
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
applyBlockLedgerResultWithValidation ValidationPolicy
doValidate =
    (HasCallStack =>
 ComputeLedgerEvents
 -> LedgerCfg (LedgerState blk)
 -> blk
 -> Ticked (LedgerState blk)
 -> Except
      (LedgerErr (LedgerState blk))
      (LedgerResult (LedgerState blk) (LedgerState blk)))
-> ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> Ticked (ExtLedgerState blk)
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
forall blk.
(HasCallStack, LedgerSupportsProtocol blk) =>
(HasCallStack =>
 ComputeLedgerEvents
 -> LedgerCfg (LedgerState blk)
 -> blk
 -> Ticked (LedgerState blk)
 -> Except
      (LedgerErr (LedgerState blk))
      (LedgerResult (LedgerState blk) (LedgerState blk)))
-> ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> Ticked (ExtLedgerState blk)
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
applyHelper (ValidationPolicy
-> ComputeLedgerEvents
-> LedgerCfg (LedgerState blk)
-> blk
-> Ticked (LedgerState blk)
-> Except
     (LedgerErr (LedgerState blk))
     (LedgerResult (LedgerState blk) (LedgerState blk))
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
ValidationPolicy
-> ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l
-> Except (LedgerErr l) (LedgerResult l l)
applyBlockLedgerResultWithValidation ValidationPolicy
doValidate)

  applyBlockLedgerResult :: HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> Ticked (ExtLedgerState blk)
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
applyBlockLedgerResult =
    (HasCallStack =>
 ComputeLedgerEvents
 -> LedgerCfg (LedgerState blk)
 -> blk
 -> Ticked (LedgerState blk)
 -> Except
      (LedgerErr (LedgerState blk))
      (LedgerResult (LedgerState blk) (LedgerState blk)))
-> ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> Ticked (ExtLedgerState blk)
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
forall blk.
(HasCallStack, LedgerSupportsProtocol blk) =>
(HasCallStack =>
 ComputeLedgerEvents
 -> LedgerCfg (LedgerState blk)
 -> blk
 -> Ticked (LedgerState blk)
 -> Except
      (LedgerErr (LedgerState blk))
      (LedgerResult (LedgerState blk) (LedgerState blk)))
-> ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> Ticked (ExtLedgerState blk)
-> Except
     (LedgerErr (ExtLedgerState blk))
     (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk))
applyHelper HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (LedgerState blk)
-> blk
-> Ticked (LedgerState blk)
-> Except
     (LedgerErr (LedgerState blk))
     (LedgerResult (LedgerState blk) (LedgerState blk))
ComputeLedgerEvents
-> LedgerCfg (LedgerState blk)
-> blk
-> Ticked (LedgerState blk)
-> Except
     (LedgerErr (LedgerState blk))
     (LedgerResult (LedgerState blk) (LedgerState blk))
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l
-> Except (LedgerErr l) (LedgerResult l l)
applyBlockLedgerResult

  reapplyBlockLedgerResult :: HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (ExtLedgerState blk)
-> blk
-> Ticked (ExtLedgerState blk)
-> LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)
reapplyBlockLedgerResult ComputeLedgerEvents
evs LedgerCfg (ExtLedgerState blk)
cfg blk
blk TickedExtLedgerState{Ticked (LedgerState blk)
Ticked (HeaderState blk)
LedgerView (BlockProtocol blk)
tickedLedgerState :: forall blk. Ticked (ExtLedgerState blk) -> Ticked (LedgerState blk)
ledgerView :: forall blk.
Ticked (ExtLedgerState blk) -> LedgerView (BlockProtocol blk)
tickedHeaderState :: forall blk. Ticked (ExtLedgerState blk) -> Ticked (HeaderState blk)
tickedLedgerState :: Ticked (LedgerState blk)
ledgerView :: LedgerView (BlockProtocol blk)
tickedHeaderState :: Ticked (HeaderState blk)
..} =
      (\LedgerState blk
l -> LedgerState blk -> HeaderState blk -> ExtLedgerState blk
forall blk.
LedgerState blk -> HeaderState blk -> ExtLedgerState blk
ExtLedgerState LedgerState blk
l HeaderState blk
hdr) (LedgerState blk -> ExtLedgerState blk)
-> LedgerResult (ExtLedgerState blk) (LedgerState blk)
-> LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerResult (LedgerState blk) (LedgerState blk)
-> LedgerResult (ExtLedgerState blk) (LedgerState blk)
forall l l' a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult (LedgerState blk) (LedgerState blk)
ledgerResult
    where
      ledgerResult :: LedgerResult (LedgerState blk) (LedgerState blk)
ledgerResult =
        ComputeLedgerEvents
-> LedgerCfg (LedgerState blk)
-> blk
-> Ticked (LedgerState blk)
-> LedgerResult (LedgerState blk) (LedgerState blk)
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
ComputeLedgerEvents
-> LedgerCfg l -> blk -> Ticked l -> LedgerResult l l
reapplyBlockLedgerResult ComputeLedgerEvents
evs
          (TopLevelConfig blk -> LedgerCfg (LedgerState blk)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger (TopLevelConfig blk -> LedgerCfg (LedgerState blk))
-> TopLevelConfig blk -> LedgerCfg (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg LedgerCfg (ExtLedgerState blk)
ExtLedgerCfg blk
cfg)
          blk
blk
          Ticked (LedgerState blk)
tickedLedgerState
      hdr :: HeaderState blk
hdr      =
        TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Ticked (HeaderState blk)
-> HeaderState blk
forall blk.
(BlockSupportsProtocol blk, ValidateEnvelope blk, HasCallStack) =>
TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Ticked (HeaderState blk)
-> HeaderState blk
revalidateHeader
          (ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg LedgerCfg (ExtLedgerState blk)
ExtLedgerCfg blk
cfg)
          LedgerView (BlockProtocol blk)
ledgerView
          (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk)
          Ticked (HeaderState blk)
tickedHeaderState

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

encodeExtLedgerState :: (LedgerState   blk -> Encoding)
                     -> (ChainDepState (BlockProtocol blk) -> Encoding)
                     -> (AnnTip        blk -> Encoding)
                     -> ExtLedgerState blk -> Encoding
encodeExtLedgerState :: forall blk.
(LedgerState blk -> Encoding)
-> (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding)
-> ExtLedgerState blk
-> Encoding
encodeExtLedgerState LedgerState blk -> Encoding
encodeLedgerState
                     ChainDepState (BlockProtocol blk) -> Encoding
encodeChainDepState
                     AnnTip blk -> Encoding
encodeAnnTip
                     ExtLedgerState{LedgerState blk
HeaderState blk
ledgerState :: forall blk. ExtLedgerState blk -> LedgerState blk
headerState :: forall blk. ExtLedgerState blk -> HeaderState blk
ledgerState :: LedgerState blk
headerState :: HeaderState blk
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
2
    , LedgerState blk -> Encoding
encodeLedgerState  LedgerState blk
ledgerState
    , HeaderState blk -> Encoding
encodeHeaderState' HeaderState blk
headerState
    ]
  where
    encodeHeaderState' :: HeaderState blk -> Encoding
encodeHeaderState' = (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding) -> HeaderState blk -> Encoding
forall blk.
(ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding) -> HeaderState blk -> Encoding
encodeHeaderState
                           ChainDepState (BlockProtocol blk) -> Encoding
encodeChainDepState
                           AnnTip blk -> Encoding
encodeAnnTip

encodeDiskExtLedgerState ::
     forall blk.
     (EncodeDisk blk (LedgerState blk),
      EncodeDisk blk (ChainDepState (BlockProtocol blk)),
      EncodeDisk blk (AnnTip blk)
     )
  => (CodecConfig blk -> ExtLedgerState blk -> Encoding)
encodeDiskExtLedgerState :: forall blk.
(EncodeDisk blk (LedgerState blk),
 EncodeDisk blk (ChainDepState (BlockProtocol blk)),
 EncodeDisk blk (AnnTip blk)) =>
CodecConfig blk -> ExtLedgerState blk -> Encoding
encodeDiskExtLedgerState CodecConfig blk
cfg =
  (LedgerState blk -> Encoding)
-> (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding)
-> ExtLedgerState blk
-> Encoding
forall blk.
(LedgerState blk -> Encoding)
-> (ChainDepState (BlockProtocol blk) -> Encoding)
-> (AnnTip blk -> Encoding)
-> ExtLedgerState blk
-> Encoding
encodeExtLedgerState
    (CodecConfig blk -> LedgerState blk -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
cfg)
    (CodecConfig blk -> ChainDepState (BlockProtocol blk) -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
cfg)
    (CodecConfig blk -> AnnTip blk -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
cfg)

decodeExtLedgerState :: (forall s. Decoder s (LedgerState    blk))
                     -> (forall s. Decoder s (ChainDepState  (BlockProtocol blk)))
                     -> (forall s. Decoder s (AnnTip         blk))
                     -> (forall s. Decoder s (ExtLedgerState blk))
decodeExtLedgerState :: forall blk.
(forall s. Decoder s (LedgerState blk))
-> (forall s. Decoder s (ChainDepState (BlockProtocol blk)))
-> (forall s. Decoder s (AnnTip blk))
-> forall s. Decoder s (ExtLedgerState blk)
decodeExtLedgerState forall s. Decoder s (LedgerState blk)
decodeLedgerState
                     forall s. Decoder s (ChainDepState (BlockProtocol blk))
decodeChainDepState
                     forall s. Decoder s (AnnTip blk)
decodeAnnTip = do
      Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
      LedgerState blk
ledgerState <- Decoder s (LedgerState blk)
forall s. Decoder s (LedgerState blk)
decodeLedgerState
      HeaderState blk
headerState <- Decoder s (HeaderState blk)
decodeHeaderState'
      ExtLedgerState blk -> Decoder s (ExtLedgerState blk)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return ExtLedgerState{LedgerState blk
HeaderState blk
ledgerState :: LedgerState blk
headerState :: HeaderState blk
ledgerState :: LedgerState blk
headerState :: HeaderState blk
..}
  where
    decodeHeaderState' :: Decoder s (HeaderState blk)
decodeHeaderState' = (forall s. Decoder s (ChainDepState (BlockProtocol blk)))
-> (forall s. Decoder s (AnnTip blk))
-> forall s. Decoder s (HeaderState blk)
forall blk.
(forall s. Decoder s (ChainDepState (BlockProtocol blk)))
-> (forall s. Decoder s (AnnTip blk))
-> forall s. Decoder s (HeaderState blk)
decodeHeaderState
                           Decoder s (ChainDepState (BlockProtocol blk))
forall s. Decoder s (ChainDepState (BlockProtocol blk))
decodeChainDepState
                           Decoder s (AnnTip blk)
forall s. Decoder s (AnnTip blk)
decodeAnnTip

decodeDiskExtLedgerState ::
     forall blk.
     (DecodeDisk blk (LedgerState blk),
      DecodeDisk blk (ChainDepState (BlockProtocol blk)),
      DecodeDisk blk (AnnTip blk)
     )
  => (CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk))
decodeDiskExtLedgerState :: forall blk.
(DecodeDisk blk (LedgerState blk),
 DecodeDisk blk (ChainDepState (BlockProtocol blk)),
 DecodeDisk blk (AnnTip blk)) =>
CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk)
decodeDiskExtLedgerState CodecConfig blk
cfg =
  (forall s. Decoder s (LedgerState blk))
-> (forall s. Decoder s (ChainDepState (BlockProtocol blk)))
-> (forall s. Decoder s (AnnTip blk))
-> forall s. Decoder s (ExtLedgerState blk)
forall blk.
(forall s. Decoder s (LedgerState blk))
-> (forall s. Decoder s (ChainDepState (BlockProtocol blk)))
-> (forall s. Decoder s (AnnTip blk))
-> forall s. Decoder s (ExtLedgerState blk)
decodeExtLedgerState
    (CodecConfig blk -> forall s. Decoder s (LedgerState blk)
forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk CodecConfig blk
cfg)
    (CodecConfig blk
-> forall s. Decoder s (ChainDepState (BlockProtocol blk))
forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk CodecConfig blk
cfg)
    (CodecConfig blk -> forall s. Decoder s (AnnTip blk)
forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk CodecConfig blk
cfg)

{-------------------------------------------------------------------------------
  Casts
-------------------------------------------------------------------------------}

castExtLedgerState ::
     ( Coercible (LedgerState blk)
                 (LedgerState blk')
     , Coercible (ChainDepState (BlockProtocol blk))
                 (ChainDepState (BlockProtocol blk'))
     , TipInfo blk ~ TipInfo blk'
     )
  => ExtLedgerState blk -> ExtLedgerState blk'
castExtLedgerState :: forall blk blk'.
(Coercible (LedgerState blk) (LedgerState blk'),
 Coercible
   (ChainDepState (BlockProtocol blk))
   (ChainDepState (BlockProtocol blk')),
 TipInfo blk ~ TipInfo blk') =>
ExtLedgerState blk -> ExtLedgerState blk'
castExtLedgerState ExtLedgerState{LedgerState blk
HeaderState blk
ledgerState :: forall blk. ExtLedgerState blk -> LedgerState blk
headerState :: forall blk. ExtLedgerState blk -> HeaderState blk
ledgerState :: LedgerState blk
headerState :: HeaderState blk
..} = ExtLedgerState {
      ledgerState :: LedgerState blk'
ledgerState = LedgerState blk -> LedgerState blk'
forall a b. Coercible a b => a -> b
coerce LedgerState blk
ledgerState
    , headerState :: HeaderState blk'
headerState = HeaderState blk -> HeaderState blk'
forall blk blk'.
(Coercible
   (ChainDepState (BlockProtocol blk))
   (ChainDepState (BlockProtocol blk')),
 TipInfo blk ~ TipInfo blk') =>
HeaderState blk -> HeaderState blk'
castHeaderState HeaderState blk
headerState
    }