{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.ByronSpec.Ledger.Mempool
  ( -- * Type family instances
    GenTx (..)
  , Validated (..)
  ) where

import Codec.Serialise
import GHC.Generics (Generic)
import NoThunks.Class (AllowThunk (..), NoThunks)
import Ouroboros.Consensus.ByronSpec.Ledger.Block
import Ouroboros.Consensus.ByronSpec.Ledger.GenTx
  ( ByronSpecGenTx (..)
  , ByronSpecGenTxErr (..)
  )
import qualified Ouroboros.Consensus.ByronSpec.Ledger.GenTx as GenTx
import Ouroboros.Consensus.ByronSpec.Ledger.Ledger
import Ouroboros.Consensus.ByronSpec.Ledger.Orphans ()
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Ledger.Tables.Utils

newtype instance GenTx ByronSpecBlock = ByronSpecGenTx
  { GenTx ByronSpecBlock -> ByronSpecGenTx
unByronSpecGenTx :: ByronSpecGenTx
  }
  deriving stock (Int -> GenTx ByronSpecBlock -> ShowS
[GenTx ByronSpecBlock] -> ShowS
GenTx ByronSpecBlock -> String
(Int -> GenTx ByronSpecBlock -> ShowS)
-> (GenTx ByronSpecBlock -> String)
-> ([GenTx ByronSpecBlock] -> ShowS)
-> Show (GenTx ByronSpecBlock)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenTx ByronSpecBlock -> ShowS
showsPrec :: Int -> GenTx ByronSpecBlock -> ShowS
$cshow :: GenTx ByronSpecBlock -> String
show :: GenTx ByronSpecBlock -> String
$cshowList :: [GenTx ByronSpecBlock] -> ShowS
showList :: [GenTx ByronSpecBlock] -> ShowS
Show, (forall x. GenTx ByronSpecBlock -> Rep (GenTx ByronSpecBlock) x)
-> (forall x. Rep (GenTx ByronSpecBlock) x -> GenTx ByronSpecBlock)
-> Generic (GenTx ByronSpecBlock)
forall x. Rep (GenTx ByronSpecBlock) x -> GenTx ByronSpecBlock
forall x. GenTx ByronSpecBlock -> Rep (GenTx ByronSpecBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GenTx ByronSpecBlock -> Rep (GenTx ByronSpecBlock) x
from :: forall x. GenTx ByronSpecBlock -> Rep (GenTx ByronSpecBlock) x
$cto :: forall x. Rep (GenTx ByronSpecBlock) x -> GenTx ByronSpecBlock
to :: forall x. Rep (GenTx ByronSpecBlock) x -> GenTx ByronSpecBlock
Generic)
  deriving anyclass [GenTx ByronSpecBlock] -> Encoding
GenTx ByronSpecBlock -> Encoding
(GenTx ByronSpecBlock -> Encoding)
-> (forall s. Decoder s (GenTx ByronSpecBlock))
-> ([GenTx ByronSpecBlock] -> Encoding)
-> (forall s. Decoder s [GenTx ByronSpecBlock])
-> Serialise (GenTx ByronSpecBlock)
forall s. Decoder s [GenTx ByronSpecBlock]
forall s. Decoder s (GenTx ByronSpecBlock)
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: GenTx ByronSpecBlock -> Encoding
encode :: GenTx ByronSpecBlock -> Encoding
$cdecode :: forall s. Decoder s (GenTx ByronSpecBlock)
decode :: forall s. Decoder s (GenTx ByronSpecBlock)
$cencodeList :: [GenTx ByronSpecBlock] -> Encoding
encodeList :: [GenTx ByronSpecBlock] -> Encoding
$cdecodeList :: forall s. Decoder s [GenTx ByronSpecBlock]
decodeList :: forall s. Decoder s [GenTx ByronSpecBlock]
Serialise
  deriving Context -> GenTx ByronSpecBlock -> IO (Maybe ThunkInfo)
Proxy (GenTx ByronSpecBlock) -> String
(Context -> GenTx ByronSpecBlock -> IO (Maybe ThunkInfo))
-> (Context -> GenTx ByronSpecBlock -> IO (Maybe ThunkInfo))
-> (Proxy (GenTx ByronSpecBlock) -> String)
-> NoThunks (GenTx ByronSpecBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> GenTx ByronSpecBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> GenTx ByronSpecBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> GenTx ByronSpecBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> GenTx ByronSpecBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (GenTx ByronSpecBlock) -> String
showTypeOf :: Proxy (GenTx ByronSpecBlock) -> String
NoThunks via AllowThunk (GenTx ByronSpecBlock)

newtype instance Validated (GenTx ByronSpecBlock) = ValidatedByronSpecGenTx
  { Validated (GenTx ByronSpecBlock) -> GenTx ByronSpecBlock
forgetValidatedByronSpecGenTx :: GenTx ByronSpecBlock
  }
  deriving stock (Int -> Validated (GenTx ByronSpecBlock) -> ShowS
[Validated (GenTx ByronSpecBlock)] -> ShowS
Validated (GenTx ByronSpecBlock) -> String
(Int -> Validated (GenTx ByronSpecBlock) -> ShowS)
-> (Validated (GenTx ByronSpecBlock) -> String)
-> ([Validated (GenTx ByronSpecBlock)] -> ShowS)
-> Show (Validated (GenTx ByronSpecBlock))
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Validated (GenTx ByronSpecBlock) -> ShowS
showsPrec :: Int -> Validated (GenTx ByronSpecBlock) -> ShowS
$cshow :: Validated (GenTx ByronSpecBlock) -> String
show :: Validated (GenTx ByronSpecBlock) -> String
$cshowList :: [Validated (GenTx ByronSpecBlock)] -> ShowS
showList :: [Validated (GenTx ByronSpecBlock)] -> ShowS
Show, (forall x.
 Validated (GenTx ByronSpecBlock)
 -> Rep (Validated (GenTx ByronSpecBlock)) x)
-> (forall x.
    Rep (Validated (GenTx ByronSpecBlock)) x
    -> Validated (GenTx ByronSpecBlock))
-> Generic (Validated (GenTx ByronSpecBlock))
forall x.
Rep (Validated (GenTx ByronSpecBlock)) x
-> Validated (GenTx ByronSpecBlock)
forall x.
Validated (GenTx ByronSpecBlock)
-> Rep (Validated (GenTx ByronSpecBlock)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
Validated (GenTx ByronSpecBlock)
-> Rep (Validated (GenTx ByronSpecBlock)) x
from :: forall x.
Validated (GenTx ByronSpecBlock)
-> Rep (Validated (GenTx ByronSpecBlock)) x
$cto :: forall x.
Rep (Validated (GenTx ByronSpecBlock)) x
-> Validated (GenTx ByronSpecBlock)
to :: forall x.
Rep (Validated (GenTx ByronSpecBlock)) x
-> Validated (GenTx ByronSpecBlock)
Generic)
  deriving anyclass Context -> Validated (GenTx ByronSpecBlock) -> IO (Maybe ThunkInfo)
Proxy (Validated (GenTx ByronSpecBlock)) -> String
(Context
 -> Validated (GenTx ByronSpecBlock) -> IO (Maybe ThunkInfo))
-> (Context
    -> Validated (GenTx ByronSpecBlock) -> IO (Maybe ThunkInfo))
-> (Proxy (Validated (GenTx ByronSpecBlock)) -> String)
-> NoThunks (Validated (GenTx ByronSpecBlock))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Validated (GenTx ByronSpecBlock) -> IO (Maybe ThunkInfo)
noThunks :: Context -> Validated (GenTx ByronSpecBlock) -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Validated (GenTx ByronSpecBlock) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Validated (GenTx ByronSpecBlock) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (Validated (GenTx ByronSpecBlock)) -> String
showTypeOf :: Proxy (Validated (GenTx ByronSpecBlock)) -> String
NoThunks

type instance ApplyTxErr ByronSpecBlock = ByronSpecGenTxErr

instance LedgerSupportsMempool ByronSpecBlock where
  applyTx :: LedgerConfig ByronSpecBlock
-> WhetherToIntervene
-> SlotNo
-> GenTx ByronSpecBlock
-> TickedLedgerState ByronSpecBlock ValuesMK
-> Except
     (ApplyTxErr ByronSpecBlock)
     (TickedLedgerState ByronSpecBlock DiffMK,
      Validated (GenTx ByronSpecBlock))
applyTx LedgerConfig ByronSpecBlock
cfg WhetherToIntervene
_wti SlotNo
_slot GenTx ByronSpecBlock
tx (TickedByronSpecLedgerState Maybe SlotNo
tip State CHAIN
st) =
    (State CHAIN
 -> (TickedLedgerState ByronSpecBlock DiffMK,
     Validated (GenTx ByronSpecBlock)))
-> ExceptT ByronSpecGenTxErr Identity (State CHAIN)
-> ExceptT
     ByronSpecGenTxErr
     Identity
     (TickedLedgerState ByronSpecBlock DiffMK,
      Validated (GenTx ByronSpecBlock))
forall a b.
(a -> b)
-> ExceptT ByronSpecGenTxErr Identity a
-> ExceptT ByronSpecGenTxErr Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      ( \State CHAIN
st' ->
          ( Maybe SlotNo
-> State CHAIN -> TickedLedgerState ByronSpecBlock DiffMK
forall (mk :: MapKind).
Maybe SlotNo
-> State CHAIN -> Ticked (LedgerState ByronSpecBlock) mk
TickedByronSpecLedgerState Maybe SlotNo
tip State CHAIN
st'
          , GenTx ByronSpecBlock -> Validated (GenTx ByronSpecBlock)
ValidatedByronSpecGenTx GenTx ByronSpecBlock
tx
          )
      )
      (ExceptT ByronSpecGenTxErr Identity (State CHAIN)
 -> ExceptT
      ByronSpecGenTxErr
      Identity
      (TickedLedgerState ByronSpecBlock DiffMK,
       Validated (GenTx ByronSpecBlock)))
-> ExceptT ByronSpecGenTxErr Identity (State CHAIN)
-> ExceptT
     ByronSpecGenTxErr
     Identity
     (TickedLedgerState ByronSpecBlock DiffMK,
      Validated (GenTx ByronSpecBlock))
forall a b. (a -> b) -> a -> b
$ ByronSpecGenesis
-> ByronSpecGenTx
-> State CHAIN
-> ExceptT ByronSpecGenTxErr Identity (State CHAIN)
GenTx.apply LedgerConfig ByronSpecBlock
ByronSpecGenesis
cfg (GenTx ByronSpecBlock -> ByronSpecGenTx
unByronSpecGenTx GenTx ByronSpecBlock
tx) State CHAIN
st

  -- Byron spec doesn't have multiple validation modes
  reapplyTx :: HasCallStack =>
ComputeDiffs
-> LedgerConfig ByronSpecBlock
-> SlotNo
-> Validated (GenTx ByronSpecBlock)
-> TickedLedgerState ByronSpecBlock ValuesMK
-> Except
     (ApplyTxErr ByronSpecBlock)
     (TickedLedgerState ByronSpecBlock TrackingMK)
reapplyTx ComputeDiffs
_ LedgerConfig ByronSpecBlock
cfg SlotNo
slot Validated (GenTx ByronSpecBlock)
vtx TickedLedgerState ByronSpecBlock ValuesMK
st =
    TickedLedgerState ByronSpecBlock ValuesMK
-> TickedLedgerState ByronSpecBlock TrackingMK
forall (l :: MapKind -> *).
HasLedgerTables l =>
l ValuesMK -> l TrackingMK
attachEmptyDiffs (TickedLedgerState ByronSpecBlock ValuesMK
 -> TickedLedgerState ByronSpecBlock TrackingMK)
-> ((TickedLedgerState ByronSpecBlock DiffMK,
     Validated (GenTx ByronSpecBlock))
    -> TickedLedgerState ByronSpecBlock ValuesMK)
-> (TickedLedgerState ByronSpecBlock DiffMK,
    Validated (GenTx ByronSpecBlock))
-> TickedLedgerState ByronSpecBlock TrackingMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickedLedgerState ByronSpecBlock ValuesMK
-> TickedLedgerState ByronSpecBlock DiffMK
-> TickedLedgerState ByronSpecBlock ValuesMK
forall (l :: MapKind -> *) (l' :: MapKind -> *).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l ValuesMK -> l' DiffMK -> l' ValuesMK
applyDiffs TickedLedgerState ByronSpecBlock ValuesMK
st (TickedLedgerState ByronSpecBlock DiffMK
 -> TickedLedgerState ByronSpecBlock ValuesMK)
-> ((TickedLedgerState ByronSpecBlock DiffMK,
     Validated (GenTx ByronSpecBlock))
    -> TickedLedgerState ByronSpecBlock DiffMK)
-> (TickedLedgerState ByronSpecBlock DiffMK,
    Validated (GenTx ByronSpecBlock))
-> TickedLedgerState ByronSpecBlock ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickedLedgerState ByronSpecBlock DiffMK,
 Validated (GenTx ByronSpecBlock))
-> TickedLedgerState ByronSpecBlock DiffMK
forall a b. (a, b) -> a
fst
      ((TickedLedgerState ByronSpecBlock DiffMK,
  Validated (GenTx ByronSpecBlock))
 -> TickedLedgerState ByronSpecBlock TrackingMK)
-> ExceptT
     ByronSpecGenTxErr
     Identity
     (TickedLedgerState ByronSpecBlock DiffMK,
      Validated (GenTx ByronSpecBlock))
-> ExceptT
     ByronSpecGenTxErr
     Identity
     (TickedLedgerState ByronSpecBlock TrackingMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerConfig ByronSpecBlock
-> WhetherToIntervene
-> SlotNo
-> GenTx ByronSpecBlock
-> TickedLedgerState ByronSpecBlock ValuesMK
-> Except
     (ApplyTxErr ByronSpecBlock)
     (TickedLedgerState ByronSpecBlock DiffMK,
      Validated (GenTx ByronSpecBlock))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk ValuesMK
-> Except
     (ApplyTxErr blk)
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
applyTx LedgerConfig ByronSpecBlock
cfg WhetherToIntervene
DoNotIntervene SlotNo
slot (Validated (GenTx ByronSpecBlock) -> GenTx ByronSpecBlock
forgetValidatedByronSpecGenTx Validated (GenTx ByronSpecBlock)
vtx) TickedLedgerState ByronSpecBlock ValuesMK
st

  txForgetValidated :: Validated (GenTx ByronSpecBlock) -> GenTx ByronSpecBlock
txForgetValidated = Validated (GenTx ByronSpecBlock) -> GenTx ByronSpecBlock
forgetValidatedByronSpecGenTx

  getTransactionKeySets :: GenTx ByronSpecBlock
-> LedgerTables (LedgerState ByronSpecBlock) KeysMK
getTransactionKeySets GenTx ByronSpecBlock
_ = LedgerTables (LedgerState ByronSpecBlock) KeysMK
forall (mk :: MapKind) (l :: MapKind -> *).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables

instance TxLimits ByronSpecBlock where
  type TxMeasure ByronSpecBlock = IgnoringOverflow ByteSize32

  -- Dummy values, as these are not used in practice.
  blockCapacityTxMeasure :: forall (mk :: MapKind).
LedgerConfig ByronSpecBlock
-> TickedLedgerState ByronSpecBlock mk -> TxMeasure ByronSpecBlock
blockCapacityTxMeasure LedgerConfig ByronSpecBlock
_cfg TickedLedgerState ByronSpecBlock mk
_st = ByteSize32 -> IgnoringOverflow ByteSize32
forall a. a -> IgnoringOverflow a
IgnoringOverflow (ByteSize32 -> IgnoringOverflow ByteSize32)
-> ByteSize32 -> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteSize32
ByteSize32 Word32
1

  txMeasure :: LedgerConfig ByronSpecBlock
-> TickedLedgerState ByronSpecBlock ValuesMK
-> GenTx ByronSpecBlock
-> Except (ApplyTxErr ByronSpecBlock) (TxMeasure ByronSpecBlock)
txMeasure LedgerConfig ByronSpecBlock
_cfg TickedLedgerState ByronSpecBlock ValuesMK
_st GenTx ByronSpecBlock
_tx = TxMeasure ByronSpecBlock
-> Except (ApplyTxErr ByronSpecBlock) (TxMeasure ByronSpecBlock)
forall a. a -> ExceptT (ApplyTxErr ByronSpecBlock) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxMeasure ByronSpecBlock
 -> Except (ApplyTxErr ByronSpecBlock) (TxMeasure ByronSpecBlock))
-> TxMeasure ByronSpecBlock
-> Except (ApplyTxErr ByronSpecBlock) (TxMeasure ByronSpecBlock)
forall a b. (a -> b) -> a -> b
$ ByteSize32 -> IgnoringOverflow ByteSize32
forall a. a -> IgnoringOverflow a
IgnoringOverflow (ByteSize32 -> IgnoringOverflow ByteSize32)
-> ByteSize32 -> IgnoringOverflow ByteSize32
forall a b. (a -> b) -> a -> b
$ Word32 -> ByteSize32
ByteSize32 Word32
0