diff --git a/README b/README --- a/README +++ b/README @@ -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: diff --git a/benchmarks/Builder.hs b/benchmarks/Builder.hs --- a/benchmarks/Builder.hs +++ b/benchmarks/Builder.hs @@ -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 diff --git a/benchmarks/Get.hs b/benchmarks/Get.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Get.hs @@ -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) diff --git a/benchmarks/Makefile b/benchmarks/Makefile --- a/benchmarks/Makefile +++ b/benchmarks/Makefile @@ -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 diff --git a/benchmarks/MemBench.hs b/benchmarks/MemBench.hs --- a/benchmarks/MemBench.hs +++ b/benchmarks/MemBench.hs @@ -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) diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,10 +1,10 @@ name: binary -version: 0.5.1.1 +version: 0.6.0.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin maintainer: Lennart Kolmodin, Don Stewart -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 diff --git a/index.html b/index.html --- a/index.html +++ b/index.html @@ -32,7 +32,7 @@ 
    "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."
diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs --- a/src/Data/Binary.hs +++ b/src/Data/Binary.hs @@ -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. diff --git a/src/Data/Binary/Builder/Base.hs b/src/Data/Binary/Builder/Base.hs --- a/src/Data/Binary/Builder/Base.hs +++ b/src/Data/Binary/Builder/Base.hs @@ -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 #-} diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -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 diff --git a/src/Data/Binary/Get/Internal.hs b/src/Data/Binary/Get/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Get/Internal.hs @@ -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 #-} diff --git a/tests/Makefile b/tests/Makefile --- a/tests/Makefile +++ b/tests/Makefile @@ -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 diff --git a/tests/Parallel.hs b/tests/Parallel.hs deleted file mode 100644 --- a/tests/Parallel.hs +++ /dev/null @@ -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_ diff --git a/tests/QC.hs b/tests/QC.hs --- a/tests/QC.hs +++ b/tests/QC.hs @@ -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) + diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs deleted file mode 100644 --- a/tests/QuickCheckUtils.hs +++ /dev/null @@ -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) diff --git a/tools/derive/BinaryDerive.hs b/tools/derive/BinaryDerive.hs --- a/tools/derive/BinaryDerive.hs +++ b/tools/derive/BinaryDerive.hs @@ -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)) = diff --git a/tools/derive/Example.hs b/tools/derive/Example.hs --- a/tools/derive/Example.hs +++ b/tools/derive/Example.hs @@ -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"