{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Ouroboros.Consensus.Ledger.Tables (
module Ouroboros.Consensus.Ledger.Tables.Basics
, module Ouroboros.Consensus.Ledger.Tables.MapKind
, module Ouroboros.Consensus.Ledger.Tables.Combinators
, CanStowLedgerTables (..)
, HasLedgerTables (..)
, HasTickedLedgerTables
, SerializeTablesHint
, SerializeTablesWithHint (..)
, defaultDecodeTablesWithHint
, defaultEncodeTablesWithHint
, valuesMKDecoder
, valuesMKEncoder
, LedgerTablesAreTrivial
, TrivialLedgerTables (..)
, convertMapKind
, trivialLedgerTables
) where
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import Data.Kind (Constraint, Type)
import qualified Data.Map.Strict as Map
import Data.MemPack
import Data.Void (Void)
import NoThunks.Class (NoThunks (..))
import Ouroboros.Consensus.Ledger.Tables.Basics
import Ouroboros.Consensus.Ledger.Tables.Combinators
import Ouroboros.Consensus.Ledger.Tables.MapKind
import Ouroboros.Consensus.Ticked
import Ouroboros.Consensus.Util.IndexedMemPack
type HasLedgerTables :: LedgerStateKind -> Constraint
class ( Ord (TxIn l)
, Eq (TxOut l)
, Show (TxIn l)
, Show (TxOut l)
, NoThunks (TxIn l)
, NoThunks (TxOut l)
, MemPack (TxIn l)
, IndexedMemPack (MemPackIdx l EmptyMK) (TxOut l)
) => HasLedgerTables l where
projectLedgerTables ::
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk)
=> l mk
-> LedgerTables l mk
withLedgerTables ::
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk)
=> l any
-> LedgerTables l mk
-> l mk
instance ( Ord (TxIn l)
, Eq (TxOut l)
, Show (TxIn l)
, Show (TxOut l)
, NoThunks (TxIn l)
, NoThunks (TxOut l)
, MemPack (TxIn l)
, IndexedMemPack (MemPackIdx l EmptyMK) (TxOut l)
) => HasLedgerTables (LedgerTables l) where
projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerTables l mk -> LedgerTables (LedgerTables l) mk
projectLedgerTables = LedgerTables l mk -> LedgerTables (LedgerTables l) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
(mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables
withLedgerTables :: forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerTables l any
-> LedgerTables (LedgerTables l) mk -> LedgerTables l mk
withLedgerTables LedgerTables l any
_ = LedgerTables (LedgerTables l) mk -> LedgerTables l mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
(mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables
type HasTickedLedgerTables :: LedgerStateKind -> Constraint
class HasLedgerTables (Ticked l) => HasTickedLedgerTables l where
instance HasLedgerTables (Ticked l) => HasTickedLedgerTables l
type CanStowLedgerTables :: LedgerStateKind -> Constraint
class CanStowLedgerTables l where
stowLedgerTables :: l ValuesMK -> l EmptyMK
unstowLedgerTables :: l EmptyMK -> l ValuesMK
valuesMKEncoder ::
forall l. SerializeTablesWithHint l
=> l EmptyMK
-> LedgerTables l ValuesMK
-> CBOR.Encoding
valuesMKEncoder :: forall (l :: LedgerStateKind).
SerializeTablesWithHint l =>
l EmptyMK -> LedgerTables l ValuesMK -> Encoding
valuesMKEncoder l EmptyMK
st LedgerTables l ValuesMK
tbs =
Word -> Encoding
CBOR.encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SerializeTablesHint (LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK -> Encoding
forall (l :: LedgerStateKind).
SerializeTablesWithHint l =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK -> Encoding
encodeTablesWithHint l EmptyMK
SerializeTablesHint (LedgerTables l ValuesMK)
st LedgerTables l ValuesMK
tbs
valuesMKDecoder ::
forall l s. SerializeTablesWithHint l
=> l EmptyMK
-> CBOR.Decoder s (LedgerTables l ValuesMK)
valuesMKDecoder :: forall (l :: LedgerStateKind) s.
SerializeTablesWithHint l =>
l EmptyMK -> Decoder s (LedgerTables l ValuesMK)
valuesMKDecoder l EmptyMK
st =
Int -> Decoder s ()
forall s. Int -> Decoder s ()
CBOR.decodeListLenOf Int
1 Decoder s ()
-> Decoder s (LedgerTables l ValuesMK)
-> Decoder s (LedgerTables l ValuesMK)
forall a b. Decoder s a -> Decoder s b -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SerializeTablesHint (LedgerTables l ValuesMK)
-> Decoder s (LedgerTables l ValuesMK)
forall s.
SerializeTablesHint (LedgerTables l ValuesMK)
-> Decoder s (LedgerTables l ValuesMK)
forall (l :: LedgerStateKind) s.
SerializeTablesWithHint l =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> Decoder s (LedgerTables l ValuesMK)
decodeTablesWithHint l EmptyMK
SerializeTablesHint (LedgerTables l ValuesMK)
st
class SerializeTablesWithHint l where
encodeTablesWithHint ::
SerializeTablesHint (LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK -> CBOR.Encoding
decodeTablesWithHint ::
SerializeTablesHint (LedgerTables l ValuesMK)
-> CBOR.Decoder s (LedgerTables l ValuesMK)
type family SerializeTablesHint values :: Type
type instance SerializeTablesHint (LedgerTables l ValuesMK) = l EmptyMK
defaultEncodeTablesWithHint ::
(MemPack (TxIn l), MemPack (TxOut l))
=> SerializeTablesHint (LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK -> CBOR.Encoding
defaultEncodeTablesWithHint :: forall (l :: LedgerStateKind).
(MemPack (TxIn l), MemPack (TxOut l)) =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK -> Encoding
defaultEncodeTablesWithHint SerializeTablesHint (LedgerTables l ValuesMK)
_ (LedgerTables (ValuesMK Map (TxIn l) (TxOut l)
tbs)) =
[Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [ Word -> Encoding
CBOR.encodeMapLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ Map (TxIn l) (TxOut l) -> Int
forall k a. Map k a -> Int
Map.size Map (TxIn l) (TxOut l)
tbs)
, (TxIn l -> TxOut l -> Encoding)
-> Map (TxIn l) (TxOut l) -> Encoding
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey (\TxIn l
k TxOut l
v ->
[Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Encoding
CBOR.encodeBytes (TxIn l -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString TxIn l
k)
, ByteString -> Encoding
CBOR.encodeBytes (TxOut l -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString TxOut l
v)
]
) Map (TxIn l) (TxOut l)
tbs
]
defaultDecodeTablesWithHint ::
(Ord (TxIn l), MemPack (TxIn l), MemPack (TxOut l))
=> SerializeTablesHint (LedgerTables l ValuesMK)
-> CBOR.Decoder s (LedgerTables l ValuesMK)
defaultDecodeTablesWithHint :: forall (l :: LedgerStateKind) s.
(Ord (TxIn l), MemPack (TxIn l), MemPack (TxOut l)) =>
SerializeTablesHint (LedgerTables l ValuesMK)
-> Decoder s (LedgerTables l ValuesMK)
defaultDecodeTablesWithHint SerializeTablesHint (LedgerTables l ValuesMK)
_ = do
n <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
LedgerTables . ValuesMK <$> go n Map.empty
where
go :: t -> Map k a -> Decoder s (Map k a)
go t
0 Map k a
m = Map k a -> Decoder s (Map k a)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map k a
m
go t
n !Map k a
m = do
(k, v) <- (,) (k -> a -> (k, a)) -> Decoder s k -> Decoder s (a -> (k, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Decoder s k
forall a b (m :: * -> *).
(MemPack a, Buffer b, MonadFail m) =>
b -> m a
unpackMonadFail (ByteString -> Decoder s k) -> Decoder s ByteString -> Decoder s k
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Decoder s ByteString
forall s. Decoder s ByteString
CBOR.decodeBytes) Decoder s (a -> (k, a)) -> Decoder s a -> Decoder s (k, 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
<*> (ByteString -> Decoder s a
forall a b (m :: * -> *).
(MemPack a, Buffer b, MonadFail m) =>
b -> m a
unpackMonadFail (ByteString -> Decoder s a) -> Decoder s ByteString -> Decoder s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Decoder s ByteString
forall s. Decoder s ByteString
CBOR.decodeBytes)
go (n - 1) (Map.insert k v m)
type LedgerTablesAreTrivial :: LedgerStateKind -> Constraint
class (TxIn l ~ Void, TxOut l ~ Void) => LedgerTablesAreTrivial l where
convertMapKind :: l mk -> l mk'
trivialLedgerTables ::
(ZeroableMK mk, LedgerTablesAreTrivial l)
=> LedgerTables l mk
trivialLedgerTables :: forall (mk :: MapKind) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTablesAreTrivial l) =>
LedgerTables l mk
trivialLedgerTables = mk (TxIn l) (TxOut l) -> LedgerTables l mk
forall (l :: LedgerStateKind) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables mk Void Void
mk (TxIn l) (TxOut l)
forall k v. (Ord k, Eq v) => mk k v
forall (mk :: MapKind) k v. (ZeroableMK mk, Ord k, Eq v) => mk k v
emptyMK
type TrivialLedgerTables :: LedgerStateKind -> MapKind -> Type
newtype TrivialLedgerTables l mk = TrivialLedgerTables { forall (l :: LedgerStateKind) (mk :: MapKind).
TrivialLedgerTables l mk -> l mk
untrivialLedgerTables :: l mk }
type instance TxIn (TrivialLedgerTables l) = TxIn l
type instance TxOut (TrivialLedgerTables l) = TxOut l
instance LedgerTablesAreTrivial l => LedgerTablesAreTrivial (TrivialLedgerTables l) where
convertMapKind :: forall (mk :: MapKind) (mk' :: MapKind).
TrivialLedgerTables l mk -> TrivialLedgerTables l mk'
convertMapKind = l mk' -> TrivialLedgerTables l mk'
forall (l :: LedgerStateKind) (mk :: MapKind).
l mk -> TrivialLedgerTables l mk
TrivialLedgerTables (l mk' -> TrivialLedgerTables l mk')
-> (TrivialLedgerTables l mk -> l mk')
-> TrivialLedgerTables l mk
-> TrivialLedgerTables l mk'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l mk -> l mk'
forall (mk :: MapKind) (mk' :: MapKind). l mk -> l mk'
forall (l :: LedgerStateKind) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind (l mk -> l mk')
-> (TrivialLedgerTables l mk -> l mk)
-> TrivialLedgerTables l mk
-> l mk'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrivialLedgerTables l mk -> l mk
forall (l :: LedgerStateKind) (mk :: MapKind).
TrivialLedgerTables l mk -> l mk
untrivialLedgerTables
instance LedgerTablesAreTrivial l => HasLedgerTables (TrivialLedgerTables l) where
projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
TrivialLedgerTables l mk -> LedgerTables (TrivialLedgerTables l) mk
projectLedgerTables TrivialLedgerTables l mk
_ = LedgerTables (TrivialLedgerTables l) mk
forall (mk :: MapKind) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTablesAreTrivial l) =>
LedgerTables l mk
trivialLedgerTables
withLedgerTables :: forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
TrivialLedgerTables l any
-> LedgerTables (TrivialLedgerTables l) mk
-> TrivialLedgerTables l mk
withLedgerTables TrivialLedgerTables l any
st LedgerTables (TrivialLedgerTables l) mk
_ = TrivialLedgerTables l any -> TrivialLedgerTables l mk
forall (mk :: MapKind) (mk' :: MapKind).
TrivialLedgerTables l mk -> TrivialLedgerTables l mk'
forall (l :: LedgerStateKind) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind TrivialLedgerTables l any
st
instance LedgerTablesAreTrivial l => CanStowLedgerTables (TrivialLedgerTables l) where
stowLedgerTables :: TrivialLedgerTables l ValuesMK -> TrivialLedgerTables l EmptyMK
stowLedgerTables = TrivialLedgerTables l ValuesMK -> TrivialLedgerTables l EmptyMK
forall (mk :: MapKind) (mk' :: MapKind).
TrivialLedgerTables l mk -> TrivialLedgerTables l mk'
forall (l :: LedgerStateKind) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind
unstowLedgerTables :: TrivialLedgerTables l EmptyMK -> TrivialLedgerTables l ValuesMK
unstowLedgerTables = TrivialLedgerTables l EmptyMK -> TrivialLedgerTables l ValuesMK
forall (mk :: MapKind) (mk' :: MapKind).
TrivialLedgerTables l mk -> TrivialLedgerTables l mk'
forall (l :: LedgerStateKind) (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l =>
l mk -> l mk'
convertMapKind
instance IndexedMemPack (TrivialLedgerTables l EmptyMK) Void where
indexedTypeName :: TrivialLedgerTables l EmptyMK -> String
indexedTypeName TrivialLedgerTables l EmptyMK
_ = forall a. MemPack a => String
typeName @Void
indexedPackedByteCount :: TrivialLedgerTables l EmptyMK -> Void -> Int
indexedPackedByteCount TrivialLedgerTables l EmptyMK
_ = Void -> Int
forall a. MemPack a => a -> Int
packedByteCount
indexedPackM :: forall s. TrivialLedgerTables l EmptyMK -> Void -> Pack s ()
indexedPackM TrivialLedgerTables l EmptyMK
_ = Void -> Pack s ()
forall s. Void -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
packM
indexedUnpackM :: forall b.
Buffer b =>
TrivialLedgerTables l EmptyMK -> Unpack b Void
indexedUnpackM TrivialLedgerTables l EmptyMK
_ = Unpack b Void
forall b. Buffer b => Unpack b Void
forall a b. (MemPack a, Buffer b) => Unpack b a
unpackM
instance SerializeTablesWithHint (TrivialLedgerTables l) where
decodeTablesWithHint :: forall s.
SerializeTablesHint (LedgerTables (TrivialLedgerTables l) ValuesMK)
-> Decoder s (LedgerTables (TrivialLedgerTables l) ValuesMK)
decodeTablesWithHint SerializeTablesHint (LedgerTables (TrivialLedgerTables l) ValuesMK)
_ = do
_ <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
pure (LedgerTables $ ValuesMK Map.empty)
encodeTablesWithHint :: SerializeTablesHint (LedgerTables (TrivialLedgerTables l) ValuesMK)
-> LedgerTables (TrivialLedgerTables l) ValuesMK -> Encoding
encodeTablesWithHint SerializeTablesHint (LedgerTables (TrivialLedgerTables l) ValuesMK)
_ LedgerTables (TrivialLedgerTables l) ValuesMK
_ = Word -> Encoding
CBOR.encodeMapLen Word
0