data-serializer (empty) → 0.1

raw patch · 7 files changed

+1623/−0 lines, 7 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, cereal, data-endian, data-serializer, parsers, tasty, tasty-quickcheck

Files

LICENSE +27/−0
README.md +15/−0
Setup.hs +2/−0
data-serializer.cabal +56/−0
src/Data/Deserializer.hs +770/−0
src/Data/Serializer.hs +673/−0
tests/Tests.hs +80/−0

+ LICENSE view

@@ -0,0 +1,27 @@+Copyright (c) 2016 Mikhail Vorozhtsov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+  this list of conditions and the following disclaimer.+- Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the distribution.+- Neither the names of the copyright owners nor the names of the+  contributors may be used to endorse or promote products derived+  from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+

+ README.md view

@@ -0,0 +1,15 @@+Data-Serializer+===============++[![Hackage](https://img.shields.io/hackage/v/data-serializer.svg)](http://hackage.haskell.org/package/data-serializer)++This package provides a common API for serialization libraries like+[binary](http://hackage.haskell.org/package/binary) and+[cereal](http://hackage.haskell.org/package/cereal).++Installation+------------+The usual:++	$ cabal install+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ data-serializer.cabal view

@@ -0,0 +1,56 @@+Name: data-serializer+Version: 0.1+Category: Data+Stability: experimental+Synopsis: Common API for serialization libraries+Description:+  This package provides a common API for serialization libraries like+  <http://hackage.haskell.org/package/binary binary> and+  <http://hackage.haskell.org/package/cereal cereal>.++Homepage: https://github.com/mvv/data-serializer+Bug-Reports: https://github.com/mvv/data-serializer/issues++Author: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Maintainer: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+Copyright: 2016 Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>+License: BSD3+License-File: LICENSE++Extra-Source-Files:+  README.md++Cabal-Version: >= 1.10.0+Build-Type: Simple++Source-Repository head+  Type: git+  Location: https://github.com/mvv/data-serializer.git++Library+  Default-Language: Haskell2010+  Build-Depends: base >= 4.7 && < 5+               , bytestring >= 0.10.4+               , binary >= 0.7.2+               , cereal >= 0.5+               , data-endian >= 0.1.1+               , parsers >= 0.12.3+  Hs-Source-Dirs: src+  GHC-Options: -Wall+  Exposed-Modules:+    Data.Serializer+    Data.Deserializer++Test-Suite tests+  Default-Language: Haskell2010+  Type: exitcode-stdio-1.0+  Build-Depends: base+               , bytestring+               , binary+               , cereal+               , tasty >= 0.8+               , tasty-quickcheck >= 0.8+               , data-serializer+  Hs-Source-Dirs: tests+  GHC-Options: -Wall+  Main-Is: Tests.hs

+ src/Data/Deserializer.hs view

@@ -0,0 +1,770 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Deserialization monad and deserializable types.+module Data.Deserializer+  (+  -- * Deserialization monad+    Deserializer(..)+  , BinaryDeserializer(..)+  , CerealDeserializer(..)+  -- ** Binary word parsing+  , word16H+  , word32H+  , word64H+  , word+  , wordL+  , wordB+  , wordH+  , int8+  , int16+  , int16L+  , int16B+  , int16H+  , int32+  , int32L+  , int32B+  , int32H+  , int64+  , int64L+  , int64B+  , int64H+  , int+  , intL+  , intB+  , intH+  -- ** Parsing combinators+  , module Text.Parser.Combinators+  , label+  , module Text.Parser.LookAhead+  -- ** Endian deserializers+  , LittleEndianDeserializer(..)+  , BigEndianDeserializer(..)+  , deserializeIn+  , deserializeH+  -- * Deserializable types+  , Deserializable(..)+  , getIn+  , getL+  , getB+  , getH+  , RestDeserializable(..)+  ) where++import Prelude hiding (take)+import GHC.Generics (Generic)+import Data.Typeable (Typeable)+import Data.Data (Data)+import Data.Proxy (Proxy(..))+import Data.Endian (Endian(..), swapEndian)+import Data.Word+import Data.Int+import Data.Bits ((.|.), shiftL)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Short as SBS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Builder as BB+import qualified Data.Binary.Get as B+import qualified Data.Binary.Get.Internal as B+import qualified Data.Serialize.Get as S+import Text.Parser.Combinators+import Text.Parser.LookAhead+import Control.Applicative (Applicative(..), Alternative,+                            (<$>), (<$), (<*>), (*>), (<|>))+import Control.Monad (unless)++-- | Deserialization monad.+class (Monad μ, Parsing μ) ⇒ Deserializer μ where+  {-# MINIMAL ensure, take, chunk, isolate #-}+  -- | Default byte order of the deserializer.+  endian ∷ Proxy μ → Endian+#ifdef WORDS_BIGENDIAN+  endian _ = BigEndian+#else+  endian _ = LittleEndian+#endif+  -- | Deserialze a byte.+  word8 ∷ μ Word8+  word8 = BS.unsafeHead <$> take 1 <?> "word8"+  {-# INLINE word8 #-}+  -- | Deserialize an unsigned 16-bit integer in default byte order.+  word16 ∷ μ Word16+  word16 = getIn (endian (Proxy ∷ Proxy μ))+  {-# INLINE word16 #-}+  -- | Deserialize an unsigned 32-bit integer in default byte order.+  word32 ∷ μ Word32+  word32 = getIn (endian (Proxy ∷ Proxy μ))+  {-# INLINE word32 #-}+  -- | Deserialize an unsigned 64-bit integer in default byte order.+  word64 ∷ μ Word64+  word64 = getIn (endian (Proxy ∷ Proxy μ))+  {-# INLINE word64 #-}+  -- | Deserialize an unsigned 16-bit integer in little endian.+  word16L ∷ μ Word16+  word16L = (<?> "word16")+          $ do bs ← take 2+               let l = BS.unsafeIndex bs 0+                   h = BS.unsafeIndex bs 1+               return $ shiftL (fromIntegral h) 8 .|. fromIntegral l+  -- | Deserialize an unsigned 16-bit integer in big endian.+  word16B ∷ μ Word16+  word16B = swapEndian <$> word16L+  -- | Deserialize an unsigned 32-bit integer in little endian.+  word32L ∷ μ Word32+  word32L = (<?> "word32")+          $ do bs ← take 4+               let o₀ = BS.unsafeIndex bs 0+                   o₁ = BS.unsafeIndex bs 1+                   o₂ = BS.unsafeIndex bs 2+                   o₃ = BS.unsafeIndex bs 3+               return  $  shiftL (fromIntegral o₃) 24+                      .|. shiftL (fromIntegral o₂) 16+                      .|. shiftL (fromIntegral o₁) 8+                      .|. fromIntegral o₀+  -- | Deserialize an unsigned 32-bit integer in big endian.+  word32B ∷ μ Word32+  word32B = swapEndian <$> word32L+  -- | Deserialize an unsigned 64-bit integer in little endian.+  word64L ∷ μ Word64+  word64L = (<?> "word64")+          $ do bs ← take 8+               let o₀ = BS.unsafeIndex bs 0+                   o₁ = BS.unsafeIndex bs 1+                   o₂ = BS.unsafeIndex bs 2+                   o₃ = BS.unsafeIndex bs 3+                   o₄ = BS.unsafeIndex bs 4+                   o₅ = BS.unsafeIndex bs 5+                   o₆ = BS.unsafeIndex bs 6+                   o₇ = BS.unsafeIndex bs 7+               return  $  shiftL (fromIntegral o₇) 56+                      .|. shiftL (fromIntegral o₆) 48+                      .|. shiftL (fromIntegral o₅) 40+                      .|. shiftL (fromIntegral o₄) 32+                      .|. shiftL (fromIntegral o₃) 24+                      .|. shiftL (fromIntegral o₂) 16+                      .|. shiftL (fromIntegral o₁) 8+                      .|. fromIntegral o₀+  -- | Deserialize an unsigned 64-bit integer in big endian.+  word64B ∷ μ Word64+  word64B = swapEndian <$> word64L+  -- | 'satisfy' /p/ deserializes a byte that satisfies the predicate /p/,+  --   failing otherwise.+  satisfy ∷ (Word8 → Bool) → μ Word8+  satisfy p = do w ← word8+                 if p w then return w+                        else unexpected (show w)+  {-# INLINE satisfy #-}+  -- | Deserialize the specified byte value, failing on any other input.+  byte ∷ Word8 → μ Word8+  byte w = (<?> "byte " ++ show w)+         $ do w' ← word8+              if w' == w then return w'+                         else unexpected (show w')+  {-# INLINE byte #-}+  -- | 'notByte' /c/ deserializes any byte that is not equal to /c/, failing+  --   if /c/ is encountered.+  notByte ∷ Word8 → μ Word8+  notByte w = (<?> "not byte " ++ show w)+            $ do w' ← word8+                 if w' == w then unexpected (show w')+                            else return w'+  {-# INLINE notByte #-}+  -- | 'bytes' /bs/ deserializes a sequence of bytes given by /bs/, failing+  --   on any other input.+  bytes ∷ BS.ByteString → μ BS.ByteString+  bytes bs = (<?> "bytes " ++ show (BS.unpack bs))+           $ do bs' ← take (BS.length bs)+                if bs' == bs then return bs'+                             else unexpected (show $ BS.unpack bs')+  {-# INLINE bytes #-}+  -- | Skip exactly the given number of bytes.+  skip ∷ Int → μ ()+  skip n | n <= 0    = pure ()+         | otherwise = word8 *> skip (n - 1)+  -- | 'ensure' /n/ checks that the input has at least /n/ more bytes and+  --   returns a portion of the input of length greater or equal to /n/+  --   (without consuming it).+  ensure ∷ Int → μ BS.ByteString+  -- | 'ensure_' /n/ fails if the input has less than /n/ more bytes.+  ensure_ ∷ Int → μ ()+  ensure_ = (() <$) . ensure+  {-# INLINE ensure_ #-}+  -- | Consume exactly the given number of bytes.+  take ∷ Int → μ BS.ByteString+  -- | Consume a portion of the input (the size of the returned+  --   'BS.ByteString' is implementation dependent). Empty result means that+  --    the 'eof' is reached.+  chunk ∷ μ BS.ByteString+  -- | 'isolate' /n/ /d/ feeds the next /n/ bytes to the deserializer /d/.+  --   If /d/ consumes less or more that /n/ bytes, 'isolate' will fail.+  isolate ∷ Int → μ α → μ α++-- | A wrapper around the 'B.Get' monad (to avoid orphan instances).+newtype BinaryDeserializer α =+          BinaryDeserializer { binaryDeserializer ∷ B.Get α }+          deriving (Typeable, Generic, Functor, Applicative,+                    Alternative, Monad)++instance Parsing BinaryDeserializer where+  try p = p+  {-# INLINE try #-}+  p <?> l = BinaryDeserializer (B.label l (binaryDeserializer p))+  {-# INLINE (<?>) #-}+  skipMany p = ((True <$ p) <|> pure False) >>= \case+                 True  → skipMany p+                 False → return ()+  unexpected = fail+  {-# INLINE unexpected #-}+  eof = BinaryDeserializer+      $ B.isEmpty >>= \case+          True  → return ()+          False → fail "Parsing.eof"+  {-# INLINABLE eof #-}+  notFollowedBy p = BinaryDeserializer+                  $ (B.lookAheadE (Left <$> (binaryDeserializer p)) <|>+                     pure (Right ())) >>= \case+                      Left e  → fail (show e)+                      Right _ → return ()+  {-# INLINABLE notFollowedBy #-}++instance LookAheadParsing BinaryDeserializer where+  lookAhead = BinaryDeserializer . B.lookAhead . binaryDeserializer+  {-# INLINE lookAhead #-}++instance Deserializer BinaryDeserializer where+  word8 = BinaryDeserializer B.getWord8+  {-# INLINE word8 #-}+  word16L = BinaryDeserializer B.getWord16le+  {-# INLINE word16L #-}+  word16B = BinaryDeserializer B.getWord16be+  {-# INLINE word16B #-}+  word32L = BinaryDeserializer B.getWord32le+  {-# INLINE word32L #-}+  word32B = BinaryDeserializer B.getWord32be+  {-# INLINE word32B #-}+  word64L = BinaryDeserializer B.getWord64le+  {-# INLINE word64L #-}+  word64B = BinaryDeserializer B.getWord64be+  {-# INLINE word64B #-}+  skip = BinaryDeserializer . B.skip+  {-# INLINE skip #-}+  ensure n = BinaryDeserializer (B.ensureN n *> B.get)+  {-# INLINE ensure #-}+  ensure_ = BinaryDeserializer . B.ensureN+  {-# INLINE ensure_ #-}+  take = BinaryDeserializer . B.getByteString+  {-# INLINE take #-}+  chunk = BinaryDeserializer+        $ do bs ← B.get+             if BS.null bs+             then do+               e ← B.isEmpty+               if e+               then return bs+               else B.get+             else+               return bs+  {-# INLINABLE chunk #-}+  isolate n d = BinaryDeserializer $ B.isolate n (binaryDeserializer d)+  {-# INLINE isolate #-}++-- | A wrapper around the 'S.Get' monad (to avoid orphan instances).+newtype CerealDeserializer α =+          CerealDeserializer { cerealDeserializer ∷ S.Get α }+          deriving (Typeable, Generic,  Functor, Applicative,+                    Alternative, Monad)++instance Parsing CerealDeserializer where+  try p = p+  {-# INLINE try #-}+  p <?> l = CerealDeserializer (S.label l (cerealDeserializer p))+  {-# INLINE (<?>) #-}+  skipMany p = ((True <$ p) <|> pure False) >>= \case+                 True  → skipMany p+                 False → return ()+  unexpected = fail+  {-# INLINE unexpected #-}+  eof = CerealDeserializer+      $ ((False <$ S.lookAheadM (Nothing <$ S.getWord8)) <|>+         pure True) >>= \case+          True  → return ()+          False → fail "Parsing.eof"+  {-# INLINABLE eof #-}+  notFollowedBy p = CerealDeserializer+                  $ (S.lookAheadE (Left <$> (cerealDeserializer p)) <|>+                     pure (Right ())) >>= \case+                      Left e  → fail (show e)+                      Right _ → return ()+  {-# INLINABLE notFollowedBy #-}++instance LookAheadParsing CerealDeserializer where+  lookAhead = CerealDeserializer . S.lookAhead . cerealDeserializer+  {-# INLINE lookAhead #-}++instance Deserializer CerealDeserializer where+  word8 = CerealDeserializer S.getWord8+  {-# INLINE word8 #-}+  word16L = CerealDeserializer S.getWord16le+  {-# INLINE word16L #-}+  word16B = CerealDeserializer S.getWord16be+  {-# INLINE word16B #-}+  word32L = CerealDeserializer S.getWord32le+  {-# INLINE word32L #-}+  word32B = CerealDeserializer S.getWord32be+  {-# INLINE word32B #-}+  word64L = CerealDeserializer S.getWord64le+  {-# INLINE word64L #-}+  word64B = CerealDeserializer S.getWord64be+  {-# INLINE word64B #-}+  skip = CerealDeserializer . S.skip+  {-# INLINE skip #-}+  ensure = CerealDeserializer . S.ensure+  {-# INLINE ensure #-}+  take = CerealDeserializer . S.getBytes+  {-# INLINE take #-}+  chunk = CerealDeserializer+        $ (<|> pure BS.empty)+        $ do bs ← S.ensure 1+             S.uncheckedSkip (BS.length bs)+             return bs+  {-# INLINE chunk #-}+  isolate n d = CerealDeserializer (S.isolate n (cerealDeserializer d))+  {-# INLINE isolate #-}++-- | Deserialize an unsigned 16-bit integer in host byte order.+word16H ∷ Deserializer μ ⇒ μ Word16+#ifdef WORDS_BIGENDIAN+word16H = word16B+#else+word16H = word16L+#endif+{-# INLINE word16H #-}++-- | Deserialize an unsigned 32-bit integer in host byte order.+word32H ∷ Deserializer μ ⇒ μ Word32+#ifdef WORDS_BIGENDIAN+word32H = word32B+#else+word32H = word32L+#endif+{-# INLINE word32H #-}++-- | Deserialize an unsigned 64-bit integer in host byte order.+word64H ∷ Deserializer μ ⇒ μ Word64+#ifdef WORDS_BIGENDIAN+word64H = word64B+#else+word64H = word64L+#endif+{-# INLINE word64H #-}++-- | Deserialize an unsigned native-sized integer in serializer default+--   byte order.+word ∷ Deserializer μ ⇒ μ Word+#if WORD_SIZE_IN_BITS == 32+word = fromIntegral <$> word32+#else+word = fromIntegral <$> word64+#endif+{-# INLINE word #-}++-- | Deserialize an unsigned native-sized integer in little endian.+wordL ∷ Deserializer μ ⇒ μ Word+#if WORD_SIZE_IN_BITS == 32+wordL = fromIntegral <$> word32L+#else+wordL = fromIntegral <$> word64L+#endif+{-# INLINE wordL #-}++-- | Deserialize an unsigned native-sized integer in big endian.+wordB ∷ Deserializer μ ⇒ μ Word+#if WORD_SIZE_IN_BITS == 32+wordB = fromIntegral <$> word32B+#else+wordB = fromIntegral <$> word64B+#endif+{-# INLINE wordB #-}++-- | Deserialize an unsigned native-sized integer in host byte order.+wordH ∷ Deserializer μ ⇒ μ Word+#ifdef WORDS_BIGENDIAN+wordH = wordB+#else+wordH = wordL+#endif+{-# INLINE wordH #-}++-- | Deserialize a signed 8-bit integer.+int8 ∷ Deserializer μ ⇒ μ Int8+int8 = fromIntegral <$> word8+{-# INLINE int8 #-}++-- | Deserialize a signed 16-bit integer in serializer default byte order.+int16 ∷ Deserializer μ ⇒ μ Int16+int16 = fromIntegral <$> word16+{-# INLINE int16 #-}++-- | Deserialize a signed 16-bit integer in little endian.+int16L ∷ Deserializer μ ⇒ μ Int16+int16L = fromIntegral <$> word16L+{-# INLINE int16L #-}++-- | Deserialize a signed 16-bit integer in big endian.+int16B ∷ Deserializer μ ⇒ μ Int16+int16B = fromIntegral <$> word16B+{-# INLINE int16B #-}++-- | Deserialize a signed 16-bit integer in host byte order.+int16H ∷ Deserializer μ ⇒ μ Int16+int16H = fromIntegral <$> word16H+{-# INLINE int16H #-}++-- | Deserialize a signed 32-bit integer in serializer default byte order.+int32 ∷ Deserializer μ ⇒ μ Int32+int32 = fromIntegral <$> word32+{-# INLINE int32 #-}++-- | Deserialize a signed 32-bit integer in little endian.+int32L ∷ Deserializer μ ⇒ μ Int32+int32L = fromIntegral <$> word32L+{-# INLINE int32L #-}++-- | Deserialize a signed 32-bit integer in big endian.+int32B ∷ Deserializer μ ⇒ μ Int32+int32B = fromIntegral <$> word32B+{-# INLINE int32B #-}++-- | Deserialize a signed 32-bit integer in host byte order.+int32H ∷ Deserializer μ ⇒ μ Int32+int32H = fromIntegral <$> word32H+{-# INLINE int32H #-}++-- | Deserialize a signed 64-bit integer in serializer default byte order.+int64 ∷ Deserializer μ ⇒ μ Int64+int64 = fromIntegral <$> word64+{-# INLINE int64 #-}++-- | Deserialize a signed 64-bit integer in little endian.+int64L ∷ Deserializer μ ⇒ μ Int64+int64L = fromIntegral <$> word64L+{-# INLINE int64L #-}++-- | Deserialize a signed 64-bit integer in big endian.+int64B ∷ Deserializer μ ⇒ μ Int64+int64B = fromIntegral <$> word64B+{-# INLINE int64B #-}++-- | Deserialize a signed 64-bit integer in host byte order.+int64H ∷ Deserializer μ ⇒ μ Int64+int64H = fromIntegral <$> word64H+{-# INLINE int64H #-}++-- | Deserialize a signed native-sized integer in serializer default byte+--   order.+int ∷ Deserializer μ ⇒ μ Int+#if WORD_SIZE_IN_BITS == 32+int = fromIntegral <$> int32+#else+int = fromIntegral <$> int64+#endif+{-# INLINE int #-}++-- | Deserialize a signed native-sized integer in little endian.+intL ∷ Deserializer μ ⇒ μ Int+#if WORD_SIZE_IN_BITS == 32+intL = fromIntegral <$> int32L+#else+intL = fromIntegral <$> int64L+#endif+{-# INLINE intL #-}++-- | Deserialize a signed native-sized integer in big endian.+intB ∷ Deserializer μ ⇒ μ Int+#if WORD_SIZE_IN_BITS == 32+intB = fromIntegral <$> int32B+#else+intB = fromIntegral <$> int64B+#endif+{-# INLINE intB #-}++-- | Deserialize a signed native-sized integer in host byte order.+intH ∷ Deserializer μ ⇒ μ Int+#if WORD_SIZE_IN_BITS == 32+intH = fromIntegral <$> int32H+#else+intH = fromIntegral <$> int64H+#endif+{-# INLINE intH #-}++-- | A shorthand for 'flip' ('<?>').+label ∷ Parsing μ ⇒ String → μ α → μ α+label = flip (<?>)+{-# INLINE label #-}++-- | Deserializer wrapper with little endian default byte order.+newtype LittleEndianDeserializer μ α =+          LittleEndianDeserializer { deserializeL ∷ μ α }+          deriving (Typeable, Data, Generic, Functor, Applicative,+                    Alternative, Monad, Parsing, LookAheadParsing)++instance Deserializer μ ⇒ Deserializer (LittleEndianDeserializer μ) where+  endian _ = LittleEndian+  {-# INLINE endian #-}+  word8 = LittleEndianDeserializer word8+  {-# INLINE word8 #-}+  word16 = LittleEndianDeserializer word16L+  {-# INLINE word16 #-}+  word32 = LittleEndianDeserializer word32L+  {-# INLINE word32 #-}+  word64 = LittleEndianDeserializer word64L+  {-# INLINE word64 #-}+  word16L = LittleEndianDeserializer word16L+  {-# INLINE word16L #-}+  word16B = LittleEndianDeserializer word16B+  {-# INLINE word16B #-}+  word32L = LittleEndianDeserializer word32L+  {-# INLINE word32L #-}+  word32B = LittleEndianDeserializer word32B+  {-# INLINE word32B #-}+  word64L = LittleEndianDeserializer word64L+  {-# INLINE word64L #-}+  word64B = LittleEndianDeserializer word64B+  {-# INLINE word64B #-}+  satisfy = LittleEndianDeserializer . satisfy+  {-# INLINE satisfy #-}+  byte = LittleEndianDeserializer . byte+  {-# INLINE byte #-}+  notByte = LittleEndianDeserializer . notByte+  {-# INLINE notByte #-}+  bytes = LittleEndianDeserializer . bytes+  {-# INLINE bytes #-}+  skip = LittleEndianDeserializer . skip+  {-# INLINE skip #-}+  ensure = LittleEndianDeserializer . ensure+  {-# INLINE ensure #-}+  ensure_ = LittleEndianDeserializer . ensure_+  {-# INLINE ensure_ #-}+  take = LittleEndianDeserializer . take+  {-# INLINE take #-}+  chunk = LittleEndianDeserializer chunk+  {-# INLINE chunk #-}+  isolate n = LittleEndianDeserializer . isolate n . deserializeL+  {-# INLINE isolate #-}++-- | Deserializer wrapper with big endian default byte order.+newtype BigEndianDeserializer μ α =+          BigEndianDeserializer { deserializeB ∷ μ α }+          deriving (Typeable, Data, Generic, Functor, Applicative,+                    Alternative, Monad, Parsing, LookAheadParsing)++instance Deserializer μ ⇒ Deserializer (BigEndianDeserializer μ) where+  endian _ = BigEndian+  {-# INLINE endian #-}+  word8 = BigEndianDeserializer word8+  {-# INLINE word8 #-}+  word16 = BigEndianDeserializer word16B+  {-# INLINE word16 #-}+  word32 = BigEndianDeserializer word32B+  {-# INLINE word32 #-}+  word64 = BigEndianDeserializer word64B+  {-# INLINE word64 #-}+  word16L = BigEndianDeserializer word16L+  {-# INLINE word16L #-}+  word16B = BigEndianDeserializer word16B+  {-# INLINE word16B #-}+  word32L = BigEndianDeserializer word32L+  {-# INLINE word32L #-}+  word32B = BigEndianDeserializer word32B+  {-# INLINE word32B #-}+  word64L = BigEndianDeserializer word64L+  {-# INLINE word64L #-}+  word64B = BigEndianDeserializer word64B+  {-# INLINE word64B #-}+  satisfy = BigEndianDeserializer . satisfy+  {-# INLINE satisfy #-}+  byte = BigEndianDeserializer . byte+  {-# INLINE byte #-}+  notByte = BigEndianDeserializer . notByte+  {-# INLINE notByte #-}+  bytes = BigEndianDeserializer . bytes+  {-# INLINE bytes #-}+  skip = BigEndianDeserializer . skip+  {-# INLINE skip #-}+  ensure = BigEndianDeserializer . ensure+  {-# INLINE ensure #-}+  ensure_ = BigEndianDeserializer . ensure_+  {-# INLINE ensure_ #-}+  take = BigEndianDeserializer . take+  {-# INLINE take #-}+  chunk = BigEndianDeserializer chunk+  {-# INLINE chunk #-}+  isolate n = BigEndianDeserializer . isolate n . deserializeB+  {-# INLINE isolate #-}++-- | Force the default byte order.+deserializeIn ∷ Deserializer μ+              ⇒ Endian → (∀ μ' . (Deserializer μ') ⇒ μ' α) → μ α+deserializeIn LittleEndian = deserializeL+deserializeIn BigEndian    = deserializeB+{-# INLINE deserializeIn #-}++-- | Force the default byte order to be the host byte order.+deserializeH ∷ Deserializer μ ⇒ (∀ μ' . (Deserializer μ') ⇒ μ' α) → μ α+#ifdef WORDS_BIGENDIAN+deserializeH = deserializeB+#else+deserializeH = deserializeL+#endif++-- | Deserializable type. 'get' must not rely on 'eof'.+class Deserializable α where+  get ∷ Deserializer μ ⇒ μ α++instance Deserializable Bool where+  get = do w ← word8+           case w of+             0 → return False+             1 → return True+             _ → unexpected (show w)++instance Deserializable Word8 where+  get = word8+  {-# INLINE get #-}++instance Deserializable Word16 where+  get = word16+  {-# INLINE get #-}++instance Deserializable Word32 where+  get = word32+  {-# INLINE get #-}++instance Deserializable Word64 where+  get = word64+  {-# INLINE get #-}++instance Deserializable Word where+  get = word+  {-# INLINE get #-}++instance Deserializable Int8 where+  get = int8+  {-# INLINE get #-}++instance Deserializable Int16 where+  get = int16+  {-# INLINE get #-}++instance Deserializable Int32 where+  get = int32+  {-# INLINE get #-}++instance Deserializable Int64 where+  get = int64+  {-# INLINE get #-}++instance Deserializable Int where+  get = int+  {-# INLINE get #-}++instance (Deserializable α, Deserializable β) ⇒ Deserializable (α, β) where+  get = (,) <$> get <*> get+  {-# INLINE get #-}++instance Deserializable α ⇒ Deserializable (Maybe α) where+  get = do w ← word8+           case w of+             0 → return Nothing+             1 → Just <$> get+             _ → unexpected (show w)++instance (Deserializable α, Deserializable β)+         ⇒ Deserializable (Either α β) where+  get = do w ← word8+           case w of+             0 → Left <$> get+             1 → Right <$> get+             _ → unexpected (show w)++instance Deserializable BS.ByteString where+  get = do l ← int <?> "length"+           unless (l >= 0) $ unexpected "negative length"+           take l <?> "contents"+  {-# INLINABLE get #-}++instance Deserializable SBS.ShortByteString where+  get = SBS.toShort <$> get+  {-# INLINE get #-}++-- | Deserialize a value using the provided default byte order.+getIn ∷ (Deserializer μ, Deserializable α) ⇒ Endian → μ α+getIn e = deserializeIn e get+{-# INLINE getIn #-}++-- | Deserialize a value using little endian as the default byte order.+getL ∷ (Deserializer μ, Deserializable α) ⇒ μ α+getL = deserializeL get+{-# INLINE getL #-}++-- | Deserialize a value using big endian as the default byte order.+getB ∷ (Deserializer μ, Deserializable α) ⇒ μ α+getB = deserializeB get+{-# INLINE getB #-}++-- | Deserialize a value using host byte order as the default byte order.+getH ∷ (Deserializer μ, Deserializable α) ⇒ μ α+#ifdef WORDS_BIGENDIAN+getH = getB+#else+getH = getL+#endif+{-# INLINE getH #-}++-- | Deserializable type. 'getRest' must consume all the remaining input+--   or fail.+class RestDeserializable α where+  getRest ∷ Deserializer μ ⇒ μ α++instance RestDeserializable BS.ByteString where+  getRest = go []+    where go acc = do bs ← chunk+                      if BS.null bs then return $ BS.concat $ reverse acc+                                    else go (bs : acc)++instance RestDeserializable SBS.ShortByteString where+  getRest = SBS.toShort <$> getRest+  {-# INLINE getRest #-}++instance RestDeserializable LBS.ByteString where+  getRest = go []+    where go acc = do bs ← chunk+                      if BS.null bs then return $ LBS.fromChunks $ reverse acc+                                    else go (bs : acc)++instance RestDeserializable BB.Builder where+  getRest = BB.lazyByteString <$> getRest+  {-# INLINE getRest #-}++instance (RestDeserializable α, RestDeserializable β)+         ⇒ RestDeserializable (Either α β) where+  getRest = word8 >>= \case+              0 → Left <$> getRest+              1 → Right <$> getRest+              w → unexpected (show w)+  {-# INLINABLE getRest #-}++instance (Deserializable α, RestDeserializable β)+         ⇒ RestDeserializable (α, β) where+  getRest = (,) <$> get <*> getRest+  {-# INLINE getRest #-}++instance Deserializable α ⇒ RestDeserializable [α] where+  getRest = ([] <$ eof) <|> ((:) <$> get <*> getRest)

+ src/Data/Serializer.hs view

@@ -0,0 +1,673 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Serialization monoid and serializable types.+module Data.Serializer+  (+  -- * Serialization monoid+    Serializer(..)+  -- ** Binary words serialization+  , word16H+  , word32H+  , word64H+  , word+  , wordL+  , wordB+  , wordH+  , int8+  , int16+  , int16L+  , int16B+  , int16H+  , int32+  , int32L+  , int32B+  , int32H+  , int64+  , int64L+  , int64B+  , int64H+  , int+  , intL+  , intB+  , intH+  -- ** Endian serializers+  , LittleEndianSerializer(..)+  , BigEndianSerializer(..)+  , serializeIn+  , serializeH+  -- * Serializable types+  , Serializable(..)+  , putIn+  , putL+  , putB+  , putH+  , SizedSerializable(..)+  , RestSerializable(..)+  ) where++import GHC.Generics (Generic)+import Data.Typeable (Typeable)+import Data.Data (Data)+import Data.Proxy (Proxy(..))+import Data.Monoid (Monoid, (<>))+import Data.Endian (Endian(..), swapEndian)+import Data.Word+import Data.Int+import Data.Bits (shiftR)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Builder as BB+import qualified Data.Binary.Put as B+import qualified Data.Serialize.Put as S++-- | Serialization monoid.+class Monoid s ⇒ Serializer s where+  {-# MINIMAL word8 #-}+  -- | Default byte order of the serializer.+  endian ∷ Proxy s → Endian+#ifdef WORDS_BIGENDIAN+  endian _ = BigEndian+#else+  endian _ = LittleEndian+#endif+  {-# INLINE endian #-}+  -- | Serialize a byte. 'word8' /x/ = 'byteString' ('BS.singleton' /x/)+  word8 ∷ Word8 → s+  -- | Serialize an unsigned 16-bit integer in the default byte order.+  word16 ∷ Word16 → s+  word16 = putIn (endian (Proxy ∷ Proxy s))+  {-# INLINE word16 #-}+  -- | Serialize an unsigned 32-bit integer in the default byte order.+  word32 ∷ Word32 → s+  word32 = putIn (endian (Proxy ∷ Proxy s))+  {-# INLINE word32 #-}+  -- | Serialize an unsigned 64-bit integer in the default byte order.+  word64 ∷ Word64 → s+  word64 = putIn (endian (Proxy ∷ Proxy s))+  {-# INLINE word64 #-}+  -- | Serialize an unsigned 16-bit integer in little endian.+  word16L ∷ Word16 → s+  word16L w =  word8 (fromIntegral w)+            <> word8 (fromIntegral (shiftR w 8))+  {-# INLINE word16L #-}+  -- | Serialize an unsigned 16-bit integer in big endian.+  word16B ∷ Word16 → s+  word16B = word16L . swapEndian+  {-# INLINE word16B #-}+  -- | Serialize an unsigned 32-bit integer in little endian.+  word32L ∷ Word32 → s+  word32L w =  word8 (fromIntegral w)+            <> word8 (fromIntegral (shiftR w 8))+            <> word8 (fromIntegral (shiftR w 16))+            <> word8 (fromIntegral (shiftR w 24))+  {-# INLINE word32L #-}+  -- | Serialize an unsigned 32-bit integer in big endian.+  word32B ∷ Word32 → s+  word32B = word32L . swapEndian+  {-# INLINE word32B #-}+  -- | Serialize an unsigned 64-bit integer in little endian.+  word64L ∷ Word64 → s+  word64L w =  word8 (fromIntegral w)+            <> word8 (fromIntegral (shiftR w 8))+            <> word8 (fromIntegral (shiftR w 16))+            <> word8 (fromIntegral (shiftR w 24))+            <> word8 (fromIntegral (shiftR w 32))+            <> word8 (fromIntegral (shiftR w 40))+            <> word8 (fromIntegral (shiftR w 48))+            <> word8 (fromIntegral (shiftR w 56))+  {-# INLINE word64L #-}+  -- | Serialize an unsigned 64-bit integer in big endian.+  word64B ∷ Word64 → s+  word64B = word64L . swapEndian+  {-# INLINE word64B #-}+  -- | Serialize a 'BS.ByteString'. Must be a monoid homomorphism.+  byteString ∷ BS.ByteString → s+  byteString = mconcat . fmap word8 . BS.unpack+  {-# INLINE byteString #-}+  -- | Serialize a 'SBS.ShortByteString'. Must be a monoid homomorphism.+  shortByteString ∷ SBS.ShortByteString → s+  shortByteString = mconcat . fmap word8 . SBS.unpack+  {-# INLINE shortByteString #-}+  -- | Serialize a lazy 'LBS.ByteString'. Must be a monoid homomorphism.+  lazyByteString ∷ LBS.ByteString → s+  lazyByteString = mconcat . fmap byteString . LBS.toChunks+  {-# INLINE lazyByteString #-}+  -- | Serialize a 'BB.Builder'. Must be a monoid homomorphism.+  builder ∷ BB.Builder → s+  builder = lazyByteString . BB.toLazyByteString+  {-# INLINE builder #-}++instance Serializer [Word8] where+  word8 = pure+  {-# INLINE word8 #-}++instance Serializer BB.Builder where+  word8 = BB.word8+  {-# INLINE word8 #-}+  word16L = BB.word16LE+  {-# INLINE word16L #-}+  word16B = BB.word16BE+  {-# INLINE word16B #-}+  word32L = BB.word32LE+  {-# INLINE word32L #-}+  word32B = BB.word32BE+  {-# INLINE word32B #-}+  word64L = BB.word64LE+  {-# INLINE word64L #-}+  word64B = BB.word64BE+  {-# INLINE word64B #-}+  byteString = BB.byteString+  {-# INLINE byteString #-}+  shortByteString = BB.shortByteString+  {-# INLINE shortByteString #-}+  lazyByteString = BB.lazyByteString+  {-# INLINE lazyByteString #-}+  builder = id+  {-# INLINE builder #-}++instance Serializer B.Put where+  word8 = B.putWord8+  {-# INLINE word8 #-}+  word16L = B.putWord16le+  {-# INLINE word16L #-}+  word16B = B.putWord16be+  {-# INLINE word16B #-}+  word32L = B.putWord32le+  {-# INLINE word32L #-}+  word32B = B.putWord32be+  {-# INLINE word32B #-}+  word64L = B.putWord64le+  {-# INLINE word64L #-}+  word64B = B.putWord64be+  {-# INLINE word64B #-}+  byteString = B.putByteString+  {-# INLINE byteString #-}+  shortByteString = B.putShortByteString+  {-# INLINE shortByteString #-}+  lazyByteString = B.putLazyByteString+  {-# INLINE lazyByteString #-}+  builder = B.putBuilder+  {-# INLINE builder #-}++#if !MIN_VERSION_cereal(0,5,3)+instance Monoid S.Put where+  mempty = return ()+  {-# INLINE mempty #-}+  mappend = (>>)+  {-# INLINE mappend #-}+#endif++instance Serializer S.Put where+  word8 = S.putWord8+  {-# INLINE word8 #-}+  word16L = S.putWord16le+  {-# INLINE word16L #-}+  word16B = S.putWord16be+  {-# INLINE word16B #-}+  word32L = S.putWord32le+  {-# INLINE word32L #-}+  word32B = S.putWord32be+  {-# INLINE word32B #-}+  word64L = S.putWord64le+  {-# INLINE word64L #-}+  word64B = S.putWord64be+  {-# INLINE word64B #-}+  byteString = S.putByteString+  {-# INLINE byteString #-}+  shortByteString = S.putShortByteString+  {-# INLINE shortByteString #-}+  lazyByteString = S.putLazyByteString+  {-# INLINE lazyByteString #-}+  builder = S.putBuilder+  {-# INLINE builder #-}++-- | Serialize an usigned 16-bit integer in host byte order.+word16H ∷ Serializer s ⇒ Word16 → s+#ifdef WORDS_BIGENDIAN+word16H = word16B+#else+word16H = word16L+#endif+{-# INLINE word16H #-}++-- | Serialize an unsigned 32-bit integer in host byte order.+word32H ∷ Serializer s ⇒ Word32 → s+#ifdef WORDS_BIGENDIAN+word32H = word32B+#else+word32H = word32L+#endif+{-# INLINE word32H #-}++-- | Serialize an unsigned 64-bit integer in host byte order.+word64H ∷ Serializer s ⇒ Word64 → s+#ifdef WORDS_BIGENDIAN+word64H = word64B+#else+word64H = word64L+#endif+{-# INLINE word64H #-}++-- | Serialize an unsigned native-sized integer in serializer default+--   byte order.+word ∷ Serializer s ⇒ Word → s+#ifdef WORDS_BIGENDIAN+word = wordB+#else+word = wordL+#endif+{-# INLINE word #-}++-- | Serialize an unsigned native-sized integer in little endian.+wordL ∷ Serializer s ⇒ Word → s+#if WORD_SIZE_IN_BITS == 32+wordL = word32L . fromIntegral+#else+wordL = word64L . fromIntegral+#endif+{-# INLINE wordL #-}++-- | Serialize an unsigned native-sized integer in big endian.+wordB ∷ Serializer s ⇒ Word → s+#if WORD_SIZE_IN_BITS == 32+wordB = word32B . fromIntegral+#else+wordB = word64B . fromIntegral+#endif+{-# INLINE wordB #-}++-- | Serialize an unsigned native-sized integer in host byte order.+wordH ∷ Serializer s ⇒ Word → s+#if WORD_SIZE_IN_BITS == 32+wordH = word32H . fromIntegral+#else+wordH = word64H . fromIntegral+#endif+{-# INLINE wordH #-}++-- | Serialize a signed 8-bit integer.+int8 ∷ Serializer s ⇒ Int8 → s+int8 = word8 . fromIntegral+{-# INLINE int8 #-}++-- | Serialize a signed 16-bit integer in serializer default byte order.+int16 ∷ Serializer s ⇒ Int16 → s+int16 = word16 . fromIntegral+{-# INLINE int16 #-}++-- | Serialize a signed 16-bit integer in little endian.+int16L ∷ Serializer s ⇒ Int16 → s+int16L = word16L . fromIntegral+{-# INLINE int16L #-}++-- | Serialize a signed 16-bit integer in big endian.+int16B ∷ Serializer s ⇒ Int16 → s+int16B = word16B . fromIntegral+{-# INLINE int16B #-}++-- | Serialize a signed 16-bit integer in host byte order.+int16H ∷ Serializer s ⇒ Int16 → s+#ifdef WORDS_BIGENDIAN+int16H = int16B+#else+int16H = int16L+#endif+{-# INLINE int16H #-}++-- | Serialize a signed 32-bit integer in serializer default byte order.+int32 ∷ Serializer s ⇒ Int32 → s+int32 = word32 . fromIntegral+{-# INLINE int32 #-}++-- | Serialize a signed 32-bit integer in little endian.+int32L ∷ Serializer s ⇒ Int32 → s+int32L = word32L . fromIntegral+{-# INLINE int32L #-}++-- | Serialize a signed 32-bit integer in big endian.+int32B ∷ Serializer s ⇒ Int32 → s+int32B = word32B . fromIntegral+{-# INLINE int32B #-}++-- | Serialize a signed 32-bit integer in host byte order.+int32H ∷ Serializer s ⇒ Int32 → s+#ifdef WORDS_BIGENDIAN+int32H = int32B+#else+int32H = int32L+#endif+{-# INLINE int32H #-}++-- | Serialize a signed 64-bit integer in serializer default byte order.+int64 ∷ Serializer s ⇒ Int64 → s+int64 = word64 . fromIntegral+{-# INLINE int64 #-}++-- | Serialize a signed 64-bit integer in little endian.+int64L ∷ Serializer s ⇒ Int64 → s+int64L = word64L . fromIntegral+{-# INLINE int64L #-}++-- | Serialize a signed 64-bit integer in big endian.+int64B ∷ Serializer s ⇒ Int64 → s+int64B = word64B . fromIntegral+{-# INLINE int64B #-}++-- | Serialize a signed 64-bit integer in host byte order.+int64H ∷ Serializer s ⇒ Int64 → s+#ifdef WORDS_BIGENDIAN+int64H = int64B+#else+int64H = int64L+#endif+{-# INLINE int64H #-}++-- | Serialize a signed native-sized integer in serializer default byte order.+int ∷ Serializer s ⇒ Int → s+#ifdef WORDS_BIGENDIAN+int = intB+#else+int = intL+#endif+{-# INLINE int #-}++-- | Serialize a signed native-sized integer in little endian.+intL ∷ Serializer s ⇒ Int → s+#if WORD_SIZE_IN_BITS == 32+intL = word32L . fromIntegral+#else+intL = word64L . fromIntegral+#endif+{-# INLINE intL #-}++-- | Serialize a signed native-sized integer in big endian.+intB ∷ Serializer s ⇒ Int64 → s+#if WORD_SIZE_IN_BITS == 32+intB = word32B . fromIntegral+#else+intB = word64B . fromIntegral+#endif+{-# INLINE intB #-}++-- | Serialize a signed native-sized integer in host byte order.+intH ∷ Serializer s ⇒ Int → s+#if WORD_SIZE_IN_BITS == 32+intH = word32H . fromIntegral+#else+intH = word64H . fromIntegral+#endif+{-# INLINE intH #-}++-- | Serializer wrapper with little endian default byte order.+newtype LittleEndianSerializer s = LittleEndianSerializer { serializeL ∷ s }+                                   deriving (Typeable, Data, Generic, Monoid)++instance Serializer s ⇒ Serializer (LittleEndianSerializer s) where+  endian _ = LittleEndian+  {-# INLINE endian #-}+  word8 = LittleEndianSerializer . word8+  {-# INLINE word8 #-}+  word16 = LittleEndianSerializer . word16L+  {-# INLINE word16 #-}+  word32 = LittleEndianSerializer . word32L+  {-# INLINE word32 #-}+  word64 = LittleEndianSerializer . word64L+  {-# INLINE word64 #-}+  word16L = LittleEndianSerializer . word16L+  {-# INLINE word16L #-}+  word16B = LittleEndianSerializer . word16B+  {-# INLINE word16B #-}+  word32L = LittleEndianSerializer . word32L+  {-# INLINE word32L #-}+  word32B = LittleEndianSerializer . word32B+  {-# INLINE word32B #-}+  word64L = LittleEndianSerializer . word64L+  {-# INLINE word64L #-}+  word64B = LittleEndianSerializer . word64B+  {-# INLINE word64B #-}+  byteString = LittleEndianSerializer . byteString+  {-# INLINE byteString #-}+  shortByteString = LittleEndianSerializer . shortByteString+  {-# INLINE shortByteString #-}+  lazyByteString = LittleEndianSerializer . lazyByteString+  {-# INLINE lazyByteString #-}+  builder = LittleEndianSerializer . builder+  {-# INLINE builder #-}++-- | Serializer wrapper with big endian default byte order.+newtype BigEndianSerializer s = BigEndianSerializer { serializeB ∷ s }+                                deriving (Typeable, Data, Generic, Monoid)++instance Serializer s ⇒ Serializer (BigEndianSerializer s) where+  endian _ = BigEndian+  {-# INLINE endian #-}+  word8 = BigEndianSerializer . word8+  {-# INLINE word8 #-}+  word16 = BigEndianSerializer . word16B+  {-# INLINE word16 #-}+  word32 = BigEndianSerializer . word32B+  {-# INLINE word32 #-}+  word64 = BigEndianSerializer . word64B+  {-# INLINE word64 #-}+  word16L = BigEndianSerializer . word16L+  {-# INLINE word16L #-}+  word16B = BigEndianSerializer . word16B+  {-# INLINE word16B #-}+  word32L = BigEndianSerializer . word32L+  {-# INLINE word32L #-}+  word32B = BigEndianSerializer . word32B+  {-# INLINE word32B #-}+  word64L = BigEndianSerializer . word64L+  {-# INLINE word64L #-}+  word64B = BigEndianSerializer . word64B+  {-# INLINE word64B #-}+  byteString = BigEndianSerializer . byteString+  {-# INLINE byteString #-}+  shortByteString = BigEndianSerializer . shortByteString+  {-# INLINE shortByteString #-}+  lazyByteString = BigEndianSerializer . lazyByteString+  {-# INLINE lazyByteString #-}+  builder = BigEndianSerializer . builder+  {-# INLINE builder #-}++-- | Force the default byte order.+serializeIn ∷ Serializer s ⇒ Endian → (∀ s' . (Serializer s') ⇒ s') → s+serializeIn LittleEndian = serializeL+serializeIn BigEndian    = serializeB+{-# INLINE serializeIn #-}++-- | Force the default byte order to be the host byte order.+serializeH ∷ Serializer s ⇒ (∀ s' . (Serializer s') ⇒ s') → s+#ifdef WORDS_BIGENDIAN+serializeH = serializeB+#else+serializeH = serializeL+#endif+{-# INLINE serializeH #-}++-- | Serializable type. 'put' must work under assumption that it will be+--   followed by more output.+class Serializable α where+  put ∷ Serializer s ⇒ α → s++instance Serializable Bool where+  put False = word8 0+  put True  = word8 1+  {-# INLINE put #-}++instance Serializable Word8 where+  put = word8+  {-# INLINE put #-}++instance Serializable Word16 where+  put = word16+  {-# INLINE put #-}++instance Serializable Word32 where+  put = word32+  {-# INLINE put #-}++instance Serializable Word64 where+  put = word64+  {-# INLINE put #-}++instance Serializable Word where+  put = word+  {-# INLINE put #-}++instance Serializable Int8 where+  put = int8+  {-# INLINE put #-}++instance Serializable Int16 where+  put = word16 . fromIntegral+  {-# INLINE put #-}++instance Serializable Int32 where+  put = word32 . fromIntegral+  {-# INLINE put #-}++instance Serializable Int64 where+  put = word64 . fromIntegral+  {-# INLINE put #-}++instance Serializable Int where+  put = int+  {-# INLINE put #-}++instance (Serializable α, Serializable β) ⇒ Serializable (α, β) where+  put (a, b) = put a <> put b+  {-# INLINE put #-}++instance Serializable α ⇒ Serializable (Maybe α) where+  put Nothing  = word8 0+  put (Just a) = word8 1 <> put a++instance (Serializable α, Serializable β) ⇒ Serializable (Either α β) where+  put (Left a)  = word8 0 <> put a+  put (Right b) = word8 1 <> put b++instance Serializable BS.ByteString where+  put bs = int (BS.length bs) <> byteString bs++instance Serializable SBS.ShortByteString where+  put bs = int (SBS.length bs) <> shortByteString bs++-- | Serialize a value using the provided default byte order.+putIn ∷ (Serializer s, Serializable α) ⇒ Endian → α → s+putIn e a = serializeIn e (put a)+{-# INLINE putIn #-}++-- | Serialize a value using little endian as the default byte order.+putL ∷ (Serializer s, Serializable α) ⇒ α → s+putL a = serializeL (put a)+{-# INLINE putL #-}++-- | Serialize a value using big endian as the default byte order.+putB ∷ (Serializer s, Serializable α) ⇒ α → s+putB a = serializeB (put a)+{-# INLINE putB #-}++-- | Serialize a value using host byte order as the default byte order.+putH ∷ (Serializer s, Serializable α) ⇒ α → s+putH a = serializeH (put a)+{-# INLINE putH #-}++-- | Types with fixed serialized size.+class Serializable α ⇒ SizedSerializable α where+  -- | Serialized size in bytes.+  size ∷ Proxy α → Int++instance SizedSerializable Bool where+  size _ = 1+  {-# INLINE size #-}++instance SizedSerializable Word8 where+  size _ = 1+  {-# INLINE size #-}++instance SizedSerializable Word16 where+  size _ = 2+  {-# INLINE size #-}++instance SizedSerializable Word32 where+  size _ = 4+  {-# INLINE size #-}++instance SizedSerializable Word64 where+  size _ = 8+  {-# INLINE size #-}++instance SizedSerializable Word where+#if WORD_SIZE_IN_BITS == 32+  size _ = 4+#else+  size _ = 8+#endif+  {-# INLINE size #-}++instance SizedSerializable Int8 where+  size _ = 1+  {-# INLINE size #-}++instance SizedSerializable Int16 where+  size _ = 2+  {-# INLINE size #-}++instance SizedSerializable Int32 where+  size _ = 4+  {-# INLINE size #-}++instance SizedSerializable Int64 where+  size _ = 8+  {-# INLINE size #-}++instance SizedSerializable Int where+#if WORD_SIZE_IN_BITS == 32+  size _ = 4+#else+  size _ = 8+#endif+  {-# INLINE size #-}++instance (SizedSerializable α, SizedSerializable β)+         ⇒ SizedSerializable (α, β) where+  size _ = size (Proxy ∷ Proxy α) + size (Proxy ∷ Proxy β)+  {-# INLINE size #-}++-- | Serializable type. 'putRest' must work under assumption that it will not+--   be followed by any more output.+class RestSerializable α where+  putRest ∷ Serializer s ⇒ α → s++instance RestSerializable BS.ByteString where+  putRest = byteString+  {-# INLINE putRest #-}++instance RestSerializable SBS.ShortByteString where+  putRest = shortByteString+  {-# INLINE putRest #-}++instance RestSerializable LBS.ByteString where+  putRest = lazyByteString+  {-# INLINE putRest #-}++instance RestSerializable BB.Builder where+  putRest = builder+  {-# INLINE putRest #-}++instance Serializable α ⇒ RestSerializable [α] where+  putRest = mconcat . fmap put+  {-# INLINE putRest #-}++instance (Serializable α, RestSerializable β) ⇒ RestSerializable (α, β) where+  putRest (a, b) = put a <> putRest b+  {-# INLINE putRest #-}

+ tests/Tests.hs view

@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.QuickCheck++import Data.Word (Word8, Word32)+import Data.Either (isLeft, isRight)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Builder as BB+import qualified Data.Binary.Put as B+import qualified Data.Binary.Get as B+import qualified Data.Serialize.Put as C+import qualified Data.Serialize.Get as C+import Data.Serializer (Serializer)+import qualified Data.Serializer as S+import Data.Deserializer (Deserializer)+import qualified Data.Deserializer as D+import Control.Applicative ((<|>))++byteStringBuilder = LBS.unpack . BB.toLazyByteString+binaryBuilder = LBS.unpack . B.runPut+cerealBuilder = LBS.unpack . C.runPutLazy++serializerTests ∷ Serializer s ⇒ String → (s → [Word8]) → TestTree+serializerTests name build =+  testGroup name+    [ testProperty "word32L" $+        build (S.word32L 0x12345678) == [0x78, 0x56, 0x34, 0x12]+    , testProperty "word32B" $+        build (S.word32B 0x12345678) == [0x12, 0x34, 0x56, 0x78]+    , testProperty "putL Word32" $+        build (S.putL (0x12345678 ∷ Word32)) == [0x78, 0x56, 0x34, 0x12]+    , testProperty "putB Word32" $+        build (S.putB (0x12345678 ∷ Word32)) == [0x12, 0x34, 0x56, 0x78]+    ]++binaryParser p = either (\(_, _, e) → Left e) (\(_, _, r) → Right r)+               . B.runGetOrFail (D.binaryDeserializer p)+               . LBS.pack+cerealParser p = C.runGet (D.cerealDeserializer p) . BS.pack++deserializerTests ∷ Deserializer μ+                  ⇒ String → (∀ α . μ α → [Word8] → Either String α) → TestTree+deserializerTests name parse =+  testGroup name+    [ testProperty "word32L" $+        parse D.word32L [0x12, 0x34, 0x56, 0x78] == Right 0x78563412+    , testProperty "word32B" $+        parse D.word32B [0x12, 0x34, 0x56, 0x78] == Right 0x12345678+    , testProperty "getL Word32" $+        parse D.getL [0x12, 0x34, 0x56, 0x78] == Right (0x78563412 ∷ Word32)+    , testProperty "getB Word32" $+        parse D.getB [0x12, 0x34, 0x56, 0x78] == Right (0x12345678 ∷ Word32)+    , testProperty "eof succeeds on empty input" $+        isRight (parse D.eof [])+    , testProperty "eof fails on non-empty input" $+        isLeft (parse D.eof [0x00])+    , testProperty "try and <|>" $+        isRight (parse (D.try (D.byte 0x01 >> D.bytes "\x02\x03") <|>+                        D.bytes "\x01\x03\x02")+                       [0x01, 0x03, 0x02])+    ]++main = defaultMain+     $ testGroup "Tests"+         [ testGroup "Serializers"+             [ serializerTests "Builder" byteStringBuilder+             , serializerTests "Binary.Put" binaryBuilder+             , serializerTests "Cereal.Put" cerealBuilder+             ]+         , testGroup "Deserializers"+             [ deserializerTests "Binary.Get" binaryParser+             , deserializerTests "Cereal.Get" cerealParser+             ]+         ]