cereal 0.5.3.0 → 0.5.8.3
raw patch · 6 files changed
Files
- CHANGELOG.md +29/−0
- cereal.cabal +18/−5
- src/Data/Serialize.hs +56/−25
- src/Data/Serialize/Get.hs +74/−64
- src/Data/Serialize/Put.hs +134/−22
- tests/RoundTrip.hs +2/−2
CHANGELOG.md view
@@ -1,3 +1,32 @@+0.5.8.3+=======+* GHC 9.4.1 compatibility++0.5.8.1+=======+* GHC 8.8.1 compatibility++0.5.8.0+=======+* Added ShortByteString instances++0.5.7.0+=======+* Added `runPutMBuilder`++0.5.6.0+=======+* Added GSerializeGet and GSerializePut instances for V1++0.5.5.0+=======+* Added Semigroup instances++0.5.4.0+=======++* Allow building with older versions of GHC (thanks to Ryan Scott!)+* Additional putters for ints (thanks to Andrew Martin!) 0.5.2.0 ======
cereal.cabal view
@@ -1,12 +1,12 @@ name: cereal-version: 0.5.3.0+version: 0.5.8.3 license: BSD3 license-file: LICENSE author: Lennart Kolmodin <kolmodin@dtek.chalmers.se>, Galois Inc., Lemmih <lemmih@gmail.com>, Bas van Dijk <v.dijk.bas@gmail.com>-maintainer: Trevor Elliott <trevor@galois.com>+maintainer: Eric Mertens <emertens@galois.com> category: Data, Parsing stability: provisional build-type: Simple@@ -25,16 +25,29 @@ type: git location: git://github.com/GaloisInc/cereal.git +flag bytestring-builder+ description:+ Decides whether to use an older version of bytestring along with bytestring-builder or just a newer version of bytestring.+ .+ This flag normally toggles automatically but you can use `-fbytestring-builder` or `-f-bytestring-builder` to explicitly change it.+ default: False+ manual: False+ library default-language: Haskell2010 - build-depends: bytestring >= 0.10.2.0,- base >= 4.4 && < 5, containers, array,+ build-depends: base >= 4.4 && < 5, containers, array, ghc-prim >= 0.2 if !impl(ghc >= 8.0) build-depends: fail == 4.9.* + if flag(bytestring-builder)+ build-depends: bytestring >= 0.9 && < 0.10.4,+ bytestring-builder >= 0.10.4 && < 1+ else+ build-depends: bytestring >= 0.10.4 && < 1+ hs-source-dirs: src exposed-modules: Data.Serialize,@@ -52,7 +65,7 @@ type: exitcode-stdio-1.0 build-depends: base == 4.*,- bytestring >= 0.10.8.1,+ bytestring >= 0.9, QuickCheck, test-framework, test-framework-quickcheck2,
src/Data/Serialize.hs view
@@ -16,7 +16,7 @@ -- Module : Data.Serialize -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE)--- +-- -- Maintainer : Trevor Elliott <trevor@galois.com> -- Stability : -- Portability :@@ -57,16 +57,17 @@ 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 qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as S+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 @@ -199,23 +200,23 @@ -- Int8s are written as a single byte. instance Serialize Int8 where- put i = put (fromIntegral i :: Word8)- get = liftM fromIntegral (get :: Get Word8)+ put = putInt8+ get = getInt8 -- 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)+ put = putInt16be+ get = getInt16be -- 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)+ put = putInt32be+ get = getInt32be -- 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)+ put = putInt64be+ get = getInt64be ------------------------------------------------------------------------ @@ -230,7 +231,7 @@ get = liftM fromIntegral (get :: Get Int64) --------------------------------------------------------------------------- +-- -- Portable, and pretty efficient, serialisation of Integer -- @@ -254,7 +255,9 @@ put n = do putWord8 1 put sign- put (unroll (abs n)) -- unroll the bytes+ let len = ((nrBits (abs n) + 7) `div` 8)+ putWord64be (fromIntegral len)+ mapM_ put (unroll (abs n)) -- unroll the bytes where sign = fromIntegral (signum n) :: Word8 @@ -281,6 +284,17 @@ where unstep b a = a `shiftL` 8 .|. fromIntegral b +nrBits :: (Ord a, Integral a) => a -> Int+nrBits k =+ let expMax = until (\e -> 2 ^ e > k) (* 2) 1+ findNr :: Int -> Int -> Int+ findNr lo hi+ | mid == lo = hi+ | 2 ^ mid <= k = findNr mid hi+ | otherwise = findNr lo mid+ where mid = (lo + hi) `div` 2+ in findNr (expMax `div` 2) expMax+ 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@@ -299,7 +313,9 @@ put n = do putWord8 1- put (unroll (abs n)) -- unroll the bytes+ let len = ((nrBits (abs n) + 7) `div` 8)+ putWord64be (fromIntegral len)+ mapM_ put (unroll (abs n)) -- unroll the bytes {-# INLINE get #-} get = do@@ -312,7 +328,7 @@ ------------------------------------------------------------------------ --- Safely wrap `chr` to avoid exceptions. +-- 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@@ -362,7 +378,7 @@ return (z .|. shiftL6 (y .|. shiftL6 (x .|. shiftL6 (xor 0xf0 w)))) case chrEither r of- Right r' -> + Right r' -> return $! r' Left err -> fail err@@ -388,7 +404,7 @@ 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: -- @@ -484,7 +500,12 @@ putLazyByteString bs get = get >>= getLazyByteString +instance Serialize S.ShortByteString where+ put sbs = do put (S.length sbs)+ putShortByteString sbs+ get = get >>= getShortByteString + ------------------------------------------------------------------------ -- Maps and Sets @@ -575,6 +596,16 @@ instance GSerializeGet U1 where gGet = pure U1+ {-# INLINE gGet #-}++-- | Always fails to serialize+instance GSerializePut V1 where+ gPut v = v `seq` error "GSerializePut.V1"+ {-# INLINE gPut #-}++-- | Always fails to deserialize+instance GSerializeGet V1 where+ gGet = fail "GSerializeGet.V1" {-# INLINE gGet #-} instance (GSerializePut a, GSerializePut b) => GSerializePut (a :*: b) where
src/Data/Serialize/Get.hs view
@@ -46,6 +46,7 @@ , lookAheadM , lookAheadE , uncheckedLookAhead+ , bytesRead -- * Utility , getBytes@@ -59,10 +60,7 @@ -- ** ByteStrings , getByteString , getLazyByteString--#if MIN_VERSION_bytestring(0,10,4) , getShortByteString-#endif -- ** Big-endian reads , getWord16be@@ -116,6 +114,7 @@ import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as BS import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map@@ -123,12 +122,6 @@ 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@@ -160,8 +153,8 @@ -- | 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 }+ -> Int -> Failure r+ -> Success a r -> Result r } type Input = B.ByteString type Buffer = Maybe B.ByteString@@ -184,7 +177,7 @@ {-# INLINE bufferBytes #-} type Failure r = Input -> Buffer -> More -> [String] -> String -> Result r-type Success a r = Input -> Buffer -> More -> a -> Result r+type Success a r = Input -> Buffer -> More -> Int -> a -> Result r -- | Have we read all available input? data More@@ -198,20 +191,20 @@ 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)+ fmap p m = Get $ \ s0 b0 m0 w0 kf ks ->+ unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 a -> ks s1 b1 m1 w1 (p a) instance A.Applicative Get where- pure a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a+ pure a = Get $ \ s0 b0 m0 w _ ks -> ks s0 b0 m0 w 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)+ f <*> x = Get $ \ s0 b0 m0 w0 kf ks ->+ unGet f s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 g ->+ unGet x s1 b1 m1 w1 kf $ \ s2 b2 m2 w2 y -> ks s2 b2 m2 w2 (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+ m *> k = Get $ \ s0 b0 m0 w0 kf ks ->+ unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 _ -> unGet k s1 b1 m1 w1 kf ks {-# INLINE (*>) #-} instance A.Alternative Get where@@ -226,15 +219,17 @@ 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+ m >>= g = Get $ \ s0 b0 m0 w0 kf ks ->+ unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 a -> unGet (g a) s1 b1 m1 w1 kf ks {-# INLINE (>>=) #-} (>>) = (A.*>) {-# INLINE (>>) #-} +#if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail {-# INLINE fail #-}+#endif instance Fail.MonadFail Get where fail = failDesc@@ -243,15 +238,15 @@ instance M.MonadPlus Get where mzero = failDesc "mzero" {-# INLINE mzero #-}-+-- TODO: Test this! mplus a b =- Get $ \s0 b0 m0 kf ks ->+ Get $ \s0 b0 m0 w0 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'+ b1 m1 w0 kf' ks'+ in unGet a s0 emptyBuffer m0 w0 try ks' {-# INLINE mplus #-} @@ -262,21 +257,21 @@ formatTrace ls = "From:\t" ++ intercalate "\n\t" ls ++ "\n" get :: Get B.ByteString-get = Get (\s0 b0 m0 _ k -> k s0 b0 m0 s0)+get = Get (\s0 b0 m0 w _ k -> k s0 b0 m0 w s0) {-# INLINE get #-} -put :: B.ByteString -> Get ()-put s = Get (\_ b0 m _ k -> k s b0 m ())+put :: B.ByteString -> Int -> Get ()+put s !w = Get (\_ b0 m _ _ k -> k s b0 m w ()) {-# INLINE put #-} label :: String -> Get a -> Get a label l m =- Get $ \ s0 b0 m0 kf ks ->+ Get $ \ s0 b0 m0 w0 kf ks -> let kf' s1 b1 m1 ls = kf s1 b1 m1 (l:ls)- in unGet m s0 b0 m0 kf' ks+ in unGet m s0 b0 m0 w0 kf' ks finalK :: Success a a-finalK s _ _ a = Done a s+finalK s _ _ _ a = Done a s failK :: Failure a failK s b _ ls msg =@@ -285,7 +280,7 @@ -- | 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+ case unGet m str Nothing Complete 0 failK finalK of Fail i _ -> Left i Done a _ -> Right a Partial{} -> Left "Failed reading: Internal error: unexpected Partial."@@ -296,7 +291,7 @@ -- 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+runGetChunk m mbLen str = unGet m str Nothing (Incomplete mbLen) 0 failK finalK {-# INLINE runGetChunk #-} -- | Run the Get monad applies a 'get'-based parser on the input ByteString@@ -305,8 +300,8 @@ {-# 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.+-- ByteString, starting at the specified offset. In addition to the result of get+-- it returns 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@@ -315,12 +310,12 @@ {-# 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.+-- ByteString, starting at the specified offset. In addition to the result of get+-- it returns 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+ case unGet m (B.drop off str) Nothing Complete 0 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)@@ -344,7 +339,6 @@ 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) []@@ -372,19 +366,18 @@ -- input, otherwise fail. {-# INLINE ensure #-} ensure :: Int -> Get B.ByteString-ensure n0 = n0 `seq` Get $ \ s0 b0 m0 kf ks -> let+ensure n0 = n0 `seq` Get $ \ s0 b0 m0 w0 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+ then ks s0 b0 m0 w0 s0+ else getMore n' s0 [] b0 m0 w0 kf ks where -- The "accumulate and concat" pattern here is important not to incur -- in quadratic behavior, see <https://github.com/GaloisInc/cereal/issues/48> 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+ getMore !n s0 ss b0 m0 w0 kf ks = let tooFewBytes = let !s = finalInput s0 ss !b = finalBuffer b0 s0 ss@@ -398,16 +391,16 @@ !mb' = case mb of Just l -> Just $! l - B.length s Nothing -> Nothing- in checkIfEnough n s (s0 : ss) b0 (Incomplete mb') kf ks+ in checkIfEnough n s (s0 : ss) b0 (Incomplete mb') w0 kf ks - checkIfEnough !n s0 ss b0 m0 kf ks = let+ checkIfEnough !n s0 ss b0 m0 w0 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+ in ks s b m0 w0 s+ else getMore n' s0 ss b0 m0 w0 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.@@ -416,48 +409,52 @@ 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'+ cur <- bytesRead+ put s' cur a <- m used <- get unless (B.null used) (fail "not all bytes parsed in isolate")- put rest+ put rest (cur + n) return a failDesc :: String -> Get a failDesc err = do let msg = "Failed reading: " ++ err- Get (\s0 b0 m0 kf _ -> kf s0 b0 m0 [] msg)+ 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)+ cur <- bytesRead+ put (B.drop n s) (cur + n) -- | 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)+ cur <- bytesRead+ put (B.drop n s) (cur + n) -- | 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 ->+lookAhead ga = Get $ \ s0 b0 m0 w0 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'+ in unGet ga s0 emptyBuffer m0 w0 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+ pre <- bytesRead ma <- gma- M.when (isNothing ma) (put s)+ M.when (isNothing ma) (put s pre) return ma -- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'.@@ -465,9 +462,10 @@ lookAheadE :: Get (Either a b) -> Get (Either a b) lookAheadE gea = do s <- get+ pre <- bytesRead ea <- gea case ea of- Left _ -> put s+ Left _ -> put s pre _ -> return () return ea @@ -487,14 +485,14 @@ -- 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))+remaining = Get (\ s0 b0 m0 w0 _ ks -> ks s0 b0 m0 w0 (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))+isEmpty = Get (\ s0 b0 m0 w0 _ ks -> ks s0 b0 m0 w0 (B.null s0 && moreLength m0 == 0)) ------------------------------------------------------------------------ -- Utility with ByteStrings@@ -511,12 +509,10 @@ 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 ------------------------------------------------------------------------@@ -530,7 +526,8 @@ let consume = B.unsafeTake n s rest = B.unsafeDrop n s -- (consume,rest) = B.splitAt n s- put rest+ cur <- bytesRead+ put rest (cur + n) return consume {-# INLINE getBytes #-} @@ -714,7 +711,7 @@ getWord32host :: Get Word32 getWord32host = getPtr (sizeOf (undefined :: Word32)) --- | /O(1)./ Read a Word64 in native host order and host endianess.+-- | /O(1)./ Read a Word64 in native host order and host endianness. getWord64host :: Get Word64 getWord64host = getPtr (sizeOf (undefined :: Word64)) @@ -726,8 +723,13 @@ shiftl_w64 :: Word64 -> Int -> Word64 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#if MIN_VERSION_base(4,16,0)+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftLWord16#` i)+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftLWord32#` i)+#else shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)+#endif #if WORD_SIZE_IN_BITS < 64 shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)@@ -739,8 +741,12 @@ #endif #else+#if MIN_VERSION_base(4,17,0)+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)+#else shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) #endif+#endif #else shiftl_w16 = shiftL@@ -835,3 +841,7 @@ getNested getLen getVal = do n <- getLen isolate n getVal++-- | Get the number of bytes read up to this point+bytesRead :: Get Int+bytesRead = Get (\i b m w _ k -> k i b m w w)
src/Data/Serialize/Put.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} @@ -14,7 +15,7 @@ -- Module : Data.Serialize.Put -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE)--- +-- -- Maintainer : Trevor Elliott <trevor@galois.com> -- Stability : -- Portability :@@ -33,6 +34,7 @@ , runPutM , runPutLazy , runPutMLazy+ , runPutMBuilder , putBuilder , execPut @@ -41,28 +43,36 @@ -- * Primitives , putWord8+ , putInt8 , putByteString , putLazyByteString--#if MIN_VERSION_bytestring(0,10,4) , putShortByteString-#endif -- * Big-endian primitives , putWord16be , putWord32be , putWord64be+ , putInt16be+ , putInt32be+ , putInt64be -- * Little-endian primitives , putWord16le , putWord32le , putWord64le+ , putInt16le+ , putInt32le+ , putInt64le -- * Host-endian, unaligned writes , putWordhost , putWord16host , putWord32host , putWord64host+ , putInthost+ , putInt16host+ , putInt32host+ , putInt64host -- * Containers , putTwoOf@@ -81,27 +91,20 @@ ) 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+#if MIN_VERSION_base(4,9,0)+import qualified Data.Semigroup as M+#endif import qualified Data.Monoid as M import qualified Data.Foldable as F import Data.Word+import Data.Int import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.IntMap as IntMap@@ -117,9 +120,17 @@ import Data.Monoid #endif +#if !(MIN_VERSION_bytestring(0,10,0))+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.Ptr (plusPtr)+import qualified Data.ByteString.Internal as S+import qualified Data.ByteString.Lazy.Internal as L+#endif+ ------------------------------------------------------------------------ --- XXX Strict in builder only. +-- XXX Strict in builder only. data PairS a = PairS a !Builder sndS :: PairS a -> Builder@@ -168,12 +179,20 @@ (>>) = (*>) {-# INLINE (>>) #-} +#if MIN_VERSION_base(4,9,0)+instance M.Semigroup (PutM ()) where+ (<>) = (*>)+ {-# INLINE (<>) #-}+#endif+ instance Monoid (PutM ()) where mempty = pure () {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) mappend = (*>) {-# INLINE mappend #-}+#endif tell :: Putter Builder tell b = Put $! PairS () b@@ -190,12 +209,12 @@ -- | Run the 'Put' monad with a serialiser runPut :: Put -> S.ByteString-runPut = L.toStrict . runPutLazy+runPut = lazyToStrictByteString . 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))+runPutM (Put (PairS f s)) = (f, lazyToStrictByteString (toLazyByteString s)) {-# INLINE runPutM #-} -- | Run the 'Put' monad with a serialiser@@ -208,6 +227,11 @@ runPutMLazy (Put (PairS f s)) = (f, toLazyByteString s) {-# INLINE runPutMLazy #-} +-- | Run the 'Put' monad and get the result and underlying 'Builder'+runPutMBuilder :: PutM a -> (a, Builder)+runPutMBuilder (Put (PairS f s)) = (f, s)+{-# INLINE runPutMBuilder #-}+ ------------------------------------------------------------------------ -- | Pop the ByteString we have constructed so far, if any, yielding a@@ -221,16 +245,19 @@ putWord8 = tell . B.word8 {-# INLINE putWord8 #-} +-- | Efficiently write an int into the output buffer+putInt8 :: Putter Int8+putInt8 = tell . B.int8+{-# INLINE putInt8 #-}+ -- | 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@@ -299,7 +326,68 @@ putWord64host = tell . B.word64Host {-# INLINE putWord64host #-} +-- | Write a Int16 in big endian format+putInt16be :: Putter Int16+putInt16be = tell . B.int16BE+{-# INLINE putInt16be #-} +-- | Write a Int16 in little endian format+putInt16le :: Putter Int16+putInt16le = tell . B.int16LE+{-# INLINE putInt16le #-}++-- | Write a Int32 in big endian format+putInt32be :: Putter Int32+putInt32be = tell . B.int32BE+{-# INLINE putInt32be #-}++-- | Write a Int32 in little endian format+putInt32le :: Putter Int32+putInt32le = tell . B.int32LE+{-# INLINE putInt32le #-}++-- | Write a Int64 in big endian format+putInt64be :: Putter Int64+putInt64be = tell . B.int64BE+{-# INLINE putInt64be #-}++-- | Write a Int64 in little endian format+putInt64le :: Putter Int64+putInt64le = tell . B.int64LE+{-# INLINE putInt64le #-}++------------------------------------------------------------------------++-- | /O(1)./ Write a single native machine int. The int is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Int is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or int sized machines, without conversion.+--+putInthost :: Putter Int+putInthost = tell . B.intHost+{-# INLINE putInthost #-}++-- | /O(1)./ Write a Int16 in native host order and host endianness.+-- For portability issues see @putInthost@.+putInt16host :: Putter Int16+putInt16host = tell . B.int16Host+{-# INLINE putInt16host #-}++-- | /O(1)./ Write a Int32 in native host order and host endianness.+-- For portability issues see @putInthost@.+putInt32host :: Putter Int32+putInt32host = tell . B.int32Host+{-# INLINE putInt32host #-}++-- | /O(1)./ Write a Int64 in native host order+-- On a 32 bit machine we write two host order Int32s, in big endian form.+-- For portability issues see @putInthost@.+putInt64host :: Putter Int64+putInt64host = tell . B.int64Host+{-# INLINE putInt64host #-}++ -- Containers ------------------------------------------------------------------ encodeListOf :: (a -> Builder) -> [a] -> Builder@@ -326,12 +414,12 @@ putSeqOf :: Putter a -> Putter (Seq.Seq a) putSeqOf pa = \s -> do- putWord64be (fromIntegral $ Seq.length s) + putWord64be (fromIntegral $ Seq.length s) F.mapM_ pa s {-# INLINE putSeqOf #-} putTreeOf :: Putter a -> Putter (T.Tree a)-putTreeOf pa = +putTreeOf pa = tell . go where go (T.Node x cs) = execPut (pa x) `M.mappend` encodeListOf go cs@@ -370,3 +458,27 @@ let bs = runPut putVal putLen (S.length bs) putByteString bs++-------------------------------------------------------------------------------+-- pre-bytestring-0.10 compatibility+-------------------------------------------------------------------------------++{-# INLINE lazyToStrictByteString #-}+lazyToStrictByteString :: L.ByteString -> S.ByteString+#if MIN_VERSION_bytestring(0,10,0)+lazyToStrictByteString = L.toStrict+#else+lazyToStrictByteString = packChunks++-- packChunks is taken from the blaze-builder package.++-- | Pack the chunks of a lazy bytestring into a single strict bytestring.+packChunks :: L.ByteString -> S.ByteString+packChunks lbs = S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs)+ where+ copyChunks !L.Empty !_pf = return ()+ copyChunks !(L.Chunk (S.PS fpbuf o l) lbs') !pf = do+ withForeignPtr fpbuf $ \pbuf ->+ copyBytes pf (pbuf `plusPtr` o) l+ copyChunks lbs' (pf `plusPtr` l)+#endif
tests/RoundTrip.hs view
@@ -30,8 +30,8 @@ -- | Did a call to 'quickCheckResult' succeed? isSuccess :: QC.Result -> Bool-isSuccess (Success _ _ _) = True-isSuccess _ = False+isSuccess Success{} = True+isSuccess _ = False tests :: Test tests = testGroup "Round Trip"