{-# 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 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 (..)
  , NestedCtxt_ (..)
  , StorageConfig (..)
  , Ticked (..)
  , TxId (..)
  , Validated (..)
    -- * Serialisation
  , decodeDualBlock
  , decodeDualGenTx
  , decodeDualGenTxErr
  , decodeDualGenTxId
  , decodeDualHeader
  , decodeDualLedgerState
  , encodeDualBlock
  , encodeDualGenTx
  , encodeDualGenTxErr
  , encodeDualGenTxId
  , encodeDualHeader
  , 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.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.Storage.Serialisation
import           Ouroboros.Consensus.Util (ShowProxy (..))
import           Ouroboros.Consensus.Util.Condense

{-------------------------------------------------------------------------------
  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)
topLevelConfigProtocol :: forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
topLevelConfigLedger :: forall blk. TopLevelConfig blk -> LedgerConfig blk
topLevelConfigBlock :: forall blk. TopLevelConfig blk -> BlockConfig blk
topLevelConfigCodec :: forall blk. TopLevelConfig blk -> CodecConfig blk
topLevelConfigStorage :: forall blk. TopLevelConfig blk -> StorageConfig blk
topLevelConfigCheckpoints :: forall blk. TopLevelConfig blk -> CheckpointsMap 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)

        -- Requirements on the auxiliary block
        -- No 'LedgerSupportsProtocol' for @a@!
      , Typeable                a
      , UpdateLedger            a
      , LedgerSupportsMempool   a
      , Show (ApplyTxErr        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)

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

instance Bridge m a => GetTip (LedgerState (DualBlock m a)) where
  getTip :: LedgerState (DualBlock m a) -> 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) -> Point (LedgerState m))
-> LedgerState (DualBlock m a)
-> Point (LedgerState (DualBlock m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState m -> Point (LedgerState m)
forall l. GetTip l => l -> Point l
getTip (LedgerState m -> Point (LedgerState m))
-> (LedgerState (DualBlock m a) -> LedgerState m)
-> LedgerState (DualBlock m a)
-> Point (LedgerState m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (DualBlock m a) -> LedgerState m
forall m a. LedgerState (DualBlock m a) -> LedgerState m
dualLedgerStateMain

instance Bridge m a => GetTip (Ticked (LedgerState (DualBlock m a))) where
  getTip :: Ticked (LedgerState (DualBlock m a))
-> 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))
    -> Point (Ticked (LedgerState m)))
-> Ticked (LedgerState (DualBlock m a))
-> Point (Ticked (LedgerState (DualBlock m a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState m) -> Point (Ticked (LedgerState m))
forall l. GetTip l => l -> Point l
getTip (Ticked (LedgerState m) -> Point (Ticked (LedgerState m)))
-> (Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m))
-> Ticked (LedgerState (DualBlock m a))
-> Point (Ticked (LedgerState m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
tickedDualLedgerStateMain

data instance Ticked (LedgerState (DualBlock m a)) = TickedDualLedgerState {
      forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
tickedDualLedgerStateMain    :: Ticked (LedgerState m)
    , forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState a)
tickedDualLedgerStateAux     :: Ticked (LedgerState a)
    , forall m a.
Ticked (LedgerState (DualBlock m a)) -> 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. Ticked (LedgerState (DualBlock m a)) -> LedgerState a
tickedDualLedgerStateAuxOrig :: LedgerState a
    }
  deriving Context
-> Ticked (LedgerState (DualBlock m a)) -> IO (Maybe ThunkInfo)
Proxy (Ticked (LedgerState (DualBlock m a))) -> String
(Context
 -> Ticked (LedgerState (DualBlock m a)) -> IO (Maybe ThunkInfo))
-> (Context
    -> Ticked (LedgerState (DualBlock m a)) -> IO (Maybe ThunkInfo))
-> (Proxy (Ticked (LedgerState (DualBlock m a))) -> String)
-> NoThunks (Ticked (LedgerState (DualBlock m a)))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall m a.
Context
-> Ticked (LedgerState (DualBlock m a)) -> IO (Maybe ThunkInfo)
forall m a. Proxy (Ticked (LedgerState (DualBlock m a))) -> String
$cnoThunks :: forall m a.
Context
-> Ticked (LedgerState (DualBlock m a)) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> Ticked (LedgerState (DualBlock m a)) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall m a.
Context
-> Ticked (LedgerState (DualBlock m a)) -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> Ticked (LedgerState (DualBlock m a)) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall m a. Proxy (Ticked (LedgerState (DualBlock m a))) -> String
showTypeOf :: Proxy (Ticked (LedgerState (DualBlock m a))) -> String
NoThunks via AllowThunk (Ticked (LedgerState (DualBlock m a)))

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 :: LedgerCfg (LedgerState (DualBlock m a))
-> SlotNo
-> LedgerState (DualBlock m a)
-> LedgerResult
     (LedgerState (DualBlock m a))
     (Ticked (LedgerState (DualBlock m a)))
applyChainTickLedgerResult 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
LedgerState a
BridgeLedger m a
dualLedgerStateMain :: forall m a. LedgerState (DualBlock m a) -> LedgerState m
dualLedgerStateMain :: LedgerState m
dualLedgerStateAux :: LedgerState a
dualLedgerStateBridge :: BridgeLedger m a
dualLedgerStateAux :: forall m a. LedgerState (DualBlock m a) -> LedgerState a
dualLedgerStateBridge :: forall m a. LedgerState (DualBlock m a) -> BridgeLedger m a
..} =
      LedgerResult (LedgerState m) (Ticked (LedgerState m))
-> LedgerResult
     (LedgerState (DualBlock m a)) (Ticked (LedgerState m))
forall l l' a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult (LedgerState m) (Ticked (LedgerState m))
ledgerResult LedgerResult (LedgerState (DualBlock m a)) (Ticked (LedgerState m))
-> (Ticked (LedgerState m) -> Ticked (LedgerState (DualBlock m a)))
-> LedgerResult
     (LedgerState (DualBlock m a))
     (Ticked (LedgerState (DualBlock m a)))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Ticked (LedgerState m)
main -> TickedDualLedgerState {
          tickedDualLedgerStateMain :: Ticked (LedgerState m)
tickedDualLedgerStateMain    = Ticked (LedgerState m)
main
        , tickedDualLedgerStateAux :: Ticked (LedgerState a)
tickedDualLedgerStateAux     = LedgerConfig a -> SlotNo -> LedgerState a -> Ticked (LedgerState a)
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick
                                           LedgerConfig a
dualLedgerConfigAux
                                           SlotNo
slot
                                          LedgerState a
dualLedgerStateAux
        , tickedDualLedgerStateAuxOrig :: LedgerState a
tickedDualLedgerStateAuxOrig = LedgerState a
dualLedgerStateAux
        , tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateBridge  = BridgeLedger m a
dualLedgerStateBridge
        }
    where
      ledgerResult :: LedgerResult (LedgerState m) (Ticked (LedgerState m))
ledgerResult = LedgerConfig m
-> SlotNo
-> LedgerState m
-> LedgerResult (LedgerState m) (Ticked (LedgerState m))
forall l.
IsLedger l =>
LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l)
applyChainTickLedgerResult
                       LedgerConfig m
dualLedgerConfigMain
                       SlotNo
slot
                       LedgerState m
dualLedgerStateMain

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

  applyBlockLedgerResult :: HasCallStack =>
LedgerCfg (LedgerState (DualBlock m a))
-> DualBlock m a
-> Ticked (LedgerState (DualBlock m a))
-> Except
     (LedgerErr (LedgerState (DualBlock m a)))
     (LedgerResult
        (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a)))
applyBlockLedgerResult 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)
Ticked (LedgerState a)
LedgerState a
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
tickedDualLedgerStateAux :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState a)
tickedDualLedgerStateBridge :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a. Ticked (LedgerState (DualBlock m a)) -> LedgerState a
tickedDualLedgerStateMain :: Ticked (LedgerState m)
tickedDualLedgerStateAux :: Ticked (LedgerState a)
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a
..} = do
      (LedgerResult (LedgerState m) (LedgerState m)
ledgerResult, LedgerState a
aux') <-
        (LedgerErr (LedgerState m)
 -> LedgerErr (LedgerState a) -> DualLedgerError m a)
-> (Except
      (LedgerErr (LedgerState m))
      (LedgerResult (LedgerState m) (LedgerState m)),
    Except (LedgerErr (LedgerState a)) (LedgerState a))
-> Except
     (DualLedgerError m a)
     (LedgerResult (LedgerState m) (LedgerState m), LedgerState 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 LedgerErr (LedgerState m)
-> LedgerErr (LedgerState a) -> DualLedgerError m a
forall m a. LedgerError m -> LedgerError a -> DualLedgerError m a
DualLedgerError (
            LedgerCfg (LedgerState m)
-> m
-> Ticked (LedgerState m)
-> Except
     (LedgerErr (LedgerState m))
     (LedgerResult (LedgerState m) (LedgerState m))
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l
-> blk -> Ticked l -> Except (LedgerErr l) (LedgerResult l l)
applyBlockLedgerResult
              (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)
tickedDualLedgerStateMain
          , LedgerConfig a
-> Maybe a
-> Ticked (LedgerState a)
-> LedgerState a
-> Except (LedgerErr (LedgerState a)) (LedgerState a)
forall blk.
UpdateLedger blk =>
LedgerConfig blk
-> Maybe blk
-> TickedLedgerState blk
-> LedgerState blk
-> Except (LedgerError blk) (LedgerState blk)
applyMaybeBlock
              (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)
tickedDualLedgerStateAux
              LedgerState a
tickedDualLedgerStateAuxOrig
          )
      LedgerResult
  (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a))
-> ExceptT
     (DualLedgerError m a)
     Identity
     (LedgerResult
        (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a)))
forall a. a -> ExceptT (DualLedgerError m a) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerResult
   (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a))
 -> ExceptT
      (DualLedgerError m a)
      Identity
      (LedgerResult
         (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a))))
-> LedgerResult
     (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a))
-> ExceptT
     (DualLedgerError m a)
     Identity
     (LedgerResult
        (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a)))
forall a b. (a -> b) -> a -> b
$ LedgerResult (LedgerState m) (LedgerState m)
-> LedgerResult (LedgerState (DualBlock m a)) (LedgerState m)
forall l l' a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult (LedgerState m) (LedgerState m)
ledgerResult LedgerResult (LedgerState (DualBlock m a)) (LedgerState m)
-> (LedgerState m -> LedgerState (DualBlock m a))
-> LedgerResult
     (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \LedgerState m
main' -> DualLedgerState {
          dualLedgerStateMain :: LedgerState m
dualLedgerStateMain   = LedgerState m
main'
        , dualLedgerStateAux :: LedgerState a
dualLedgerStateAux    = LedgerState a
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
        }

  reapplyBlockLedgerResult :: HasCallStack =>
LedgerCfg (LedgerState (DualBlock m a))
-> DualBlock m a
-> Ticked (LedgerState (DualBlock m a))
-> LedgerResult
     (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a))
reapplyBlockLedgerResult 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)
Ticked (LedgerState a)
LedgerState a
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
tickedDualLedgerStateAux :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState a)
tickedDualLedgerStateBridge :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a. Ticked (LedgerState (DualBlock m a)) -> LedgerState a
tickedDualLedgerStateMain :: Ticked (LedgerState m)
tickedDualLedgerStateAux :: Ticked (LedgerState a)
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a
..} =
    LedgerResult (LedgerState m) (LedgerState m)
-> LedgerResult (LedgerState (DualBlock m a)) (LedgerState m)
forall l l' a.
(AuxLedgerEvent l ~ AuxLedgerEvent l') =>
LedgerResult l a -> LedgerResult l' a
castLedgerResult LedgerResult (LedgerState m) (LedgerState m)
ledgerResult LedgerResult (LedgerState (DualBlock m a)) (LedgerState m)
-> (LedgerState m -> LedgerState (DualBlock m a))
-> LedgerResult
     (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \LedgerState m
main' -> DualLedgerState {
        dualLedgerStateMain :: LedgerState m
dualLedgerStateMain   = LedgerState m
main'
      , dualLedgerStateAux :: LedgerState a
dualLedgerStateAux    = LedgerConfig a
-> Maybe a
-> Ticked (LedgerState a)
-> LedgerState a
-> LedgerState a
forall blk.
UpdateLedger blk =>
LedgerConfig blk
-> Maybe blk
-> TickedLedgerState blk
-> LedgerState blk
-> LedgerState blk
reapplyMaybeBlock
                                  (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)
tickedDualLedgerStateAux
                                  LedgerState a
tickedDualLedgerStateAuxOrig
      , 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
      ledgerResult :: LedgerResult (LedgerState m) (LedgerState m)
ledgerResult = LedgerCfg (LedgerState m)
-> m
-> Ticked (LedgerState m)
-> LedgerResult (LedgerState m) (LedgerState m)
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> LedgerResult l l
reapplyBlockLedgerResult
                       (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)
tickedDualLedgerStateMain

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

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

deriving instance ( Bridge m a
                  ) => Show (LedgerState (DualBlock m a))
deriving instance ( Bridge m a
                  ) => Eq (LedgerState (DualBlock m a))

{-------------------------------------------------------------------------------
  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 :: LedgerConfig (DualBlock m a)
-> Ticked (LedgerState (DualBlock m a))
-> LedgerView (BlockProtocol (DualBlock m a))
protocolLedgerView LedgerConfig (DualBlock m a)
cfg Ticked (LedgerState (DualBlock m a))
state =
      LedgerConfig m
-> Ticked (LedgerState m) -> LedgerView (BlockProtocol m)
forall blk.
LedgerSupportsProtocol blk =>
LedgerConfig blk
-> Ticked (LedgerState blk) -> LedgerView (BlockProtocol blk)
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)) -> Ticked (LedgerState m)
forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
tickedDualLedgerStateMain Ticked (LedgerState (DualBlock m a))
state)

  ledgerViewForecastAt :: HasCallStack =>
LedgerConfig (DualBlock m a)
-> LedgerState (DualBlock m a)
-> Forecast (LedgerView (BlockProtocol (DualBlock m a)))
ledgerViewForecastAt LedgerConfig (DualBlock m a)
cfg LedgerState (DualBlock m a)
state =
      LedgerConfig m
-> LedgerState m -> Forecast (LedgerView (BlockProtocol m))
forall blk.
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
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) -> LedgerState m
forall m a. LedgerState (DualBlock m a) -> LedgerState m
dualLedgerStateMain  LedgerState (DualBlock m a)
state)

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

  hardForkSummary :: LedgerConfig (DualBlock m a)
-> LedgerState (DualBlock m a)
-> Summary (HardForkIndices (DualBlock m a))
hardForkSummary LedgerConfig (DualBlock m a)
cfg LedgerState (DualBlock m a)
state =
      LedgerConfig m -> LedgerState m -> Summary (HardForkIndices m)
forall blk.
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
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) -> LedgerState m
forall m a. LedgerState (DualBlock m a) -> LedgerState m
dualLedgerStateMain  LedgerState (DualBlock m a)
state)

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

data instance BlockQuery (DualBlock m a) result
  deriving (Int -> BlockQuery (DualBlock m a) result -> ShowS
[BlockQuery (DualBlock m a) result] -> ShowS
BlockQuery (DualBlock m a) result -> String
(Int -> BlockQuery (DualBlock m a) result -> ShowS)
-> (BlockQuery (DualBlock m a) result -> String)
-> ([BlockQuery (DualBlock m a) result] -> ShowS)
-> Show (BlockQuery (DualBlock m a) result)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall m a result.
Int -> BlockQuery (DualBlock m a) result -> ShowS
forall m a result. [BlockQuery (DualBlock m a) result] -> ShowS
forall m a result. BlockQuery (DualBlock m a) result -> String
$cshowsPrec :: forall m a result.
Int -> BlockQuery (DualBlock m a) result -> ShowS
showsPrec :: Int -> BlockQuery (DualBlock m a) result -> ShowS
$cshow :: forall m a result. BlockQuery (DualBlock m a) result -> String
show :: BlockQuery (DualBlock m a) result -> String
$cshowList :: forall m a result. [BlockQuery (DualBlock m a) result] -> ShowS
showList :: [BlockQuery (DualBlock m a) 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
  answerBlockQuery :: forall result.
ExtLedgerCfg (DualBlock m a)
-> BlockQuery (DualBlock m a) result
-> ExtLedgerState (DualBlock m a)
-> result
answerBlockQuery ExtLedgerCfg (DualBlock m a)
_ = \case {}

instance SameDepIndex (BlockQuery (DualBlock m a)) where
  sameDepIndex :: forall a b.
BlockQuery (DualBlock m a) a
-> BlockQuery (DualBlock m a) b -> Maybe (a :~: b)
sameDepIndex = \case {}

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

-- | Forward to the main ledger
instance Bridge m a => CommonProtocolParams (DualBlock m a) where
  maxHeaderSize :: LedgerState (DualBlock m a) -> Word32
maxHeaderSize = LedgerState m -> Word32
forall blk. CommonProtocolParams blk => LedgerState blk -> Word32
maxHeaderSize (LedgerState m -> Word32)
-> (LedgerState (DualBlock m a) -> LedgerState m)
-> LedgerState (DualBlock m a)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (DualBlock m a) -> LedgerState m
forall m a. LedgerState (DualBlock m a) -> LedgerState m
dualLedgerStateMain
  maxTxSize :: LedgerState (DualBlock m a) -> Word32
maxTxSize     = LedgerState m -> Word32
forall blk. CommonProtocolParams blk => LedgerState blk -> Word32
maxTxSize     (LedgerState m -> Word32)
-> (LedgerState (DualBlock m a) -> LedgerState m)
-> LedgerState (DualBlock m a)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (DualBlock m a) -> LedgerState m
forall m a. LedgerState (DualBlock m a) -> LedgerState m
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)
-> Ticked (LedgerState (DualBlock m a))
-> Except
     (ApplyTxErr (DualBlock m a))
     (Ticked (LedgerState (DualBlock m a)),
      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)
Ticked (LedgerState a)
LedgerState a
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
tickedDualLedgerStateAux :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState a)
tickedDualLedgerStateBridge :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a. Ticked (LedgerState (DualBlock m a)) -> LedgerState a
tickedDualLedgerStateMain :: Ticked (LedgerState m)
tickedDualLedgerStateAux :: Ticked (LedgerState a)
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a
..} = do
      ((Ticked (LedgerState m)
main', Validated (GenTx m)
mainVtx), (Ticked (LedgerState a)
aux', Validated (GenTx a)
auxVtx)) <-
        (ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a)
-> (Except
      (ApplyTxErr m) (Ticked (LedgerState m), Validated (GenTx m)),
    Except
      (ApplyTxErr a) (Ticked (LedgerState a), Validated (GenTx a)))
-> Except
     (DualGenTxErr m a)
     ((Ticked (LedgerState m), Validated (GenTx m)),
      (Ticked (LedgerState a), 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)
-> Except
     (ApplyTxErr m) (Ticked (LedgerState m), Validated (GenTx m))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> Ticked (LedgerState blk)
-> Except
     (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
applyTx
              LedgerConfig m
dualLedgerConfigMain
              WhetherToIntervene
wti
              SlotNo
slot
              GenTx m
dualGenTxMain
              Ticked (LedgerState m)
tickedDualLedgerStateMain
          , LedgerConfig a
-> WhetherToIntervene
-> SlotNo
-> GenTx a
-> Ticked (LedgerState a)
-> Except
     (ApplyTxErr a) (Ticked (LedgerState a), Validated (GenTx a))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> Ticked (LedgerState blk)
-> Except
     (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
applyTx
              LedgerConfig a
dualLedgerConfigAux
              WhetherToIntervene
wti
              SlotNo
slot
              GenTx a
dualGenTxAux
              Ticked (LedgerState a)
tickedDualLedgerStateAux
          )
      let vtx :: Validated (GenTx (DualBlock m a))
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
              }
      (Ticked (LedgerState (DualBlock m a)),
 Validated (GenTx (DualBlock m a)))
-> ExceptT
     (DualGenTxErr m a)
     Identity
     (Ticked (LedgerState (DualBlock m a)),
      Validated (GenTx (DualBlock m a)))
forall a. a -> ExceptT (DualGenTxErr m a) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ticked (LedgerState (DualBlock m a)),
  Validated (GenTx (DualBlock m a)))
 -> ExceptT
      (DualGenTxErr m a)
      Identity
      (Ticked (LedgerState (DualBlock m a)),
       Validated (GenTx (DualBlock m a))))
-> (Ticked (LedgerState (DualBlock m a)),
    Validated (GenTx (DualBlock m a)))
-> ExceptT
     (DualGenTxErr m a)
     Identity
     (Ticked (LedgerState (DualBlock m a)),
      Validated (GenTx (DualBlock m a)))
forall a b. (a -> b) -> a -> b
$ (Ticked (LedgerState (DualBlock m a))
 -> Validated (GenTx (DualBlock m a))
 -> (Ticked (LedgerState (DualBlock m a)),
     Validated (GenTx (DualBlock m a))))
-> Validated (GenTx (DualBlock m a))
-> Ticked (LedgerState (DualBlock m a))
-> (Ticked (LedgerState (DualBlock m a)),
    Validated (GenTx (DualBlock m a)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) Validated (GenTx (DualBlock m a))
vtx (Ticked (LedgerState (DualBlock m a))
 -> (Ticked (LedgerState (DualBlock m a)),
     Validated (GenTx (DualBlock m a))))
-> Ticked (LedgerState (DualBlock m a))
-> (Ticked (LedgerState (DualBlock m a)),
    Validated (GenTx (DualBlock m a)))
forall a b. (a -> b) -> a -> b
$ TickedDualLedgerState {
          tickedDualLedgerStateMain :: Ticked (LedgerState m)
tickedDualLedgerStateMain    = Ticked (LedgerState m)
main'
        , tickedDualLedgerStateAux :: Ticked (LedgerState a)
tickedDualLedgerStateAux     = Ticked (LedgerState a)
aux'
        , tickedDualLedgerStateAuxOrig :: LedgerState a
tickedDualLedgerStateAuxOrig = LedgerState a
tickedDualLedgerStateAuxOrig
        , tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateBridge  = Validated (GenTx (DualBlock m a))
-> BridgeLedger m a -> BridgeLedger m a
forall m a.
Bridge m a =>
Validated (GenTx (DualBlock m a))
-> BridgeLedger m a -> BridgeLedger m a
updateBridgeWithTx
                                           Validated (GenTx (DualBlock m a))
vtx
                                           BridgeLedger m a
tickedDualLedgerStateBridge
        }

  reapplyTx :: HasCallStack =>
LedgerConfig (DualBlock m a)
-> SlotNo
-> Validated (GenTx (DualBlock m a))
-> Ticked (LedgerState (DualBlock m a))
-> Except
     (ApplyTxErr (DualBlock m a)) (Ticked (LedgerState (DualBlock m a)))
reapplyTx 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)
Ticked (LedgerState a)
LedgerState a
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
tickedDualLedgerStateAux :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState a)
tickedDualLedgerStateBridge :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a. Ticked (LedgerState (DualBlock m a)) -> LedgerState a
tickedDualLedgerStateMain :: Ticked (LedgerState m)
tickedDualLedgerStateAux :: Ticked (LedgerState a)
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a
..} = do
      (Ticked (LedgerState m)
main', Ticked (LedgerState a)
aux') <-
        (ApplyTxErr m -> ApplyTxErr a -> DualGenTxErr m a)
-> (Except (ApplyTxErr m) (Ticked (LedgerState m)),
    Except (ApplyTxErr a) (Ticked (LedgerState a)))
-> Except
     (DualGenTxErr m a) (Ticked (LedgerState m), Ticked (LedgerState 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
-> SlotNo
-> Validated (GenTx m)
-> Ticked (LedgerState m)
-> Except (ApplyTxErr m) (Ticked (LedgerState m))
forall blk.
(LedgerSupportsMempool blk, HasCallStack) =>
LedgerConfig blk
-> SlotNo
-> Validated (GenTx blk)
-> Ticked (LedgerState blk)
-> Except (ApplyTxErr blk) (Ticked (LedgerState blk))
reapplyTx
              LedgerConfig m
dualLedgerConfigMain
              SlotNo
slot
              Validated (GenTx m)
vDualGenTxMain
              Ticked (LedgerState m)
tickedDualLedgerStateMain
          , LedgerConfig a
-> SlotNo
-> Validated (GenTx a)
-> Ticked (LedgerState a)
-> Except (ApplyTxErr a) (Ticked (LedgerState a))
forall blk.
(LedgerSupportsMempool blk, HasCallStack) =>
LedgerConfig blk
-> SlotNo
-> Validated (GenTx blk)
-> Ticked (LedgerState blk)
-> Except (ApplyTxErr blk) (Ticked (LedgerState blk))
reapplyTx
              LedgerConfig a
dualLedgerConfigAux
              SlotNo
slot
              Validated (GenTx a)
vDualGenTxAux
              Ticked (LedgerState a)
tickedDualLedgerStateAux
          )
      Ticked (LedgerState (DualBlock m a))
-> ExceptT
     (DualGenTxErr m a) Identity (Ticked (LedgerState (DualBlock m a)))
forall a. a -> ExceptT (DualGenTxErr m a) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ticked (LedgerState (DualBlock m a))
 -> ExceptT
      (DualGenTxErr m a) Identity (Ticked (LedgerState (DualBlock m a))))
-> Ticked (LedgerState (DualBlock m a))
-> ExceptT
     (DualGenTxErr m a) Identity (Ticked (LedgerState (DualBlock m a)))
forall a b. (a -> b) -> a -> b
$ TickedDualLedgerState {
          tickedDualLedgerStateMain :: Ticked (LedgerState m)
tickedDualLedgerStateMain    = Ticked (LedgerState m)
main'
        , tickedDualLedgerStateAux :: Ticked (LedgerState a)
tickedDualLedgerStateAux     = Ticked (LedgerState a)
aux'
        , tickedDualLedgerStateAuxOrig :: LedgerState a
tickedDualLedgerStateAuxOrig = LedgerState a
tickedDualLedgerStateAuxOrig
        , tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateBridge  = Validated (GenTx (DualBlock m a))
-> BridgeLedger m a -> BridgeLedger m a
forall m a.
Bridge m a =>
Validated (GenTx (DualBlock m a))
-> BridgeLedger m a -> BridgeLedger m a
updateBridgeWithTx
                                           Validated (GenTx (DualBlock m a))
tx
                                           BridgeLedger m a
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

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)
-> 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)
Ticked (LedgerState a)
LedgerState a
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
tickedDualLedgerStateAux :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState a)
tickedDualLedgerStateBridge :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a. Ticked (LedgerState (DualBlock m a)) -> LedgerState a
tickedDualLedgerStateMain :: Ticked (LedgerState m)
tickedDualLedgerStateAux :: Ticked (LedgerState a)
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a
..} 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)
-> GenTx m
-> Except (ApplyTxErr m) (TxMeasure m)
forall blk.
TxLimits blk =>
LedgerConfig blk
-> TickedLedgerState blk
-> GenTx blk
-> Except (ApplyTxErr blk) (TxMeasure blk)
txMeasure LedgerConfig m
dualLedgerConfigMain Ticked (LedgerState m)
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 :: LedgerConfig (DualBlock m a)
-> TickedLedgerState (DualBlock m a) -> 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)
Ticked (LedgerState a)
LedgerState a
BridgeLedger m a
tickedDualLedgerStateMain :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState m)
tickedDualLedgerStateAux :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> Ticked (LedgerState a)
tickedDualLedgerStateBridge :: forall m a.
Ticked (LedgerState (DualBlock m a)) -> BridgeLedger m a
tickedDualLedgerStateAuxOrig :: forall m a. Ticked (LedgerState (DualBlock m a)) -> LedgerState a
tickedDualLedgerStateMain :: Ticked (LedgerState m)
tickedDualLedgerStateAux :: Ticked (LedgerState a)
tickedDualLedgerStateBridge :: BridgeLedger m a
tickedDualLedgerStateAuxOrig :: LedgerState a
..} =
      LedgerConfig m -> Ticked (LedgerState m) -> TxMeasure m
forall blk.
TxLimits blk =>
LedgerConfig blk -> TickedLedgerState blk -> TxMeasure blk
blockCapacityTxMeasure LedgerConfig m
dualLedgerConfigMain Ticked (LedgerState m)
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 (f :: * -> *) a b.
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 (f :: * -> *) (f' :: * -> *) (g :: * -> *).
(forall a. 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 (f :: * -> *) (f' :: * -> *) (g :: * -> *).
(forall a. 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 :: TopLevelConfig (DualBlock m a)
-> LedgerState (DualBlock m a)
-> LedgerState (DualBlock m a)
-> [LedgerEvent (DualBlock m a)]
inspectLedger TopLevelConfig (DualBlock m a)
cfg LedgerState (DualBlock m a)
before LedgerState (DualBlock m a)
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 -> LedgerState m -> [LedgerEvent m]
forall blk.
InspectLedger blk =>
TopLevelConfig blk
-> LedgerState blk -> LedgerState blk -> [LedgerEvent blk]
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) -> LedgerState m
forall m a. LedgerState (DualBlock m a) -> LedgerState m
dualLedgerStateMain    LedgerState (DualBlock m a)
before)
        (LedgerState (DualBlock m a) -> LedgerState m
forall m a. LedgerState (DualBlock m a) -> LedgerState m
dualLedgerStateMain    LedgerState (DualBlock m a)
after)


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

instance LedgerSupportsPeerSelection m
      => LedgerSupportsPeerSelection (DualBlock m a) where
  getPeers :: LedgerState (DualBlock m a)
-> [(PoolStake, NonEmpty StakePoolRelay)]
getPeers = LedgerState m -> [(PoolStake, NonEmpty StakePoolRelay)]
forall blk.
LedgerSupportsPeerSelection blk =>
LedgerState blk -> [(PoolStake, NonEmpty StakePoolRelay)]
getPeers (LedgerState m -> [(PoolStake, NonEmpty StakePoolRelay)])
-> (LedgerState (DualBlock m a) -> LedgerState m)
-> LedgerState (DualBlock m a)
-> [(PoolStake, NonEmpty StakePoolRelay)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (DualBlock m a) -> LedgerState m
forall m a. LedgerState (DualBlock m a) -> LedgerState m
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
                => LedgerConfig blk
                -> Maybe blk
                -> TickedLedgerState blk
                -> LedgerState blk
                -> Except (LedgerError blk) (LedgerState blk)
applyMaybeBlock :: forall blk.
UpdateLedger blk =>
LedgerConfig blk
-> Maybe blk
-> TickedLedgerState blk
-> LedgerState blk
-> Except (LedgerError blk) (LedgerState blk)
applyMaybeBlock LedgerConfig blk
_   Maybe blk
Nothing      TickedLedgerState blk
_   LedgerState blk
st = LedgerState blk
-> ExceptT (LedgerErr (LedgerState blk)) Identity (LedgerState blk)
forall a. a -> ExceptT (LedgerErr (LedgerState blk)) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return LedgerState blk
st
applyMaybeBlock LedgerConfig blk
cfg (Just blk
block) TickedLedgerState blk
tst LedgerState blk
_  = LedgerConfig blk
-> blk
-> TickedLedgerState blk
-> ExceptT (LedgerErr (LedgerState blk)) Identity (LedgerState blk)
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> Except (LedgerErr l) l
applyLedgerBlock LedgerConfig blk
cfg blk
block TickedLedgerState blk
tst

-- | Lift 'reapplyLedgerBlock' to @Maybe blk@
--
-- See also 'applyMaybeBlock'
reapplyMaybeBlock :: UpdateLedger blk
                  => LedgerConfig blk
                  -> Maybe blk
                  -> TickedLedgerState blk
                  -> LedgerState blk
                  -> LedgerState blk
reapplyMaybeBlock :: forall blk.
UpdateLedger blk =>
LedgerConfig blk
-> Maybe blk
-> TickedLedgerState blk
-> LedgerState blk
-> LedgerState blk
reapplyMaybeBlock LedgerConfig blk
_   Maybe blk
Nothing      TickedLedgerState blk
_   LedgerState blk
st = LedgerState blk
st
reapplyMaybeBlock LedgerConfig blk
cfg (Just blk
block) TickedLedgerState blk
tst LedgerState blk
_  = LedgerConfig blk -> blk -> TickedLedgerState blk -> LedgerState blk
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> l
reapplyLedgerBlock LedgerConfig blk
cfg blk
block TickedLedgerState blk
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.
-------------------------------------------------------------------------------}

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))
                      => (LedgerState m -> Encoding)
                      -> LedgerState (DualBlock m a) -> Encoding
encodeDualLedgerState :: forall m a.
(Bridge m a, Serialise (LedgerState a)) =>
(LedgerState m -> Encoding)
-> LedgerState (DualBlock m a) -> Encoding
encodeDualLedgerState LedgerState m -> Encoding
encodeMain DualLedgerState{LedgerState m
LedgerState a
BridgeLedger m a
dualLedgerStateMain :: forall m a. LedgerState (DualBlock m a) -> LedgerState m
dualLedgerStateAux :: forall m a. LedgerState (DualBlock m a) -> LedgerState a
dualLedgerStateBridge :: forall m a. LedgerState (DualBlock m a) -> BridgeLedger m a
dualLedgerStateMain :: LedgerState m
dualLedgerStateAux :: LedgerState a
dualLedgerStateBridge :: BridgeLedger m a
..} = [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [
      Word -> Encoding
encodeListLen Word
3
    , LedgerState m -> Encoding
encodeMain LedgerState m
dualLedgerStateMain
    , LedgerState a -> Encoding
forall a. Serialise a => a -> Encoding
encode     LedgerState a
dualLedgerStateAux
    , BridgeLedger m a -> Encoding
forall a. Serialise a => a -> Encoding
encode     BridgeLedger m a
dualLedgerStateBridge
    ]

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