cereal 0.5.1.0 → 0.5.2.0

raw patch · 6 files changed

+161/−117 lines, 6 filesdep +faildep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: fail

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• cereal.cabal +6/−5
• src/Data/Serialize.hs +65/−36
• src/Data/Serialize/Get.hs +50/−36
• src/Data/Serialize/IEEE754.hs +16/−33
• src/Data/Serialize/Put.hs +10/−7

@@ -1,4 +1,18 @@ +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 ======= 

@@ -1,5 +1,5 @@ name:                   cereal-version:                0.5.1.0+version:                0.5.2.0 license:                BSD3 license-file:           LICENSE author:                 Lennart Kolmodin <kolmodin@dtek.chalmers.se>,@@ -13,6 +13,7 @@ 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@@ -27,10 +28,13 @@ library         default-language:       Haskell2010 -        build-depends:          bytestring >= 0.10.0.0,+        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,@@ -40,9 +44,6 @@          ghc-options:            -Wall -O2 -funbox-strict-fields -        if impl(ghc >= 7.2.1)-                                cpp-options:    -DGENERICS-                                build-depends:  ghc-prim >= 0.2   test-suite test-cereal

@@ -1,14 +1,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE CPP #-}--#ifdef GENERICS {-# LANGUAGE DefaultSignatures            , TypeOperators            , BangPatterns            , KindSignatures            , ScopedTypeVariables #-}-#endif  #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1@@ -41,6 +38,10 @@     , module Data.Serialize.Get     , module Data.Serialize.Put     , module Data.Serialize.IEEE754++    -- * Generic deriving+    , GSerializePut(..)+    , GSerializeGet(..)     ) where  import Data.Serialize.Put@@ -67,9 +68,7 @@ import qualified Data.Tree            as T import qualified Data.Sequence        as Seq -#ifdef GENERICS import GHC.Generics-#endif  #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((*>),(<*>),(<$>),pure)@@ -95,13 +94,11 @@     -- | Decode a value in the Get monad     get :: Get t -#ifdef GENERICS-    default put :: (Generic t, GSerialize (Rep t)) => Putter t+    default put :: (Generic t, GSerializePut (Rep t)) => Putter t     put = gPut . from -    default get :: (Generic t, GSerialize (Rep t)) => Get t+    default get :: (Generic t, GSerializeGet (Rep t)) => Get t     get = to <$> gGet-#endif  ------------------------------------------------------------------------ -- Wrappers to run the underlying monad@@ -143,15 +140,39 @@     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 . fromIntegral . fromEnum-    get     = liftM (toEnum . fromIntegral) getWord8+    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 . fromIntegral . fromEnum-    get     = liftM (toEnum . fromIntegral) getWord8+    put     = putWord8 . orderingToWord8+    get     = orderingFromWord8 =<< getWord8  ------------------------------------------------------------------------ -- Words and Ints@@ -249,13 +270,13 @@ -- -- Fold and unfold an Integer to and from a list of its bytes ---unroll :: (Integral a, Num a, Bits a) => a -> [Word8]+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, Num a, Bits a) => [Word8] -> a+roll :: (Integral a, Bits a) => [Word8] -> a roll   = foldr unstep 0   where     unstep b a = a `shiftL` 8 .|. fromIntegral b@@ -523,39 +544,48 @@     put = putIArrayOf put put     get = getIArrayOf get get -#ifdef GENERICS ------------------------------------------------------------------------ -- Generic Serialze -class GSerialize f where+class GSerializePut f where     gPut :: Putter (f a)++class GSerializeGet f where     gGet :: Get (f a) -instance GSerialize a => GSerialize (M1 i c a) where+instance GSerializePut a => GSerializePut (M1 i c a) where     gPut = gPut . unM1-    gGet = M1 <$> gGet     {-# INLINE gPut #-}++instance GSerializeGet a => GSerializeGet (M1 i c a) where+    gGet = M1 <$> gGet     {-# INLINE gGet #-} -instance Serialize a => GSerialize (K1 i a) where+instance Serialize a => GSerializePut (K1 i a) where     gPut = put . unK1-    gGet = K1 <$> get     {-# INLINE gPut #-}++instance Serialize a => GSerializeGet (K1 i a) where+    gGet = K1 <$> get     {-# INLINE gGet #-} -instance GSerialize U1 where+instance GSerializePut U1 where     gPut _ = pure ()-    gGet   = pure U1     {-# INLINE gPut #-}++instance GSerializeGet U1 where+    gGet   = pure U1     {-# INLINE gGet #-} -instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where+instance (GSerializePut a, GSerializePut b) => GSerializePut (a :*: b) where     gPut (a :*: b) = gPut a *> gPut b-    gGet = (:*:) <$> gGet  <*> gGet     {-# 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+-- 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@@ -565,20 +595,20 @@ #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-         , GetSum     a, GetSum     b-         , GSerialize a, GSerialize b-         , SumSize    a, SumSize    b) => GSerialize (a :+: b) where+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 gPut #-}     {-# INLINE gGet #-}  sizeError :: Show size => String -> size -> error@@ -589,7 +619,7 @@ class PutSum f where     putSum :: (Num word, Bits word, Serialize word) => word -> word -> Putter (f a) -instance (PutSum a, PutSum b, GSerialize a, GSerialize b) => PutSum (a :+: b) where+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@@ -602,7 +632,7 @@           sizeR = size - sizeL     {-# INLINE putSum #-} -instance GSerialize a => PutSum (C1 c a) where+instance GSerializePut a => PutSum (C1 c a) where     putSum !code _ x = put code *> gPut x     {-# INLINE putSum #-} @@ -617,7 +647,7 @@ class GetSum f where     getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) -instance (GetSum a, GetSum b, GSerialize a, GSerialize b) => GetSum (a :+: b) where+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@@ -629,7 +659,7 @@           sizeR = size - sizeL     {-# INLINE getSum #-} -instance GSerialize a => GetSum (C1 c a) where+instance GSerializeGet a => GetSum (C1 c a) where     getSum _ _ = gGet     {-# INLINE getSum #-} @@ -646,4 +676,3 @@  instance SumSize (C1 c a) where     sumSize = Tagged 1-#endif

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP        #-} {-# LANGUAGE MagicHash  #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-}  ----------------------------------------------------------------------------- -- |@@ -98,12 +99,12 @@     , 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)@@ -171,7 +172,7 @@ extendBuffer :: Buffer -> B.ByteString -> Buffer extendBuffer buf chunk =   do bs <- buf-     return (bs `B.append` chunk)+     return $! bs `B.append` chunk {-# INLINE extendBuffer #-}  append :: Buffer -> Buffer -> Buffer@@ -201,7 +202,7 @@       unGet m s0 b0 m0 kf $ \ s1 b1 m1 a     -> ks s1 b1 m1 (p a)  instance A.Applicative Get where-    pure  = return+    pure a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a     {-# INLINE pure #-}      f <*> x =         Get $ \ s0 b0 m0 kf ks ->@@ -209,6 +210,10 @@       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 #-}@@ -218,20 +223,22 @@  -- Definition directly from Control.Monad.State.Strict instance Monad Get where-    return a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a+    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 (>>=) #-} -    m >> k =          Get $ \ s0 b0 m0 kf ks ->-      unGet m s0 b0 m0 kf $ \ s1 b1 m1 _     -> unGet k s1 b1 m1 kf ks+    (>>) = (A.*>)     {-# INLINE (>>) #-} -    fail     = failDesc+    fail     = Fail.fail     {-# INLINE fail #-} +instance Fail.MonadFail Get where+    fail     = failDesc+    {-# INLINE fail #-}  instance M.MonadPlus Get where     mzero     = failDesc "mzero"@@ -363,21 +370,45 @@  -- | If at least @n@ bytes of input are available, return the current --   input, otherwise fail.-ensure :: Int -> Get B.ByteString-ensure n = n `seq` Get $ \ s0 b0 m0 kf ks ->-    if B.length s0 >= n-    then ks s0 b0 m0 s0-    else unGet (demandInput >> ensureRec n) s0 b0 m0 kf ks {-# 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 <https://github.com/GaloisInc/cereal/issues/48> --- | If at least @n@ bytes of input are available, return the current---   input, otherwise fail.-ensureRec :: Int -> Get B.ByteString-ensureRec n = Get $ \s0 b0 m0 kf ks ->-    if B.length s0 >= n-    then ks s0 b0 m0 s0-    else unGet (demandInput >> ensureRec n) s0 b0 m0 kf ks+        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@@ -391,23 +422,6 @@   unless (B.null used) (fail "not all bytes parsed in isolate")   put rest   return a---- | Immediately demand more input via a 'Partial' continuation---   result.-demandInput :: Get ()-demandInput = Get $ \s0 b0 m0 kf ks ->-  case m0 of-    Complete      -> kf s0 b0 m0 ["demandInput"] "too few bytes"-    Incomplete mb -> Partial $ \s ->-      if B.null s-      then kf s0 b0 m0 ["demandInput"] "too few bytes"-      else let s1 = s0 `B.append` s-               b1 = extendBuffer b0 s-               mb' = case mb of-                       Just l  -> Just $! l - B.length s-                       Nothing -> Nothing-            in b1  `seq`-               mb' `seq` ks s1 b1 (Incomplete mb') ()  failDesc :: String -> Get a failDesc err = do

@@ -1,14 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}  #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif -#ifndef MIN_VERSION_array-#define MIN_VERSION_array(x,y,z) 1-#endif- -- | IEEE-754 parsing, as described in this stack-overflow article: -- -- <http://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-float/7002812#7002812>@@ -29,23 +26,19 @@  ) where -import Control.Monad.ST ( runST, ST )--import Data.Array.ST ( newArray, readArray, MArray, STUArray ) 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 -#if MIN_VERSION_array(0,4,0)-import Data.Array.Unsafe (castSTUArray)-#else-import Data.Array.ST (castSTUArray)-#endif- -- | Read a Float in little endian IEEE-754 format getFloat32le :: Get Float getFloat32le = wordToFloat <$> getWord32le@@ -64,38 +57,28 @@  -- | Write a Float in little endian IEEE-754 format putFloat32le :: Float -> Put-putFloat32le = putWord32le . floatToWord+putFloat32le = putBuilder . Builder.floatLE  -- | Write a Float in big endian IEEE-754 format putFloat32be :: Float -> Put-putFloat32be = putWord32be . floatToWord+putFloat32be = putBuilder . Builder.floatBE  -- | Write a Double in little endian IEEE-754 format putFloat64le :: Double -> Put-putFloat64le = putWord64le . doubleToWord+putFloat64le = putBuilder . Builder.doubleLE  -- | Write a Double in big endian IEEE-754 format putFloat64be :: Double -> Put-putFloat64be = putWord64be . doubleToWord+putFloat64be = putBuilder . Builder.doubleBE  {-# INLINE wordToFloat #-} wordToFloat :: Word32 -> Float-wordToFloat x = runST (cast x)--{-# INLINE floatToWord #-}-floatToWord :: Float -> Word32-floatToWord x = runST (cast x)+wordToFloat w = unsafeDupablePerformIO $ alloca $ \(ptr :: Ptr Word32) -> do+    poke ptr w+    peek (castPtr ptr)  {-# INLINE wordToDouble #-} wordToDouble :: Word64 -> Double-wordToDouble x = runST (cast x)--{-# INLINE doubleToWord #-}-doubleToWord :: Double -> Word64-doubleToWord x = runST (cast x)--{-# INLINE cast #-}-cast :: (MArray (STUArray s) a (ST s),-         MArray (STUArray s) b (ST s)) =>-        a -> ST s b-cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0+wordToDouble w = unsafeDupablePerformIO $ alloca $ \(ptr :: Ptr Word64) -> do+    poke ptr w+    peek (castPtr ptr)

@@ -138,7 +138,7 @@   instance A.Applicative PutM where-        pure    = return+        pure a = Put (PairS a M.mempty)         {-# INLINE pure #-}          m <*> k = Put $@@ -147,9 +147,15 @@             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 a = Put (PairS a M.mempty)+    return = pure     {-# INLINE return #-}      m >>= k  = Put $@@ -158,10 +164,7 @@         in PairS b (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 (>>) #-}  tell :: Putter Builder@@ -326,7 +329,7 @@     go (T.Node x cs) = execPut (pa x) `M.mappend` encodeListOf go cs {-# INLINE putTreeOf #-} -putMapOf :: Ord k => Putter k -> Putter a -> Putter (Map.Map k a)+putMapOf :: Putter k -> Putter a -> Putter (Map.Map k a) putMapOf pk pa = putListOf (putTwoOf pk pa) . Map.toAscList {-# INLINE putMapOf #-}