cereal-0.5.3.0/0000755000000000000000000000000012744462505011307 5ustar0000000000000000cereal-0.5.3.0/cereal.cabal0000644000000000000000000000430212744462505013525 0ustar0000000000000000name: cereal version: 0.5.3.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin , Galois Inc., Lemmih , Bas van Dijk maintainer: Trevor Elliott category: Data, Parsing stability: provisional build-type: Simple cabal-version: >= 1.10 synopsis: A binary serialization library homepage: https://github.com/GaloisInc/cereal tested-with: GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 description: A binary serialization library, similar to binary, that introduces an isolate primitive for parser isolation, and labeled blocks for better error messages. extra-source-files: CHANGELOG.md source-repository head type: git location: git://github.com/GaloisInc/cereal.git library default-language: Haskell2010 build-depends: bytestring >= 0.10.2.0, base >= 4.4 && < 5, containers, array, ghc-prim >= 0.2 if !impl(ghc >= 8.0) build-depends: fail == 4.9.* hs-source-dirs: src exposed-modules: Data.Serialize, Data.Serialize.Put, Data.Serialize.Get, Data.Serialize.IEEE754 ghc-options: -Wall -O2 -funbox-strict-fields test-suite test-cereal default-language: Haskell2010 type: exitcode-stdio-1.0 build-depends: base == 4.*, bytestring >= 0.10.8.1, QuickCheck, test-framework, test-framework-quickcheck2, cereal main-is: Main.hs other-modules: RoundTrip GetTests hs-source-dirs: tests cereal-0.5.3.0/CHANGELOG.md0000644000000000000000000000153712744462505013126 0ustar0000000000000000 0.5.2.0 ====== * Implement the AMP recommended refactoring for the Functor/Applicative/Monad hierarchy for Get and PutM (thanks to Herbert Valerio Riedel!) * Unconditionally support GHC generics (thanks to Eric Mertens!) * Split the GSerialize class in two, to deal with a GHC bug (thanks Austin Seipp!) * No longer use Enum in the Serialize instance for Bool (thanks Francesco Mazzoli!) 0.5.1.0 ======= * Re-enable GHC.Generics support which was accidentally removed in 0.5.0.0 0.5.0.0 ======= * Switch to using the builder provided by the `ByteString` package * Change the encoding of Float and Double with the Serialize class to use the `Data.Serialize.IEEE754` module * Add support for encoding and decoding `ShortByteString` * New and improved test suite thanks to Kei Hibino * Fix two bugs involving the `lookAhead` combinator and partial chunks. cereal-0.5.3.0/LICENSE0000644000000000000000000000270112744462505012314 0ustar0000000000000000Copyright (c) Lennart Kolmodin, Galois, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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. cereal-0.5.3.0/Setup.lhs0000644000000000000000000000011412744462505013113 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain cereal-0.5.3.0/src/0000755000000000000000000000000012744462505012076 5ustar0000000000000000cereal-0.5.3.0/src/Data/0000755000000000000000000000000012744462505012747 5ustar0000000000000000cereal-0.5.3.0/src/Data/Serialize.hs0000644000000000000000000005305212744462505015237 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures , TypeOperators , BangPatterns , KindSignatures , ScopedTypeVariables #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Serialize -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE) -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- ----------------------------------------------------------------------------- module Data.Serialize ( -- * The Serialize class Serialize(..) -- $example -- * Serialize serialisation , encode, encodeLazy , decode, decodeLazy , expect , module Data.Serialize.Get , module Data.Serialize.Put , module Data.Serialize.IEEE754 -- * Generic deriving , GSerializePut(..) , GSerializeGet(..) ) where import Data.Serialize.Put import Data.Serialize.Get import Data.Serialize.IEEE754 import Control.Monad import Data.Array.Unboxed import Data.ByteString (ByteString) import Data.Char (chr,ord) import Data.List (unfoldr) import Data.Word import Foreign -- And needed for the instances: import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import qualified Data.Monoid as M import qualified Data.Set as Set import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Ratio as R import qualified Data.Tree as T import qualified Data.Sequence as Seq import GHC.Generics #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((*>),(<*>),(<$>),pure) #endif #if MIN_VERSION_base(4,8,0) import Numeric.Natural #endif ------------------------------------------------------------------------ -- | If your compiler has support for the @DeriveGeneric@ and -- @DefaultSignatures@ language extensions (@ghc >= 7.2.1@), the 'put' and 'get' -- methods will have default generic implementations. -- -- To use this option, simply add a @deriving 'Generic'@ clause to your datatype -- and declare a 'Serialize' instance for it without giving a definition for -- 'put' and 'get'. class Serialize t where -- | Encode a value in the Put monad. put :: Putter t -- | Decode a value in the Get monad get :: Get t default put :: (Generic t, GSerializePut (Rep t)) => Putter t put = gPut . from default get :: (Generic t, GSerializeGet (Rep t)) => Get t get = to <$> gGet ------------------------------------------------------------------------ -- Wrappers to run the underlying monad -- | Encode a value using binary serialization to a strict ByteString. encode :: Serialize a => a -> ByteString encode = runPut . put -- | Encode a value using binary serialization to a lazy ByteString. encodeLazy :: Serialize a => a -> L.ByteString encodeLazy = runPutLazy . put -- | Decode a value from a strict ByteString, reconstructing the original -- structure. decode :: Serialize a => ByteString -> Either String a decode = runGet get -- | Decode a value from a lazy ByteString, reconstructing the original -- structure. decodeLazy :: Serialize a => L.ByteString -> Either String a decodeLazy = runGetLazy get ------------------------------------------------------------------------ -- Combinators -- | Perform an action, failing if the read result does not match the argument -- provided. expect :: (Eq a, Serialize a) => a -> Get a expect x = get >>= \y -> if x == y then return x else mzero ------------------------------------------------------------------------ -- Simple instances -- The () type need never be written to disk: values of singleton type -- can be reconstructed from the type alone instance Serialize () where put () = return () get = return () {-# INLINE boolToWord8 #-} boolToWord8 :: Bool -> Word8 boolToWord8 False = 0 boolToWord8 True = 1 {-# INLINE boolFromWord8 #-} boolFromWord8 :: Word8 -> Get Bool boolFromWord8 0 = return False boolFromWord8 1 = return True boolFromWord8 w = fail ("Invalid Bool encoding " ++ show w) {-# INLINE orderingToWord8 #-} orderingToWord8 :: Ordering -> Word8 orderingToWord8 LT = 0 orderingToWord8 EQ = 1 orderingToWord8 GT = 2 {-# INLINE orderingFromWord8 #-} orderingFromWord8 :: Word8 -> Get Ordering orderingFromWord8 0 = return LT orderingFromWord8 1 = return EQ orderingFromWord8 2 = return GT orderingFromWord8 w = fail ("Invalid Ordering encoding " ++ show w) -- Bools are encoded as a byte in the range 0 .. 1 instance Serialize Bool where put = putWord8 . boolToWord8 get = boolFromWord8 =<< getWord8 -- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 instance Serialize Ordering where put = putWord8 . orderingToWord8 get = orderingFromWord8 =<< getWord8 ------------------------------------------------------------------------ -- Words and Ints -- Words8s are written as bytes instance Serialize Word8 where put = putWord8 get = getWord8 -- Words16s are written as 2 bytes in big-endian (network) order instance Serialize Word16 where put = putWord16be get = getWord16be -- Words32s are written as 4 bytes in big-endian (network) order instance Serialize Word32 where put = putWord32be get = getWord32be -- Words64s are written as 8 bytes in big-endian (network) order instance Serialize Word64 where put = putWord64be get = getWord64be -- Int8s are written as a single byte. instance Serialize Int8 where put i = put (fromIntegral i :: Word8) get = liftM fromIntegral (get :: Get Word8) -- Int16s are written as a 2 bytes in big endian format instance Serialize Int16 where put i = put (fromIntegral i :: Word16) get = liftM fromIntegral (get :: Get Word16) -- Int32s are written as a 4 bytes in big endian format instance Serialize Int32 where put i = put (fromIntegral i :: Word32) get = liftM fromIntegral (get :: Get Word32) -- Int64s are written as a 8 bytes in big endian format instance Serialize Int64 where put i = put (fromIntegral i :: Word64) get = liftM fromIntegral (get :: Get Word64) ------------------------------------------------------------------------ -- Words are are written as Word64s, that is, 8 bytes in big endian format instance Serialize Word where put i = put (fromIntegral i :: Word64) get = liftM fromIntegral (get :: Get Word64) -- Ints are are written as Int64s, that is, 8 bytes in big endian format instance Serialize Int where put i = put (fromIntegral i :: Int64) get = liftM fromIntegral (get :: Get Int64) ------------------------------------------------------------------------ -- -- Portable, and pretty efficient, serialisation of Integer -- -- Fixed-size type for a subset of Integer type SmallInt = Int32 -- Integers are encoded in two ways: if they fit inside a SmallInt, -- they're written as a byte tag, and that value. If the Integer value -- is too large to fit in a SmallInt, it is written as a byte array, -- along with a sign and length field. instance Serialize Integer where put n | n >= lo && n <= hi = do putWord8 0 put (fromIntegral n :: SmallInt) -- fast path where lo = fromIntegral (minBound :: SmallInt) :: Integer hi = fromIntegral (maxBound :: SmallInt) :: Integer put n = do putWord8 1 put sign put (unroll (abs n)) -- unroll the bytes where sign = fromIntegral (signum n) :: Word8 get = do tag <- get :: Get Word8 case tag of 0 -> liftM fromIntegral (get :: Get SmallInt) _ -> do sign <- get bytes <- get let v = roll bytes return $! if sign == (1 :: Word8) then v else - v -- -- Fold and unfold an Integer to and from a list of its bytes -- unroll :: (Integral a, Bits a) => a -> [Word8] unroll = unfoldr step where step 0 = Nothing step i = Just (fromIntegral i, i `shiftR` 8) roll :: (Integral a, Bits a) => [Word8] -> a roll = foldr unstep 0 where unstep b a = a `shiftL` 8 .|. fromIntegral b instance (Serialize a,Integral a) => Serialize (R.Ratio a) where put r = put (R.numerator r) >> put (R.denominator r) get = liftM2 (R.%) get get #if MIN_VERSION_base(4,8,0) -- Fixed-size type for a subset of Natural type NaturalWord = Word64 instance Serialize Natural where {-# INLINE put #-} put n | n <= hi = do putWord8 0 put (fromIntegral n :: NaturalWord) -- fast path where hi = fromIntegral (maxBound :: NaturalWord) :: Natural put n = do putWord8 1 put (unroll (abs n)) -- unroll the bytes {-# INLINE get #-} get = do tag <- get :: Get Word8 case tag of 0 -> liftM fromIntegral (get :: Get NaturalWord) _ -> do bytes <- get return $! roll bytes #endif ------------------------------------------------------------------------ -- Safely wrap `chr` to avoid exceptions. -- `chr` source: http://hackage.haskell.org/package/base-4.7.0.2/docs/src/GHC-Char.html#chr chrEither :: Int -> Either String Char chrEither i | i <= 0x10FFFF = Right (chr i) -- Or: C# (chr# i#) | otherwise = Left ("bad argument: " ++ show i) -- Char is serialised as UTF-8 instance Serialize Char where put a | c <= 0x7f = put (fromIntegral c :: Word8) | c <= 0x7ff = do put (0xc0 .|. y) put (0x80 .|. z) | c <= 0xffff = do put (0xe0 .|. x) put (0x80 .|. y) put (0x80 .|. z) | c <= 0x10ffff = do put (0xf0 .|. w) put (0x80 .|. x) put (0x80 .|. y) put (0x80 .|. z) | otherwise = error "Not a valid Unicode code point" where c = ord a z, y, x, w :: Word8 z = fromIntegral (c .&. 0x3f) y = fromIntegral (shiftR c 6 .&. 0x3f) x = fromIntegral (shiftR c 12 .&. 0x3f) w = fromIntegral (shiftR c 18 .&. 0x7) get = do let getByte = liftM (fromIntegral :: Word8 -> Int) get shiftL6 = flip shiftL 6 :: Int -> Int w <- getByte r <- case () of _ | w < 0x80 -> return w | w < 0xe0 -> do x <- liftM (xor 0x80) getByte return (x .|. shiftL6 (xor 0xc0 w)) | w < 0xf0 -> do x <- liftM (xor 0x80) getByte y <- liftM (xor 0x80) getByte return (y .|. shiftL6 (x .|. shiftL6 (xor 0xe0 w))) | otherwise -> do x <- liftM (xor 0x80) getByte y <- liftM (xor 0x80) getByte z <- liftM (xor 0x80) getByte return (z .|. shiftL6 (y .|. shiftL6 (x .|. shiftL6 (xor 0xf0 w)))) case chrEither r of Right r' -> return $! r' Left err -> fail err ------------------------------------------------------------------------ -- Instances for the first few tuples instance (Serialize a, Serialize b) => Serialize (a,b) where put = putTwoOf put put get = getTwoOf get get instance (Serialize a, Serialize b, Serialize c) => Serialize (a,b,c) where put (a,b,c) = put a >> put b >> put c get = liftM3 (,,) get get get instance (Serialize a, Serialize b, Serialize c, Serialize d) => Serialize (a,b,c,d) where put (a,b,c,d) = put a >> put b >> put c >> put d get = liftM4 (,,,) get get get get instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e) => Serialize (a,b,c,d,e) where put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e get = liftM5 (,,,,) get get get get get -- -- and now just recurse: -- instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e , Serialize f) => Serialize (a,b,c,d,e,f) where put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e , Serialize f, Serialize g) => Serialize (a,b,c,d,e,f,g) where put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f, Serialize g, Serialize h) => Serialize (a,b,c,d,e,f,g,h) where put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) get = do (a,(b,c,d,e,f,g,h)) <- get return (a,b,c,d,e,f,g,h) instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f, Serialize g, Serialize h, Serialize i) => Serialize (a,b,c,d,e,f,g,h,i) where put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) get = do (a,(b,c,d,e,f,g,h,i)) <- get return (a,b,c,d,e,f,g,h,i) instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f, Serialize g, Serialize h, Serialize i, Serialize j) => Serialize (a,b,c,d,e,f,g,h,i,j) where put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) get = do (a,(b,c,d,e,f,g,h,i,j)) <- get return (a,b,c,d,e,f,g,h,i,j) ------------------------------------------------------------------------ -- Monoid newtype wrappers instance Serialize a => Serialize (M.Dual a) where put = put . M.getDual get = fmap M.Dual get instance Serialize M.All where put = put . M.getAll get = fmap M.All get instance Serialize M.Any where put = put . M.getAny get = fmap M.Any get instance Serialize a => Serialize (M.Sum a) where put = put . M.getSum get = fmap M.Sum get instance Serialize a => Serialize (M.Product a) where put = put . M.getProduct get = fmap M.Product get instance Serialize a => Serialize (M.First a) where put = put . M.getFirst get = fmap M.First get instance Serialize a => Serialize (M.Last a) where put = put . M.getLast get = fmap M.Last get ------------------------------------------------------------------------ -- Container types instance Serialize a => Serialize [a] where put = putListOf put get = getListOf get instance (Serialize a) => Serialize (Maybe a) where put = putMaybeOf put get = getMaybeOf get instance (Serialize a, Serialize b) => Serialize (Either a b) where put = putEitherOf put put get = getEitherOf get get ------------------------------------------------------------------------ -- ByteStrings (have specially efficient instances) instance Serialize B.ByteString where put bs = do put (B.length bs :: Int) putByteString bs get = get >>= getByteString instance Serialize L.ByteString where put bs = do put (L.length bs :: Int64) putLazyByteString bs get = get >>= getLazyByteString ------------------------------------------------------------------------ -- Maps and Sets instance (Ord a, Serialize a) => Serialize (Set.Set a) where put = putSetOf put get = getSetOf get instance (Ord k, Serialize k, Serialize e) => Serialize (Map.Map k e) where put = putMapOf put put get = getMapOf get get instance Serialize IntSet.IntSet where put = putIntSetOf put get = getIntSetOf get instance (Serialize e) => Serialize (IntMap.IntMap e) where put = putIntMapOf put put get = getIntMapOf get get ------------------------------------------------------------------------ -- Queues and Sequences instance (Serialize e) => Serialize (Seq.Seq e) where put = putSeqOf put get = getSeqOf get ------------------------------------------------------------------------ -- Floating point instance Serialize Double where put = putFloat64be get = getFloat64be instance Serialize Float where put = putFloat32be get = getFloat32be ------------------------------------------------------------------------ -- Trees instance (Serialize e) => Serialize (T.Tree e) where put = putTreeOf put get = getTreeOf get ------------------------------------------------------------------------ -- Arrays instance (Serialize i, Ix i, Serialize e) => Serialize (Array i e) where put = putIArrayOf put put get = getIArrayOf get get -- -- The IArray UArray e constraint is non portable. Requires flexible instances -- instance (Serialize i, Ix i, Serialize e, IArray UArray e) => Serialize (UArray i e) where put = putIArrayOf put put get = getIArrayOf get get ------------------------------------------------------------------------ -- Generic Serialze class GSerializePut f where gPut :: Putter (f a) class GSerializeGet f where gGet :: Get (f a) instance GSerializePut a => GSerializePut (M1 i c a) where gPut = gPut . unM1 {-# INLINE gPut #-} instance GSerializeGet a => GSerializeGet (M1 i c a) where gGet = M1 <$> gGet {-# INLINE gGet #-} instance Serialize a => GSerializePut (K1 i a) where gPut = put . unK1 {-# INLINE gPut #-} instance Serialize a => GSerializeGet (K1 i a) where gGet = K1 <$> get {-# INLINE gGet #-} instance GSerializePut U1 where gPut _ = pure () {-# INLINE gPut #-} instance GSerializeGet U1 where gGet = pure U1 {-# INLINE gGet #-} instance (GSerializePut a, GSerializePut b) => GSerializePut (a :*: b) where gPut (a :*: b) = gPut a *> gPut b {-# INLINE gPut #-} instance (GSerializeGet a, GSerializeGet b) => GSerializeGet (a :*: b) where gGet = (:*:) <$> gGet <*> gGet {-# INLINE gGet #-} -- The following GSerialize* instance for sums has support for serializing types -- with up to 2^64-1 constructors. It will use the minimal number of bytes -- needed to encode the constructor. For example when a type has 2^8 -- constructors or less it will use a single byte to encode the constructor. If -- it has 2^16 constructors or less it will use two bytes, and so on till 2^64-1. #define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) instance ( PutSum a, PutSum b , SumSize a, SumSize b) => GSerializePut (a :+: b) where gPut | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) | otherwise = sizeError "encode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64) {-# INLINE gPut #-} instance ( GetSum a, GetSum b , SumSize a, SumSize b) => GSerializeGet (a :+: b) where gGet | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) | otherwise = sizeError "decode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64) {-# INLINE gGet #-} sizeError :: Show size => String -> size -> error sizeError s size = error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" ------------------------------------------------------------------------ class PutSum f where putSum :: (Num word, Bits word, Serialize word) => word -> word -> Putter (f a) instance (PutSum a, PutSum b) => PutSum (a :+: b) where putSum !code !size s = case s of L1 x -> putSum code sizeL x R1 x -> putSum (code + sizeL) sizeR x where #if MIN_VERSION_base(4,5,0) sizeL = size `unsafeShiftR` 1 #else sizeL = size `shiftR` 1 #endif sizeR = size - sizeL {-# INLINE putSum #-} instance GSerializePut a => PutSum (C1 c a) where putSum !code _ x = put code *> gPut x {-# INLINE putSum #-} ------------------------------------------------------------------------ checkGetSum :: (Ord word, Num word, Bits word, GetSum f) => word -> word -> Get (f a) checkGetSum size code | code < size = getSum code size | otherwise = fail "Unknown encoding for constructor" {-# INLINE checkGetSum #-} class GetSum f where getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) instance (GetSum a, GetSum b) => GetSum (a :+: b) where getSum !code !size | code < sizeL = L1 <$> getSum code sizeL | otherwise = R1 <$> getSum (code - sizeL) sizeR where #if MIN_VERSION_base(4,5,0) sizeL = size `unsafeShiftR` 1 #else sizeL = size `shiftR` 1 #endif sizeR = size - sizeL {-# INLINE getSum #-} instance GSerializeGet a => GetSum (C1 c a) where getSum _ _ = gGet {-# INLINE getSum #-} ------------------------------------------------------------------------ class SumSize f where sumSize :: Tagged f Word64 newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} instance (SumSize a, SumSize b) => SumSize (a :+: b) where sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + unTagged (sumSize :: Tagged b Word64) instance SumSize (C1 c a) where sumSize = Tagged 1 cereal-0.5.3.0/src/Data/Serialize/0000755000000000000000000000000012744462505014676 5ustar0000000000000000cereal-0.5.3.0/src/Data/Serialize/Get.hs0000644000000000000000000006410312744462505015755 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Serialize.Get -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE) -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- -- The Get monad. A monad for efficiently building structures from -- strict ByteStrings -- ----------------------------------------------------------------------------- #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) #include "MachDeps.h" #endif module Data.Serialize.Get ( -- * The Get type Get , runGet , runGetLazy , runGetState , runGetLazyState -- ** Incremental interface , Result(..) , runGetPartial , runGetChunk -- * Parsing , ensure , isolate , label , skip , uncheckedSkip , lookAhead , lookAheadM , lookAheadE , uncheckedLookAhead -- * Utility , getBytes , remaining , isEmpty -- * Parsing particular types , getWord8 , getInt8 -- ** ByteStrings , getByteString , getLazyByteString #if MIN_VERSION_bytestring(0,10,4) , getShortByteString #endif -- ** Big-endian reads , getWord16be , getWord32be , getWord64be , getInt16be , getInt32be , getInt64be -- ** Little-endian reads , getWord16le , getWord32le , getWord64le , getInt16le , getInt32le , getInt64le -- ** Host-endian, unaligned reads , getWordhost , getWord16host , getWord32host , getWord64host -- ** Containers , getTwoOf , getListOf , getIArrayOf , getTreeOf , getSeqOf , getMapOf , getIntMapOf , getSetOf , getIntSetOf , getMaybeOf , getEitherOf , getNested ) where import qualified Control.Applicative as A import qualified Control.Monad as M import Control.Monad (unless) import qualified Control.Monad.Fail as Fail import Data.Array.IArray (IArray,listArray) import Data.Ix (Ix) import Data.List (intercalate) import Data.Maybe (isNothing,fromMaybe) import Foreign import System.IO.Unsafe (unsafeDupablePerformIO) import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as L import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Tree as T #if MIN_VERSION_bytestring(0,10,4) import qualified Data.ByteString.Short as BS #endif #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base import GHC.Word #endif -- | The result of a parse. data Result r = Fail String B.ByteString -- ^ The parse failed. The 'String' is the -- message describing the error, if any. | Partial (B.ByteString -> Result r) -- ^ Supply this continuation with more input so that -- the parser can resume. To indicate that no more -- input is available, use an 'B.empty' string. | Done r B.ByteString -- ^ The parse succeeded. The 'B.ByteString' is the -- input that had not yet been consumed (if any) when -- the parse succeeded. instance Show r => Show (Result r) where show (Fail msg _) = "Fail " ++ show msg show (Partial _) = "Partial _" show (Done r bs) = "Done " ++ show r ++ " " ++ show bs instance Functor Result where fmap _ (Fail msg rest) = Fail msg rest fmap f (Partial k) = Partial (fmap f . k) fmap f (Done r bs) = Done (f r) bs -- | The Get monad is an Exception and State monad. newtype Get a = Get { unGet :: forall r. Input -> Buffer -> More -> Failure r -> Success a r -> Result r } type Input = B.ByteString type Buffer = Maybe B.ByteString emptyBuffer :: Buffer emptyBuffer = Just B.empty extendBuffer :: Buffer -> B.ByteString -> Buffer extendBuffer buf chunk = do bs <- buf return $! bs `B.append` chunk {-# INLINE extendBuffer #-} append :: Buffer -> Buffer -> Buffer append l r = B.append `fmap` l A.<*> r {-# INLINE append #-} bufferBytes :: Buffer -> B.ByteString bufferBytes = fromMaybe B.empty {-# INLINE bufferBytes #-} type Failure r = Input -> Buffer -> More -> [String] -> String -> Result r type Success a r = Input -> Buffer -> More -> a -> Result r -- | Have we read all available input? data More = Complete | Incomplete (Maybe Int) deriving (Eq) moreLength :: More -> Int moreLength m = case m of Complete -> 0 Incomplete mb -> fromMaybe 0 mb instance Functor Get where fmap p m = Get $ \ s0 b0 m0 kf ks -> unGet m s0 b0 m0 kf $ \ s1 b1 m1 a -> ks s1 b1 m1 (p a) instance A.Applicative Get where pure a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a {-# INLINE pure #-} f <*> x = Get $ \ s0 b0 m0 kf ks -> unGet f s0 b0 m0 kf $ \ s1 b1 m1 g -> unGet x s1 b1 m1 kf $ \ s2 b2 m2 y -> ks s2 b2 m2 (g y) {-# INLINE (<*>) #-} m *> k = Get $ \ s0 b0 m0 kf ks -> unGet m s0 b0 m0 kf $ \ s1 b1 m1 _ -> unGet k s1 b1 m1 kf ks {-# INLINE (*>) #-} instance A.Alternative Get where empty = failDesc "empty" {-# INLINE empty #-} (<|>) = M.mplus {-# INLINE (<|>) #-} -- Definition directly from Control.Monad.State.Strict instance Monad Get where return = A.pure {-# INLINE return #-} m >>= g = Get $ \ s0 b0 m0 kf ks -> unGet m s0 b0 m0 kf $ \ s1 b1 m1 a -> unGet (g a) s1 b1 m1 kf ks {-# INLINE (>>=) #-} (>>) = (A.*>) {-# INLINE (>>) #-} fail = Fail.fail {-# INLINE fail #-} instance Fail.MonadFail Get where fail = failDesc {-# INLINE fail #-} instance M.MonadPlus Get where mzero = failDesc "mzero" {-# INLINE mzero #-} mplus a b = Get $ \s0 b0 m0 kf ks -> let ks' s1 b1 = ks s1 (b0 `append` b1) kf' _ b1 m1 = kf (s0 `B.append` bufferBytes b1) (b0 `append` b1) m1 try _ b1 m1 _ _ = unGet b (s0 `B.append` bufferBytes b1) b1 m1 kf' ks' in unGet a s0 emptyBuffer m0 try ks' {-# INLINE mplus #-} ------------------------------------------------------------------------ formatTrace :: [String] -> String formatTrace [] = "Empty call stack" formatTrace ls = "From:\t" ++ intercalate "\n\t" ls ++ "\n" get :: Get B.ByteString get = Get (\s0 b0 m0 _ k -> k s0 b0 m0 s0) {-# INLINE get #-} put :: B.ByteString -> Get () put s = Get (\_ b0 m _ k -> k s b0 m ()) {-# INLINE put #-} label :: String -> Get a -> Get a label l m = Get $ \ s0 b0 m0 kf ks -> let kf' s1 b1 m1 ls = kf s1 b1 m1 (l:ls) in unGet m s0 b0 m0 kf' ks finalK :: Success a a finalK s _ _ a = Done a s failK :: Failure a failK s b _ ls msg = Fail (unlines [msg, formatTrace ls]) (s `B.append` bufferBytes b) -- | Run the Get monad applies a 'get'-based parser on the input ByteString runGet :: Get a -> B.ByteString -> Either String a runGet m str = case unGet m str Nothing Complete failK finalK of Fail i _ -> Left i Done a _ -> Right a Partial{} -> Left "Failed reading: Internal error: unexpected Partial." {-# INLINE runGet #-} -- | Run the get monad on a single chunk, providing an optional length for the -- remaining, unseen input, with Nothing indicating that it's not clear how much -- input is left. For example, with a lazy ByteString, the optional length -- represents the sum of the lengths of all remaining chunks. runGetChunk :: Get a -> Maybe Int -> B.ByteString -> Result a runGetChunk m mbLen str = unGet m str Nothing (Incomplete mbLen) failK finalK {-# INLINE runGetChunk #-} -- | Run the Get monad applies a 'get'-based parser on the input ByteString runGetPartial :: Get a -> B.ByteString -> Result a runGetPartial m = runGetChunk m Nothing {-# INLINE runGetPartial #-} -- | Run the Get monad applies a 'get'-based parser on the input -- ByteString. Additional to the result of get it returns the number of -- consumed bytes and the rest of the input. runGetState :: Get a -> B.ByteString -> Int -> Either String (a, B.ByteString) runGetState m str off = case runGetState' m str off of (Right a,bs) -> Right (a,bs) (Left i,_) -> Left i {-# INLINE runGetState #-} -- | Run the Get monad applies a 'get'-based parser on the input -- ByteString. Additional to the result of get it returns the number of -- consumed bytes and the rest of the input, even in the event of a failure. runGetState' :: Get a -> B.ByteString -> Int -> (Either String a, B.ByteString) runGetState' m str off = case unGet m (B.drop off str) Nothing Complete failK finalK of Fail i bs -> (Left i,bs) Done a bs -> (Right a, bs) Partial{} -> (Left "Failed reading: Internal error: unexpected Partial.",B.empty) {-# INLINE runGetState' #-} -- Lazy Get -------------------------------------------------------------------- runGetLazy' :: Get a -> L.ByteString -> (Either String a,L.ByteString) runGetLazy' m lstr = case L.toChunks lstr of [c] -> wrapStrict (runGetState' m c 0) [] -> wrapStrict (runGetState' m B.empty 0) c:cs -> loop (runGetChunk m (Just (len - B.length c)) c) cs where len = fromIntegral (L.length lstr) wrapStrict (e,s) = (e,L.fromChunks [s]) loop result chunks = case result of Fail str rest -> (Left str, L.fromChunks (rest : chunks)) Partial k -> case chunks of c:cs -> loop (k c) cs [] -> loop (k B.empty) [] Done r rest -> (Right r, L.fromChunks (rest : chunks)) {-# INLINE runGetLazy' #-} -- | Run the Get monad over a Lazy ByteString. Note that this will not run the -- Get parser lazily, but will operate on lazy ByteStrings. runGetLazy :: Get a -> L.ByteString -> Either String a runGetLazy m lstr = fst (runGetLazy' m lstr) {-# INLINE runGetLazy #-} -- | Run the Get monad over a Lazy ByteString. Note that this does not run the -- Get parser lazily, but will operate on lazy ByteStrings. runGetLazyState :: Get a -> L.ByteString -> Either String (a,L.ByteString) runGetLazyState m lstr = case runGetLazy' m lstr of (Right a,rest) -> Right (a,rest) (Left err,_) -> Left err {-# INLINE runGetLazyState #-} ------------------------------------------------------------------------ -- | If at least @n@ bytes of input are available, return the current -- input, otherwise fail. {-# INLINE ensure #-} ensure :: Int -> Get B.ByteString ensure n0 = n0 `seq` Get $ \ s0 b0 m0 kf ks -> let n' = n0 - B.length s0 in if n' <= 0 then ks s0 b0 m0 s0 else getMore n' s0 [] b0 m0 kf ks where -- The "accumulate and concat" pattern here is important not to incur -- in quadratic behavior, see finalInput s0 ss = B.concat (reverse (s0 : ss)) finalBuffer b0 s0 ss = extendBuffer b0 (B.concat (reverse (init (s0 : ss)))) getMore !n s0 ss b0 m0 kf ks = let tooFewBytes = let !s = finalInput s0 ss !b = finalBuffer b0 s0 ss in kf s b m0 ["demandInput"] "too few bytes" in case m0 of Complete -> tooFewBytes Incomplete mb -> Partial $ \s -> if B.null s then tooFewBytes else let !mb' = case mb of Just l -> Just $! l - B.length s Nothing -> Nothing in checkIfEnough n s (s0 : ss) b0 (Incomplete mb') kf ks checkIfEnough !n s0 ss b0 m0 kf ks = let n' = n - B.length s0 in if n' <= 0 then let !s = finalInput s0 ss !b = finalBuffer b0 s0 ss in ks s b m0 s else getMore n' s0 ss b0 m0 kf ks -- | Isolate an action to operating within a fixed block of bytes. The action -- is required to consume all the bytes that it is isolated to. isolate :: Int -> Get a -> Get a isolate n m = do M.when (n < 0) (fail "Attempted to isolate a negative number of bytes") s <- ensure n let (s',rest) = B.splitAt n s put s' a <- m used <- get unless (B.null used) (fail "not all bytes parsed in isolate") put rest return a failDesc :: String -> Get a failDesc err = do let msg = "Failed reading: " ++ err Get (\s0 b0 m0 kf _ -> kf s0 b0 m0 [] msg) -- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. skip :: Int -> Get () skip n = do s <- ensure n put (B.drop n s) -- | Skip ahead up to @n@ bytes in the current chunk. No error if there aren't -- enough bytes, or if less than @n@ bytes are skipped. uncheckedSkip :: Int -> Get () uncheckedSkip n = do s <- get put (B.drop n s) -- | Run @ga@, but return without consuming its input. -- Fails if @ga@ fails. lookAhead :: Get a -> Get a lookAhead ga = Get $ \ s0 b0 m0 kf ks -> -- the new continuation extends the old input with the new buffered bytes, and -- appends the new buffer to the old one, if there was one. let ks' _ b1 = ks (s0 `B.append` bufferBytes b1) (b0 `append` b1) kf' _ b1 = kf s0 (b0 `append` b1) in unGet ga s0 emptyBuffer m0 kf' ks' -- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. -- Fails if @gma@ fails. lookAheadM :: Get (Maybe a) -> Get (Maybe a) lookAheadM gma = do s <- get ma <- gma M.when (isNothing ma) (put s) return ma -- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. -- Fails if @gea@ fails. lookAheadE :: Get (Either a b) -> Get (Either a b) lookAheadE gea = do s <- get ea <- gea case ea of Left _ -> put s _ -> return () return ea -- | Get the next up to @n@ bytes as a ByteString until end of this chunk, -- without consuming them. uncheckedLookAhead :: Int -> Get B.ByteString uncheckedLookAhead n = do s <- get return (B.take n s) ------------------------------------------------------------------------ -- Utility -- | Get the number of remaining unparsed bytes. Useful for checking whether -- all input has been consumed. -- -- WARNING: when run with @runGetPartial@, remaining will only return the number -- of bytes that are remaining in the current input. remaining :: Get Int remaining = Get (\ s0 b0 m0 _ ks -> ks s0 b0 m0 (B.length s0 + moreLength m0)) -- | Test whether all input has been consumed. -- -- WARNING: when run with @runGetPartial@, isEmpty will only tell you if you're -- at the end of the current chunk. isEmpty :: Get Bool isEmpty = Get (\ s0 b0 m0 _ ks -> ks s0 b0 m0 (B.null s0 && moreLength m0 == 0)) ------------------------------------------------------------------------ -- Utility with ByteStrings -- | An efficient 'get' method for strict ByteStrings. Fails if fewer -- than @n@ bytes are left in the input. This function creates a fresh -- copy of the underlying bytes. getByteString :: Int -> Get B.ByteString getByteString n = do bs <- getBytes n return $! B.copy bs getLazyByteString :: Int64 -> Get L.ByteString getLazyByteString n = f `fmap` getByteString (fromIntegral n) where f bs = L.fromChunks [bs] #if MIN_VERSION_bytestring(0,10,4) getShortByteString :: Int -> Get BS.ShortByteString getShortByteString n = do bs <- getBytes n return $! BS.toShort bs #endif ------------------------------------------------------------------------ -- Helpers -- | Pull @n@ bytes from the input, as a strict ByteString. getBytes :: Int -> Get B.ByteString getBytes n | n < 0 = fail "getBytes: negative length requested" getBytes n = do s <- ensure n let consume = B.unsafeTake n s rest = B.unsafeDrop n s -- (consume,rest) = B.splitAt n s put rest return consume {-# INLINE getBytes #-} ------------------------------------------------------------------------ -- Primtives -- helper, get a raw Ptr onto a strict ByteString copied out of the -- underlying strict byteString. getPtr :: Storable a => Int -> Get a getPtr n = do (fp,o,_) <- B.toForeignPtr `fmap` getBytes n let k p = peek (castPtr (p `plusPtr` o)) return (unsafeDupablePerformIO (withForeignPtr fp k)) {-# INLINE getPtr #-} ----------------------------------------------------------------------- -- | Read a Int8 from the monad state getInt8 :: Get Int8 getInt8 = do s <- getBytes 1 return $! fromIntegral (B.unsafeHead s) -- | Read a Int16 in big endian format getInt16be :: Get Int16 getInt16be = do s <- getBytes 2 return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 8) .|. (fromIntegral (s `B.unsafeIndex` 1) ) -- | Read a Int16 in little endian format getInt16le :: Get Int16 getInt16le = do s <- getBytes 2 return $! (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) ) -- | Read a Int32 in big endian format getInt32be :: Get Int32 getInt32be = do s <- getBytes 4 return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 24) .|. (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 16) .|. (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 8) .|. (fromIntegral (s `B.unsafeIndex` 3) ) -- | Read a Int32 in little endian format getInt32le :: Get Int32 getInt32le = do s <- getBytes 4 return $! (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 24) .|. (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 16) .|. (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) ) -- | Read a Int64 in big endian format getInt64be :: Get Int64 getInt64be = do s <- getBytes 8 return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 56) .|. (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 48) .|. (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 40) .|. (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 32) .|. (fromIntegral (s `B.unsafeIndex` 4) `shiftL` 24) .|. (fromIntegral (s `B.unsafeIndex` 5) `shiftL` 16) .|. (fromIntegral (s `B.unsafeIndex` 6) `shiftL` 8) .|. (fromIntegral (s `B.unsafeIndex` 7) ) -- | Read a Int64 in little endian format getInt64le :: Get Int64 getInt64le = do s <- getBytes 8 return $! (fromIntegral (s `B.unsafeIndex` 7) `shiftL` 56) .|. (fromIntegral (s `B.unsafeIndex` 6) `shiftL` 48) .|. (fromIntegral (s `B.unsafeIndex` 5) `shiftL` 40) .|. (fromIntegral (s `B.unsafeIndex` 4) `shiftL` 32) .|. (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 24) .|. (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 16) .|. (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) ) {-# INLINE getInt8 #-} {-# INLINE getInt16be #-} {-# INLINE getInt16le #-} {-# INLINE getInt32be #-} {-# INLINE getInt32le #-} {-# INLINE getInt64be #-} {-# INLINE getInt64le #-} ------------------------------------------------------------------------ -- | Read a Word8 from the monad state getWord8 :: Get Word8 getWord8 = do s <- getBytes 1 return (B.unsafeHead s) -- | Read a Word16 in big endian format getWord16be :: Get Word16 getWord16be = do s <- getBytes 2 return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|. (fromIntegral (s `B.unsafeIndex` 1)) -- | Read a Word16 in little endian format getWord16le :: Get Word16 getWord16le = do s <- getBytes 2 return $! (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) ) -- | Read a Word32 in big endian format getWord32be :: Get Word32 getWord32be = do s <- getBytes 4 return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|. (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|. (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 8) .|. (fromIntegral (s `B.unsafeIndex` 3) ) -- | Read a Word32 in little endian format getWord32le :: Get Word32 getWord32le = do s <- getBytes 4 return $! (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|. (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|. (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) ) -- | Read a Word64 in big endian format getWord64be :: Get Word64 getWord64be = do s <- getBytes 8 return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|. (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|. (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|. (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|. (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|. (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|. (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 8) .|. (fromIntegral (s `B.unsafeIndex` 7) ) -- | Read a Word64 in little endian format getWord64le :: Get Word64 getWord64le = do s <- getBytes 8 return $! (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|. (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|. (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|. (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|. (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|. (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|. (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 8) .|. (fromIntegral (s `B.unsafeIndex` 0) ) {-# INLINE getWord8 #-} {-# INLINE getWord16be #-} {-# INLINE getWord16le #-} {-# INLINE getWord32be #-} {-# INLINE getWord32le #-} {-# INLINE getWord64be #-} {-# INLINE getWord64le #-} ------------------------------------------------------------------------ -- Host-endian reads -- | /O(1)./ Read a single native machine word. The word is read in -- host order, host endian form, for the machine you're on. On a 64 bit -- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. getWordhost :: Get Word getWordhost = getPtr (sizeOf (undefined :: Word)) -- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. getWord16host :: Get Word16 getWord16host = getPtr (sizeOf (undefined :: Word16)) -- | /O(1)./ Read a Word32 in native host order and host endianness. getWord32host :: Get Word32 getWord32host = getPtr (sizeOf (undefined :: Word32)) -- | /O(1)./ Read a Word64 in native host order and host endianess. getWord64host :: Get Word64 getWord64host = getPtr (sizeOf (undefined :: Word64)) ------------------------------------------------------------------------ -- Unchecked shifts shiftl_w16 :: Word16 -> Int -> Word16 shiftl_w32 :: Word32 -> Int -> Word32 shiftl_w64 :: Word64 -> Int -> Word64 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) #if WORD_SIZE_IN_BITS < 64 shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) #if __GLASGOW_HASKELL__ <= 606 -- Exported by GHC.Word in GHC 6.8 and higher foreign import ccall unsafe "stg_uncheckedShiftL64" uncheckedShiftL64# :: Word64# -> Int# -> Word64# #endif #else shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) #endif #else shiftl_w16 = shiftL shiftl_w32 = shiftL shiftl_w64 = shiftL #endif -- Containers ------------------------------------------------------------------ getTwoOf :: Get a -> Get b -> Get (a,b) getTwoOf ma mb = M.liftM2 (,) ma mb -- | Get a list in the following format: -- Word64 (big endian format) -- element 1 -- ... -- element n getListOf :: Get a -> Get [a] getListOf m = go [] =<< getWord64be where go as 0 = return $! reverse as go as i = do x <- m x `seq` go (x:as) (i - 1) -- | Get an IArray in the following format: -- index (lower bound) -- index (upper bound) -- Word64 (big endian format) -- element 1 -- ... -- element n getIArrayOf :: (Ix i, IArray a e) => Get i -> Get e -> Get (a i e) getIArrayOf ix e = M.liftM2 listArray (getTwoOf ix ix) (getListOf e) -- | Get a sequence in the following format: -- Word64 (big endian format) -- element 1 -- ... -- element n getSeqOf :: Get a -> Get (Seq.Seq a) getSeqOf m = go Seq.empty =<< getWord64be where go xs 0 = return $! xs go xs n = xs `seq` n `seq` do x <- m go (xs Seq.|> x) (n - 1) -- | Read as a list of lists. getTreeOf :: Get a -> Get (T.Tree a) getTreeOf m = M.liftM2 T.Node m (getListOf (getTreeOf m)) -- | Read as a list of pairs of key and element. getMapOf :: Ord k => Get k -> Get a -> Get (Map.Map k a) getMapOf k m = Map.fromList `fmap` getListOf (getTwoOf k m) -- | Read as a list of pairs of int and element. getIntMapOf :: Get Int -> Get a -> Get (IntMap.IntMap a) getIntMapOf i m = IntMap.fromList `fmap` getListOf (getTwoOf i m) -- | Read as a list of elements. getSetOf :: Ord a => Get a -> Get (Set.Set a) getSetOf m = Set.fromList `fmap` getListOf m -- | Read as a list of ints. getIntSetOf :: Get Int -> Get IntSet.IntSet getIntSetOf m = IntSet.fromList `fmap` getListOf m -- | Read in a Maybe in the following format: -- Word8 (0 for Nothing, anything else for Just) -- element (when Just) getMaybeOf :: Get a -> Get (Maybe a) getMaybeOf m = do tag <- getWord8 case tag of 0 -> return Nothing _ -> Just `fmap` m -- | Read an Either, in the following format: -- Word8 (0 for Left, anything else for Right) -- element a when 0, element b otherwise getEitherOf :: Get a -> Get b -> Get (Either a b) getEitherOf ma mb = do tag <- getWord8 case tag of 0 -> Left `fmap` ma _ -> Right `fmap` mb -- | Read in a length and then read a nested structure -- of that length. getNested :: Get Int -> Get a -> Get a getNested getLen getVal = do n <- getLen isolate n getVal cereal-0.5.3.0/src/Data/Serialize/IEEE754.hs0000644000000000000000000000444112744462505016204 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif -- | IEEE-754 parsing, as described in this stack-overflow article: -- -- module Data.Serialize.IEEE754 ( -- * IEEE-754 reads getFloat32le , getFloat32be , getFloat64le , getFloat64be -- * IEEE-754 writes , putFloat32le , putFloat32be , putFloat64le , putFloat64be ) where import Data.Word ( Word32, Word64 ) import Data.Serialize.Get import Data.Serialize.Put import qualified Data.ByteString.Builder as Builder import System.IO.Unsafe (unsafeDupablePerformIO) import Foreign.Marshal.Alloc (alloca) import Foreign.Storable (peek, poke) import Foreign.Ptr (castPtr, Ptr) #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ( (<$>) ) #endif -- | Read a Float in little endian IEEE-754 format getFloat32le :: Get Float getFloat32le = wordToFloat <$> getWord32le -- | Read a Float in big endian IEEE-754 format getFloat32be :: Get Float getFloat32be = wordToFloat <$> getWord32be -- | Read a Double in little endian IEEE-754 format getFloat64le :: Get Double getFloat64le = wordToDouble <$> getWord64le -- | Read a Double in big endian IEEE-754 format getFloat64be :: Get Double getFloat64be = wordToDouble <$> getWord64be -- | Write a Float in little endian IEEE-754 format putFloat32le :: Float -> Put putFloat32le = putBuilder . Builder.floatLE -- | Write a Float in big endian IEEE-754 format putFloat32be :: Float -> Put putFloat32be = putBuilder . Builder.floatBE -- | Write a Double in little endian IEEE-754 format putFloat64le :: Double -> Put putFloat64le = putBuilder . Builder.doubleLE -- | Write a Double in big endian IEEE-754 format putFloat64be :: Double -> Put putFloat64be = putBuilder . Builder.doubleBE {-# INLINE wordToFloat #-} wordToFloat :: Word32 -> Float wordToFloat w = unsafeDupablePerformIO $ alloca $ \(ptr :: Ptr Word32) -> do poke ptr w peek (castPtr ptr) {-# INLINE wordToDouble #-} wordToDouble :: Word64 -> Double wordToDouble w = unsafeDupablePerformIO $ alloca $ \(ptr :: Ptr Word64) -> do poke ptr w peek (castPtr ptr) cereal-0.5.3.0/src/Data/Serialize/Put.hs0000644000000000000000000002431112744462505016003 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 0 #endif #ifndef MIN_VERSION_bytestring #define MIN_VERSION_bytestring(x,y,z) 0 #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Serialize.Put -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE) -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- -- The Put monad. A monad for efficiently constructing bytestrings. -- ----------------------------------------------------------------------------- module Data.Serialize.Put ( -- * The Put type Put , PutM(..) , Putter , runPut , runPutM , runPutLazy , runPutMLazy , putBuilder , execPut -- * Flushing the implicit parse state , flush -- * Primitives , putWord8 , putByteString , putLazyByteString #if MIN_VERSION_bytestring(0,10,4) , putShortByteString #endif -- * Big-endian primitives , putWord16be , putWord32be , putWord64be -- * Little-endian primitives , putWord16le , putWord32le , putWord64le -- * Host-endian, unaligned writes , putWordhost , putWord16host , putWord32host , putWord64host -- * Containers , putTwoOf , putListOf , putIArrayOf , putSeqOf , putTreeOf , putMapOf , putIntMapOf , putSetOf , putIntSetOf , putMaybeOf , putEitherOf , putNested ) where #if MIN_VERSION_bytestring(0,10,2) import Data.ByteString.Builder (Builder, toLazyByteString) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Builder.Extra as B #elif MIN_VERSION_bytestring(0,10,0) import Data.ByteString.Lazy.Builder (Builder, toLazyByteString) import qualified Data.ByteString.Lazy.Builder as B import qualified Data.ByteString.Lazy.Builder.Extras as B #else #error "cereal requires bytestring >= 0.10.0.0" #endif #if MIN_VERSION_bytestring(0,10,4) import qualified Data.ByteString.Short as BS #endif import qualified Control.Applicative as A import Data.Array.Unboxed import qualified Data.Monoid as M import qualified Data.Foldable as F import Data.Word import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Tree as T #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative import Data.Foldable (foldMap) import Data.Monoid #endif ------------------------------------------------------------------------ -- XXX Strict in builder only. data PairS a = PairS a !Builder sndS :: PairS a -> Builder sndS (PairS _ b) = b -- | The PutM type. A Writer monad over the efficient Builder monoid. newtype PutM a = Put { unPut :: PairS a } -- | Put merely lifts Builder into a Writer monad, applied to (). type Put = PutM () type Putter a = a -> Put instance Functor PutM where fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w {-# INLINE fmap #-} instance A.Applicative PutM where pure a = Put (PairS a M.mempty) {-# INLINE pure #-} m <*> k = Put $ let PairS f w = unPut m PairS x w' = unPut k in PairS (f x) (w `M.mappend` w') {-# INLINE (<*>) #-} m *> k = Put $ let PairS _ w = unPut m PairS b w' = unPut k in PairS b (w `M.mappend` w') {-# INLINE (*>) #-} instance Monad PutM where return = pure {-# INLINE return #-} m >>= k = Put $ let PairS a w = unPut m PairS b w' = unPut (k a) in PairS b (w `M.mappend` w') {-# INLINE (>>=) #-} (>>) = (*>) {-# INLINE (>>) #-} instance Monoid (PutM ()) where mempty = pure () {-# INLINE mempty #-} mappend = (*>) {-# INLINE mappend #-} tell :: Putter Builder tell b = Put $! PairS () b {-# INLINE tell #-} putBuilder :: Putter Builder putBuilder = tell {-# INLINE putBuilder #-} -- | Run the 'Put' monad execPut :: PutM a -> Builder execPut = sndS . unPut {-# INLINE execPut #-} -- | Run the 'Put' monad with a serialiser runPut :: Put -> S.ByteString runPut = L.toStrict . runPutLazy {-# INLINE runPut #-} -- | Run the 'Put' monad with a serialiser and get its result runPutM :: PutM a -> (a, S.ByteString) runPutM (Put (PairS f s)) = (f, L.toStrict (toLazyByteString s)) {-# INLINE runPutM #-} -- | Run the 'Put' monad with a serialiser runPutLazy :: Put -> L.ByteString runPutLazy = toLazyByteString . sndS . unPut {-# INLINE runPutLazy #-} -- | Run the 'Put' monad with a serialiser runPutMLazy :: PutM a -> (a, L.ByteString) runPutMLazy (Put (PairS f s)) = (f, toLazyByteString s) {-# INLINE runPutMLazy #-} ------------------------------------------------------------------------ -- | Pop the ByteString we have constructed so far, if any, yielding a -- new chunk in the result ByteString. flush :: Put flush = tell B.flush {-# INLINE flush #-} -- | Efficiently write a byte into the output buffer putWord8 :: Putter Word8 putWord8 = tell . B.word8 {-# INLINE putWord8 #-} -- | An efficient primitive to write a strict ByteString into the output buffer. -- It flushes the current buffer, and writes the argument into a new chunk. putByteString :: Putter S.ByteString putByteString = tell . B.byteString {-# INLINE putByteString #-} #if MIN_VERSION_bytestring(0,10,4) putShortByteString :: Putter BS.ShortByteString putShortByteString = tell . B.shortByteString #endif -- | Write a lazy ByteString efficiently, simply appending the lazy -- ByteString chunks to the output buffer putLazyByteString :: Putter L.ByteString putLazyByteString = tell . B.lazyByteString {-# INLINE putLazyByteString #-} -- | Write a Word16 in big endian format putWord16be :: Putter Word16 putWord16be = tell . B.word16BE {-# INLINE putWord16be #-} -- | Write a Word16 in little endian format putWord16le :: Putter Word16 putWord16le = tell . B.word16LE {-# INLINE putWord16le #-} -- | Write a Word32 in big endian format putWord32be :: Putter Word32 putWord32be = tell . B.word32BE {-# INLINE putWord32be #-} -- | Write a Word32 in little endian format putWord32le :: Putter Word32 putWord32le = tell . B.word32LE {-# INLINE putWord32le #-} -- | Write a Word64 in big endian format putWord64be :: Putter Word64 putWord64be = tell . B.word64BE {-# INLINE putWord64be #-} -- | Write a Word64 in little endian format putWord64le :: Putter Word64 putWord64le = tell . B.word64LE {-# INLINE putWord64le #-} ------------------------------------------------------------------------ -- | /O(1)./ Write a single native machine word. The word is -- written in host order, host endian form, for the machine you're on. -- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, -- 4 bytes. Values written this way are not portable to -- different endian or word sized machines, without conversion. -- putWordhost :: Putter Word putWordhost = tell . B.wordHost {-# INLINE putWordhost #-} -- | /O(1)./ Write a Word16 in native host order and host endianness. -- For portability issues see @putWordhost@. putWord16host :: Putter Word16 putWord16host = tell . B.word16Host {-# INLINE putWord16host #-} -- | /O(1)./ Write a Word32 in native host order and host endianness. -- For portability issues see @putWordhost@. putWord32host :: Putter Word32 putWord32host = tell . B.word32Host {-# INLINE putWord32host #-} -- | /O(1)./ Write a Word64 in native host order -- On a 32 bit machine we write two host order Word32s, in big endian form. -- For portability issues see @putWordhost@. putWord64host :: Putter Word64 putWord64host = tell . B.word64Host {-# INLINE putWord64host #-} -- Containers ------------------------------------------------------------------ encodeListOf :: (a -> Builder) -> [a] -> Builder encodeListOf f = -- allow inlining with just a single argument \xs -> execPut (putWord64be (fromIntegral $ length xs)) `M.mappend` F.foldMap f xs {-# INLINE encodeListOf #-} putTwoOf :: Putter a -> Putter b -> Putter (a,b) putTwoOf pa pb (a,b) = pa a >> pb b {-# INLINE putTwoOf #-} putListOf :: Putter a -> Putter [a] putListOf pa = \l -> do putWord64be (fromIntegral (length l)) mapM_ pa l {-# INLINE putListOf #-} putIArrayOf :: (Ix i, IArray a e) => Putter i -> Putter e -> Putter (a i e) putIArrayOf pix pe a = do putTwoOf pix pix (bounds a) putListOf pe (elems a) {-# INLINE putIArrayOf #-} putSeqOf :: Putter a -> Putter (Seq.Seq a) putSeqOf pa = \s -> do putWord64be (fromIntegral $ Seq.length s) F.mapM_ pa s {-# INLINE putSeqOf #-} putTreeOf :: Putter a -> Putter (T.Tree a) putTreeOf pa = tell . go where go (T.Node x cs) = execPut (pa x) `M.mappend` encodeListOf go cs {-# INLINE putTreeOf #-} putMapOf :: Putter k -> Putter a -> Putter (Map.Map k a) putMapOf pk pa = putListOf (putTwoOf pk pa) . Map.toAscList {-# INLINE putMapOf #-} putIntMapOf :: Putter Int -> Putter a -> Putter (IntMap.IntMap a) putIntMapOf pix pa = putListOf (putTwoOf pix pa) . IntMap.toAscList {-# INLINE putIntMapOf #-} putSetOf :: Putter a -> Putter (Set.Set a) putSetOf pa = putListOf pa . Set.toAscList {-# INLINE putSetOf #-} putIntSetOf :: Putter Int -> Putter IntSet.IntSet putIntSetOf pix = putListOf pix . IntSet.toAscList {-# INLINE putIntSetOf #-} putMaybeOf :: Putter a -> Putter (Maybe a) putMaybeOf _ Nothing = putWord8 0 putMaybeOf pa (Just a) = putWord8 1 >> pa a {-# INLINE putMaybeOf #-} putEitherOf :: Putter a -> Putter b -> Putter (Either a b) putEitherOf pa _ (Left a) = putWord8 0 >> pa a putEitherOf _ pb (Right b) = putWord8 1 >> pb b {-# INLINE putEitherOf #-} -- | Put a nested structure by first putting a length -- field and then putting the encoded value. putNested :: Putter Int -> Put -> Put putNested putLen putVal = do let bs = runPut putVal putLen (S.length bs) putByteString bs cereal-0.5.3.0/tests/0000755000000000000000000000000012744462505012451 5ustar0000000000000000cereal-0.5.3.0/tests/GetTests.hs0000644000000000000000000001554112744462505014555 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} module GetTests (tests) where import Control.Applicative import Control.Monad import Data.Word import Data.Function import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LB import Data.Serialize.Get import Test.Framework (Test(),testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck as QC -- Data to express Get parser to generate data GetD = Get8 | Eof | Get16be | Get32be | Get64be | Get16le | Get32le | Get64le | GetD :*> GetD | GetD :<|> GetD | LookAhead GetD | Skip Int deriving Show -- Get parser generator buildGet :: GetD -> Get () buildGet = d where d Get8 = getWord8 *> pure () d Eof = guard =<< isEmpty d Get16be = getWord16be *> pure () d Get32be = getWord32be *> pure () d Get64be = getWord64be *> pure () d Get16le = getWord16le *> pure () d Get32le = getWord32le *> pure () d Get64le = getWord64le *> pure () d (x :*> y) = d x *> d y d (x :<|> y) = d x <|> d y d (LookAhead x) = lookAhead $ d x d (Skip i) = skip i -- Randomly generate parser genGetD :: Gen GetD genGetD = oneof $ [ pure g | g <- [ Get8, Eof , Get16be, Get32be, Get64be , Get16le, Get32le, Get64le ] ] ++ [ (:*>) <$> genGetD <*> genGetD , (:<|>) <$> genGetD <*> genGetD , LookAhead <$> genGetD , Skip <$> choose (0, 10) ] instance Arbitrary GetD where arbitrary = genGetD instance Arbitrary (Get ()) where arbitrary = buildGet <$> genGetD newtype R a = R { unR :: Either String a } deriving Show -- Ignore equality of error message string instance Eq a => Eq (R a) where (==) = (==) `on` either (const Nothing) Just . unR data Chunks = Chunks [[Word8]] deriving (Eq, Show) mkChunks :: Word -> Chunks mkChunks n = Chunks . take (fromIntegral n) $ cycle [ [x] | x <- [0 .. 255] ] instance Arbitrary Chunks where arbitrary = mkChunks <$> choose (0, 512) testLength :: Word testLength = 255 -- Equality between strict and lazy parsing eqStrictLazy :: GetD -> Property eqStrictLazy getD = conjoin [ counterexample (show in0) $ R (runGet parser sb) == R (runGetLazy parser lb) | n <- [0 .. testLength] , let Chunks in0 = mkChunks n lb = LB.fromChunks [ BS.pack c | c <- in0 ] sb = BS.pack $ concat in0 ] where parser = buildGet getD -- Remaining length equality between strict and lazy parsing remainingStrictLazy :: GetD -> Property remainingStrictLazy getD = conjoin [ counterexample (show in0) $ R (runGet parser sb) == R (runGetLazy parser lb) | n <- [0 .. testLength] , let Chunks in0 = mkChunks n lb = LB.fromChunks [ BS.pack c | c <- in0 ] sb = BS.pack $ concat in0 ] where parser = buildGet getD *> remaining isEmpty2 :: Get Bool isEmpty2 = do lookAhead getWord8 *> pure False <|> pure True -- Compare with chunks (==~) :: Eq a => Get a -> Get a -> Property p1 ==~ p2 = conjoin [ counterexample (show in0) $ R (runGetLazy p1 s) == R (runGetLazy p2 s) | n <- [0 .. testLength] , let Chunks in0 = mkChunks n s = LB.fromChunks [ BS.pack c | c <- in0 ] ] (==!) :: Eq a => Get a -> Get a -> Property p1 ==! p2 = conjoin [ counterexample (show s) $ R (runGet p1 s) == R (runGet p2 s) | n <- [0 .. testLength] , let Chunks in0 = mkChunks n s = BS.pack $ concat in0 ] infix 2 ==~, ==! -- Equality between two eof definition - lazy eqEof :: GetD -> Property eqEof getD = x *> isEmpty ==~ x *> isEmpty2 where x = buildGet getD -- Equality between two eof definition - strict eqEof' :: GetD -> Property eqEof' getD = x *> isEmpty ==! x *> isEmpty2 where x = buildGet getD monadIdL :: GetD -> Property monadIdL getD = (return () >>= const x) ==~ x where x = buildGet getD monadIdL' :: GetD -> Property monadIdL' getD = (return () >>= const x) ==! x where x = buildGet getD monadIdR :: GetD -> Property monadIdR getD = (x >>= return) ==~ x where x = buildGet getD monadIdR' :: GetD -> Property monadIdR' getD = (x >>= return) ==! x where x = buildGet getD monadAssoc :: GetD -> GetD -> GetD -> Property monadAssoc p1 p2 p3 = (x >> (y >> z)) ==~ (x >> y >> z) where x = buildGet p1 y = buildGet p2 z = buildGet p3 monadAssoc' :: GetD -> GetD -> GetD -> Property monadAssoc' p1 p2 p3 = (x >> (y >> z)) ==! (x >> y >> z) where x = buildGet p1 y = buildGet p2 z = buildGet p3 alterIdL :: GetD -> Property alterIdL getD = empty <|> x ==~ x where x = buildGet getD alterIdL' :: GetD -> Property alterIdL' getD = empty <|> x ==! x where x = buildGet getD alterIdR :: GetD -> Property alterIdR getD = x <|> empty ==~ x where x = buildGet getD alterIdR' :: GetD -> Property alterIdR' getD = x <|> empty ==! x where x = buildGet getD alterAssoc :: GetD -> GetD -> GetD -> Property alterAssoc p1 p2 p3 = x <|> y <|> z ==~ x <|> (y <|> z) where x = buildGet p1 y = buildGet p2 z = buildGet p3 alterAssoc' :: GetD -> GetD -> GetD -> Property alterAssoc' p1 p2 p3 = x <|> y <|> z ==! x <|> (y <|> z) where x = buildGet p1 y = buildGet p2 z = buildGet p3 alterDistr :: GetD -> GetD -> GetD -> Property alterDistr p1 p2 p3 = x *> (y <|> z) ==~ x *> y <|> x *> z where x = buildGet p1 y = buildGet p2 z = buildGet p3 alterDistr' :: GetD -> GetD -> GetD -> Property alterDistr' p1 p2 p3 = x *> (y <|> z) ==! x *> y <|> x *> z where x = buildGet p1 y = buildGet p2 z = buildGet p3 tests :: Test tests = testGroup "GetTests" [ testProperty "lazy - monad left id" monadIdL , testProperty "strict - monad left id" monadIdL' , testProperty "lazy - monad right id" monadIdR , testProperty "strict - monad right id" monadIdR' , testProperty "lazy - monad assoc" monadAssoc , testProperty "strict - monad assoc" monadAssoc' , testProperty "strict lazy - equality" eqStrictLazy , testProperty "strict lazy - remaining equality"remainingStrictLazy , testProperty "lazy - two eof" eqEof , testProperty "strict - two eof" eqEof' , testProperty "lazy - alternative left Id" alterIdL , testProperty "strict - alternative left Id" alterIdL' , testProperty "lazy - alternative right Id" alterIdR , testProperty "strict - alternative right Id" alterIdR' , testProperty "lazy - alternative assoc" alterAssoc , testProperty "strict - alternative assoc" alterAssoc' , testProperty "lazy - alternative distr" alterDistr , testProperty "strict - alternative distr" alterDistr' ] cereal-0.5.3.0/tests/Main.hs0000644000000000000000000000027612744462505013676 0ustar0000000000000000module Main where import qualified GetTests import qualified RoundTrip import Test.Framework.Runners.Console main :: IO () main = defaultMain [ GetTests.tests , RoundTrip.tests ] cereal-0.5.3.0/tests/RoundTrip.hs0000644000000000000000000000505312744462505014736 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} -------------------------------------------------------------------------------- -- | -- Module : -- Copyright : (c) Galois, Inc, 2009 -- License : BSD3 -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- module RoundTrip where import Data.Serialize import Data.Serialize.Get import Data.Serialize.Put import Data.Serialize.IEEE754 import Data.Word (Word8,Word16,Word32,Word64) import System.Exit (ExitCode(..), exitSuccess, exitWith) import Test.QuickCheck as QC import Test.Framework (Test(),testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) roundTrip :: Eq a => Putter a -> Get a -> a -> Bool roundTrip p g a = res == Right a where res = runGet g (runPut (p a)) -- | Did a call to 'quickCheckResult' succeed? isSuccess :: QC.Result -> Bool isSuccess (Success _ _ _) = True isSuccess _ = False tests :: Test tests = testGroup "Round Trip" [ testProperty "Word8 Round Trip" $ roundTrip putWord8 getWord8 , testProperty "Word16be Round Trip" $ roundTrip putWord16be getWord16be , testProperty "Word16le Round Trip" $ roundTrip putWord16le getWord16le , testProperty "Word32be Round Trip" $ roundTrip putWord32be getWord32be , testProperty "Word32le Round Trip" $ roundTrip putWord32le getWord32le , testProperty "Word64be Round Trip" $ roundTrip putWord64be getWord64be , testProperty "Word64le Round Trip" $ roundTrip putWord64le getWord64le , testProperty "Word16host Round Trip" $ roundTrip putWord16host getWord16host , testProperty "Word32host Round Trip" $ roundTrip putWord32host getWord32host , testProperty "Word64host Round Trip" $ roundTrip putWord64host getWord64host , testProperty "Float32le Round Trip" $ roundTrip putFloat32le getFloat32le , testProperty "Float32be Round Trip" $ roundTrip putFloat32be getFloat32be , testProperty "Float64le Round Trip" $ roundTrip putFloat64le getFloat64le , testProperty "Float64be Round Trip" $ roundTrip putFloat64be getFloat64be -- Containers , testProperty "(Word8,Word8) Round Trip" $ roundTrip (putTwoOf putWord8 putWord8) (getTwoOf getWord8 getWord8) , testProperty "[Word8] Round Trip" $ roundTrip (putListOf putWord8) (getListOf getWord8) , testProperty "Maybe Word8 Round Trip" $ roundTrip (putMaybeOf putWord8) (getMaybeOf getWord8) , testProperty "Either Word8 Word16be Round Trip " $ roundTrip (putEitherOf putWord8 putWord16be) (getEitherOf getWord8 getWord16be) ]