summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEdwardKmett <>2013-03-28 08:56:48 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-03-28 08:56:48 (GMT)
commit5f7c846c952deb6642b3c2d4613e789e7c675f00 (patch)
tree5ba916dfc38863ff405ab1f6128e207ea3c2078b
parent0f1f710bd3f91d5125aaeb89b3581c0a983da502 (diff)
version 0.20.2
-rw-r--r--CHANGELOG.markdown4
-rw-r--r--bytes.cabal4
-rw-r--r--src/Data/Bytes/Put.hs7
-rw-r--r--src/Data/Bytes/Serial.hs211
4 files changed, 225 insertions, 1 deletions
diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown
index d86ca8a..f23a6d8 100644
--- a/CHANGELOG.markdown
+++ b/CHANGELOG.markdown
@@ -1,3 +1,7 @@
+0.2
+---
+* Added `Serial` and `Serial1`.
+
0.1
---
* Repository initialized
diff --git a/bytes.cabal b/bytes.cabal
index 813bdbc..1050eb5 100644
--- a/bytes.cabal
+++ b/bytes.cabal
@@ -1,6 +1,6 @@
name: bytes
category: Data, Serialization
-version: 0.1
+version: 0.2
license: BSD3
cabal-version: >= 1.8
license-file: LICENSE
@@ -45,12 +45,14 @@ library
binary >= 0.5 && < 0.8,
bytestring >= 0.9 && < 0.11,
cereal >= 0.3.5 && < 0.4,
+ ghc-prim,
mtl >= 2.0 && < 2.2,
transformers >= 0.2 && < 0.4,
transformers-compat >= 0.1 && < 1
exposed-modules:
Data.Bytes.Get
+ Data.Bytes.Serial
Data.Bytes.Put
if flag(lib-Werror)
diff --git a/src/Data/Bytes/Put.hs b/src/Data/Bytes/Put.hs
index 6085dfc..18209e7 100644
--- a/src/Data/Bytes/Put.hs
+++ b/src/Data/Bytes/Put.hs
@@ -2,6 +2,9 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------
-- |
-- Copyright : (c) Edward Kmett 2013
@@ -34,6 +37,10 @@ import Data.ByteString.Lazy as Lazy
import qualified Data.Serialize.Put as S
import Data.Word
+------------------------------------------------------------------------------
+-- MonadPut
+------------------------------------------------------------------------------
+
class Monad m => MonadPut m where
-- | Efficiently write a byte into the output buffer
putWord8 :: Word8 -> m ()
diff --git a/src/Data/Bytes/Serial.hs b/src/Data/Bytes/Serial.hs
new file mode 100644
index 0000000..0a82ef3
--- /dev/null
+++ b/src/Data/Bytes/Serial.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+--------------------------------------------------------------------
+-- |
+-- Copyright : (c) Edward Kmett 2013
+-- License : BSD3
+-- Maintainer: Edward Kmett <ekmett@gmail.com>
+-- Stability : experimental
+-- Portability: non-portable
+--
+-- This module generalizes the @binary@ 'B.PutM' and @cereal@ 'S.PutM'
+-- monads in an ad hoc fashion to permit code to be written that is
+-- compatible across them.
+--
+-- Moreover, this class permits code to be written to be portable over
+-- various monad transformers applied to these as base monads.
+--------------------------------------------------------------------
+module Data.Bytes.Serial
+ ( Serial(..)
+ , GSerial(..)
+ , Serial1(..), serialize1, deserialize1
+ , GSerial1(..)
+ ) where
+
+import Control.Monad
+import Data.Bytes.Get
+import Data.Bytes.Put
+import Data.Int
+import Data.Word
+import GHC.Generics
+
+------------------------------------------------------------------------------
+-- Serialization
+------------------------------------------------------------------------------
+
+class Serial a where
+ serialize :: MonadPut m => a -> m ()
+#ifndef HLINT
+ default serialize :: (MonadPut m, GSerial (Rep a), Generic a) => a -> m ()
+ serialize = gserialize . from
+#endif
+
+ deserialize :: MonadGet m => m a
+ default deserialize :: (MonadGet m, Generic a, GSerial (Rep a)) => m a
+ deserialize = liftM to gdeserialize
+
+instance Serial a => Serial [a]
+instance Serial a => Serial (Maybe a)
+instance (Serial a, Serial b) => Serial (Either a b)
+
+instance Serial Bool
+
+instance Serial Char where
+ serialize = putWord32host . fromIntegral . fromEnum
+ deserialize = liftM (toEnum . fromIntegral) getWord32host
+
+instance Serial Word where
+ serialize = putWordhost
+ deserialize = getWordhost
+
+instance Serial Word64 where
+ serialize = putWord64host
+ deserialize = getWord64host
+
+instance Serial Word32 where
+ serialize = putWord32host
+ deserialize = getWord32host
+
+instance Serial Word16 where
+ serialize = putWord16host
+ deserialize = getWord16host
+
+instance Serial Word8 where
+ serialize = putWord8
+ deserialize = getWord8
+
+instance Serial Int where
+ serialize = putWordhost . fromIntegral
+ deserialize = liftM fromIntegral getWordhost
+
+instance Serial Int64 where
+ serialize = putWord64host . fromIntegral
+ deserialize = liftM fromIntegral getWord64host
+
+instance Serial Int32 where
+ serialize = putWord32host . fromIntegral
+ deserialize = liftM fromIntegral getWord32host
+
+instance Serial Int16 where
+ serialize = putWord16host . fromIntegral
+ deserialize = liftM fromIntegral getWord16host
+
+instance Serial Int8 where
+ serialize = putWord8 . fromIntegral
+ deserialize = liftM fromIntegral getWord8
+
+------------------------------------------------------------------------------
+-- Generic Serialization
+------------------------------------------------------------------------------
+
+-- | Used internally to provide generic serialization
+class GSerial f where
+ gserialize :: MonadPut m => f a -> m ()
+ gdeserialize :: MonadGet m => m (f a)
+
+instance GSerial U1 where
+ gserialize U1 = return ()
+ gdeserialize = return U1
+
+instance GSerial V1 where
+ gserialize _ = fail "I looked into the void."
+ gdeserialize = fail "I looked into the void."
+
+instance (GSerial f, GSerial g) => GSerial (f :*: g) where
+ gserialize (f :*: g) = do
+ gserialize f
+ gserialize g
+ gdeserialize = liftM2 (:*:) gdeserialize gdeserialize
+
+instance (GSerial f, GSerial g) => GSerial (f :+: g) where
+ gserialize (L1 x) = putWord8 0 >> gserialize x
+ gserialize (R1 y) = putWord8 1 >> gserialize y
+ gdeserialize = getWord8 >>= \a -> case a of
+ 0 -> liftM L1 gdeserialize
+ 1 -> liftM R1 gdeserialize
+ _ -> fail "Missing case"
+
+instance GSerial f => GSerial (M1 i c f) where
+ gserialize (M1 x) = gserialize x
+ gdeserialize = liftM M1 gdeserialize
+
+instance Serial a => GSerial (K1 i a) where
+ gserialize (K1 x) = serialize x
+ gdeserialize = liftM K1 deserialize
+
+------------------------------------------------------------------------------
+-- Higher-Rank Serialization
+------------------------------------------------------------------------------
+
+class Serial1 f where
+ serializeWith :: MonadPut m => (a -> m ()) -> f a -> m ()
+#ifndef HLINT
+ default serializeWith :: (MonadPut m, GSerial1 (Rep1 f), Generic1 f) => (a -> m ()) -> f a -> m ()
+ serializeWith f = gserializeWith f . from1
+#endif
+
+ deserializeWith :: MonadGet m => m a -> m (f a)
+#ifndef HLINT
+ default deserializeWith :: (MonadGet m, GSerial1 (Rep1 f), Generic1 f) => m a -> m (f a)
+ deserializeWith f = liftM to1 (gdeserializeWith f)
+#endif
+
+serialize1 :: (MonadPut m, Serial1 f, Serial a) => f a -> m ()
+serialize1 = serializeWith serialize
+{-# INLINE serialize1 #-}
+
+deserialize1 :: (MonadGet m, Serial1 f, Serial a) => m (f a)
+deserialize1 = deserializeWith deserialize
+{-# INLINE deserialize1 #-}
+
+------------------------------------------------------------------------------
+-- Higher-Rank Generic Serialization
+------------------------------------------------------------------------------
+
+-- | Used internally to provide generic serialization
+class GSerial1 f where
+ gserializeWith :: MonadPut m => (a -> m ()) -> f a -> m ()
+ gdeserializeWith :: MonadGet m => m a -> m (f a)
+
+instance GSerial1 Par1 where
+ gserializeWith f (Par1 a) = f a
+ gdeserializeWith m = liftM Par1 m
+
+instance GSerial1 f => GSerial1 (Rec1 f) where
+ gserializeWith f (Rec1 fa) = gserializeWith f fa
+ gdeserializeWith m = liftM Rec1 (gdeserializeWith m)
+
+-- instance (Serial1 f, GSerial1 g) => GSerial1 (f :.: g) where
+
+instance GSerial1 U1 where
+ gserializeWith _ U1 = return ()
+ gdeserializeWith _ = return U1
+
+instance GSerial1 V1 where
+ gserializeWith _ = fail "I looked into the void."
+ gdeserializeWith _ = fail "I looked into the void."
+
+instance (GSerial1 f, GSerial1 g) => GSerial1 (f :*: g) where
+ gserializeWith f (a :*: b) = gserializeWith f a >> gserializeWith f b
+ gdeserializeWith m = liftM2 (:*:) (gdeserializeWith m) (gdeserializeWith m)
+
+instance (GSerial1 f, GSerial1 g) => GSerial1 (f :+: g) where
+ gserializeWith f (L1 x) = putWord8 0 >> gserializeWith f x
+ gserializeWith f (R1 y) = putWord8 1 >> gserializeWith f y
+ gdeserializeWith m = getWord8 >>= \a -> case a of
+ 0 -> liftM L1 (gdeserializeWith m)
+ 1 -> liftM R1 (gdeserializeWith m)
+ _ -> fail "Missing case"
+
+instance GSerial1 f => GSerial1 (M1 i c f) where
+ gserializeWith f (M1 x) = gserializeWith f x
+ gdeserializeWith = liftM M1 . gdeserializeWith
+
+instance Serial a => GSerial1 (K1 i a) where
+ gserializeWith _ (K1 x) = serialize x
+ gdeserializeWith _ = liftM K1 deserialize