binary 0.5.1.1 → 0.6.0.0

raw patch · 17 files changed

+1230/−987 lines, 17 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README +19/−16
• benchmarks/Builder.hs +2/−0
• benchmarks/Get.hs +243/−0
• benchmarks/Makefile +12/−1
• benchmarks/MemBench.hs +2/−2
• binary.cabal +10/−5
• index.html +1/−1
• src/Data/Binary.hs +1/−1
• src/Data/Binary/Builder/Base.hs +3/−1
• src/Data/Binary/Get.hs +273/−394
• src/Data/Binary/Get/Internal.hs +302/−0
• tests/Makefile +6/−2
• tests/Parallel.hs +0/−147
• tests/QC.hs +327/−134
• tests/QuickCheckUtils.hs +0/−258
• tools/derive/BinaryDerive.hs +2/−2
• tools/derive/Example.hs +27/−23

@@ -35,26 +35,29 @@      *BinaryDerive> :l Example.hs  -    *Main> deriveM (undefined :: Drinks)+    *Main> deriveM (undefined :: Exp) -    instance Binary Main.Drinks where-      put (Beer a) = putWord8 0 >> put a-      put Coffee = putWord8 1-      put Tea = putWord8 2-      put EnergyDrink = putWord8 3-      put Water = putWord8 4-      put Wine = putWord8 5-      put Whisky = putWord8 6+    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 -> return (Beer a)-          1 -> return Coffee-          2 -> return Tea-          3 -> return EnergyDrink-          4 -> return Water-          5 -> return Wine-          6 -> return Whisky+          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"  Contributors: 

@@ -20,7 +20,9 @@  import Data.Binary.Builder +#if __GLASGOW_HASKELL__ < 706 instance NFData S.ByteString+#endif  data B = forall a. NFData a => B a 

@@ -0,0 +1,243 @@+{-# LANGUAGE CPP, OverloadedStrings, ExistentialQuantification, BangPatterns #-}++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#include "MachDeps.h"+#endif++module Main (main) where++import Control.DeepSeq+import Control.Exception (evaluate)+import Control.Monad.Trans (liftIO)+import Criterion.Config+import Criterion.Main hiding (run)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as L+import Data.Char (ord)+import Data.Monoid (Monoid(mappend, mempty))+import Data.Word (Word8, Word16, Word32)++import Control.Applicative+import Data.Binary.Get+import Data.Binary ( get )++#if __GLASGOW_HASKELL__ < 706+instance NFData S.ByteString+#endif++main :: IO ()+main = do+  evaluate $ rnf [+#if defined(ALTERNATIVE)+    -- rnf brackets,+#endif+    rnf oneMegabyte+    -- rnf oneMegabyteLBS]+     ]+  defaultMain+    [+#if defined(ALTERNATIVE)+      bench "brackets 100k" $ whnf (runTest bracketParser) brackets,+#endif+      bench "getStruct4 1MB struct of 4 word32 strict" $+        whnf (runTest (getStruct4Strict mega)) oneMegabyteLBS+    , bench "getStruct4 1MB struct of 4 word32" $+        whnf (runTest (getStruct4 mega)) oneMegabyteLBS+    , bench "getWord8 1MB chunk size 1 byte" $+        whnf (runTest (getWord8N1 mega)) oneMegabyteLBS+    , bench "getWord8 1MB chunk size 2 bytes" $+        whnf (runTest (getWord8N2 mega)) oneMegabyteLBS+    , bench "getWord8 1MB chunk size 4 bytes" $+        whnf (runTest (getWord8N4 mega)) oneMegabyteLBS+    , bench "getWord8 1MB chunk size 8 bytes" $+        whnf (runTest (getWord8N8 mega)) oneMegabyteLBS+    , bench "getWord8 1MB chunk size 16 bytes" $+        whnf (runTest (getWord8N16 mega)) oneMegabyteLBS+    , bench "getWord8 1MB chunk size 2 bytes Applicative" $+        whnf (runTest (getWord8N2A mega)) oneMegabyteLBS+    , bench "getWord8 1MB chunk size 4 bytes Applicative" $+        whnf (runTest (getWord8N4A mega)) oneMegabyteLBS+    , bench "getWord8 1MB chunk size 8 bytes Applicative" $+        whnf (runTest (getWord8N8A mega)) oneMegabyteLBS+    , bench "getWord8 1MB chunk size 16 bytes Applicative" $+        whnf (runTest (getWord8N16A mega)) oneMegabyteLBS+    ]++runTest parser inp = runGet parser inp++-- Defs.++oneMegabyte :: S.ByteString+oneMegabyte = S.replicate mega $ fromIntegral $ ord 'a'++oneMegabyteLBS :: L.ByteString+oneMegabyteLBS = L.fromChunks [oneMegabyte]++mega = 1024 * 1024++-- 100k of brackets+#if defined(ALTERNATIVE)+bracketTest inp = runTest bracketParser inp++brackets = L.fromChunks [C8.concat (replicate 1024 "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))")]++bracketParser = cont <|> end+  where+  end = return 0+  cont = do v <- some ( do 40 <- getWord8+                           n <- bracketParser+                           41 <- getWord8+                           return $! n + 1)+            return $! sum v+#endif++-- Struct strict++data Struct4S = Struct4S !Word32 !Word32 !Word32 !Word32++instance NFData Struct4S where+  rnf (Struct4S !a !b !c !d) = ()++getStruct4Strict = 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++instance NFData Struct4 where+  rnf (Struct4 !a !b !c !d) = ()++getStruct4 = 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)++-- No-allocation loops.++getWord8N1 = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          s0 <- getWord8+          loop (s+s0) (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)++getWord8N2A = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          v <- (+) <$> getWord8 <*> getWord8+          loop (s+v) (n-2)++getWord8N4 = 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+          s2 <- getWord8+          s3 <- getWord8+          loop (s+s0+s1+s2+s3) (n-4)++getWord8N4A = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          let p !s0 !s1 !s2 !s3 = s0 + s1 + s2 + s3+          v <- p <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8+          loop (s+v) (n-4)++getWord8N8 = 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+          s2 <- getWord8+          s3 <- getWord8+          s4 <- getWord8+          s5 <- getWord8+          s6 <- getWord8+          s7 <- getWord8+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord8N8A = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          let p !s0 !s1 !s2 !s3 !s4 !s5 !s6 !s7 =+                s0 + s1 + s2 + s3 + s4 + s5 + s6 + s7+          v <- p <$> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+          loop (s+v) (n-8)++getWord8N16 = 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+          s2 <- getWord8+          s3 <- getWord8+          s4 <- getWord8+          s5 <- getWord8+          s6 <- getWord8+          s7 <- getWord8+          s8 <- getWord8+          s9 <- getWord8+          s10 <- getWord8+          s11 <- getWord8+          s12 <- getWord8+          s13 <- getWord8+          s14 <- getWord8+          s15 <- getWord8+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s8+s9+s10+s11+s12+s13+s14+s15) (n-16)++getWord8N16A = loop 0+  where loop s n | s `seq` n `seq` False = undefined+        loop s 0 = return s+        loop s n = do+          let p !s0 !s1 !s2 !s3 !s4 !s5 !s6 !s7 !s8 !s9 !s10 !s11 !s12 !s13 !s14 !s15 =+                s0 + s1 + s2 + s3 + s4 + s5 + s6 + s7 + s8 + s9 + s10 + s11 + s12 + s13 + s14 + s15+          !v <- p <$> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+                   <*> getWord8+          loop (s+v) (n-16)

@@ -2,14 +2,25 @@ ghc-flags := programs := builder bench +SYSTEM_BINARY := binary-0.5.1.0+ .PHONY: all all: $(programs)  builder: Builder.hs 	$(ghc) $(ghc-flags) --make -O2 Builder.hs -o $@ -fforce-recomp -i../src +get: Get.hs+	$(ghc) $(ghc-flags) --make -O2 Get.hs -o $@ -fforce-recomp -i../src++system-get: Get.hs+	$(ghc) $(ghc-flags) --make -O2 Get.hs -o $@ -package $(SYSTEM_BINARY)+ bench: Benchmark.hs MemBench.hs CBenchmark.o-	$(ghc) $(ghc-flags) --make -O2 -fliberate-case-threshold=1000 -fasm Benchmark.hs CBenchmark.o -o $@ -fforce-recomp -i../src+	$(ghc) $(ghc-flags) --make -O2 -fliberate-case-threshold=1000 Benchmark.hs CBenchmark.o -o $@ -fforce-recomp -i../src++system-bench: Benchmark.hs MemBench.hs CBenchmark.o+	$(ghc) $(ghc-flags) --make -O2 -fliberate-case-threshold=1000 Benchmark.hs CBenchmark.o -o $@ -fforce-recomp -no-user-package-conf  .PHONY: run-bench run-bench: bench

@@ -53,7 +53,7 @@   where iterations = bytes `div` sizeOf (undefined :: CULong)         loop :: Int -> CULong -> IO ()         loop !i !n | i == iterations = return ()-                   | otherwise = do pokeByteOff ptr i n+                   | otherwise = do pokeElemOff ptr i n                                     loop (i+1) (n+1)  hs_wordread  :: Ptr CULong -> Int -> IO CULong@@ -61,7 +61,7 @@   where iterations = bytes `div` sizeOf (undefined :: CULong)         loop :: Int -> CULong -> IO CULong         loop !i !n | i == iterations = return n-                   | otherwise = do x <- peekByteOff ptr i+                   | otherwise = do x <- peekElemOff ptr i                                     loop (i+1) (n+x)  

@@ -1,10 +1,10 @@ name:            binary-version:         0.5.1.1+version:         0.6.0.0 license:         BSD3 license-file:    LICENSE author:          Lennart Kolmodin <kolmodin@gmail.com> maintainer:      Lennart Kolmodin, Don Stewart <dons@galois.com>-homepage:        http://code.haskell.org/binary/+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.@@ -15,10 +15,14 @@ category:        Data, Parsing stability:       provisional build-type:      Simple-cabal-version:   >= 1.2-tested-with:     GHC ==6.4.2, GHC ==6.6.1, GHC ==6.8.0, GHC ==6.10.1+cabal-version:   >= 1.6+tested-with:     GHC == 7.0.4, GHC == 7.4.1, GHC == 7.6.1 extra-source-files: README index.html +source-repository head+  type: git+  location: git://github.com/kolmodin/binary.git+ flag bytestring-in-base flag split-base flag applicative-in-base@@ -47,7 +51,8 @@   exposed-modules: Data.Binary,                    Data.Binary.Put,                    Data.Binary.Get,-                   Data.Binary.Builder+                   Data.Binary.Get.Internal,+                   Data.Binary.Builder,                    Data.Binary.Builder.Internal    other-modules:   Data.Binary.Builder.Base

@@ -32,7 +32,7 @@     <pre>    "The communication with Sphinx is done using a quite low-level binary     protocol, but Data.Binary saved the day: it made it very easy for us-    to parse all the binary things. Especially the use of the Get and+    to decode all the binary things. Especially the use of the Get and     Put monads are a big improvement over the manual reading and keeping     track of positions, as is done in the PHP/Python clients."     </pre>

@@ -100,7 +100,7 @@ -- Show classes for textual representation of Haskell types, and is -- suitable for serialising Haskell values to disk, over the network. ----- For parsing and generating simple external binary formats (e.g. C+-- For decoding and generating simple external binary formats (e.g. C -- structures), Binary may be used, but in general is not suitable -- for complex protocols. Instead use the Put and Get primitives -- directly.

@@ -68,6 +68,8 @@ import Data.Word import Foreign +import System.IO.Unsafe as IO ( unsafePerformIO )+ #ifdef BYTESTRING_IN_BASE import Data.ByteString.Base (inlinePerformIO) import qualified Data.ByteString.Base as S@@ -174,7 +176,7 @@ -- the lazy 'L.ByteString' is demanded. -- toLazyByteString :: Builder -> L.ByteString-toLazyByteString m = unsafePerformIO $ do+toLazyByteString m = IO.unsafePerformIO $ do     buf <- newBuffer defaultSize     runBuilder (m `append` flush) (const (return L.Empty)) buf {-# INLINE toLazyByteString #-}

@@ -1,9 +1,12 @@-{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}--- MagicHash, UnboxedTuples for unboxed shifts+{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#include "MachDeps.h"+#endif+ ----------------------------------------------------------------------------- -- | -- Module      : Data.Binary.Get@@ -15,37 +18,36 @@ -- Portability : portable to Hugs and GHC. -- -- The Get monad. A monad for efficiently building structures from--- encoded lazy ByteStrings+-- encoded lazy ByteStrings. -- ----------------------------------------------------------------------------- -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-#include "MachDeps.h"-#endif  module Data.Binary.Get (      -- * The Get type       Get-    , runGet-    , runGetState +    -- * The lazy input interface+    -- $lazyinterface+    , runGet +    , runGetState -- DEPRECATED++    -- * The incremental input interface+    -- $incrementalinterface+    , Decoder(..)+    , runGetIncremental++    -- ** Providing input+    , pushChunk+    , pushChunks+    , pushEndOfInput+     -- * Parsing     , skip-    , uncheckedSkip-    , lookAhead-    , lookAheadM-    , lookAheadE-    , uncheckedLookAhead--    -- * Utility-    , bytesRead-    , getBytes-    , remaining     , isEmpty--    -- * Parsing particular types-    , getWord8+    , bytesRead+    -- , lookAhead      -- ** ByteStrings     , getByteString@@ -53,447 +55,324 @@     , getLazyByteStringNul     , getRemainingLazyByteString -    -- ** Big-endian reads+    -- ** Decoding words+    , getWord8++    -- *** Big-endian decoding     , getWord16be     , getWord32be     , getWord64be -    -- ** Little-endian reads+    -- *** Little-endian decoding     , getWord16le     , getWord32le     , getWord64le -    -- ** Host-endian, unaligned reads+    -- *** Host-endian, unaligned decoding     , getWordhost     , getWord16host     , getWord32host     , getWord64host -  ) where--import Control.Monad (when,liftM,ap)-import Control.Monad.Fix-import Data.Maybe (isNothing)+    -- * Deprecated functions+    , remaining -- DEPRECATED+    , getBytes -- DEPRECATED+    ) where +import Foreign import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as L -#ifdef BYTESTRING_IN_BASE-import qualified Data.ByteString.Base as B-#else-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Lazy.Internal as L-#endif--#ifdef APPLICATIVE_IN_BASE-import Control.Applicative (Applicative(..))-#endif--import Foreign+import Control.Applicative --- used by splitAtST-import Control.Monad.ST-import Data.STRef+import Data.Binary.Get.Internal hiding ( Decoder(..), runGetIncremental )+import qualified Data.Binary.Get.Internal as I  #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+-- needed for (# unboxing #) with magic hash import GHC.Base import GHC.Word-import GHC.Int #endif --- | The parse state-data S = S {-# UNPACK #-} !B.ByteString  -- current chunk-           L.ByteString                  -- the rest of the input-           {-# UNPACK #-} !Int64         -- bytes read+-- $lazyinterface+-- The lazy interface consumes a single lazy bytestring.+-- It's the easiest interface to get started with, but it has limitations.+-- If the decoder runs into an error, it will throw an exception using 'error'.+-- It will also throw an error if the decoder runs out of input.+-- +-- 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. --- | The Get monad is just a State monad carrying around the input ByteString--- We treat it as a strict state monad. -newtype Get a = Get { unGet :: S -> (# a, S #) }+-- $incrementalinterface+-- The incremental interface consumes a strict 'B.ByteString' at a time, each+-- being part of the total amount of input. If your decoder needs more input to+-- finish it will return a 'Partial' with a continuation.+-- If there is no more input, provide it 'Nothing'. -instance Functor Get where-    fmap f m = Get (\s -> case unGet m s of-                             (# a, s' #) -> (# f a, s' #))-    {-# INLINE fmap #-}+-- 'Fail' will be returned if it runs into an error, together with a message,+-- the position and the remaining input.+-- If it succeeds it will return 'Done' with the resulting value,+-- the position and the remaining input. -#ifdef APPLICATIVE_IN_BASE-instance Applicative Get where-    pure  = return-    (<*>) = ap-#endif+-- | A decoder procuced by running a 'Get' monad.+data Decoder a = Fail !B.ByteString {-# UNPACK #-} !Int64 String+              -- ^ The decoder ran into an error. The decoder either used+              -- 'fail' or was not provided enough input.+              | Partial (Maybe B.ByteString -> Decoder a)+              -- ^ The decoder has consumed the available input and needs+              -- more to continue. Provide 'Just' if more input is available+              -- and 'Nothing' otherwise, and you will get a new 'Decoder'.+              | Done !B.ByteString {-# UNPACK #-} !Int64 a+              -- ^ The decoder has successfully finished. Except for the+              -- output value you also get the unused input as well as the+              -- count of used bytes. --- Definition directly from Control.Monad.State.Strict-instance Monad Get where-    return a  = Get $ \s -> (# a, s #)-    {-# INLINE return #-}+-- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing+-- input, handling decoder errors and to get the output value.+-- Hint: Use the helper functions 'pushChunk', 'pushChunks' and+-- 'pushEndOfInput'.+runGetIncremental :: Get a -> Decoder a+runGetIncremental = calculateOffset . I.runGetIncremental -    m >>= k   = Get $ \s -> case unGet m s of-                             (# a, s' #) -> unGet (k a) s'-    {-# INLINE (>>=) #-}+calculateOffset :: I.Decoder a -> Decoder a+calculateOffset r0 = go r0 0+  where+  go r !acc = case r of+                I.Done inp a -> Done inp (acc - fromIntegral (B.length inp)) a+                I.Fail inp s -> Fail inp (acc - fromIntegral (B.length inp)) s+                I.Partial k ->+                    Partial $ \ms ->+                      case ms of+                        Nothing -> go (k Nothing) acc+                        Just i -> go (k ms) (acc + fromIntegral (B.length i))+                I.BytesRead unused k ->+                    go (k (acc - unused)) acc  -    fail      = failDesc+-- | DEPRECATED. Provides compatibility with previous versions of this library.+-- Run a 'Get' monad and return a tuple with thee 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 runGetPartial instead. This function will be removed." #-}+runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64)+runGetState g lbs0 pos' = go (runGetIncremental g) (L.toChunks 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 (Fail _ pos msg) _ =+    error ("Data.Binary.Get.runGetState at position " ++ show pos ++ ": " ++ msg) -instance MonadFix Get where-    mfix f = Get $ \s -> let (a,s') = case unGet (f a) s of-                                              (# a', s'' #) -> (a',s'')-                        in (# a,s' #) -------------------------------------------------------------------------+-- | The simplest interface to run a 'Get' decoder. If the decoder runs into+-- an error, calling 'fail' or running out of input, it will call 'error'.+runGet :: Get a -> L.ByteString -> a+runGet g bs = feedAll (runGetIncremental g) chunks+  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 (Fail _ pos msg) _ =+    error ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) -get :: Get S-get   = Get $ \s -> (# s, s #) -put :: S -> Get ()-put s = Get $ \_ -> (# (), s #)-------------------------------------------------------------------------------- dons, GHC 6.10: explicit inlining disabled, was killing performance.--- Without it, GHC seems to do just fine. And we get similar--- performance with 6.8.2 anyway.+-- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it+-- will add the input to 'B.ByteString' of unconsumed input. --+-- @+--    'runGetPartial' myParser \`pushChunk\` myInput1 \`pushChunk\` myInput2+-- @+pushChunk :: Decoder a -> B.ByteString -> Decoder a+pushChunk r inp =+  case r of+    Done inp0 p a -> Done (inp0 `B.append` inp) p a+    Partial k -> k (Just inp)+    Fail inp0 p s -> Fail (inp0 `B.append` inp) p s -initState :: L.ByteString -> S-initState xs = mkState xs 0-{- INLINE initState -} -{--initState (B.LPS xs) =-    case xs of-      []      -> S B.empty L.empty 0-      (x:xs') -> S x (B.LPS xs') 0--}--#ifndef BYTESTRING_IN_BASE-mkState :: L.ByteString -> Int64 -> S-mkState l = case l of-    L.Empty      -> S B.empty L.empty-    L.Chunk x xs -> S x xs-{- INLINE mkState -}--#else-mkState :: L.ByteString -> Int64 -> S-mkState (B.LPS xs) =-    case xs of-        [] -> S B.empty L.empty-        (x:xs') -> S x (B.LPS xs')-#endif---- | Run the Get monad applies a 'get'-based parser on the input ByteString-runGet :: Get a -> L.ByteString -> a-runGet m str = case unGet m (initState str) of (# a, _ #) -> a---- | 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 -> L.ByteString -> Int64 -> (a, L.ByteString, Int64)-runGetState m str off =-    case unGet m (mkState str off) of-      (# a, ~(S s ss newOff) #) -> (a, s `join` ss, newOff)----------------------------------------------------------------------------failDesc :: String -> Get a-failDesc err = do-    S _ _ bytes <- get-    Get (error (err ++ ". Failed reading at byte position " ++ show bytes))---- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available.-skip :: Int -> Get ()-skip n = readN (fromIntegral n) (const ())---- | Skip ahead @n@ bytes. No error if there isn't enough bytes.-uncheckedSkip :: Int64 -> Get ()-uncheckedSkip n = do-    S s ss bytes <- get-    if fromIntegral (B.length s) >= n-      then put (S (B.drop (fromIntegral n) s) ss (bytes + n))-      else do-        let rest = L.drop (n - fromIntegral (B.length s)) ss-        put $! mkState rest (bytes + n)---- | Run @ga@, but return without consuming its input.--- Fails if @ga@ fails.-lookAhead :: Get a -> Get a-lookAhead ga = do-    s <- get-    a <- ga-    put s-    return a---- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'.--- Fails if @gma@ fails.-lookAheadM :: Get (Maybe a) -> Get (Maybe a)-lookAheadM gma = do-    s <- get-    ma <- gma-    when (isNothing ma) $-        put s-    return ma---- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'.--- Fails if @gea@ fails.-lookAheadE :: Get (Either a b) -> Get (Either a b)-lookAheadE gea = do-    s <- get-    ea <- gea-    case ea of-        Left _ -> put s-        _      -> return ()-    return ea---- | Get the next up to @n@ bytes as a lazy ByteString, without consuming them. -uncheckedLookAhead :: Int64 -> Get L.ByteString-uncheckedLookAhead n = do-    S s ss _ <- get-    if n <= fromIntegral (B.length s)-        then return (L.fromChunks [B.take (fromIntegral n) s])-        else return $ L.take n (s `join` ss)----------------------------------------------------------------------------- Utility---- | Get the total number of bytes read to this point.-bytesRead :: Get Int64-bytesRead = do-    S _ _ b <- get-    return b---- | Get the number of remaining unparsed bytes.--- Useful for checking whether all input has been consumed.--- Note that this forces the rest of the input.-remaining :: Get Int64-remaining = do-    S s ss _ <- get-    return (fromIntegral (B.length s) + L.length ss)---- | Test whether all input has been consumed,--- i.e. there are no remaining unparsed bytes.-isEmpty :: Get Bool-isEmpty = do-    S s ss _ <- get-    return (B.null s && L.null ss)----------------------------------------------------------------------------- Utility with ByteStrings---- | An efficient 'get' method for strict ByteStrings. Fails if fewer--- than @n@ bytes are left in the input.-getByteString :: Int -> Get B.ByteString-getByteString n = readN n id-{-# INLINE getByteString #-}+-- | 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+-- @+pushChunks :: Decoder a -> L.ByteString -> Decoder a+pushChunks r0 = go r0 . L.toChunks+  where+  go r [] = r+  go r (x:xs) = go (pushChunk r x) xs --- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than--- @n@ bytes are left in the input.+-- | Tell a 'Decoder' that there is no more input. This passes 'Nothing' to a+-- 'Partial' decoder, otherwise returns the decoder unchanged.+pushEndOfInput :: Decoder a -> Decoder a+pushEndOfInput r =+  case r of+    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-getLazyByteString n = do-    S s ss bytes <- get-    let big = s `join` ss-    case splitAtST n big of-      (consume, rest) -> do put $ mkState rest (bytes + n)-                            return consume-{-# INLINE getLazyByteString #-}+getLazyByteString n0 = L.fromChunks <$> go n0+  where+  consume n str+    | fromIntegral (B.length str) >= n = Right (B.splitAt (fromIntegral n) str)+    | otherwise = Left (fromIntegral (B.length str))+  go n = do+    str <- get+    case consume n str of+      Left used -> do+        put B.empty+        demandInput+        fmap (str:) (go (n - used))+      Right (want,rest) -> do+        put rest+        return [want] --- | Get a lazy ByteString that is terminated with a NUL byte. Fails--- if it reaches the end of input without hitting a NUL.+-- | Get a lazy ByteString that is terminated with a NUL byte.+-- The returned string does not contain the NUL byte. Fails+-- if it reaches the end of input without finding a NUL. getLazyByteStringNul :: Get L.ByteString-getLazyByteStringNul = do-    S s ss bytes <- get-    let big = s `join` ss-        (consume, t) = L.break (== 0) big-        (h, rest) = L.splitAt 1 t-    if L.null h-      then fail "too few bytes"-      else do-        put $ mkState rest (bytes + L.length consume + 1)-        return consume-{-# INLINE getLazyByteStringNul #-}---- | Get the remaining bytes as a lazy ByteString+getLazyByteStringNul = L.fromChunks <$> go+  where+  findNull str =+    case B.break (==0) str of+      (want,rest) | B.null rest -> Nothing+                  | otherwise -> Just (want, B.drop 1 rest)+  go = do+    str <- get+    case findNull str of+      Nothing -> do+        put B.empty+        demandInput+        fmap (str:) go+      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. getRemainingLazyByteString :: Get L.ByteString-getRemainingLazyByteString = do-    S s ss _ <- get-    return (s `join` ss)----------------------------------------------------------------------------- Helpers---- | Pull @n@ bytes from the input, as a strict ByteString.-getBytes :: Int -> Get B.ByteString-getBytes n = do-    S s ss bytes <- 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-{- INLINE getBytes -}--- ^ important--#ifndef BYTESTRING_IN_BASE-join :: B.ByteString -> L.ByteString -> L.ByteString-join bb lb-    | B.null bb = lb-    | otherwise = L.Chunk bb lb--#else-join :: B.ByteString -> L.ByteString -> L.ByteString-join bb (B.LPS lb)-    | B.null bb = B.LPS lb-    | otherwise = B.LPS (bb:lb)-#endif-    -- don't use L.append, it's strict in it's second argument :/-{- INLINE join -}---- | Split a ByteString. If the first result is consumed before the ----- second, this runs in constant heap space.------ You must force the returned tuple for that to work, e.g.--- --- > case splitAtST n xs of--- >    (ys,zs) -> consume ys ... consume zs----splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString)-splitAtST i ps | i <= 0 = (L.empty, ps)-#ifndef BYTESTRING_IN_BASE-splitAtST i ps          = runST (-     do r  <- newSTRef undefined-        xs <- first r i ps-        ys <- unsafeInterleaveST (readSTRef r)-        return (xs, ys))-+getRemainingLazyByteString = L.fromChunks <$> go   where-    first :: STRef s L.ByteString -> Int64 -> L.ByteString -> ST s L.ByteString-    first r 0 xs@(L.Chunk _ _) = writeSTRef r xs    >> return L.Empty-    first r _ L.Empty          = writeSTRef r L.Empty >> return L.Empty--    first r n (L.Chunk x xs)-      | n < l     = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs)-                       return $ L.Chunk (B.take (fromIntegral n) x) L.Empty-      | otherwise = do writeSTRef r (L.drop (n - l) xs)-                       liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs)-      where -        l = fromIntegral (B.length x)-#else-splitAtST i (B.LPS ps)  = runST (-     do r  <- newSTRef undefined-        xs <- first r i ps-        ys <- unsafeInterleaveST (readSTRef r)-        return (B.LPS xs, B.LPS ys))--  where first r 0 xs     = writeSTRef r xs >> return []-        first r _ []     = writeSTRef r [] >> return []-        first r n (x:xs)-          | n < l     = do writeSTRef r (B.drop (fromIntegral n) x : xs)-                           return [B.take (fromIntegral n) x]-          | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs)))-                           fmap (x:) $ unsafeInterleaveST (first r (n - l) xs)--         where l = fromIntegral (B.length x)-#endif-{- INLINE splitAtST -}---- Pull n bytes from the input, and apply a parser to those bytes,--- yielding a value. If less than @n@ bytes are available, fail with an--- error. This wraps @getBytes@.-readN :: Int -> (B.ByteString -> a) -> Get a-readN n f = fmap f $ getBytes n-{- INLINE readN -}--- ^ important+  go = do+    str <- get+    put B.empty+    done <- isEmpty+    if done+      then return [str]+      else fmap (str:) go  ------------------------------------------------------------------------ -- Primtives  -- helper, get a raw Ptr onto a strict ByteString copied out of the--- underlying lazy byteString. So many indirections from the raw parser--- state that my head hurts...+-- underlying lazy byteString.  getPtr :: Storable a => Int -> Get a-getPtr n = do-    (fp,o,_) <- readN n B.toForeignPtr-    return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)-{- INLINE getPtr -}--------------------------------------------------------------------------+getPtr n = readNWith n peek+{-# INLINE getPtr #-}  -- | Read a Word8 from the monad state getWord8 :: Get Word8-getWord8 = getPtr (sizeOf (undefined :: Word8))-{- INLINE getWord8 -}+getWord8 = readN 1 B.unsafeHead+{-# INLINE getWord8 #-} +-- force GHC to inline getWordXX+{-# RULES+"getWord8/readN" getWord8 = readN 1 B.unsafeHead+"getWord16be/readN" getWord16be = readN 2 word16be+"getWord16le/readN" getWord16le = readN 2 word16le+"getWord32be/readN" getWord32be = readN 4 word32be+"getWord32le/readN" getWord32le = readN 4 word32le+"getWord64be/readN" getWord64be = readN 8 word64be+"getWord64le/readN" getWord64le = readN 8 word64le+ #-}+ -- | Read a Word16 in big endian format getWord16be :: Get Word16-getWord16be = do-    s <- readN 2 id-    return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|.-              (fromIntegral (s `B.index` 1))-{- INLINE getWord16be -}+getWord16be = readN 2 word16be +word16be :: B.ByteString -> Word16+word16be = \s ->+        (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|.+        (fromIntegral (s `B.unsafeIndex` 1))+{-# INLINE getWord16be #-}+{-# INLINE word16be #-}+ -- | Read a Word16 in little endian format getWord16le :: Get Word16-getWord16le = do-    s <- readN 2 id-    return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|.-              (fromIntegral (s `B.index` 0) )-{- INLINE getWord16le -}+getWord16le = readN 2 word16le +word16le :: B.ByteString -> Word16+word16le = \s ->+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )+{-# INLINE getWord16le #-}+{-# INLINE word16le #-}+ -- | Read a Word32 in big endian format getWord32be :: Get Word32-getWord32be = do-    s <- readN 4 id-    return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|.-              (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|.-              (fromIntegral (s `B.index` 2) `shiftl_w32`  8) .|.-              (fromIntegral (s `B.index` 3) )-{- INLINE getWord32be -}+getWord32be = readN 4 word32be +word32be :: B.ByteString -> Word32+word32be = \s ->+              (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 3) )+{-# INLINE getWord32be #-}+{-# INLINE word32be #-}+ -- | Read a Word32 in little endian format getWord32le :: Get Word32-getWord32le = do-    s <- readN 4 id-    return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|.-              (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|.-              (fromIntegral (s `B.index` 1) `shiftl_w32`  8) .|.-              (fromIntegral (s `B.index` 0) )-{- INLINE getWord32le -}+getWord32le = readN 4 word32le +word32le :: B.ByteString -> Word32+word32le = \s ->+              (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )+{-# INLINE getWord32le #-}+{-# INLINE word32le #-}+ -- | Read a Word64 in big endian format getWord64be :: Get Word64-getWord64be = do-    s <- readN 8 id-    return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|.-              (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|.-              (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|.-              (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|.-              (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|.-              (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|.-              (fromIntegral (s `B.index` 6) `shiftl_w64`  8) .|.-              (fromIntegral (s `B.index` 7) )-{- INLINE getWord64be -}+getWord64be = readN 8 word64be +word64be :: B.ByteString -> Word64+word64be = \s ->+              (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|.+              (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|.+              (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 7) )+{-# INLINE getWord64be #-}+{-# INLINE word64be #-}+ -- | Read a Word64 in little endian format getWord64le :: Get Word64-getWord64le = do-    s <- readN 8 id-    return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|.-              (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|.-              (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|.-              (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|.-              (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|.-              (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|.-              (fromIntegral (s `B.index` 1) `shiftl_w64`  8) .|.-              (fromIntegral (s `B.index` 0) )-{- INLINE getWord64le -}+getWord64le = readN 8 word64le +word64le :: B.ByteString -> Word64+word64le = \s ->+              (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|.+              (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|.+              (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|.+              (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|.+              (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )+{-# INLINE getWord64le #-}+{-# INLINE word64le #-}+ ------------------------------------------------------------------------ -- Host-endian reads @@ -502,22 +381,22 @@ -- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. getWordhost :: Get Word getWordhost = getPtr (sizeOf (undefined :: Word))-{- INLINE getWordhost -}+{-# INLINE getWordhost #-}  -- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. getWord16host :: Get Word16 getWord16host = getPtr (sizeOf (undefined :: Word16))-{- INLINE getWord16host -}+{-# INLINE getWord16host #-}  -- | /O(1)./ Read a Word32 in native host order and host endianness. getWord32host :: Get Word32 getWord32host = getPtr  (sizeOf (undefined :: Word32))-{- INLINE getWord32host -}+{-# INLINE getWord32host #-}  -- | /O(1)./ Read a Word64 in native host order and host endianess. getWord64host   :: Get Word64 getWord64host = getPtr  (sizeOf (undefined :: Word64))-{- INLINE getWord64host -}+{-# INLINE getWord64host #-}  ------------------------------------------------------------------------ -- Unchecked shifts

@@ -0,0 +1,302 @@+{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-}++-- CPP C style pre-precessing, the #if defined lines+-- RankNTypes forall r. statement+-- MagicHash the (# unboxing #), also needs GHC.primitives++module Data.Binary.Get.Internal (++    -- * The Get type+      Get+    , runCont+    , Decoder(..)+    , runGetIncremental++    , readN+    , readNWith++    -- * Parsing+    , skip+    , bytesRead+    +    , get+    , put+    , demandInput+    , ensureN++    -- * Utility+    , remaining+    , getBytes+    , isEmpty++    -- ** ByteStrings+    , getByteString++    ) where++import Foreign+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Unsafe as B++import Control.Applicative++#if defined(__GLASGOW_HASKELL__) && !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+-- "Maybe ByteString" and implemented it in this way.+-- The reasoning was that you could accidently provide an empty bytestring,+-- and it should not terminate the decoding (empty would mean eof).+-- However, I'd say that it's also a risk that you get stuck in a loop,+-- where you keep providing an empty string. Anyway, no new input should be+-- rare, as the RTS should only wake you up if you actually have some data+-- to read from your fd.++-- | A decoder procuced by running a 'Get' monad.+data Decoder a = Fail !B.ByteString String+              -- ^ The decoder ran into an error. The decoder either used+              -- 'fail' or was not provided enough input.+              | Partial (Maybe B.ByteString -> Decoder a)+              -- ^ The decoder has consumed the available input and needs+              -- more to continue. Provide 'Just' if more input is available+              -- and 'Nothing' otherwise, and you will get a new 'Decoder'.+              | Done !B.ByteString a+              -- ^ The decoder has successfully finished. Except for the+              -- output value you also get the unused input.+              | BytesRead {-# UNPACK #-} !Int64 (Int64 -> Decoder a)+              -- ^ The decoder needs to know the current position in the input.+              -- Given the number of bytes remaning in the decoder, the outer+              -- decoder runner needs to calculate the position and+              -- resume the decoding.++-- unrolled codensity/state monad+newtype Get a = C { runCont :: forall r.+                               B.ByteString ->+                               Success a r ->+                               Decoder    r }++type Success a r = B.ByteString -> a -> Decoder r++instance Monad Get where+  return = returnG+  (>>=) = bindG+  fail = failG++returnG :: a -> Get a+returnG a = C $ \s ks -> ks s a+{-# INLINE [0] returnG #-}++bindG :: Get a -> (a -> Get b) -> Get b+bindG (C c) f = C $ \i ks -> c i (\i' a -> (runCont (f a)) i' ks)+{-# INLINE bindG #-}++failG :: String -> Get a+failG str = C $ \i _ks -> Fail i str++apG :: Get (a -> b) -> Get a -> Get b+apG d e = do+  b <- d+  a <- e+  return (b a)+{-# INLINE [0] apG #-}++fmapG :: (a -> b) -> Get a -> Get b+fmapG f m = C $ \i ks -> runCont m i (\i' a -> ks i' (f a))+{-# INLINE fmapG #-}++instance Applicative Get where+  pure = returnG+  {-# INLINE pure #-}+  (<*>) = apG+  {-# INLINE (<*>) #-}++instance Functor Get where+  fmap = fmapG++instance Functor Decoder where+  fmap f (Done s a) = Done s (f a)+  fmap f (Partial k) = Partial (fmap f . k)+  fmap _ (Fail s msg) = Fail s msg+  fmap f (BytesRead b k) = BytesRead b (fmap f . k)++instance (Show a) => Show (Decoder a) where+  show (Fail _ msg) = "Fail: " ++ msg+  show (Partial _) = "Partial _"+  show (Done _ a) = "Done: " ++ show a+  show (BytesRead _ _) = "BytesRead"++-- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing+-- input, handling decoding errors and to get the output value.+runGetIncremental :: Get a -> Decoder a+runGetIncremental g = noMeansNo $+  runCont g B.empty (\i a -> Done i a)++-- | Make sure we don't have to pass Nothing to a Partial twice.+-- This way we don't need to pass around an EOF value in the Get monad, it+-- can safely ask several times if it needs to.+noMeansNo :: Decoder a -> Decoder a+noMeansNo r0 = go r0+  where+  go r =+    case r of+      Partial k -> Partial $ \ms ->+                    case ms of+                      Just _ -> go (k ms)+                      Nothing -> neverAgain (k ms)+      _ -> r+  neverAgain r =+    case r of+      Partial k -> neverAgain (k Nothing)+      _ -> r++prompt :: B.ByteString -> Decoder a -> (B.ByteString -> Decoder a) -> Decoder a+prompt inp kf ks =+    let loop =+         Partial $ \sm ->+           case sm of+             Just s | B.null s -> loop+                    | otherwise -> ks (inp `B.append` s)+             Nothing -> kf+    in loop++-- | Get the total number of bytes read to this point.+bytesRead :: Get Int64+bytesRead = C $ \inp k -> BytesRead (fromIntegral $ B.length inp) (k inp)++-- | Demand more input. If none available, fail.+demandInput :: Get ()+demandInput = C $ \inp ks ->+  prompt inp (Fail inp "demandInput: not enough bytes") (\inp' -> ks inp' ())++-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available.+skip :: Int -> Get ()+skip n = readN n (const ())+{-# INLINE skip #-}++-- | Test whether all input has been consumed, i.e. there are no remaining+-- undecoded bytes.+isEmpty :: Get Bool+isEmpty = C $ \inp ks ->+    if B.null inp+      then prompt inp (ks inp True) (\inp' -> ks inp' False)+      else ks inp False++-- | DEPRECATED. Same as 'getByteString'.+{-# DEPRECATED getBytes "Use 'getByteString' instead of 'getBytes'." #-}+getBytes :: Int -> Get B.ByteString+getBytes = getByteString+{-# INLINE getBytes #-}++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++-- | Try to execute a Get. If it fails, the consumed input will be restored.+try :: Get a -> Get a+try g = C $ \inp ks ->+  let r0 = runGetIncremental g `feed` inp+      go !acc r = case r of+                    Done inp' a -> ks inp' a+                    Partial k -> Partial $ \minp -> go (maybe acc (:acc) minp) (k minp)+                    Fail _ s -> Fail (B.concat (inp : reverse acc)) s+                    BytesRead unused k -> BytesRead unused (go acc . k)+  in go [] r0+  where+  feed r inp =+    case r of+      Done inp0 a -> Done (inp0 `B.append` inp) a+      Partial k -> k (Just inp)+      Fail inp0 s -> Fail (inp0 `B.append` inp) s+      BytesRead unused k -> BytesRead unused (\i -> k i `feed` inp)++-- | 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.+-- The decoder keeps the input as a strict bytestring, so you are likely better+-- off by calculating the remaining input in another way.+{-# DEPRECATED remaining "This will force all remaining input, don't use it." #-}+remaining :: Get Int64+remaining = C $ \ inp ks ->+  let loop acc = Partial $ \ minp ->+                  case minp of+                    Nothing -> let all_inp = B.concat (inp : (reverse acc))+                               in ks all_inp (fromIntegral $ B.length all_inp)+                    Just inp' -> loop (inp':acc)+  in loop []++------------------------------------------------------------------------+-- ByteStrings+--++-- | An efficient get method for strict ByteStrings. Fails if fewer than @n@+-- bytes are left in the input. If @n <= 0@ then the empty string is returned.+getByteString :: Int -> Get B.ByteString+getByteString n | n > 0 = readN n (B.unsafeTake n)+                | otherwise = return B.empty+{-# INLINE getByteString #-}++-- | Get the current chunk.+get :: Get B.ByteString+get = C $ \inp ks -> ks inp inp++-- | Replace the current chunk.+put :: B.ByteString -> Get ()+put s = C $ \_inp ks -> ks s ()++-- | Return at least @n@ bytes, maybe more. If not enough data is available+-- the computation will escape with 'Partial'.+readN :: Int -> (B.ByteString -> a) -> Get a+readN !n f = ensureN n >> unsafeReadN n f+{-# INLINE [0] readN #-}++{-# RULES++"<$> to <*>" forall f g.+  (<$>) f g = returnG f <*> g++"readN/readN merge" forall n m f g.+  apG (readN n f) (readN m g) = readN (n+m) (\bs -> f bs $ g (B.unsafeDrop n bs))++"returnG/readN swap" [~1] forall f.+  returnG f = readN 0 (const f)++"readN 0/returnG swapback" [1] forall f.+  readN 0 f = returnG (f B.empty)+ #-}++-- | Ensure that there are at least @n@ bytes available. If not, the+-- computation will escape with 'Partial'.+ensureN :: Int -> Get ()+ensureN !n0 = C $ \inp ks -> do+  if B.length inp >= n0+    then ks inp ()+    else runCont (go n0) inp ks+  where -- might look a bit funny, but plays very well with GHC's inliner.+        -- GHC won't inline recursive functions, so we make ensureN non-recursive+    go n = C $ \inp ks -> do+      if B.length inp >= n+        then ks inp ()+        else runCont (demandInput >> go n) inp ks+{-# INLINE ensureN #-}++unsafeReadN :: Int -> (B.ByteString -> a) -> Get a+unsafeReadN !n f = C $ \inp ks -> do+  ks (B.unsafeDrop n inp) $! f inp -- strict return++readNWith :: Int -> (Ptr a -> IO a) -> Get a+readNWith n f = do+    readN n $ \s -> B.inlinePerformIO $ B.unsafeUseAsCString s (f . castPtr)+{-# INLINE readNWith #-}

@@ -1,11 +1,15 @@+ghc := ghc+ghc-flags := + all: compiled  interpreted: 	runhaskell QC.hs 1000  compiled:-	ghc --make -fhpc -O QC.hs -o qc -threaded -package QuickCheck-1.2.0.1 -i../src-	./qc 500+	$(ghc) --make -fhpc -O QC.hs -o qc -fforce-recomp -threaded -rtsopts -i../src -XCPP -package test-framework -package test-framework-quickcheck2 $(ghc-flags)+	rm -f qc.tix+	./qc --maximum-generated-tests=1000 -j2 +RTS -N2  hugs: 	runhugs -98 QC.hs  

@@ -1,147 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Test.QuickCheck.Parallel--- Copyright   :  (c) Don Stewart 2006--- License     :  BSD-style (see the file LICENSE)--- --- Maintainer  :  dons@cse.unsw.edu.au--- Stability   :  experimental--- Portability :  non-portable (uses Control.Exception, Control.Concurrent)------ A parallel batch driver for running QuickCheck on threaded or SMP systems.--- See the /Example.hs/ file for a complete overview.-----module Parallel (-    pRun,-    pDet,-    pNon-  ) where--import Test.QuickCheck-import Data.List-import Control.Concurrent-import Control.Exception  hiding (evaluate)-import System.Random-import System.IO          (hFlush,stdout)-import Text.Printf--type Name   = String-type Depth  = Int-type Test   = (Name, Depth -> IO String)---- | Run a list of QuickCheck properties in parallel chunks, using--- 'n' Haskell threads (first argument), and test to a depth of 'd'--- (second argument). Compile your application with '-threaded' and run--- with the SMP runtime's '-N4' (or however many OS threads you want to--- donate), for best results.------ > import Test.QuickCheck.Parallel--- >--- > do n <- getArgs >>= readIO . head--- >    pRun n 1000 [ ("sort1", pDet prop_sort1) ]------ Will run 'n' threads over the property list, to depth 1000.----pRun :: Int -> Int -> [Test] -> IO ()-pRun n depth tests = do-    chan <- newChan-    ps   <- getChanContents chan-    work <- newMVar tests--    forM_ [1..n] $ forkIO . thread work chan--    let wait xs i-            | i >= n     = return () -- done-            | otherwise = case xs of-                    Nothing : xs -> wait xs $! i+1-                    Just s  : xs -> putStr s >> hFlush stdout >> wait xs i-    wait ps 0--  where-    thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO ()-    thread work chan me = loop-      where-        loop = do-            job <- modifyMVar work $ \jobs -> return $ case jobs of-                        []     -> ([], Nothing)-                        (j:js) -> (js, Just j)-            case job of-                Nothing          -> writeChan chan Nothing -- done-                Just (name,prop) -> do-                    v <- prop depth-                    writeChan chan . Just $ printf "%d: %-25s: %s" me name v-                    loop----- | Wrap a property, and run it on a deterministic set of data-pDet :: Testable a => a -> Int -> IO String-pDet a n = mycheck Det defaultConfig-    { configMaxTest = n-    , configEvery   = \n args -> unlines args } a---- | Wrap a property, and run it on a non-deterministic set of data-pNon :: Testable a => a -> Int -> IO String-pNon a n = mycheck NonDet defaultConfig-    { configMaxTest = n-    , configEvery   = \n args -> unlines args } a--data Mode = Det | NonDet----------------------------------------------------------------------------mycheck :: Testable a => Mode -> Config -> a -> IO String-mycheck Det config a = do-     let rnd = mkStdGen 99  -- deterministic-     mytests config (evaluate a) rnd 0 0 []--mycheck NonDet config a = do-    rnd <- newStdGen        -- different each run-    mytests config (evaluate a) rnd 0 0 []--mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String-mytests config gen rnd0 ntest nfail stamps-  | ntest == configMaxTest config = do done "OK," ntest stamps-  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps-  | otherwise = do-         case ok result of-           Nothing    ->-             mytests config gen rnd1 ntest (nfail+1) stamps-           Just True  ->-             mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)-           Just False ->-             return ( "Falsifiable after "-                   ++ show ntest-                   ++ " tests:\n"-                   ++ unlines (arguments result)-                    )-     where-      result      = generate (configSize config ntest) rnd2 gen-      (rnd1,rnd2) = split rnd0--done :: String -> Int -> [[String]] -> IO String-done mesg ntest stamps =-    return ( mesg ++ " " ++ show ntest ++ " tests" ++ table )-  where-    table = display-        . map entry-        . reverse-        . sort-        . map pairLength-        . group-        . sort-        . filter (not . null)-        $ stamps--    display []  = ".\n"-    display [x] = " (" ++ x ++ ").\n"-    display xs  = ".\n" ++ unlines (map (++ ".") xs)--    pairLength xss@(xs:_) = (length xss, xs)-    entry (n, xs)         = percentage n ntest-                          ++ " "-                          ++ concat (intersperse ", " xs)--    percentage n m        = show ((100 * n) `div` m) ++ "%"--forM_ = flip mapM_

@@ -1,38 +1,42 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE ScopedTypeVariables #-} module Main where  import Data.Binary import Data.Binary.Put import Data.Binary.Get -import Parallel+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.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 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.Array (Array)+-- import Data.Array.IArray+-- import Data.Array.Unboxed (UArray) -import qualified Control.OldException as C (catch,evaluate)-import Control.Monad-import Foreign-import System.Environment-import System.IO+-- 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 -import Test.QuickCheck hiding (test)-import QuickCheckUtils-import Text.Printf+import Test.QuickCheck+-- import Text.Printf --- import qualified Data.Sequence as Seq+import Test.Framework+import Test.Framework.Providers.QuickCheck2+-- import Data.Monoid  ------------------------------------------------------------------------ @@ -40,39 +44,187 @@ roundTrip a f = a ==     {-# SCC "decode.refragment.encode" #-} decode (f (encode a)) -roundTripWith put get x =+roundTripWith ::  Eq a => (a -> Put) -> Get a -> a -> Property+roundTripWith putter getter x =     forAll positiveList $ \xs ->-    x == runGet get (refragment xs (runPut (put x)))+    x == runGet getter (refragment xs (runPut (putter x)))  -- make sure that a test fails-errorish :: B a-errorish a = unsafePerformIO $-    C.catch (do C.evaluate a+mustThrowError :: B a+mustThrowError a = unsafePerformIO $+    C.catch (do _ <- C.evaluate a                 return False)-            (\_ -> return True)+            (\(_e :: SomeException) -> return True)  -- low level ones: +prop_Word16be :: Word16 -> Property prop_Word16be = roundTripWith putWord16be getWord16be++prop_Word16le :: Word16 -> Property prop_Word16le = roundTripWith putWord16le getWord16le++prop_Word16host :: Word16 -> Property prop_Word16host = roundTripWith putWord16host getWord16host +prop_Word32be :: Word32 -> Property prop_Word32be = roundTripWith putWord32be getWord32be++prop_Word32le :: Word32 -> Property prop_Word32le = roundTripWith putWord32le getWord32le++prop_Word32host :: Word32 -> Property prop_Word32host = roundTripWith putWord32host getWord32host +prop_Word64be :: Word64 -> Property prop_Word64be = roundTripWith putWord64be getWord64be++prop_Word64le :: Word64 -> Property prop_Word64le = roundTripWith putWord64le getWord64le++prop_Word64host :: Word64 -> Property prop_Word64host = roundTripWith putWord64host getWord64host +prop_Wordhost :: Word -> Property prop_Wordhost = roundTripWith putWordhost getWordhost --- read too much: -prop_bookworm x = errorish $ x == a && x /= b+-- done, partial and fail++-- | Test partial results.+-- May or may not use the whole input, check conditions for the different+-- outcomes.+prop_partial :: L.ByteString -> Property+prop_partial lbs = forAll (choose (0, L.length lbs * 2)) $ \skipN ->+  let result = pushChunks (runGetIncremental decoder) lbs+      decoder = do+        s <- getByteString (fromIntegral skipN)+        return (L.fromChunks [s])+  in case result of+       Partial _ -> L.length lbs < skipN+       Done unused _pos value ->+         and [ L.length value == skipN+             , L.append value (L.fromChunks [unused]) == lbs+             ]+       Fail _ _ _ -> False++-- | Fail a decoder and make sure the result is sane.+prop_fail :: L.ByteString -> String -> Property+prop_fail lbs msg = forAll (choose (0, L.length lbs)) $ \pos ->+  let result = pushChunks (runGetIncremental decoder) lbs+      decoder = do+        -- use part of the input...+        _ <- getByteString (fromIntegral pos)+        -- ... then fail+        fail msg+  in case result of+     Fail unused pos' msg' ->+       and [ pos == pos'+           , msg == msg'+           , L.length lbs - pos == fromIntegral (B.length unused)+           , L.fromChunks [unused] `L.isSuffixOf` lbs+           ]+     _ -> False -- wuut?++-- read negative length+prop_getByteString_negative :: Int -> Property+prop_getByteString_negative n =+  n < 1 ==>+    runGet (getByteString n) L.empty == B.empty+++prop_bytesRead :: L.ByteString -> Property+prop_bytesRead lbs =+  forAll (makeChunks 0 totalLength) $ \chunkSizes ->+  let result = pushChunks (runGetIncremental decoder) lbs+      decoder = do+        -- Read some data and invoke bytesRead several times.+        -- Each time, check that the values are what we expect.+        flip mapM_ chunkSizes $ \(total, step) -> do+          _ <- getByteString (fromIntegral step)+          n <- bytesRead+          unless (n == total) $ fail "unexpected position"+        bytesRead+  in case result of+       Done unused pos value ->+         and [ value == totalLength+             , pos == value+             , B.null unused+             ]+       Partial _ -> False+       Fail _ _ _ -> False   where+    totalLength = L.length lbs+    makeChunks total i+      | i == 0 = return []+      | otherwise = do+          n <- choose (0,i)+          let total' = total + n+          rest <- makeChunks total' (i - n)+          return ((total',n):rest)+++-- read too much+prop_readTooMuch :: (Eq a, Binary a) => a -> Bool+prop_readTooMuch x = mustThrowError $ x == a && x /= b+  where+    -- encode 'a', but try to read 'b' too     (a,b) = decode (encode x)+    _types = [a,b] ++-- String utilities++prop_getLazyByteString :: L.ByteString -> Property+prop_getLazyByteString lbs = forAll (choose (0, 2 * L.length lbs)) $ \len ->+  let result = pushChunks (runGetIncremental decoder) lbs+      decoder = getLazyByteString len+  in case result of+       Done unused _pos value ->+         and [ value == L.take len lbs+             , L.fromChunks [unused] == L.drop len lbs+             ]+       Partial _ -> len > L.length lbs+       _ -> False++prop_getLazyByteStringNul :: Word16 -> [Int] -> Property+prop_getLazyByteStringNul count0 fragments = count >= 0 ==>+  forAll (choose (0, count)) $ \pos ->+  let lbs = case L.splitAt pos (L.replicate count 65) of+              (start,end) -> refragment fragments $ L.concat [start, L.singleton 0, end]+      result = pushEndOfInput $ pushChunks (runGetIncremental getLazyByteStringNul) lbs+  in case result of+       Done unused pos' value ->+         and [ value == L.take pos lbs+             , pos + 1 == pos' -- 1 for the NUL+             , L.fromChunks [unused] == L.drop (pos + 1) lbs+             ]+       _ -> False+  where+  count = fromIntegral count0 -- to make the generated numbers a bit smaller++-- | Same as prop_getLazyByteStringNul, but without any NULL in the string.+prop_getLazyByteStringNul_noNul :: Word16 -> [Int] -> Property+prop_getLazyByteStringNul_noNul count0 fragments = count >= 0 ==>+  let lbs = refragment fragments $ L.replicate count 65+      result = pushEndOfInput $ pushChunks (runGetIncremental getLazyByteStringNul) lbs+  in case result of+       Fail _ _ _ -> True+       _ -> False+  where+  count = fromIntegral count0 -- to make the generated numbers a bit smaller++prop_getRemainingLazyByteString :: L.ByteString -> Property+prop_getRemainingLazyByteString lbs = property $+  let result = pushEndOfInput $ pushChunks (runGetIncremental getRemainingLazyByteString) lbs+  in case result of+    Done unused pos value ->+      and [ value == lbs+          , B.null unused+          , fromIntegral pos == L.length lbs+          ]+    _ -> False+ -- sanity:  invariant_lbs :: L.ByteString -> Bool@@ -82,15 +234,6 @@ prop_invariant :: (Binary a) => a -> Bool prop_invariant = invariant_lbs . encode --- be lazy!---- doesn't do fair testing of lazy put/get.--- tons of untested cases---- lazyTrip :: (Binary a, Eq a) => a -> Property--- lazyTrip a = forAll positiveList $ \xs ->---     a == (runGet lazyGet . refragment xs . runPut . lazyPut $ a)- -- refragment a lazy bytestring's chunks refragment :: [Int] -> L.ByteString -> L.ByteString refragment [] lps = lps@@ -100,33 +243,23 @@     L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest  -- check identity of refragmentation+prop_refragment :: L.ByteString -> [Int] -> Bool prop_refragment lps xs = lps == refragment xs lps  -- check that refragmention still hold invariant+prop_refragment_inv :: L.ByteString -> [Int] -> Bool prop_refragment_inv lps xs = invariant_lbs $ refragment xs lps  main :: IO ()-main = do-    hSetBuffering stdout NoBuffering-    s <- getArgs-    let x = if null s then 100 else read (head s)-    pRun 2 x tests--{--run :: [(String, Int -> IO ())] -> IO ()-run tests = do-    x <- getArgs-    let n = if null x then 100 else read . head $ x-    mapM_ (\(s,a) -> printf "%-50s" s >> a n) tests--}+main = defaultMain tests  ------------------------------------------------------------------------  type T a = a -> Property type B a = a -> Bool -p       :: Testable a => a -> Int -> IO String-p       = pNon+p :: (Testable p) => p -> Property+p = property  test    :: (Eq a, Binary a) => a -> Property test a  = forAll positiveList (roundTrip a . refragment)@@ -134,111 +267,171 @@ positiveList :: Gen [Int] positiveList = fmap (filter (/=0) . map abs) $ arbitrary --- tests :: [(String, Int -> IO String)]+tests :: [Test] tests =--- utils-        [ ("refragment id",        p prop_refragment     )-        , ("refragment invariant", p prop_refragment_inv )+        [ testGroup "Utils"+            [ testProperty "refragment id" (p prop_refragment)+            , testProperty "refragment invariant" (p prop_refragment_inv)+            ] --- boundaries-        , ("read to much",  p (prop_bookworm :: B Word8     ))+        , testGroup "Boundaries"+            [ testProperty "read to much"         (p (prop_readTooMuch :: B Word8))+            , testProperty "read negative length" (p (prop_getByteString_negative :: T Int))+            ] --- Primitives-        , ("Word16be",      p prop_Word16be)-        , ("Word16le",      p prop_Word16le)-        , ("Word16host",    p prop_Word16host)-        , ("Word32be",      p prop_Word32be)-        , ("Word32le",      p prop_Word32le)-        , ("Word32host",    p prop_Word32host)-        , ("Word64be",      p prop_Word64be)-        , ("Word64le",      p prop_Word64le)-        , ("Word64host",    p prop_Word64host)-        , ("Wordhost",      p prop_Wordhost)+        , testGroup "Partial"+            [ testProperty "partial" (p prop_partial)+            , testProperty "fail"    (p prop_fail)+            , testProperty "bytesRead" (p prop_bytesRead)+            ] --- higher level ones using the Binary class-        ,("()",         p (test :: T ()                     ))-        ,("Bool",       p (test :: T Bool                   ))-        ,("Ordering",   p (test :: T Ordering               ))+        , testGroup "Primitives"+            [ testProperty "Word16be"   (p prop_Word16be)+            , testProperty "Word16le"   (p prop_Word16le)+            , testProperty "Word16host" (p prop_Word16host)+            , testProperty "Word32be"   (p prop_Word32be)+            , testProperty "Word32le"   (p prop_Word32le)+            , testProperty "Word32host" (p prop_Word32host)+            , testProperty "Word64be"   (p prop_Word64be)+            , testProperty "Word64le"   (p prop_Word64le)+            , testProperty "Word64host" (p prop_Word64host)+            , testProperty "Wordhost"   (p prop_Wordhost)+            ] -        ,("Word8",      p (test :: T Word8                  ))-        ,("Word16",     p (test :: T Word16                 ))-        ,("Word32",     p (test :: T Word32                 ))-        ,("Word64",     p (test :: T Word64                 ))+        , testGroup "String utils"+            [ testProperty "getLazyByteString"          prop_getLazyByteString+            , testProperty "getLazyByteStringNul"       prop_getLazyByteStringNul +            , testProperty "getLazyByteStringNul No Null" prop_getLazyByteStringNul_noNul+            , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString +            ] -        ,("Int8",       p (test :: T Int8                   ))-        ,("Int16",      p (test :: T Int16                  ))-        ,("Int32",      p (test :: T Int32                  ))-        ,("Int64",      p (test :: T Int64                  ))+        , testGroup "Using Binary class, refragmented ByteString" $ map (uncurry testProperty)+            [ ("()",         p (test :: T ()                     ))+            , ("Bool",       p (test :: T Bool                   ))+            , ("Ordering",   p (test :: T Ordering               ))+            , ("Ratio Int",  p (test :: T (Ratio Int)            )) -        ,("Word",       p (test :: T Word                   ))-        ,("Int",        p (test :: T Int                    ))-        ,("Integer",    p (test :: T Integer                )) -        ,("Float",      p (test :: T Float                  ))-        ,("Double",     p (test :: T Double                 ))+            , ("Word8",      p (test :: T Word8                  ))+            , ("Word16",     p (test :: T Word16                 ))+            , ("Word32",     p (test :: T Word32                 ))+            , ("Word64",     p (test :: T Word64                 )) -        ,("Char",       p (test :: T Char                   ))+            , ("Int8",       p (test :: T Int8                   ))+            , ("Int16",      p (test :: T Int16                  ))+            , ("Int32",      p (test :: T Int32                  ))+            , ("Int64",      p (test :: T Int64                  )) -        ,("[()]",       p (test :: T [()]                  ))-        ,("[Word8]",    p (test :: T [Word8]               ))-        ,("[Word32]",   p (test :: T [Word32]              ))-        ,("[Word64]",   p (test :: T [Word64]              ))-        ,("[Word]",     p (test :: T [Word]                ))-        ,("[Int]",      p (test :: T [Int]                 ))-        ,("[Integer]",  p (test :: T [Integer]             ))-        ,("String",     p (test :: T String                ))+            , ("Word",       p (test :: T Word                   ))+            , ("Int",        p (test :: T Int                    ))+            , ("Integer",    p (test :: T Integer                )) -        ,("((), ())",           p (test :: T ((), ())        ))-        ,("(Word8, Word32)",    p (test :: T (Word8, Word32) ))-        ,("(Int8, Int32)",      p (test :: T (Int8,  Int32)  ))-        ,("(Int32, [Int])",     p (test :: T (Int32, [Int])  ))+            , ("Float",      p (test :: T Float                  ))+            , ("Double",     p (test :: T Double                 )) -        ,("Maybe Int8",         p (test :: T (Maybe Int8)        ))-        ,("Either Int8 Int16",  p (test :: T (Either Int8 Int16) ))+            , ("Char",       p (test :: T Char                   )) -        ,("(Maybe Word8, Bool, [Int], Either Bool Word8)",-                p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))+            , ("[()]",       p (test :: T [()]                  ))+            , ("[Word8]",    p (test :: T [Word8]               ))+            , ("[Word32]",   p (test :: T [Word32]              ))+            , ("[Word64]",   p (test :: T [Word64]              ))+            , ("[Word]",     p (test :: T [Word]                ))+            , ("[Int]",      p (test :: T [Int]                 ))+            , ("[Integer]",  p (test :: T [Integer]             ))+            , ("String",     p (test :: T String                ))+            , ("((), ())",           p (test :: T ((), ())        ))+            , ("(Word8, Word32)",    p (test :: T (Word8, Word32) ))+            , ("(Int8, Int32)",      p (test :: T (Int8,  Int32)  ))+            , ("(Int32, [Int])",     p (test :: T (Int32, [Int])  )) -        ,("(Int, ByteString)",        p (test     :: T (Int, B.ByteString)   ))---      ,("Lazy (Int, ByteString)",   p (lazyTrip :: T (Int, B.ByteString)   ))-        ,("[(Int, ByteString)]",      p (test     :: T [(Int, B.ByteString)] ))---      ,("Lazy [(Int, ByteString)]", p (lazyTrip :: T [(Int, B.ByteString)] ))+            , ("Maybe Int8",         p (test :: T (Maybe Int8)        ))+            , ("Either Int8 Int16",  p (test :: T (Either Int8 Int16) )) +            , ("(Int, ByteString)",+                      p (test     :: T (Int, B.ByteString)   ))+            , ("[(Int, ByteString)]",+                      p (test     :: T [(Int, B.ByteString)] )) ---      ,("Lazy IntMap",       p (lazyTrip  :: T IntSet.IntSet          ))-        ,("IntSet",            p (test      :: T IntSet.IntSet          ))-        ,("IntMap ByteString", p (test      :: T (IntMap.IntMap B.ByteString) ))+            , ("(Maybe Int64, Bool, [Int])",+                      p (test :: T (Maybe Int64, Bool, [Int])))+            , ("(Maybe Word8, Bool, [Int], Either Bool Word8)",+                      p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))+            , ("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",+                      p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) )) -        ,("B.ByteString",  p (test :: T B.ByteString        ))-        ,("L.ByteString",  p (test :: T L.ByteString        ))+            , ("(Int,Int,Int,Int,Int,Int)",+                      p (test :: T (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,Int,Int,Int,Int,Int)",+                      p (test :: T (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,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 invariant",   p (prop_invariant :: B B.ByteString                 ))-        ,("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString]               ))-        ,("L.ByteString invariant",   p (prop_invariant :: B L.ByteString                 ))-        ,("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString]               ))-        ,("IntMap invariant",         p (prop_invariant :: B (IntMap.IntMap B.ByteString) ))+            , ("B.ByteString",  p (test :: T B.ByteString        ))+            , ("L.ByteString",  p (test :: T L.ByteString        ))+            ] -        ,("Set Word32",      p (test :: T (Set.Set Word32)      ))-        ,("Map Word16 Int",  p (test :: T (Map.Map Word16 Int)  ))+        , testGroup "Invariants" $ map (uncurry testProperty)+            [ ("B.ByteString invariant",   p (prop_invariant :: B B.ByteString                 ))+            , ("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString]               ))+            , ("L.ByteString invariant",   p (prop_invariant :: B L.ByteString                 ))+            , ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString]               ))+            ]+        ] -        ,("(Maybe Int64, Bool, [Int])", p (test :: T (Maybe Int64, Bool, [Int])))+-- GHC only:+--      ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool)) -{------- Big tuples lack an Arbitrary instance in Hugs/QuickCheck---+instance Arbitrary L.ByteString where+    arbitrary     = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant. -        ,("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",-            p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) ))+instance Arbitrary B.ByteString where+  arbitrary = B.pack `fmap` arbitrary -        ,("(Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int)", p (roundTrip :: (Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int) -> Bool))+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+          Arbitrary f) =>+         Arbitrary (a,b,c,d,e,f) where+  arbitrary = do+    (a,b,c,d,e) <- arbitrary+    f <- arbitrary+    return (a,b,c,d,e,f) -        ,("(Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int)", p (roundTrip :: (Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int) -> Bool))--}+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+          Arbitrary f, Arbitrary g) =>+         Arbitrary (a,b,c,d,e,f,g) where+  arbitrary = do+    (a,b,c,d,e) <- arbitrary+    (f,g) <- arbitrary+    return (a,b,c,d,e,f,g) --- GHC only:---      ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+          Arbitrary f, Arbitrary g, Arbitrary h) =>+         Arbitrary (a,b,c,d,e,f,g,h) where+  arbitrary = do+    (a,b,c,d,e) <- arbitrary+    (f,g,h) <- arbitrary+    return (a,b,c,d,e,f,g,h) --- Obsolete---      ,("ensureLeft/Fail", mytest (shouldFail (decode L.empty :: Either ParseError Int)))-        ]+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+          Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i) =>+         Arbitrary (a,b,c,d,e,f,g,h,i) where+  arbitrary = do+    (a,b,c,d,e) <- arbitrary+    (f,g,h,i) <- arbitrary+    return (a,b,c,d,e,f,g,h,i)++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+          Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i, Arbitrary j) =>+         Arbitrary (a,b,c,d,e,f,g,h,i,j) where+  arbitrary = do+    (a,b,c,d,e) <- arbitrary+    (f,g,h,i,j) <- arbitrary+    return (a,b,c,d,e,f,g,h,i,j)+

@@ -1,258 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------ Uses multi-param type classes----module QuickCheckUtils where--import Control.Monad--import Test.QuickCheck.Batch-import Test.QuickCheck-import Text.Show.Functions--import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as B-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Lazy 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 qualified Control.Exception as C (evaluate)--import Control.Monad        ( liftM2 )-import Data.Char-import Data.List-import Data.Word-import Data.Int-import System.Random-import System.IO---- import Control.Concurrent-import System.Mem-import System.CPUTime-import Text.Printf--import qualified Data.ByteString      as P-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Internal as L---- import qualified Data.Sequence as Seq---- Enable this to get verbose test output. Including the actual tests.-debug = False--mytest :: Testable a => a -> Int -> IO ()-mytest a n = mycheck defaultConfig-    { configMaxTest=n-    , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a--mycheck :: Testable a => Config -> a -> IO ()-mycheck config a = do-     rnd <- newStdGen-     performGC -- >> threadDelay 100-     t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0-     printf " %0.3f seconds\n" (t :: Double)-     hFlush stdout--time :: a -> IO (a , Double)-time a = do-    start <- getCPUTime-    v     <- C.evaluate a-    v `seq` return ()-    end   <- getCPUTime-    return (v,     (      (fromIntegral (end - start)) / (10^12)))--mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO  Double-mytests config gen rnd0 ntest nfail stamps t0-  | ntest == configMaxTest config = do done "OK," ntest stamps-                                       return t0--  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps-                                       return t0--  | otherwise = do-     (result,t1) <- time (generate (configSize config ntest) rnd2 gen)--     putStr (configEvery config ntest (arguments result)) >> hFlush stdout-     case ok result of-       Nothing    ->-         mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1)-       Just True  ->-         mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1)-       Just False -> do-         putStr ( "Falsifiable after "-               ++ show ntest-               ++ " tests:\n"-               ++ unlines (arguments result)-                ) >> hFlush stdout-         return t0--     where-      (rnd1,rnd2) = split rnd0--done :: String -> Int -> [[String]] -> IO ()-done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )- where-  table = display-        . map entry-        . reverse-        . sort-        . map pairLength-        . group-        . sort-        . filter (not . null)-        $ stamps--  display []  = ". "-  display [x] = " (" ++ x ++ "). "-  display xs  = ".\n" ++ unlines (map (++ ".") xs)--  pairLength xss@(xs:_) = (length xss, xs)-  entry (n, xs)         = percentage n ntest-                       ++ " "-                       ++ concat (intersperse ", " xs)--  percentage n m        = show ((100 * n) `div` m) ++ "%"----------------------------------------------------------------------------instance Random Word8 where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)--instance Random Int8 where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)--instance Random Word16 where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)--instance Random Int16 where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)--instance Random Word where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)--instance Random Word32 where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)--instance Random Int32 where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)--instance Random Word64 where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)--instance Random Int64 where-  randomR = integralRandomR-  random = randomR (minBound,maxBound)----------------------------------------------------------------------------integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)-integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,-                                         fromIntegral b :: Integer) g of-                            (x,g) -> (fromIntegral x, g)----------------------------------------------------------------------------instance Arbitrary Word8 where-    arbitrary       = choose (0, 2^8-1)-    coarbitrary w   = variant 0--instance Arbitrary Word16 where-    arbitrary       = choose (0, 2^16-1)-    coarbitrary     = undefined--instance Arbitrary Word32 where---  arbitrary       = choose (0, 2^32-1)-    arbitrary       = choose (minBound, maxBound)-    coarbitrary     = undefined--instance Arbitrary Word64 where---  arbitrary       = choose (0, 2^64-1)-    arbitrary       = choose (minBound, maxBound)-    coarbitrary     = undefined--instance Arbitrary Int8 where---  arbitrary       = choose (0, 2^8-1)-    arbitrary       = choose (minBound, maxBound)-    coarbitrary w   = variant 0--instance Arbitrary Int16 where---  arbitrary       = choose (0, 2^16-1)-    arbitrary       = choose (minBound, maxBound)-    coarbitrary     = undefined--instance Arbitrary Int32 where---  arbitrary       = choose (0, 2^32-1)-    arbitrary       = choose (minBound, maxBound)-    coarbitrary     = undefined--instance Arbitrary Int64 where---  arbitrary       = choose (0, 2^64-1)-    arbitrary       = choose (minBound, maxBound)-    coarbitrary     = undefined--instance Arbitrary Word where-    arbitrary       = choose (minBound, maxBound)-    coarbitrary w   = variant 0----------------------------------------------------------------------------instance Arbitrary Char where-    arbitrary = choose (maxBound, minBound)-    coarbitrary = undefined--{--instance Arbitrary a => Arbitrary (Maybe a) where-    arbitrary = oneof [ return Nothing, liftM Just arbitrary]-    coarbitrary = undefined-    -}--instance Arbitrary Ordering where-    arbitrary = oneof [ return LT,return  GT,return  EQ ]-    coarbitrary = undefined--{--instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where-    arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary]-    coarbitrary = undefined-    -}--instance Arbitrary IntSet.IntSet where-    arbitrary = fmap IntSet.fromList arbitrary-    coarbitrary = undefined--instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where-    arbitrary = fmap IntMap.fromList arbitrary-    coarbitrary = undefined--instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where-    arbitrary = fmap Set.fromList arbitrary-    coarbitrary = undefined--instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where-    arbitrary = fmap Map.fromList arbitrary-    coarbitrary = undefined--{--instance (Arbitrary a) => Arbitrary (Seq.Seq a) where-    arbitrary = fmap Seq.fromList arbitrary-    coarbitrary = undefined--}--instance Arbitrary L.ByteString where-    arbitrary     = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant.-    coarbitrary s = coarbitrary (L.unpack s)--instance Arbitrary B.ByteString where-  arbitrary = B.pack `fmap` arbitrary-  coarbitrary s = coarbitrary (B.unpack s)

@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE ScopedTypeVariables #-}  module BinaryDerive where @@ -45,7 +45,7 @@             else "  get =")         ++ concatMap ((++"\n")) (map getDef constrs) ++        (if length constrs > 1-	    then "      _ -> fail \"no parse\""+	    then "      _ -> fail \"no decoding\"" 	    else ""        )     getDef (n, (name, ps)) =

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-}  import Data.Generics @@ -38,31 +39,34 @@       0 -> get >>= \a -> return (Laptop a)       1 -> get >>= \a -> get >>= \b -> return (Desktop a b) --- | All drinks mankind will ever need-data Drinks = Beer Bool{-ale?-}-            | Coffee-            | Tea-            | EnergyDrink-            | Water-            | Wine-            | Whisky+data Exp = ExpOr Exp Exp+         | ExpAnd Exp Exp+         | ExpEq Exp Exp+         | ExpNEq Exp Exp+         | ExpAdd Exp Exp+         | ExpSub Exp Exp+         | ExpVar String+         | ExpInt Int     deriving (Typeable, Data, Show, Eq) -instance Binary Main.Drinks where-  put (Beer a) = putWord8 0 >> put a-  put Coffee = putWord8 1-  put Tea = putWord8 2-  put EnergyDrink = putWord8 3-  put Water = putWord8 4-  put Wine = putWord8 5-  put Whisky = putWord8 6+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 -> return (Beer a)-      1 -> return Coffee-      2 -> return Tea-      3 -> return EnergyDrink-      4 -> return Water-      5 -> return Wine-      6 -> return Whisky+      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"