Decouple Header from its class

Sometimes it is more convenient to simply define the data/type instances without having to define the whole type class instances. For example, when wrapping an existing block to override the serialisation instances, we should not have to provide instances for classes like `GetHeader` when we only want to wrap the associated data type.
IntersectMBO · Jul 10, 2020 · 77df204 · 77df204
1 parent 7d88a0a
commit 77df204
Show file tree

Hide file tree

Showing 12 changed files with 90 additions and 86 deletions.
diff --git a/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Block.hs b/ouroboros-consensus-byron/src/Ouroboros/Consensus/Byron/Ledger/Block.hs
@@ -121,24 +121,24 @@ annotateByronBlock es = mkByronBlock es . CC.ABOBBlock . CC.reAnnotateBlock es
   Header
 -------------------------------------------------------------------------------}
 
-instance GetHeader ByronBlock where
-  -- | Byron header
-  --
-  -- See 'ByronBlock' for comments on why we cache certain values.
-  data Header ByronBlock = ByronHeader {
-        byronHeaderRaw    :: !(CC.ABlockOrBoundaryHdr ByteString)
-      , byronHeaderSlotNo :: !SlotNo
-      , byronHeaderHash   :: !ByronHash
-
-        -- | Hint about the block size
-        --
-        -- This is used only for the block fetch client. When this value is
-        -- wrong, block fetch might make suboptimal decisions, but it shouldn't
-        -- /break/ anything
-      , byronHeaderBlockSizeHint :: !SizeInBytes
-      }
-    deriving (Eq, Show, Generic)
+-- | Byron header
+--
+-- See 'ByronBlock' for comments on why we cache certain values.
+data instance Header ByronBlock = ByronHeader {
+      byronHeaderRaw    :: !(CC.ABlockOrBoundaryHdr ByteString)
+    , byronHeaderSlotNo :: !SlotNo
+    , byronHeaderHash   :: !ByronHash
+
+      -- | Hint about the block size
+      --
+      -- This is used only for the block fetch client. When this value is
+      -- wrong, block fetch might make suboptimal decisions, but it shouldn't
+      -- /break/ anything
+    , byronHeaderBlockSizeHint :: !SizeInBytes
+    }
+  deriving (Eq, Show, Generic)
 
+instance GetHeader ByronBlock where
   getHeader ByronBlock{..} = ByronHeader {
         byronHeaderRaw           = CC.abobHdrFromBlock byronBlockRaw
       , byronHeaderSlotNo        = byronBlockSlotNo

diff --git a/ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Block.hs b/ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Block.hs
@@ -48,14 +48,14 @@ data ByronSpecBlock = ByronSpecBlock {
   GetHeader
 -------------------------------------------------------------------------------}
 
-instance GetHeader ByronSpecBlock where
-  data Header ByronSpecBlock = ByronSpecHeader {
-        byronSpecHeader     :: Spec.BlockHeader
-      , byronSpecHeaderNo   :: BlockNo
-      , byronSpecHeaderHash :: Spec.Hash
-      }
-    deriving (Show, Eq, Generic, Serialise)
+data instance Header ByronSpecBlock = ByronSpecHeader {
+      byronSpecHeader     :: Spec.BlockHeader
+    , byronSpecHeaderNo   :: BlockNo
+    , byronSpecHeaderHash :: Spec.Hash
+    }
+  deriving (Show, Eq, Generic, Serialise)
 
+instance GetHeader ByronSpecBlock where
   getHeader ByronSpecBlock{..} = ByronSpecHeader {
         byronSpecHeader     = Spec._bHeader byronSpecBlock
       , byronSpecHeaderNo   = byronSpecBlockNo

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs
@@ -102,13 +102,13 @@ mkShelleyBlock raw = ShelleyBlock {
     , shelleyBlockHeaderHash = ShelleyHash (SL.bhHash (SL.bheader raw))
     }
 
-instance Crypto c => GetHeader (ShelleyBlock c) where
-  data Header (ShelleyBlock c) = ShelleyHeader {
-        shelleyHeaderRaw  :: !(SL.BHeader c)
-      , shelleyHeaderHash :: !(ShelleyHash c)
-      }
-    deriving (Eq, Generic, Show, NoUnexpectedThunks)
+data instance Header (ShelleyBlock c) = ShelleyHeader {
+      shelleyHeaderRaw  :: !(SL.BHeader c)
+    , shelleyHeaderHash :: !(ShelleyHash c)
+    }
+  deriving (Eq, Generic, Show, NoUnexpectedThunks)
 
+instance Crypto c => GetHeader (ShelleyBlock c) where
   getHeader (ShelleyBlock rawBlk hdrHash) = ShelleyHeader {
       shelleyHeaderRaw  = SL.bheader rawBlk
     , shelleyHeaderHash = hdrHash

diff --git a/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Block.hs
@@ -113,29 +113,29 @@ data SimpleBlock' c ext ext' = SimpleBlock {
   deriving stock    (Generic, Show, Eq)
   deriving anyclass (Serialise)
 
+data instance Header (SimpleBlock' c ext ext') = SimpleHeader {
+      -- | The header hash
+      --
+      -- This is the hash of the header itself. This is a bit unpleasant,
+      -- because it makes the hash look self-referential (when computing the
+      -- hash we must ignore the 'simpleHeaderHash' field). However, the benefit
+      -- is that we can give a 'HasHeader' instance that does not require
+      -- a (static) 'Serialise' instance.
+      simpleHeaderHash :: HeaderHash (SimpleBlock' c ext ext')
+
+      -- | Fields required for the 'HasHeader' instance
+    , simpleHeaderStd  :: SimpleStdHeader c ext
+
+      -- | Header extension
+      --
+      -- This extension will be required when using 'SimpleBlock' for specific
+      -- consensus protocols.
+    , simpleHeaderExt  :: ext'
+    }
+  deriving (Generic, Show, Eq, NoUnexpectedThunks)
+
 instance (SimpleCrypto c, Typeable ext, Typeable ext')
       => GetHeader (SimpleBlock' c ext ext') where
-  data Header (SimpleBlock' c ext ext') = SimpleHeader {
-        -- | The header hash
-        --
-        -- This is the hash of the header itself. This is a bit unpleasant,
-        -- because it makes the hash look self-referential (when computing the
-        -- hash we must ignore the 'simpleHeaderHash' field). However, the benefit
-        -- is that we can give a 'HasHeader' instance that does not require
-        -- a (static) 'Serialise' instance.
-        simpleHeaderHash :: HeaderHash (SimpleBlock' c ext ext')
-
-        -- | Fields required for the 'HasHeader' instance
-      , simpleHeaderStd  :: SimpleStdHeader c ext
-
-        -- | Header extension
-        --
-        -- This extension will be required when using 'SimpleBlock' for specific
-        -- consensus protocols.
-      , simpleHeaderExt  :: ext'
-      }
-    deriving (Generic, Show, Eq, NoUnexpectedThunks)
-
   getHeader = simpleHeader
 
   blockMatchesHeader = matchesSimpleHeader

diff --git a/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs b/ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/TestBlock.hs
@@ -177,10 +177,11 @@ data TestBlock = TestBlock {
   deriving stock    (Show, Eq, Ord, Generic)
   deriving anyclass (Serialise, NoUnexpectedThunks, ToExpr)
 
+newtype instance Header TestBlock = TestHeader { testHeader :: TestBlock }
+  deriving stock   (Eq, Show)
+  deriving newtype (NoUnexpectedThunks, Serialise)
+
 instance GetHeader TestBlock where
-  newtype Header TestBlock = TestHeader { testHeader :: TestBlock }
-    deriving stock   (Eq, Show)
-    deriving newtype (NoUnexpectedThunks, Serialise)
   getHeader = TestHeader
   blockMatchesHeader (TestHeader blk') blk = blk == blk'
   headerIsEBB = const Nothing

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Block/Abstract.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Block/Abstract.hs
@@ -15,6 +15,7 @@ module Ouroboros.Consensus.Block.Abstract (
   , GetPrevHash(..)
   , blockPrevHash
     -- * Working with headers
+  , Header
   , GetHeader(..)
   , getBlockHeaderFields
   , headerHash
@@ -120,8 +121,9 @@ blockPrevHash cfg = castHash . headerPrevHash cfg . getHeader
   Link block to its header
 -------------------------------------------------------------------------------}
 
+data family Header blk :: *
+
 class HasHeader (Header blk) => GetHeader blk where
-  data family Header blk :: *
   getHeader          :: blk -> Header blk
   -- | Check whether the header is the header of the block.
   --

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Block.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Block.hs
@@ -44,12 +44,12 @@ import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Match as Match
   GetHeader
 -------------------------------------------------------------------------------}
 
-instance CanHardFork xs => GetHeader (HardForkBlock xs) where
-  newtype Header (HardForkBlock xs) = HardForkHeader {
-        getHardForkHeader :: OneEraHeader xs
-      }
-    deriving (Show, NoUnexpectedThunks)
+newtype instance Header (HardForkBlock xs) = HardForkHeader {
+      getHardForkHeader :: OneEraHeader xs
+    }
+  deriving (Show, NoUnexpectedThunks)
 
+instance CanHardFork xs => GetHeader (HardForkBlock xs) where
   getHeader = HardForkHeader . oneEraBlockHeader . getHardForkBlock
 
   blockMatchesHeader = \hdr blk ->

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs
@@ -107,12 +107,12 @@ newtype DegenFork b = DBlk {
   Data family instances
 -------------------------------------------------------------------------------}
 
-instance NoHardForks b => GetHeader (DegenFork b) where
-  newtype Header (DegenFork b) = DHdr {
-        unDHdr :: Header (HardForkBlock '[b])
-      }
-    deriving (Show, NoUnexpectedThunks)
+newtype instance Header (DegenFork b) = DHdr {
+      unDHdr :: Header (HardForkBlock '[b])
+    }
+  deriving (Show, NoUnexpectedThunks)
 
+instance NoHardForks b => GetHeader (DegenFork b) where
   getHeader (DBlk b) = DHdr (getHeader b)
 
   blockMatchesHeader (DHdr hdr) (DBlk blk) =

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Dual.hs
@@ -132,10 +132,10 @@ instance ConvertRawHash m => ConvertRawHash (DualBlock m a) where
   Header
 -------------------------------------------------------------------------------}
 
-instance Bridge m a => GetHeader (DualBlock m a) where
-  newtype Header (DualBlock m a) = DualHeader { dualHeaderMain :: Header m }
-    deriving NoUnexpectedThunks via AllowThunk (Header (DualBlock m a))
+newtype instance Header (DualBlock m a) = DualHeader { dualHeaderMain :: Header m }
+  deriving NoUnexpectedThunks via AllowThunk (Header (DualBlock m a))
 
+instance Bridge m a => GetHeader (DualBlock m a) where
   getHeader = DualHeader . getHeader . dualBlockMain
 
   blockMatchesHeader hdr =

diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/A.hs
@@ -146,15 +146,15 @@ binaryBlockInfoA BlkA{..} = BinaryBlockInfo {
     , headerSize   = fromIntegral $ Lazy.length (serialise blkA_header)
     }
 
-instance GetHeader BlockA where
-  data Header BlockA = HdrA {
-        hdrA_fields :: HeaderFields BlockA
-      , hdrA_prev   :: ChainHash BlockA
-      }
-    deriving stock    (Show, Eq, Generic)
-    deriving anyclass (Serialise)
-    deriving NoUnexpectedThunks via OnlyCheckIsWHNF "HdrA" (Header BlockA)
+data instance Header BlockA = HdrA {
+      hdrA_fields :: HeaderFields BlockA
+    , hdrA_prev   :: ChainHash BlockA
+    }
+  deriving stock    (Show, Eq, Generic)
+  deriving anyclass (Serialise)
+  deriving NoUnexpectedThunks via OnlyCheckIsWHNF "HdrA" (Header BlockA)
 
+instance GetHeader BlockA where
   getHeader          = blkA_header
   blockMatchesHeader = \_ _ -> True -- We are not interested in integrity here
   headerIsEBB        = const Nothing

diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus/test-consensus/Test/Consensus/HardFork/Combinator/B.hs
@@ -125,15 +125,15 @@ binaryBlockInfoB BlkB{..} = BinaryBlockInfo {
     , headerSize   = fromIntegral $ Lazy.length (serialise blkB_header)
     }
 
-instance GetHeader BlockB where
-  data Header BlockB = HdrB {
-        hdrB_fields :: HeaderFields BlockB
-      , hdrB_prev   :: ChainHash BlockB
-      }
-    deriving stock    (Show, Eq, Generic)
-    deriving anyclass (Serialise)
-    deriving NoUnexpectedThunks via OnlyCheckIsWHNF "HdrB" (Header BlockB)
+data instance Header BlockB = HdrB {
+      hdrB_fields :: HeaderFields BlockB
+    , hdrB_prev   :: ChainHash BlockB
+    }
+  deriving stock    (Show, Eq, Generic)
+  deriving anyclass (Serialise)
+  deriving NoUnexpectedThunks via OnlyCheckIsWHNF "HdrB" (Header BlockB)
 
+instance GetHeader BlockB where
   getHeader          = blkB_header
   blockMatchesHeader = \_ _ -> True -- We are not interested in integrity here
   headerIsEBB        = const Nothing

diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/TestBlock.hs
@@ -188,9 +188,10 @@ data TestBody = TestBody {
   deriving stock    (Eq, Show, Generic)
   deriving anyclass (NoUnexpectedThunks, Serialise, Hashable)
 
+newtype instance Header TestBlock = TestHeader' { unTestHeader :: TestHeader }
+  deriving newtype (Eq, Show, NoUnexpectedThunks, Serialise)
+
 instance GetHeader TestBlock where
-  newtype Header TestBlock = TestHeader' { unTestHeader :: TestHeader }
-    deriving newtype (Eq, Show, NoUnexpectedThunks, Serialise)
   getHeader = TestHeader' . testHeader
 
   blockMatchesHeader (TestHeader' hdr) blk =