diff --git a/cereal.cabal b/cereal.cabal --- a/cereal.cabal +++ b/cereal.cabal @@ -1,5 +1,5 @@ name: cereal -version: 0.3.5.2 +version: 0.4.0.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin , @@ -57,5 +57,5 @@ Rank2Types, MagicHash - ghc-options: -Wall -funbox-strict-fields + ghc-options: -Wall -O2 -funbox-strict-fields ghc-prof-options: -prof -auto-all diff --git a/src/Data/Serialize.hs b/src/Data/Serialize.hs --- a/src/Data/Serialize.hs +++ b/src/Data/Serialize.hs @@ -7,8 +7,7 @@ , TypeOperators , BangPatterns , KindSignatures - , ScopedTypeVariables - #-} + , ScopedTypeVariables #-} #endif ----------------------------------------------------------------------------- @@ -55,6 +54,7 @@ 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 @@ -344,6 +344,37 @@ 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 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 @@ -112,7 +112,7 @@ #endif -- | The result of a parse. -data Result r = Fail String +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) @@ -125,14 +125,14 @@ -- 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 + 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) = Fail msg - fmap f (Partial k) = Partial (fmap f . k) - fmap f (Done r bs) = Done (f r) bs + 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 @@ -222,13 +222,14 @@ finalK s _ _ a = Done a s failK :: Failure a -failK _ _ _ ls s = Fail (unlines [s, formatTrace ls]) +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 + Fail i _ -> Left i Done a _ -> Right a Partial{} -> Left "Failed reading: Internal error: unexpected Partial." {-# INLINE runGet #-} @@ -244,14 +245,25 @@ -- consumed bytes and the rest of the input. 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 -> Left i - Done a bs -> Right (a, bs) - Partial{} -> Left "Failed reading: Internal error: unexpected Partial." +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) @@ -263,15 +275,14 @@ 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)) + Fail str rest -> (Left str,L.fromChunks [rest]) + 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) - + Fail str rest -> (Left str,L.fromChunks [rest]) + Partial _ -> (Left "Failed reading: Internal error: unexpected end of input",L.empty) + Done r rest -> (Right r,L.fromChunks [rest]) {-# INLINE runGetLazy' #-} -- | Run the Get monad over a Lazy ByteString. Note that this will not run the diff --git a/src/Data/Serialize/IEEE754.hs b/src/Data/Serialize/IEEE754.hs --- a/src/Data/Serialize/IEEE754.hs +++ b/src/Data/Serialize/IEEE754.hs @@ -1,8 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} -- | 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 +-- module Data.Serialize.IEEE754 ( @@ -23,10 +24,16 @@ import Control.Applicative ( (<$>) ) import Control.Monad.ST ( runST, ST ) -import Data.Array.ST ( newArray, castSTUArray, readArray, MArray, STUArray ) +import Data.Array.ST ( newArray, readArray, MArray, STUArray ) import Data.Word ( Word32, Word64 ) import Data.Serialize.Get import Data.Serialize.Put + +#if __GLASGOW_HASKELL__ >= 704 +import Data.Array.Unsafe (castSTUArray) +#else +import Data.Array.ST (castSTUArray) +#endif -- | Read a Float in little endian IEEE-754 format getFloat32le :: Get Float