Use MKs in ouroboros-consensus-byron

Co-authored-by: Nick Frisby <nick.frisby@iohk.io> Co-authored-by: Damian Nadales <damian.nadales@iohk.io> Co-authored-by: Joris Dral <joris@well-typed.com> skip-checks: true
IntersectMBO · Mar 27, 2023 · f1eaab1 · f1eaab1
1 parent 09bd0ad
commit f1eaab1
Show file tree

Hide file tree

Showing 7 changed files with 52 additions and 25 deletions.
diff --git a/ouroboros-consensus-byron/ouroboros-consensus-byron.cabal b/ouroboros-consensus-byron/ouroboros-consensus-byron.cabal
@@ -72,6 +72,7 @@ library
     -Wall -Wcompat -Wincomplete-uni-patterns
     -Wincomplete-record-updates -Wpartial-fields -Widentities
     -Wredundant-constraints -Wmissing-export-lists -Wunused-packages
+    -Wno-unticked-promoted-constructors
 
   if flag(asserts)
     ghc-options: -fno-ignore-asserts

diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Forge.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Forge.hs
@@ -53,7 +53,7 @@ forgeByronBlock
                                       --   defined by ledger
   -> BlockNo                          -- ^ Current block number
   -> SlotNo                           -- ^ Current slot number
-  -> TickedLedgerState ByronBlock     -- ^ Current ledger
+  -> TickedLedgerState ByronBlock mk  -- ^ Current ledger
   -> [Validated (GenTx ByronBlock)]   -- ^ Txs to consider adding in the block
   -> PBftIsLeader PBftByronCrypto     -- ^ Leader proof ('IsLeader')
   -> ByronBlock
@@ -130,7 +130,7 @@ forgeRegularBlock
                                        --   defined by ledger
   -> BlockNo                           -- ^ Current block number
   -> SlotNo                            -- ^ Current slot number
-  -> TickedLedgerState ByronBlock      -- ^ Current ledger
+  -> TickedLedgerState ByronBlock mk   -- ^ Current ledger
   -> [Validated (GenTx ByronBlock)]    -- ^ Txs to consider adding in the block
   -> PBftIsLeader PBftByronCrypto      -- ^ Leader proof ('IsLeader')
   -> ByronBlock

diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Inspect.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Inspect.hs
@@ -103,7 +103,7 @@ data UpdateState =
 -- | All proposal updates, from new to old
 protocolUpdates ::
        LedgerConfig ByronBlock
-    -> LedgerState ByronBlock
+    -> LedgerState ByronBlock mk
     -> [ProtocolUpdate]
 protocolUpdates genesis st = concat [
       map fromCandidate candidates

diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Ledger.hs
@@ -36,7 +36,8 @@ module Ouroboros.Consensus.Byron.Ledger.Ledger (
     -- * Type family instances
   , BlockQuery (..)
   , LedgerState (..)
-  , Ticked (..)
+  , LedgerTables (..)
+  , Ticked1 (..)
     -- * Auxiliary
   , validationErrorImpossible
   ) where
@@ -80,14 +81,14 @@ import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.Query
 import           Ouroboros.Consensus.Ledger.SupportsPeerSelection
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
-import           Ouroboros.Consensus.Protocol.PBFT
+import           Ouroboros.Consensus.Ledger.Tables.Utils
 import           Ouroboros.Consensus.Util (ShowProxy (..), (..:))
 
 {-------------------------------------------------------------------------------
   LedgerState
 -------------------------------------------------------------------------------}
 
-data instance LedgerState ByronBlock = ByronLedgerState {
+data instance LedgerState ByronBlock mk = ByronLedgerState {
       byronLedgerTipBlockNo :: !(WithOrigin BlockNo)
     , byronLedgerState      :: !CC.ChainValidationState
     , byronLedgerTransition :: !ByronTransition
@@ -117,7 +118,7 @@ type instance LedgerCfg (LedgerState ByronBlock) = Gen.Config
 
 initByronLedgerState :: Gen.Config
                      -> Maybe CC.UTxO -- ^ Optionally override UTxO
-                     -> LedgerState ByronBlock
+                     -> LedgerState ByronBlock mk
 initByronLedgerState genesis mUtxo = ByronLedgerState {
       byronLedgerState      = override mUtxo initState
     , byronLedgerTipBlockNo = Origin
@@ -142,7 +143,7 @@ initByronLedgerState genesis mUtxo = ByronLedgerState {
 instance GetTip (LedgerState ByronBlock) where
   getTip = castPoint . getByronTip . byronLedgerState
 
-instance GetTip (Ticked (LedgerState ByronBlock)) where
+instance GetTip (Ticked1 (LedgerState ByronBlock)) where
   getTip = castPoint . getByronTip . tickedByronLedgerState
 
 getByronTip :: CC.ChainValidationState -> Point ByronBlock
@@ -160,7 +161,7 @@ getByronTip state =
 -------------------------------------------------------------------------------}
 
 -- | The ticked Byron ledger state
-data instance Ticked (LedgerState ByronBlock) = TickedByronLedgerState {
+data instance Ticked1 (LedgerState ByronBlock) mk = TickedByronLedgerState {
       tickedByronLedgerState        :: !CC.ChainValidationState
     , untickedByronLedgerTransition :: !ByronTransition
     }
@@ -180,6 +181,22 @@ instance IsLedger (LedgerState ByronBlock) where
             byronLedgerTransition
         }
 
+instance HasLedgerTables (LedgerState ByronBlock) where
+  data LedgerTables (LedgerState ByronBlock) mk = NoByronLedgerTables
+    deriving (Generic, Eq, Show, NoThunks)
+
+instance CanSerializeLedgerTables (LedgerState ByronBlock) where
+
+instance LedgerTablesAreTrivial (LedgerState ByronBlock) where
+  convertMapKind ByronLedgerState{..} = ByronLedgerState{..}
+  trivialLedgerTables = NoByronLedgerTables
+
+instance HasTickedLedgerTables (LedgerState ByronBlock) where
+  withLedgerTablesTicked (TickedByronLedgerState st trans) NoByronLedgerTables =
+    TickedByronLedgerState st trans
+
+instance CanStowLedgerTables (LedgerState ByronBlock) where
+
 {-------------------------------------------------------------------------------
   Supporting the various consensus interfaces
 -------------------------------------------------------------------------------}
@@ -195,12 +212,16 @@ instance ApplyBlock (LedgerState ByronBlock) ByronBlock where
     where
       validationMode = CC.fromBlockValidationMode CC.NoBlockValidation
 
+  getBlockKeySets _ = emptyLedgerTables
+
 data instance BlockQuery ByronBlock :: Type -> Type where
   GetUpdateInterfaceState :: BlockQuery ByronBlock UPI.State
 
 instance QueryLedger ByronBlock where
-  answerBlockQuery _cfg GetUpdateInterfaceState (ExtLedgerState ledgerState _) =
-    CC.cvsUpdateState (byronLedgerState ledgerState)
+  answerBlockQuery _cfg GetUpdateInterfaceState (DiskLedgerView (ExtLedgerState ledgerState _) _ _ _) =
+    pure $ CC.cvsUpdateState (byronLedgerState ledgerState)
+  getQueryKeySets _ = NoByronLedgerTables
+  tableTraversingQuery _ = Nothing
 
 instance SameDepIndex (BlockQuery ByronBlock) where
   sameDepIndex GetUpdateInterfaceState GetUpdateInterfaceState = Just Refl
@@ -221,7 +242,7 @@ instance CommonProtocolParams ByronBlock where
   maxTxSize     = fromIntegral . Update.ppMaxTxSize     . getProtocolParameters
 
 -- | Return the protocol parameters adopted by the given ledger.
-getProtocolParameters :: LedgerState ByronBlock -> Update.ProtocolParameters
+getProtocolParameters :: LedgerState ByronBlock mk -> Update.ProtocolParameters
 getProtocolParameters =
       CC.adoptedProtocolParameters
     . CC.cvsUpdateState
@@ -322,8 +343,8 @@ validationErrorImpossible = cantBeError . runExcept
 applyByronBlock :: CC.ValidationMode
                 -> LedgerConfig ByronBlock
                 -> ByronBlock
-                -> TickedLedgerState ByronBlock
-                -> Except (LedgerError ByronBlock) (LedgerState ByronBlock)
+                -> TickedLedgerState ByronBlock mk1
+                -> Except (LedgerError ByronBlock) (LedgerState ByronBlock mk2)
 applyByronBlock validationMode
                 cfg
                 blk@(ByronBlock raw _ (ByronHash blkHash))
@@ -340,8 +361,8 @@ applyABlock :: CC.ValidationMode
             -> CC.ABlock ByteString
             -> CC.HeaderHash
             -> BlockNo
-            -> Ticked (LedgerState (ByronBlock))
-            -> Except (LedgerError ByronBlock) (LedgerState ByronBlock)
+            -> TickedLedgerState ByronBlock mk1
+            -> Except (LedgerError ByronBlock) (LedgerState ByronBlock mk2)
 applyABlock validationMode cfg blk blkHash blkNo TickedByronLedgerState{..} = do
     st' <- CC.validateBlock cfg validationMode blk blkHash tickedByronLedgerState
 
@@ -380,8 +401,8 @@ applyABlock validationMode cfg blk blkHash blkNo TickedByronLedgerState{..} = do
 applyABoundaryBlock :: Gen.Config
                     -> CC.ABoundaryBlock ByteString
                     -> BlockNo
-                    -> Ticked (LedgerState ByronBlock)
-                    -> Except (LedgerError ByronBlock) (LedgerState ByronBlock)
+                    -> TickedLedgerState ByronBlock mk1
+                    -> Except (LedgerError ByronBlock) (LedgerState ByronBlock mk2)
 applyABoundaryBlock cfg blk blkNo TickedByronLedgerState{..} = do
     st' <- CC.validateBoundary cfg blk tickedByronLedgerState
     return ByronLedgerState {
@@ -400,7 +421,7 @@ encodeByronAnnTip = encodeAnnTipIsEBB encodeByronHeaderHash
 decodeByronAnnTip :: Decoder s (AnnTip ByronBlock)
 decodeByronAnnTip = decodeAnnTipIsEBB decodeByronHeaderHash
 
-encodeByronExtLedgerState :: ExtLedgerState ByronBlock -> Encoding
+encodeByronExtLedgerState :: ExtLedgerState ByronBlock mk -> Encoding
 encodeByronExtLedgerState = encodeExtLedgerState
     encodeByronLedgerState
     encodeByronChainDepState
@@ -464,15 +485,15 @@ decodeByronTransition = do
         bno     <- decode
         return (Update.ProtocolVersion { pvMajor, pvMinor, pvAlt }, bno)
 
-encodeByronLedgerState :: LedgerState ByronBlock -> Encoding
+encodeByronLedgerState :: LedgerState ByronBlock mk -> Encoding
 encodeByronLedgerState ByronLedgerState{..} = mconcat [
       encodeListLen 3
     , encode byronLedgerTipBlockNo
     , encode byronLedgerState
     , encodeByronTransition byronLedgerTransition
     ]
 
-decodeByronLedgerState :: Decoder s (LedgerState ByronBlock)
+decodeByronLedgerState :: Decoder s (LedgerState ByronBlock mk)
 decodeByronLedgerState = do
     enforceSize "ByronLedgerState" 3
     ByronLedgerState

diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Mempool.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Mempool.hs
@@ -73,6 +73,7 @@ import           Ouroboros.Consensus.Byron.Ledger.Serialisation
                      (byronBlockEncodingOverhead)
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool
+import           Ouroboros.Consensus.Ledger.Tables.Utils
 import           Ouroboros.Consensus.Mempool
 import           Ouroboros.Consensus.Util (ShowProxy (..))
 import           Ouroboros.Consensus.Util.Condense
@@ -145,6 +146,8 @@ instance LedgerSupportsMempool ByronBlock where
 
   txForgetValidated = forgetValidatedByronTx
 
+  getTransactionKeySets _ = emptyLedgerTables
+
 data instance TxId (GenTx ByronBlock)
   = ByronTxId             !Utxo.TxId
   | ByronDlgId            !Delegation.CertificateId
@@ -246,8 +249,8 @@ applyByronGenTx :: CC.ValidationMode
                 -> LedgerConfig ByronBlock
                 -> SlotNo
                 -> GenTx ByronBlock
-                -> TickedLedgerState ByronBlock
-                -> Except (ApplyTxErr ByronBlock) (TickedLedgerState ByronBlock)
+                -> TickedLedgerState ByronBlock mk1
+                -> Except (ApplyTxErr ByronBlock) (TickedLedgerState ByronBlock mk2)
 applyByronGenTx validationMode cfg slot genTx st =
     (\state -> st {tickedByronLedgerState = state}) <$>
       CC.applyMempoolPayload

diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node/Serialisation.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Node/Serialisation.hs
@@ -48,9 +48,9 @@ instance EncodeDisk ByronBlock ByronBlock where
 instance DecodeDisk ByronBlock (Lazy.ByteString -> ByronBlock) where
   decodeDisk ccfg = decodeByronBlock (getByronEpochSlots ccfg)
 
-instance EncodeDisk ByronBlock (LedgerState ByronBlock) where
+instance EncodeDisk ByronBlock (LedgerState ByronBlock mk) where
   encodeDisk _ = encodeByronLedgerState
-instance DecodeDisk ByronBlock (LedgerState ByronBlock) where
+instance DecodeDisk ByronBlock (LedgerState ByronBlock mk) where
   decodeDisk _ = decodeByronLedgerState
 
 -- | @'ChainDepState' ('BlockProtocol' 'ByronBlock')@

diff --git a/ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs b/ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs
@@ -1,8 +1,10 @@
+{-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE DerivingVia           #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TypeFamilies          #-}