diff --git a/cereal.cabal b/cereal.cabal --- a/cereal.cabal +++ b/cereal.cabal @@ -1,5 +1,5 @@ name: cereal -version: 0.3.5.1 +version: 0.3.5.2 license: BSD3 license-file: LICENSE author: Lennart Kolmodin , @@ -27,7 +27,7 @@ source-repository head type: git - location: git://code.galois.com/cereal.git + location: git://github.com/GaloisInc/cereal.git flag split-base default: True diff --git a/src/Data/Serialize.hs b/src/Data/Serialize.hs --- a/src/Data/Serialize.hs +++ b/src/Data/Serialize.hs @@ -364,12 +364,12 @@ -- ByteStrings (have specially efficient instances) instance Serialize B.ByteString where - put bs = do put (B.length bs) + put bs = do put (B.length bs :: Int) putByteString bs get = get >>= getByteString instance Serialize L.ByteString where - put bs = do put (fromIntegral (L.length bs) :: Int) + put bs = do put (L.length bs :: Int64) putLazyByteString bs get = get >>= getLazyByteString @@ -504,7 +504,11 @@ 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 #-} @@ -514,7 +518,8 @@ ------------------------------------------------------------------------ -checkGetSum :: (Ord word, Bits word, GetSum f) => word -> word -> Get (f a) +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 #-} @@ -526,7 +531,11 @@ 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 #-} diff --git a/src/Data/Serialize/Builder.hs b/src/Data/Serialize/Builder.hs --- a/src/Data/Serialize/Builder.hs +++ b/src/Data/Serialize/Builder.hs @@ -57,7 +57,11 @@ ) where import Data.Monoid -import Foreign +import Data.Word +import Foreign.ForeignPtr +import Foreign.Ptr (Ptr,plusPtr) +import Foreign.Storable +import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Internal as S diff --git a/src/Data/Serialize/Get.hs b/src/Data/Serialize/Get.hs --- a/src/Data/Serialize/Get.hs +++ b/src/Data/Serialize/Get.hs @@ -7,7 +7,7 @@ -- Module : Data.Serialize.Get -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE) --- +-- -- Maintainer : Trevor Elliott -- Stability : -- Portability : @@ -260,12 +260,18 @@ remLen c = fromIntegral (L.length lstr) - B.length c run str = unGet m str Nothing (Incomplete (Just (remLen str))) failK finalK - loop _ [] = - (Left "Failed reading: Internal error: unexpected end of input",L.empty) - loop k (c:cs) = case k c of - Fail str -> (Left str,L.empty) - Partial k' -> loop k' cs - Done r c' -> (Right r,L.fromChunks (c':cs)) + loop k chunks = case chunks of + + c:cs -> case k c of + Fail str -> (Left str,L.empty) + Partial k' -> loop k' cs + Done r c' -> (Right r,L.fromChunks (c':cs)) + + [] -> case k B.empty of + Fail str -> (Left str,L.empty) + Partial k' -> (Left "Failed reading: Internal error: unexpected end of input",L.empty) + Done r c' -> (Right r,L.empty) + {-# INLINE runGetLazy' #-} -- | Run the Get monad over a Lazy ByteString. Note that this will not run the @@ -350,7 +356,7 @@ -- Fails if @ga@ fails. lookAhead :: Get a -> Get a lookAhead ga = Get $ \ s0 b0 m0 kf ks -> - let ks' s1 b1 = ks (s0 `B.append` bufferBytes b1) (b0 `append` b1) + let ks' _s1 b1 = ks (s0 `B.append` bufferBytes b1) (b0 `append` b1) in unGet ga s0 (Just B.empty) m0 kf ks' -- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. @@ -418,6 +424,7 @@ -- | 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 diff --git a/src/Data/Serialize/Put.hs b/src/Data/Serialize/Put.hs --- a/src/Data/Serialize/Put.hs +++ b/src/Data/Serialize/Put.hs @@ -70,6 +70,7 @@ import Control.Applicative import Data.Array.Unboxed import Data.Monoid +import Data.Foldable (foldMap) import Data.Word import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -83,8 +84,8 @@ ------------------------------------------------------------------------ --- XXX Strict in buffer only. -data PairS a = PairS a {-# UNPACK #-}!Builder +-- XXX Strict in builder only. +data PairS a = PairS a !Builder sndS :: PairS a -> Builder sndS (PairS _ b) = b @@ -251,16 +252,18 @@ -- Containers ------------------------------------------------------------------ +encodeListOf :: (a -> Builder) -> [a] -> Builder +encodeListOf f = -- allow inlining with just a single argument + \xs -> execPut (putWord64be (fromIntegral $ length xs)) `mappend` + 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 = go 0 (return ()) - where - go n body [] = putWord64be n >> body - go n body (x:xs) = n' `seq` go n' (body >> pa x) xs - where n' = n + 1 +putListOf pa = tell . encodeListOf (execPut . pa) {-# INLINE putListOf #-} putIArrayOf :: (Ix i, IArray a e) => Putter i -> Putter e -> Putter (a i e) @@ -270,16 +273,16 @@ {-# INLINE putIArrayOf #-} putSeqOf :: Putter a -> Putter (Seq.Seq a) -putSeqOf pa = go 0 (return ()) - where - go n body s = case Seq.viewl s of - Seq.EmptyL -> putWord64be n >> body - a Seq.:< as -> n' `seq` go n' (body >> pa a) as - where n' = n + 1 +putSeqOf pa = \s -> do + putWord64be (fromIntegral $ Seq.length s) + tell (foldMap (execPut . pa) s) {-# INLINE putSeqOf #-} putTreeOf :: Putter a -> Putter (T.Tree a) -putTreeOf pa (T.Node r s) = pa r >> putListOf (putTreeOf pa) s +putTreeOf pa = + tell . go + where + go (T.Node x cs) = execPut (pa x) `mappend` encodeListOf go cs {-# INLINE putTreeOf #-} putMapOf :: Ord k => Putter k -> Putter a -> Putter (Map.Map k a)