{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Ouroboros.Consensus.Ledger.Tables
(
module Ouroboros.Consensus.Ledger.Tables.Basics
, module Ouroboros.Consensus.Ledger.Tables.MapKind
, module Ouroboros.Consensus.Ledger.Tables.Combinators
, HasLedgerTables (..)
, CanStowLedgerTables (..)
, CanUpgradeLedgerTables (..)
, SerializeTablesWithHint (..)
, defaultDecodeTablesWithHint
, defaultEncodeTablesWithHint
, valuesMKDecoder
, valuesMKEncoder
, LedgerTablesAreTrivial (..)
, trivialProjectLedgerTables
, trivialWithLedgerTables
, trivialStowLedgerTables
, trivialUnstowLedgerTables
, trivialEncodeTablesWithHint
, trivialDecodeTablesWithHint
, 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.Proxy
import Data.Void
import NoThunks.Class
import Ouroboros.Consensus.Ledger.Tables.Basics
import Ouroboros.Consensus.Ledger.Tables.Combinators
import Ouroboros.Consensus.Ledger.Tables.MapKind
import Ouroboros.Consensus.Util.RedundantConstraints
type HasLedgerTables :: StateKind -> Type -> Constraint
class (NoThunks (TxIn blk), NoThunks (TxOut blk), LedgerTableConstraints blk) => HasLedgerTables l blk where
projectLedgerTables ::
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l blk mk ->
LedgerTables blk mk
withLedgerTables ::
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l blk any ->
LedgerTables blk mk ->
l blk mk
type CanStowLedgerTables :: LedgerStateKind -> Constraint
class CanStowLedgerTables l where
stowLedgerTables :: l ValuesMK -> l EmptyMK
unstowLedgerTables :: l EmptyMK -> l ValuesMK
type CanUpgradeLedgerTables :: StateKind -> Type -> Constraint
class CanUpgradeLedgerTables l blk where
upgradeTables ::
l blk mk1 ->
l blk mk2 ->
LedgerTables blk ValuesMK ->
LedgerTables blk ValuesMK
valuesMKEncoder ::
SerializeTablesWithHint l blk =>
l blk EmptyMK ->
LedgerTables blk ValuesMK ->
CBOR.Encoding
valuesMKEncoder :: forall (l :: StateKind) blk.
SerializeTablesWithHint l blk =>
l blk EmptyMK -> LedgerTables blk ValuesMK -> Encoding
valuesMKEncoder l blk EmptyMK
st LedgerTables blk ValuesMK
tbs =
Word -> Encoding
CBOR.encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> l blk EmptyMK -> LedgerTables blk ValuesMK -> Encoding
forall (l :: StateKind) blk.
SerializeTablesWithHint l blk =>
l blk EmptyMK -> LedgerTables blk ValuesMK -> Encoding
encodeTablesWithHint l blk EmptyMK
st LedgerTables blk ValuesMK
tbs
valuesMKDecoder ::
forall l blk s.
SerializeTablesWithHint l blk =>
l blk EmptyMK ->
CBOR.Decoder s (LedgerTables blk ValuesMK)
valuesMKDecoder :: forall (l :: StateKind) blk s.
SerializeTablesWithHint l blk =>
l blk EmptyMK -> Decoder s (LedgerTables blk ValuesMK)
valuesMKDecoder l blk EmptyMK
st =
Int -> Decoder s ()
forall s. Int -> Decoder s ()
CBOR.decodeListLenOf Int
1 Decoder s ()
-> Decoder s (LedgerTables blk ValuesMK)
-> Decoder s (LedgerTables blk 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
>> l blk EmptyMK -> Decoder s (LedgerTables blk ValuesMK)
forall s. l blk EmptyMK -> Decoder s (LedgerTables blk ValuesMK)
forall (l :: StateKind) blk s.
SerializeTablesWithHint l blk =>
l blk EmptyMK -> Decoder s (LedgerTables blk ValuesMK)
decodeTablesWithHint l blk EmptyMK
st
class SerializeTablesWithHint l blk where
encodeTablesWithHint ::
l blk EmptyMK ->
LedgerTables blk ValuesMK ->
CBOR.Encoding
decodeTablesWithHint ::
l blk EmptyMK ->
CBOR.Decoder s (LedgerTables blk ValuesMK)
defaultEncodeTablesWithHint ::
(MemPack (TxIn blk), MemPack (TxOut blk)) =>
l blk EmptyMK ->
LedgerTables blk ValuesMK ->
CBOR.Encoding
defaultEncodeTablesWithHint :: forall blk (l :: StateKind).
(MemPack (TxIn blk), MemPack (TxOut blk)) =>
l blk EmptyMK -> LedgerTables blk ValuesMK -> Encoding
defaultEncodeTablesWithHint l blk EmptyMK
_ (LedgerTables (ValuesMK Map (TxIn blk) (TxOut blk)
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 blk) (TxOut blk) -> Int
forall k a. Map k a -> Int
Map.size Map (TxIn blk) (TxOut blk)
tbs)
, (TxIn blk -> TxOut blk -> Encoding)
-> Map (TxIn blk) (TxOut blk) -> Encoding
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey
( \TxIn blk
k TxOut blk
v ->
[Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
[ ByteString -> Encoding
CBOR.encodeBytes (TxIn blk -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString TxIn blk
k)
, ByteString -> Encoding
CBOR.encodeBytes (TxOut blk -> ByteString
forall a. (MemPack a, HasCallStack) => a -> ByteString
packByteString TxOut blk
v)
]
)
Map (TxIn blk) (TxOut blk)
tbs
]
defaultDecodeTablesWithHint ::
(Ord (TxIn blk), MemPack (TxIn blk), MemPack (TxOut blk)) =>
l blk EmptyMK ->
CBOR.Decoder s (LedgerTables blk ValuesMK)
defaultDecodeTablesWithHint :: forall blk (l :: StateKind) s.
(Ord (TxIn blk), MemPack (TxIn blk), MemPack (TxOut blk)) =>
l blk EmptyMK -> Decoder s (LedgerTables blk ValuesMK)
defaultDecodeTablesWithHint l blk EmptyMK
_ = 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 :: StateKind -> Type -> Constraint
class (TxIn blk ~ Void, TxOut blk ~ Void) => LedgerTablesAreTrivial l blk where
convertMapKind :: l blk mk -> l blk mk'
trivialLedgerTables ::
(ZeroableMK mk, LedgerTablesAreTrivial l blk) =>
Proxy l ->
LedgerTables blk mk
trivialLedgerTables :: forall (mk :: MapKind) (l :: StateKind) blk.
(ZeroableMK mk, LedgerTablesAreTrivial l blk) =>
Proxy l -> LedgerTables blk mk
trivialLedgerTables Proxy l
_ = mk (TxIn blk) (TxOut blk) -> LedgerTables blk mk
forall blk (mk :: MapKind).
mk (TxIn blk) (TxOut blk) -> LedgerTables blk mk
LedgerTables mk Void Void
mk (TxIn blk) (TxOut blk)
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
trivialProjectLedgerTables ::
forall l blk mk.
(LedgerTablesAreTrivial l blk, ZeroableMK mk) =>
l blk mk ->
LedgerTables blk mk
trivialProjectLedgerTables :: forall (l :: StateKind) blk (mk :: MapKind).
(LedgerTablesAreTrivial l blk, ZeroableMK mk) =>
l blk mk -> LedgerTables blk mk
trivialProjectLedgerTables l blk mk
_ = Proxy l -> LedgerTables blk mk
forall (mk :: MapKind) (l :: StateKind) blk.
(ZeroableMK mk, LedgerTablesAreTrivial l blk) =>
Proxy l -> LedgerTables blk mk
trivialLedgerTables (forall {k} (t :: k). Proxy t
forall (t :: StateKind). Proxy t
Proxy @l)
trivialWithLedgerTables ::
LedgerTablesAreTrivial l blk =>
l blk any ->
LedgerTables blk mk ->
l blk mk
trivialWithLedgerTables :: forall (l :: StateKind) blk (any :: MapKind) (mk :: MapKind).
LedgerTablesAreTrivial l blk =>
l blk any -> LedgerTables blk mk -> l blk mk
trivialWithLedgerTables l blk any
st LedgerTables blk mk
_ = l blk any -> l blk mk
forall (mk :: MapKind) (mk' :: MapKind). l blk mk -> l blk mk'
forall (l :: StateKind) blk (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l blk =>
l blk mk -> l blk mk'
convertMapKind l blk any
st
trivialStowLedgerTables :: LedgerTablesAreTrivial l blk => l blk ValuesMK -> l blk EmptyMK
trivialStowLedgerTables :: forall (l :: StateKind) blk.
LedgerTablesAreTrivial l blk =>
l blk ValuesMK -> l blk EmptyMK
trivialStowLedgerTables = l blk ValuesMK -> l blk EmptyMK
forall (mk :: MapKind) (mk' :: MapKind). l blk mk -> l blk mk'
forall (l :: StateKind) blk (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l blk =>
l blk mk -> l blk mk'
convertMapKind
trivialUnstowLedgerTables :: LedgerTablesAreTrivial l blk => l blk EmptyMK -> l blk ValuesMK
trivialUnstowLedgerTables :: forall (l :: StateKind) blk.
LedgerTablesAreTrivial l blk =>
l blk EmptyMK -> l blk ValuesMK
trivialUnstowLedgerTables = l blk EmptyMK -> l blk ValuesMK
forall (mk :: MapKind) (mk' :: MapKind). l blk mk -> l blk mk'
forall (l :: StateKind) blk (mk :: MapKind) (mk' :: MapKind).
LedgerTablesAreTrivial l blk =>
l blk mk -> l blk mk'
convertMapKind
trivialDecodeTablesWithHint ::
forall l blk s.
LedgerTablesAreTrivial l blk =>
l blk EmptyMK ->
CBOR.Decoder s (LedgerTables blk ValuesMK)
trivialDecodeTablesWithHint :: forall (l :: StateKind) blk s.
LedgerTablesAreTrivial l blk =>
l blk EmptyMK -> Decoder s (LedgerTables blk ValuesMK)
trivialDecodeTablesWithHint l blk EmptyMK
_ = do
_ <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
pure $ trivialLedgerTables (Proxy @l)
trivialEncodeTablesWithHint ::
forall l blk.
LedgerTablesAreTrivial l blk =>
l blk EmptyMK ->
LedgerTables blk ValuesMK ->
CBOR.Encoding
trivialEncodeTablesWithHint :: forall (l :: StateKind) blk.
LedgerTablesAreTrivial l blk =>
l blk EmptyMK -> LedgerTables blk ValuesMK -> Encoding
trivialEncodeTablesWithHint l blk EmptyMK
_ LedgerTables blk ValuesMK
_ = Word -> Encoding
CBOR.encodeMapLen Word
0
where
()
_ = Proxy (LedgerTablesAreTrivial l blk) -> ()
forall (c :: Constraint) (proxy :: Constraint -> *).
c =>
proxy c -> ()
keepRedundantConstraint (forall {k} (t :: k). Proxy t
forall (t :: Constraint). Proxy t
Proxy @(LedgerTablesAreTrivial l blk))