[mmzk] (feat) Binary for KindID

MMZK1526 · Jul 22, 2023 · 59c5698 · 59c5698
1 parent fb7eda8
commit 59c5698
Show file tree

Hide file tree

Showing 2 changed files with 15 additions and 2 deletions.
diff --git a/src/Data/KindID/Internal.hs b/src/Data/KindID/Internal.hs
@@ -12,6 +12,7 @@ module Data.KindID.Internal where
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Data.Aeson.Types hiding (String)
+import           Data.Binary
 import           Data.ByteString.Lazy (ByteString)
 import           Data.Hashable
 import           Data.Proxy
@@ -24,7 +25,6 @@ import           Data.TypeID.Internal (TypeID)
 import qualified Data.TypeID.Internal as TID
 import           Data.UUID.Types.Internal (UUID(..))
 import qualified Data.UUID.V7 as V7
-import           Data.Word
 import           GHC.TypeLits (symbolVal)
 
 -- | A TypeID with the prefix encoded at type level.
@@ -80,6 +80,20 @@ instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
       Right kid -> pure kid
     {-# INLINE fromJSONKey #-}
 
+instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
+  => Binary (KindID prefix) where
+    put :: KindID prefix -> Put
+    put = put . toTypeID
+    {-# INLINE put #-}
+
+    get :: Get (KindID prefix)
+    get = do
+      tid <- get :: Get TypeID
+      case fromTypeID tid of
+        Nothing  -> fail "Binary: Prefix mismatch"
+        Just kid -> pure kid
+    {-# INLINE get #-}
+
 instance (ToPrefix prefix, ValidPrefix (PrefixSymbol prefix))
   => Hashable (KindID prefix) where
     hashWithSalt :: Int -> KindID prefix -> Int

diff --git a/src/Data/TypeID/Internal.hs b/src/Data/TypeID/Internal.hs
@@ -34,7 +34,6 @@ import           Data.TypeID.Error
 import           Data.UUID.Types.Internal (UUID(..))
 import qualified Data.UUID.Types.Internal as UUID
 import qualified Data.UUID.V7 as V7
-import           Data.Word
 
 -- | The constructor is not exposed to the public API to prevent generating
 -- invalid @TypeID@s.