diff --git a/cereal.cabal b/cereal.cabal --- a/cereal.cabal +++ b/cereal.cabal @@ -1,8 +1,10 @@ name: cereal -version: 0.3.0.0 +version: 0.3.1.0 license: BSD3 license-file: LICENSE -author: Lennart Kolmodin , Galois Inc. +author: Lennart Kolmodin , + Galois Inc., + Lemmih maintainer: Trevor Elliott category: Data, Parsing stability: provisional 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 @@ -27,8 +27,11 @@ Get , runGet , runGetState + , Result(..) + , runGetPartial -- * Parsing + , ensure , isolate , label , skip @@ -91,6 +94,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as L import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet @@ -105,18 +109,47 @@ import GHC.Word #endif -type Failure r = [String] -> String -> Either String (r, B.ByteString) -type Success a r = B.ByteString -> a -> Either String (r, B.ByteString) +type Failure r = [String] -> String -> Result r +type Success a r = B.ByteString -> More -> a -> Result r +-- | The result of a parse. +data Result r = Fail String + -- ^ The parse failed. The 'String' is the + -- message describing the error, if any. + | Partial (B.ByteString -> Result r) + -- ^ Supply this continuation with more input so that + -- the parser can resume. To indicate that no more + -- input is available, use an 'B.empty' string. + | Done r B.ByteString + -- ^ The parse succeeded. The 'B.ByteString' is the + -- input that had not yet been consumed (if any) when + -- 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 + +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 + -- | The Get monad is an Exception and State monad. newtype Get a = Get { unGet :: forall r. B.ByteString + -> More -> Failure r -> Success a r - -> Either String (r, B.ByteString) } + -- -> Either String (r, B.ByteString) } + -> Result r } +-- | Have we read all available input? +data More = Complete | Incomplete + deriving (Eq) + instance Functor Get where - fmap p m = Get (\s0 f k -> unGet m s0 f (\s a -> k s (p a))) + fmap p m = Get (\s0 m0 f k -> unGet m s0 m0 f (\s m1 a -> k s m1 (p a))) instance Applicative Get where pure = return @@ -128,13 +161,13 @@ -- Definition directly from Control.Monad.State.Strict instance Monad Get where - 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)) + return a = Get (\s0 m _ k -> k s0 m a) + m >>= g = Get (\s0 m0 f k -> unGet m s0 m0 f (\s m1 a -> unGet (g a) s m1 f k)) fail = failDesc instance MonadPlus Get where mzero = failDesc "mzero" - mplus a b = Get (\s0 f k -> unGet a s0 (\_ _ -> unGet b s0 f k) k) + mplus a b = Get (\s0 m0 f k -> unGet a s0 m0 (\_ _ -> unGet b s0 m0 f k) k) ------------------------------------------------------------------------ @@ -143,48 +176,70 @@ formatTrace ls = "From:\t" ++ intercalate "\n\t" ls ++ "\n" get :: Get B.ByteString -get = Get (\s0 _ k -> k s0 s0) +get = Get (\s0 m0 _ k -> k s0 m0 s0) put :: B.ByteString -> Get () -put s = Get (\_ _ k -> k s ()) +put s = Get (\_ m _ k -> k s m ()) label :: String -> Get a -> Get a -label l m = Get (\s0 f k -> unGet m s0 (\ls -> f (l:ls)) k) +label l m = Get (\s0 m0 f k -> unGet m s0 m0 (\ls -> f (l:ls)) k) finalK :: Success a a -finalK s a = Right (a,s) +finalK s _ a = Done a s failK :: Failure a -failK ls s = Left (unlines [s, formatTrace ls]) +failK ls s = Fail (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 str failK finalK of - Left i -> Left i - Right (a, _) -> Right a +runGet m str = case unGet m str Complete failK finalK of + Fail i -> Left i + Done a _ -> Right a + Partial{} -> Left "Failed reading: Internal error: unexpected Partial." {-# INLINE runGet #-} +-- | Run the Get monad applies a 'get'-based parser on the input ByteString +runGetPartial :: Get a -> B.ByteString -> Result a +runGetPartial m str = unGet m str Incomplete failK finalK +{-# 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. runGetState :: Get a -> B.ByteString -> Int -> Either String (a, B.ByteString) runGetState m str off = - case unGet m (B.drop off str) failK finalK of - Left i -> Left i - Right (a, bs) -> Right (a, bs) + case unGet m (B.drop off str) Complete failK finalK of + Fail i -> Left i + Done a bs -> Right (a, bs) + Partial{} -> Left "Failed reading: Internal error: unexpected Partial." {-# INLINE runGetState #-} ------------------------------------------------------------------------ +-- | 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 $ \i0 m0 kf ks -> + if B.length i0 >= n + then ks i0 m0 i0 + else unGet (demandInput >> ensureRec n) i0 m0 kf ks +{-# INLINE ensure #-} + +-- | If at least @n@ bytes of input are available, return the current +-- input, otherwise fail. +ensureRec :: Int -> Get B.ByteString +ensureRec n = Get $ \i0 m0 kf ks -> + if B.length i0 >= n + then ks i0 m0 i0 + else unGet (demandInput >> ensureRec n) i0 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 isolate n m = 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") + s <- ensure n let (s',rest) = B.splitAt n s put s' a <- m @@ -193,16 +248,26 @@ put rest return a +-- | Immediately demand more input via a 'Partial' continuation +-- result. +demandInput :: Get () +demandInput = Get $ \i0 m0 kf ks -> + if m0 == Complete + then kf ["demandInput"] "too few bytes" + else Partial $ \s -> + if B.null s + then kf ["demandInput"] "too few bytes" + else ks (i0 `B.append` s) Incomplete () + failDesc :: String -> Get a failDesc err = do let msg = "Failed reading: " ++ err - Get (\_ f _ -> f [] msg) + Get (\_ _ f _ -> f [] msg) -- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. skip :: Int -> Get () skip n = do - s <- get - when (B.length s < n) (fail "too few bytes") + s <- ensure n put (B.drop n s) -- | Skip ahead @n@ bytes. No error if there isn't enough bytes. @@ -282,9 +347,10 @@ -- | Pull @n@ bytes from the input, as a strict ByteString. getBytes :: Int -> Get B.ByteString getBytes n = do - s <- get - when (n > B.length s) (fail "too few bytes") - let (consume,rest) = B.splitAt n s + s <- ensure n + let consume = B.unsafeTake n s + rest = B.unsafeDrop n s + -- (consume,rest) = B.splitAt n s put rest return consume 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 @@ -8,7 +8,7 @@ -- Stability : -- Portability : -- --- The Put monad. A monad for efficiently constructing lazy bytestrings. +-- The Put monad. A monad for efficiently constructing bytestrings. -- ----------------------------------------------------------------------------- diff --git a/tests/Benchmark.hs b/tests/Benchmark.hs --- a/tests/Benchmark.hs +++ b/tests/Benchmark.hs @@ -7,6 +7,7 @@ import Data.Serialize.Get import Control.Exception +import Data.Word import System.CPUTime import Numeric import Text.Printf diff --git a/tests/Makefile b/tests/Makefile --- a/tests/Makefile +++ b/tests/Makefile @@ -1,10 +1,14 @@ -GHC = ghc -O2 -fasm -fforce-recomp +GHC = ghc -O2 -fasm -fforce-recomp -i../src -prof all: bench qc bench:: Benchmark.hs MemBench.hs CBenchmark.o $(GHC) -fliberate-case-threshold=1000 --make Benchmark.hs CBenchmark.o -o $@ ./$@ 100 + +bench-prof: Benchmark.hs MemBench.hs CBenchmark.o + $(GHC) -auto-all -rtsopts -fliberate-case-threshold=1000 --make Benchmark.hs CBenchmark.o -o $@ + ./$@ 100 +RTS -p CBenchmark.o: CBenchmark.c gcc -O3 -c $< -o $@ diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -14,20 +14,8 @@ import Data.Serialize import Data.Serialize.Get import Data.Serialize.Put -import Data.Word (Word8) -import Test.QuickCheck - -instance Arbitrary Word8 where - arbitrary = arbitraryBoundedIntegral - -instance Arbitrary Word16 where - arbitrary = arbitraryBoundedIntegral - -instance Arbitrary Word32 where - arbitrary = arbitraryBoundedIntegral - -instance Arbitrary Word64 where - arbitrary = arbitraryBoundedIntegral +import Data.Word (Word8,Word16,Word32,Word64) +import Test.QuickCheck as QC roundTrip :: Eq a => Putter a -> Get a -> a -> Bool @@ -36,25 +24,25 @@ main :: IO () main = mapM_ quickCheck - [ label "Word8 Round Trip" $ roundTrip putWord8 getWord8 - , label "Word16be Round Trip" $ roundTrip putWord16be getWord16be - , label "Word16le Round Trip" $ roundTrip putWord16le getWord16le - , label "Word32be Round Trip" $ roundTrip putWord32be getWord32be - , label "Word32le Round Trip" $ roundTrip putWord32le getWord32le - , label "Word64be Round Trip" $ roundTrip putWord64be getWord64be - , label "Word64le Round Trip" $ roundTrip putWord64le getWord64le - , label "Word16host Round Trip" $ roundTrip putWord16host getWord16host - , label "Word32host Round Trip" $ roundTrip putWord32host getWord32host - , label "Word64host Round Trip" $ roundTrip putWord64host getWord64host + [ QC.label "Word8 Round Trip" $ roundTrip putWord8 getWord8 + , QC.label "Word16be Round Trip" $ roundTrip putWord16be getWord16be + , QC.label "Word16le Round Trip" $ roundTrip putWord16le getWord16le + , QC.label "Word32be Round Trip" $ roundTrip putWord32be getWord32be + , QC.label "Word32le Round Trip" $ roundTrip putWord32le getWord32le + , QC.label "Word64be Round Trip" $ roundTrip putWord64be getWord64be + , QC.label "Word64le Round Trip" $ roundTrip putWord64le getWord64le + , QC.label "Word16host Round Trip" $ roundTrip putWord16host getWord16host + , QC.label "Word32host Round Trip" $ roundTrip putWord32host getWord32host + , QC.label "Word64host Round Trip" $ roundTrip putWord64host getWord64host -- Containers - , label "(Word8,Word8) Round Trip" + , QC.label "(Word8,Word8) Round Trip" $ roundTrip (putTwoOf putWord8 putWord8) (getTwoOf getWord8 getWord8) - , label "[Word8] Round Trip" + , QC.label "[Word8] Round Trip" $ roundTrip (putListOf putWord8) (getListOf getWord8) - , label "Maybe Word8 Round Trip" + , QC.label "Maybe Word8 Round Trip" $ roundTrip (putMaybeOf putWord8) (getMaybeOf getWord8) - , label "Either Word8 Word16be Round Trip " + , QC.label "Either Word8 Word16be Round Trip " $ roundTrip (putEitherOf putWord8 putWord16be) (getEitherOf getWord8 getWord16be) ]