{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -- | Definition is 'IsLedger' -- -- Normally this is imported from "Ouroboros.Consensus.Ledger.Abstract". We -- pull this out to avoid circular module dependencies. module Ouroboros.Consensus.Ledger.Basics ( -- * GetTip GetTip (..) , getTipHash , getTipSlot -- * Ledger Events , LedgerResult (..) , VoidLedgerEvent , castLedgerResult , embedLedgerResult , pureLedgerResult -- * Definition of a ledger independent of a choice of block , IsLedger (..) , LedgerCfg , applyChainTick -- * Link block to its ledger , LedgerConfig , LedgerError , LedgerState , TickedLedgerState ) where import Data.Kind (Type) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ticked import Ouroboros.Consensus.Util ((..:)) {------------------------------------------------------------------------------- Tip -------------------------------------------------------------------------------} class GetTip l where -- | Point of the most recently applied block -- -- Should be 'genesisPoint' when no blocks have been applied yet getTip :: l -> Point l type instance HeaderHash (Ticked l) = HeaderHash l getTipHash :: GetTip l => l -> ChainHash l getTipHash :: l -> ChainHash l getTipHash = Point l -> ChainHash l forall block. Point block -> ChainHash block pointHash (Point l -> ChainHash l) -> (l -> Point l) -> l -> ChainHash l forall b c a. (b -> c) -> (a -> b) -> a -> c . l -> Point l forall l. GetTip l => l -> Point l getTip getTipSlot :: GetTip l => l -> WithOrigin SlotNo getTipSlot :: l -> WithOrigin SlotNo getTipSlot = Point l -> WithOrigin SlotNo forall block. Point block -> WithOrigin SlotNo pointSlot (Point l -> WithOrigin SlotNo) -> (l -> Point l) -> l -> WithOrigin SlotNo forall b c a. (b -> c) -> (a -> b) -> a -> c . l -> Point l forall l. GetTip l => l -> Point l getTip {------------------------------------------------------------------------------- Events directly from the ledger -------------------------------------------------------------------------------} -- | A 'Data.Void.Void' isomorph for explicitly declaring that some ledger has -- no events data VoidLedgerEvent l -- | The result of invoke a ledger function that does validation -- -- Note: we do not instantiate 'Applicative' or 'Monad' for this type because -- those interfaces would typically incur space leaks. We encourage you to -- process the events each time you invoke a ledger function. data LedgerResult l a = LedgerResult { LedgerResult l a -> [AuxLedgerEvent l] lrEvents :: [AuxLedgerEvent l] , LedgerResult l a -> a lrResult :: !a } deriving (LedgerResult l a -> Bool (a -> m) -> LedgerResult l a -> m (a -> b -> b) -> b -> LedgerResult l a -> b (forall m. Monoid m => LedgerResult l m -> m) -> (forall m a. Monoid m => (a -> m) -> LedgerResult l a -> m) -> (forall m a. Monoid m => (a -> m) -> LedgerResult l a -> m) -> (forall a b. (a -> b -> b) -> b -> LedgerResult l a -> b) -> (forall a b. (a -> b -> b) -> b -> LedgerResult l a -> b) -> (forall b a. (b -> a -> b) -> b -> LedgerResult l a -> b) -> (forall b a. (b -> a -> b) -> b -> LedgerResult l a -> b) -> (forall a. (a -> a -> a) -> LedgerResult l a -> a) -> (forall a. (a -> a -> a) -> LedgerResult l a -> a) -> (forall a. LedgerResult l a -> [a]) -> (forall a. LedgerResult l a -> Bool) -> (forall a. LedgerResult l a -> Int) -> (forall a. Eq a => a -> LedgerResult l a -> Bool) -> (forall a. Ord a => LedgerResult l a -> a) -> (forall a. Ord a => LedgerResult l a -> a) -> (forall a. Num a => LedgerResult l a -> a) -> (forall a. Num a => LedgerResult l a -> a) -> Foldable (LedgerResult l) forall a. Eq a => a -> LedgerResult l a -> Bool forall a. Num a => LedgerResult l a -> a forall a. Ord a => LedgerResult l a -> a forall m. Monoid m => LedgerResult l m -> m forall a. LedgerResult l a -> Bool forall a. LedgerResult l a -> Int forall a. LedgerResult l a -> [a] forall a. (a -> a -> a) -> LedgerResult l a -> a forall l a. Eq a => a -> LedgerResult l a -> Bool forall l a. Num a => LedgerResult l a -> a forall l a. Ord a => LedgerResult l a -> a forall m a. Monoid m => (a -> m) -> LedgerResult l a -> m forall l m. Monoid m => LedgerResult l m -> m forall l a. LedgerResult l a -> Bool forall l a. LedgerResult l a -> Int forall l a. LedgerResult l a -> [a] forall b a. (b -> a -> b) -> b -> LedgerResult l a -> b forall a b. (a -> b -> b) -> b -> LedgerResult l a -> b forall l a. (a -> a -> a) -> LedgerResult l a -> a forall l m a. Monoid m => (a -> m) -> LedgerResult l a -> m forall l b a. (b -> a -> b) -> b -> LedgerResult l a -> b forall l a b. (a -> b -> b) -> b -> LedgerResult l a -> b forall (t :: * -> *). (forall m. Monoid m => t m -> m) -> (forall m a. Monoid m => (a -> m) -> t a -> m) -> (forall m a. Monoid m => (a -> m) -> t a -> m) -> (forall a b. (a -> b -> b) -> b -> t a -> b) -> (forall a b. (a -> b -> b) -> b -> t a -> b) -> (forall b a. (b -> a -> b) -> b -> t a -> b) -> (forall b a. (b -> a -> b) -> b -> t a -> b) -> (forall a. (a -> a -> a) -> t a -> a) -> (forall a. (a -> a -> a) -> t a -> a) -> (forall a. t a -> [a]) -> (forall a. t a -> Bool) -> (forall a. t a -> Int) -> (forall a. Eq a => a -> t a -> Bool) -> (forall a. Ord a => t a -> a) -> (forall a. Ord a => t a -> a) -> (forall a. Num a => t a -> a) -> (forall a. Num a => t a -> a) -> Foldable t product :: LedgerResult l a -> a $cproduct :: forall l a. Num a => LedgerResult l a -> a sum :: LedgerResult l a -> a $csum :: forall l a. Num a => LedgerResult l a -> a minimum :: LedgerResult l a -> a $cminimum :: forall l a. Ord a => LedgerResult l a -> a maximum :: LedgerResult l a -> a $cmaximum :: forall l a. Ord a => LedgerResult l a -> a elem :: a -> LedgerResult l a -> Bool $celem :: forall l a. Eq a => a -> LedgerResult l a -> Bool length :: LedgerResult l a -> Int $clength :: forall l a. LedgerResult l a -> Int null :: LedgerResult l a -> Bool $cnull :: forall l a. LedgerResult l a -> Bool toList :: LedgerResult l a -> [a] $ctoList :: forall l a. LedgerResult l a -> [a] foldl1 :: (a -> a -> a) -> LedgerResult l a -> a $cfoldl1 :: forall l a. (a -> a -> a) -> LedgerResult l a -> a foldr1 :: (a -> a -> a) -> LedgerResult l a -> a $cfoldr1 :: forall l a. (a -> a -> a) -> LedgerResult l a -> a foldl' :: (b -> a -> b) -> b -> LedgerResult l a -> b $cfoldl' :: forall l b a. (b -> a -> b) -> b -> LedgerResult l a -> b foldl :: (b -> a -> b) -> b -> LedgerResult l a -> b $cfoldl :: forall l b a. (b -> a -> b) -> b -> LedgerResult l a -> b foldr' :: (a -> b -> b) -> b -> LedgerResult l a -> b $cfoldr' :: forall l a b. (a -> b -> b) -> b -> LedgerResult l a -> b foldr :: (a -> b -> b) -> b -> LedgerResult l a -> b $cfoldr :: forall l a b. (a -> b -> b) -> b -> LedgerResult l a -> b foldMap' :: (a -> m) -> LedgerResult l a -> m $cfoldMap' :: forall l m a. Monoid m => (a -> m) -> LedgerResult l a -> m foldMap :: (a -> m) -> LedgerResult l a -> m $cfoldMap :: forall l m a. Monoid m => (a -> m) -> LedgerResult l a -> m fold :: LedgerResult l m -> m $cfold :: forall l m. Monoid m => LedgerResult l m -> m Foldable, a -> LedgerResult l b -> LedgerResult l a (a -> b) -> LedgerResult l a -> LedgerResult l b (forall a b. (a -> b) -> LedgerResult l a -> LedgerResult l b) -> (forall a b. a -> LedgerResult l b -> LedgerResult l a) -> Functor (LedgerResult l) forall a b. a -> LedgerResult l b -> LedgerResult l a forall a b. (a -> b) -> LedgerResult l a -> LedgerResult l b forall l a b. a -> LedgerResult l b -> LedgerResult l a forall l a b. (a -> b) -> LedgerResult l a -> LedgerResult l b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> LedgerResult l b -> LedgerResult l a $c<$ :: forall l a b. a -> LedgerResult l b -> LedgerResult l a fmap :: (a -> b) -> LedgerResult l a -> LedgerResult l b $cfmap :: forall l a b. (a -> b) -> LedgerResult l a -> LedgerResult l b Functor, Functor (LedgerResult l) Foldable (LedgerResult l) Functor (LedgerResult l) -> Foldable (LedgerResult l) -> (forall (f :: * -> *) a b. Applicative f => (a -> f b) -> LedgerResult l a -> f (LedgerResult l b)) -> (forall (f :: * -> *) a. Applicative f => LedgerResult l (f a) -> f (LedgerResult l a)) -> (forall (m :: * -> *) a b. Monad m => (a -> m b) -> LedgerResult l a -> m (LedgerResult l b)) -> (forall (m :: * -> *) a. Monad m => LedgerResult l (m a) -> m (LedgerResult l a)) -> Traversable (LedgerResult l) (a -> f b) -> LedgerResult l a -> f (LedgerResult l b) forall l. Functor (LedgerResult l) forall l. Foldable (LedgerResult l) forall l (m :: * -> *) a. Monad m => LedgerResult l (m a) -> m (LedgerResult l a) forall l (f :: * -> *) a. Applicative f => LedgerResult l (f a) -> f (LedgerResult l a) forall l (m :: * -> *) a b. Monad m => (a -> m b) -> LedgerResult l a -> m (LedgerResult l b) forall l (f :: * -> *) a b. Applicative f => (a -> f b) -> LedgerResult l a -> f (LedgerResult l b) forall (t :: * -> *). Functor t -> Foldable t -> (forall (f :: * -> *) a b. Applicative f => (a -> f b) -> t a -> f (t b)) -> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a)) -> (forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)) -> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a)) -> Traversable t forall (m :: * -> *) a. Monad m => LedgerResult l (m a) -> m (LedgerResult l a) forall (f :: * -> *) a. Applicative f => LedgerResult l (f a) -> f (LedgerResult l a) forall (m :: * -> *) a b. Monad m => (a -> m b) -> LedgerResult l a -> m (LedgerResult l b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> LedgerResult l a -> f (LedgerResult l b) sequence :: LedgerResult l (m a) -> m (LedgerResult l a) $csequence :: forall l (m :: * -> *) a. Monad m => LedgerResult l (m a) -> m (LedgerResult l a) mapM :: (a -> m b) -> LedgerResult l a -> m (LedgerResult l b) $cmapM :: forall l (m :: * -> *) a b. Monad m => (a -> m b) -> LedgerResult l a -> m (LedgerResult l b) sequenceA :: LedgerResult l (f a) -> f (LedgerResult l a) $csequenceA :: forall l (f :: * -> *) a. Applicative f => LedgerResult l (f a) -> f (LedgerResult l a) traverse :: (a -> f b) -> LedgerResult l a -> f (LedgerResult l b) $ctraverse :: forall l (f :: * -> *) a b. Applicative f => (a -> f b) -> LedgerResult l a -> f (LedgerResult l b) $cp2Traversable :: forall l. Foldable (LedgerResult l) $cp1Traversable :: forall l. Functor (LedgerResult l) Traversable) castLedgerResult :: (AuxLedgerEvent l ~ AuxLedgerEvent l') => LedgerResult l a -> LedgerResult l' a castLedgerResult :: LedgerResult l a -> LedgerResult l' a castLedgerResult (LedgerResult [AuxLedgerEvent l] x0 a x1) = [AuxLedgerEvent l'] -> a -> LedgerResult l' a forall l a. [AuxLedgerEvent l] -> a -> LedgerResult l a LedgerResult [AuxLedgerEvent l] [AuxLedgerEvent l'] x0 a x1 embedLedgerResult :: (AuxLedgerEvent l -> AuxLedgerEvent l') -> LedgerResult l a -> LedgerResult l' a embedLedgerResult :: (AuxLedgerEvent l -> AuxLedgerEvent l') -> LedgerResult l a -> LedgerResult l' a embedLedgerResult AuxLedgerEvent l -> AuxLedgerEvent l' inj LedgerResult l a lr = LedgerResult l a lr{lrEvents :: [AuxLedgerEvent l'] lrEvents = AuxLedgerEvent l -> AuxLedgerEvent l' inj (AuxLedgerEvent l -> AuxLedgerEvent l') -> [AuxLedgerEvent l] -> [AuxLedgerEvent l'] forall a b. (a -> b) -> [a] -> [b] `map` LedgerResult l a -> [AuxLedgerEvent l] forall l a. LedgerResult l a -> [AuxLedgerEvent l] lrEvents LedgerResult l a lr} pureLedgerResult :: a -> LedgerResult l a pureLedgerResult :: a -> LedgerResult l a pureLedgerResult a a = LedgerResult :: forall l a. [AuxLedgerEvent l] -> a -> LedgerResult l a LedgerResult { lrEvents :: [AuxLedgerEvent l] lrEvents = [AuxLedgerEvent l] forall a. Monoid a => a mempty , lrResult :: a lrResult = a a } {------------------------------------------------------------------------------- Definition of a ledger independent of a choice of block -------------------------------------------------------------------------------} -- | Static environment required for the ledger type family LedgerCfg l :: Type class ( -- Requirements on the ledger state itself Show l , Eq l , NoThunks l -- Requirements on 'LedgerCfg' , NoThunks (LedgerCfg l) -- Requirements on 'LedgerErr' , Show (LedgerErr l) , Eq (LedgerErr l) , NoThunks (LedgerErr l) -- Get the tip -- -- See comment for 'applyChainTickLedgerResult' about the tip of the -- ticked ledger. , GetTip l , GetTip (Ticked l) ) => IsLedger l where -- | Errors that can arise when updating the ledger -- -- This is defined here rather than in 'ApplyBlock', since the /type/ of -- these errors does not depend on the type of the block. type family LedgerErr l :: Type -- | Event emitted by the ledger -- -- TODO we call this 'AuxLedgerEvent' to differentiate from 'LedgerEvent' in -- 'InspectLedger'. When that module is rewritten to make use of ledger -- derived events, we may rename this type. type family AuxLedgerEvent l :: Type -- | Apply "slot based" state transformations -- -- When a block is applied to the ledger state, a number of things happen -- purely based on the slot number of that block. For example: -- -- * In Byron, scheduled updates are applied, and the update system state is -- updated. -- * In Shelley, delegation state is updated (on epoch boundaries). -- -- The consensus layer must be able to apply such a "chain tick" function, -- primarily when validating transactions in the mempool (which, conceptually, -- live in "some block in the future") or when extracting valid transactions -- from the mempool to insert into a new block to be produced. -- -- This is not allowed to throw any errors. After all, if this could fail, -- it would mean a /previous/ block set up the ledger state in such a way -- that as soon as a certain slot was reached, /any/ block would be invalid. -- -- PRECONDITION: The slot number must be strictly greater than the slot at -- the tip of the ledger (except for EBBs, obviously..). -- -- NOTE: 'applyChainTickLedgerResult' should /not/ change the tip of the -- underlying ledger state, which should still refer to the most recent -- applied /block/. In other words, we should have -- -- > ledgerTipPoint (applyChainTick cfg slot st) -- > == ledgerTipPoint st applyChainTickLedgerResult :: LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l) -- | 'lrResult' after 'applyChainTickLedgerResult' applyChainTick :: IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l applyChainTick :: LedgerCfg l -> SlotNo -> l -> Ticked l applyChainTick = LedgerResult l (Ticked l) -> Ticked l forall l a. LedgerResult l a -> a lrResult (LedgerResult l (Ticked l) -> Ticked l) -> (LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l)) -> LedgerCfg l -> SlotNo -> l -> Ticked l forall y z x0 x1 x2. (y -> z) -> (x0 -> x1 -> x2 -> y) -> x0 -> x1 -> x2 -> z ..: LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l) forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l) applyChainTickLedgerResult {------------------------------------------------------------------------------- Link block to its ledger -------------------------------------------------------------------------------} -- | Ledger state associated with a block data family LedgerState blk :: Type type instance HeaderHash (LedgerState blk) = HeaderHash blk type LedgerConfig blk = LedgerCfg (LedgerState blk) type LedgerError blk = LedgerErr (LedgerState blk) type TickedLedgerState blk = Ticked (LedgerState blk)