binary 0.7.1.0 → 0.7.2.0
raw patch · 7 files changed
+548/−231 lines, 7 filesdep −binarydep ~QuickCheckPVP ok
version bump matches the API change (PVP)
Dependencies removed: binary
Dependency ranges changed: QuickCheck
API changes (from Hackage documentation)
+ Data.Binary.Get: isolate :: Int -> Get a -> Get a
+ Data.Binary.Get: label :: String -> Get a -> Get a
+ Data.Binary.Get.Internal: isolate :: Int -> Get a -> Get a
+ Data.Binary.Get.Internal: label :: String -> Get a -> Get a
Files
- README.md +16/−31
- binary.cabal +24/−19
- src/Data/Binary/Builder/Base.hs +1/−3
- src/Data/Binary/Get.hs +63/−46
- src/Data/Binary/Get/Internal.hs +55/−3
- tests/Action.hs +277/−79
- tests/QC.hs +112/−50
README.md view
@@ -1,5 +1,7 @@ # binary package # +[](http://travis-ci.org/kolmodin/binary)+ *Efficient, pure binary serialisation using lazy ByteStrings.* The ``binary`` package provides Data.Binary, containing the Binary class,@@ -52,42 +54,22 @@ More information in the haddock documentation. -## Deriving binary instances ##--It is possible to mechanically derive new instances of Binary for your-types, if they support the Data and Typeable classes. A script is-provided in tools/derive. Here's an example of its use.+## Deriving binary instances using GHC's Generic ## - $ cd binary - $ cd tools/derive +Beginning with GHC 7.2, it is possible to use binary serialization without+writing any instance boilerplate code. - $ ghci -fglasgow-exts BinaryDerive.hs+```haskell+{-# LANGUAGE DeriveGeneric #-} - *BinaryDerive> :l Example.hs +import Data.Binary+import GHC.Generics (Generic) - *Main> deriveM (undefined :: Exp)+data Foo = Foo deriving (Generic) - instance Binary Main.Exp where- put (ExpOr a b) = putWord8 0 >> put a >> put b- put (ExpAnd a b) = putWord8 1 >> put a >> put b- put (ExpEq a b) = putWord8 2 >> put a >> put b- put (ExpNEq a b) = putWord8 3 >> put a >> put b- put (ExpAdd a b) = putWord8 4 >> put a >> put b- put (ExpSub a b) = putWord8 5 >> put a >> put b- put (ExpVar a) = putWord8 6 >> put a- put (ExpInt a) = putWord8 7 >> put a- get = do- tag_ <- getWord8- case tag_ of- 0 -> get >>= \a -> get >>= \b -> return (ExpOr a b)- 1 -> get >>= \a -> get >>= \b -> return (ExpAnd a b)- 2 -> get >>= \a -> get >>= \b -> return (ExpEq a b)- 3 -> get >>= \a -> get >>= \b -> return (ExpNEq a b)- 4 -> get >>= \a -> get >>= \b -> return (ExpAdd a b)- 5 -> get >>= \a -> get >>= \b -> return (ExpSub a b)- 6 -> get >>= \a -> return (ExpVar a)- 7 -> get >>= \a -> return (ExpInt a)- _ -> fail "no decoding"+-- GHC will automatically fill out the instance+instance Binary Foo+``` ## Contributors ## @@ -106,3 +88,6 @@ * Bryan O'Sullivan * Bas van Dijk * Florian Weimer++For a full list of contributors, see+[here](https://github.com/kolmodin/binary/graphs/contributors).
binary.cabal view
@@ -1,5 +1,5 @@ name: binary-version: 0.7.1.0+version: 0.7.2.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin <kolmodin@gmail.com>@@ -18,7 +18,7 @@ stability: provisional build-type: Simple cabal-version: >= 1.8-tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.6.1+tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.2 extra-source-files: README.md index.html docs/hcar/binary-Lb.tex tools/derive/*.hs tests/Makefile benchmarks/Makefile@@ -31,9 +31,6 @@ type: git location: git://github.com/kolmodin/binary.git -flag development- default: False- library build-depends: base >= 3.0 && < 5, bytestring >= 0.9, containers, array hs-source-dirs: src@@ -56,78 +53,86 @@ ghc-options: -O2 -Wall -fliberate-case-threshold=1000 +-- Due to circular dependency, we cannot make any of the test-suites or+-- benchmark depend on the binary library. Instead, for each test-suite and+-- benchmark, we include the source directory of binary and build-depend on all+-- the dependencies binary has.+ test-suite qc type: exitcode-stdio-1.0- hs-source-dirs: tests+ hs-source-dirs: src tests main-is: QC.hs other-modules: Action Arbitrary build-depends:- array, base >= 3.0 && < 5, bytestring >= 0.9,- containers, random>=1.0.1.0, test-framework, test-framework-quickcheck2 >= 0.3,- QuickCheck>=2.5+ QuickCheck>=2.7 - ghc-options: -Wall -O2- hs-source-dirs: src+ -- build dependencies from using binary source rather than depending on the library+ build-depends: array, containers+ ghc-options: -Wall -O2 -threaded test-suite read-write-file type: exitcode-stdio-1.0- hs-source-dirs: tests+ hs-source-dirs: src tests main-is: File.hs build-depends: base >= 3.0 && < 5, bytestring >= 0.9,- binary, Cabal, directory, filepath, HUnit + -- build dependencies from using binary source rather than depending on the library+ build-depends: array, containers ghc-options: -Wall benchmark bench type: exitcode-stdio-1.0- hs-source-dirs: benchmarks+ hs-source-dirs: src benchmarks main-is: Benchmark.hs other-modules: MemBench build-depends: base >= 3.0 && < 5,- binary, bytestring+ -- build dependencies from using binary source rather than depending on the library+ build-depends: array, containers c-sources: benchmarks/CBenchmark.c include-dirs: benchmarks ghc-options: -O2 benchmark get type: exitcode-stdio-1.0- hs-source-dirs: benchmarks+ hs-source-dirs: src benchmarks main-is: Get.hs build-depends: attoparsec, base >= 3.0 && < 5,- binary, bytestring, cereal, criterion, deepseq, mtl+ -- build dependencies from using binary source rather than depending on the library+ build-depends: array, containers ghc-options: -O2 benchmark builder type: exitcode-stdio-1.0- hs-source-dirs: benchmarks+ hs-source-dirs: src benchmarks main-is: Builder.hs build-depends: base >= 3.0 && < 5,- binary, bytestring, criterion, deepseq, mtl+ -- build dependencies from using binary source rather than depending on the library+ build-depends: array, containers ghc-options: -O2
src/Data/Binary/Builder/Base.hs view
@@ -508,7 +508,5 @@ append (ensureFree a) (ensureFree b) = ensureFree (max a b) "flush/flush"- append flush flush = flush-- #-}+ append flush flush = flush #-} #endif
src/Data/Binary/Get.hs view
@@ -12,7 +12,7 @@ -- Module : Data.Binary.Get -- Copyright : Lennart Kolmodin -- License : BSD3-style (see LICENSE)--- +-- -- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : experimental -- Portability : portable to Hugs and GHC.@@ -33,11 +33,11 @@ -- A corresponding Haskell value looks like this: -- -- @--- data Trade = Trade--- { timestamp :: !'Word32'--- , price :: !'Word32'--- , qty :: !'Word16'--- } deriving ('Show')+--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@@ -46,21 +46,21 @@ -- <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+--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'+--getTrade' :: 'Get' Trade+--getTrade' = Trade '<$>' 'getWord32le' '<*>' 'getWord32le' '<*>' 'getWord16le' -- @ -- -- The applicative style can sometimes result in faster code, as @binary@@@ -73,24 +73,23 @@ -- 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)+--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+--lazyIOExample :: IO [Trade]+--lazyIOExample = do -- input <- BL.readFile \"trades.bin\"--- let trades = runGet getTrades input --- print trades+-- return ('runGet' getTrades input) -- @ -- -- This decoder has the downside that it will need to read all the input before@@ -98,24 +97,41 @@ -- 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+-- and get the following decoder. It will start to return data without knowing -- 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+--incrementalExample :: BL.ByteString -> [Trade]+--incrementalExample input0 = go decoder input0+-- where+-- decoder = 'runGetIncremental' getTrade+-- go :: 'Decoder' Trade -> BL.ByteString -> [Trade]+-- go ('Done' leftover _consumed trade) input =+-- trade : go decoder (BL.chunk leftover input)+-- go ('Partial' k) input =+-- go (k . takeHeadChunk $ input) (dropHeadChunk input)+-- go ('Fail' _leftover _consumed msg) _input =+-- error msg+--+--takeHeadChunk :: BL.ByteString -> Maybe BS.ByteString+--takeHeadChunk lbs =+-- case lbs of+-- (BL.Chunk bs _) -> Just bs+-- _ -> Nothing+--+--dropHeadChunk :: BL.ByteString -> BL.ByteString+--dropHeadChunk lbs =+-- case lbs of+-- (BL.Chunk _ lbs') -> lbs'+-- _ -> BL.Empty -- @ ----- Both these examples use lazy I/O to read the file from the disk, which is+-- The @lazyIOExample@ uses 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".+-- use the incremental input method like in @incrementalExample@.+-- For an example of how to read incrementally from a Handle,+-- see the implementation of 'decodeFileOrFail' in "Data.Binary". ----------------------------------------------------------------------------- @@ -126,7 +142,7 @@ -- * The lazy input interface -- $lazyinterface- , runGet + , runGet , runGetOrFail , ByteOffset @@ -144,9 +160,11 @@ , skip , isEmpty , bytesRead+ , isolate , lookAhead , lookAheadM , lookAheadE+ , label -- ** ByteStrings , getByteString@@ -200,7 +218,7 @@ -- The lazy interface consumes a single lazy 'L.ByteString'. It's the easiest -- interface to get started with, but it doesn't support interleaving I\/O and -- parsing, unless lazy I/O is used.--- +-- -- There is no way to provide more input other than the initial data. To be -- able to incrementally give more data, see the incremental input interface. @@ -255,7 +273,7 @@ go (k $! (acc - unused)) acc -- | DEPRECATED. Provides compatibility with previous versions of this library.--- Run a 'Get' monad and return a tuple with thee values.+-- Run a 'Get' monad and return a tuple with three values. -- The first value is the result of the decoder. The second and third are the -- unused input, and the number of consumed bytes. {-# DEPRECATED runGetState "Use runGetIncremental instead. This function will be removed." #-}@@ -341,7 +359,7 @@ Done _ _ _ -> r Partial k -> k Nothing Fail _ _ _ -> r- + -- | An efficient get method for lazy ByteStrings. Fails if fewer than @n@ -- bytes are left in the input. getLazyByteString :: Int64 -> Get L.ByteString@@ -381,7 +399,7 @@ Just (want,rest) -> do put rest return [want]- + -- | Get the remaining bytes as a lazy ByteString. -- Note that this can be an expensive function to use as it forces reading -- all input and keeping the string in-memory.@@ -419,8 +437,7 @@ "getWord32be/readN" getWord32be = readN 4 word32be "getWord32le/readN" getWord32le = readN 4 word32le "getWord64be/readN" getWord64be = readN 8 word64be-"getWord64le/readN" getWord64le = readN 8 word64le- #-}+"getWord64le/readN" getWord64le = readN 8 word64le #-} -- | Read a Word16 in big endian format getWord16be :: Get Word16
src/Data/Binary/Get/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-}+{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns, TypeFamilies #-} -- CPP C style pre-precessing, the #if defined lines -- RankNTypes forall r. statement@@ -18,6 +18,7 @@ -- * Parsing , skip , bytesRead+ , isolate , get , put@@ -31,6 +32,7 @@ , lookAhead , lookAheadM , lookAheadE+ , label -- ** ByteStrings , getByteString@@ -179,6 +181,41 @@ bytesRead :: Get Int64 bytesRead = C $ \inp k -> BytesRead (fromIntegral $ B.length inp) (k inp) +-- | Isolate a decoder to operate with a fixed number of bytes, and fail if+-- fewer bytes were consumed, or more bytes were attempted to be consumed.+-- If the given decoder fails, 'isolate' will also fail.+-- Offset from 'bytesRead' will be relative to the start of 'isolate', not the+-- absolute of the input.+isolate :: Int -- ^ The number of bytes that must be consumed+ -> Get a -- ^ The decoder to isolate+ -> Get a+isolate n0 act+ | n0 < 0 = fail "isolate: negative size"+ | otherwise = go n0 (runCont act B.empty Done)+ where+ go !n (Done left x)+ | n == 0 && B.null left = return x+ | otherwise = do+ pushFront left+ let consumed = n0 - n - B.length left+ fail $ "isolate: the decoder consumed " ++ show consumed ++ " bytes" +++ " which is less than the expected " ++ show n0 ++ " bytes"+ go 0 (Partial resume) = go 0 (resume Nothing)+ go n (Partial resume) = do+ inp <- C $ \inp k -> do+ let takeLimited str =+ let (inp', out) = B.splitAt n str+ in k out (Just inp')+ case not (B.null inp) of+ True -> takeLimited inp+ False -> prompt inp (k B.empty Nothing) takeLimited+ case inp of+ Nothing -> go n (resume Nothing)+ Just str -> go (n - B.length str) (resume (Just str))+ go _ (Fail bs err) = pushFront bs >> fail err+ go n (BytesRead r resume) =+ go n (resume $! fromIntegral n0 - fromIntegral n - r)+ -- | Demand more input. If none available, fail. demandInput :: Get () demandInput = C $ \inp ks ->@@ -239,6 +276,10 @@ pushBack bs = C $ \ inp ks -> ks (B.concat (inp : bs)) () {-# INLINE pushBack #-} +pushFront :: B.ByteString -> Get ()+pushFront bs = C $ \ inp ks -> ks (B.append bs inp) ()+{-# INLINE pushFront #-}+ -- | Run the given decoder, but without consuming its input. If the given -- decoder fails, then so will this function. lookAhead :: Get a -> Get a@@ -269,6 +310,18 @@ Fail inp s -> C $ \_ _ -> Fail inp s _ -> error "Binary: impossible" +-- Label a decoder. If the decoder fails, the label will be appended on+-- a new line to the error message string.+label :: String -> Get a -> Get a+label msg decoder = C $ \inp ks ->+ let r0 = runCont decoder inp (\inp' a -> Done inp' a)+ go r = case r of+ Done inp' a -> ks inp' a+ Partial k -> Partial (go . k)+ Fail inp' s -> Fail inp' (s ++ "\n" ++ msg)+ BytesRead u k -> BytesRead u (go . k)+ in go r0+ -- | DEPRECATED. Get the number of bytes of remaining input. -- Note that this is an expensive function to use as in order to calculate how -- much input remains, all input has to be read and kept in-memory.@@ -321,8 +374,7 @@ returnG f = readN 0 (const f) "readN 0/returnG swapback" [1] forall f.- readN 0 f = returnG (f B.empty)- #-}+ readN 0 f = returnG (f B.empty) #-} -- | Ensure that there are at least @n@ bytes available. If not, the -- computation will escape with 'Partial'.
tests/Action.hs view
@@ -1,22 +1,31 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-} module Action where -import Control.Applicative-import Control.Monad-import Test.QuickCheck-import Data.Maybe ( fromJust )+import Control.Applicative+import Control.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Char+import Data.List (intersperse, nub) -import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck -import qualified Data.Binary.Get as Binary+import Arbitrary ()+import qualified Data.Binary.Get as Binary -import Arbitrary()+tests :: [Test]+tests = [ testProperty "action" prop_action+ , testProperty "label" prop_label+ , testProperty "fail" prop_fail ] data Action = Actions [Action] | GetByteString Int+ | Isolate Int [Action] | Try [Action] [Action]+ | Label String [Action] | LookAhead [Action] -- | First argument is True if this action returns Just, otherwise False. | LookAheadM Bool [Action]@@ -31,32 +40,36 @@ case action of 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]- LookAheadE b a -> Actions a : [ LookAheadE b a' | a' <- shrink a]- Try [Fail] b -> Actions b : [ Try [Fail] b' | b' <- shrink b ]+ GetByteString n -> [ GetByteString n' | n' <- shrink n, n >= 0 ]+ Isolate 0 as -> [ Isolate 0 as' | as' <- shrink as ]+ Isolate 1 as -> [ Isolate 0 as' | as' <- shrink as ]+ Isolate n0 as -> nub $+ let ns as' = filter (>=0) $ (n0 - 1) : [ 0 .. max_len as' + 1 ]+ in Actions as : [ Isolate n' as'+ | as' <- [] : shrink as+ , n' <- ns as' ]+ Label str a -> Actions a : [ Label str a' | a' <- [] : shrink a, a /= []]+ LookAhead a -> Actions a : [ LookAhead a' | a' <- [] : shrink a, a /= []]+ LookAheadM b a -> Actions a : [ LookAheadM b a' | a' <- [] : shrink a, a /= []]+ LookAheadE b a -> Actions a : [ LookAheadE b a' | a' <- [] : shrink a, a /= []]+ Try [Fail] b -> Actions b : [ Try [Fail] b' | b' <- [] : shrink b ] Try a 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 ]+ [Actions a | not (willFail' a)]+ ++ [ Try a' b' | a' <- [] : shrink a, b' <- [] : shrink b ]+ ++ [ Try a' b | a' <- [] : shrink a ]+ ++ [ Try a b' | b' <- [] : shrink b ] -willFail :: [Action] -> Bool-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- LookAheadE _ a -> willFail a || willFail xs- BytesRead -> willFail xs- Fail -> True+willFail :: Int -> [Action] -> Bool+willFail inp xxs =+ case eval inp xxs of+ EFail {} -> True+ _ -> False +willFail' :: [Action] -> Bool+willFail' = willFail maxBound+ -- | The maximum length of input decoder can request. -- The decoder may end up using less, but never more. -- This way, you know how much input to generate for running a decoder test.@@ -64,65 +77,202 @@ max_len [] = 0 max_len (x:xs) = case x of- Actions x' -> max_len x' + max_len xs- GetByteString n -> n + max_len xs+ Actions xs' -> max_len (xs' ++ 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)- LookAheadE b a | willFail a -> max_len a- | b -> max_len a + max_len xs- | otherwise -> max (max_len a) (max_len xs)+ GetByteString n -> n + max_len xs+ Isolate n xs'+ | Just _ <- actual_len' [Isolate n xs'] -> n + max_len xs+ | otherwise -> n+ Label _ xs' -> max_len (xs' ++ xs)+ LookAhead xs'+ | willFail' xs' -> max_len xs'+ | otherwise -> max (max_len xs') (max_len xs)+ LookAheadM consume xs'+ | consume -> max_len (xs' ++ xs)+ | otherwise -> max_len (LookAhead xs' : xs)+ LookAheadE consume xs'+ | consume -> max_len (xs' ++ xs)+ | otherwise -> max_len (LookAhead xs' : xs)+ Try a b+ | willFail' a && willFail' b -> max (max_len a) (max_len b)+ | willFail' a -> max (max_len a) (max_len b) + max_len xs+ | otherwise -> max_len (a ++ xs) -- | The actual length of input that will be consumed when -- a decoder is executed, or Nothing if the decoder will fail.-actual_len :: [Action] -> Maybe Int-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- LookAheadE 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+actual_len :: Int -> [Action] -> Maybe Int+actual_len inp xs =+ case eval inp xs of+ ESuccess inp' -> Just (inp - inp')+ _ -> Nothing - where- rest = actual_len xs+actual_len' :: [Action] -> Maybe Int+actual_len' = actual_len maxBound +randomInput :: Int -> Gen L.ByteString+randomInput 0 = return L.empty+randomInput n = do+ m <- choose (1, min n 10)+ s <- vectorOf m $ choose ('a', 'z')+ let b = B.pack $ map (fromIntegral.ord) s+ rest <- randomInput (n-m)+ return (L.append (L.fromChunks [b]) rest)+ -- | Build binary programs and compare running them to running a (hopefully) -- identical model. -- Tests that 'bytesRead' returns correct values when used together with '<|>' -- and 'fail'. prop_action :: Property prop_action =- forAllShrink gen_actions shrink $ \ actions ->- forAll arbitrary $ \ lbs ->- L.length lbs >= fromIntegral (max_len actions) ==>- let allInput = B.concat (L.toChunks lbs) in- case Binary.runGet (eval allInput actions) lbs of- () -> True+ forAllShrink (gen_actions False) shrink $ \ actions ->+ let max_len_input = max_len actions in+ forAll (randomInput max_len_input) $ \ lbs ->+ let allInput = B.concat (L.toChunks lbs) in+ case Binary.runGetOrFail (execute allInput actions) lbs of+ Right (_inp, _off, _x) -> True+ Left (_inp, _off, _msg) -> True --- | Evaluate (run) the model.+-- | When a decoder aborts with 'fail', check that all relevant uses of 'label'+-- are respected.+prop_label :: Property+prop_label =+ forAllShrink (gen_actions True) shrink $ \ actions ->+ let max_len_input = max_len actions in+ forAll (randomInput max_len_input) $ \ lbs ->+ let allInput = B.concat (L.toChunks lbs) in+ collect (failReason $ eval max_len_input actions) $+ case Binary.runGetOrFail (execute allInput actions) lbs of+ Left (_inp, _off, msg) ->+ let lbls = case collectLabels max_len_input actions of+ Just lbls' -> lbls'+ Nothing -> error ("expected labels, got: " ++ msg)+ expectedMsg = concat $ intersperse "\n" lbls+ in expectedMsg === msg+ Right (_inp, _off, _value) -> label "test case without 'fail'" $ True++-- | When a decoder aborts with 'fail', check the fail position and+-- remaining input.+prop_fail :: Property+prop_fail =+ forAllShrink (gen_actions True) shrink $ \ actions ->+ let max_len_input = max_len actions in+ forAll (randomInput max_len_input) $ \ lbs ->+ let allInput = B.concat (L.toChunks lbs) in+ collect (failReason $ eval max_len_input actions) $+ case Binary.runGetOrFail (execute allInput actions) lbs of+ Left (inp, off, _msg) ->+ case () of+ _ | Just off /= findFailPosition max_len_input actions ->+ error ("fail position incorrect, expected " +++ show (findFailPosition max_len_input actions) +++ " but got " ++ show off)+ | inp /= L.drop (fromIntegral off) lbs ->+ error $ "remaining output incorrect, was: " ++ show inp +++ ", should hav been: " ++ show (L.drop (fromIntegral off) lbs)+ | otherwise -> property True+ Right (_inp, _off, _value) -> label "test case without 'fail'" $ property True++-- | Collect all the labels up to a 'fail', or Nothing if the+-- decoder will not fail.+collectLabels :: Int -> [Action] -> Maybe [String]+collectLabels inp xxs =+ case eval inp xxs of+ EFail _ lbls _ -> Just lbls+ _ -> Nothing++-- | Finds at which byte offset the decoder will fail,+-- or Nothing if it won't fail.+findFailPosition :: Int -> [Action] -> Maybe Binary.ByteOffset+findFailPosition inp xxs =+ case eval inp xxs of+ EFail _ _ inp' -> return (fromIntegral (inp-inp'))+ _ -> Nothing++failReason :: Eval -> String+failReason (EFail fr _ _) = show fr+failReason _ = "NoFail"++-- | The result of an evaluation.+data Eval = ESuccess Int+ -- ^ The evalutation completed successfully. Contains the number of+ -- remaining bytes of the input.+ | EFail FailReason [String] Int+ -- ^ The evaluation completed with a failure. Contains the labels up+ -- to the failure, and the number of remaining bytes of the input.+ deriving (Show,Eq)++data FailReason+ = FRFail+ | FRIsolateTooMuch+ | FRIsolateTooLittle+ | FRTooMuch+ deriving (Show,Eq)++-- | Given the number of input bytes and a list of actions, evaluate the+-- actions and return whether the actions succeeed or fail.+eval :: Int -> [Action] -> Eval+eval inp0 = go inp0 []+ where+ step :: Int -> Int -> [String] -> [Action] -> Eval+ step inp n lbls xs+ | inp - n < 0 =+ let msg = "demandInput: not enough bytes"+ in EFail FRTooMuch (msg:lbls) inp+ | otherwise = go (inp-n) lbls xs+ go :: Int -> [String] -> [Action] -> Eval+ go inp _lbls [] = ESuccess inp+ go inp lbls (x:xs) =+ case x of+ Actions xs' -> go inp lbls (xs'++xs)+ BytesRead -> go inp lbls xs+ Fail -> EFail FRFail ("fail":lbls) inp+ GetByteString n -> step inp n lbls xs+ Isolate n xs'+ | n > inp ->+ case go inp lbls xs' of+ ESuccess inp' ->+ let msg = "isolate: the decoder consumed " ++ show (inp - inp') +++ " bytes which is less than the expected " ++ (show n) +++ " bytes"+ in EFail FRTooMuch (msg:lbls) inp'+ efail -> efail+ | otherwise ->+ case go n lbls xs' of+ EFail fr lbls' inp' -> EFail fr lbls' (inp - n + inp')+ ESuccess 0 -> go (inp-n) lbls xs+ ESuccess inp' ->+ let msg = "isolate: the decoder consumed " ++ show (n - inp') +++ " bytes which is less than the expected " ++ (show n) +++ " bytes"+ in EFail FRIsolateTooLittle (msg:lbls) (inp - n + inp')+ Label str xs' ->+ case go inp (str:lbls) xs' of+ EFail fr lbls' inp' -> EFail fr lbls' inp'+ ESuccess inp' -> go inp' lbls xs+ LookAhead xs'+ | EFail fr lbls' inp' <- go inp lbls xs' -> EFail fr lbls' inp'+ | otherwise -> go inp lbls xs+ LookAheadM consume xs'+ | consume -> go inp lbls (xs'++xs)+ | otherwise -> go inp lbls (LookAhead xs' : xs)+ LookAheadE consume xs'+ | consume -> go inp lbls (xs'++xs)+ | otherwise -> go inp lbls (LookAhead xs' : xs)+ Try a b ->+ case go inp lbls a of+ ESuccess inp' -> go inp' lbls xs+ EFail {} -> go inp lbls (b++xs)+ +-- | Execute (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+-- The second argument is the model - the actions we will execute.+execute :: B.ByteString -> [Action] -> Binary.Get ()+execute inp acts0 = go 0 acts0 >> return () where+ inp_len = B.length inp go _ [] = return () go pos (x:xs) = case x of@@ -130,16 +280,28 @@ GetByteString n -> do -- Run the operation in the Get monad... actual <- Binary.getByteString n- let expected = B.take n . B.drop pos $ str+ let expected = B.take n . B.drop pos $ inp -- ... and compare that we got what we expected.- when (actual /= expected) $ error "actual /= expected"+ when (actual /= expected) $ error $+ "execute(getByteString): actual /= expected at pos " ++ show pos +++ ", got: " ++ show actual ++ ", expected: " ++ show expected go (pos+n) xs BytesRead -> do pos' <- Binary.bytesRead- if (pos == fromIntegral pos')+ if pos == fromIntegral pos' then go pos xs- else error $ "expected " ++ show pos ++ " but got " ++ show pos'+ else error $ "execute(bytesRead): expected " +++ show pos ++ " but got " ++ show pos' Fail -> fail "fail"+ Isolate n as -> do+ let str = B.take n (B.drop pos inp)+ _ <- Binary.isolate n (execute str as)+ when (willFail (inp_len - pos) [Isolate n as]) $+ error "expected isolate to fail"+ go (pos + n) xs+ Label str as -> do+ len <- Binary.label str (leg pos as)+ go (pos+len) xs LookAhead a -> do _ <- Binary.lookAhead (go pos a) go pos xs@@ -162,12 +324,14 @@ go (pos+offset) xs leg pos t = do go pos t- case actual_len t of+ case actual_len (inp_len - pos) t of Nothing -> error "impossible: branch should have failed" Just offset -> return offset -gen_actions :: Gen [Action]-gen_actions = sized (go False)+gen_actions :: Bool -> Gen [Action]+gen_actions genFail = do+ acts <- sized (go False)+ return acts where go :: Bool -> Int -> Gen [Action] go _ 0 = return []@@ -185,4 +349,38 @@ , do t <- go inTry (s`div`2) b <- arbitrary (:) (LookAheadE b t) <$> go inTry (s-1)- ] ++ [ return [Fail] | inTry ]+ , do t <- go inTry (s`div`2)+ Positive n <- arbitrary :: Gen (Positive Int)+ (:) (Label ("some label: " ++ show n) t) <$> go inTry (s-1)+ , do t <- resize (s`div`2) (gen_isolate (genFail || inTry))+ (:) t <$> go inTry (s-1)+ ] ++ [frequency [(if inTry || genFail then 1 else 0, return [Fail])+ ,(9 , go inTry s)]]++gen_isolate :: Bool -> Gen Action+gen_isolate genFail = gen_actions genFail >>= go+ where+ go t0 = do+ -- We can isolate the decoder with three different ranges;+ -- * give too few bytes -> isolate will fail+ -- * give exactly right amount of bytes -> isolate+ -- will succeed if the given decoder succeeds+ -- * give too many bytes -> isolate will fail+ -- Here we generate Isolates that belong to the different+ -- buckets.+ let t = t0+ tooFewBytes n = do+ n' <- choose (0, n)+ return (n',t)+ requiredBytes n = return (n,t)+ tooManyBytes n = do+ n' <- choose (n+1, n+10)+ return (n+n',t)+ let trees+ | Just n <- actual_len' t = oneof $+ [ requiredBytes n ] +++ [ tooFewBytes n | genFail ] +++ [ tooManyBytes n | genFail ]+ | otherwise = return (max_len t, t)+ (n,t') <- trees+ return (Isolate n t')
tests/QC.hs view
@@ -1,46 +1,26 @@ {-# LANGUAGE ScopedTypeVariables #-}-module Main where--import Data.Binary-import Data.Binary.Put-import Data.Binary.Get--import Control.Applicative-import Control.Monad (unless)--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.ByteString.Lazy.Internal as L--- import qualified Data.Map as Map--- import qualified Data.Set as Set--- import qualified Data.IntMap as IntMap--- import qualified Data.IntSet as IntSet---- import Data.Array (Array)--- import Data.Array.IArray--- import Data.Array.Unboxed (UArray)---- import Data.Word-import Data.Int-import Data.Ratio--import Control.Exception as C (catch,evaluate,SomeException)--- import Control.Monad--- import System.Environment--- import System.IO-import System.IO.Unsafe+module Main ( main ) where -import Test.QuickCheck--- import Text.Printf+import Control.Applicative+import Control.Exception as C (SomeException,+ catch, evaluate)+import Control.Monad (unless)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L+import Data.Int+import Data.Ratio+import System.IO.Unsafe -import Test.Framework-import Test.Framework.Providers.QuickCheck2--- import Data.Monoid+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck -import Action (prop_action)-import Arbitrary()+import qualified Action (tests)+import Arbitrary ()+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put ------------------------------------------------------------------------ @@ -199,7 +179,94 @@ (a,b) = decode (encode x) _types = [a,b] +-- In binary-0.5 the Get monad looked like+--+-- > data S = S {-# UNPACK #-} !B.ByteString+-- > L.ByteString+-- > {-# UNPACK #-} !Int64+-- >+-- > newtype Get a = Get { unGet :: S -> (# a, S #) }+--+-- with a helper function+--+-- > mkState :: L.ByteString -> Int64 -> S+-- > mkState l = case l of+-- > L.Empty -> S B.empty L.empty+-- > L.Chunk x xs -> S x xs+--+-- Note that mkState is strict in its first argument. This goes wrong in this+-- function:+--+-- > getBytes :: Int -> Get B.ByteString+-- > getBytes n = do+-- > S s ss bytes <- traceNumBytes n $ get+-- > if n <= B.length s+-- > then do let (consume,rest) = B.splitAt n s+-- > put $! S rest ss (bytes + fromIntegral n)+-- > return $! consume+-- > else+-- > case L.splitAt (fromIntegral n) (s `join` ss) of+-- > (consuming, rest) ->+-- > do let now = B.concat . L.toChunks $ consuming+-- > put $ mkState rest (bytes + fromIntegral n)+-- > -- forces the next chunk before this one is returned+-- > if (B.length now < n)+-- > then+-- > fail "too few bytes"+-- > else+-- > return now+--+-- Consider the else-branch of this function; suppose we ask for n bytes;+-- the call to L.splitAt gives us a lazy bytestring 'consuming' of precisely @n@+-- bytes (unless we don't have enough data, in which case we fail); but then+-- the strict evaluation of mkState on 'rest' means we look ahead too far.+--+-- Although this is all done completely differently in binary-0.7 it is+-- important that the same bug does not get introduced in some other way. The+-- test is basically the same test that already exists in this test suite,+-- verifying that+--+-- > decode . refragment . encode == id+--+-- However, we use a different 'refragment', one that introduces an exception+-- as the tail of the bytestring after rechunking. If we don't look ahead too+-- far then this should make no difference, but if we do then this will throw+-- an exception (for instance, in binary-0.5, this will throw an exception for+-- certain rechunkings, but not for others).+--+-- To make sure that the property holds no matter what refragmentation we use,+-- we test exhaustively for a single chunk, and all ways to break the string+-- into 2, 3 and 4 chunks.+prop_lookAheadIndepOfChunking :: (Eq a, Binary a) => a -> Property+prop_lookAheadIndepOfChunking testInput =+ forAll (testCuts (L.length (encode testInput))) $+ roundTrip testInput . rechunk+ where+ testCuts :: forall a. (Num a, Enum a) => a -> Gen [a]+ testCuts len = elements $ [ [] ]+ ++ [ [i]+ | i <- [0 .. len] ]+ ++ [ [i, j]+ | i <- [0 .. len]+ , j <- [0 .. len - i] ]+ ++ [ [i, j, k]+ | i <- [0 .. len]+ , j <- [0 .. len - i]+ , k <- [0 .. len - i - j] ] + -- Rechunk a bytestring, leaving the tail as an exception rather than Empty+ rechunk :: forall a. Integral a => [a] -> L.ByteString -> L.ByteString+ rechunk cuts = fromChunks . cut cuts . B.concat . L.toChunks+ where+ cut :: [a] -> B.ByteString -> [B.ByteString]+ cut [] bs = [bs]+ cut (i:is) bs = let (bs0, bs1) = B.splitAt (fromIntegral i) bs+ in bs0 : cut is bs1++ fromChunks :: [B.ByteString] -> L.ByteString+ fromChunks [] = error "Binary should not have to ask for this chunk!"+ fromChunks (bs:bss) = L.Chunk bs (fromChunks bss)+ -- String utilities prop_getLazyByteString :: L.ByteString -> Property@@ -304,6 +371,9 @@ , testGroup "Boundaries" [ testProperty "read to much" (p (prop_readTooMuch :: B Word8)) , testProperty "read negative length" (p (prop_getByteString_negative :: T Int))+ , -- Arbitrary test input+ let testInput :: [Int] ; testInput = [0 .. 10]+ in testProperty "look-ahead independent of chunking" (p (prop_lookAheadIndepOfChunking testInput)) ] , testGroup "Partial"@@ -314,8 +384,7 @@ ] , testGroup "Model"- [ testProperty "action" Action.prop_action- ]+ Action.tests , testGroup "Primitives" [ testProperty "Word16be" (p prop_Word16be)@@ -332,9 +401,9 @@ , testGroup "String utils" [ testProperty "getLazyByteString" prop_getLazyByteString- , testProperty "getLazyByteStringNul" prop_getLazyByteStringNul + , testProperty "getLazyByteStringNul" prop_getLazyByteStringNul , testProperty "getLazyByteStringNul No Null" prop_getLazyByteStringNul_noNul- , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString + , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString ] , testGroup "Using Binary class, refragmented ByteString" $ map (uncurry testProperty)@@ -401,10 +470,6 @@ p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int))) , ("(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)", p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)))- {-- , ("IntSet", p (test :: T IntSet.IntSet ))- , ("IntMap ByteString", p (test :: T (IntMap.IntMap B.ByteString) ))- -} , ("B.ByteString", p (test :: T B.ByteString )) , ("L.ByteString", p (test :: T L.ByteString ))@@ -417,6 +482,3 @@ , ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] )) ] ]---- GHC only:--- ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))