binary 0.5.1.0 → 0.5.1.1
raw patch · 22 files changed
+2697/−7 lines, 22 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- .gitignore +14/−0
- TODO +28/−0
- benchmarks/Benchmark.hs +1461/−0
- benchmarks/Builder.hs +196/−0
- benchmarks/CBenchmark.c +39/−0
- benchmarks/CBenchmark.h +4/−0
- benchmarks/Makefile +23/−0
- benchmarks/MemBench.hs +85/−0
- binary.cabal +1/−1
- docs/hcar/binary-Lb.tex +48/−0
- src/Data/Binary.hs +1/−1
- src/Data/Binary/Builder.hs +2/−1
- src/Data/Binary/Builder/Base.hs +1/−1
- src/Data/Binary/Builder/Internal.hs +2/−1
- src/Data/Binary/Get.hs +1/−1
- src/Data/Binary/Put.hs +1/−1
- tests/Makefile +16/−0
- tests/Parallel.hs +147/−0
- tests/QC.hs +244/−0
- tests/QuickCheckUtils.hs +258/−0
- tools/derive/BinaryDerive.hs +57/−0
- tools/derive/Example.hs +68/−0
+ .gitignore view
@@ -0,0 +1,14 @@+*.hi+*.o+*.p_hi+*.prof+*.tix+.hpc/+/benchmarks/bench+/benchmarks/builder+/dist/*+/tests/qc+GNUmakefile+dist-boot+dist-install+ghc.mk
+ TODO view
@@ -0,0 +1,28 @@+layer handling:++ bit packing+ state parameters+ string pools++ reading structures from the end of a stream, seek/tell behaviour++seek based protocols are too hard. + hGetContents/ interleaving.++user requests:++ get remaining bytestring after a runGet++ some kind of lookahead, or restoring parsing state, or something with+ equal functionality. make it another layer on top?++ getLazyByteString takes an Int, which in Haskell98 is only guarantied to+ be 29 bits, ie. 512 mb.+ maybe we should have a readN64 for allowing reading of larger stuff?+ (which could be implemented with readN on 64bit machines)+ reference: bringerts tar archive decoder would be limitid to 0.5GB+ files, alt. 2GB in GHC++SYB-deriving++investigate the UArray instance, it does not seem to compile in GHC 6.4
+ benchmarks/Benchmark.hs view
@@ -0,0 +1,1461 @@+{-# LANGUAGE BangPatterns #-}+module Main (main) where++import qualified Data.ByteString.Lazy as L+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get++import Control.Exception+import System.CPUTime+import Numeric+import Text.Printf+import System.Environment++import MemBench++data Endian+ = Big+ | Little+ | Host+ deriving (Eq,Ord,Show)++main :: IO ()+main = do+ mb <- getArgs >>= readIO . head+ memBench (mb*10) + putStrLn ""+ putStrLn "Binary (de)serialisation benchmarks:"++ -- do bytewise + sequence_+ [ test wordSize chunkSize Host mb+ | wordSize <- [1]+ , chunkSize <- [16] --1,2,4,8,16]+ ]++ -- now Word16 .. Word64+ sequence_+ [ test wordSize chunkSize end mb+ | wordSize <- [2,4,8]+ , chunkSize <- [16]+ , end <- [Host] -- ,Big,Little]+ ]++------------------------------------------------------------------------++time :: IO a -> IO Double+time action = do+ start <- getCPUTime+ action+ end <- getCPUTime+ return $! (fromIntegral (end - start)) / (10^12)++------------------------------------------------------------------------++test :: Int -> Int -> Endian -> Int -> IO ()+test wordSize chunkSize end mb = do+ let bytes :: Int+ bytes = mb * 2^20+ iterations = bytes `div` wordSize+ bs = runPut (doPut wordSize chunkSize end iterations)+ sum = runGet (doGet wordSize chunkSize end iterations) bs++ case (chunkSize,end) of (1,Host) -> putStrLn "" ; _ -> return ()++ printf "%dMB of Word%-2d in chunks of %2d (%6s endian): "+ (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end)++ putSeconds <- time $ evaluate (L.length bs)+ getSeconds <- time $ evaluate sum+-- print (L.length bs, sum)+ let putThroughput = fromIntegral mb / putSeconds+ getThroughput = fromIntegral mb / getSeconds++ printf "%6.1f MB/s write, %6.1f MB/s read, %5.1f get/put-ratio\n"+ putThroughput+ getThroughput+ (getThroughput/putThroughput)++------------------------------------------------------------------------++doPut :: Int -> Int -> Endian -> Int -> Put+doPut wordSize chunkSize end = case (wordSize, chunkSize, end) of+ (1, 1,_) -> putWord8N1+ (1, 2,_) -> putWord8N2+ (1, 4,_) -> putWord8N4+ (1, 8,_) -> putWord8N8+ (1, 16, _) -> putWord8N16++ (2, 1, Big) -> putWord16N1Big+ (2, 2, Big) -> putWord16N2Big+ (2, 4, Big) -> putWord16N4Big+ (2, 8, Big) -> putWord16N8Big+ (2, 16, Big) -> putWord16N16Big+ (2, 1, Little) -> putWord16N1Little+ (2, 2, Little) -> putWord16N2Little+ (2, 4, Little) -> putWord16N4Little+ (2, 8, Little) -> putWord16N8Little+ (2, 16, Little) -> putWord16N16Little+ (2, 1, Host) -> putWord16N1Host+ (2, 2, Host) -> putWord16N2Host+ (2, 4, Host) -> putWord16N4Host+ (2, 8, Host) -> putWord16N8Host+ (2, 16, Host) -> putWord16N16Host++ (4, 1, Big) -> putWord32N1Big+ (4, 2, Big) -> putWord32N2Big+ (4, 4, Big) -> putWord32N4Big+ (4, 8, Big) -> putWord32N8Big+ (4, 16, Big) -> putWord32N16Big+ (4, 1, Little) -> putWord32N1Little+ (4, 2, Little) -> putWord32N2Little+ (4, 4, Little) -> putWord32N4Little+ (4, 8, Little) -> putWord32N8Little+ (4, 16, Little) -> putWord32N16Little+ (4, 1, Host) -> putWord32N1Host+ (4, 2, Host) -> putWord32N2Host+ (4, 4, Host) -> putWord32N4Host+ (4, 8, Host) -> putWord32N8Host+ (4, 16, Host) -> putWord32N16Host++ (8, 1, Host) -> putWord64N1Host+ (8, 2, Host) -> putWord64N2Host+ (8, 4, Host) -> putWord64N4Host+ (8, 8, Host) -> putWord64N8Host+ (8, 16, Host) -> putWord64N16Host+ (8, 1, Big) -> putWord64N1Big+ (8, 2, Big) -> putWord64N2Big+ (8, 4, Big) -> putWord64N4Big+ (8, 8, Big) -> putWord64N8Big+ (8, 16, Big) -> putWord64N16Big+ (8, 1, Little) -> putWord64N1Little+ (8, 2, Little) -> putWord64N2Little+ (8, 4, Little) -> putWord64N4Little+ (8, 8, Little) -> putWord64N8Little+ (8, 16, Little) -> putWord64N16Little++------------------------------------------------------------------------++doGet :: Int -> Int -> Endian -> Int -> Get Int+doGet wordSize chunkSize end =+ case (wordSize, chunkSize, end) of+ (1, 1,_) -> fmap fromIntegral . getWord8N1+ (1, 2,_) -> fmap fromIntegral . getWord8N2+ (1, 4,_) -> fmap fromIntegral . getWord8N4+ (1, 8,_) -> fmap fromIntegral . getWord8N8+ (1, 16,_) -> fmap fromIntegral . getWord8N16++ (2, 1,Big) -> fmap fromIntegral . getWord16N1Big+ (2, 2,Big) -> fmap fromIntegral . getWord16N2Big+ (2, 4,Big) -> fmap fromIntegral . getWord16N4Big+ (2, 8,Big) -> fmap fromIntegral . getWord16N8Big+ (2, 16,Big) -> fmap fromIntegral . getWord16N16Big+ (2, 1,Little) -> fmap fromIntegral . getWord16N1Little+ (2, 2,Little) -> fmap fromIntegral . getWord16N2Little+ (2, 4,Little) -> fmap fromIntegral . getWord16N4Little+ (2, 8,Little) -> fmap fromIntegral . getWord16N8Little+ (2, 16,Little) -> fmap fromIntegral . getWord16N16Little+ (2, 1,Host) -> fmap fromIntegral . getWord16N1Host+ (2, 2,Host) -> fmap fromIntegral . getWord16N2Host+ (2, 4,Host) -> fmap fromIntegral . getWord16N4Host+ (2, 8,Host) -> fmap fromIntegral . getWord16N8Host+ (2, 16,Host) -> fmap fromIntegral . getWord16N16Host++ (4, 1,Big) -> fmap fromIntegral . getWord32N1Big+ (4, 2,Big) -> fmap fromIntegral . getWord32N2Big+ (4, 4,Big) -> fmap fromIntegral . getWord32N4Big+ (4, 8,Big) -> fmap fromIntegral . getWord32N8Big+ (4, 16,Big) -> fmap fromIntegral . getWord32N16Big+ (4, 1,Little) -> fmap fromIntegral . getWord32N1Little+ (4, 2,Little) -> fmap fromIntegral . getWord32N2Little+ (4, 4,Little) -> fmap fromIntegral . getWord32N4Little+ (4, 8,Little) -> fmap fromIntegral . getWord32N8Little+ (4, 16,Little) -> fmap fromIntegral . getWord32N16Little+ (4, 1,Host) -> fmap fromIntegral . getWord32N1Host+ (4, 2,Host) -> fmap fromIntegral . getWord32N2Host+ (4, 4,Host) -> fmap fromIntegral . getWord32N4Host+ (4, 8,Host) -> fmap fromIntegral . getWord32N8Host+ (4, 16,Host) -> fmap fromIntegral . getWord32N16Host++ (8, 1,Host) -> fmap fromIntegral . getWord64N1Host+ (8, 2,Host) -> fmap fromIntegral . getWord64N2Host+ (8, 4,Host) -> fmap fromIntegral . getWord64N4Host+ (8, 8,Host) -> fmap fromIntegral . getWord64N8Host+ (8, 16,Host) -> fmap fromIntegral . getWord64N16Host+ (8, 1,Big) -> fmap fromIntegral . getWord64N1Big+ (8, 2,Big) -> fmap fromIntegral . getWord64N2Big+ (8, 4,Big) -> fmap fromIntegral . getWord64N4Big+ (8, 8,Big) -> fmap fromIntegral . getWord64N8Big+ (8, 16,Big) -> fmap fromIntegral . getWord64N16Big+ (8, 1,Little) -> fmap fromIntegral . getWord64N1Little+ (8, 2,Little) -> fmap fromIntegral . getWord64N2Little+ (8, 4,Little) -> fmap fromIntegral . getWord64N4Little+ (8, 8,Little) -> fmap fromIntegral . getWord64N8Little+ (8, 16,Little) -> fmap fromIntegral . getWord64N16Little++------------------------------------------------------------------------++putWord8N1 bytes = loop 0 0+ where loop :: Word8 -> Int -> Put+ loop !s !n | n == bytes = return ()+ | otherwise = do putWord8 s+ loop (s+1) (n+1)++putWord8N2 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 (s+0)+ putWord8 (s+1)+ loop (s+2) (n-2)++putWord8N4 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 (s+0)+ putWord8 (s+1)+ putWord8 (s+2)+ putWord8 (s+3)+ loop (s+4) (n-4)++putWord8N8 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 (s+0)+ putWord8 (s+1)+ putWord8 (s+2)+ putWord8 (s+3)+ putWord8 (s+4)+ putWord8 (s+5)+ putWord8 (s+6)+ putWord8 (s+7)+ loop (s+8) (n-8)++putWord8N16 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 (s+0)+ putWord8 (s+1)+ putWord8 (s+2)+ putWord8 (s+3)+ putWord8 (s+4)+ putWord8 (s+5)+ putWord8 (s+6)+ putWord8 (s+7)+ putWord8 (s+8)+ putWord8 (s+9)+ putWord8 (s+10)+ putWord8 (s+11)+ putWord8 (s+12)+ putWord8 (s+13)+ putWord8 (s+14)+ putWord8 (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------+-- Big endian, word16 writes++putWord16N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be (s+0)+ loop (s+1) (n-1)++putWord16N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be (s+0)+ putWord16be (s+1)+ loop (s+2) (n-2)++putWord16N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be (s+0)+ putWord16be (s+1)+ putWord16be (s+2)+ putWord16be (s+3)+ loop (s+4) (n-4)++putWord16N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be (s+0)+ putWord16be (s+1)+ putWord16be (s+2)+ putWord16be (s+3)+ putWord16be (s+4)+ putWord16be (s+5)+ putWord16be (s+6)+ putWord16be (s+7)+ loop (s+8) (n-8)++putWord16N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be (s+0)+ putWord16be (s+1)+ putWord16be (s+2)+ putWord16be (s+3)+ putWord16be (s+4)+ putWord16be (s+5)+ putWord16be (s+6)+ putWord16be (s+7)+ putWord16be (s+8)+ putWord16be (s+9)+ putWord16be (s+10)+ putWord16be (s+11)+ putWord16be (s+12)+ putWord16be (s+13)+ putWord16be (s+14)+ putWord16be (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------+-- Little endian, word16 writes++putWord16N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16le (s+0)+ loop (s+1) (n-1)++putWord16N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16le (s+0)+ putWord16le (s+1)+ loop (s+2) (n-2)++putWord16N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16le (s+0)+ putWord16le (s+1)+ putWord16le (s+2)+ putWord16le (s+3)+ loop (s+4) (n-4)++putWord16N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16le (s+0)+ putWord16le (s+1)+ putWord16le (s+2)+ putWord16le (s+3)+ putWord16le (s+4)+ putWord16le (s+5)+ putWord16le (s+6)+ putWord16le (s+7)+ loop (s+8) (n-8)++putWord16N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16le (s+0)+ putWord16le (s+1)+ putWord16le (s+2)+ putWord16le (s+3)+ putWord16le (s+4)+ putWord16le (s+5)+ putWord16le (s+6)+ putWord16le (s+7)+ putWord16le (s+8)+ putWord16le (s+9)+ putWord16le (s+10)+ putWord16le (s+11)+ putWord16le (s+12)+ putWord16le (s+13)+ putWord16le (s+14)+ putWord16le (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------+-- Host endian, unaligned, word16 writes++putWord16N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16host (s+0)+ loop (s+1) (n-1)++putWord16N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16host (s+0)+ putWord16host (s+1)+ loop (s+2) (n-2)++putWord16N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16host (s+0)+ putWord16host (s+1)+ putWord16host (s+2)+ putWord16host (s+3)+ loop (s+4) (n-4)++putWord16N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16host (s+0)+ putWord16host (s+1)+ putWord16host (s+2)+ putWord16host (s+3)+ putWord16host (s+4)+ putWord16host (s+5)+ putWord16host (s+6)+ putWord16host (s+7)+ loop (s+8) (n-8)++putWord16N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16host (s+0)+ putWord16host (s+1)+ putWord16host (s+2)+ putWord16host (s+3)+ putWord16host (s+4)+ putWord16host (s+5)+ putWord16host (s+6)+ putWord16host (s+7)+ putWord16host (s+8)+ putWord16host (s+9)+ putWord16host (s+10)+ putWord16host (s+11)+ putWord16host (s+12)+ putWord16host (s+13)+ putWord16host (s+14)+ putWord16host (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be (s+0)+ loop (s+1) (n-1)++putWord32N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be (s+0)+ putWord32be (s+1)+ loop (s+2) (n-2)++putWord32N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be (s+0)+ putWord32be (s+1)+ putWord32be (s+2)+ putWord32be (s+3)+ loop (s+4) (n-4)++putWord32N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be (s+0)+ putWord32be (s+1)+ putWord32be (s+2)+ putWord32be (s+3)+ putWord32be (s+4)+ putWord32be (s+5)+ putWord32be (s+6)+ putWord32be (s+7)+ loop (s+8) (n-8)++putWord32N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be (s+0)+ putWord32be (s+1)+ putWord32be (s+2)+ putWord32be (s+3)+ putWord32be (s+4)+ putWord32be (s+5)+ putWord32be (s+6)+ putWord32be (s+7)+ putWord32be (s+8)+ putWord32be (s+9)+ putWord32be (s+10)+ putWord32be (s+11)+ putWord32be (s+12)+ putWord32be (s+13)+ putWord32be (s+14)+ putWord32be (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32le (s+0)+ loop (s+1) (n-1)++putWord32N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32le (s+0)+ putWord32le (s+1)+ loop (s+2) (n-2)++putWord32N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32le (s+0)+ putWord32le (s+1)+ putWord32le (s+2)+ putWord32le (s+3)+ loop (s+4) (n-4)++putWord32N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32le (s+0)+ putWord32le (s+1)+ putWord32le (s+2)+ putWord32le (s+3)+ putWord32le (s+4)+ putWord32le (s+5)+ putWord32le (s+6)+ putWord32le (s+7)+ loop (s+8) (n-8)++putWord32N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32le (s+0)+ putWord32le (s+1)+ putWord32le (s+2)+ putWord32le (s+3)+ putWord32le (s+4)+ putWord32le (s+5)+ putWord32le (s+6)+ putWord32le (s+7)+ putWord32le (s+8)+ putWord32le (s+9)+ putWord32le (s+10)+ putWord32le (s+11)+ putWord32le (s+12)+ putWord32le (s+13)+ putWord32le (s+14)+ putWord32le (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32host (s+0)+ loop (s+1) (n-1)++putWord32N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32host (s+0)+ putWord32host (s+1)+ loop (s+2) (n-2)++putWord32N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32host (s+0)+ putWord32host (s+1)+ putWord32host (s+2)+ putWord32host (s+3)+ loop (s+4) (n-4)++putWord32N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32host (s+0)+ putWord32host (s+1)+ putWord32host (s+2)+ putWord32host (s+3)+ putWord32host (s+4)+ putWord32host (s+5)+ putWord32host (s+6)+ putWord32host (s+7)+ loop (s+8) (n-8)++putWord32N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32host (s+0)+ putWord32host (s+1)+ putWord32host (s+2)+ putWord32host (s+3)+ putWord32host (s+4)+ putWord32host (s+5)+ putWord32host (s+6)+ putWord32host (s+7)+ putWord32host (s+8)+ putWord32host (s+9)+ putWord32host (s+10)+ putWord32host (s+11)+ putWord32host (s+12)+ putWord32host (s+13)+ putWord32host (s+14)+ putWord32host (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be (s+0)+ loop (s+1) (n-1)++putWord64N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be (s+0)+ putWord64be (s+1)+ loop (s+2) (n-2)++putWord64N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be (s+0)+ putWord64be (s+1)+ putWord64be (s+2)+ putWord64be (s+3)+ loop (s+4) (n-4)++putWord64N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be (s+0)+ putWord64be (s+1)+ putWord64be (s+2)+ putWord64be (s+3)+ putWord64be (s+4)+ putWord64be (s+5)+ putWord64be (s+6)+ putWord64be (s+7)+ loop (s+8) (n-8)++putWord64N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be (s+0)+ putWord64be (s+1)+ putWord64be (s+2)+ putWord64be (s+3)+ putWord64be (s+4)+ putWord64be (s+5)+ putWord64be (s+6)+ putWord64be (s+7)+ putWord64be (s+8)+ putWord64be (s+9)+ putWord64be (s+10)+ putWord64be (s+11)+ putWord64be (s+12)+ putWord64be (s+13)+ putWord64be (s+14)+ putWord64be (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64le (s+0)+ loop (s+1) (n-1)++putWord64N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64le (s+0)+ putWord64le (s+1)+ loop (s+2) (n-2)++putWord64N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64le (s+0)+ putWord64le (s+1)+ putWord64le (s+2)+ putWord64le (s+3)+ loop (s+4) (n-4)++putWord64N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64le (s+0)+ putWord64le (s+1)+ putWord64le (s+2)+ putWord64le (s+3)+ putWord64le (s+4)+ putWord64le (s+5)+ putWord64le (s+6)+ putWord64le (s+7)+ loop (s+8) (n-8)++putWord64N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64le (s+0)+ putWord64le (s+1)+ putWord64le (s+2)+ putWord64le (s+3)+ putWord64le (s+4)+ putWord64le (s+5)+ putWord64le (s+6)+ putWord64le (s+7)+ putWord64le (s+8)+ putWord64le (s+9)+ putWord64le (s+10)+ putWord64le (s+11)+ putWord64le (s+12)+ putWord64le (s+13)+ putWord64le (s+14)+ putWord64le (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64host (s+0)+ loop (s+1) (n-1)++putWord64N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64host (s+0)+ putWord64host (s+1)+ loop (s+2) (n-2)++putWord64N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64host (s+0)+ putWord64host (s+1)+ putWord64host (s+2)+ putWord64host (s+3)+ loop (s+4) (n-4)++putWord64N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64host (s+0)+ putWord64host (s+1)+ putWord64host (s+2)+ putWord64host (s+3)+ putWord64host (s+4)+ putWord64host (s+5)+ putWord64host (s+6)+ putWord64host (s+7)+ loop (s+8) (n-8)++putWord64N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64host (s+0)+ putWord64host (s+1)+ putWord64host (s+2)+ putWord64host (s+3)+ putWord64host (s+4)+ putWord64host (s+5)+ putWord64host (s+6)+ putWord64host (s+7)+ putWord64host (s+8)+ putWord64host (s+9)+ putWord64host (s+10)+ putWord64host (s+11)+ putWord64host (s+12)+ putWord64host (s+13)+ putWord64host (s+14)+ putWord64host (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------+------------------------------------------------------------------------++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)++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)++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)++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+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be+ loop (s+s0) (n-1)++getWord16N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be+ s1 <- getWord16be+ loop (s+s0+s1) (n-2)++getWord16N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be+ s1 <- getWord16be+ s2 <- getWord16be+ s3 <- getWord16be+ loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be+ s1 <- getWord16be+ s2 <- getWord16be+ s3 <- getWord16be+ s4 <- getWord16be+ s5 <- getWord16be+ s6 <- getWord16be+ s7 <- getWord16be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be+ s1 <- getWord16be+ s2 <- getWord16be+ s3 <- getWord16be+ s4 <- getWord16be+ s5 <- getWord16be+ s6 <- getWord16be+ s7 <- getWord16be+ s8 <- getWord16be+ s9 <- getWord16be+ s10 <- getWord16be+ s11 <- getWord16be+ s12 <- getWord16be+ s13 <- getWord16be+ s14 <- getWord16be+ s15 <- getWord16be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16le+ loop (s+s0) (n-1)++getWord16N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16le+ s1 <- getWord16le+ loop (s+s0+s1) (n-2)++getWord16N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16le+ s1 <- getWord16le+ s2 <- getWord16le+ s3 <- getWord16le+ loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16le+ s1 <- getWord16le+ s2 <- getWord16le+ s3 <- getWord16le+ s4 <- getWord16le+ s5 <- getWord16le+ s6 <- getWord16le+ s7 <- getWord16le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16le+ s1 <- getWord16le+ s2 <- getWord16le+ s3 <- getWord16le+ s4 <- getWord16le+ s5 <- getWord16le+ s6 <- getWord16le+ s7 <- getWord16le+ s8 <- getWord16le+ s9 <- getWord16le+ s10 <- getWord16le+ s11 <- getWord16le+ s12 <- getWord16le+ s13 <- getWord16le+ s14 <- getWord16le+ s15 <- getWord16le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16host+ loop (s+s0) (n-1)++getWord16N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16host+ s1 <- getWord16host+ loop (s+s0+s1) (n-2)++getWord16N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16host+ s1 <- getWord16host+ s2 <- getWord16host+ s3 <- getWord16host+ loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16host+ s1 <- getWord16host+ s2 <- getWord16host+ s3 <- getWord16host+ s4 <- getWord16host+ s5 <- getWord16host+ s6 <- getWord16host+ s7 <- getWord16host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16host+ s1 <- getWord16host+ s2 <- getWord16host+ s3 <- getWord16host+ s4 <- getWord16host+ s5 <- getWord16host+ s6 <- getWord16host+ s7 <- getWord16host+ s8 <- getWord16host+ s9 <- getWord16host+ s10 <- getWord16host+ s11 <- getWord16host+ s12 <- getWord16host+ s13 <- getWord16host+ s14 <- getWord16host+ s15 <- getWord16host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be+ loop (s+s0) (n-1)++getWord32N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be+ s1 <- getWord32be+ loop (s+s0+s1) (n-2)++getWord32N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be+ s1 <- getWord32be+ s2 <- getWord32be+ s3 <- getWord32be+ loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be+ s1 <- getWord32be+ s2 <- getWord32be+ s3 <- getWord32be+ s4 <- getWord32be+ s5 <- getWord32be+ s6 <- getWord32be+ s7 <- getWord32be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be+ s1 <- getWord32be+ s2 <- getWord32be+ s3 <- getWord32be+ s4 <- getWord32be+ s5 <- getWord32be+ s6 <- getWord32be+ s7 <- getWord32be+ s8 <- getWord32be+ s9 <- getWord32be+ s10 <- getWord32be+ s11 <- getWord32be+ s12 <- getWord32be+ s13 <- getWord32be+ s14 <- getWord32be+ s15 <- getWord32be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32le+ loop (s+s0) (n-1)++getWord32N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32le+ s1 <- getWord32le+ loop (s+s0+s1) (n-2)++getWord32N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32le+ s1 <- getWord32le+ s2 <- getWord32le+ s3 <- getWord32le+ loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32le+ s1 <- getWord32le+ s2 <- getWord32le+ s3 <- getWord32le+ s4 <- getWord32le+ s5 <- getWord32le+ s6 <- getWord32le+ s7 <- getWord32le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32le+ s1 <- getWord32le+ s2 <- getWord32le+ s3 <- getWord32le+ s4 <- getWord32le+ s5 <- getWord32le+ s6 <- getWord32le+ s7 <- getWord32le+ s8 <- getWord32le+ s9 <- getWord32le+ s10 <- getWord32le+ s11 <- getWord32le+ s12 <- getWord32le+ s13 <- getWord32le+ s14 <- getWord32le+ s15 <- getWord32le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32host+ loop (s+s0) (n-1)++getWord32N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32host+ s1 <- getWord32host+ loop (s+s0+s1) (n-2)++getWord32N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32host+ s1 <- getWord32host+ s2 <- getWord32host+ s3 <- getWord32host+ loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32host+ s1 <- getWord32host+ s2 <- getWord32host+ s3 <- getWord32host+ s4 <- getWord32host+ s5 <- getWord32host+ s6 <- getWord32host+ s7 <- getWord32host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32host+ s1 <- getWord32host+ s2 <- getWord32host+ s3 <- getWord32host+ s4 <- getWord32host+ s5 <- getWord32host+ s6 <- getWord32host+ s7 <- getWord32host+ s8 <- getWord32host+ s9 <- getWord32host+ s10 <- getWord32host+ s11 <- getWord32host+ s12 <- getWord32host+ s13 <- getWord32host+ s14 <- getWord32host+ s15 <- getWord32host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be+ loop (s+s0) (n-1)++getWord64N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be+ s1 <- getWord64be+ loop (s+s0+s1) (n-2)++getWord64N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be+ s1 <- getWord64be+ s2 <- getWord64be+ s3 <- getWord64be+ loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be+ s1 <- getWord64be+ s2 <- getWord64be+ s3 <- getWord64be+ s4 <- getWord64be+ s5 <- getWord64be+ s6 <- getWord64be+ s7 <- getWord64be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be+ s1 <- getWord64be+ s2 <- getWord64be+ s3 <- getWord64be+ s4 <- getWord64be+ s5 <- getWord64be+ s6 <- getWord64be+ s7 <- getWord64be+ s8 <- getWord64be+ s9 <- getWord64be+ s10 <- getWord64be+ s11 <- getWord64be+ s12 <- getWord64be+ s13 <- getWord64be+ s14 <- getWord64be+ s15 <- getWord64be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64le+ loop (s+s0) (n-1)++getWord64N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64le+ s1 <- getWord64le+ loop (s+s0+s1) (n-2)++getWord64N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64le+ s1 <- getWord64le+ s2 <- getWord64le+ s3 <- getWord64le+ loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64le+ s1 <- getWord64le+ s2 <- getWord64le+ s3 <- getWord64le+ s4 <- getWord64le+ s5 <- getWord64le+ s6 <- getWord64le+ s7 <- getWord64le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64le+ s1 <- getWord64le+ s2 <- getWord64le+ s3 <- getWord64le+ s4 <- getWord64le+ s5 <- getWord64le+ s6 <- getWord64le+ s7 <- getWord64le+ s8 <- getWord64le+ s9 <- getWord64le+ s10 <- getWord64le+ s11 <- getWord64le+ s12 <- getWord64le+ s13 <- getWord64le+ s14 <- getWord64le+ s15 <- getWord64le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64host+ loop (s+s0) (n-1)++getWord64N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64host+ s1 <- getWord64host+ loop (s+s0+s1) (n-2)++getWord64N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64host+ s1 <- getWord64host+ s2 <- getWord64host+ s3 <- getWord64host+ loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64host+ s1 <- getWord64host+ s2 <- getWord64host+ s3 <- getWord64host+ s4 <- getWord64host+ s5 <- getWord64host+ s6 <- getWord64host+ s7 <- getWord64host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64host+ s1 <- getWord64host+ s2 <- getWord64host+ s3 <- getWord64host+ s4 <- getWord64host+ s5 <- getWord64host+ s6 <- getWord64host+ s7 <- getWord64host+ s8 <- getWord64host+ s9 <- getWord64host+ s10 <- getWord64host+ s11 <- getWord64host+ s12 <- getWord64host+ s13 <- getWord64host+ s14 <- getWord64host+ s15 <- getWord64host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)
+ benchmarks/Builder.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE CPP, ExistentialQuantification #-}++#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 C+import qualified Data.ByteString.Lazy as L+import Data.Char (ord)+import Data.Monoid (Monoid(mappend, mempty))+import Data.Word (Word8)++import Data.Binary.Builder++instance NFData S.ByteString++data B = forall a. NFData a => B a++instance NFData B where+ rnf (B b) = rnf b++main :: IO ()+main = defaultMainWith defaultConfig+ (liftIO . evaluate $ rnf [B word8s, B smallByteString, B largeByteString])+ [ -- Test GHC loop optimization of continuation based code.+ bench "[Word8]" $ whnf (run . fromWord8s) word8s++ -- Test bounds check merging+ , bench "bounds/[Word8]" $ whnf (run . from4Word8s) word8s++ , bench "small ByteString" $ whnf (run . fromByteString) smallByteString+ , bench "large ByteString" $ whnf (run . fromByteString) largeByteString+ , bench "length-prefixed ByteString" $ whnf (run . lengthPrefixedBS)+ smallByteString++ , bgroup "Host endian"+ [ bench "1MB of Word8 in chunks of 16" $ whnf (run . putWord8N16) n+ , bench "1MB of Word16 in chunks of 16" $ whnf (run . putWord16N16Host)+ (n `div` 2)+ , bench "1MB of Word32 in chunks of 16" $ whnf (run . putWord32N16Host)+ (n `div` 4)+ , bench "1MB of Word64 in chunks of 16" $ whnf (run . putWord64N16Host)+ (n `div` 8)+ ]+ ]+ where+ run = L.length . toLazyByteString+ n = 1 * (2 ^ (20 :: Int)) -- one MB++-- Input data++word8s :: [Word8]+word8s = replicate 10000 $ fromIntegral $ ord 'a'+{-# NOINLINE word8s #-}++smallByteString :: S.ByteString+smallByteString = C.pack "abcdefghi"++largeByteString :: S.ByteString+largeByteString = S.pack word8s++------------------------------------------------------------------------+-- Benchmarks++fromWord8s :: [Word8] -> Builder+fromWord8s [] = mempty+fromWord8s (x:xs) = singleton x <> fromWord8s xs++from4Word8s :: [Word8] -> Builder+from4Word8s [] = mempty+from4Word8s (x:xs) = singleton x <> singleton x <> singleton x <> singleton x <>+ from4Word8s xs++-- Write 100 short, length-prefixed ByteStrings.+lengthPrefixedBS :: S.ByteString -> Builder+lengthPrefixedBS bs = loop 100+ where loop n | n `seq` False = undefined+ loop 0 = mempty+ loop n =+#if WORD_SIZE_IN_BITS == 32+ putWord32be (fromIntegral $ S.length bs) <>+#elif WORD_SIZE_IN_BITS == 64+ putWord64be (fromIntegral $ S.length bs) <>+#else+# error Unsupported platform+#endif+ fromByteString bs <>+ loop (n-1)++putWord8N16 :: Int -> Builder+putWord8N16 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = mempty+ loop s n =+ singleton (s+0) <>+ singleton (s+1) <>+ singleton (s+2) <>+ singleton (s+3) <>+ singleton (s+4) <>+ singleton (s+5) <>+ singleton (s+6) <>+ singleton (s+7) <>+ singleton (s+8) <>+ singleton (s+9) <>+ singleton (s+10) <>+ singleton (s+11) <>+ singleton (s+12) <>+ singleton (s+13) <>+ singleton (s+14) <>+ singleton (s+15) <>+ loop (s+16) (n-16)++putWord16N16Host :: Int -> Builder+putWord16N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = mempty+ loop s n =+ putWord16host (s+0) <>+ putWord16host (s+1) <>+ putWord16host (s+2) <>+ putWord16host (s+3) <>+ putWord16host (s+4) <>+ putWord16host (s+5) <>+ putWord16host (s+6) <>+ putWord16host (s+7) <>+ putWord16host (s+8) <>+ putWord16host (s+9) <>+ putWord16host (s+10) <>+ putWord16host (s+11) <>+ putWord16host (s+12) <>+ putWord16host (s+13) <>+ putWord16host (s+14) <>+ putWord16host (s+15) <>+ loop (s+16) (n-16)++putWord32N16Host :: Int -> Builder+putWord32N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = mempty+ loop s n =+ putWord32host (s+0) <>+ putWord32host (s+1) <>+ putWord32host (s+2) <>+ putWord32host (s+3) <>+ putWord32host (s+4) <>+ putWord32host (s+5) <>+ putWord32host (s+6) <>+ putWord32host (s+7) <>+ putWord32host (s+8) <>+ putWord32host (s+9) <>+ putWord32host (s+10) <>+ putWord32host (s+11) <>+ putWord32host (s+12) <>+ putWord32host (s+13) <>+ putWord32host (s+14) <>+ putWord32host (s+15) <>+ loop (s+16) (n-16)++putWord64N16Host :: Int -> Builder+putWord64N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = mempty+ loop s n =+ putWord64host (s+0) <>+ putWord64host (s+1) <>+ putWord64host (s+2) <>+ putWord64host (s+3) <>+ putWord64host (s+4) <>+ putWord64host (s+5) <>+ putWord64host (s+6) <>+ putWord64host (s+7) <>+ putWord64host (s+8) <>+ putWord64host (s+9) <>+ putWord64host (s+10) <>+ putWord64host (s+11) <>+ putWord64host (s+12) <>+ putWord64host (s+13) <>+ putWord64host (s+14) <>+ putWord64host (s+15) <>+ loop (s+16) (n-16)++------------------------------------------------------------------------+-- Utilities++infixr 6 <>++(<>) :: Monoid m => m -> m -> m+(<>) = mappend
+ benchmarks/CBenchmark.c view
@@ -0,0 +1,39 @@+#include "CBenchmark.h"++void bytewrite(unsigned char *a, int bytes) {+ unsigned char n = 0;+ int i = 0;+ int iterations = bytes;+ while (i < iterations) {+ a[i++] = n++;+ }+}++unsigned char byteread(unsigned char *a, int bytes) {+ unsigned char n = 0;+ int i = 0;+ int iterations = bytes;+ while (i < iterations) {+ n += a[i++];+ }+ return n;+}++void wordwrite(unsigned long *a, int bytes) {+ unsigned long n = 0;+ int i = 0;+ int iterations = bytes / sizeof(unsigned long) ;+ while (i < iterations) {+ a[i++] = n++;+ }+}++unsigned int wordread(unsigned long *a, int bytes) {+ unsigned long n = 0;+ int i = 0;+ int iterations = bytes / sizeof(unsigned long);+ while (i < iterations) {+ n += a[i++];+ }+ return n;+}
+ benchmarks/CBenchmark.h view
@@ -0,0 +1,4 @@+void bytewrite(unsigned char *a, int bytes);+unsigned char byteread(unsigned char *a, int bytes);+void wordwrite(unsigned long *a, int bytes);+unsigned int wordread(unsigned long *a, int bytes);
+ benchmarks/Makefile view
@@ -0,0 +1,23 @@+ghc := ghc+ghc-flags :=+programs := builder bench++.PHONY: all+all: $(programs)++builder: Builder.hs+ $(ghc) $(ghc-flags) --make -O2 Builder.hs -o $@ -fforce-recomp -i../src++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++.PHONY: run-bench+run-bench: bench+ ./bench 100++CBenchmark.o: CBenchmark.c+ $(ghc) -c -optc -O3 $< -o $@++.PHONY: clean+clean:+ rm -f *.o *.hi $(programs)
+ benchmarks/MemBench.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}+module MemBench (memBench) where++import Foreign+import Foreign.C++import Control.Exception+import System.CPUTime+import Numeric++memBench :: Int -> IO ()+memBench mb = do+ let bytes = mb * 2^20+ allocaBytes bytes $ \ptr -> do+ let bench label test = do+ seconds <- time $ test (castPtr ptr) (fromIntegral bytes)+ let throughput = fromIntegral mb / seconds+ putStrLn $ show mb ++ "MB of " ++ label+ ++ " in " ++ showFFloat (Just 3) seconds "s, at: "+ ++ showFFloat (Just 1) throughput "MB/s"+ bench "setup " c_wordwrite+ putStrLn ""+ putStrLn "C memory throughput benchmarks:"+ bench "bytes written" c_bytewrite+ bench "bytes read " c_byteread+ bench "words written" c_wordwrite+ bench "words read " c_wordread+ putStrLn ""+ putStrLn "Haskell memory throughput benchmarks:"+ bench "bytes written" hs_bytewrite+ bench "bytes read " hs_byteread+ bench "words written" hs_wordwrite+ bench "words read " hs_wordread++hs_bytewrite :: Ptr CUChar -> Int -> IO ()+hs_bytewrite !ptr bytes = loop 0 0+ where iterations = bytes+ loop :: Int -> CUChar -> IO ()+ loop !i !n | i == iterations = return ()+ | otherwise = do pokeByteOff ptr i n+ loop (i+1) (n+1)++hs_byteread :: Ptr CUChar -> Int -> IO CUChar+hs_byteread !ptr bytes = loop 0 0+ where iterations = bytes+ loop :: Int -> CUChar -> IO CUChar+ loop !i !n | i == iterations = return n+ | otherwise = do x <- peekByteOff ptr i+ loop (i+1) (n+x)++hs_wordwrite :: Ptr CULong -> Int -> IO ()+hs_wordwrite !ptr bytes = loop 0 0+ where iterations = bytes `div` sizeOf (undefined :: CULong)+ loop :: Int -> CULong -> IO ()+ loop !i !n | i == iterations = return ()+ | otherwise = do pokeByteOff ptr i n+ loop (i+1) (n+1)++hs_wordread :: Ptr CULong -> Int -> IO CULong+hs_wordread !ptr bytes = loop 0 0+ 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+ loop (i+1) (n+x)+++foreign import ccall unsafe "CBenchmark.h byteread"+ c_byteread :: Ptr CUChar -> CInt -> IO ()++foreign import ccall unsafe "CBenchmark.h bytewrite"+ c_bytewrite :: Ptr CUChar -> CInt -> IO ()++foreign import ccall unsafe "CBenchmark.h wordread"+ c_wordread :: Ptr CUInt -> CInt -> IO ()++foreign import ccall unsafe "CBenchmark.h wordwrite"+ c_wordwrite :: Ptr CUInt -> CInt -> IO ()++time :: IO a -> IO Double+time action = do+ start <- getCPUTime+ action+ end <- getCPUTime+ return $! (fromIntegral (end - start)) / (10^12)
binary.cabal view
@@ -1,5 +1,5 @@ name: binary-version: 0.5.1.0+version: 0.5.1.1 license: BSD3 license-file: LICENSE author: Lennart Kolmodin <kolmodin@gmail.com>
+ docs/hcar/binary-Lb.tex view
@@ -0,0 +1,48 @@+\begin{hcarentry}{binary}+\label{binary}+\report{Lennart Kolmodin}+\status{active}+\participants{Duncan Coutts, Don Stewart, Binary Strike Team}+\makeheader++The Binary Strike Team is pleased to announce yet a release of a new,+pure, efficient binary serialisation library.++The `binary' package provides efficient serialisation of Haskell values+to and from lazy ByteStrings. ByteStrings constructed this way may then+be written to disk, written to the network, or further processed (e.g.+stored in memory directly, or compressed in memory with zlib or bzlib).++The binary library has been heavily tuned for performance, particularly for+writing speed. Throughput of up to 160M/s has been achieved in practice, and+in general speed is on par or better than NewBinary, with the advantage of a+pure interface. Efforts are underway to improve performance still further.+Plans are also taking shape for a parser combinator library on top of+binary, for bit parsing and foreign structure parsing (e.g. network+protocols).++Data.Derive~\cref{derive} has support for automatically generating Binary+instances, allowing to read and write your data structures with little fuzz.++Binary was developed by a team of 8 during the Haskell Hackathon in Oxford+2007, and since then has about 15 people contributed code and many more+given feedback and cheerleading on \verb|#haskell|.++The package is cabalized and available through Hackage~\cref{hackagedb}.+% to editors: ref. to cabal?++\FurtherReading+\begin{compactitem}+\item Homepage++ \url{http://code.haskell.org/binary/}+\item Hackage++ \url{http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary}+\item Development version++ \texttt{darcs get --partial}++ \url{http://code.haskell.org/binary}+\end{compactitem}+\end{hcarentry}
src/Data/Binary.hs view
@@ -8,7 +8,7 @@ -- Copyright : Lennart Kolmodin -- License : BSD3-style (see LICENSE) -- --- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>+-- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : unstable -- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances --
src/Data/Binary/Builder.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif@@ -7,7 +8,7 @@ -- Copyright : Lennart Kolmodin, Ross Paterson -- License : BSD3-style (see LICENSE) -- --- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>+-- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : experimental -- Portability : portable to Hugs and GHC --
src/Data/Binary/Builder/Base.hs view
@@ -9,7 +9,7 @@ -- Copyright : Lennart Kolmodin, Ross Paterson -- License : BSD3-style (see LICENSE) ----- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>+-- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : experimental -- Portability : portable to Hugs and GHC --
src/Data/Binary/Builder/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif@@ -7,7 +8,7 @@ -- Copyright : Lennart Kolmodin, Ross Paterson -- License : BSD3-style (see LICENSE) -- --- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>+-- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : experimental -- Portability : portable to Hugs and GHC --
src/Data/Binary/Get.hs view
@@ -10,7 +10,7 @@ -- Copyright : Lennart Kolmodin -- License : BSD3-style (see LICENSE) -- --- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>+-- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : experimental -- Portability : portable to Hugs and GHC. --
src/Data/Binary/Put.hs view
@@ -9,7 +9,7 @@ -- Copyright : Lennart Kolmodin -- License : BSD3-style (see LICENSE) -- --- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>+-- Maintainer : Lennart Kolmodin <kolmodin@gmail.com> -- Stability : stable -- Portability : Portable to Hugs and GHC. Requires MPTCs --
+ tests/Makefile view
@@ -0,0 +1,16 @@+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++hugs:+ runhugs -98 QC.hs ++clean:+ rm -f *.o *.hi qc *.tix *~++.PHONY: clean
+ tests/Parallel.hs view
@@ -0,0 +1,147 @@+-----------------------------------------------------------------------------+-- |+-- 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_
+ tests/QC.hs view
@@ -0,0 +1,244 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module Main where++import Data.Binary+import Data.Binary.Put+import Data.Binary.Get++import Parallel++import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet++import Data.Array (Array)+import Data.Array.IArray+import Data.Array.Unboxed (UArray)++import qualified Control.OldException as C (catch,evaluate)+import Control.Monad+import Foreign+import System.Environment+import System.IO+import System.IO.Unsafe++import Test.QuickCheck hiding (test)+import QuickCheckUtils+import Text.Printf++-- import qualified Data.Sequence as Seq++------------------------------------------------------------------------++roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool+roundTrip a f = a ==+ {-# SCC "decode.refragment.encode" #-} decode (f (encode a))++roundTripWith put get x =+ forAll positiveList $ \xs ->+ x == runGet get (refragment xs (runPut (put x)))++-- make sure that a test fails+errorish :: B a+errorish a = unsafePerformIO $+ C.catch (do C.evaluate a+ return False)+ (\_ -> return True)++-- low level ones:++prop_Word16be = roundTripWith putWord16be getWord16be+prop_Word16le = roundTripWith putWord16le getWord16le+prop_Word16host = roundTripWith putWord16host getWord16host++prop_Word32be = roundTripWith putWord32be getWord32be+prop_Word32le = roundTripWith putWord32le getWord32le+prop_Word32host = roundTripWith putWord32host getWord32host++prop_Word64be = roundTripWith putWord64be getWord64be+prop_Word64le = roundTripWith putWord64le getWord64le+prop_Word64host = roundTripWith putWord64host getWord64host++prop_Wordhost = roundTripWith putWordhost getWordhost++-- read too much:++prop_bookworm x = errorish $ x == a && x /= b+ where+ (a,b) = decode (encode x)++-- sanity:++invariant_lbs :: L.ByteString -> Bool+invariant_lbs (L.Empty) = True+invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs++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+refragment (x:xs) lps =+ let x' = fromIntegral . (+1) . abs $ x+ rest = refragment xs (L.drop x' lps) in+ L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest++-- check identity of refragmentation+prop_refragment lps xs = lps == refragment xs lps++-- check that refragmention still hold invariant+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+-}++------------------------------------------------------------------------++type T a = a -> Property+type B a = a -> Bool++p :: Testable a => a -> Int -> IO String+p = pNon++test :: (Eq a, Binary a) => a -> Property+test a = forAll positiveList (roundTrip a . refragment)++positiveList :: Gen [Int]+positiveList = fmap (filter (/=0) . map abs) $ arbitrary++-- tests :: [(String, Int -> IO String)]+tests =+-- utils+ [ ("refragment id", p prop_refragment )+ , ("refragment invariant", p prop_refragment_inv )++-- boundaries+ , ("read to much", p (prop_bookworm :: B Word8 ))++-- 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)++-- higher level ones using the Binary class+ ,("()", p (test :: T () ))+ ,("Bool", p (test :: T Bool ))+ ,("Ordering", p (test :: T Ordering ))++ ,("Word8", p (test :: T Word8 ))+ ,("Word16", p (test :: T Word16 ))+ ,("Word32", p (test :: T Word32 ))+ ,("Word64", p (test :: T Word64 ))++ ,("Int8", p (test :: T Int8 ))+ ,("Int16", p (test :: T Int16 ))+ ,("Int32", p (test :: T Int32 ))+ ,("Int64", p (test :: T Int64 ))++ ,("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 ))++ ,("Char", p (test :: T Char ))++ ,("[()]", 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]) ))++ ,("Maybe Int8", p (test :: T (Maybe Int8) ))+ ,("Either Int8 Int16", p (test :: T (Either Int8 Int16) ))++ ,("(Maybe Word8, Bool, [Int], Either Bool Word8)",+ p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))++ ,("(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)] ))+++-- ,("Lazy IntMap", p (lazyTrip :: T IntSet.IntSet ))+ ,("IntSet", p (test :: T IntSet.IntSet ))+ ,("IntMap ByteString", p (test :: T (IntMap.IntMap B.ByteString) ))++ ,("B.ByteString", p (test :: T B.ByteString ))+ ,("L.ByteString", p (test :: T L.ByteString ))++ ,("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) ))++ ,("Set Word32", p (test :: T (Set.Set Word32) ))+ ,("Map Word16 Int", p (test :: T (Map.Map Word16 Int) ))++ ,("(Maybe Int64, Bool, [Int])", p (test :: T (Maybe Int64, Bool, [Int])))++{-+--+-- Big tuples lack an Arbitrary instance in Hugs/QuickCheck+--++ ,("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",+ p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) ))++ ,("(Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int)", p (roundTrip :: (Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int) -> Bool))++ ,("(Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int)", p (roundTrip :: (Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int) -> Bool))+-}++-- GHC only:+-- ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))++-- Obsolete+-- ,("ensureLeft/Fail", mytest (shouldFail (decode L.empty :: Either ParseError Int)))+ ]
+ tests/QuickCheckUtils.hs view
@@ -0,0 +1,258 @@+{-# 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)
+ tools/derive/BinaryDerive.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS -fglasgow-exts #-}++module BinaryDerive where++import Data.Generics+import Data.List++deriveM :: (Typeable a, Data a) => a -> IO ()+deriveM (a :: a) = mapM_ putStrLn . lines $ derive (undefined :: a)++derive :: (Typeable a, Data a) => a -> String+derive x = + "instance " ++ context ++ "Binary " ++ inst ++ " where\n" +++ concat putDefs ++ getDefs+ where+ context+ | nTypeChildren > 0 =+ wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => "+ | otherwise = ""+ inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters+ wrap x = if nTypeChildren > 0 then "("++x++")" else x + join sep lst = concat $ intersperse sep lst+ nTypeChildren = length typeChildren+ typeLetters = take nTypeChildren manyLetters+ manyLetters = map (:[]) ['a'..'z']+ (typeName,typeChildren) = splitTyConApp (typeOf x)+ constrs :: [(Int, (String, Int))]+ constrs = zip [0..] $ map gen $ dataTypeConstrs (dataTypeOf x)+ gen con = ( showConstr con+ , length $ gmapQ undefined $ fromConstr con `asTypeOf` x+ )+ putDefs = map ((++"\n") . putDef) constrs+ putDef (n, (name, ps)) =+ let wrap = if ps /= 0 then ("("++) . (++")") else id+ pattern = name ++ concatMap (' ':) (take ps manyLetters)+ in+ " put " ++ wrap pattern ++" = "+ ++ concat [ "putWord8 " ++ show n | length constrs > 1 ]+ ++ concat [ " >> " | length constrs > 1 && ps > 0 ]+ ++ concat [ "return ()" | length constrs == 1 && ps == 0 ]+ ++ join " >> " (map ("put "++) (take ps manyLetters))+ getDefs =+ (if length constrs > 1+ then " get = do\n tag_ <- getWord8\n case tag_ of\n"+ else " get =")+ ++ concatMap ((++"\n")) (map getDef constrs) +++ (if length constrs > 1+ then " _ -> fail \"no parse\""+ else ""+ )+ getDef (n, (name, ps)) =+ let wrap = if ps /= 0 then ("("++) . (++")") else id+ in+ concat [ " " ++ show n ++ " ->" | length constrs > 1 ]+ ++ concatMap (\x -> " get >>= \\"++x++" ->") (take ps manyLetters)+ ++ " return "+ ++ wrap (name ++ concatMap (" "++) (take ps manyLetters))
+ tools/derive/Example.hs view
@@ -0,0 +1,68 @@++import Data.Generics++import Data.Binary++import BinaryDerive++data Foo = Bar+ deriving (Typeable, Data, Show, Eq)++instance Binary Main.Foo where+ put Bar = return ()+ get = return Bar++data Color = RGB Int Int Int+ | CMYK Int Int Int Int+ deriving (Typeable, Data, Show, Eq)++instance Binary Main.Color where+ put (RGB a b c) = putWord8 0 >> put a >> put b >> put c+ put (CMYK a b c d) = putWord8 1 >> put a >> put b >> put c >> put d+ get = do+ tag_ <- getWord8+ case tag_ of+ 0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (RGB a b c)+ 1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (CMYK a b c d)++data Computer = Laptop { weight :: Int }+ | Desktop { speed :: Int, memory :: Int }+ deriving (Typeable, Data, Show, Eq)++instance Binary Main.Computer where+ put (Laptop a) = putWord8 0 >> put a+ put (Desktop a b) = putWord8 1 >> put a >> put b+ get = do+ tag_ <- getWord8+ case tag_ of+ 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+ 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+ 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