packages feed

binary 0.6.4.0 → 0.7.0.0

raw patch · 14 files changed

+487/−198 lines, 14 filesdep +Cabaldep +HUnitdep +attoparsecdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal, HUnit, attoparsec, cereal, directory, filepath

Dependency ranges changed: base, bytestring

API changes (from Hackage documentation)

+ Data.Binary: decodeFileOrFail :: Binary a => FilePath -> IO (Either (ByteOffset, String) a)
+ Data.Binary: decodeOrFail :: Binary a => ByteString -> Either (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
+ Data.Binary.Get: lookAhead :: Get a -> Get a
+ Data.Binary.Get: lookAheadM :: Get (Maybe a) -> Get (Maybe a)
+ Data.Binary.Get.Internal: lookAhead :: Get a -> Get a
+ Data.Binary.Get.Internal: lookAheadM :: Get (Maybe a) -> Get (Maybe a)

Files

− .gitignore 
@@ -1,14 +0,0 @@-*.hi-*.o-*.p_hi-*.prof-*.tix-.hpc/-/benchmarks/bench-/benchmarks/builder-/dist/*-/tests/qc-GNUmakefile-dist-boot-dist-install-ghc.mk
− .hgignore 
@@ -1,5 +0,0 @@-^dist$-syntax: glob-.*.swp-*~-\#*
README view
@@ -74,4 +74,5 @@     Tomasz Zielonka     Stefan Karrmann     Bryan O'Sullivan+    Bas van Dijk     Florian Weimer
− TODO 
@@ -1,28 +0,0 @@-layer handling:--    bit packing-    state parameters-    string pools--    reading structures from the end of a stream, seek/tell behaviour--seek based protocols are too hard. -    hGetContents/ interleaving.--user requests:--    get remaining bytestring after a runGet--    some kind of lookahead, or restoring parsing state, or something with-      equal functionality. make it another layer on top?--    getLazyByteString takes an Int, which in Haskell98 is only guarantied to-      be 29 bits, ie. 512 mb.-      maybe we should have a readN64 for allowing reading of larger stuff?-      (which could be implemented with readN on 64bit machines)-      reference: bringerts tar archive decoder would be limitid to 0.5GB-                 files, alt. 2GB in GHC--SYB-deriving--investigate the UArray instance, it does not seem to compile in GHC 6.4
benchmarks/Get.hs view
@@ -4,7 +4,7 @@ #include "MachDeps.h" #endif -module Main (main) where+module Main where  import Control.DeepSeq import Control.Exception (evaluate)@@ -22,6 +22,12 @@ import Data.Binary.Get import Data.Binary ( get ) +import qualified Data.Serialize.Get as Cereal+import qualified Data.Serialize as Cereal++import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Lazy as AL+ #if !MIN_VERSION_bytestring(0,10,0) instance NFData S.ByteString instance NFData L.ByteString where@@ -32,21 +38,35 @@ main = do   evaluate $ rnf [     rnf brackets,+    rnf bracketsInChunks,+    rnf bracketCount,     rnf oneMegabyte,     rnf oneMegabyteLBS      ]   defaultMain     [-      bench "brackets 100k one chunk input" $-        whnf (runTest bracketParser) brackets-    , bench "brackets 100k in 1024 100 byte chunks" $-        whnf (runTest bracketParser) bracketsInChunks-    , bench "getStruct4 1MB struct of 4 word32 strict" $-        whnf (runTest (getStruct4Strict mega)) oneMegabyteLBS-    , bench "getStruct4 1MB struct of 4 word32" $+      bench "brackets 100kb one chunk input" $+        whnf (checkBracket . runTest bracketParser) brackets+    , bench "brackets 100kb in 100 byte chunks" $+        whnf (checkBracket . runTest bracketParser) bracketsInChunks+    , bench "Attoparsec lazy-bs brackets 100kb one chunk" $+        whnf (checkBracket . runAttoL bracketParser_atto) brackets+    , bench "Attoparsec lazy-bs brackets 100kb in 100 byte chunks" $+        whnf (checkBracket . runAttoL bracketParser_atto) bracketsInChunks+    , bench "Attoparsec strict-bs brackets 10M0kb one chunk" $+        whnf (checkBracket . runAtto bracketParser_atto) $ S.concat (L.toChunks brackets)+    , bench "Binary getStruct4 1MB struct of 4 word8" $         whnf (runTest (getStruct4 mega)) oneMegabyteLBS-    , bench "getWord8 1MB chunk size 1 byte" $+    , bench "Cereal getStruct4 1MB struct of 4 word8" $+        whnf (runCereal (getStruct4_cereal mega)) oneMegabyte+    , bench "Attoparsec getStruct4 1MB struct of 4 word8" $+        whnf (runAtto (getStruct4_atto mega)) oneMegabyte+    , bench "Binary getWord8 1MB chunk size 1 byte" $         whnf (runTest (getWord8N1 mega)) oneMegabyteLBS+    , bench "Cereal getWord8 1MB chunk size 1 byte" $+        whnf (runCereal (getWord8N1_cereal mega)) oneMegabyte+    , bench "Attoparsec getWord8 1MB chunk size 1 byte" $+        whnf (runAtto (getWord8N1_atto mega)) oneMegabyte     , bench "getWord8 1MB chunk size 2 bytes" $         whnf (runTest (getWord8N2 mega)) oneMegabyteLBS     , bench "getWord8 1MB chunk size 4 bytes" $@@ -65,8 +85,18 @@         whnf (runTest (getWord8N16A mega)) oneMegabyteLBS     ] -runTest parser inp = runGet parser inp+checkBracket x | x == bracketCount = x+               | otherwise = error "argh!" +runTest decoder inp = runGet decoder inp+runCereal decoder inp = Cereal.runGet decoder inp+runAtto decoder inp = case A.parseOnly decoder inp of+                        Right a -> a+                        Left err -> error err+runAttoL decoder inp = case AL.parse decoder inp of+                        AL.Done _ r -> r+                        a -> error (show a)+ -- Defs.  oneMegabyte :: S.ByteString@@ -80,49 +110,69 @@ -- 100k of brackets bracketTest inp = runTest bracketParser inp -brackets = L.fromChunks [C8.concat (replicate 1024 "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))")]-bracketsInChunks = L.fromChunks (replicate 1024 "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))")+bracketCount :: Int+bracketCount = fromIntegral $ L.length brackets `div` 2 -bracketParser = cont <|> end+brackets = L.fromChunks [C8.concat (L.toChunks bracketsInChunks)]+bracketsInChunks = L.fromChunks (replicate chunksOfBrackets oneChunk)   where-  end = return 0+    oneChunk = "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))"+    chunksOfBrackets = 102400 `div` S.length oneChunk++bracketParser :: Get Int+bracketParser = cont <|> return 0+  where   cont = do v <- some ( do 40 <- getWord8-                           n <- bracketParser+                           n <- many cont                            41 <- getWord8-                           return $! n + 1)+                           return $! sum n + 1)             return $! sum v --- Struct strict--data Struct4S = Struct4S !Word32 !Word32 !Word32 !Word32+bracketParser_atto :: A.Parser Int+bracketParser_atto = cont <|> return 0+  where+  cont = do v <- some ( do A.word8 40+                           n <- bracketParser_atto+                           A.word8 41+                           return $! n + 1)+            return $! sum v -instance NFData Struct4S where-  rnf (Struct4S !a !b !c !d) = ()+-- Strict struct of 4 Word8s+data Struct4 = Struct4 {-# UNPACK #-} !Word8+                       {-# UNPACK #-} !Word8+                       {-# UNPACK #-} !Word8+                       {-# UNPACK #-} !Word8+               deriving Show -getStruct4Strict = loop []+getStruct4 = loop []   where loop acc 0 = return acc         loop acc n = do-          !w0 <- get-          !w1 <- get-          !w2 <- get-          !w3 <- get-          loop (Struct4S w0 w1 w2 w3 : acc) (n - 16)---- Struct lazy--data Struct4 = Struct4 Word32 Word32 Word32 Word32+          !w0 <- getWord8+          !w1 <- getWord8+          !w2 <- getWord8+          !w3 <- getWord8+          let !s = Struct4 w0 w1 w2 w3+          loop (s : acc) (n - 4) -instance NFData Struct4 where-  rnf (Struct4 !a !b !c !d) = ()+getStruct4_cereal = loop []+  where loop acc 0 = return acc+        loop acc n = do+          !w0 <- Cereal.getWord8+          !w1 <- Cereal.getWord8+          !w2 <- Cereal.getWord8+          !w3 <- Cereal.getWord8+          let !s = Struct4 w0 w1 w2 w3+          loop (s : acc) (n - 4) -getStruct4 = loop []+getStruct4_atto = loop []   where loop acc 0 = return acc         loop acc n = do-          w0 <- get-          w1 <- get-          w2 <- get-          w3 <- get-          loop (Struct4 w0 w1 w2 w3 : acc) (n - 16)+          !w0 <- A.anyWord8+          !w1 <- A.anyWord8+          !w2 <- A.anyWord8+          !w3 <- A.anyWord8+          let !s = Struct4 w0 w1 w2 w3+          loop (s : acc) (n - 4)  -- No-allocation loops. @@ -131,15 +181,29 @@         loop s 0 = return s         loop s n = do           s0 <- getWord8-          loop (s+s0) (n-1)+          loop (s0+s) (n-1) +getWord8N1_cereal = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- Cereal.getWord8+          loop (s0+s) (n-1)++getWord8N1_atto = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- A.anyWord8+          loop (s0+s) (n-1)+ getWord8N2 = loop 0   where loop s n | s `seq` n `seq` False = undefined         loop s 0 = return s         loop s n = do           s0 <- getWord8           s1 <- getWord8-          loop (s+s0+s1) (n-2)+          loop (s0+s1+s) (n-2)  getWord8N2A = loop 0   where loop s n | s `seq` n `seq` False = undefined
benchmarks/Makefile view
@@ -2,7 +2,7 @@ ghc-flags := programs := builder bench -SYSTEM_BINARY := binary-0.5.1.0+SYSTEM_BINARY := binary-0.5.1.1  .PHONY: all all: $(programs)
binary.cabal view
@@ -1,13 +1,15 @@ name:            binary-version:         0.6.4.0+version:         0.7.0.0 license:         BSD3 license-file:    LICENSE author:          Lennart Kolmodin <kolmodin@gmail.com>-maintainer:      Lennart Kolmodin, Don Stewart <dons@galois.com>+maintainer:      Lennart Kolmodin, Don Stewart <dons00@gmail.com> homepage:        https://github.com/kolmodin/binary description:     Efficient, pure binary serialisation using lazy ByteStrings.                  Haskell values may be encoded to and from binary formats,                  written to disk as binary, or sent over the network.+                 The format used can be automatically generated, or+                 you can choose to implement a custom format if needed.                  Serialisation speeds of over 1 G\/sec have been observed,                  so this library should be suitable for high performance                  scenarios.@@ -17,8 +19,14 @@ build-type:      Simple cabal-version:   >= 1.8 tested-with:     GHC == 7.0.4, GHC == 7.4.1, GHC == 7.6.1-extra-source-files: README index.html+extra-source-files:+  README index.html docs/hcar/binary-Lb.tex+  tools/derive/*.hs tests/Makefile benchmarks/Makefile +-- from the benchmark 'bench'+extra-source-files:+  benchmarks/CBenchmark.h+ source-repository head   type: git   location: git://github.com/kolmodin/binary.git@@ -52,6 +60,9 @@   type:  exitcode-stdio-1.0   hs-source-dirs: tests   main-is: QC.hs+  other-modules:+    Action+    Arbitrary   build-depends:     array,     base >= 3.0 && < 5,@@ -62,13 +73,29 @@     test-framework-quickcheck2,     QuickCheck>=2.5 -  ghc-options: -Wall+  ghc-options: -Wall -O2   hs-source-dirs: src +test-suite read-write-file+  type:  exitcode-stdio-1.0+  hs-source-dirs: tests+  main-is: File.hs+  build-depends:+    base >= 3.0 && < 5,+    bytestring >= 0.9,+    binary,+    Cabal,+    directory,+    filepath,+    HUnit++  ghc-options: -Wall+ benchmark bench   type: exitcode-stdio-1.0   hs-source-dirs: benchmarks   main-is: Benchmark.hs+  other-modules: MemBench   build-depends:     base >= 3.0 && < 5,     binary,@@ -82,9 +109,11 @@   hs-source-dirs: benchmarks   main-is: Get.hs   build-depends:+    attoparsec,     base >= 3.0 && < 5,     binary,     bytestring,+    cereal,     criterion,     deepseq,     mtl
src/Data/Binary.hs view
@@ -10,7 +10,7 @@ -- -- Maintainer  : Lennart Kolmodin <kolmodin@gmail.com> -- Stability   : unstable--- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances+-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances. -- -- Binary serialisation of Haskell values to and from lazy 'ByteString's. -- The Binary library provides methods for encoding Haskell values as@@ -18,16 +18,23 @@ -- then be written to disk, sent over the network, or further processed -- (for example, compressed with gzip). ----- The @Binary@ package is notable in that it provides both pure, and+-- The @binary@ package is notable in that it provides both pure, and -- high performance serialisation. ----- Values are always encoded in network order (big endian) form, and--- encoded data should be portable across machine endianness, word size,--- or compiler version. For example, data encoded using the 'Binary' class--- could be written from GHC, and read back in Hugs.+-- Values encoded using the 'Binary' class are always encoded in network order+-- (big endian) form, and encoded data should be portable across+-- machine endianness, word size, or compiler version. For example,+-- data encoded using the 'Binary' class could be written on any machine,+-- and read back on any another. ----- You can either provide a hand written implementation of the 'Binary' class,--- or derive one using the generic support. See 'GBinary'.+-- If the specifics of the data format is not important to you, for example,+-- you are more interested in serializing and deserializing values than+-- in which format will be used, it is possible to derive 'Binary'+-- instances using the generic support. See 'GBinary'.+-- +-- If you have specific requirements about the encoding format, you can use+-- the encoding and decoding primitives directly, see the modules+-- "Data.Binary.Get" and "Data.Binary.Put". -- ----------------------------------------------------------------------------- @@ -55,14 +62,12 @@     -- * Binary serialisation     , encode                    -- :: Binary a => a -> ByteString     , decode                    -- :: Binary a => ByteString -> a+    , decodeOrFail      -- * IO functions for serialisation     , encodeFile                -- :: Binary a => FilePath -> a -> IO ()     , decodeFile                -- :: Binary a => FilePath -> IO a---- Lazy put and get---  , lazyPut---  , lazyGet+    , decodeFileOrFail      , module Data.Word -- useful @@ -77,8 +82,11 @@ import Data.Binary.Generic () #endif +import qualified Data.ByteString as B ( hGet, length ) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L ( defaultChunkSize )+import System.IO ( withBinaryFile, IOMode(ReadMode) )  ------------------------------------------------------------------------ @@ -95,12 +103,12 @@ -- structure to serialise: -- -- > instance Binary Exp where--- >       put (IntE i)          = do put (0 :: Word8)--- >                                  put i--- >       put (OpE s e1 e2)     = do put (1 :: Word8)--- >                                  put s--- >                                  put e1--- >                                  put e2+-- >       put (IntE i)      = do put (0 :: Word8)+-- >                              put i+-- >       put (OpE s e1 e2) = do put (1 :: Word8)+-- >                              put s+-- >                              put e1+-- >                              put e2 -- > -- >       get = do t <- get :: Get Word8 -- >                case t of@@ -165,14 +173,23 @@ {-# INLINE encode #-}  -- | Decode a value from a lazy ByteString, reconstructing the original structure.--- decode :: Binary a => ByteString -> a decode = runGet get +-- | Decode a value from a lazy ByteString. Returning 'Left' on failure and+-- 'Right' on success. In both cases the unconsumed input and the number of+-- consumed bytes is returned. In case of failure, a human-readable error+-- message will be returned as well.+decodeOrFail :: Binary a => L.ByteString+             -> Either (L.ByteString, ByteOffset, String)+                       (L.ByteString, ByteOffset, a)+decodeOrFail = runGetOrFail get++ ------------------------------------------------------------------------ -- Convenience IO operations --- | Lazily serialise a value to a file+-- | Lazily serialise a value to a file. -- -- This is just a convenience function, it's defined simply as: --@@ -185,40 +202,32 @@ encodeFile :: Binary a => FilePath -> a -> IO () encodeFile f v = L.writeFile f (encode v) --- | Lazily reconstruct a value previously written to a file.------ This is just a convenience function, it's defined simply as:------ > decodeFile f = return . decode =<< B.readFile f------ So for example if you wanted to decompress as well, you could use:------ > return . decode . decompress =<< B.readFile f------ After contructing the data from the input file, 'decodeFile' checks--- if the file is empty, and in doing so will force the associated file--- handle closed, if it is indeed empty. If the file is not empty,--- it is up to the decoding instance to consume the rest of the data,--- or otherwise finalise the resource.---+-- | Decode a value from a file. In case of errors, 'error' will+-- be called with the error message. decodeFile :: Binary a => FilePath -> IO a decodeFile f = do-    s <- L.readFile f-    return $ runGet (do v <- get-                        m <- isEmpty-                        m `seq` return v) s+  result <- decodeFileOrFail f+  case result of+    Right x -> return x+    Left (_,str) -> error str --- needs bytestring 0.9.1.x to work+-- | Decode a value from a file. In case of success, the value will be returned+-- in 'Right'. In case of decoder errors, the error message together with+-- the byte offset will be returned.+decodeFileOrFail :: Binary a => FilePath -> IO (Either (ByteOffset, String) a)+decodeFileOrFail f =+  withBinaryFile f ReadMode $ \h -> do+    feed (runGetIncremental get) h+  where -- TODO: put in Data.Binary.Get and name pushFromHandle?+    feed (Done _ _ x) _ = return (Right x)+    feed (Fail _ pos str) _ = return (Left (pos, str))+    feed (Partial k) h = do+      chunk <- B.hGet h L.defaultChunkSize+      case B.length chunk of+        0 -> feed (k Nothing) h+        _ -> feed (k (Just chunk)) h  --------------------------------------------------------------------------- Lazy put and get---- lazyPut :: (Binary a) => a -> Put--- lazyPut a = put (encode a)---- lazyGet :: (Binary a) => Get a--- lazyGet = fmap decode get- -- $generics -- -- Beginning with GHC 7.2, it is possible to use binary serialization
src/Data/Binary/Class.hs view
@@ -460,11 +460,11 @@ ------------------------------------------------------------------------ -- Maps and Sets -instance (Ord a, Binary a) => Binary (Set.Set a) where+instance (Binary a) => Binary (Set.Set a) where     put s = put (Set.size s) >> mapM_ put (Set.toAscList s)     get   = liftM Set.fromDistinctAscList get -instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where+instance (Binary k, Binary e) => Binary (Map.Map k e) where     put m = put (Map.size m) >> mapM_ put (Map.toAscList m)     get   = liftM Map.fromDistinctAscList get
src/Data/Binary/Get.hs view
@@ -17,15 +17,111 @@ -- Stability   : experimental -- Portability : portable to Hugs and GHC. ----- The Get monad. A monad for efficiently building structures from+-- The 'Get' monad. A monad for efficiently building structures from -- encoded lazy ByteStrings. --+-- Primitives are available to decode words of various sizes, both big and+-- little endian.+--+-- Let's decode binary data representing illustrated here.+-- In this example the values are in little endian.+--+-- > +------------------+--------------+-----------------++-- > | 32 bit timestamp | 32 bit price | 16 bit quantity |+-- > +------------------+--------------+-----------------++--+-- A corresponding Haskell value looks like this:+--+-- @+-- data Trade = Trade+--   { timestamp :: !'Word32'+--   , price     :: !'Word32'+--   , qty       :: !'Word16'+--   } deriving ('Show')+-- @+--+-- The fields in @Trade@ are marked as strict (using @!@) since we don't need+-- laziness here. In practise, you would probably consider using the UNPACK+-- pragma as well.+-- <http://www.haskell.org/ghc/docs/latest/html/users_guide/pragmas.html#unpack-pragma>+--+-- Now, let's have a look at a decoder for this format.+-- +-- @+-- getTrade :: 'Get' Trade+-- getTrade = do+--   timestamp <- 'getWord32le'+--   price     <- 'getWord32le'+--   quantity  <- 'getWord16le'+--   return '$!' Trade timestamp price quantity+-- @+-- +-- Or even simpler using applicative style:+--+-- @+-- getTrade' :: 'Get' Trade+-- getTrade' = Trade '<$>' 'getWord32le' '<*>' 'getWord32le' '<*>' 'getWord16le'+-- @+--+-- The applicative style can sometimes result in faster code, as @binary@+-- will try to optimize the code by grouping the reads together.+--+-- There are two kinds of ways to execute this decoder, the lazy input+-- method and the incremental input method. Here we will use the lazy+-- input method.+--+-- Let's first define a function that decodes many @Trade@s.+--+-- @+-- getTrades :: Get ['Trade']+-- getTrades = do+--   empty <- 'isEmpty'+--   if empty+--     then return []+--     else do trade <- getTrade+--             trades <- getTrades+--             return (trade:trades)+-- @+--+-- Finally, we run the decoder:+--+-- @+-- example :: IO ()+-- example = do+--  input <- BL.readFile \"trades.bin\"+--  let trades = runGet getTrades input +--  print trades+-- @+--+-- This decoder has the downside that it will need to read all the input before+-- it can return. On the other hand, it will not return anything until+-- it knows it could decode without any decoder errors.+--+-- You could also refactor to a left-fold, to decode in a more streaming fashion,+-- and get the following decoder. It will start to return data without knowning+-- that it can decode all input.+--+-- @+-- example2 :: BL.ByteString -> [Trade]+-- example2 input+--   | BL.null input = []+--   | otherwise =+--      let (trade, rest, _) = 'runGetState' getTrade input 0+--      in trade : example2 rest+-- @+--+-- Both these examples use lazy I/O to read the file from the disk, which is+-- not suitable in all applications, and certainly not if you need to read+-- from a socket which has higher likelihood to fail. To address these needs,+-- use the incremental input method.+-- For an example of this, see the implementation of 'decodeFileOrFail' in+-- "Data.Binary". -----------------------------------------------------------------------------   module Data.Binary.Get ( -    -- * The Get type+    -- * The Get monad       Get      -- * The lazy input interface@@ -44,11 +140,12 @@     , pushChunks     , pushEndOfInput -    -- * Parsing+    -- * Decoding     , skip     , isEmpty     , bytesRead-    -- , lookAhead+    , lookAhead+    , lookAheadM      -- ** ByteStrings     , getByteString@@ -85,6 +182,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L  import Control.Applicative @@ -161,27 +259,36 @@ -- unused input, and the number of consumed bytes. {-# DEPRECATED runGetState "Use runGetPartial instead. This function will be removed." #-} runGetState :: Get a -> L.ByteString -> ByteOffset -> (a, L.ByteString, ByteOffset)-runGetState g lbs0 pos' = go (runGetIncremental g) (L.toChunks lbs0)+runGetState g lbs0 pos' = go (runGetIncremental g) lbs0   where-  go (Done s pos a) lbs = (a, L.fromChunks (s:lbs), pos+pos')-  go (Partial k) (x:xs) = go (k $ Just x) xs-  go (Partial k) []     = go (k Nothing) []+  go (Done s pos a) lbs = (a, L.chunk s lbs, pos+pos')+  go (Partial k) lbs = go (k (takeHeadChunk lbs)) (dropHeadChunk lbs)   go (Fail _ pos msg) _ =     error ("Data.Binary.Get.runGetState at position " ++ show pos ++ ": " ++ msg) +takeHeadChunk :: L.ByteString -> Maybe B.ByteString+takeHeadChunk lbs =+  case lbs of+    (L.Chunk bs _) -> Just bs+    _ -> Nothing++dropHeadChunk :: L.ByteString -> L.ByteString+dropHeadChunk lbs =+  case lbs of+    (L.Chunk _ lbs') -> lbs'+    _ -> L.Empty+ -- | Run a 'Get' monad and return 'Left' on failure and 'Right' on -- success. In both cases any unconsumed input and the number of bytes -- consumed is returned. In the case of failure, a human-readable -- error message is included as well. runGetOrFail :: Get a -> L.ByteString              -> Either (L.ByteString, ByteOffset, String) (L.ByteString, ByteOffset, a)-runGetOrFail g bs = feedAll (runGetIncremental g) chunks+runGetOrFail g lbs0 = feedAll (runGetIncremental g) lbs0   where-  chunks = L.toChunks bs-  feedAll (Done x pos r) xs = Right ((L.fromChunks (x:xs)), pos, r)-  feedAll (Partial k) (x:xs) = feedAll (k (Just x)) xs-  feedAll (Partial k) [] = feedAll (k Nothing) []-  feedAll (Fail x pos msg) xs = Left ((L.fromChunks (x:xs)), pos, msg)+  feedAll (Done bs pos x) lbs = Right (L.chunk bs lbs, pos, x)+  feedAll (Partial k) lbs = feedAll (k (takeHeadChunk lbs)) (dropHeadChunk lbs)+  feedAll (Fail x pos msg) xs = Left (L.chunk x xs, pos, msg)  -- | An offset, counted in bytes. type ByteOffset = Int64@@ -189,12 +296,10 @@ -- | The simplest interface to run a 'Get' decoder. If the decoder runs into -- an error, calls 'fail', or runs out of input, it will call 'error'. runGet :: Get a -> L.ByteString -> a-runGet g bs = feedAll (runGetIncremental g) chunks+runGet g lbs0 = feedAll (runGetIncremental g) lbs0   where-  chunks = L.toChunks bs-  feedAll (Done _ _ r) _ = r-  feedAll (Partial k) (x:xs) = feedAll (k (Just x)) xs-  feedAll (Partial k) [] = feedAll (k Nothing) []+  feedAll (Done _ _ x) _ = x+  feedAll (Partial k) lbs = feedAll (k (takeHeadChunk lbs)) (dropHeadChunk lbs)   feedAll (Fail _ pos msg) _ =     error ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) @@ -213,7 +318,8 @@     Fail inp0 p s -> Fail (inp0 `B.append` inp) p s  --- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it -- will add the input to 'ByteString' of unconsumed input.+-- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it+-- will add the input to 'ByteString' of unconsumed input. -- -- @ --    'runGetPartial' myParser \`pushChunks\` myLazyByteString@@ -222,7 +328,9 @@ pushChunks r0 = go r0 . L.toChunks   where   go r [] = r-  go r (x:xs) = go (pushChunk r x) xs+  go (Done inp pos a) xs = Done (B.concat (inp:xs)) pos a+  go (Fail inp pos s) xs = Fail (B.concat (inp:xs)) pos s+  go (Partial k) (x:xs) = go (k (Just x)) xs  -- | Tell a 'Decoder' that there is no more input. This passes 'Nothing' to a -- 'Partial' decoder, otherwise returns the decoder unchanged.
src/Data/Binary/Get/Internal.hs view
@@ -28,6 +28,8 @@     , remaining     , getBytes     , isEmpty+    , lookAhead+    , lookAheadM      -- ** ByteStrings     , getByteString@@ -77,7 +79,7 @@ newtype Get a = C { runCont :: forall r.                                B.ByteString ->                                Success a r ->-                               Decoder    r }+                               Decoder   r }  type Success a r = B.ByteString -> a -> Decoder r @@ -197,14 +199,12 @@  instance Alternative Get where   empty = C $ \inp _ks -> Fail inp "Data.Binary.Get(Alternative).empty"-  (<|>) f g = C $ \inp ks ->-    let r0 = runCont (try f) inp (\inp' a -> Done inp' a)-        go r = case r of-                  Done inp' a -> ks inp' a-                  Partial k -> Partial (go . k)-                  Fail inp' _str -> runCont g inp' ks-                  BytesRead unused k -> BytesRead unused (go . k)-    in go r0+  (<|>) f g = do+    (decoder, bs) <- runAndKeepTrack f+    case decoder of+      Done inp x -> C $ \_ ks -> ks inp x+      Fail _ _ -> pushBack bs >> g+      _ -> error "Binary: impossible"   some p = (:) <$> p <*> many p   many p = do     v <- (Just <$> p) <|> pure Nothing@@ -212,16 +212,48 @@       Nothing -> pure []       Just x -> (:) x <$> many p --- | Try to execute a Get. If it fails, the consumed input will be restored.-try :: Get a -> Get a-try g = C $ \inp ks ->+-- | Run a decoder and keep track of all the input it consumes.+-- Once it's finished, return the final decoder (always 'Done' or 'Fail'), +-- and unconsume all the the input the decoder required to run.+-- Any additional chunks which was required to run the decoder+-- will also be returned.+runAndKeepTrack :: Get a -> Get (Decoder a, [B.ByteString])+runAndKeepTrack g = C $ \inp ks ->   let r0 = runCont g inp (\inp' a -> Done inp' a)       go !acc r = case r of-                    Done inp' a -> ks inp' a+                    Done inp' a -> ks inp (Done inp' a, reverse acc)                     Partial k -> Partial $ \minp -> go (maybe acc (:acc) minp) (k minp)-                    Fail _ s -> Fail (B.concat (inp : reverse acc)) s+                    Fail inp' s -> ks inp (Fail inp' s, reverse acc)                     BytesRead unused k -> BytesRead unused (go acc . k)   in go [] r0+{-# INLINE runAndKeepTrack #-}++pushBack :: [B.ByteString] -> Get ()+pushBack [] = C $ \ inp ks -> ks inp ()+pushBack bs = C $ \ inp ks -> ks (B.concat (inp : bs)) ()+{-# INLINE pushBack #-}++-- | Run the given decoder, but without consuming its input. If the given+-- decoder fails, then so will this function.+lookAhead :: Get a -> Get a+lookAhead g = do+  (decoder, bs) <- runAndKeepTrack g+  case decoder of+    Done _ a -> pushBack bs >> return a+    Fail inp s -> C $ \_ _ -> Fail inp s+    _ -> error "Binary: impossible"++-- | Run the given decoder, and only consume its input if it returns 'Just'.+-- If 'Nothing' is returned, the input will be unconsumed.+-- If the given decoder fails, then so will this function.+lookAheadM :: Get (Maybe a) -> Get (Maybe a)+lookAheadM g = do+  (decoder, bs) <- runAndKeepTrack g+  case decoder of+    Done _ Nothing -> pushBack bs >> return Nothing+    Done inp (Just x) -> C $ \_ ks -> ks inp (Just x)+    Fail inp s -> C $ \_ _ -> Fail inp s+    _ -> error "Binary: impossible"  -- | DEPRECATED. Get the number of bytes of remaining input. -- Note that this is an expensive function to use as in order to calculate how
tests/Action.hs view
@@ -2,8 +2,10 @@ module Action where  import Control.Applicative+import Control.Monad import Test.QuickCheck +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L  import qualified Data.Binary.Get as Binary@@ -11,8 +13,12 @@ import Arbitrary()  data Action-  = GetByteString Int+  = Actions [Action]+  | GetByteString Int   | Try [Action] [Action]+  | LookAhead [Action]+  -- | First argument is True if this action returns Just, otherwise False.+  | LookAheadM Bool [Action]   | BytesRead   | Fail   deriving (Show, Eq)@@ -20,11 +26,17 @@ instance Arbitrary Action where   shrink action =     case action of-      GetByteString n -> [ GetByteString n' | n' <- shrink n, n > 0 ]+      Actions [a] -> [a]+      Actions as -> [ Actions as' | as' <- shrink as ]+      GetByteString n -> [ GetByteString n' | n' <- shrink n, n >= 0 ]       BytesRead -> []       Fail -> []+      LookAhead a -> Actions a : [ LookAhead a' | a' <- shrink a ]+      LookAheadM b a -> Actions a : [ LookAheadM b a' | a' <- shrink a]+      Try [Fail] b -> Actions b : [ Try [Fail] b' | b' <- shrink b ]       Try a b ->-        [ Try a' b' | a' <- shrink a, b' <- shrink b ]+        (if not (willFail a) then [Actions a] else [])+        ++ [ Try a' b' | a' <- shrink a, b' <- shrink b ]         ++ [ Try a' b | a' <- shrink a ]         ++ [ Try a b' | b' <- shrink b ] @@ -32,8 +44,11 @@ willFail [] = False willFail (x:xs) =   case x of+    Actions x' -> willFail x' || willFail xs     GetByteString _ -> willFail xs     Try a b -> (willFail a && willFail b) || willFail xs+    LookAhead a -> willFail a || willFail xs+    LookAheadM _ a -> willFail a || willFail xs     BytesRead -> willFail xs     Fail -> True @@ -41,23 +56,35 @@ max_len [] = 0 max_len (x:xs) =   case x of+    Actions x' -> max_len x' + max_len xs     GetByteString n -> n + max_len xs     BytesRead -> max_len xs     Fail -> 0     Try a b -> max (max_len a) (max_len b) + max_len xs+    LookAhead a -> max (max_len a) (max_len xs)+    LookAheadM b a | willFail a -> max_len a+                   | b -> max_len a + max_len xs+                   | otherwise -> max (max_len a) (max_len xs)  actual_len :: [Action] -> Maybe Int-actual_len = go 0+actual_len [] = Just 0+actual_len (x:xs) =+  case x of+    Actions x' -> (+) <$> actual_len x' <*> rest+    GetByteString n -> (n+) <$> rest+    Fail -> Nothing+    BytesRead -> rest+    LookAhead a | willFail a -> Nothing+                | otherwise -> rest+    LookAheadM b a | willFail a -> Nothing+                   | b -> (+) <$> actual_len a <*> rest+                   | otherwise -> rest+    Try a b | not (willFail a) -> (+) <$> actual_len a <*> rest+            | not (willFail b) -> (+) <$> actual_len b <*> rest+            | otherwise -> Nothing+   where-  go !s [] = Just s-  go !s (x:xs) =-    case x of-      GetByteString n -> go (s+n) xs-      Fail -> Nothing-      BytesRead -> go s xs-      Try a b | not (willFail a) -> liftA2 (+) (go s a) (actual_len xs)-              | not (willFail b) -> liftA2 (+) (go s b) (actual_len xs)-              | otherwise -> Nothing+    rest = actual_len xs  -- | Build binary programs and compare running them to running a (hopefully) -- identical model.@@ -68,23 +95,45 @@   forAllShrink gen_actions shrink $ \ actions ->     forAll arbitrary $ \ lbs ->       L.length lbs >= fromIntegral (max_len actions) ==>-        case Binary.runGet (eval actions) lbs of+        let allInput = B.concat (L.toChunks lbs) in+        case Binary.runGet (eval allInput actions) lbs of           () -> True -eval :: [Action] -> Binary.Get ()-eval = go 0+-- | Evaluate (run) the model.+-- First argument is all the input that will be used when executing+-- this decoder. It is used in this function to compare the expected+-- value with the actual value from the decoder functions.+-- The second argument is the model - the actions we will evaluate.+eval :: B.ByteString -> [Action] -> Binary.Get ()+eval str = go 0   where   go _ [] = return ()   go pos (x:xs) =     case x of-      GetByteString n ->-        Binary.getByteString n >> go (pos+n) xs+      Actions a -> go pos (a++xs)+      GetByteString n -> do+        -- Run the operation in the Get monad...+        actual <- Binary.getByteString n+        let expected = B.take n . B.drop pos $ str+        -- ... and compare that we got what we expected.+        when (actual /= expected) $ error "actual /= expected"+        go (pos+n) xs       BytesRead -> do         pos' <- Binary.bytesRead         if (pos == fromIntegral pos')           then go pos xs           else error $ "expected " ++ show pos ++ " but got " ++ show pos'       Fail -> fail "fail"+      LookAhead a -> do+        _ <- Binary.lookAhead (go pos a)+        go pos xs+      LookAheadM b a -> do+        let f True = leg pos a+            f False = go pos a >> return Nothing+        len <- Binary.lookAheadM (f b)+        case len of+          Nothing -> go pos xs+          Just offset -> go (pos+offset) xs       Try a b -> do         len <- leg pos a <|> leg pos b         case len of@@ -103,4 +152,9 @@                        , do t1 <- go True (s `div` 2)                             t2 <- go inTry (s `div` 2)                             (:) (Try t1 t2) <$> go inTry (s `div` 2)+                       , do t <- go inTry (s`div`2)+                            (:) (LookAhead t) <$> go inTry (s-1)+                       , do t <- go inTry (s`div`2)+                            b <- arbitrary+                            (:) (LookAheadM b t) <$> go inTry (s-1)                        ] ++ [ return [Fail] | inTry ]
tests/Arbitrary.hs view
@@ -8,7 +8,7 @@ import qualified Data.ByteString.Lazy as L  instance Arbitrary L.ByteString where-    arbitrary     = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant.+  arbitrary = fmap L.fromChunks arbitrary  instance Arbitrary B.ByteString where   arbitrary = B.pack `fmap` arbitrary
+ tests/File.hs view
@@ -0,0 +1,39 @@+module Main where++import Control.Applicative+import Test.HUnit+import System.Directory ( getTemporaryDirectory )+import System.FilePath ( (</>) )++import Distribution.Simple.Utils ( withTempDirectory )+import Distribution.Verbosity ( silent )++import Data.Binary++data Foo = Bar !Word32 !Word32 !Word32 deriving (Eq, Show)++instance Binary Foo where+  get = Bar <$> get <*> get <*> get+  put (Bar a b c) = put (a,b,c)++exampleData :: [Foo]+exampleData = make bytes+  where+    make (a:b:c:xs) = Bar a b c : make xs+    make _ = []+    bytes = take (256*1024) (cycle [minBound..maxBound])++readWriteTest :: Test+readWriteTest = TestCase $ do+  tmpDir <- getTemporaryDirectory+  withTempDirectory silent tmpDir "foo-dir" $ \dir -> do+    let fn = dir </> "foo.bin"+    encodeFile fn exampleData+    content <- decodeFile fn+    -- It'd be nice to use lsof to verify that 'fn' isn't still open.+    exampleData @=? content++main :: IO ()+main = do +  _ <- runTestTT readWriteTest+  return ()