diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,5 +1,5 @@ name: binary -version: 0.6.0.0 +version: 0.6.1.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin @@ -15,7 +15,7 @@ category: Data, Parsing stability: provisional build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.8 tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.6.1 extra-source-files: README index.html @@ -23,31 +23,12 @@ type: git location: git://github.com/kolmodin/binary.git -flag bytestring-in-base -flag split-base -flag applicative-in-base +flag development + default: False library - if flag(bytestring-in-base) - -- bytestring was in base-2.0 and 2.1.1 - build-depends: base >= 2.0 && < 2.2 - cpp-options: -DBYTESTRING_IN_BASE - else - -- in base 1.0 and 3.0 bytestring is a separate package - build-depends: base < 2.0 || >= 3, bytestring >= 0.9 - - if flag(split-base) - build-depends: base >= 3.0, containers, array - else - build-depends: base < 3.0 - - if flag(applicative-in-base) - build-depends: base >= 2.0 - cpp-options: -DAPPLICATIVE_IN_BASE - else - build-depends: base < 2.0 + build-depends: base >= 3.0 && < 5, bytestring >= 0.9, containers, array hs-source-dirs: src - exposed-modules: Data.Binary, Data.Binary.Put, Data.Binary.Get, @@ -62,5 +43,22 @@ ghc-options: -O2 -Wall -fliberate-case-threshold=1000 --- if impl(ghc < 6.5) --- ghc-options: -fallow-undecidable-instances +test-suite qc + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: QC.hs + build-depends: + array, + base >= 3.0 && < 5, + bytestring >= 0.9, + containers, + random>=1.0.1.0, + test-framework, + test-framework-quickcheck2, + QuickCheck>=2.5 + + if flag(development) + ghc-options: -Wall + hs-source-dirs: src + else + build-depends: binary diff --git a/src/Data/Binary/Get/Internal.hs b/src/Data/Binary/Get/Internal.hs --- a/src/Data/Binary/Get/Internal.hs +++ b/src/Data/Binary/Get/Internal.hs @@ -41,12 +41,10 @@ import Control.Applicative -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#if __GLASGOW_HASKELL__ < 704 && !defined(__HADDOCK__) -- needed for (# unboxing #) with magic hash -- Do we still need these? Works without on modern GHCs. import GHC.Base -import GHC.Word --- import GHC.Int #endif -- Kolmodin 20100427: at zurihac we discussed of having partial take a @@ -149,11 +147,15 @@ case ms of Just _ -> go (k ms) Nothing -> neverAgain (k ms) - _ -> r + BytesRead n k -> BytesRead n (go . k) + Done _ _ -> r + Fail _ _ -> r neverAgain r = case r of Partial k -> neverAgain (k Nothing) - _ -> r + BytesRead n k -> BytesRead n (neverAgain . k) + Fail _ _ -> r + Done _ _ -> r prompt :: B.ByteString -> Decoder a -> (B.ByteString -> Decoder a) -> Decoder a prompt inp kf ks = diff --git a/src/Data/Binary/Put.hs b/src/Data/Binary/Put.hs --- a/src/Data/Binary/Put.hs +++ b/src/Data/Binary/Put.hs @@ -61,9 +61,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -#ifdef APPLICATIVE_IN_BASE import Control.Applicative -#endif ------------------------------------------------------------------------ @@ -84,14 +82,12 @@ fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w {-# INLINE fmap #-} -#ifdef APPLICATIVE_IN_BASE instance Applicative PutM where pure = return m <*> k = Put $ let PairS f w = unPut m PairS x w' = unPut k in PairS (f x) (w `mappend` w') -#endif -- Standard Writer monad, with aggressive inlining instance Monad PutM where diff --git a/tests/QC.hs b/tests/QC.hs --- a/tests/QC.hs +++ b/tests/QC.hs @@ -5,6 +5,7 @@ import Data.Binary.Put import Data.Binary.Get +import Control.Applicative import Control.Monad (unless) import qualified Data.ByteString as B @@ -164,6 +165,29 @@ return ((total',n):rest) +-- | We're trying to guarantee that the Decoder will not ask for more input +-- with Partial if it has been given Nothing once. +-- In this test we're making the decoder return 'Partial' to get more +-- input, and to get knownledge of the current position using 'BytesRead'. +-- Both of these operations, when used with the <|> operator, result internally +-- in that the decoder return with Partial and BytesRead multiple times, +-- in which case we need to keep track of if the user has passed Nothing to a +-- Partial in the past. +prop_partialOnlyOnce :: Property +prop_partialOnlyOnce = property $ + let result = runGetIncremental (decoder <|> decoder) + decoder = do + 0 <- bytesRead + _ <- getWord8 -- this will make the decoder return with Partial + return "shouldn't get here" + in case result of + -- we expect Partial followed by Fail + Partial k -> case k Nothing of -- push down a Nothing + Fail _ _ _ -> True + Partial _ -> error $ "partial twice! oh noes!" + Done _ _ _ -> error $ "we're not supposed to be done." + _ -> error $ "not partial, error!" + -- read too much prop_readTooMuch :: (Eq a, Binary a) => a -> Bool prop_readTooMuch x = mustThrowError $ x == a && x /= b @@ -236,19 +260,19 @@ -- refragment a lazy bytestring's chunks refragment :: [Int] -> L.ByteString -> L.ByteString -refragment [] lps = lps -refragment (x:xs) lps = +refragment [] lbs = lbs +refragment (x:xs) lbs = let x' = fromIntegral . (+1) . abs $ x - rest = refragment xs (L.drop x' lps) in - L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest + rest = refragment xs (L.drop x' lbs) in + L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lbs]) rest -- check identity of refragmentation prop_refragment :: L.ByteString -> [Int] -> Bool -prop_refragment lps xs = lps == refragment xs lps +prop_refragment lbs xs = lbs == refragment xs lbs -- check that refragmention still hold invariant prop_refragment_inv :: L.ByteString -> [Int] -> Bool -prop_refragment_inv lps xs = invariant_lbs $ refragment xs lps +prop_refragment_inv lbs xs = invariant_lbs $ refragment xs lbs main :: IO () main = defaultMain tests @@ -283,6 +307,7 @@ [ testProperty "partial" (p prop_partial) , testProperty "fail" (p prop_fail) , testProperty "bytesRead" (p prop_bytesRead) + , testProperty "partial only once" (p prop_partialOnlyOnce) ] , testGroup "Primitives"