Added SomeBlockType and reflBlockType

IntersectMBO · Jul 6, 2023 · ec55c00 · ec55c00
1 parent 188397d
commit ec55c00
Show file tree

Hide file tree

Showing 2 changed files with 18 additions and 0 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Protocol.hs b/cardano-api/internal/Cardano/Api/Protocol.hs
@@ -6,9 +6,12 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Cardano.Api.Protocol
   ( BlockType(..)
+  , SomeBlockType (..)
+  , reflBlockType
   , Protocol(..)
   , ProtocolInfoArgs(..)
   , ProtocolClient(..)
@@ -36,6 +39,8 @@ import           Ouroboros.Consensus.Shelley.Node.Praos
 import           Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC)
 import           Ouroboros.Consensus.Util.IOLike (IOLike)
 
+import           Type.Reflection ((:~:) (..))
+
 class (RunNode blk, IOLike m) => Protocol m blk where
   data ProtocolInfoArgs blk
   protocolInfo :: ProtocolInfoArgs blk -> (ProtocolInfo blk, m [BlockForging m blk])
@@ -147,3 +152,14 @@ data BlockType blk where
 deriving instance Eq (BlockType blk)
 deriving instance Show (BlockType blk)
 
+reflBlockType :: BlockType blk -> BlockType blk' -> Maybe (blk :~: blk')
+reflBlockType ByronBlockType   ByronBlockType   = Just Refl
+reflBlockType ShelleyBlockType ShelleyBlockType = Just Refl
+reflBlockType CardanoBlockType CardanoBlockType = Just Refl
+reflBlockType _                _                = Nothing
+
+
+data SomeBlockType where
+  SomeBlockType :: BlockType blk -> SomeBlockType
+
+deriving instance Show SomeBlockType
diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -707,6 +707,8 @@ module Cardano.Api (
 
     -- ** Protocol related types
     BlockType(..),
+    SomeBlockType (..),
+    reflBlockType,
     Protocol(..),
     ProtocolInfoArgs(..),