{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Ouroboros.Consensus.Ledger.Dual (
    Bridge (..)
    -- * Pair types
  , DualBlock (..)
  , DualGenTxErr (..)
  , DualHeader
  , DualLedgerConfig (..)
  , DualLedgerError (..)
    -- * Lifted functions
  , ctxtDualMain
  , dualExtValidationErrorMain
  , dualTopLevelConfigMain
    -- * Type class family instances
  , BlockConfig (..)
  , CodecConfig (..)
  , GenTx (..)
  , Header (..)
  , LedgerState (..)
  , LedgerTables (..)
  , NestedCtxt_ (..)
  , StorageConfig (..)
  , Ticked (..)
  , TxId (..)
  , Validated (..)
    -- * Serialisation
  , decodeDualBlock
  , decodeDualGenTx
  , decodeDualGenTxErr
  , decodeDualGenTxId
  , decodeDualHeader
  , decodeDualLedgerConfig
  , decodeDualLedgerState
  , encodeDualBlock
  , encodeDualGenTx
  , encodeDualGenTxErr
  , encodeDualGenTxId
  , encodeDualHeader
  , encodeDualLedgerConfig
  , encodeDualLedgerState
  ) where

import           Cardano.Binary (enforceSize)
import           Codec.CBOR.Decoding (Decoder)
import           Codec.CBOR.Encoding (Encoding, encodeListLen)
import           Codec.Serialise
import           Control.Arrow ((+++))
import           Control.Monad.Except
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.Short as Short
import           Data.Functor ((<&>))
import           Data.Kind (Type)
import           Data.Typeable
import           GHC.Generics (Generic)
import           GHC.Stack
import           NoThunks.Class (AllowThunk (..), NoThunks (..))
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Config.SupportsNode
import           Ouroboros.Consensus.HardFork.Abstract
import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.CommonProtocolParams
import           Ouroboros.Consensus.Ledger.Extended
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.Ledger.Tables.Utils
import           Ouroboros.Consensus.Storage.LedgerDB
import           Ouroboros.Consensus.Storage.Serialisation
import           Ouroboros.Consensus.Util (ShowProxy (..))
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.IndexedMemPack

{-------------------------------------------------------------------------------
  Block
-------------------------------------------------------------------------------}

-- | Dual block
--
-- The dual block is used to instantiate the consensus with a dual ledger,
-- consisting of two ledger states associated with two types of blocks. The
-- (consensus) chain state will still be updated based on one block type only,
-- which is therefore designed as the /main/ block, while the other block is
-- designated as the /auxiliary/ block.
--
-- The auxiliary block is optional; this can be used if some " main " blocks
-- should have no effect on the auxiliary ledger state at all. The motivating
-- example is EBBs: if the main blocks are real Byron blocks, and the auxiliary
-- blocks are Byron spec blocks, then regular Byron blocks correspond to Byron
-- spec blocks, but EBBs don't correspond to a spec block at all and should
-- leave the Byron spec ledger state unchanged.
--
-- NOTE: The dual ledger is used for testing purposes only; we do not do any
-- meaningful 'NoThunks' checks here.
data DualBlock m a = DualBlock {
      forall m a. DualBlock m a -> m
dualBlockMain   :: m
    , forall m a. DualBlock m a -> Maybe a
dualBlockAux    :: Maybe a
    , forall m a. DualBlock m a -> BridgeBlock m a
dualBlockBridge :: BridgeBlock m a
    }

deriving instance (Show m, Show a, Show (BridgeBlock m a)) => Show (DualBlock m a)
deriving instance (Eq   m, Eq   a, Eq   (BridgeBlock m a)) => Eq   (DualBlock m a)

instance (Typeable m, Typeable a)
    => ShowProxy (DualBlock m a) where

instance Condense m => Condense (DualBlock m a) where
  condense :: DualBlock m a -> String
condense = m -> String
forall a. Condense a => a -> String
condense (m -> String) -> (DualBlock m a -> m) -> DualBlock m a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DualBlock m a -> m
forall m a. DualBlock m a -> m
dualBlockMain

type instance HeaderHash (DualBlock m a) = HeaderHash m
instance StandardHash m => StandardHash (DualBlock m a)

instance ConvertRawHash m => ConvertRawHash (DualBlock m a) where
  toShortRawHash :: forall (proxy :: * -> *).
proxy (DualBlock m a)
-> HeaderHash (DualBlock m a) -> ShortByteString
toShortRawHash   proxy (DualBlock m a)
_ = Proxy m -> HeaderHash m -> ShortByteString
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ShortByteString
forall (proxy :: * -> *).
proxy m -> HeaderHash m -> ShortByteString
toShortRawHash   (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @m)
  fromShortRawHash :: forall (proxy :: * -> *).
proxy (DualBlock m a)
-> ShortByteString -> HeaderHash (DualBlock m a)
fromShortRawHash proxy (DualBlock m a)
_ = Proxy m -> ShortByteString -> HeaderHash m
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> ShortByteString -> HeaderHash blk
forall (proxy :: * -> *).
proxy m -> ShortByteString -> HeaderHash m
fromShortRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @m)
  hashSize :: forall (proxy :: * -> *). proxy (DualBlock m a) -> Word32
hashSize         proxy (DualBlock m a)
_ = Proxy m -> Word32
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> Word32
forall (proxy :: * -> *). proxy m -> Word32
hashSize         (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @m)

{-------------------------------------------------------------------------------
  Header
-------------------------------------------------------------------------------}

newtype instance Header (DualBlock m a) = DualHeader { forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain :: Header m }
  deriving Context -> Header (DualBlock m a) -> IO (Maybe ThunkInfo)
Proxy (Header (DualBlock m a)) -> String
(Context -> Header (DualBlock m a) -> IO (Maybe ThunkInfo))
-> (Context -> Header (DualBlock m a) -> IO (Maybe ThunkInfo))
-> (Proxy (Header (DualBlock m a)) -> String)
-> NoThunks (Header (DualBlock m a))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall m a.
Context -> Header (DualBlock m a) -> IO (Maybe ThunkInfo)
forall m a. Proxy (Header (DualBlock m a)) -> String
$cnoThunks :: forall m a.
Context -> Header (DualBlock m a) -> IO (Maybe ThunkInfo)
noThunks :: Context -> Header (DualBlock m a) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall m a.
Context -> Header (DualBlock m a) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Header (DualBlock m a) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall m a. Proxy (Header (DualBlock m a)) -> String
showTypeOf :: Proxy (Header (DualBlock m a)) -> String
NoThunks via AllowThunk (Header (DualBlock m a))

instance Bridge m a => GetHeader (DualBlock m a) where
  getHeader :: DualBlock m a -> Header (DualBlock m a)
getHeader = Header m -> Header (DualBlock m a)
forall m a. Header m -> Header (DualBlock m a)
DualHeader (Header m -> Header (DualBlock m a))
-> (DualBlock m a -> Header m)
-> DualBlock m a
-> Header (DualBlock m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> Header m
forall blk. GetHeader blk => blk -> Header blk
getHeader (m -> Header m)
-> (DualBlock m a -> m) -> DualBlock m a -> Header m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DualBlock m a -> m
forall m a. DualBlock m a -> m
dualBlockMain

  blockMatchesHeader :: Header (DualBlock m a) -> DualBlock m a -> Bool
blockMatchesHeader Header (DualBlock m a)
hdr =
      Header m -> m -> Bool
forall blk. GetHeader blk => Header blk -> blk -> Bool
blockMatchesHeader (Header (DualBlock m a) -> Header m
forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain Header (DualBlock m a)
hdr) (m -> Bool) -> (DualBlock m a -> m) -> DualBlock m a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DualBlock m a -> m
forall m a. DualBlock m a -> m
dualBlockMain

  -- We can look at the concrete header to see if this is an EBB
  headerIsEBB :: Header (DualBlock m a) -> Maybe EpochNo
headerIsEBB = Header m -> Maybe EpochNo
forall blk. GetHeader blk => Header blk -> Maybe EpochNo
headerIsEBB (Header m -> Maybe EpochNo)
-> (Header (DualBlock m a) -> Header m)
-> Header (DualBlock m a)
-> Maybe EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (DualBlock m a) -> Header m
forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain

type DualHeader m a = Header (DualBlock m a)

deriving instance Show (Header m) => Show (DualHeader m a)

instance (Typeable m, Typeable a)
    => ShowProxy (DualHeader m a) where

{-------------------------------------------------------------------------------
  Config
-------------------------------------------------------------------------------}

data instance BlockConfig (DualBlock m a) = DualBlockConfig {
      forall m a. BlockConfig (DualBlock m a) -> BlockConfig m
dualBlockConfigMain :: BlockConfig m
    , forall m a. BlockConfig (DualBlock m a) -> BlockConfig a
dualBlockConfigAux  :: BlockConfig a
    }
  deriving Context -> BlockConfig (DualBlock m a) -> IO (Maybe ThunkInfo)
Proxy (BlockConfig (DualBlock m a)) -> String
(Context -> BlockConfig (DualBlock m a) -> IO (Maybe ThunkInfo))
-> (Context -> BlockConfig (DualBlock m a) -> IO (Maybe ThunkInfo))
-> (Proxy (BlockConfig (DualBlock m a)) -> String)
-> NoThunks (BlockConfig (DualBlock m a))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall m a.
Context -> BlockConfig (DualBlock m a) -> IO (Maybe ThunkInfo)
forall m a. Proxy (BlockConfig (DualBlock m a)) -> String
$cnoThunks :: forall m a.
Context -> BlockConfig (DualBlock m a) -> IO (Maybe ThunkInfo)
noThunks :: Context -> BlockConfig (DualBlock m a) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall m a.
Context -> BlockConfig (DualBlock m a) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> BlockConfig (DualBlock m a) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall m a. Proxy (BlockConfig (DualBlock m a)) -> String
showTypeOf :: Proxy (BlockConfig (DualBlock m a)) -> String
NoThunks via AllowThunk (BlockConfig (DualBlock m a))

instance ConfigSupportsNode m => ConfigSupportsNode (DualBlock m a) where
  getSystemStart :: BlockConfig (DualBlock m a) -> SystemStart
getSystemStart  = BlockConfig m -> SystemStart
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> SystemStart
getSystemStart  (BlockConfig m -> SystemStart)
-> (BlockConfig (DualBlock m a) -> BlockConfig m)
-> BlockConfig (DualBlock m a)
-> SystemStart
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockConfig (DualBlock m a) -> BlockConfig m
forall m a. BlockConfig (DualBlock m a) -> BlockConfig m
dualBlockConfigMain
  getNetworkMagic :: BlockConfig (DualBlock m a) -> NetworkMagic
getNetworkMagic = BlockConfig m -> NetworkMagic
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> NetworkMagic
getNetworkMagic (BlockConfig m -> NetworkMagic)
-> (BlockConfig (DualBlock m a) -> BlockConfig m)
-> BlockConfig (DualBlock m a)
-> NetworkMagic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockConfig (DualBlock m a) -> BlockConfig m
forall m a. BlockConfig (DualBlock m a) -> BlockConfig m
dualBlockConfigMain

{-------------------------------------------------------------------------------
  Splitting the config
-------------------------------------------------------------------------------}

-- | This is only used for block production
dualTopLevelConfigMain :: TopLevelConfig (DualBlock m a) -> TopLevelConfig m
dualTopLevelConfigMain :: forall m a. TopLevelConfig (DualBlock m a) -> TopLevelConfig m
dualTopLevelConfigMain TopLevelConfig{StorageConfig (DualBlock m a)
CodecConfig (DualBlock m a)
BlockConfig (DualBlock m a)
ConsensusConfig (BlockProtocol (DualBlock m a))
LedgerConfig (DualBlock m a)
CheckpointsMap (DualBlock m a)
topLevelConfigProtocol :: ConsensusConfig (BlockProtocol (DualBlock m a))
topLevelConfigLedger :: LedgerConfig (DualBlock m a)
topLevelConfigBlock :: BlockConfig (DualBlock m a)
topLevelConfigCodec :: CodecConfig (DualBlock m a)
topLevelConfigStorage :: StorageConfig (DualBlock m a)
topLevelConfigCheckpoints :: CheckpointsMap (DualBlock m a)
topLevelConfigCheckpoints :: forall blk. TopLevelConfig blk -> CheckpointsMap blk
topLevelConfigStorage :: forall blk. TopLevelConfig blk -> StorageConfig blk
topLevelConfigCodec :: forall blk. TopLevelConfig blk -> CodecConfig blk
topLevelConfigBlock :: forall blk. TopLevelConfig blk -> BlockConfig blk
topLevelConfigLedger :: forall blk. TopLevelConfig blk -> LedgerConfig blk
topLevelConfigProtocol :: forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
..} = TopLevelConfig{
      topLevelConfigProtocol :: ConsensusConfig (BlockProtocol m)
topLevelConfigProtocol    = ConsensusConfig (BlockProtocol m)
ConsensusConfig (BlockProtocol (DualBlock m a))
topLevelConfigProtocol
    , topLevelConfigLedger :: LedgerConfig m
topLevelConfigLedger      = DualLedgerConfig m a -> LedgerConfig m
forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigMain  LedgerConfig (DualBlock m a)
DualLedgerConfig m a
topLevelConfigLedger
    , topLevelConfigBlock :: BlockConfig m
topLevelConfigBlock       = BlockConfig (DualBlock m a) -> BlockConfig m
forall m a. BlockConfig (DualBlock m a) -> BlockConfig m
dualBlockConfigMain   BlockConfig (DualBlock m a)
topLevelConfigBlock
    , topLevelConfigCodec :: CodecConfig m
topLevelConfigCodec       = CodecConfig (DualBlock m a) -> CodecConfig m
forall m a. CodecConfig (DualBlock m a) -> CodecConfig m
dualCodecConfigMain   CodecConfig (DualBlock m a)
topLevelConfigCodec
    , topLevelConfigStorage :: StorageConfig m
topLevelConfigStorage     = StorageConfig (DualBlock m a) -> StorageConfig m
forall m a. StorageConfig (DualBlock m a) -> StorageConfig m
dualStorageConfigMain StorageConfig (DualBlock m a)
topLevelConfigStorage
    , topLevelConfigCheckpoints :: CheckpointsMap m
topLevelConfigCheckpoints = CheckpointsMap (DualBlock m a) -> CheckpointsMap m
forall blk blk'.
Coercible (HeaderHash blk) (HeaderHash blk') =>
CheckpointsMap blk -> CheckpointsMap blk'
castCheckpointsMap CheckpointsMap (DualBlock m a)
topLevelConfigCheckpoints
    }

{-------------------------------------------------------------------------------
  CodecConfig
-------------------------------------------------------------------------------}

data instance CodecConfig (DualBlock m a) = DualCodecConfig {
      forall m a. CodecConfig (DualBlock m a) -> CodecConfig m
dualCodecConfigMain :: !(CodecConfig m)
    , forall m a. CodecConfig (DualBlock m a) -> CodecConfig a
dualCodecConfigAux  :: !(CodecConfig a)
    }
  deriving ((forall x.
 CodecConfig (DualBlock m a) -> Rep (CodecConfig (DualBlock m a)) x)
-> (forall x.
    Rep (CodecConfig (DualBlock m a)) x -> CodecConfig (DualBlock m a))
-> Generic (CodecConfig (DualBlock m a))
forall x.
Rep (CodecConfig (DualBlock m a)) x -> CodecConfig (DualBlock m a)
forall x.
CodecConfig (DualBlock m a) -> Rep (CodecConfig (DualBlock m a)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall m a x.
Rep (CodecConfig (DualBlock m a)) x -> CodecConfig (DualBlock m a)
forall m a x.
CodecConfig (DualBlock m a) -> Rep (CodecConfig (DualBlock m a)) x
$cfrom :: forall m a x.
CodecConfig (DualBlock m a) -> Rep (CodecConfig (DualBlock m a)) x
from :: forall x.
CodecConfig (DualBlock m a) -> Rep (CodecConfig (DualBlock m a)) x
$cto :: forall m a x.
Rep (CodecConfig (DualBlock m a)) x -> CodecConfig (DualBlock m a)
to :: forall x.
Rep (CodecConfig (DualBlock m a)) x -> CodecConfig (DualBlock m a)
Generic)

instance ( NoThunks (CodecConfig m)
         , NoThunks (CodecConfig a)
         ) => NoThunks (CodecConfig (DualBlock m a))
  -- Use generic instance

{-------------------------------------------------------------------------------
  StorageConfig
-------------------------------------------------------------------------------}

data instance StorageConfig (DualBlock m a) = DualStorageConfig {
      forall m a. StorageConfig (DualBlock m a) -> StorageConfig m
dualStorageConfigMain :: !(StorageConfig m)
    , forall m a. StorageConfig (DualBlock m a) -> StorageConfig a
dualStorageConfigAux  :: !(StorageConfig a)
    }
  deriving ((forall x.
 StorageConfig (DualBlock m a)
 -> Rep (StorageConfig (DualBlock m a)) x)
-> (forall x.
    Rep (StorageConfig (DualBlock m a)) x
    -> StorageConfig (DualBlock m a))
-> Generic (StorageConfig (DualBlock m a))
forall x.
Rep (StorageConfig (DualBlock m a)) x
-> StorageConfig (DualBlock m a)
forall x.
StorageConfig (DualBlock m a)
-> Rep (StorageConfig (DualBlock m a)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall m a x.
Rep (StorageConfig (DualBlock m a)) x
-> StorageConfig (DualBlock m a)
forall m a x.
StorageConfig (DualBlock m a)
-> Rep (StorageConfig (DualBlock m a)) x
$cfrom :: forall m a x.
StorageConfig (DualBlock m a)
-> Rep (StorageConfig (DualBlock m a)) x
from :: forall x.
StorageConfig (DualBlock m a)
-> Rep (StorageConfig (DualBlock m a)) x
$cto :: forall m a x.
Rep (StorageConfig (DualBlock m a)) x
-> StorageConfig (DualBlock m a)
to :: forall x.
Rep (StorageConfig (DualBlock m a)) x
-> StorageConfig (DualBlock m a)
Generic)

instance ( NoThunks (StorageConfig m)
         , NoThunks (StorageConfig a)
         ) => NoThunks (StorageConfig (DualBlock m a))
  -- Use generic instance

{-------------------------------------------------------------------------------
  Bridge two ledgers
-------------------------------------------------------------------------------}

-- | Bridge the two ledgers
class (
        -- Requirements on the main block
        HasHeader              m
      , GetHeader              m
      , HasHeader     (Header  m)
      , LedgerSupportsProtocol m
      , HasHardForkHistory     m
      , LedgerSupportsMempool  m
      , CommonProtocolParams   m
      , HasTxId (GenTx         m)
      , Show (ApplyTxErr       m)
      , Show (LedgerConfig     m)

        -- Requirements on the auxiliary block
        -- No 'LedgerSupportsProtocol' for @a@!
      , Typeable                a
      , UpdateLedger            a
      , LedgerSupportsMempool   a
      , Show (ApplyTxErr        a)
      , Show (LedgerConfig      a)
      , NoThunks (LedgerConfig  a)
      , NoThunks (CodecConfig   a)
      , NoThunks (StorageConfig a)

        -- Requirements on the various bridges
      , Show      (BridgeLedger m a)
      , Eq        (BridgeLedger m a)
      , Serialise (BridgeLedger m a)
      , Serialise (BridgeBlock  m a)
      , Serialise (BridgeTx     m a)
      , Show      (BridgeTx     m a)
      ) => Bridge m a where

  -- | Additional information relating both ledgers
  type BridgeLedger m a :: Type

  -- | Information required to update the bridge when applying a block
  type BridgeBlock m a :: Type

  -- | Information required to update the bridge when applying a transaction
  type BridgeTx m a :: Type

  updateBridgeWithBlock :: DualBlock m a
                        -> BridgeLedger m a -> BridgeLedger m a

  updateBridgeWithTx :: Validated (GenTx (DualBlock m a))
                     -> BridgeLedger m a -> BridgeLedger m a

{-------------------------------------------------------------------------------
  HasHeader instance
-------------------------------------------------------------------------------}

instance Bridge m a => HasHeader (DualBlock m a) where
  getHeaderFields :: DualBlock m a -> HeaderFields (DualBlock m a)
getHeaderFields = DualBlock m a -> HeaderFields (DualBlock m a)
forall blk. GetHeader blk => blk -> HeaderFields blk
getBlockHeaderFields

instance Bridge m a => HasHeader (DualHeader m a) where
  getHeaderFields :: DualHeader m a -> HeaderFields (DualHeader m a)
getHeaderFields = HeaderFields (Header m) -> HeaderFields (DualHeader m a)
forall {k1} {k2} (b :: k1) (b' :: k2).
(HeaderHash b ~ HeaderHash b') =>
HeaderFields b -> HeaderFields b'
castHeaderFields (HeaderFields (Header m) -> HeaderFields (DualHeader m a))
-> (DualHeader m a -> HeaderFields (Header m))
-> DualHeader m a
-> HeaderFields (DualHeader m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header m -> HeaderFields (Header m)
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields (Header m -> HeaderFields (Header m))
-> (DualHeader m a -> Header m)
-> DualHeader m a
-> HeaderFields (Header m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DualHeader m a -> Header m
forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain

instance Bridge m a => GetPrevHash (DualBlock m a) where
  headerPrevHash :: Header (DualBlock m a) -> ChainHash (DualBlock m a)
headerPrevHash = ChainHash m -> ChainHash (DualBlock m a)
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (ChainHash m -> ChainHash (DualBlock m a))
-> (Header (DualBlock m a) -> ChainHash m)
-> Header (DualBlock m a)
-> ChainHash (DualBlock m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header m -> ChainHash m
forall blk. GetPrevHash blk => Header blk -> ChainHash blk
headerPrevHash (Header m -> ChainHash m)
-> (Header (DualBlock m a) -> Header m)
-> Header (DualBlock m a)
-> ChainHash m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (DualBlock m a) -> Header m
forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain

{-------------------------------------------------------------------------------
  Protocol
-------------------------------------------------------------------------------}

type instance BlockProtocol (DualBlock m a) = BlockProtocol m

instance Bridge m a => BlockSupportsProtocol (DualBlock m a) where
  validateView :: BlockConfig (DualBlock m a)
-> Header (DualBlock m a)
-> ValidateView (BlockProtocol (DualBlock m a))
validateView BlockConfig (DualBlock m a)
cfg = BlockConfig m -> Header m -> ValidateView (BlockProtocol m)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> ValidateView (BlockProtocol blk)
validateView (BlockConfig (DualBlock m a) -> BlockConfig m
forall m a. BlockConfig (DualBlock m a) -> BlockConfig m
dualBlockConfigMain BlockConfig (DualBlock m a)
cfg) (Header m -> ValidateView (BlockProtocol m))
-> (Header (DualBlock m a) -> Header m)
-> Header (DualBlock m a)
-> ValidateView (BlockProtocol m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (DualBlock m a) -> Header m
forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain
  selectView :: BlockConfig (DualBlock m a)
-> Header (DualBlock m a)
-> SelectView (BlockProtocol (DualBlock m a))
selectView   BlockConfig (DualBlock m a)
cfg = BlockConfig m -> Header m -> SelectView (BlockProtocol m)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView   (BlockConfig (DualBlock m a) -> BlockConfig m
forall m a. BlockConfig (DualBlock m a) -> BlockConfig m
dualBlockConfigMain BlockConfig (DualBlock m a)
cfg) (Header m -> SelectView (BlockProtocol m))
-> (Header (DualBlock m a) -> Header m)
-> Header (DualBlock m a)
-> SelectView (BlockProtocol m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (DualBlock m a) -> Header m
forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain

  projectChainOrderConfig :: BlockConfig (DualBlock m a)
-> ChainOrderConfig (SelectView (BlockProtocol (DualBlock m a)))
projectChainOrderConfig = BlockConfig m -> ChainOrderConfig (SelectView (BlockProtocol m))
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk
-> ChainOrderConfig (SelectView (BlockProtocol blk))
projectChainOrderConfig (BlockConfig m -> ChainOrderConfig (SelectView (BlockProtocol m)))
-> (BlockConfig (DualBlock m a) -> BlockConfig m)
-> BlockConfig (DualBlock m a)
-> ChainOrderConfig (SelectView (BlockProtocol m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockConfig (DualBlock m a) -> BlockConfig m
forall m a. BlockConfig (DualBlock m a) -> BlockConfig m
dualBlockConfigMain

{-------------------------------------------------------------------------------
  Ledger errors
-------------------------------------------------------------------------------}

-- | Both ledger rules threw an error
--
-- We do not verify that the errors agree, merely that they both report /some/
-- error.
--
-- If only /one/ of the two semantics reports an error, we fail with an 'error'
-- (see 'agreeOnError'), rather than a regular chain failure; if this happens,
-- it indicates a bug, and the node should fail (rather than just, for example,
-- reject a block).
data DualLedgerError m a = DualLedgerError {
        forall m a. DualLedgerError m a -> LedgerError m
dualLedgerErrorMain :: LedgerError m
      , forall m a. DualLedgerError m a -> LedgerError a
dualLedgerErrorAux  :: LedgerError a
      }
  deriving Context -> DualLedgerError m a -> IO (Maybe ThunkInfo)
Proxy (DualLedgerError m a) -> String
(Context -> DualLedgerError m a -> IO (Maybe ThunkInfo))
-> (Context -> DualLedgerError m a -> IO (Maybe ThunkInfo))
-> (Proxy (DualLedgerError m a) -> String)
-> NoThunks (DualLedgerError m a)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall m a. Context -> DualLedgerError m a -> IO (Maybe ThunkInfo)
forall m a. Proxy (DualLedgerError m a) -> String
$cnoThunks :: forall m a. Context -> DualLedgerError m a -> IO (Maybe ThunkInfo)
noThunks :: Context -> DualLedgerError m a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall m a. Context -> DualLedgerError m a -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> DualLedgerError m a -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall m a. Proxy (DualLedgerError m a) -> String
showTypeOf :: Proxy (DualLedgerError m a) -> String
NoThunks via AllowThunk (DualLedgerError m a)

deriving instance ( Show (LedgerError m)
                  , Show (LedgerError a)
                  ) => Show (DualLedgerError m a)
deriving instance ( Eq (LedgerError m)
                  , Eq (LedgerError a)
                  ) => Eq (DualLedgerError m a)

{-------------------------------------------------------------------------------
  Update the ledger
-------------------------------------------------------------------------------}

data DualLedgerConfig m a = DualLedgerConfig {
      forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigMain :: LedgerConfig m
    , forall m a. DualLedgerConfig m a -> LedgerConfig a
dualLedgerConfigAux  :: LedgerConfig a
    }
  deriving Context -> DualLedgerConfig m a -> IO (Maybe ThunkInfo)
Proxy (DualLedgerConfig m a) -> String
(Context -> DualLedgerConfig m a -> IO (Maybe ThunkInfo))
-> (Context -> DualLedgerConfig m a -> IO (Maybe ThunkInfo))
-> (Proxy (DualLedgerConfig m a) -> String)
-> NoThunks (DualLedgerConfig m a)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall m a. Context -> DualLedgerConfig m a -> IO (Maybe ThunkInfo)
forall m a. Proxy (DualLedgerConfig m a) -> String
$cnoThunks :: forall m a. Context -> DualLedgerConfig m a -> IO (Maybe ThunkInfo)
noThunks :: Context -> DualLedgerConfig m a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall m a. Context -> DualLedgerConfig m a -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> DualLedgerConfig m a -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall m a. Proxy (DualLedgerConfig m a) -> String
showTypeOf :: Proxy (DualLedgerConfig m a) -> String
NoThunks via AllowThunk (DualLedgerConfig m a)

deriving instance (Show (LedgerConfig m), Show (LedgerConfig a)) => Show (DualLedgerConfig m a)

type instance LedgerCfg (LedgerState (DualBlock m a)) = DualLedgerConfig m a

instance Bridge m a => HasPartialLedgerConfig (DualBlock m a)

instance Bridge m a => GetTip (LedgerState (DualBlock m a)) where
  getTip :: forall (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk
-> Point (LedgerState (DualBlock m a))
getTip = Point (LedgerState m) -> Point (LedgerState (DualBlock m a))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (LedgerState m) -> Point (LedgerState (DualBlock m a)))
-> (LedgerState (DualBlock m a) mk -> Point (LedgerState m))
-> LedgerState (DualBlock m a) mk
-> Point (LedgerState (DualBlock m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState m mk -> Point (LedgerState m)
forall (mk :: * -> * -> *).
LedgerState m mk -> Point (LedgerState m)
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip (LedgerState m mk -> Point (LedgerState m))
-> (LedgerState (DualBlock m a) mk -> LedgerState m mk)
-> LedgerState (DualBlock m a) mk
-> Point (LedgerState m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (DualBlock m a) mk -> LedgerState m mk
forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain

instance Bridge m a => GetTip (Ticked (LedgerState (DualBlock m a))) where
  getTip :: forall (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Point (Ticked (LedgerState (DualBlock m a)))
getTip = Point (Ticked (LedgerState m))
-> Point (Ticked (LedgerState (DualBlock m a)))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Ticked (LedgerState m))
 -> Point (Ticked (LedgerState (DualBlock m a))))
-> (Ticked (LedgerState (DualBlock m a)) mk
    -> Point (Ticked (LedgerState m)))
-> Ticked (LedgerState (DualBlock m a)) mk
-> Point (Ticked (LedgerState (DualBlock m a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState m) mk -> Point (Ticked (LedgerState m))
forall (mk :: * -> * -> *).
Ticked (LedgerState m) mk -> Point (Ticked (LedgerState m))
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip (Ticked (LedgerState m) mk -> Point (Ticked (LedgerState m)))
-> (Ticked (LedgerState (DualBlock m a)) mk
    -> Ticked (LedgerState m) mk)
-> Ticked (LedgerState (DualBlock m a)) mk
-> Point (Ticked (LedgerState m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateMain

-- We only have tables on the main ledger state to be able to compare it to a
-- reference spec implementation which doesn't use tables. The result should be
-- the same.
data instance Ticked (LedgerState (DualBlock m a)) mk = TickedDualLedgerState {
      forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateMain    :: Ticked (LedgerState m) mk
    , forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux     :: Ticked (LedgerState a) ValuesMK
    , forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> BridgeLedger m a
tickedDualLedgerStateBridge  :: BridgeLedger m a

      -- | The original, unticked ledger for the auxiliary block
      --
      -- The reason we keep this in addition to the ticked ledger state is that
      -- not every main block is paired with an auxiliary block. When there is
      -- no auxiliary block, the auxiliary ledger state remains unchanged.
    , forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> LedgerState a ValuesMK
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
    }
  deriving Context
-> Ticked (LedgerState (DualBlock m a)) mk -> IO (Maybe ThunkInfo)
Proxy (Ticked (LedgerState (DualBlock m a)) mk) -> String
(Context
 -> Ticked (LedgerState (DualBlock m a)) mk -> IO (Maybe ThunkInfo))
-> (Context
    -> Ticked (LedgerState (DualBlock m a)) mk -> IO (Maybe ThunkInfo))
-> (Proxy (Ticked (LedgerState (DualBlock m a)) mk) -> String)
-> NoThunks (Ticked (LedgerState (DualBlock m a)) mk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall m a (mk :: * -> * -> *).
Context
-> Ticked (LedgerState (DualBlock m a)) mk -> IO (Maybe ThunkInfo)
forall m a (mk :: * -> * -> *).
Proxy (Ticked (LedgerState (DualBlock m a)) mk) -> String
$cnoThunks :: forall m a (mk :: * -> * -> *).
Context
-> Ticked (LedgerState (DualBlock m a)) mk -> IO (Maybe ThunkInfo)
noThunks :: Context
-> Ticked (LedgerState (DualBlock m a)) mk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall m a (mk :: * -> * -> *).
Context
-> Ticked (LedgerState (DualBlock m a)) mk -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> Ticked (LedgerState (DualBlock m a)) mk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall m a (mk :: * -> * -> *).
Proxy (Ticked (LedgerState (DualBlock m a)) mk) -> String
showTypeOf :: Proxy (Ticked (LedgerState (DualBlock m a)) mk) -> String
NoThunks via AllowThunk (Ticked (LedgerState (DualBlock m a)) mk)

instance Bridge m a => IsLedger (LedgerState (DualBlock m a)) where
  type LedgerErr (LedgerState (DualBlock m a)) = DualLedgerError   m a

  -- | The dual ledger events are exactly those of the main ledger; it ignores
  -- any possible auxiliary ledger events.
  --
  -- NOTE: This may change. It's unclear whether we want the two ledgers to emit
  -- the same events. And right now we only use the Dual ledger for our tests,
  -- and do so only with the Byron and ByronSpecs ledgers, neither of which have
  -- any events. So we make this easy choice for for now.
  type AuxLedgerEvent (LedgerState (DualBlock m a)) = AuxLedgerEvent (LedgerState m)

  applyChainTickLedgerResult :: ComputeLedgerEvents
-> LedgerCfg (LedgerState (DualBlock m a))
-> SlotNo
-> LedgerState (DualBlock m a) EmptyMK
-> LedgerResult
     (LedgerState (DualBlock m a))
     (Ticked (LedgerState (DualBlock m a)) DiffMK)
applyChainTickLedgerResult ComputeLedgerEvents
evs
                             DualLedgerConfig{LedgerConfig m
LedgerConfig a
dualLedgerConfigMain :: forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigAux :: forall m a. DualLedgerConfig m a -> LedgerConfig a
dualLedgerConfigMain :: LedgerConfig m
dualLedgerConfigAux :: LedgerConfig a
..}
                             SlotNo
slot
                             DualLedgerState{LedgerState m EmptyMK
LedgerState a ValuesMK
BridgeLedger m a
dualLedgerStateMain :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain :: LedgerState m EmptyMK
dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> BridgeLedger m a
dualLedgerStateAux :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState a ValuesMK
..} =
      LedgerResult (LedgerState m) (Ticked (LedgerState m) DiffMK)
-> LedgerResult
     (LedgerState (DualBlock m a)) (Ticked (LedgerState m) DiffMK)
forall (l :: LedgerStateKind) (l' :: LedgerStateKind) a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult (LedgerState m) (Ticked (LedgerState m) DiffMK)
ledgerResult LedgerResult
  (LedgerState (DualBlock m a)) (Ticked (LedgerState m) DiffMK)
-> (Ticked (LedgerState m) DiffMK
    -> Ticked (LedgerState (DualBlock m a)) DiffMK)
-> LedgerResult
     (LedgerState (DualBlock m a))
     (Ticked (LedgerState (DualBlock m a)) DiffMK)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Ticked (LedgerState m) DiffMK
main -> TickedDualLedgerState {
          tickedDualLedgerStateMain :: Ticked (LedgerState m) DiffMK
tickedDualLedgerStateMain    = Ticked (LedgerState m) DiffMK
main
        , tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux     = LedgerState a ValuesMK
-> Ticked (LedgerState a) DiffMK -> Ticked (LedgerState a) ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' DiffMK -> l' ValuesMK
applyDiffs LedgerState a ValuesMK
dualLedgerStateAux Ticked (LedgerState a) DiffMK
dualLedger
        , tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
tickedDualLedgerStateAuxOrig = LedgerState a ValuesMK
dualLedgerStateAux
        , tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateBridge  = BridgeLedger m a
dualLedgerStateBridge
        }
    where
      dualLedger :: Ticked (LedgerState a) DiffMK
dualLedger = ComputeLedgerEvents
-> LedgerConfig a
-> SlotNo
-> LedgerState a EmptyMK
-> Ticked (LedgerState a) DiffMK
forall (l :: LedgerStateKind).
IsLedger l =>
ComputeLedgerEvents
-> LedgerCfg l -> SlotNo -> l EmptyMK -> Ticked l DiffMK
applyChainTick ComputeLedgerEvents
evs
                     LedgerConfig a
dualLedgerConfigAux
                     SlotNo
slot
                     (LedgerState a ValuesMK -> LedgerState a EmptyMK
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables LedgerState a ValuesMK
dualLedgerStateAux)
      ledgerResult :: LedgerResult (LedgerState m) (Ticked (LedgerState m) DiffMK)
ledgerResult = ComputeLedgerEvents
-> LedgerConfig m
-> SlotNo
-> LedgerState m EmptyMK
-> LedgerResult (LedgerState m) (Ticked (LedgerState m) DiffMK)
forall (l :: LedgerStateKind).
IsLedger l =>
ComputeLedgerEvents
-> LedgerCfg l
-> SlotNo
-> l EmptyMK
-> LedgerResult l (Ticked l DiffMK)
applyChainTickLedgerResult ComputeLedgerEvents
evs
                       LedgerConfig m
dualLedgerConfigMain
                       SlotNo
slot
                       LedgerState m EmptyMK
dualLedgerStateMain

applyHelper ::
     Bridge m a
  => (   ComputeLedgerEvents
      -> LedgerCfg (LedgerState m)
      -> m
      -> Ticked (LedgerState m) ValuesMK
      -> Except (LedgerErr (LedgerState m)) (LedgerResult (LedgerState m) (LedgerState m DiffMK))
     )
  -> ComputeLedgerEvents
  -> DualLedgerConfig m a
  -> DualBlock m a
  -> Ticked (LedgerState (DualBlock m a)) ValuesMK
  -> Except (DualLedgerError m a) (LedgerResult (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a) DiffMK))
applyHelper :: forall m a.
Bridge m a =>
(ComputeLedgerEvents
 -> LedgerCfg (LedgerState m)
 -> m
 -> Ticked (LedgerState m) ValuesMK
 -> Except
      (LedgerErr (LedgerState m))
      (LedgerResult (LedgerState m) (LedgerState m DiffMK)))
-> ComputeLedgerEvents
-> DualLedgerConfig m a
-> DualBlock m a
-> Ticked (LedgerState (DualBlock m a)) ValuesMK
-> Except
     (DualLedgerError m a)
     (LedgerResult
        (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a) DiffMK))
applyHelper ComputeLedgerEvents
-> LedgerCfg (LedgerState m)
-> m
-> Ticked (LedgerState m) ValuesMK
-> Except
     (LedgerErr (LedgerState m))
     (LedgerResult (LedgerState m) (LedgerState m DiffMK))
f ComputeLedgerEvents
opts DualLedgerConfig m a
cfg block :: DualBlock m a
block@DualBlock{m
Maybe a
BridgeBlock m a
dualBlockMain :: forall m a. DualBlock m a -> m
dualBlockAux :: forall m a. DualBlock m a -> Maybe a
dualBlockBridge :: forall m a. DualBlock m a -> BridgeBlock m a
dualBlockMain :: m
dualBlockAux :: Maybe a
dualBlockBridge :: BridgeBlock m a
..} TickedDualLedgerState{Ticked (LedgerState m) ValuesMK
Ticked (LedgerState a) ValuesMK
LedgerState a ValuesMK
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateAux :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> LedgerState a ValuesMK
tickedDualLedgerStateMain :: Ticked (LedgerState m) ValuesMK
tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
..} = do
      (ledgerResult, aux') <-
        (LedgerErr (LedgerState m)
 -> LedgerErr (LedgerState a) -> DualLedgerError m a)
-> (Except
      (LedgerErr (LedgerState m))
      (LedgerResult (LedgerState m) (LedgerState m DiffMK)),
    Except (LedgerErr (LedgerState a)) (LedgerState a DiffMK))
-> Except
     (DualLedgerError m a)
     (LedgerResult (LedgerState m) (LedgerState m DiffMK),
      LedgerState a DiffMK)
forall e e' err a b.
(Show e, Show e', HasCallStack) =>
(e -> e' -> err) -> (Except e a, Except e' b) -> Except err (a, b)
agreeOnError LedgerErr (LedgerState m)
-> LedgerErr (LedgerState a) -> DualLedgerError m a
forall m a. LedgerError m -> LedgerError a -> DualLedgerError m a
DualLedgerError (
             ComputeLedgerEvents
-> LedgerCfg (LedgerState m)
-> m
-> Ticked (LedgerState m) ValuesMK
-> Except
     (LedgerErr (LedgerState m))
     (LedgerResult (LedgerState m) (LedgerState m DiffMK))
f ComputeLedgerEvents
opts
              (DualLedgerConfig m a -> LedgerCfg (LedgerState m)
forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigMain DualLedgerConfig m a
cfg)
              m
dualBlockMain
              Ticked (LedgerState m) ValuesMK
tickedDualLedgerStateMain
          , ComputeLedgerEvents
-> LedgerConfig a
-> Maybe a
-> Ticked (LedgerState a) ValuesMK
-> LedgerState a EmptyMK
-> Except (LedgerErr (LedgerState a)) (LedgerState a DiffMK)
forall blk.
UpdateLedger blk =>
ComputeLedgerEvents
-> LedgerConfig blk
-> Maybe blk
-> TickedLedgerState blk ValuesMK
-> LedgerState blk EmptyMK
-> Except (LedgerError blk) (LedgerState blk DiffMK)
applyMaybeBlock ComputeLedgerEvents
opts
              (DualLedgerConfig m a -> LedgerConfig a
forall m a. DualLedgerConfig m a -> LedgerConfig a
dualLedgerConfigAux DualLedgerConfig m a
cfg)
              Maybe a
dualBlockAux
              Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux
              (LedgerState a ValuesMK -> LedgerState a EmptyMK
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables LedgerState a ValuesMK
tickedDualLedgerStateAuxOrig)
          )
      return $ castLedgerResult ledgerResult <&> \LedgerState m DiffMK
main' -> DualLedgerState {
          dualLedgerStateMain :: LedgerState m DiffMK
dualLedgerStateMain   = LedgerState m DiffMK
main'
        , dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateAux    = Ticked (LedgerState a) ValuesMK
-> LedgerState a DiffMK -> LedgerState a ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' DiffMK -> l' ValuesMK
applyDiffs Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux LedgerState a DiffMK
aux'
        , dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateBridge = DualBlock m a -> BridgeLedger m a -> BridgeLedger m a
forall m a.
Bridge m a =>
DualBlock m a -> BridgeLedger m a -> BridgeLedger m a
updateBridgeWithBlock
                                    DualBlock m a
block
                                    BridgeLedger m a
tickedDualLedgerStateBridge
        }

instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) where

  applyBlockLedgerResultWithValidation :: HasCallStack =>
ValidationPolicy
-> ComputeLedgerEvents
-> LedgerCfg (LedgerState (DualBlock m a))
-> DualBlock m a
-> Ticked (LedgerState (DualBlock m a)) ValuesMK
-> Except
     (LedgerErr (LedgerState (DualBlock m a)))
     (LedgerResult
        (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a) DiffMK))
applyBlockLedgerResultWithValidation ValidationPolicy
doValidate =
    (ComputeLedgerEvents
 -> LedgerCfg (LedgerState m)
 -> m
 -> Ticked (LedgerState m) ValuesMK
 -> Except
      (LedgerErr (LedgerState m))
      (LedgerResult (LedgerState m) (LedgerState m DiffMK)))
-> ComputeLedgerEvents
-> DualLedgerConfig m a
-> DualBlock m a
-> Ticked (LedgerState (DualBlock m a)) ValuesMK
-> Except
     (DualLedgerError m a)
     (LedgerResult
        (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a) DiffMK))
forall m a.
Bridge m a =>
(ComputeLedgerEvents
 -> LedgerCfg (LedgerState m)
 -> m
 -> Ticked (LedgerState m) ValuesMK
 -> Except
      (LedgerErr (LedgerState m))
      (LedgerResult (LedgerState m) (LedgerState m DiffMK)))
-> ComputeLedgerEvents
-> DualLedgerConfig m a
-> DualBlock m a
-> Ticked (LedgerState (DualBlock m a)) ValuesMK
-> Except
     (DualLedgerError m a)
     (LedgerResult
        (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a) DiffMK))
applyHelper (ValidationPolicy
-> ComputeLedgerEvents
-> LedgerCfg (LedgerState m)
-> m
-> Ticked (LedgerState m) ValuesMK
-> Except
     (LedgerErr (LedgerState m))
     (LedgerResult (LedgerState m) (LedgerState m DiffMK))
forall (l :: LedgerStateKind) blk.
(ApplyBlock l blk, HasCallStack) =>
ValidationPolicy
-> ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> Except (LedgerErr l) (LedgerResult l (l DiffMK))
applyBlockLedgerResultWithValidation ValidationPolicy
doValidate)

  applyBlockLedgerResult :: HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (LedgerState (DualBlock m a))
-> DualBlock m a
-> Ticked (LedgerState (DualBlock m a)) ValuesMK
-> Except
     (LedgerErr (LedgerState (DualBlock m a)))
     (LedgerResult
        (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a) DiffMK))
applyBlockLedgerResult =
    (ComputeLedgerEvents
 -> LedgerCfg (LedgerState m)
 -> m
 -> Ticked (LedgerState m) ValuesMK
 -> Except
      (LedgerErr (LedgerState m))
      (LedgerResult (LedgerState m) (LedgerState m DiffMK)))
-> ComputeLedgerEvents
-> DualLedgerConfig m a
-> DualBlock m a
-> Ticked (LedgerState (DualBlock m a)) ValuesMK
-> Except
     (DualLedgerError m a)
     (LedgerResult
        (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a) DiffMK))
forall m a.
Bridge m a =>
(ComputeLedgerEvents
 -> LedgerCfg (LedgerState m)
 -> m
 -> Ticked (LedgerState m) ValuesMK
 -> Except
      (LedgerErr (LedgerState m))
      (LedgerResult (LedgerState m) (LedgerState m DiffMK)))
-> ComputeLedgerEvents
-> DualLedgerConfig m a
-> DualBlock m a
-> Ticked (LedgerState (DualBlock m a)) ValuesMK
-> Except
     (DualLedgerError m a)
     (LedgerResult
        (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a) DiffMK))
applyHelper ComputeLedgerEvents
-> LedgerCfg (LedgerState m)
-> m
-> Ticked (LedgerState m) ValuesMK
-> Except
     (LedgerErr (LedgerState m))
     (LedgerResult (LedgerState m) (LedgerState m DiffMK))
forall (l :: LedgerStateKind) blk.
(ApplyBlock l blk, HasCallStack) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> Except (LedgerErr l) (LedgerResult l (l DiffMK))
applyBlockLedgerResult

  reapplyBlockLedgerResult :: HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (LedgerState (DualBlock m a))
-> DualBlock m a
-> Ticked (LedgerState (DualBlock m a)) ValuesMK
-> LedgerResult
     (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a) DiffMK)
reapplyBlockLedgerResult ComputeLedgerEvents
evs LedgerCfg (LedgerState (DualBlock m a))
cfg
                           block :: DualBlock m a
block@DualBlock{m
Maybe a
BridgeBlock m a
dualBlockMain :: forall m a. DualBlock m a -> m
dualBlockAux :: forall m a. DualBlock m a -> Maybe a
dualBlockBridge :: forall m a. DualBlock m a -> BridgeBlock m a
dualBlockMain :: m
dualBlockAux :: Maybe a
dualBlockBridge :: BridgeBlock m a
..}
                           TickedDualLedgerState{Ticked (LedgerState m) ValuesMK
Ticked (LedgerState a) ValuesMK
LedgerState a ValuesMK
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateAux :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> LedgerState a ValuesMK
tickedDualLedgerStateMain :: Ticked (LedgerState m) ValuesMK
tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
..} =
    LedgerResult (LedgerState m) (LedgerState m DiffMK)
-> LedgerResult
     (LedgerState (DualBlock m a)) (LedgerState m DiffMK)
forall (l :: LedgerStateKind) (l' :: LedgerStateKind) a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult (LedgerState m) (LedgerState m DiffMK)
ledgerResult LedgerResult (LedgerState (DualBlock m a)) (LedgerState m DiffMK)
-> (LedgerState m DiffMK -> LedgerState (DualBlock m a) DiffMK)
-> LedgerResult
     (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a) DiffMK)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \LedgerState m DiffMK
main' -> DualLedgerState {
        dualLedgerStateMain :: LedgerState m DiffMK
dualLedgerStateMain   = LedgerState m DiffMK
main'
      , dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateAux    = Ticked (LedgerState a) ValuesMK
-> LedgerState a DiffMK -> LedgerState a ValuesMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' DiffMK -> l' ValuesMK
applyDiffs Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux LedgerState a DiffMK
auxLedger
      , dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateBridge = DualBlock m a -> BridgeLedger m a -> BridgeLedger m a
forall m a.
Bridge m a =>
DualBlock m a -> BridgeLedger m a -> BridgeLedger m a
updateBridgeWithBlock
                                  DualBlock m a
block
                                  BridgeLedger m a
tickedDualLedgerStateBridge
      }
   where
      auxLedger :: LedgerState a DiffMK
auxLedger = ComputeLedgerEvents
-> LedgerConfig a
-> Maybe a
-> Ticked (LedgerState a) ValuesMK
-> LedgerState a EmptyMK
-> LedgerState a DiffMK
forall blk.
UpdateLedger blk =>
ComputeLedgerEvents
-> LedgerConfig blk
-> Maybe blk
-> TickedLedgerState blk ValuesMK
-> LedgerState blk EmptyMK
-> LedgerState blk DiffMK
reapplyMaybeBlock ComputeLedgerEvents
evs
                    (DualLedgerConfig m a -> LedgerConfig a
forall m a. DualLedgerConfig m a -> LedgerConfig a
dualLedgerConfigAux LedgerCfg (LedgerState (DualBlock m a))
DualLedgerConfig m a
cfg)
                    Maybe a
dualBlockAux
                    Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux
                    (LedgerState a ValuesMK -> LedgerState a EmptyMK
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables LedgerState a ValuesMK
tickedDualLedgerStateAuxOrig)
      ledgerResult :: LedgerResult (LedgerState m) (LedgerState m DiffMK)
ledgerResult = ComputeLedgerEvents
-> LedgerCfg (LedgerState m)
-> m
-> Ticked (LedgerState m) ValuesMK
-> LedgerResult (LedgerState m) (LedgerState m DiffMK)
forall (l :: LedgerStateKind) blk.
(ApplyBlock l blk, HasCallStack) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> LedgerResult l (l DiffMK)
reapplyBlockLedgerResult ComputeLedgerEvents
evs
                       (DualLedgerConfig m a -> LedgerCfg (LedgerState m)
forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigMain LedgerCfg (LedgerState (DualBlock m a))
DualLedgerConfig m a
cfg)
                       m
dualBlockMain
                       Ticked (LedgerState m) ValuesMK
tickedDualLedgerStateMain

  getBlockKeySets :: DualBlock m a -> LedgerTables (LedgerState (DualBlock m a)) KeysMK
getBlockKeySets = LedgerTables (LedgerState m) KeysMK
-> LedgerTables (LedgerState (DualBlock m a)) KeysMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: * -> * -> *).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables
                  (LedgerTables (LedgerState m) KeysMK
 -> LedgerTables (LedgerState (DualBlock m a)) KeysMK)
-> (DualBlock m a -> LedgerTables (LedgerState m) KeysMK)
-> DualBlock m a
-> LedgerTables (LedgerState (DualBlock m a)) KeysMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
blk -> LedgerTables l KeysMK
getBlockKeySets @(LedgerState m)
                  (m -> LedgerTables (LedgerState m) KeysMK)
-> (DualBlock m a -> m)
-> DualBlock m a
-> LedgerTables (LedgerState m) KeysMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DualBlock m a -> m
forall m a. DualBlock m a -> m
dualBlockMain

data instance LedgerState (DualBlock m a) mk = DualLedgerState {
      forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain   :: LedgerState m mk
    , forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState a ValuesMK
dualLedgerStateAux    :: LedgerState a ValuesMK
    , forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> BridgeLedger m a
dualLedgerStateBridge :: BridgeLedger m a
    }
  deriving Context -> LedgerState (DualBlock m a) mk -> IO (Maybe ThunkInfo)
Proxy (LedgerState (DualBlock m a) mk) -> String
(Context -> LedgerState (DualBlock m a) mk -> IO (Maybe ThunkInfo))
-> (Context
    -> LedgerState (DualBlock m a) mk -> IO (Maybe ThunkInfo))
-> (Proxy (LedgerState (DualBlock m a) mk) -> String)
-> NoThunks (LedgerState (DualBlock m a) mk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall m a (mk :: * -> * -> *).
Context -> LedgerState (DualBlock m a) mk -> IO (Maybe ThunkInfo)
forall m a (mk :: * -> * -> *).
Proxy (LedgerState (DualBlock m a) mk) -> String
$cnoThunks :: forall m a (mk :: * -> * -> *).
Context -> LedgerState (DualBlock m a) mk -> IO (Maybe ThunkInfo)
noThunks :: Context -> LedgerState (DualBlock m a) mk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall m a (mk :: * -> * -> *).
Context -> LedgerState (DualBlock m a) mk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LedgerState (DualBlock m a) mk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall m a (mk :: * -> * -> *).
Proxy (LedgerState (DualBlock m a) mk) -> String
showTypeOf :: Proxy (LedgerState (DualBlock m a) mk) -> String
NoThunks via AllowThunk (LedgerState (DualBlock m a) mk)

instance Bridge m a => UpdateLedger (DualBlock m a)

deriving instance ( Bridge m a, ShowMK mk
                  ) => Show (LedgerState (DualBlock m a) mk)
deriving instance ( Bridge m a, EqMK mk
                  ) => Eq (LedgerState (DualBlock m a) mk)

{-------------------------------------------------------------------------------
  Utilities for working with the extended ledger state
-------------------------------------------------------------------------------}

dualExtValidationErrorMain :: ExtValidationError (DualBlock m a)
                           -> ExtValidationError m
dualExtValidationErrorMain :: forall m a.
ExtValidationError (DualBlock m a) -> ExtValidationError m
dualExtValidationErrorMain = \case
    ExtValidationErrorLedger LedgerError (DualBlock m a)
e -> LedgerError m -> ExtValidationError m
forall blk. LedgerError blk -> ExtValidationError blk
ExtValidationErrorLedger (DualLedgerError m a -> LedgerError m
forall m a. DualLedgerError m a -> LedgerError m
dualLedgerErrorMain LedgerError (DualBlock m a)
DualLedgerError m a
e)
    ExtValidationErrorHeader HeaderError (DualBlock m a)
e -> HeaderError m -> ExtValidationError m
forall blk. HeaderError blk -> ExtValidationError blk
ExtValidationErrorHeader (HeaderError (DualBlock m a) -> HeaderError m
forall blk blk'.
(ValidationErr (BlockProtocol blk)
 ~ ValidationErr (BlockProtocol blk'),
 HeaderHash blk ~ HeaderHash blk',
 OtherHeaderEnvelopeError blk ~ OtherHeaderEnvelopeError blk') =>
HeaderError blk -> HeaderError blk'
castHeaderError     HeaderError (DualBlock m a)
e)

{-------------------------------------------------------------------------------
  LedgerSupportsProtocol

  These definitions are asymmetric because the auxiliary block is not involved
  in the consensus protocol, and has no 'LedgerSupportsProtocol' instance.
-------------------------------------------------------------------------------}

instance Bridge m a => HasAnnTip (DualBlock m a) where
  type TipInfo (DualBlock m a) = TipInfo m
  tipInfoHash :: forall (proxy :: * -> *).
proxy (DualBlock m a)
-> TipInfo (DualBlock m a) -> HeaderHash (DualBlock m a)
tipInfoHash proxy (DualBlock m a)
_ = Proxy m -> TipInfo m -> HeaderHash m
forall blk (proxy :: * -> *).
HasAnnTip blk =>
proxy blk -> TipInfo blk -> HeaderHash blk
forall (proxy :: * -> *). proxy m -> TipInfo m -> HeaderHash m
tipInfoHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @m)
  getTipInfo :: Header (DualBlock m a) -> TipInfo (DualBlock m a)
getTipInfo    = Header m -> TipInfo m
forall blk. HasAnnTip blk => Header blk -> TipInfo blk
getTipInfo (Header m -> TipInfo m)
-> (Header (DualBlock m a) -> Header m)
-> Header (DualBlock m a)
-> TipInfo m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (DualBlock m a) -> Header m
forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain

instance Bridge m a => BasicEnvelopeValidation (DualBlock m a) where
  expectedFirstBlockNo :: forall (proxy :: * -> *). proxy (DualBlock m a) -> BlockNo
expectedFirstBlockNo  proxy (DualBlock m a)
_ = Proxy m -> BlockNo
forall blk (proxy :: * -> *).
BasicEnvelopeValidation blk =>
proxy blk -> BlockNo
forall (proxy :: * -> *). proxy m -> BlockNo
expectedFirstBlockNo  (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @m)
  expectedNextBlockNo :: forall (proxy :: * -> *).
proxy (DualBlock m a)
-> TipInfo (DualBlock m a)
-> TipInfo (DualBlock m a)
-> BlockNo
-> BlockNo
expectedNextBlockNo   proxy (DualBlock m a)
_ = Proxy m -> TipInfo m -> TipInfo m -> BlockNo -> BlockNo
forall blk (proxy :: * -> *).
BasicEnvelopeValidation blk =>
proxy blk -> TipInfo blk -> TipInfo blk -> BlockNo -> BlockNo
forall (proxy :: * -> *).
proxy m -> TipInfo m -> TipInfo m -> BlockNo -> BlockNo
expectedNextBlockNo   (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @m)
  minimumPossibleSlotNo :: Proxy (DualBlock m a) -> SlotNo
minimumPossibleSlotNo Proxy (DualBlock m a)
_ = Proxy m -> SlotNo
forall blk. BasicEnvelopeValidation blk => Proxy blk -> SlotNo
minimumPossibleSlotNo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @m)
  minimumNextSlotNo :: forall (proxy :: * -> *).
proxy (DualBlock m a)
-> TipInfo (DualBlock m a)
-> TipInfo (DualBlock m a)
-> SlotNo
-> SlotNo
minimumNextSlotNo     proxy (DualBlock m a)
_ = Proxy m -> TipInfo m -> TipInfo m -> SlotNo -> SlotNo
forall blk (proxy :: * -> *).
BasicEnvelopeValidation blk =>
proxy blk -> TipInfo blk -> TipInfo blk -> SlotNo -> SlotNo
forall (proxy :: * -> *).
proxy m -> TipInfo m -> TipInfo m -> SlotNo -> SlotNo
minimumNextSlotNo     (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @m)

instance Bridge m a => ValidateEnvelope (DualBlock m a) where
  type OtherHeaderEnvelopeError (DualBlock m a) = OtherHeaderEnvelopeError m

  additionalEnvelopeChecks :: TopLevelConfig (DualBlock m a)
-> LedgerView (BlockProtocol (DualBlock m a))
-> Header (DualBlock m a)
-> Except (OtherHeaderEnvelopeError (DualBlock m a)) ()
additionalEnvelopeChecks TopLevelConfig (DualBlock m a)
cfg LedgerView (BlockProtocol (DualBlock m a))
ledgerView Header (DualBlock m a)
hdr =
      TopLevelConfig m
-> LedgerView (BlockProtocol m)
-> Header m
-> Except (OtherHeaderEnvelopeError m) ()
forall blk.
ValidateEnvelope blk =>
TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Except (OtherHeaderEnvelopeError blk) ()
additionalEnvelopeChecks
        (TopLevelConfig (DualBlock m a) -> TopLevelConfig m
forall m a. TopLevelConfig (DualBlock m a) -> TopLevelConfig m
dualTopLevelConfigMain TopLevelConfig (DualBlock m a)
cfg)
        LedgerView (BlockProtocol m)
LedgerView (BlockProtocol (DualBlock m a))
ledgerView
        (Header (DualBlock m a) -> Header m
forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain Header (DualBlock m a)
hdr)

instance Bridge m a => LedgerSupportsProtocol (DualBlock m a) where
  protocolLedgerView :: forall (mk :: * -> * -> *).
LedgerConfig (DualBlock m a)
-> Ticked (LedgerState (DualBlock m a)) mk
-> LedgerView (BlockProtocol (DualBlock m a))
protocolLedgerView LedgerConfig (DualBlock m a)
cfg Ticked (LedgerState (DualBlock m a)) mk
state =
      LedgerConfig m
-> Ticked (LedgerState m) mk -> LedgerView (BlockProtocol m)
forall blk (mk :: * -> * -> *).
LedgerSupportsProtocol blk =>
LedgerConfig blk
-> Ticked (LedgerState blk) mk -> LedgerView (BlockProtocol blk)
forall (mk :: * -> * -> *).
LedgerConfig m
-> Ticked (LedgerState m) mk -> LedgerView (BlockProtocol m)
protocolLedgerView
        (DualLedgerConfig m a -> LedgerConfig m
forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigMain      LedgerConfig (DualBlock m a)
DualLedgerConfig m a
cfg)
        (Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateMain Ticked (LedgerState (DualBlock m a)) mk
state)

  ledgerViewForecastAt :: forall (mk :: * -> * -> *).
HasCallStack =>
LedgerConfig (DualBlock m a)
-> LedgerState (DualBlock m a) mk
-> Forecast (LedgerView (BlockProtocol (DualBlock m a)))
ledgerViewForecastAt LedgerConfig (DualBlock m a)
cfg LedgerState (DualBlock m a) mk
state =
      LedgerConfig m
-> LedgerState m mk -> Forecast (LedgerView (BlockProtocol m))
forall blk (mk :: * -> * -> *).
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
forall (mk :: * -> * -> *).
HasCallStack =>
LedgerConfig m
-> LedgerState m mk -> Forecast (LedgerView (BlockProtocol m))
ledgerViewForecastAt
        (DualLedgerConfig m a -> LedgerConfig m
forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigMain LedgerConfig (DualBlock m a)
DualLedgerConfig m a
cfg)
        (LedgerState (DualBlock m a) mk -> LedgerState m mk
forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain  LedgerState (DualBlock m a) mk
state)

instance Bridge m a => HasHardForkHistory (DualBlock m a) where
  type HardForkIndices (DualBlock m a) = HardForkIndices m

  hardForkSummary :: forall (mk :: * -> * -> *).
LedgerConfig (DualBlock m a)
-> LedgerState (DualBlock m a) mk
-> Summary (HardForkIndices (DualBlock m a))
hardForkSummary LedgerConfig (DualBlock m a)
cfg LedgerState (DualBlock m a) mk
state =
      LedgerConfig m -> LedgerState m mk -> Summary (HardForkIndices m)
forall blk (mk :: * -> * -> *).
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall (mk :: * -> * -> *).
LedgerConfig m -> LedgerState m mk -> Summary (HardForkIndices m)
hardForkSummary
        (DualLedgerConfig m a -> LedgerConfig m
forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigMain LedgerConfig (DualBlock m a)
DualLedgerConfig m a
cfg)
        (LedgerState (DualBlock m a) mk -> LedgerState m mk
forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain  LedgerState (DualBlock m a) mk
state)

{-------------------------------------------------------------------------------
  Querying the ledger
-------------------------------------------------------------------------------}

data instance BlockQuery (DualBlock m a) footprint result
  deriving (Int -> BlockQuery (DualBlock m a) footprint result -> ShowS
[BlockQuery (DualBlock m a) footprint result] -> ShowS
BlockQuery (DualBlock m a) footprint result -> String
(Int -> BlockQuery (DualBlock m a) footprint result -> ShowS)
-> (BlockQuery (DualBlock m a) footprint result -> String)
-> ([BlockQuery (DualBlock m a) footprint result] -> ShowS)
-> Show (BlockQuery (DualBlock m a) footprint result)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall m a (footprint :: QueryFootprint) result.
Int -> BlockQuery (DualBlock m a) footprint result -> ShowS
forall m a (footprint :: QueryFootprint) result.
[BlockQuery (DualBlock m a) footprint result] -> ShowS
forall m a (footprint :: QueryFootprint) result.
BlockQuery (DualBlock m a) footprint result -> String
$cshowsPrec :: forall m a (footprint :: QueryFootprint) result.
Int -> BlockQuery (DualBlock m a) footprint result -> ShowS
showsPrec :: Int -> BlockQuery (DualBlock m a) footprint result -> ShowS
$cshow :: forall m a (footprint :: QueryFootprint) result.
BlockQuery (DualBlock m a) footprint result -> String
show :: BlockQuery (DualBlock m a) footprint result -> String
$cshowList :: forall m a (footprint :: QueryFootprint) result.
[BlockQuery (DualBlock m a) footprint result] -> ShowS
showList :: [BlockQuery (DualBlock m a) footprint result] -> ShowS
Show)

instance (Typeable m, Typeable a)
    => ShowProxy (BlockQuery (DualBlock m a)) where

-- | Not used in the tests: no constructors
instance Bridge m a => BlockSupportsLedgerQuery (DualBlock m a) where
  answerPureBlockQuery :: forall result.
ExtLedgerCfg (DualBlock m a)
-> BlockQuery (DualBlock m a) 'QFNoTables result
-> ExtLedgerState (DualBlock m a) EmptyMK
-> result
answerPureBlockQuery ExtLedgerCfg (DualBlock m a)
_ = \case {}
  answerBlockQueryLookup :: forall (m :: * -> *) result.
MonadSTM m =>
ExtLedgerCfg (DualBlock m a)
-> BlockQuery (DualBlock m a) 'QFLookupTables result
-> ReadOnlyForker' m (DualBlock m a)
-> m result
answerBlockQueryLookup ExtLedgerCfg (DualBlock m a)
_ = \case {}
  answerBlockQueryTraverse :: forall (m :: * -> *) result.
MonadSTM m =>
ExtLedgerCfg (DualBlock m a)
-> BlockQuery (DualBlock m a) 'QFTraverseTables result
-> ReadOnlyForker' m (DualBlock m a)
-> m result
answerBlockQueryTraverse ExtLedgerCfg (DualBlock m a)
_ = \case {}
  blockQueryIsSupportedOnVersion :: forall (fp :: QueryFootprint) result.
BlockQuery (DualBlock m a) fp result
-> BlockNodeToClientVersion (DualBlock m a) -> Bool
blockQueryIsSupportedOnVersion BlockQuery (DualBlock m a) fp result
qry BlockNodeToClientVersion (DualBlock m a)
_ = case BlockQuery (DualBlock m a) fp result
qry of {}

instance SameDepIndex2 (BlockQuery (DualBlock m a)) where
  sameDepIndex2 :: forall (x :: QueryFootprint) a (y :: QueryFootprint) b.
BlockQuery (DualBlock m a) x a
-> BlockQuery (DualBlock m a) y b -> Maybe ('(x, a) :~: '(y, b))
sameDepIndex2 = \case {}

instance ShowQuery (BlockQuery (DualBlock m a) footprint) where
  showResult :: forall result.
BlockQuery (DualBlock m a) footprint result -> result -> String
showResult = \case {}

-- | Forward to the main ledger
instance Bridge m a => CommonProtocolParams (DualBlock m a) where
  maxHeaderSize :: forall (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> Word32
maxHeaderSize = LedgerState m mk -> Word32
forall blk (mk :: * -> * -> *).
CommonProtocolParams blk =>
LedgerState blk mk -> Word32
forall (mk :: * -> * -> *). LedgerState m mk -> Word32
maxHeaderSize (LedgerState m mk -> Word32)
-> (LedgerState (DualBlock m a) mk -> LedgerState m mk)
-> LedgerState (DualBlock m a) mk
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (DualBlock m a) mk -> LedgerState m mk
forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain
  maxTxSize :: forall (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> Word32
maxTxSize     = LedgerState m mk -> Word32
forall blk (mk :: * -> * -> *).
CommonProtocolParams blk =>
LedgerState blk mk -> Word32
forall (mk :: * -> * -> *). LedgerState m mk -> Word32
maxTxSize     (LedgerState m mk -> Word32)
-> (LedgerState (DualBlock m a) mk -> LedgerState m mk)
-> LedgerState (DualBlock m a) mk
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (DualBlock m a) mk -> LedgerState m mk
forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain

{-------------------------------------------------------------------------------
  Mempool support
-------------------------------------------------------------------------------}

data DualGenTxErr m a = DualGenTxErr {
      forall m a. DualGenTxErr m a -> ApplyTxErr m
dualGenTxErrMain :: ApplyTxErr m
    , forall m a. DualGenTxErr m a -> ApplyTxErr a
dualGenTxErrAux  :: ApplyTxErr a
    }

instance (Typeable m, Typeable a)
    => ShowProxy (DualGenTxErr m a) where

data instance GenTx (DualBlock m a) = DualGenTx {
      forall m a. GenTx (DualBlock m a) -> GenTx m
dualGenTxMain   :: GenTx m
    , forall m a. GenTx (DualBlock m a) -> GenTx a
dualGenTxAux    :: GenTx a
    , forall m a. GenTx (DualBlock m a) -> BridgeTx m a
dualGenTxBridge :: BridgeTx m a
    }
  deriving Context -> GenTx (DualBlock m a) -> IO (Maybe ThunkInfo)
Proxy (GenTx (DualBlock m a)) -> String
(Context -> GenTx (DualBlock m a) -> IO (Maybe ThunkInfo))
-> (Context -> GenTx (DualBlock m a) -> IO (Maybe ThunkInfo))
-> (Proxy (GenTx (DualBlock m a)) -> String)
-> NoThunks (GenTx (DualBlock m a))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall m a.
Context -> GenTx (DualBlock m a) -> IO (Maybe ThunkInfo)
forall m a. Proxy (GenTx (DualBlock m a)) -> String
$cnoThunks :: forall m a.
Context -> GenTx (DualBlock m a) -> IO (Maybe ThunkInfo)
noThunks :: Context -> GenTx (DualBlock m a) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall m a.
Context -> GenTx (DualBlock m a) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> GenTx (DualBlock m a) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall m a. Proxy (GenTx (DualBlock m a)) -> String
showTypeOf :: Proxy (GenTx (DualBlock m a)) -> String
NoThunks via AllowThunk (GenTx (DualBlock m a))

data instance Validated (GenTx (DualBlock m a)) = ValidatedDualGenTx {
      forall m a.
Validated (GenTx (DualBlock m a)) -> Validated (GenTx m)
vDualGenTxMain   :: Validated (GenTx m)
    , forall m a.
Validated (GenTx (DualBlock m a)) -> Validated (GenTx a)
vDualGenTxAux    :: Validated (GenTx a)
    , forall m a. Validated (GenTx (DualBlock m a)) -> BridgeTx m a
vDualGenTxBridge :: BridgeTx m a
    }
  deriving Context
-> Validated (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
Proxy (Validated (GenTx (DualBlock m a))) -> String
(Context
 -> Validated (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo))
-> (Context
    -> Validated (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo))
-> (Proxy (Validated (GenTx (DualBlock m a))) -> String)
-> NoThunks (Validated (GenTx (DualBlock m a)))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall m a.
Context
-> Validated (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
forall m a. Proxy (Validated (GenTx (DualBlock m a))) -> String
$cnoThunks :: forall m a.
Context
-> Validated (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> Validated (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall m a.
Context
-> Validated (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> Validated (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall m a. Proxy (Validated (GenTx (DualBlock m a))) -> String
showTypeOf :: Proxy (Validated (GenTx (DualBlock m a))) -> String
NoThunks via AllowThunk (Validated (GenTx (DualBlock m a)))

instance (Typeable m, Typeable a)
    => ShowProxy (GenTx (DualBlock m a)) where

type instance ApplyTxErr (DualBlock m a) = DualGenTxErr m a

instance Bridge m a => LedgerSupportsMempool (DualBlock m a) where
  applyTx :: LedgerConfig (DualBlock m a)
-> WhetherToIntervene
-> SlotNo
-> GenTx (DualBlock m a)
-> TickedLedgerState (DualBlock m a) ValuesMK
-> Except
     (ApplyTxErr (DualBlock m a))
     (TickedLedgerState (DualBlock m a) DiffMK,
      Validated (GenTx (DualBlock m a)))
applyTx DualLedgerConfig{LedgerConfig m
LedgerConfig a
dualLedgerConfigMain :: forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigAux :: forall m a. DualLedgerConfig m a -> LedgerConfig a
dualLedgerConfigMain :: LedgerConfig m
dualLedgerConfigAux :: LedgerConfig a
..}
          WhetherToIntervene
wti
          SlotNo
slot
          DualGenTx{GenTx m
GenTx a
BridgeTx m a
dualGenTxMain :: forall m a. GenTx (DualBlock m a) -> GenTx m
dualGenTxAux :: forall m a. GenTx (DualBlock m a) -> GenTx a
dualGenTxBridge :: forall m a. GenTx (DualBlock m a) -> BridgeTx m a
dualGenTxMain :: GenTx m
dualGenTxAux :: GenTx a
dualGenTxBridge :: BridgeTx m a
..}
          TickedDualLedgerState{Ticked (LedgerState m) ValuesMK
Ticked (LedgerState a) ValuesMK
LedgerState a ValuesMK
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateAux :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> LedgerState a ValuesMK
tickedDualLedgerStateMain :: Ticked (LedgerState m) ValuesMK
tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
..} = do
      ((main', mainVtx), (aux', auxVtx)) <-
        (ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a)
-> (Except
      (ApplyTxErr m) (TickedLedgerState m DiffMK, Validated (GenTx m)),
    Except
      (ApplyTxErr a) (TickedLedgerState a DiffMK, Validated (GenTx a)))
-> Except
     (DualGenTxErr m a)
     ((TickedLedgerState m DiffMK, Validated (GenTx m)),
      (TickedLedgerState a DiffMK, Validated (GenTx a)))
forall e e' err a b.
(Show e, Show e', HasCallStack) =>
(e -> e' -> err) -> (Except e a, Except e' b) -> Except err (a, b)
agreeOnError ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a
forall m a. ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a
DualGenTxErr (
            LedgerConfig m
-> WhetherToIntervene
-> SlotNo
-> GenTx m
-> Ticked (LedgerState m) ValuesMK
-> Except
     (ApplyTxErr m) (TickedLedgerState m DiffMK, Validated (GenTx m))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk ValuesMK
-> Except
     (ApplyTxErr blk)
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
applyTx
              LedgerConfig m
dualLedgerConfigMain
              WhetherToIntervene
wti
              SlotNo
slot
              GenTx m
dualGenTxMain
              Ticked (LedgerState m) ValuesMK
tickedDualLedgerStateMain
          , LedgerConfig a
-> WhetherToIntervene
-> SlotNo
-> GenTx a
-> Ticked (LedgerState a) ValuesMK
-> Except
     (ApplyTxErr a) (TickedLedgerState a DiffMK, Validated (GenTx a))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk ValuesMK
-> Except
     (ApplyTxErr blk)
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
applyTx
              LedgerConfig a
dualLedgerConfigAux
              WhetherToIntervene
wti
              SlotNo
slot
              GenTx a
dualGenTxAux
              Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux
          )
      let vtx = ValidatedDualGenTx {
                vDualGenTxMain :: Validated (GenTx m)
vDualGenTxMain   = Validated (GenTx m)
mainVtx
              , vDualGenTxAux :: Validated (GenTx a)
vDualGenTxAux    = Validated (GenTx a)
auxVtx
              , vDualGenTxBridge :: BridgeTx m a
vDualGenTxBridge = BridgeTx m a
dualGenTxBridge
              }
      return (TickedDualLedgerState {
          tickedDualLedgerStateMain    = main'
        , tickedDualLedgerStateAux     = applyDiffs tickedDualLedgerStateAux aux'
        , tickedDualLedgerStateAuxOrig = tickedDualLedgerStateAuxOrig
        , tickedDualLedgerStateBridge  = updateBridgeWithTx
                                           vtx
                                           tickedDualLedgerStateBridge
        }, vtx)


  reapplyTx :: HasCallStack =>
ComputeDiffs
-> LedgerConfig (DualBlock m a)
-> SlotNo
-> Validated (GenTx (DualBlock m a))
-> TickedLedgerState (DualBlock m a) ValuesMK
-> Except
     (ApplyTxErr (DualBlock m a))
     (TickedLedgerState (DualBlock m a) TrackingMK)
reapplyTx ComputeDiffs
doDiffs DualLedgerConfig{LedgerConfig m
LedgerConfig a
dualLedgerConfigMain :: forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigAux :: forall m a. DualLedgerConfig m a -> LedgerConfig a
dualLedgerConfigMain :: LedgerConfig m
dualLedgerConfigAux :: LedgerConfig a
..}
            SlotNo
slot
            tx :: Validated (GenTx (DualBlock m a))
tx@ValidatedDualGenTx{Validated (GenTx m)
Validated (GenTx a)
BridgeTx m a
vDualGenTxMain :: forall m a.
Validated (GenTx (DualBlock m a)) -> Validated (GenTx m)
vDualGenTxAux :: forall m a.
Validated (GenTx (DualBlock m a)) -> Validated (GenTx a)
vDualGenTxBridge :: forall m a. Validated (GenTx (DualBlock m a)) -> BridgeTx m a
vDualGenTxMain :: Validated (GenTx m)
vDualGenTxAux :: Validated (GenTx a)
vDualGenTxBridge :: BridgeTx m a
..}
            TickedDualLedgerState{Ticked (LedgerState m) ValuesMK
Ticked (LedgerState a) ValuesMK
LedgerState a ValuesMK
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateAux :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> LedgerState a ValuesMK
tickedDualLedgerStateMain :: Ticked (LedgerState m) ValuesMK
tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
..} = do
      (main', aux') <-
        (ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a)
-> (Except (ApplyTxErr m) (TickedLedgerState m TrackingMK),
    Except (ApplyTxErr a) (TickedLedgerState a TrackingMK))
-> Except
     (DualGenTxErr m a)
     (TickedLedgerState m TrackingMK, TickedLedgerState a TrackingMK)
forall e e' err a b.
(Show e, Show e', HasCallStack) =>
(e -> e' -> err) -> (Except e a, Except e' b) -> Except err (a, b)
agreeOnError ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a
forall m a. ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a
DualGenTxErr (
            ComputeDiffs
-> LedgerConfig m
-> SlotNo
-> Validated (GenTx m)
-> Ticked (LedgerState m) ValuesMK
-> Except (ApplyTxErr m) (TickedLedgerState m TrackingMK)
forall blk.
(LedgerSupportsMempool blk, HasCallStack) =>
ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> Validated (GenTx blk)
-> TickedLedgerState blk ValuesMK
-> Except (ApplyTxErr blk) (TickedLedgerState blk TrackingMK)
reapplyTx
              ComputeDiffs
doDiffs
              LedgerConfig m
dualLedgerConfigMain
              SlotNo
slot
              Validated (GenTx m)
vDualGenTxMain
              Ticked (LedgerState m) ValuesMK
tickedDualLedgerStateMain
          , ComputeDiffs
-> LedgerConfig a
-> SlotNo
-> Validated (GenTx a)
-> Ticked (LedgerState a) ValuesMK
-> Except (ApplyTxErr a) (TickedLedgerState a TrackingMK)
forall blk.
(LedgerSupportsMempool blk, HasCallStack) =>
ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> Validated (GenTx blk)
-> TickedLedgerState blk ValuesMK
-> Except (ApplyTxErr blk) (TickedLedgerState blk TrackingMK)
reapplyTx
              ComputeDiffs
doDiffs
              LedgerConfig a
dualLedgerConfigAux
              SlotNo
slot
              Validated (GenTx a)
vDualGenTxAux
              Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux
          )
      return $ TickedDualLedgerState {
          tickedDualLedgerStateMain    = main'
        , tickedDualLedgerStateAux     = trackingToValues aux'
        , tickedDualLedgerStateAuxOrig = tickedDualLedgerStateAuxOrig
        , tickedDualLedgerStateBridge  = updateBridgeWithTx
                                           tx
                                           tickedDualLedgerStateBridge
        }

  txForgetValidated :: Validated (GenTx (DualBlock m a)) -> GenTx (DualBlock m a)
txForgetValidated Validated (GenTx (DualBlock m a))
vtx =
      DualGenTx {
          dualGenTxMain :: GenTx m
dualGenTxMain   = Validated (GenTx m) -> GenTx m
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx m)
vDualGenTxMain
        , dualGenTxAux :: GenTx a
dualGenTxAux    = Validated (GenTx a) -> GenTx a
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx a)
vDualGenTxAux
        , dualGenTxBridge :: BridgeTx m a
dualGenTxBridge = BridgeTx m a
vDualGenTxBridge
        }
    where
      ValidatedDualGenTx {
            Validated (GenTx m)
vDualGenTxMain :: forall m a.
Validated (GenTx (DualBlock m a)) -> Validated (GenTx m)
vDualGenTxMain :: Validated (GenTx m)
vDualGenTxMain
          , Validated (GenTx a)
vDualGenTxAux :: forall m a.
Validated (GenTx (DualBlock m a)) -> Validated (GenTx a)
vDualGenTxAux :: Validated (GenTx a)
vDualGenTxAux
          , BridgeTx m a
vDualGenTxBridge :: forall m a. Validated (GenTx (DualBlock m a)) -> BridgeTx m a
vDualGenTxBridge :: BridgeTx m a
vDualGenTxBridge
          } = Validated (GenTx (DualBlock m a))
vtx

  getTransactionKeySets :: GenTx (DualBlock m a)
-> LedgerTables (LedgerState (DualBlock m a)) KeysMK
getTransactionKeySets = LedgerTables (LedgerState m) KeysMK
-> LedgerTables (LedgerState (DualBlock m a)) KeysMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: * -> * -> *).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables
                        (LedgerTables (LedgerState m) KeysMK
 -> LedgerTables (LedgerState (DualBlock m a)) KeysMK)
-> (GenTx (DualBlock m a) -> LedgerTables (LedgerState m) KeysMK)
-> GenTx (DualBlock m a)
-> LedgerTables (LedgerState (DualBlock m a)) KeysMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall blk.
LedgerSupportsMempool blk =>
GenTx blk -> LedgerTables (LedgerState blk) KeysMK
getTransactionKeySets @m
                        (GenTx m -> LedgerTables (LedgerState m) KeysMK)
-> (GenTx (DualBlock m a) -> GenTx m)
-> GenTx (DualBlock m a)
-> LedgerTables (LedgerState m) KeysMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (DualBlock m a) -> GenTx m
forall m a. GenTx (DualBlock m a) -> GenTx m
dualGenTxMain

instance Bridge m a => TxLimits (DualBlock m a) where
  type TxMeasure (DualBlock m a) = TxMeasure m

  txMeasure :: LedgerConfig (DualBlock m a)
-> TickedLedgerState (DualBlock m a) ValuesMK
-> GenTx (DualBlock m a)
-> Except (ApplyTxErr (DualBlock m a)) (TxMeasure (DualBlock m a))
txMeasure DualLedgerConfig{LedgerConfig m
LedgerConfig a
dualLedgerConfigMain :: forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigAux :: forall m a. DualLedgerConfig m a -> LedgerConfig a
dualLedgerConfigMain :: LedgerConfig m
dualLedgerConfigAux :: LedgerConfig a
..} TickedDualLedgerState{Ticked (LedgerState m) ValuesMK
Ticked (LedgerState a) ValuesMK
LedgerState a ValuesMK
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateAux :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> LedgerState a ValuesMK
tickedDualLedgerStateMain :: Ticked (LedgerState m) ValuesMK
tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
..} DualGenTx{GenTx m
GenTx a
BridgeTx m a
dualGenTxMain :: forall m a. GenTx (DualBlock m a) -> GenTx m
dualGenTxAux :: forall m a. GenTx (DualBlock m a) -> GenTx a
dualGenTxBridge :: forall m a. GenTx (DualBlock m a) -> BridgeTx m a
dualGenTxMain :: GenTx m
dualGenTxAux :: GenTx a
dualGenTxBridge :: BridgeTx m a
..} = do
      (Either (ApplyTxErr m) (TxMeasure m)
 -> Either (DualGenTxErr m a) (TxMeasure m))
-> Except (ApplyTxErr m) (TxMeasure m)
-> Except (DualGenTxErr m a) (TxMeasure m)
forall e a e' b.
(Either e a -> Either e' b) -> Except e a -> Except e' b
mapExcept (ApplyTxErr m -> DualGenTxErr m a
forall {m} {a}. ApplyTxErr m -> DualGenTxErr m a
inj (ApplyTxErr m -> DualGenTxErr m a)
-> (TxMeasure m -> TxMeasure m)
-> Either (ApplyTxErr m) (TxMeasure m)
-> Either (DualGenTxErr m a) (TxMeasure m)
forall b c b' c'.
(b -> c) -> (b' -> c') -> Either b b' -> Either c c'
forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
+++ TxMeasure m -> TxMeasure m
forall a. a -> a
id)
    (Except (ApplyTxErr m) (TxMeasure m)
 -> Except (ApplyTxErr (DualBlock m a)) (TxMeasure (DualBlock m a)))
-> Except (ApplyTxErr m) (TxMeasure m)
-> Except (ApplyTxErr (DualBlock m a)) (TxMeasure (DualBlock m a))
forall a b. (a -> b) -> a -> b
$ LedgerConfig m
-> Ticked (LedgerState m) ValuesMK
-> GenTx m
-> Except (ApplyTxErr m) (TxMeasure m)
forall blk.
TxLimits blk =>
LedgerConfig blk
-> TickedLedgerState blk ValuesMK
-> GenTx blk
-> Except (ApplyTxErr blk) (TxMeasure blk)
txMeasure LedgerConfig m
dualLedgerConfigMain Ticked (LedgerState m) ValuesMK
tickedDualLedgerStateMain GenTx m
dualGenTxMain
    where
      inj :: ApplyTxErr m -> DualGenTxErr m a
inj ApplyTxErr m
m = ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a
forall m a. ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a
DualGenTxErr ApplyTxErr m
m (String -> ApplyTxErr a
forall a. HasCallStack => String -> a
error String
"ByronSpec has no tx-too-big error")

  blockCapacityTxMeasure :: forall (mk :: * -> * -> *).
LedgerConfig (DualBlock m a)
-> TickedLedgerState (DualBlock m a) mk
-> TxMeasure (DualBlock m a)
blockCapacityTxMeasure DualLedgerConfig{LedgerConfig m
LedgerConfig a
dualLedgerConfigMain :: forall m a. DualLedgerConfig m a -> LedgerConfig m
dualLedgerConfigAux :: forall m a. DualLedgerConfig m a -> LedgerConfig a
dualLedgerConfigMain :: LedgerConfig m
dualLedgerConfigAux :: LedgerConfig a
..} TickedDualLedgerState{Ticked (LedgerState m) mk
Ticked (LedgerState a) ValuesMK
LedgerState a ValuesMK
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateAux :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> LedgerState a ValuesMK
tickedDualLedgerStateMain :: Ticked (LedgerState m) mk
tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
..} =
      LedgerConfig m -> Ticked (LedgerState m) mk -> TxMeasure m
forall blk (mk :: * -> * -> *).
TxLimits blk =>
LedgerConfig blk -> TickedLedgerState blk mk -> TxMeasure blk
forall (mk :: * -> * -> *).
LedgerConfig m -> TickedLedgerState m mk -> TxMeasure m
blockCapacityTxMeasure LedgerConfig m
dualLedgerConfigMain Ticked (LedgerState m) mk
tickedDualLedgerStateMain

-- We don't need a pair of IDs, as long as we can unique ID the transaction
newtype instance TxId (GenTx (DualBlock m a)) = DualGenTxId {
      forall m a. TxId (GenTx (DualBlock m a)) -> GenTxId m
dualGenTxIdMain :: GenTxId m
    }
  deriving Context -> TxId (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
Proxy (TxId (GenTx (DualBlock m a))) -> String
(Context -> TxId (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo))
-> (Context
    -> TxId (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo))
-> (Proxy (TxId (GenTx (DualBlock m a))) -> String)
-> NoThunks (TxId (GenTx (DualBlock m a)))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall m a.
Context -> TxId (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
forall m a. Proxy (TxId (GenTx (DualBlock m a))) -> String
$cnoThunks :: forall m a.
Context -> TxId (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
noThunks :: Context -> TxId (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall m a.
Context -> TxId (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TxId (GenTx (DualBlock m a)) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall m a. Proxy (TxId (GenTx (DualBlock m a))) -> String
showTypeOf :: Proxy (TxId (GenTx (DualBlock m a))) -> String
NoThunks via AllowThunk (TxId (GenTx (DualBlock m a)))

instance (Typeable m, Typeable a)
    => ShowProxy (TxId (GenTx (DualBlock m a))) where

instance Bridge m a => HasTxId (GenTx (DualBlock m a)) where
  txId :: GenTx (DualBlock m a) -> TxId (GenTx (DualBlock m a))
txId = TxId (GenTx m) -> TxId (GenTx (DualBlock m a))
forall m a. GenTxId m -> TxId (GenTx (DualBlock m a))
DualGenTxId (TxId (GenTx m) -> TxId (GenTx (DualBlock m a)))
-> (GenTx (DualBlock m a) -> TxId (GenTx m))
-> GenTx (DualBlock m a)
-> TxId (GenTx (DualBlock m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx m -> TxId (GenTx m)
forall tx. HasTxId tx => tx -> TxId tx
txId (GenTx m -> TxId (GenTx m))
-> (GenTx (DualBlock m a) -> GenTx m)
-> GenTx (DualBlock m a)
-> TxId (GenTx m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (DualBlock m a) -> GenTx m
forall m a. GenTx (DualBlock m a) -> GenTx m
dualGenTxMain

deriving instance Bridge m a => Show (GenTx (DualBlock m a))
deriving instance Bridge m a => Show (Validated (GenTx (DualBlock m a)))
deriving instance Bridge m a => Show (DualGenTxErr m a)

deriving instance Show (GenTxId m) => Show (TxId (GenTx (DualBlock m a)))
deriving instance Eq   (GenTxId m) => Eq   (TxId (GenTx (DualBlock m a)))
deriving instance Ord  (GenTxId m) => Ord  (TxId (GenTx (DualBlock m a)))

{-------------------------------------------------------------------------------
  Nested contents

  Since we only have a single header, we just delegate to the main block.
-------------------------------------------------------------------------------}

newtype instance NestedCtxt_ (DualBlock m a) f x where
    CtxtDual :: NestedCtxt_ m f x -> NestedCtxt_ (DualBlock m a) f x

deriving instance Show (NestedCtxt_ m f x)
               => Show (NestedCtxt_ (DualBlock m a) f x)

instance SameDepIndex (NestedCtxt_ m f)
      => SameDepIndex (NestedCtxt_ (DualBlock m a) f) where
  sameDepIndex :: forall a b.
NestedCtxt_ (DualBlock m a) f a
-> NestedCtxt_ (DualBlock m a) f b -> Maybe (a :~: b)
sameDepIndex (CtxtDual NestedCtxt_ m f a
ctxt) (CtxtDual NestedCtxt_ m f b
ctxt') =
     NestedCtxt_ m f a -> NestedCtxt_ m f b -> Maybe (a :~: b)
forall a b.
NestedCtxt_ m f a -> NestedCtxt_ m f b -> Maybe (a :~: b)
forall k (f :: k -> *) (a :: k) (b :: k).
SameDepIndex f =>
f a -> f b -> Maybe (a :~: b)
sameDepIndex NestedCtxt_ m f a
ctxt NestedCtxt_ m f b
ctxt'

ctxtDualMain :: NestedCtxt_ (DualBlock m a) f x -> NestedCtxt_ m f x
ctxtDualMain :: forall m a (f :: * -> *) x.
NestedCtxt_ (DualBlock m a) f x -> NestedCtxt_ m f x
ctxtDualMain (CtxtDual NestedCtxt_ m f x
ctxtMain) = NestedCtxt_ m f x
ctxtMain

instance HasNestedContent Header m
      => HasNestedContent Header (DualBlock m a) where
  unnest :: Header (DualBlock m a)
-> DepPair (NestedCtxt Header (DualBlock m a))
unnest = (forall a.
 NestedCtxt Header m a -> NestedCtxt Header (DualBlock m a) a)
-> GenDepPair I (NestedCtxt Header m)
-> DepPair (NestedCtxt Header (DualBlock m a))
forall {k} (f :: k -> *) (f' :: k -> *) (g :: k -> *).
(forall (a :: k). f a -> f' a) -> GenDepPair g f -> GenDepPair g f'
depPairFirst ((NestedCtxt_ m Header a -> NestedCtxt_ (DualBlock m a) Header a)
-> NestedCtxt Header m a -> NestedCtxt Header (DualBlock m a) a
forall blk (f :: * -> *) a blk' (f' :: * -> *) a'.
(NestedCtxt_ blk f a -> NestedCtxt_ blk' f' a')
-> NestedCtxt f blk a -> NestedCtxt f' blk' a'
mapNestedCtxt NestedCtxt_ m Header a -> NestedCtxt_ (DualBlock m a) Header a
forall m (f :: * -> *) x a.
NestedCtxt_ m f x -> NestedCtxt_ (DualBlock m a) f x
CtxtDual) (GenDepPair I (NestedCtxt Header m)
 -> DepPair (NestedCtxt Header (DualBlock m a)))
-> (Header (DualBlock m a) -> GenDepPair I (NestedCtxt Header m))
-> Header (DualBlock m a)
-> DepPair (NestedCtxt Header (DualBlock m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header m -> GenDepPair I (NestedCtxt Header m)
forall (f :: * -> *) blk.
HasNestedContent f blk =>
f blk -> DepPair (NestedCtxt f blk)
unnest (Header m -> GenDepPair I (NestedCtxt Header m))
-> (Header (DualBlock m a) -> Header m)
-> Header (DualBlock m a)
-> GenDepPair I (NestedCtxt Header m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (DualBlock m a) -> Header m
forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain
  nest :: DepPair (NestedCtxt Header (DualBlock m a))
-> Header (DualBlock m a)
nest   = Header m -> Header (DualBlock m a)
forall m a. Header m -> Header (DualBlock m a)
DualHeader (Header m -> Header (DualBlock m a))
-> (DepPair (NestedCtxt Header (DualBlock m a)) -> Header m)
-> DepPair (NestedCtxt Header (DualBlock m a))
-> Header (DualBlock m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenDepPair I (NestedCtxt Header m) -> Header m
forall (f :: * -> *) blk.
HasNestedContent f blk =>
DepPair (NestedCtxt f blk) -> f blk
nest (GenDepPair I (NestedCtxt Header m) -> Header m)
-> (DepPair (NestedCtxt Header (DualBlock m a))
    -> GenDepPair I (NestedCtxt Header m))
-> DepPair (NestedCtxt Header (DualBlock m a))
-> Header m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 NestedCtxt Header (DualBlock m a) a -> NestedCtxt Header m a)
-> DepPair (NestedCtxt Header (DualBlock m a))
-> GenDepPair I (NestedCtxt Header m)
forall {k} (f :: k -> *) (f' :: k -> *) (g :: k -> *).
(forall (a :: k). f a -> f' a) -> GenDepPair g f -> GenDepPair g f'
depPairFirst ((NestedCtxt_ (DualBlock m a) Header a -> NestedCtxt_ m Header a)
-> NestedCtxt Header (DualBlock m a) a -> NestedCtxt Header m a
forall blk (f :: * -> *) a blk' (f' :: * -> *) a'.
(NestedCtxt_ blk f a -> NestedCtxt_ blk' f' a')
-> NestedCtxt f blk a -> NestedCtxt f' blk' a'
mapNestedCtxt NestedCtxt_ (DualBlock m a) Header a -> NestedCtxt_ m Header a
forall m a (f :: * -> *) x.
NestedCtxt_ (DualBlock m a) f x -> NestedCtxt_ m f x
ctxtDualMain)

instance ReconstructNestedCtxt Header m
      => ReconstructNestedCtxt Header (DualBlock m a) where
  reconstructPrefixLen :: forall (proxy :: * -> *).
proxy (Header (DualBlock m a)) -> PrefixLen
reconstructPrefixLen proxy (Header (DualBlock m a))
_ =
      -- Account for the outer @encodeListLen 3@
      Word8
1 Word8 -> PrefixLen -> PrefixLen
`addPrefixLen` Proxy (Header m) -> PrefixLen
forall (proxy :: * -> *). proxy (Header m) -> PrefixLen
forall (f :: * -> *) blk (proxy :: * -> *).
ReconstructNestedCtxt f blk =>
proxy (f blk) -> PrefixLen
reconstructPrefixLen (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Header m))
  reconstructNestedCtxt :: forall (proxy :: * -> *).
proxy (Header (DualBlock m a))
-> ShortByteString
-> SizeInBytes
-> SomeSecond (NestedCtxt Header) (DualBlock m a)
reconstructNestedCtxt proxy (Header (DualBlock m a))
_ ShortByteString
prefix SizeInBytes
size =
      case Proxy (Header m)
-> ShortByteString
-> SizeInBytes
-> SomeSecond (NestedCtxt Header) m
forall (proxy :: * -> *).
proxy (Header m)
-> ShortByteString
-> SizeInBytes
-> SomeSecond (NestedCtxt Header) m
forall (f :: * -> *) blk (proxy :: * -> *).
ReconstructNestedCtxt f blk =>
proxy (f blk)
-> ShortByteString -> SizeInBytes -> SomeSecond (NestedCtxt f) blk
reconstructNestedCtxt (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Header m)) ShortByteString
prefixMain SizeInBytes
size of
        SomeSecond NestedCtxt Header m b
ctxt -> NestedCtxt Header (DualBlock m a) b
-> SomeSecond (NestedCtxt Header) (DualBlock m a)
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond ((NestedCtxt_ m Header b -> NestedCtxt_ (DualBlock m a) Header b)
-> NestedCtxt Header m b -> NestedCtxt Header (DualBlock m a) b
forall blk (f :: * -> *) a blk' (f' :: * -> *) a'.
(NestedCtxt_ blk f a -> NestedCtxt_ blk' f' a')
-> NestedCtxt f blk a -> NestedCtxt f' blk' a'
mapNestedCtxt NestedCtxt_ m Header b -> NestedCtxt_ (DualBlock m a) Header b
forall m (f :: * -> *) x a.
NestedCtxt_ m f x -> NestedCtxt_ (DualBlock m a) f x
CtxtDual NestedCtxt Header m b
ctxt)
    where
      prefixMain :: ShortByteString
prefixMain = [Word8] -> ShortByteString
Short.pack ([Word8] -> ShortByteString)
-> (ShortByteString -> [Word8])
-> ShortByteString
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
drop Int
1 ([Word8] -> [Word8])
-> (ShortByteString -> [Word8]) -> ShortByteString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> [Word8]
Short.unpack (ShortByteString -> ShortByteString)
-> ShortByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$ ShortByteString
prefix

instance EncodeDiskDepIx (NestedCtxt Header) m
      => EncodeDiskDepIx (NestedCtxt Header) (DualBlock m a) where
  encodeDiskDepIx :: CodecConfig (DualBlock m a)
-> SomeSecond (NestedCtxt Header) (DualBlock m a) -> Encoding
encodeDiskDepIx CodecConfig (DualBlock m a)
ccfg (SomeSecond NestedCtxt Header (DualBlock m a) b
ctxt) =
      CodecConfig m -> SomeSecond (NestedCtxt Header) m -> Encoding
forall (f :: * -> * -> *) blk.
EncodeDiskDepIx f blk =>
CodecConfig blk -> SomeSecond f blk -> Encoding
encodeDiskDepIx
        (CodecConfig (DualBlock m a) -> CodecConfig m
forall m a. CodecConfig (DualBlock m a) -> CodecConfig m
dualCodecConfigMain CodecConfig (DualBlock m a)
ccfg)
        (NestedCtxt Header m b -> SomeSecond (NestedCtxt Header) m
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond ((NestedCtxt_ (DualBlock m a) Header b -> NestedCtxt_ m Header b)
-> NestedCtxt Header (DualBlock m a) b -> NestedCtxt Header m b
forall blk (f :: * -> *) a blk' (f' :: * -> *) a'.
(NestedCtxt_ blk f a -> NestedCtxt_ blk' f' a')
-> NestedCtxt f blk a -> NestedCtxt f' blk' a'
mapNestedCtxt NestedCtxt_ (DualBlock m a) Header b -> NestedCtxt_ m Header b
forall m a (f :: * -> *) x.
NestedCtxt_ (DualBlock m a) f x -> NestedCtxt_ m f x
ctxtDualMain NestedCtxt Header (DualBlock m a) b
ctxt))

instance EncodeDiskDep (NestedCtxt Header) m
      => EncodeDiskDep (NestedCtxt Header) (DualBlock m a) where
  encodeDiskDep :: forall a.
CodecConfig (DualBlock m a)
-> NestedCtxt Header (DualBlock m a) a -> a -> Encoding
encodeDiskDep CodecConfig (DualBlock m a)
ccfg NestedCtxt Header (DualBlock m a) a
ctxt =
      CodecConfig m -> NestedCtxt Header m a -> a -> Encoding
forall a. CodecConfig m -> NestedCtxt Header m a -> a -> Encoding
forall (f :: * -> * -> *) blk a.
EncodeDiskDep f blk =>
CodecConfig blk -> f blk a -> a -> Encoding
encodeDiskDep
        (CodecConfig (DualBlock m a) -> CodecConfig m
forall m a. CodecConfig (DualBlock m a) -> CodecConfig m
dualCodecConfigMain CodecConfig (DualBlock m a)
ccfg)
        ((NestedCtxt_ (DualBlock m a) Header a -> NestedCtxt_ m Header a)
-> NestedCtxt Header (DualBlock m a) a -> NestedCtxt Header m a
forall blk (f :: * -> *) a blk' (f' :: * -> *) a'.
(NestedCtxt_ blk f a -> NestedCtxt_ blk' f' a')
-> NestedCtxt f blk a -> NestedCtxt f' blk' a'
mapNestedCtxt NestedCtxt_ (DualBlock m a) Header a -> NestedCtxt_ m Header a
forall m a (f :: * -> *) x.
NestedCtxt_ (DualBlock m a) f x -> NestedCtxt_ m f x
ctxtDualMain NestedCtxt Header (DualBlock m a) a
ctxt)

{-------------------------------------------------------------------------------
  HasBinaryBlockInfo
-------------------------------------------------------------------------------}

-- | The binary info just refers to the main block
--
-- This is sufficient, because we never need just the header of the auxiliary.
instance HasBinaryBlockInfo m => HasBinaryBlockInfo (DualBlock m a) where
  getBinaryBlockInfo :: DualBlock m a -> BinaryBlockInfo
getBinaryBlockInfo DualBlock{m
Maybe a
BridgeBlock m a
dualBlockMain :: forall m a. DualBlock m a -> m
dualBlockAux :: forall m a. DualBlock m a -> Maybe a
dualBlockBridge :: forall m a. DualBlock m a -> BridgeBlock m a
dualBlockMain :: m
dualBlockAux :: Maybe a
dualBlockBridge :: BridgeBlock m a
..} =
      BinaryBlockInfo {
          headerSize :: Word16
headerSize   = BinaryBlockInfo -> Word16
headerSize   BinaryBlockInfo
mainBinaryBlockInfo
        , headerOffset :: Word16
headerOffset = BinaryBlockInfo -> Word16
headerOffset BinaryBlockInfo
mainBinaryBlockInfo Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
1
        }
    where
      mainBinaryBlockInfo :: BinaryBlockInfo
      mainBinaryBlockInfo :: BinaryBlockInfo
mainBinaryBlockInfo = m -> BinaryBlockInfo
forall blk. HasBinaryBlockInfo blk => blk -> BinaryBlockInfo
getBinaryBlockInfo m
dualBlockMain

{-------------------------------------------------------------------------------
  Inspection
-------------------------------------------------------------------------------}

-- | 'InspectLedger' just refers to the main block
--
-- 'InspectLedger' is intended to check the ledger state against the node's
-- configuration, and hence takes a full 'TopLevelConfig'. However, we cannot
-- construct that for the auxiliary block, since we have no protocol config
-- for it. We therefore just use the main block.
instance InspectLedger m => InspectLedger (DualBlock m a) where
  type LedgerWarning (DualBlock m a) = LedgerWarning m
  type LedgerUpdate  (DualBlock m a) = LedgerUpdate  m

  inspectLedger :: forall (mk1 :: * -> * -> *) (mk2 :: * -> * -> *).
TopLevelConfig (DualBlock m a)
-> LedgerState (DualBlock m a) mk1
-> LedgerState (DualBlock m a) mk2
-> [LedgerEvent (DualBlock m a)]
inspectLedger TopLevelConfig (DualBlock m a)
cfg LedgerState (DualBlock m a) mk1
before LedgerState (DualBlock m a) mk2
after = (LedgerEvent m -> LedgerEvent (DualBlock m a))
-> [LedgerEvent m] -> [LedgerEvent (DualBlock m a)]
forall a b. (a -> b) -> [a] -> [b]
map LedgerEvent m -> LedgerEvent (DualBlock m a)
forall blk blk'.
(LedgerWarning blk ~ LedgerWarning blk',
 LedgerUpdate blk ~ LedgerUpdate blk') =>
LedgerEvent blk -> LedgerEvent blk'
castLedgerEvent ([LedgerEvent m] -> [LedgerEvent (DualBlock m a)])
-> [LedgerEvent m] -> [LedgerEvent (DualBlock m a)]
forall a b. (a -> b) -> a -> b
$
      TopLevelConfig m
-> LedgerState m mk1 -> LedgerState m mk2 -> [LedgerEvent m]
forall blk (mk1 :: * -> * -> *) (mk2 :: * -> * -> *).
InspectLedger blk =>
TopLevelConfig blk
-> LedgerState blk mk1 -> LedgerState blk mk2 -> [LedgerEvent blk]
forall (mk1 :: * -> * -> *) (mk2 :: * -> * -> *).
TopLevelConfig m
-> LedgerState m mk1 -> LedgerState m mk2 -> [LedgerEvent m]
inspectLedger
        (TopLevelConfig (DualBlock m a) -> TopLevelConfig m
forall m a. TopLevelConfig (DualBlock m a) -> TopLevelConfig m
dualTopLevelConfigMain TopLevelConfig (DualBlock m a)
cfg)
        (LedgerState (DualBlock m a) mk1 -> LedgerState m mk1
forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain    LedgerState (DualBlock m a) mk1
before)
        (LedgerState (DualBlock m a) mk2 -> LedgerState m mk2
forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain    LedgerState (DualBlock m a) mk2
after)


{-------------------------------------------------------------------------------
  PeerSelection
-------------------------------------------------------------------------------}

instance LedgerSupportsPeerSelection m
      => LedgerSupportsPeerSelection (DualBlock m a) where
  getPeers :: forall (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk
-> [(PoolStake, NonEmpty StakePoolRelay)]
getPeers = LedgerState m mk -> [(PoolStake, NonEmpty StakePoolRelay)]
forall blk (mk :: * -> * -> *).
LedgerSupportsPeerSelection blk =>
LedgerState blk mk -> [(PoolStake, NonEmpty StakePoolRelay)]
forall (mk :: * -> * -> *).
LedgerState m mk -> [(PoolStake, NonEmpty StakePoolRelay)]
getPeers (LedgerState m mk -> [(PoolStake, NonEmpty StakePoolRelay)])
-> (LedgerState (DualBlock m a) mk -> LedgerState m mk)
-> LedgerState (DualBlock m a) mk
-> [(PoolStake, NonEmpty StakePoolRelay)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (DualBlock m a) mk -> LedgerState m mk
forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain

{-------------------------------------------------------------------------------
  Forging
-------------------------------------------------------------------------------}

type instance CannotForge           (DualBlock m a) = CannotForge           m
type instance ForgeStateInfo        (DualBlock m a) = ForgeStateInfo        m
type instance ForgeStateUpdateError (DualBlock m a) = ForgeStateUpdateError m

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Lift 'applyLedgerBlock' to @Maybe blk@
--
-- Returns state unchanged on 'Nothing'
applyMaybeBlock :: UpdateLedger blk
                => ComputeLedgerEvents
                -> LedgerConfig blk
                -> Maybe blk
                -> TickedLedgerState blk ValuesMK
                -> LedgerState blk EmptyMK
                -> Except (LedgerError blk) (LedgerState blk DiffMK)
applyMaybeBlock :: forall blk.
UpdateLedger blk =>
ComputeLedgerEvents
-> LedgerConfig blk
-> Maybe blk
-> TickedLedgerState blk ValuesMK
-> LedgerState blk EmptyMK
-> Except (LedgerError blk) (LedgerState blk DiffMK)
applyMaybeBlock ComputeLedgerEvents
_   LedgerConfig blk
_   Maybe blk
Nothing      TickedLedgerState blk ValuesMK
_   LedgerState blk EmptyMK
st = LedgerState blk DiffMK
-> ExceptT
     (LedgerErr (LedgerState blk)) Identity (LedgerState blk DiffMK)
forall a. a -> ExceptT (LedgerErr (LedgerState blk)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerState blk DiffMK
 -> ExceptT
      (LedgerErr (LedgerState blk)) Identity (LedgerState blk DiffMK))
-> LedgerState blk DiffMK
-> ExceptT
     (LedgerErr (LedgerState blk)) Identity (LedgerState blk DiffMK)
forall a b. (a -> b) -> a -> b
$ LedgerState blk EmptyMK
st LedgerState blk EmptyMK
-> LedgerTables (LedgerState blk) DiffMK -> LedgerState blk DiffMK
forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState blk any
-> LedgerTables (LedgerState blk) mk -> LedgerState blk mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *)
       (any :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (LedgerState blk) DiffMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
applyMaybeBlock ComputeLedgerEvents
evs LedgerConfig blk
cfg (Just blk
block) TickedLedgerState blk ValuesMK
tst LedgerState blk EmptyMK
_  = ComputeLedgerEvents
-> LedgerConfig blk
-> blk
-> TickedLedgerState blk ValuesMK
-> ExceptT
     (LedgerErr (LedgerState blk)) Identity (LedgerState blk DiffMK)
forall (l :: LedgerStateKind) blk.
(ApplyBlock l blk, HasCallStack) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> Except (LedgerErr l) (l DiffMK)
applyLedgerBlock ComputeLedgerEvents
evs LedgerConfig blk
cfg blk
block TickedLedgerState blk ValuesMK
tst

-- | Lift 'reapplyLedgerBlock' to @Maybe blk@
--
-- See also 'applyMaybeBlock'
reapplyMaybeBlock :: UpdateLedger blk
                  => ComputeLedgerEvents
                  -> LedgerConfig blk
                  -> Maybe blk
                  -> TickedLedgerState blk ValuesMK
                  -> LedgerState blk EmptyMK
                  -> LedgerState blk DiffMK
reapplyMaybeBlock :: forall blk.
UpdateLedger blk =>
ComputeLedgerEvents
-> LedgerConfig blk
-> Maybe blk
-> TickedLedgerState blk ValuesMK
-> LedgerState blk EmptyMK
-> LedgerState blk DiffMK
reapplyMaybeBlock ComputeLedgerEvents
_   LedgerConfig blk
_   Maybe blk
Nothing      TickedLedgerState blk ValuesMK
_   LedgerState blk EmptyMK
st = LedgerState blk EmptyMK
st LedgerState blk EmptyMK
-> LedgerTables (LedgerState blk) DiffMK -> LedgerState blk DiffMK
forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState blk any
-> LedgerTables (LedgerState blk) mk -> LedgerState blk mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *)
       (any :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (LedgerState blk) DiffMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
reapplyMaybeBlock ComputeLedgerEvents
evs LedgerConfig blk
cfg (Just blk
block) TickedLedgerState blk ValuesMK
tst LedgerState blk EmptyMK
_  = ComputeLedgerEvents
-> LedgerConfig blk
-> blk
-> TickedLedgerState blk ValuesMK
-> LedgerState blk DiffMK
forall (l :: LedgerStateKind) blk.
(ApplyBlock l blk, HasCallStack) =>
ComputeLedgerEvents
-> LedgerCfg l -> blk -> Ticked l ValuesMK -> l DiffMK
reapplyLedgerBlock ComputeLedgerEvents
evs LedgerConfig blk
cfg blk
block TickedLedgerState blk ValuesMK
tst

-- | Used when the concrete and abstract implementation should agree on errors
--
-- The abstract-versus-concrete tests from the ledger folks tests precisely
-- this, so if this fails, it indicates a bug somewhere and we error out.
agreeOnError :: (Show e, Show e', HasCallStack)
             => (e -> e' -> err)
             -> (Except e a, Except e' b)
             -> Except err (a, b)
agreeOnError :: forall e e' err a b.
(Show e, Show e', HasCallStack) =>
(e -> e' -> err) -> (Except e a, Except e' b) -> Except err (a, b)
agreeOnError e -> e' -> err
f (Except e a
ma, Except e' b
mb) =
    case (Except e a -> Either e a
forall e a. Except e a -> Either e a
runExcept Except e a
ma, Except e' b -> Either e' b
forall e a. Except e a -> Either e a
runExcept Except e' b
mb) of
      (Left e
e, Left e'
e') ->
        err -> Except err (a, b)
forall a. err -> ExceptT err Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (err -> Except err (a, b)) -> err -> Except err (a, b)
forall a b. (a -> b) -> a -> b
$ e -> e' -> err
f e
e e'
e'
      (Left e
e, Right b
_) ->
        String -> Except err (a, b)
forall a. HasCallStack => String -> a
error (String -> Except err (a, b)) -> String -> Except err (a, b)
forall a b. (a -> b) -> a -> b
$ String
"agreeOnError: unexpected error " String -> ShowS
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e
      (Right a
_, Left e'
e') ->
        String -> Except err (a, b)
forall a. HasCallStack => String -> a
error (String -> Except err (a, b)) -> String -> Except err (a, b)
forall a b. (a -> b) -> a -> b
$ String
"agreeOnError: unexpected error " String -> ShowS
forall a. [a] -> [a] -> [a]
++ e' -> String
forall a. Show a => a -> String
show e'
e'
      (Right a
a, Right b
b) ->
        (a, b) -> Except err (a, b)
forall a. a -> ExceptT err Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)

{-------------------------------------------------------------------------------
  Serialisation

  For now we just require 'Serialise' for the auxiliary block.
-------------------------------------------------------------------------------}

encodeDualLedgerConfig :: (LedgerCfg (LedgerState m) -> Encoding)
                       -> (LedgerCfg (LedgerState a) -> Encoding)
                       -> DualLedgerConfig m a
                       -> Encoding
encodeDualLedgerConfig :: forall m a.
(LedgerCfg (LedgerState m) -> Encoding)
-> (LedgerCfg (LedgerState a) -> Encoding)
-> DualLedgerConfig m a
-> Encoding
encodeDualLedgerConfig LedgerCfg (LedgerState m) -> Encoding
encodeM LedgerCfg (LedgerState a) -> Encoding
encodeA (DualLedgerConfig LedgerCfg (LedgerState m)
m LedgerCfg (LedgerState a)
a) = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
2
    , LedgerCfg (LedgerState m) -> Encoding
encodeM LedgerCfg (LedgerState m)
m
    , LedgerCfg (LedgerState a) -> Encoding
encodeA LedgerCfg (LedgerState a)
a
    ]

decodeDualLedgerConfig :: Decoder s (LedgerCfg (LedgerState m))
                       -> Decoder s (LedgerCfg (LedgerState a))
                       -> Decoder s (DualLedgerConfig m a)
decodeDualLedgerConfig :: forall s m a.
Decoder s (LedgerCfg (LedgerState m))
-> Decoder s (LedgerCfg (LedgerState a))
-> Decoder s (DualLedgerConfig m a)
decodeDualLedgerConfig Decoder s (LedgerCfg (LedgerState m))
decodeM Decoder s (LedgerCfg (LedgerState a))
decodeA = do
  Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"DualLedgerConfig" Int
2
  LedgerCfg (LedgerState m)
-> LedgerCfg (LedgerState a) -> DualLedgerConfig m a
forall m a.
LedgerConfig m -> LedgerConfig a -> DualLedgerConfig m a
DualLedgerConfig
    (LedgerCfg (LedgerState m)
 -> LedgerCfg (LedgerState a) -> DualLedgerConfig m a)
-> Decoder s (LedgerCfg (LedgerState m))
-> Decoder s (LedgerCfg (LedgerState a) -> DualLedgerConfig m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (LedgerCfg (LedgerState m))
decodeM
    Decoder s (LedgerCfg (LedgerState a) -> DualLedgerConfig m a)
-> Decoder s (LedgerCfg (LedgerState a))
-> Decoder s (DualLedgerConfig m a)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (LedgerCfg (LedgerState a))
decodeA

encodeDualBlock :: (Bridge m a, Serialise a)
                => (m -> Encoding)
                -> DualBlock m a -> Encoding
encodeDualBlock :: forall m a.
(Bridge m a, Serialise a) =>
(m -> Encoding) -> DualBlock m a -> Encoding
encodeDualBlock m -> Encoding
encodeMain DualBlock{m
Maybe a
BridgeBlock m a
dualBlockMain :: forall m a. DualBlock m a -> m
dualBlockAux :: forall m a. DualBlock m a -> Maybe a
dualBlockBridge :: forall m a. DualBlock m a -> BridgeBlock m a
dualBlockMain :: m
dualBlockAux :: Maybe a
dualBlockBridge :: BridgeBlock m a
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
        Word -> Encoding
encodeListLen Word
3
      , m -> Encoding
encodeMain m
dualBlockMain
      , Maybe a -> Encoding
forall a. Serialise a => a -> Encoding
encode Maybe a
dualBlockAux
      , BridgeBlock m a -> Encoding
forall a. Serialise a => a -> Encoding
encode BridgeBlock m a
dualBlockBridge
      ]

decodeDualBlock :: (Bridge m a, Serialise a)
                => Decoder s (Lazy.ByteString -> m)
                -> Decoder s (Lazy.ByteString -> DualBlock m a)
decodeDualBlock :: forall m a s.
(Bridge m a, Serialise a) =>
Decoder s (ByteString -> m)
-> Decoder s (ByteString -> DualBlock m a)
decodeDualBlock Decoder s (ByteString -> m)
decodeMain = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"DualBlock" Int
3
    (ByteString -> m)
-> Maybe a -> BridgeBlock m a -> ByteString -> DualBlock m a
forall m a.
(ByteString -> m)
-> Maybe a -> BridgeBlock m a -> ByteString -> DualBlock m a
dualBlock
      ((ByteString -> m)
 -> Maybe a -> BridgeBlock m a -> ByteString -> DualBlock m a)
-> Decoder s (ByteString -> m)
-> Decoder
     s (Maybe a -> BridgeBlock m a -> ByteString -> DualBlock m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (ByteString -> m)
decodeMain
      Decoder
  s (Maybe a -> BridgeBlock m a -> ByteString -> DualBlock m a)
-> Decoder s (Maybe a)
-> Decoder s (BridgeBlock m a -> ByteString -> DualBlock m a)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Maybe a)
forall s. Decoder s (Maybe a)
forall a s. Serialise a => Decoder s a
decode
      Decoder s (BridgeBlock m a -> ByteString -> DualBlock m a)
-> Decoder s (BridgeBlock m a)
-> Decoder s (ByteString -> DualBlock m a)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (BridgeBlock m a)
forall s. Decoder s (BridgeBlock m a)
forall a s. Serialise a => Decoder s a
decode
  where
    dualBlock :: (Lazy.ByteString -> m)
              -> Maybe a
              -> BridgeBlock m a
              -> (Lazy.ByteString -> DualBlock m a)
    dualBlock :: forall m a.
(ByteString -> m)
-> Maybe a -> BridgeBlock m a -> ByteString -> DualBlock m a
dualBlock ByteString -> m
conc Maybe a
abst BridgeBlock m a
bridge ByteString
bs = m -> Maybe a -> BridgeBlock m a -> DualBlock m a
forall m a. m -> Maybe a -> BridgeBlock m a -> DualBlock m a
DualBlock (ByteString -> m
conc ByteString
bs) Maybe a
abst BridgeBlock m a
bridge

encodeDualHeader :: (Header m -> Encoding)
                 -> Header (DualBlock m a) -> Encoding
encodeDualHeader :: forall m a.
(Header m -> Encoding) -> Header (DualBlock m a) -> Encoding
encodeDualHeader Header m -> Encoding
encodeMain DualHeader{Header m
dualHeaderMain :: forall m a. Header (DualBlock m a) -> Header m
dualHeaderMain :: Header m
..} = Header m -> Encoding
encodeMain Header m
dualHeaderMain

decodeDualHeader :: Decoder s (Lazy.ByteString -> Header m)
                 -> Decoder s (Lazy.ByteString -> Header (DualBlock m a))
decodeDualHeader :: forall s m a.
Decoder s (ByteString -> Header m)
-> Decoder s (ByteString -> Header (DualBlock m a))
decodeDualHeader Decoder s (ByteString -> Header m)
decodeMain =
    (ByteString -> Header m) -> ByteString -> Header (DualBlock m a)
forall m a.
(ByteString -> Header m) -> ByteString -> Header (DualBlock m a)
dualHeader ((ByteString -> Header m) -> ByteString -> Header (DualBlock m a))
-> Decoder s (ByteString -> Header m)
-> Decoder s (ByteString -> Header (DualBlock m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (ByteString -> Header m)
decodeMain
  where
    dualHeader :: (Lazy.ByteString -> Header m)
               -> (Lazy.ByteString -> Header (DualBlock m a))
    dualHeader :: forall m a.
(ByteString -> Header m) -> ByteString -> Header (DualBlock m a)
dualHeader ByteString -> Header m
conc ByteString
bs = Header m -> Header (DualBlock m a)
forall m a. Header m -> Header (DualBlock m a)
DualHeader (ByteString -> Header m
conc ByteString
bs)

encodeDualGenTx :: (Bridge m a, Serialise (GenTx a))
                => (GenTx m -> Encoding)
                -> GenTx (DualBlock m a) -> Encoding
encodeDualGenTx :: forall m a.
(Bridge m a, Serialise (GenTx a)) =>
(GenTx m -> Encoding) -> GenTx (DualBlock m a) -> Encoding
encodeDualGenTx GenTx m -> Encoding
encodeMain DualGenTx{GenTx m
GenTx a
BridgeTx m a
dualGenTxMain :: forall m a. GenTx (DualBlock m a) -> GenTx m
dualGenTxAux :: forall m a. GenTx (DualBlock m a) -> GenTx a
dualGenTxBridge :: forall m a. GenTx (DualBlock m a) -> BridgeTx m a
dualGenTxMain :: GenTx m
dualGenTxAux :: GenTx a
dualGenTxBridge :: BridgeTx m a
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
3
    , GenTx m -> Encoding
encodeMain GenTx m
dualGenTxMain
    , GenTx a -> Encoding
forall a. Serialise a => a -> Encoding
encode     GenTx a
dualGenTxAux
    , BridgeTx m a -> Encoding
forall a. Serialise a => a -> Encoding
encode     BridgeTx m a
dualGenTxBridge
    ]

decodeDualGenTx :: (Bridge m a, Serialise (GenTx a))
                => Decoder s (GenTx m)
                -> Decoder s (GenTx (DualBlock m a))
decodeDualGenTx :: forall m a s.
(Bridge m a, Serialise (GenTx a)) =>
Decoder s (GenTx m) -> Decoder s (GenTx (DualBlock m a))
decodeDualGenTx Decoder s (GenTx m)
decodeMain = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"DualGenTx" Int
3
    GenTx m -> GenTx a -> BridgeTx m a -> GenTx (DualBlock m a)
forall m a.
GenTx m -> GenTx a -> BridgeTx m a -> GenTx (DualBlock m a)
DualGenTx
      (GenTx m -> GenTx a -> BridgeTx m a -> GenTx (DualBlock m a))
-> Decoder s (GenTx m)
-> Decoder s (GenTx a -> BridgeTx m a -> GenTx (DualBlock m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (GenTx m)
decodeMain
      Decoder s (GenTx a -> BridgeTx m a -> GenTx (DualBlock m a))
-> Decoder s (GenTx a)
-> Decoder s (BridgeTx m a -> GenTx (DualBlock m a))
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (GenTx a)
forall s. Decoder s (GenTx a)
forall a s. Serialise a => Decoder s a
decode
      Decoder s (BridgeTx m a -> GenTx (DualBlock m a))
-> Decoder s (BridgeTx m a) -> Decoder s (GenTx (DualBlock m a))
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (BridgeTx m a)
forall s. Decoder s (BridgeTx m a)
forall a s. Serialise a => Decoder s a
decode

encodeDualGenTxId :: (GenTxId m -> Encoding)
                  -> GenTxId (DualBlock m a) -> Encoding
encodeDualGenTxId :: forall m a.
(GenTxId m -> Encoding) -> GenTxId (DualBlock m a) -> Encoding
encodeDualGenTxId GenTxId m -> Encoding
encodeMain = GenTxId m -> Encoding
encodeMain (GenTxId m -> Encoding)
-> (GenTxId (DualBlock m a) -> GenTxId m)
-> GenTxId (DualBlock m a)
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTxId (DualBlock m a) -> GenTxId m
forall m a. TxId (GenTx (DualBlock m a)) -> GenTxId m
dualGenTxIdMain

decodeDualGenTxId :: Decoder s (GenTxId m)
                  -> Decoder s (GenTxId (DualBlock m a))
decodeDualGenTxId :: forall s m a.
Decoder s (GenTxId m) -> Decoder s (GenTxId (DualBlock m a))
decodeDualGenTxId Decoder s (GenTxId m)
decodeMain = GenTxId m -> TxId (GenTx (DualBlock m a))
forall m a. GenTxId m -> TxId (GenTx (DualBlock m a))
DualGenTxId (GenTxId m -> TxId (GenTx (DualBlock m a)))
-> Decoder s (GenTxId m)
-> Decoder s (TxId (GenTx (DualBlock m a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (GenTxId m)
decodeMain

encodeDualGenTxErr :: Serialise (ApplyTxErr a)
                   => (ApplyTxErr m -> Encoding)
                   -> ApplyTxErr (DualBlock m a) -> Encoding
encodeDualGenTxErr :: forall a m.
Serialise (ApplyTxErr a) =>
(ApplyTxErr m -> Encoding)
-> ApplyTxErr (DualBlock m a) -> Encoding
encodeDualGenTxErr ApplyTxErr m -> Encoding
encodeMain DualGenTxErr{ApplyTxErr a
ApplyTxErr m
dualGenTxErrMain :: forall m a. DualGenTxErr m a -> ApplyTxErr m
dualGenTxErrAux :: forall m a. DualGenTxErr m a -> ApplyTxErr a
dualGenTxErrMain :: ApplyTxErr m
dualGenTxErrAux :: ApplyTxErr a
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
2
    , ApplyTxErr m -> Encoding
encodeMain ApplyTxErr m
dualGenTxErrMain
    , ApplyTxErr a -> Encoding
forall a. Serialise a => a -> Encoding
encode     ApplyTxErr a
dualGenTxErrAux
    ]

decodeDualGenTxErr :: Serialise (ApplyTxErr a)
                   => Decoder s (ApplyTxErr m)
                   -> Decoder s (ApplyTxErr (DualBlock m a))
decodeDualGenTxErr :: forall a s m.
Serialise (ApplyTxErr a) =>
Decoder s (ApplyTxErr m) -> Decoder s (ApplyTxErr (DualBlock m a))
decodeDualGenTxErr Decoder s (ApplyTxErr m)
decodeMain = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"DualGenTxErr" Int
2
    ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a
forall m a. ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a
DualGenTxErr
      (ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a)
-> Decoder s (ApplyTxErr m)
-> Decoder s (ApplyTxErr a -> DualGenTxErr m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (ApplyTxErr m)
decodeMain
      Decoder s (ApplyTxErr a -> DualGenTxErr m a)
-> Decoder s (ApplyTxErr a) -> Decoder s (DualGenTxErr m a)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (ApplyTxErr a)
forall s. Decoder s (ApplyTxErr a)
forall a s. Serialise a => Decoder s a
decode

encodeDualLedgerState :: (Bridge m a, Serialise (LedgerState a ValuesMK))
                      => (LedgerState m mk -> Encoding)
                      -> LedgerState (DualBlock m a) mk -> Encoding
encodeDualLedgerState :: forall m a (mk :: * -> * -> *).
(Bridge m a, Serialise (LedgerState a ValuesMK)) =>
(LedgerState m mk -> Encoding)
-> LedgerState (DualBlock m a) mk -> Encoding
encodeDualLedgerState LedgerState m mk -> Encoding
encodeMain DualLedgerState{LedgerState m mk
LedgerState a ValuesMK
BridgeLedger m a
dualLedgerStateMain :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> BridgeLedger m a
dualLedgerStateAux :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState a ValuesMK
dualLedgerStateMain :: LedgerState m mk
dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateBridge :: BridgeLedger m a
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
3
    , LedgerState m mk -> Encoding
encodeMain LedgerState m mk
dualLedgerStateMain
    , LedgerState a ValuesMK -> Encoding
forall a. Serialise a => a -> Encoding
encode     LedgerState a ValuesMK
dualLedgerStateAux
    , BridgeLedger m a -> Encoding
forall a. Serialise a => a -> Encoding
encode     BridgeLedger m a
dualLedgerStateBridge
    ]

decodeDualLedgerState :: (Bridge m a, Serialise (LedgerState a ValuesMK))
                      => Decoder s (LedgerState m mk)
                      -> Decoder s (LedgerState (DualBlock m a) mk)
decodeDualLedgerState :: forall m a s (mk :: * -> * -> *).
(Bridge m a, Serialise (LedgerState a ValuesMK)) =>
Decoder s (LedgerState m mk)
-> Decoder s (LedgerState (DualBlock m a) mk)
decodeDualLedgerState Decoder s (LedgerState m mk)
decodeMain = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"DualLedgerState" Int
3
    LedgerState m mk
-> LedgerState a ValuesMK
-> BridgeLedger m a
-> LedgerState (DualBlock m a) mk
forall m a (mk :: * -> * -> *).
LedgerState m mk
-> LedgerState a ValuesMK
-> BridgeLedger m a
-> LedgerState (DualBlock m a) mk
DualLedgerState
      (LedgerState m mk
 -> LedgerState a ValuesMK
 -> BridgeLedger m a
 -> LedgerState (DualBlock m a) mk)
-> Decoder s (LedgerState m mk)
-> Decoder
     s
     (LedgerState a ValuesMK
      -> BridgeLedger m a -> LedgerState (DualBlock m a) mk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (LedgerState m mk)
decodeMain
      Decoder
  s
  (LedgerState a ValuesMK
   -> BridgeLedger m a -> LedgerState (DualBlock m a) mk)
-> Decoder s (LedgerState a ValuesMK)
-> Decoder s (BridgeLedger m a -> LedgerState (DualBlock m a) mk)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (LedgerState a ValuesMK)
forall s. Decoder s (LedgerState a ValuesMK)
forall a s. Serialise a => Decoder s a
decode
      Decoder s (BridgeLedger m a -> LedgerState (DualBlock m a) mk)
-> Decoder s (BridgeLedger m a)
-> Decoder s (LedgerState (DualBlock m a) mk)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (BridgeLedger m a)
forall s. Decoder s (BridgeLedger m a)
forall a s. Serialise a => Decoder s a
decode

{-------------------------------------------------------------------------------
  Ledger Tables
-------------------------------------------------------------------------------}

type instance TxIn  (LedgerState (DualBlock m a)) = TxIn  (LedgerState m)
type instance TxOut (LedgerState (DualBlock m a)) = TxOut (LedgerState m)

instance CanUpgradeLedgerTables (LedgerState (DualBlock m a)) where
  upgradeTables :: forall (mk1 :: * -> * -> *) (mk2 :: * -> * -> *).
LedgerState (DualBlock m a) mk1
-> LedgerState (DualBlock m a) mk2
-> LedgerTables (LedgerState (DualBlock m a)) ValuesMK
-> LedgerTables (LedgerState (DualBlock m a)) ValuesMK
upgradeTables LedgerState (DualBlock m a) mk1
_ LedgerState (DualBlock m a) mk2
_ = LedgerTables (LedgerState (DualBlock m a)) ValuesMK
-> LedgerTables (LedgerState (DualBlock m a)) ValuesMK
forall a. a -> a
id

instance (txout ~ TxOut (LedgerState m), IndexedMemPack (LedgerState m EmptyMK) txout)
      => IndexedMemPack (LedgerState (DualBlock m a) EmptyMK) txout where
  indexedTypeName :: LedgerState (DualBlock m a) EmptyMK -> String
indexedTypeName (DualLedgerState LedgerState m EmptyMK
st LedgerState a ValuesMK
_ BridgeLedger m a
_) = forall idx a. IndexedMemPack idx a => idx -> String
indexedTypeName @(LedgerState m EmptyMK) @txout LedgerState m EmptyMK
st
  indexedPackedByteCount :: LedgerState (DualBlock m a) EmptyMK -> txout -> Int
indexedPackedByteCount (DualLedgerState LedgerState m EmptyMK
st LedgerState a ValuesMK
_ BridgeLedger m a
_) = LedgerState m EmptyMK -> txout -> Int
forall idx a. IndexedMemPack idx a => idx -> a -> Int
indexedPackedByteCount LedgerState m EmptyMK
st
  indexedPackM :: forall s. LedgerState (DualBlock m a) EmptyMK -> txout -> Pack s ()
indexedPackM (DualLedgerState LedgerState m EmptyMK
st LedgerState a ValuesMK
_ BridgeLedger m a
_) = LedgerState m EmptyMK -> txout -> Pack s ()
forall s. LedgerState m EmptyMK -> txout -> Pack s ()
forall idx a s. IndexedMemPack idx a => idx -> a -> Pack s ()
indexedPackM LedgerState m EmptyMK
st
  indexedUnpackM :: forall b.
Buffer b =>
LedgerState (DualBlock m a) EmptyMK -> Unpack b txout
indexedUnpackM (DualLedgerState LedgerState m EmptyMK
st LedgerState a ValuesMK
_ BridgeLedger m a
_) = LedgerState m EmptyMK -> Unpack b txout
forall b. Buffer b => LedgerState m EmptyMK -> Unpack b txout
forall idx a b.
(IndexedMemPack idx a, Buffer b) =>
idx -> Unpack b a
indexedUnpackM LedgerState m EmptyMK
st

instance (Ord (TxIn (LedgerState m)), MemPack (TxIn (LedgerState m)), MemPack (TxOut (LedgerState m)))
      => SerializeTablesWithHint (LedgerState (DualBlock m a)) where
  encodeTablesWithHint :: SerializeTablesHint
  (LedgerTables (LedgerState (DualBlock m a)) ValuesMK)
-> LedgerTables (LedgerState (DualBlock m a)) ValuesMK -> Encoding
encodeTablesWithHint = SerializeTablesHint
  (LedgerTables (LedgerState (DualBlock m a)) ValuesMK)
-> LedgerTables (LedgerState (DualBlock m a)) ValuesMK -> Encoding
forall (l :: LedgerStateKind).
(MemPack (TxIn l), MemPack (TxOut l)) =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK -> Encoding
defaultEncodeTablesWithHint
  decodeTablesWithHint :: forall s.
SerializeTablesHint
  (LedgerTables (LedgerState (DualBlock m a)) ValuesMK)
-> Decoder s (LedgerTables (LedgerState (DualBlock m a)) ValuesMK)
decodeTablesWithHint = SerializeTablesHint
  (LedgerTables (LedgerState (DualBlock m a)) ValuesMK)
-> Decoder s (LedgerTables (LedgerState (DualBlock m a)) ValuesMK)
forall (l :: LedgerStateKind) s.
(Ord (TxIn l), MemPack (TxIn l), MemPack (TxOut l)) =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> Decoder s (LedgerTables l ValuesMK)
defaultDecodeTablesWithHint

instance (
    Bridge m a
  , NoThunks (TxOut (LedgerState m))
  , NoThunks (TxIn (LedgerState m))
  , Show (TxOut (LedgerState m))
  , Show (TxIn (LedgerState m))
  , Eq (TxOut (LedgerState m))
  , Ord (TxIn (LedgerState m))
  , MemPack (TxIn (LedgerState m))
  ) => HasLedgerTables (LedgerState (DualBlock m a)) where
  projectLedgerTables :: forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (DualBlock m a) mk
-> LedgerTables (LedgerState (DualBlock m a)) mk
projectLedgerTables DualLedgerState{LedgerState m mk
LedgerState a ValuesMK
BridgeLedger m a
dualLedgerStateMain :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> BridgeLedger m a
dualLedgerStateAux :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState a ValuesMK
dualLedgerStateMain :: LedgerState m mk
dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateBridge :: BridgeLedger m a
..} =
      LedgerTables (LedgerState m) mk
-> LedgerTables (LedgerState (DualBlock m a)) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: * -> * -> *).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables
        (LedgerState m mk -> LedgerTables (LedgerState m) mk
forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState m mk -> LedgerTables (LedgerState m) mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
projectLedgerTables LedgerState m mk
dualLedgerStateMain)

  withLedgerTables :: forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (DualBlock m a) any
-> LedgerTables (LedgerState (DualBlock m a)) mk
-> LedgerState (DualBlock m a) mk
withLedgerTables DualLedgerState{LedgerState m any
LedgerState a ValuesMK
BridgeLedger m a
dualLedgerStateMain :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> BridgeLedger m a
dualLedgerStateAux :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState a ValuesMK
dualLedgerStateMain :: LedgerState m any
dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateBridge :: BridgeLedger m a
..} LedgerTables (LedgerState (DualBlock m a)) mk
main =
      DualLedgerState {
          dualLedgerStateMain :: LedgerState m mk
dualLedgerStateMain   = LedgerState m any
-> LedgerTables (LedgerState m) mk -> LedgerState m mk
forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState m any
-> LedgerTables (LedgerState m) mk -> LedgerState m mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *)
       (any :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
withLedgerTables LedgerState m any
dualLedgerStateMain
                                (LedgerTables (LedgerState m) mk -> LedgerState m mk)
-> LedgerTables (LedgerState m) mk -> LedgerState m mk
forall a b. (a -> b) -> a -> b
$ LedgerTables (LedgerState (DualBlock m a)) mk
-> LedgerTables (LedgerState m) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: * -> * -> *).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables LedgerTables (LedgerState (DualBlock m a)) mk
main
        , dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateAux    = LedgerState a ValuesMK
dualLedgerStateAux
        , dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateBridge = BridgeLedger m a
dualLedgerStateBridge
        }

instance (
    Bridge m a
  , NoThunks (TxOut (LedgerState m))
  , NoThunks (TxIn (LedgerState m))
  , Show (TxOut (LedgerState m))
  , Show (TxIn (LedgerState m))
  , Eq (TxOut (LedgerState m))
  , Ord (TxIn (LedgerState m))
  , MemPack (TxIn (LedgerState m))
  )=> HasLedgerTables (Ticked (LedgerState (DualBlock m a))) where
  projectLedgerTables :: forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState (DualBlock m a)) mk
-> LedgerTables (Ticked (LedgerState (DualBlock m a))) mk
projectLedgerTables TickedDualLedgerState{Ticked (LedgerState m) mk
Ticked (LedgerState a) ValuesMK
LedgerState a ValuesMK
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateAux :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> LedgerState a ValuesMK
tickedDualLedgerStateMain :: Ticked (LedgerState m) mk
tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
..} =
      LedgerTables (Ticked (LedgerState m)) mk
-> LedgerTables (Ticked (LedgerState (DualBlock m a))) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: * -> * -> *).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables
        (Ticked (LedgerState m) mk
-> LedgerTables (Ticked (LedgerState m)) mk
forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState m) mk
-> LedgerTables (Ticked (LedgerState m)) mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
projectLedgerTables Ticked (LedgerState m) mk
tickedDualLedgerStateMain)

  withLedgerTables :: forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState (DualBlock m a)) any
-> LedgerTables (Ticked (LedgerState (DualBlock m a))) mk
-> Ticked (LedgerState (DualBlock m a)) mk
withLedgerTables
    TickedDualLedgerState{Ticked (LedgerState m) any
Ticked (LedgerState a) ValuesMK
LedgerState a ValuesMK
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState m) mk
tickedDualLedgerStateAux :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk
-> Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a (mk :: * -> * -> *).
Ticked (LedgerState (DualBlock m a)) mk -> LedgerState a ValuesMK
tickedDualLedgerStateMain :: Ticked (LedgerState m) any
tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
..}
    LedgerTables (Ticked (LedgerState (DualBlock m a))) mk
main =
      TickedDualLedgerState {
          tickedDualLedgerStateMain :: Ticked (LedgerState m) mk
tickedDualLedgerStateMain   =
            Ticked (LedgerState m) any
-> LedgerTables (Ticked (LedgerState m)) mk
-> Ticked (LedgerState m) mk
forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState m) any
-> LedgerTables (Ticked (LedgerState m)) mk
-> Ticked (LedgerState m) mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *)
       (any :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
withLedgerTables Ticked (LedgerState m) any
tickedDualLedgerStateMain (LedgerTables (Ticked (LedgerState m)) mk
 -> Ticked (LedgerState m) mk)
-> LedgerTables (Ticked (LedgerState m)) mk
-> Ticked (LedgerState m) mk
forall a b. (a -> b) -> a -> b
$ LedgerTables (Ticked (LedgerState (DualBlock m a))) mk
-> LedgerTables (Ticked (LedgerState m)) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: * -> * -> *).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables LedgerTables (Ticked (LedgerState (DualBlock m a))) mk
main
        , Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux :: Ticked (LedgerState a) ValuesMK
tickedDualLedgerStateAux
        , BridgeLedger m a
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateBridge
        , LedgerState a ValuesMK
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
tickedDualLedgerStateAuxOrig :: LedgerState a ValuesMK
tickedDualLedgerStateAuxOrig
        }

instance CanStowLedgerTables (LedgerState m)
      => CanStowLedgerTables (LedgerState (DualBlock m a)) where
  stowLedgerTables :: LedgerState (DualBlock m a) ValuesMK
-> LedgerState (DualBlock m a) EmptyMK
stowLedgerTables LedgerState (DualBlock m a) ValuesMK
dls =
    DualLedgerState{
      dualLedgerStateMain :: LedgerState m EmptyMK
dualLedgerStateMain = LedgerState m ValuesMK -> LedgerState m EmptyMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l ValuesMK -> l EmptyMK
stowLedgerTables LedgerState m ValuesMK
dualLedgerStateMain
    , LedgerState a ValuesMK
dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateAux
    , BridgeLedger m a
dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateBridge
    }
   where
    DualLedgerState { LedgerState m ValuesMK
dualLedgerStateMain :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain :: LedgerState m ValuesMK
dualLedgerStateMain
                    , LedgerState a ValuesMK
dualLedgerStateAux :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState a ValuesMK
dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateAux
                    , BridgeLedger m a
dualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> BridgeLedger m a
dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateBridge
                    } = LedgerState (DualBlock m a) ValuesMK
dls

  unstowLedgerTables :: LedgerState (DualBlock m a) EmptyMK
-> LedgerState (DualBlock m a) ValuesMK
unstowLedgerTables LedgerState (DualBlock m a) EmptyMK
dls =
    DualLedgerState{
      dualLedgerStateMain :: LedgerState m ValuesMK
dualLedgerStateMain = LedgerState m EmptyMK -> LedgerState m ValuesMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l EmptyMK -> l ValuesMK
unstowLedgerTables LedgerState m EmptyMK
dualLedgerStateMain
    , LedgerState a ValuesMK
dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateAux
    , BridgeLedger m a
dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateBridge
    }
   where
    DualLedgerState { LedgerState m EmptyMK
dualLedgerStateMain :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState m mk
dualLedgerStateMain :: LedgerState m EmptyMK
dualLedgerStateMain
                    , LedgerState a ValuesMK
dualLedgerStateAux :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> LedgerState a ValuesMK
dualLedgerStateAux :: LedgerState a ValuesMK
dualLedgerStateAux
                    , BridgeLedger m a
dualLedgerStateBridge :: forall m a (mk :: * -> * -> *).
LedgerState (DualBlock m a) mk -> BridgeLedger m a
dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateBridge
                    } = LedgerState (DualBlock m a) EmptyMK
dls