{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | 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 getTipHash :: GetTip l => l -> ChainHash l getTipHash :: forall l. GetTip l => l -> ChainHash l getTipHash = Point l -> ChainHash l forall {k} (block :: k). 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 :: forall l. GetTip l => l -> WithOrigin SlotNo getTipSlot = Point l -> WithOrigin SlotNo forall {k} (block :: k). 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 { forall l a. LedgerResult l a -> [AuxLedgerEvent l] lrEvents :: [AuxLedgerEvent l] , forall l a. LedgerResult l a -> a lrResult :: !a } deriving ((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 $cfold :: forall l m. Monoid m => LedgerResult l m -> m fold :: forall m. Monoid m => LedgerResult l m -> m $cfoldMap :: forall l m a. Monoid m => (a -> m) -> LedgerResult l a -> m foldMap :: forall m a. Monoid m => (a -> m) -> LedgerResult l a -> m $cfoldMap' :: forall l m a. Monoid m => (a -> m) -> LedgerResult l a -> m foldMap' :: forall m a. Monoid m => (a -> m) -> LedgerResult l a -> m $cfoldr :: forall l a b. (a -> b -> b) -> b -> LedgerResult l a -> b foldr :: forall a b. (a -> b -> b) -> b -> LedgerResult l a -> b $cfoldr' :: forall l a b. (a -> b -> b) -> b -> LedgerResult l a -> b foldr' :: forall a b. (a -> b -> b) -> b -> LedgerResult l a -> b $cfoldl :: forall l b a. (b -> a -> b) -> b -> LedgerResult l a -> b foldl :: forall b a. (b -> a -> b) -> b -> LedgerResult l a -> b $cfoldl' :: forall l b a. (b -> a -> b) -> b -> LedgerResult l a -> b foldl' :: forall b a. (b -> a -> b) -> b -> LedgerResult l a -> b $cfoldr1 :: forall l a. (a -> a -> a) -> LedgerResult l a -> a foldr1 :: forall a. (a -> a -> a) -> LedgerResult l a -> a $cfoldl1 :: forall l a. (a -> a -> a) -> LedgerResult l a -> a foldl1 :: forall a. (a -> a -> a) -> LedgerResult l a -> a $ctoList :: forall l a. LedgerResult l a -> [a] toList :: forall a. LedgerResult l a -> [a] $cnull :: forall l a. LedgerResult l a -> Bool null :: forall a. LedgerResult l a -> Bool $clength :: forall l a. LedgerResult l a -> Int length :: forall a. LedgerResult l a -> Int $celem :: forall l a. Eq a => a -> LedgerResult l a -> Bool elem :: forall a. Eq a => a -> LedgerResult l a -> Bool $cmaximum :: forall l a. Ord a => LedgerResult l a -> a maximum :: forall a. Ord a => LedgerResult l a -> a $cminimum :: forall l a. Ord a => LedgerResult l a -> a minimum :: forall a. Ord a => LedgerResult l a -> a $csum :: forall l a. Num a => LedgerResult l a -> a sum :: forall a. Num a => LedgerResult l a -> a $cproduct :: forall l a. Num a => LedgerResult l a -> a product :: forall a. Num a => LedgerResult l a -> a Foldable, (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 $cfmap :: forall l a b. (a -> b) -> LedgerResult l a -> LedgerResult l b fmap :: forall a b. (a -> b) -> LedgerResult l a -> LedgerResult l b $c<$ :: forall l a b. a -> LedgerResult l b -> LedgerResult l a <$ :: forall a b. a -> LedgerResult l b -> LedgerResult l a 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) 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) $ctraverse :: forall l (f :: * -> *) a b. Applicative f => (a -> f b) -> LedgerResult l a -> f (LedgerResult l b) traverse :: forall (f :: * -> *) a b. Applicative f => (a -> f b) -> LedgerResult l a -> f (LedgerResult l b) $csequenceA :: forall l (f :: * -> *) a. Applicative f => LedgerResult l (f a) -> f (LedgerResult l a) sequenceA :: forall (f :: * -> *) a. Applicative f => LedgerResult l (f a) -> f (LedgerResult l a) $cmapM :: forall l (m :: * -> *) a b. Monad m => (a -> m b) -> LedgerResult l a -> m (LedgerResult l b) mapM :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> LedgerResult l a -> m (LedgerResult l b) $csequence :: forall l (m :: * -> *) a. Monad m => LedgerResult l (m a) -> m (LedgerResult l a) sequence :: forall (m :: * -> *) a. Monad m => LedgerResult l (m a) -> m (LedgerResult l a) Traversable) castLedgerResult :: (AuxLedgerEvent l ~ AuxLedgerEvent l') => LedgerResult l a -> LedgerResult l' a castLedgerResult :: forall l l' a. (AuxLedgerEvent l ~ AuxLedgerEvent l') => 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 :: forall l l' a. (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 = inj `map` lrEvents lr} pureLedgerResult :: a -> LedgerResult l a pureLedgerResult :: forall a l. a -> LedgerResult l a pureLedgerResult a 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 -- -- Types that inhabit this family will come from the Ledger code. 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 :: forall l. IsLedger l => 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 -- -- This is the Consensus notion of a /ledger state/. Each block type is -- associated with one of the Ledger types for the /ledger state/. Virtually -- every concept in this codebase revolves around this type, or the referenced -- @blk@. Whenever we use the type variable @l@, we intend to denote that the -- expected instantiation is either a 'LedgerState' or some wrapper over it -- (like the 'Ouroboros.Consensus.Ledger.Extended.ExtLedgerState'). -- -- The main operations we can do with a 'LedgerState' are /ticking/ (defined in -- 'IsLedger'), and /applying a block/ (defined in -- 'Ouroboros.Consensus.Ledger.Abstract.ApplyBlock'). 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)