diff --git a/cereal.cabal b/cereal.cabal --- a/cereal.cabal +++ b/cereal.cabal @@ -1,5 +1,5 @@ name: cereal -version: 0.1 +version: 0.2 license: BSD3 license-file: LICENSE author: Lennart Kolmodin , Galois Inc. @@ -32,17 +32,18 @@ else build-depends: base < 3.0 - hs-source-dirs: src + hs-source-dirs: src - exposed-modules:Data.Serialize, - Data.Serialize.Put, - Data.Serialize.Get, - Data.Serialize.Builder + exposed-modules: Data.Serialize, + Data.Serialize.Put, + Data.Serialize.Get, + Data.Serialize.Builder - extensions: CPP, - FlexibleContexts, - FlexibleInstances, - Rank2Types, - MagicHash + extensions: CPP, + FlexibleContexts, + FlexibleInstances, + Rank2Types, + MagicHash - ghc-options: -O2 -Wall -fliberate-case-threshold=1000 + ghc-options: -Wall -funbox-strict-fields + ghc-prof-options: -prof -auto-all 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 @@ -30,6 +30,7 @@ -- * Parsing , isolate + , label , skip , uncheckedSkip , lookAhead @@ -47,7 +48,6 @@ -- ** ByteStrings , getByteString - , getRemaining , getLazyByteString -- ** Big-endian reads @@ -105,20 +105,18 @@ import GHC.Word #endif -type Trace = [String] -> String - -type Failure r = String -> Either String (r, B.ByteString) -type Success a r = B.ByteString -> a -> Either String (r, B.ByteString) +type Failure r = [String] -> String -> Either String (r, B.ByteString) +type Success a r = B.ByteString -> a -> Either String (r, B.ByteString) -- | The Get monad is an Exception and State monad. newtype Get a = Get - { unGet :: forall r. Trace -> B.ByteString - -> Failure r -- failure - -> Success a r -- success + { unGet :: forall r. B.ByteString + -> Failure r + -> Success a r -> Either String (r, B.ByteString) } instance Functor Get where - fmap p m = Get (\t s0 f k -> unGet m t s0 f (\s a -> k s (p a))) + fmap p m = Get (\s0 f k -> unGet m s0 f (\s a -> k s (p a))) instance Applicative Get where pure = return @@ -130,40 +128,41 @@ -- Definition directly from Control.Monad.State.Strict instance Monad Get where - return a = Get (\_ s0 _ k -> k s0 a) - m >>= g = Get (\t s0 f k -> unGet m t s0 f (\s a -> unGet (g a) t s f k)) + return a = Get (\s0 _ k -> k s0 a) + m >>= g = Get (\s0 f k -> unGet m s0 f (\s a -> unGet (g a) s f k)) fail = failDesc instance MonadPlus Get where mzero = failDesc "mzero" - mplus a b = Get (\t s0 f k -> unGet a t s0 (\_ -> unGet b t s0 f k) k) + mplus a b = Get (\s0 f k -> unGet a s0 (\_ _ -> unGet b s0 f k) k) ------------------------------------------------------------------------ -formatTrace :: Trace +formatTrace :: [String] -> String formatTrace [] = "Empty call stack" formatTrace ls = "From:\t" ++ intercalate "\n\t" ls ++ "\n" get :: Get B.ByteString -get = Get (\_ s0 _ k -> k s0 s0) +get = Get (\s0 _ k -> k s0 s0) put :: B.ByteString -> Get () -put s = Get (\_ _ _ k -> k s ()) +put s = Get (\_ _ k -> k s ()) label :: String -> Get a -> Get a -label l m = Get (\t s0 k -> unGet m (\ls -> t (l:ls)) s0 k) +label l m = Get (\s0 f k -> unGet m s0 (\ls s -> f (l:ls) s) k) finalK :: Success a a finalK s a = Right (a,s) failK :: Failure a -failK = Left +failK ls s = Left (unlines [s, formatTrace ls]) -- | 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 formatTrace str failK finalK of +runGet m str = case unGet m str failK finalK of Left i -> Left i Right (a, _) -> Right a +{-# INLINE runGet #-} -- | Run the Get monad applies a 'get'-based parser on the input -- ByteString. Additional to the result of get it returns the number of @@ -171,9 +170,10 @@ runGetState :: Get a -> B.ByteString -> Int -> Either String (a, B.ByteString) runGetState m str off = - case unGet m formatTrace (B.drop off str) failK finalK of + case unGet m (B.drop off str) failK finalK of Left i -> Left i Right (a, bs) -> Right (a, bs) +{-# INLINE runGetState #-} ------------------------------------------------------------------------ @@ -181,6 +181,7 @@ -- is required to consume all the bytes that it is isolated to. isolate :: String -> Int -> Get a -> Get a isolate l n m = label l $ do + when (n < 0) (fail "Attempted to isolate a negative number of bytes") s <- get let left = B.length s unless (n <= left) (fail "not enough space left to isolate") @@ -194,8 +195,8 @@ failDesc :: String -> Get a failDesc err = do - let msg = "Failed reading" ++ err - Get (\t _ f _ -> f (msg ++ "\n" ++ t [])) + let msg = "Failed reading: " ++ err + Get (\_ f _ -> f [] msg) -- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. skip :: Int -> Get () @@ -263,12 +264,12 @@ -- Utility with ByteStrings -- | An efficient 'get' method for strict ByteStrings. Fails if fewer --- than @n@ bytes are left in the input. +-- than @n@ bytes are left in the input. This function creates a fresh +-- copy of the underlying bytes. getByteString :: Int -> Get B.ByteString -getByteString = getBytes - -getRemaining :: Get B.ByteString -getRemaining = getBytes =<< remaining +getByteString n = do + bs <- getBytes n + return $! B.copy bs getLazyByteString :: Int64 -> Get L.ByteString getLazyByteString n = f `fmap` getBytes (fromIntegral n) @@ -286,6 +287,7 @@ let (consume,rest) = B.splitAt n s put rest return consume + ------------------------------------------------------------------------ -- Primtives