binary (empty) → 0.2
raw patch · 20 files changed
+4480/−0 lines, 20 filesdep +basebuild-type:Customsetup-changed
Dependencies added: base
Files
- LICENSE +30/−0
- README +34/−0
- Setup.lhs +3/−0
- TODO +28/−0
- binary.cabal +19/−0
- src/Data/Binary.hs +620/−0
- src/Data/Binary/Builder.hs +348/−0
- src/Data/Binary/Get.hs +323/−0
- src/Data/Binary/Put.hs +126/−0
- tests/Benchmark.hs +590/−0
- tests/CBenchmark.c +39/−0
- tests/CBenchmark.h +4/−0
- tests/Makefile +27/−0
- tests/MemBench.hs +85/−0
- tests/NewBenchmark.hs +625/−0
- tests/NewBinary.hs +1006/−0
- tests/QC.hs +203/−0
- tests/QuickCheckUtils.hs +253/−0
- tools/derive/BinaryDerive.hs +49/−0
- tools/derive/Example.hs +68/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) Lennart Kolmodin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,34 @@++ binary: efficient, pure binary serialisation using lazy ByteStrings+------------------------------------------------------------------------++The 'binary' package provides Data.Binary, containing the Binary class,+and associated methods, for serialising values to and from lazy+ByteStrings. ++A key feature of 'binary' is that the interface is both pure, and efficient.++The 'binary' package is portable to GHC and Hugs.++Building:++ runhaskell Setup.hs configure+ runhaskell Setup.hs build+ runhaskell Setup.hs install++First:+ import Data.Binary++and then write an instance of Binary for the type you wish to serialise.+More information in the haddock documentation.++Contributors:++ Lennart Kolmodin+ Duncan Coutts+ Don Stewart+ Spencer Janssen+ David Himmelstrup+ Björn Bringert+ Ross Paterson+ Einar Karttunen
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ 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
+ binary.cabal view
@@ -0,0 +1,19 @@+name: binary+version: 0.2+license: BSD3+license-file: LICENSE+author: Lennart Kolmodin <kolmodin@dtek.chalmers.se>+maintainer: Lennart Kolmodin+description: Efficient, pure binary serialisation using lazy ByteStrings+synopsis: Binary serialization using lazy ByteStrings+category: Data, Parsing+build-depends: base+-- ghc 6.4 also needs package fps+exposed-modules: Data.Binary,+ Data.Binary.Put,+ Data.Binary.Get,+ Data.Binary.Builder+extensions: ForeignFunctionInterface,CPP,FlexibleInstances+hs-source-dirs: src+ghc-options: -O2 -Wall -Werror -fliberate-case-threshold=1000+extra-source-files: README
+ src/Data/Binary.hs view
@@ -0,0 +1,620 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Binary+-- Copyright : Lennart Kolmodin+-- License : BSD3-style (see LICENSE)+-- +-- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>+-- Stability : unstable+-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances+--+-- Binary serialisation of Haskell values to and from lazy ByteStrings.+-- The Binary library provides methods for encoding Haskell values as+-- streams of bytes directly in memory. The resulting @ByteString@ can+-- then be written to disk, sent over the network, or futher processed+-- (for example, compressed with gzip).+--+-- The 'Binary' package is notable in that it provides both pure, and+-- high performance serialisation.+--+-- Values are always encoded in network order (big endian) form, and+-- encoded data should be portable across machine endianess, word size,+-- or compiler version. For example, data encoded using the Binary class+-- could be written from GHC, and read back in Hugs.+--+-----------------------------------------------------------------------------++module Data.Binary (++ -- * The Binary class+ Binary(..)++ -- $example++ -- * The Get and Put monads+ , Get+ , Put++ -- * Useful helpers for writing instances+ , putWord8+ , getWord8++ -- * Binary serialisation+ , encode -- :: Binary a => a -> ByteString+ , decode -- :: Binary a => ByteString -> a++ -- * IO functions for serialisation+ , encodeFile -- :: Binary a => FilePath -> a -> IO ()+ , decodeFile -- :: Binary a => FilePath -> IO a++-- Lazy put and get+-- , lazyPut+-- , lazyGet++ , module Data.Word -- useful++ ) where++import Data.Word++import Data.Binary.Put+import Data.Binary.Get++import Control.Monad+import Foreign+import System.IO++import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as L++import Data.Char (chr,ord)+import Data.List (unfoldr)++-- And needed for the instances:+import qualified Data.ByteString as B+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.Tree as T++import Data.Array.Unboxed++--+-- This isn't available in older Hugs or older GHC+--+#if __GLASGOW_HASKELL__ >= 606+import qualified Data.Sequence as Seq+#endif++------------------------------------------------------------------------++-- | The @Binary@ class provides 'put' and 'get', methods to encode and+-- decode a Haskell value to a lazy ByteString. It mirrors the Read and+-- 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+-- structures), Binary may be used, but in general is not suitable+-- for complex protocols. Instead use the Put and Get primitives+-- directly.+--+-- Instances of Binary should satisfy the following property:+--+-- > get . put == id+--+-- A range of instances are provided for basic Haskell types. +--+class Binary t where+ -- | Encode a value in the Put monad.+ put :: t -> Put+ -- | Decode a value in the Get monad+ get :: Get t++-- $example+-- To serialise a custom type, an instance of Binary for that type is+-- required. For example, suppose we have a data structure:+--+-- > data Exp = IntE Int+-- > | OpE String Exp Exp+-- > deriving Show+--+-- We can encode values of this type into bytestrings using the+-- following instance, which proceeds by recursively breaking down the+-- structure to serialise:+--+-- > instance Binary Exp where+-- > put (IntE i) = do put (0 :: Word8)+-- > put i+-- > put (OpE s e1 e2) = do put (1 :: Word8)+-- > put s+-- > put e1+-- > put e2+-- > +-- > get = do t <- get :: Get Word8+-- > case t of+-- > 0 -> do i <- get+-- > return (IntE i)+-- > 1 -> do s <- get+-- > e1 <- get+-- > e2 <- get+-- > return (OpE s e1 e2)+--+-- Note how we write an initial tag byte to indicate each variant of the+-- data type.+--+-- To serialise this to a bytestring, we use 'encode', which packs the+-- data structure into a binary format, in a lazy bytestring+--+-- > > let e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))+-- > > let v = encode e+--+-- Where 'v' is a binary encoded data structure. To reconstruct the+-- original data, we use 'decode'+--+-- > > decode v :: Exp+-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))+--+-- The lazy ByteString that results from 'encode' can be written to+-- disk, and read from disk using Data.ByteString.Lazy IO functions,+-- such as hPutStr or writeFile:+--+-- > > writeFile "/tmp/exp.txt" (encode e)+--+-- And read back with:+--+-- > > readFile "/tmp/exp.txt" >>= return . decode :: IO Exp+-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))+--+-- We can also directly serialise a value to and from a Handle, or a file:+-- +-- > > v <- decodeFile "/tmp/exp.txt" :: IO Exp+-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))+--+-- And write a value to disk+--+-- > > encodeFile "/tmp/a.txt" v+--++------------------------------------------------------------------------+-- Wrappers to run the underlying monad++-- | Encode a value using binary serialisation to a lazy ByteString.+--+encode :: Binary a => a -> ByteString+encode = runPut . put+{-# INLINE encode #-}++-- | Decode a value from a lazy ByteString, reconstructing the original structure.+--+decode :: Binary a => ByteString -> a+decode = runGet get++------------------------------------------------------------------------+-- Convenience IO operations++-- | Lazily serialise a value to a file+--+-- This is just a convenience function, it's defined simply as:+--+-- > encodeFile f = B.writeFile f . encode+--+-- So for example if you wanted to compress as well, you could use:+--+-- > B.writeFile f . compress . encode+--+encodeFile :: Binary a => FilePath -> a -> IO ()+encodeFile f v = L.writeFile f (encode v)++-- | Lazily reconstruct a value previously written to a file+--+-- This is just a convenience function, it's defined simply as:+--+-- > decodeFile f = return . decode =<< B.readFile f+--+-- So for example if you wanted to decompress as well, you could use:+--+-- > return . decode . decompress =<< B.readFile f+--+decodeFile :: Binary a => FilePath -> IO a+decodeFile f = liftM decode (L.readFile f)++------------------------------------------------------------------------+-- Lazy put and get++-- lazyPut :: (Binary a) => a -> Put+-- lazyPut a = put (encode a)++-- lazyGet :: (Binary a) => Get a+-- lazyGet = fmap decode get++------------------------------------------------------------------------+-- Simple instances++-- The () type need never be written to disk: values of singleton type+-- can be reconstructed from the type alone+instance Binary () where+ put () = return ()+ get = return ()++-- Bools are encoded as a byte in the range 0 .. 1+instance Binary Bool where+ put = putWord8 . fromIntegral . fromEnum+ get = liftM (toEnum . fromIntegral) getWord8++-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2+instance Binary Ordering where+ put = putWord8 . fromIntegral . fromEnum+ get = liftM (toEnum . fromIntegral) getWord8++------------------------------------------------------------------------+-- Words and Ints++-- Words8s are written as bytes+instance Binary Word8 where+ put = putWord8+ get = getWord8++-- Words16s are written as 2 bytes in big-endian (network) order+instance Binary Word16 where+ put = putWord16be+ get = getWord16be++-- Words32s are written as 4 bytes in big-endian (network) order+instance Binary Word32 where+ put = putWord32be+ get = getWord32be++-- Words64s are written as 8 bytes in big-endian (network) order+instance Binary Word64 where+ put = putWord64be+ get = getWord64be++-- Int8s are written as a single byte.+instance Binary Int8 where+ put i = put (fromIntegral i :: Word8)+ get = liftM fromIntegral (get :: Get Word8)++-- Int16s are written as a 2 bytes in big endian format+instance Binary Int16 where+ put i = put (fromIntegral i :: Word16)+ get = liftM fromIntegral (get :: Get Word16)++-- Int32s are written as a 4 bytes in big endian format+instance Binary Int32 where+ put i = put (fromIntegral i :: Word32)+ get = liftM fromIntegral (get :: Get Word32)++-- Int64s are written as a 4 bytes in big endian format+instance Binary Int64 where+ put i = put (fromIntegral i :: Word64)+ get = liftM fromIntegral (get :: Get Word64)++------------------------------------------------------------------------++-- Words are are written as Word64s, that is, 8 bytes in big endian format+instance Binary Word where+ put i = put (fromIntegral i :: Word64)+ get = liftM fromIntegral (get :: Get Word64)++-- Ints are are written as Int64s, that is, 8 bytes in big endian format+instance Binary Int where+ put i = put (fromIntegral i :: Int64)+ get = liftM fromIntegral (get :: Get Int64)++------------------------------------------------------------------------+-- +-- Portable, and pretty efficient, serialisation of Integer+--++-- Fixed-size type for a subset of Integer+type SmallInt = Int32++-- Integers are encoded in two ways: if they fit inside a SmallInt,+-- they're written as a byte tag, and that value. If the Integer value+-- is too large to fit in a SmallInt, it is written as a byte array,+-- along with a sign and length field.++instance Binary Integer where++ put n | n >= lo && n <= hi = do+ putWord8 0+ put (fromIntegral n :: SmallInt) -- fast path+ where+ lo = fromIntegral (minBound :: SmallInt) :: Integer+ hi = fromIntegral (maxBound :: SmallInt) :: Integer++ put n = do+ putWord8 1+ put sign+ put (unroll (abs n)) -- unroll the bytes+ where+ sign = fromIntegral (signum n) :: Word8++ get = do+ tag <- get :: Get Word8+ case tag of+ 0 -> liftM fromIntegral (get :: Get SmallInt)+ _ -> do sign <- get+ bytes <- get+ let v = roll bytes+ return $! if sign == (1 :: Word8) then v else - v++--+-- Fold and unfold an Integer to and from a list of its bytes+--+unroll :: Integer -> [Word8]+unroll = unfoldr step+ where+ step 0 = Nothing+ step i = Just (fromIntegral i, i `shiftR` 8)++roll :: [Word8] -> Integer+roll = foldr unstep 0+ where+ unstep b a = a `shiftL` 8 .|. fromIntegral b++{-++--+-- An efficient, raw serialisation for Integer (GHC only)+--++-- TODO This instance is not architecture portable. GMP stores numbers as+-- arrays of machine sized words, so the byte format is not portable across+-- architectures with different endianess and word size.++import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)+import GHC.Base hiding (ord, chr)+import GHC.Prim+import GHC.Ptr (Ptr(..))+import GHC.IOBase (IO(..))++instance Binary Integer where+ put (S# i) = putWord8 0 >> put (I# i)+ put (J# s ba) = do+ putWord8 1+ put (I# s)+ put (BA ba)++ get = do+ b <- getWord8+ case b of+ 0 -> do (I# i#) <- get+ return (S# i#)+ _ -> do (I# s#) <- get+ (BA a#) <- get+ return (J# s# a#)++instance Binary ByteArray where++ -- Pretty safe.+ put (BA ba) =+ let sz = sizeofByteArray# ba -- (primitive) in *bytes*+ addr = byteArrayContents# ba+ bs = unsafePackAddress (I# sz) addr+ in put bs -- write as a ByteString. easy, yay!++ -- Pretty scary. Should be quick though+ get = do+ (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString+ assert (off == 0) $ return $ unsafePerformIO $ do+ (MBA arr) <- newByteArray sz -- and copy it into a ByteArray#+ let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?+ withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)+ freezeByteArray arr++-- wrapper for ByteArray#+data ByteArray = BA {-# UNPACK #-} !ByteArray#+data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)++newByteArray :: Int# -> IO MBA+newByteArray sz = IO $ \s ->+ case newPinnedByteArray# sz s of { (# s', arr #) ->+ (# s', MBA arr #) }++freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray+freezeByteArray arr = IO $ \s ->+ case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->+ (# s', BA arr' #) }++-}++------------------------------------------------------------------------++-- Char is serialised as UTF-8+instance Binary Char where+ put a | c <= 0x7f = put (fromIntegral c :: Word8)+ | c <= 0x7ff = do put (0xc0 .|. y)+ put (0x80 .|. z)+ | c <= 0xffff = do put (0xe0 .|. x)+ put (0x80 .|. y)+ put (0x80 .|. z)+ | c <= 0x10ffff = do put (0xf0 .|. w)+ put (0x80 .|. x)+ put (0x80 .|. y)+ put (0x80 .|. z)+ | otherwise = error "Not a valid Unicode code point"+ where+ c = ord a+ z, y, x, w :: Word8+ z = fromIntegral (c .&. 0x3f)+ y = fromIntegral (shiftR c 6 .&. 0x3f)+ x = fromIntegral (shiftR c 12 .&. 0x3f)+ w = fromIntegral (shiftR c 18 .&. 0x7)++ get = do+ let getByte = liftM (fromIntegral :: Word8 -> Int) get+ shiftL6 = flip shiftL 6 :: Int -> Int+ w <- getByte+ r <- case () of+ _ | w < 0x80 -> return w+ | w < 0xe0 -> do+ x <- liftM (xor 0x80) getByte+ return (x .|. shiftL6 (xor 0xc0 w))+ | w < 0xf0 -> do+ x <- liftM (xor 0x80) getByte+ y <- liftM (xor 0x80) getByte+ return (y .|. shiftL6 (x .|. shiftL6+ (xor 0xe0 w)))+ | otherwise -> do+ x <- liftM (xor 0x80) getByte+ y <- liftM (xor 0x80) getByte+ z <- liftM (xor 0x80) getByte+ return (z .|. shiftL6 (y .|. shiftL6+ (x .|. shiftL6 (xor 0xf0 w))))+ return $! chr r++------------------------------------------------------------------------+-- Instances for the first few tuples++instance (Binary a, Binary b) => Binary (a,b) where+ put (a,b) = put a >> put b+ get = liftM2 (,) get get++instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+ put (a,b,c) = put a >> put b >> put c+ get = liftM3 (,,) get get get++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+ put (a,b,c,d) = put a >> put b >> put c >> put d+ get = liftM4 (,,,) get get get get++instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where+ put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e+ get = liftM5 (,,,,) get get get get get++-- +-- and now just recurse:+--++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)+ => Binary (a,b,c,d,e,f) where+ put (a,b,c,d,e,f) = put (a,(b,c,d,e,f))+ get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)+ => Binary (a,b,c,d,e,f,g) where+ put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))+ get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+ Binary f, Binary g, Binary h)+ => Binary (a,b,c,d,e,f,g,h) where+ put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))+ get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+ Binary f, Binary g, Binary h, Binary i)+ => Binary (a,b,c,d,e,f,g,h,i) where+ put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))+ get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+ Binary f, Binary g, Binary h, Binary i, Binary j)+ => Binary (a,b,c,d,e,f,g,h,i,j) where+ put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))+ get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)++------------------------------------------------------------------------+-- Container types++instance Binary a => Binary [a] where+ put l = put (length l) >> mapM_ put l+ get = do n <- get :: Get Int+ replicateM n get++instance (Binary a) => Binary (Maybe a) where+ put Nothing = putWord8 0+ put (Just x) = putWord8 1 >> put x+ get = do+ w <- getWord8+ case w of+ 0 -> return Nothing+ _ -> liftM Just get++instance (Binary a, Binary b) => Binary (Either a b) where+ put (Left a) = putWord8 0 >> put a+ put (Right b) = putWord8 1 >> put b+ get = do+ w <- getWord8+ case w of+ 0 -> liftM Left get+ _ -> liftM Right get++------------------------------------------------------------------------+-- ByteStrings (have specially efficient instances)++instance Binary B.ByteString where+ put bs = do put (B.length bs)+ putByteString bs+ get = get >>= getByteString++--+-- Using old versions of fps, this is a type synonym, and non portable+-- +-- Requires 'flexible instances'+--+instance Binary ByteString where+ put bs = do put (fromIntegral (L.length bs) :: Int)+ putLazyByteString bs+ get = get >>= getLazyByteString++------------------------------------------------------------------------+-- Maps and Sets++instance (Ord a, Binary a) => Binary (Set.Set a) where+ put = put . Set.toAscList+ get = liftM Set.fromDistinctAscList get++instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where+ put = put . Map.toAscList+ get = liftM Map.fromDistinctAscList get++instance Binary IntSet.IntSet where+ put = put . IntSet.toAscList+ get = liftM IntSet.fromDistinctAscList get++instance (Binary e) => Binary (IntMap.IntMap e) where+ put = put . IntMap.toAscList+ get = liftM IntMap.fromDistinctAscList get++------------------------------------------------------------------------+-- Queues and Sequences++#if __GLASGOW_HASKELL__ >= 606+--+-- This is valid Hugs, but you need the most recent Hugs+--++instance (Binary e) => Binary (Seq.Seq e) where+ -- any better way to do this?+ put s = put . flip unfoldr s $ \sq ->+ case Seq.viewl sq of+ Seq.EmptyL -> Nothing+ (Seq.:<) e sq' -> Just (e,sq')+ get = fmap Seq.fromList get++#endif++------------------------------------------------------------------------+-- Trees++instance (Binary e) => Binary (T.Tree e) where+ put (T.Node r s) = put r >> put s+ get = liftM2 T.Node get get++------------------------------------------------------------------------+-- Arrays++instance (Binary i, Ix i, Binary e) => Binary (Array i e) where+ put a = put (bounds a) >> put (elems a)+ get = liftM2 listArray get get++--+-- The IArray UArray e constraint is non portable. Requires flexible instances+--+instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where+ put a = put (bounds a) >> put (elems a)+ get = liftM2 listArray get get
+ src/Data/Binary/Builder.hs view
@@ -0,0 +1,348 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-- for unboxed shifts++-----------------------------------------------------------------------------+-- |+-- Module : Data.Binary.Builder+-- Copyright : Lennart Kolmodin, Ross Paterson+-- License : BSD3-style (see LICENSE)+-- +-- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>+-- Stability : experimental+-- Portability : portable to Hugs and GHC+--+-- Efficient construction of lazy bytestrings.+--+-----------------------------------------------------------------------------++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#include "MachDeps.h"+#endif++module Data.Binary.Builder (++ -- * The Builder type+ Builder+ , toLazyByteString++ -- * Constructing Builders+ , empty+ , singleton+ , append+ , fromByteString -- :: S.ByteString -> Builder+ , fromLazyByteString -- :: L.ByteString -> Builder++ -- * Flushing the buffer state+ , flush++ -- * Derived Builders+ -- ** Big-endian writes+ , putWord16be -- :: Word16 -> Builder+ , putWord32be -- :: Word32 -> Builder+ , putWord64be -- :: Word64 -> Builder++ -- ** Little-endian writes+ , putWord16le -- :: Word16 -> Builder+ , putWord32le -- :: Word32 -> Builder+ , putWord64le -- :: Word64 -> Builder++ ) where++import Foreign+import Data.Monoid+import Data.Word+import Data.ByteString.Base (inlinePerformIO)+import qualified Data.ByteString as S+import qualified Data.ByteString.Base as S+import qualified Data.ByteString.Lazy as L++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base+import GHC.Word (Word32(..),Word16(..),Word64(..))+#endif++------------------------------------------------------------------------++-- | A 'Builder' is an efficient way to build lazy 'L.ByteString's.+-- There are several functions for constructing 'Builder's, but only one+-- to inspect them: to extract any data, you have to turn them into lazy+-- 'L.ByteString's using 'toLazyByteString'.+--+-- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte+-- arrays piece by piece. As each buffer is filled, it is \'popped\'+-- off, to become a new chunk of the resulting lazy 'L.ByteString'.+-- All this is hidden from the user of the 'Builder'.++newtype Builder = Builder {+ -- Invariant (from Data.ByteString.Lazy):+ -- The lists include no null ByteStrings.+ runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]+ }++instance Monoid Builder where+ mempty = empty+ mappend = append++------------------------------------------------------------------------++-- | /O(1)./ The empty Builder, satisfying+--+-- * @'toLazyByteString' 'empty' = 'L.empty'@+--+empty :: Builder+empty = Builder id++-- | /O(1)./ A Builder taking a single byte, satisfying+--+-- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@+--+singleton :: Word8 -> Builder+singleton = writeN 1 . flip poke+{-# INLINE singleton #-}++------------------------------------------------------------------------++-- | /O(1)./ The concatenation of two Builders, an associative operation+-- with identity 'empty', satisfying+--+-- * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@+--+append :: Builder -> Builder -> Builder+append (Builder f) (Builder g) = Builder (f . g)++-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying+--+-- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@+--+fromByteString :: S.ByteString -> Builder+fromByteString bs+ | S.null bs = empty+ | otherwise = flush `append` mapBuilder (bs :)++-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying+--+-- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@+--+fromLazyByteString :: L.ByteString -> Builder+fromLazyByteString (S.LPS []) = empty+fromLazyByteString (S.LPS bss) = flush `append` mapBuilder (bss ++)++------------------------------------------------------------------------++-- Our internal buffer type+data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)+ {-# UNPACK #-} !Int -- offset+ {-# UNPACK #-} !Int -- used bytes+ {-# UNPACK #-} !Int -- length left++------------------------------------------------------------------------++-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'.+-- The construction work takes place if and when the relevant part of+-- the lazy 'L.ByteString' is demanded.+--+toLazyByteString :: Builder -> L.ByteString+toLazyByteString m = S.LPS $ inlinePerformIO $ do+ buf <- newBuffer defaultSize+ return (runBuilder (m `append` flush) (const []) buf)++-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any,+-- yielding a new chunk in the result lazy 'L.ByteString'.+flush :: Builder+flush = Builder $ \ k buf@(Buffer p o u l) ->+ if u == 0+ then k buf+ else S.PS p o u : k (Buffer p (o+u) 0 l)++------------------------------------------------------------------------++--+-- copied from Data.ByteString.Lazy+--+defaultSize :: Int+defaultSize = 32 * k - overhead+ where k = 1024+ overhead = 2 * sizeOf (undefined :: Int)++------------------------------------------------------------------------++-- | Sequence an IO operation on the buffer+unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder+unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do+ buf' <- f buf+ return (k buf')+{-# INLINE unsafeLiftIO #-}++-- | Get the size of the buffer+withSize :: (Int -> Builder) -> Builder+withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->+ runBuilder (f l) k buf++-- | Map the resulting list of bytestrings.+mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder+mapBuilder f = Builder (f .)++------------------------------------------------------------------------++-- | Ensure that there are at least @n@ many bytes available.+ensureFree :: Int -> Builder+ensureFree n = n `seq` withSize $ \ l ->+ if n <= l then empty else+ flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))+{-# INLINE ensureFree #-}++-- | Ensure that @n@ many bytes are available, and then use @f@ to write some+-- bytes into the memory.+writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder+writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)+{-# INLINE [1] writeN #-}++writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer+writeNBuffer n f (Buffer fp o u l) = do+ withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))+ return (Buffer fp o (u+n) (l-n))+{-# INLINE writeNBuffer #-}++newBuffer :: Int -> IO Buffer+newBuffer size = do+ fp <- S.mallocByteString size+ return $! Buffer fp 0 0 size++------------------------------------------------------------------------++--+-- We rely on the fromIntegral to do the right masking for us.+-- The inlining here is critical, and can be worth 4x performance+--++-- | Write a Word16 in big endian format+putWord16be :: Word16 -> Builder+putWord16be w = writeN 2 $ \p -> do+ poke p (fromIntegral (shiftr_w16 w 8) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (w) :: Word8)+{-# INLINE putWord16be #-}++-- | Write a Word16 in little endian format+putWord16le :: Word16 -> Builder+putWord16le w = writeN 2 $ \p -> do+ poke p (fromIntegral (w) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8)+{-# INLINE putWord16le #-}++-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16)++-- | Write a Word32 in big endian format+putWord32be :: Word32 -> Builder+putWord32be w = writeN 4 $ \p -> do+ poke p (fromIntegral (shiftr_w32 w 24) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (w) :: Word8)+{-# INLINE putWord32be #-}++--+-- a data type to tag Put/Check. writes construct these which are then+-- inlined and flattened. matching Checks will be more robust with rules.+--++-- | Write a Word32 in little endian format+putWord32le :: Word32 -> Builder+putWord32le w = writeN 4 $ \p -> do+ poke p (fromIntegral (w) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8)+{-# INLINE putWord32le #-}++-- on a little endian machine:+-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32)++-- | Write a Word64 in big endian format+putWord64be :: Word64 -> Builder+#if WORD_SIZE_IN_BITS < 64+--+-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to+-- Word32, and write that+--+putWord64be w =+ let a = fromIntegral (shiftr_w64 w 32) :: Word32+ b = fromIntegral w :: Word32+ in writeN 8 $ \p -> do+ poke p (fromIntegral (shiftr_w32 a 24) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (a) :: Word8)+ poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8)+ poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8)+ poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8)+ poke (p `plusPtr` 7) (fromIntegral (b) :: Word8)+#else+putWord64be w = writeN 8 $ \p -> do+ poke p (fromIntegral (shiftr_w64 w 56) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8)+ poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8)+ poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8)+ poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8)+ poke (p `plusPtr` 7) (fromIntegral (w) :: Word8)+#endif+{-# INLINE putWord64be #-}++-- | Write a Word64 in little endian format+putWord64le :: Word64 -> Builder++#if WORD_SIZE_IN_BITS < 64+putWord64le w =+ let b = fromIntegral (shiftr_w64 w 32) :: Word32+ a = fromIntegral w :: Word32+ in writeN 8 $ \p -> do+ poke (p) (fromIntegral (a) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8)+ poke (p `plusPtr` 4) (fromIntegral (b) :: Word8)+ poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8)+ poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8)+ poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8)+#else+putWord64le w = writeN 8 $ \p -> do+ poke p (fromIntegral (w) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8)+ poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8)+ poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8)+ poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8)+ poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8)+#endif+{-# INLINE putWord64le #-}++-- on a little endian machine:+-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)++------------------------------------------------------------------------+-- Unchecked shifts++shiftr_w16 :: Word16 -> Int -> Word16+shiftr_w32 :: Word32 -> Int -> Word32+shiftr_w64 :: Word64 -> Int -> Word64++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)+shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)++#if WORD_SIZE_IN_BITS < 64+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)++foreign import ccall unsafe "stg_uncheckedShiftRL64" + uncheckedShiftRL64# :: Word64# -> Int# -> Word64#+#else+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)+#endif++#else+shiftr_w16 = shiftR+shiftr_w32 = shiftR+shiftr_w64 = shiftR+#endif
+ src/Data/Binary/Get.hs view
@@ -0,0 +1,323 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+-- for unboxed shifts++-----------------------------------------------------------------------------+-- |+-- Module : Data.Binary.Get+-- Copyright : Lennart Kolmodin+-- License : BSD3-style (see LICENSE)+-- +-- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>+-- Stability : experimental+-- Portability : portable to Hugs and GHC.+--+-- The Get monad. A monad for efficiently building structures from+-- encoded lazy ByteStrings+--+-----------------------------------------------------------------------------++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#include "MachDeps.h"+#endif++module Data.Binary.Get (++ -- * The Get type+ Get+ , runGet++ -- * Parsing+ , skip+ , uncheckedSkip+ , lookAhead+ , lookAheadM+ , lookAheadE+ , uncheckedLookAhead+ , getBytes+ , remaining+ , isEmpty++ -- * Parsing particular types+ , getWord8++ -- ** ByteStrings+ , getByteString+ , getLazyByteString++ -- ** Big-endian reads+ , getWord16be+ , getWord16le+ , getWord32be++ -- ** Little-endian reads+ , getWord32le+ , getWord64be+ , getWord64le++ ) where++import Control.Monad (liftM,when)+import Data.Maybe (isNothing)++import qualified Data.ByteString as B+import qualified Data.ByteString.Base as B+import qualified Data.ByteString.Lazy as L++import Foreign++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base+import GHC.Word+import GHC.Int+#endif++-- | The parse state+data S = S {-# UNPACK #-} !L.ByteString -- the rest of the input+ {-# UNPACK #-} !Int64 -- bytes read++-- | The Get monad is just a State monad carrying around the input ByteString+newtype Get a = Get { unGet :: S -> (a, S ) }++instance Functor Get where+ fmap f m = Get (\s -> let (a, s') = unGet m s+ in (f a, s'))++instance Monad Get where+ return a = Get (\s -> (a, s))+ m >>= k = Get (\s -> let (a, s') = unGet m s+ in unGet (k a) s')+ fail = failDesc++------------------------------------------------------------------------++get :: Get S+get = Get (\s -> (s, s))++put :: S -> Get ()+put s = Get (\_ -> ((), s))++------------------------------------------------------------------------++-- | 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 (S str 0) of (a, _) -> a++------------------------------------------------------------------------++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 n (const ())++-- | Skip ahead @n@ bytes. +uncheckedSkip :: Int -> Get ()+uncheckedSkip n = do+ S s bytes <- get+ let rest = L.drop (fromIntegral n) s+ put $! S rest (bytes + (fromIntegral n))+ return ()++-- | Run @ga@, but return withou 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 @g@ 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 @g@ 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 :: Int -> Get L.ByteString+uncheckedLookAhead n = do+ S s _ <- get+ return $ L.take (fromIntegral n) s++-- | 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 _ <- get+ return (L.length s)++-- | Test whether all input has been consumed,+-- i.e. there are no remaining unparsed bytes.+isEmpty :: Get Bool+isEmpty = do+ S s _ <- get+ return (L.null s)++------------------------------------------------------------------------+-- Helpers++-- Fail if the ByteString does not have the right size.+takeExactly :: Int -> L.ByteString -> Get L.ByteString+takeExactly n bs+ | l == n = return bs+ | otherwise = fail $ concat [ "Data.Binary.Get.takeExactly: Wanted "+ , show n, " bytes, found ", show l, "." ]+ where l = fromIntegral (L.length bs)+{-# INLINE takeExactly #-}++-- | Pull up to @n@ bytes from the input. +getBytes :: Int -> Get L.ByteString+getBytes n = do+ S s bytes <- get+ let (consuming, rest) = L.splitAt (fromIntegral n) s+ put $! S rest (bytes + (fromIntegral n))+ return consuming+{-# INLINE getBytes #-}+-- ^ important++-- Pull n bytes from the input, and apply a parser to those bytes,+-- yielding a value+readN :: Int -> (L.ByteString -> a) -> Get a+readN n f = liftM f (getBytes n >>= takeExactly n)+{-# INLINE readN #-}+-- ^ important++------------------------------------------------------------------------++-- | An efficient 'get' method for strict ByteStrings+getByteString :: Int -> Get B.ByteString+getByteString n = readN (fromIntegral n) (B.concat . L.toChunks)+{-# INLINE getByteString #-}++-- | An efficient 'get' method for lazy ByteStrings. Fails if fewer than+-- @n@ bytes are left in the input.+getLazyByteString :: Int -> Get L.ByteString+getLazyByteString n = readN n id+{-# INLINE getLazyByteString #-}++------------------------------------------------------------------------+-- Primtives++-- | Read a Word8 from the monad state+getWord8 :: Get Word8+getWord8 = readN 1 L.head+{-# INLINE getWord8 #-}++-- | Read a Word16 in big endian format+getWord16be :: Get Word16+getWord16be = do+ s <- readN 2 (L.take 2)+ return $! (fromIntegral (s `L.index` 0) `shiftl_w16` 8) .|.+ (fromIntegral (s `L.index` 1))+{-# INLINE getWord16be #-}++-- | Read a Word16 in little endian format+getWord16le :: Get Word16+getWord16le = do+ w1 <- liftM fromIntegral getWord8+ w2 <- liftM fromIntegral getWord8+ return $! w2 `shiftl_w16` 8 .|. w1+{-# INLINE getWord16le #-}++-- | Read a Word32 in big endian format+getWord32be :: Get Word32+getWord32be = do+ s <- readN 4 (L.take 4)+ return $! (fromIntegral (s `L.index` 0) `shiftl_w32` 24) .|.+ (fromIntegral (s `L.index` 1) `shiftl_w32` 16) .|.+ (fromIntegral (s `L.index` 2) `shiftl_w32` 8) .|.+ (fromIntegral (s `L.index` 3) )+{-# INLINE getWord32be #-}++-- | Read a Word32 in little endian format+getWord32le :: Get Word32+getWord32le = do+ w1 <- liftM fromIntegral getWord8+ w2 <- liftM fromIntegral getWord8+ w3 <- liftM fromIntegral getWord8+ w4 <- liftM fromIntegral getWord8+ return $! (w4 `shiftl_w32` 24) .|.+ (w3 `shiftl_w32` 16) .|.+ (w2 `shiftl_w32` 8) .|.+ (w1)+{-# INLINE getWord32le #-}++-- | Read a Word64 in big endian format+getWord64be :: Get Word64+getWord64be = do+ s <- readN 8 (L.take 8)+ return $! (fromIntegral (s `L.index` 0) `shiftl_w64` 56) .|.+ (fromIntegral (s `L.index` 1) `shiftl_w64` 48) .|.+ (fromIntegral (s `L.index` 2) `shiftl_w64` 40) .|.+ (fromIntegral (s `L.index` 3) `shiftl_w64` 32) .|.+ (fromIntegral (s `L.index` 4) `shiftl_w64` 24) .|.+ (fromIntegral (s `L.index` 5) `shiftl_w64` 16) .|.+ (fromIntegral (s `L.index` 6) `shiftl_w64` 8) .|.+ (fromIntegral (s `L.index` 7) )+{-# INLINE getWord64be #-}++-- | Read a Word64 in little endian format+getWord64le :: Get Word64+getWord64le = do+ w1 <- liftM fromIntegral getWord8+ w2 <- liftM fromIntegral getWord8+ w3 <- liftM fromIntegral getWord8+ w4 <- liftM fromIntegral getWord8+ w5 <- liftM fromIntegral getWord8+ w6 <- liftM fromIntegral getWord8+ w7 <- liftM fromIntegral getWord8+ w8 <- liftM fromIntegral getWord8+ return $! (w8 `shiftl_w64` 56) .|.+ (w7 `shiftl_w64` 48) .|.+ (w6 `shiftl_w64` 40) .|.+ (w5 `shiftl_w64` 32) .|.+ (w4 `shiftl_w64` 24) .|.+ (w3 `shiftl_w64` 16) .|.+ (w2 `shiftl_w64` 8) .|.+ (w1)+{-# INLINE getWord64le #-}++------------------------------------------------------------------------+-- Unchecked shifts++shiftl_w16 :: Word16 -> Int -> Word16+shiftl_w32 :: Word32 -> Int -> Word32+shiftl_w64 :: Word64 -> Int -> Word64++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)++#if WORD_SIZE_IN_BITS < 64+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)++foreign import ccall unsafe "stg_uncheckedShiftL64" + uncheckedShiftL64# :: Word64# -> Int# -> Word64#+#else+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)+#endif++#else+shiftl_w16 = shiftL+shiftl_w32 = shiftL+shiftl_w64 = shiftL+#endif
+ src/Data/Binary/Put.hs view
@@ -0,0 +1,126 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Binary.Put+-- Copyright : Lennart Kolmodin+-- License : BSD3-style (see LICENSE)+-- +-- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>+-- Stability : stable+-- Portability : Portable to Hugs and GHC. Requires MPTCs+--+-- The Put monad. A monad for efficiently constructing lazy bytestrings.+--+-----------------------------------------------------------------------------++module Data.Binary.Put (++ -- * The Put type+ Put+ , runPut++ -- * Flushing the implicit parse state+ , flush++ -- * Primitives+ , putWord8+ , putByteString+ , putLazyByteString++ -- * Big-endian primitives+ , putWord16be+ , putWord32be+ , putWord64be++ -- * Little-endian primitives+ , putWord16le+ , putWord32le+ , putWord64le++ ) where++import Data.Binary.Builder (Builder, toLazyByteString)+import qualified Data.Binary.Builder as B++import Data.Word+import qualified Data.ByteString.Base as S+import qualified Data.ByteString.Lazy as L++------------------------------------------------------------------------++-- | The Put types. A Writer monad over the efficient Builder monoid.+-- Put merely lifts Builder into a monad+newtype PutM a = Put { unPut :: (a, Builder) }+type Put = PutM ()++instance Functor PutM where+ fmap f m = Put (let (a, w) = unPut m+ in (f a, w))++instance Monad PutM where+ return a = Put (a, B.empty)++ m >>= k = Put (let (a, w) = unPut m+ (b, w') = unPut (k a)+ in (b, w `B.append` w'))++ m1 >> m2 = Put (let (_, w) = unPut m1+ (b, w') = unPut m2+ in (b, w `B.append` w'))+ {-# INlINE (>>) #-}++tell :: Builder -> Put+tell b = Put ((), b)+{-# INlINE tell #-}++-- | Run the 'Put' monad with a serialiser+runPut :: Put -> L.ByteString+runPut = toLazyByteString . snd . unPut+{-# INLINE runPut #-}++-- | Pop the ByteString we have constructed so far, if any, yielding a+-- new chunk in the result ByteString.+flush :: Put+flush = tell B.flush++-- | Efficiently write a byte into the output buffer+putWord8 :: Word8 -> Put+putWord8 = tell . B.singleton+{-# INLINE putWord8 #-}++-- | An efficient primitive to write a strict ByteString into the output buffer.+-- It flushes the current buffer, and writes the argument into a new chunk.+putByteString :: S.ByteString -> Put+putByteString = tell . B.fromByteString++-- | Write a lazy ByteString efficiently, simply appending the lazy+-- ByteString chunks to the output buffer+putLazyByteString :: L.ByteString -> Put+putLazyByteString = tell . B.fromLazyByteString++-- | Write a Word16 in big endian format+putWord16be :: Word16 -> Put+putWord16be = tell . B.putWord16be++-- | Write a Word16 in little endian format+putWord16le :: Word16 -> Put+putWord16le = tell . B.putWord16le++-- | Write a Word32 in big endian format+putWord32be :: Word32 -> Put+putWord32be = tell . B.putWord32be+{-# INLINE putWord32be #-}++-- | Write a Word32 in little endian format+putWord32le :: Word32 -> Put+putWord32le = tell . B.putWord32le+{-# INLINE putWord32le #-}++-- | Write a Word64 in big endian format+putWord64be :: Word64 -> Put+putWord64be = tell . B.putWord64be+{-# INLINE putWord64be #-}++-- | Write a Word64 in little endian format+putWord64le :: Word64 -> Put+putWord64le = tell . B.putWord64le+{-# INLINE putWord64le #-}
+ tests/Benchmark.hs view
@@ -0,0 +1,590 @@+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 MemBench++mb :: Int+mb = 10++main :: IO ()+main = do+ memBench (mb*10)+ putStrLn ""+ putStrLn "Binary (de)serialisation benchmarks:"+ sequence_+ [ test wordSize chunkSize mb+ | wordSize <- [1,2,4,8]+ , chunkSize <- [1,2,4,8,16] ]++time :: IO a -> IO Double+time action = do+ start <- getCPUTime+ action+ end <- getCPUTime+ return $! (fromIntegral (end - start)) / (10^12)++test :: Int -> Int -> Int -> IO ()+test wordSize chunkSize mb = do+ let bytes :: Int+ bytes = mb * 2^20+ iterations = bytes `div` wordSize+ bs = runPut (doPut wordSize chunkSize iterations)+ sum = runGet (doGet wordSize chunkSize iterations) bs+ putStr $ show mb ++ "MB of Word" ++ show (8 * wordSize)+ ++ " in chunks of " ++ show chunkSize ++ ": "+ putSeconds <- time $ evaluate (L.length bs)+ getSeconds <- time $ evaluate sum+-- print (L.length bs, sum)+ let putThroughput = fromIntegral mb / putSeconds+ getThroughput = fromIntegral mb / getSeconds+ putStrLn $ showFFloat (Just 1) putThroughput "MB/s write, "+ ++ showFFloat (Just 1) getThroughput "MB/s read"++doPut :: Int -> Int -> Int -> Put+doPut wordSize chunkSize =+ case (wordSize, chunkSize) of+ (1, 1) -> putWord8N1+ (1, 2) -> putWord8N2+ (1, 4) -> putWord8N4+ (1, 8) -> putWord8N8+ (1, 16) -> putWord8N16+ (2, 1) -> putWord16N1+ (2, 2) -> putWord16N2+ (2, 4) -> putWord16N4+ (2, 8) -> putWord16N8+ (2, 16) -> putWord16N16+ (4, 1) -> putWord32N1+ (4, 2) -> putWord32N2+ (4, 4) -> putWord32N4+ (4, 8) -> putWord32N8+ (4, 16) -> putWord32N16+ (8, 1) -> putWord64N1+ (8, 2) -> putWord64N2+ (8, 4) -> putWord64N4+ (8, 8) -> putWord64N8+ (8, 16) -> putWord64N16++putWord8N1 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 (s+0)+ 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)+++putWord16N1 = 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)++putWord16N2 = 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)++putWord16N4 = 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)++putWord16N8 = 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)++putWord16N16 = 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)+++putWord32N1 = 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)++putWord32N2 = 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)++putWord32N4 = 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)++putWord32N8 = 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)++putWord32N16 = 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)++putWord64N1 = 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)++putWord64N2 = 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)++putWord64N4 = 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)++putWord64N8 = 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)++putWord64N16 = 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)+++doGet :: Int -> Int -> Int -> Get Int+doGet wordSize chunkSize =+ case (wordSize, chunkSize) 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) -> fmap fromIntegral . getWord16N1+ (2, 2) -> fmap fromIntegral . getWord16N2+ (2, 4) -> fmap fromIntegral . getWord16N4+ (2, 8) -> fmap fromIntegral . getWord16N8+ (2, 16) -> fmap fromIntegral . getWord16N16+ (4, 1) -> fmap fromIntegral . getWord32N1+ (4, 2) -> fmap fromIntegral . getWord32N2+ (4, 4) -> fmap fromIntegral . getWord32N4+ (4, 8) -> fmap fromIntegral . getWord32N8+ (4, 16) -> fmap fromIntegral . getWord32N16+ (8, 1) -> fmap fromIntegral . getWord64N1+ (8, 2) -> fmap fromIntegral . getWord64N2+ (8, 4) -> fmap fromIntegral . getWord64N4+ (8, 8) -> fmap fromIntegral . getWord64N8+ (8, 16) -> fmap fromIntegral . getWord64N16++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)+++getWord16N1 = 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)++getWord16N2 = 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)++getWord16N4 = 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)++getWord16N8 = 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)++getWord16N16 = 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)+++getWord32N1 = 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)++getWord32N2 = 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)++getWord32N4 = 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)++getWord32N8 = 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)++getWord32N16 = 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)++getWord64N1 = 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)++getWord64N2 = 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)++getWord64N4 = 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)++getWord64N8 = 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)++getWord64N16 = 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)
+ tests/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 int *a, int bytes) {+ unsigned int n = 0;+ int i = 0;+ int iterations = bytes / sizeof(unsigned int) ;+ while (i < iterations) {+ a[i++] = n++;+ }+}++unsigned int wordread(unsigned int *a, int bytes) {+ unsigned int n = 0;+ int i = 0;+ int iterations = bytes / sizeof(unsigned int);+ while (i < iterations) {+ n += a[i++];+ }+ return n;+}
+ tests/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 int *a, int bytes);+unsigned int wordread(unsigned int *a, int bytes);
+ tests/Makefile view
@@ -0,0 +1,27 @@+all: compiled+ +interpreted:+ runhaskell QC.hs 1000++compiled:+ ghc --make -O QC.hs -o qc -no-recomp+ time ./qc 1000++bench:: Benchmark.hs MemBench.hs CBenchmark.o+ ghc --make -O Benchmark.hs -fasm CBenchmark.o -o bench -no-recomp+ time ./bench++bench-nb::+ ghc --make -O NewBenchmark.hs -fasm -o bench-nb+ time ./bench-nb++CBenchmark.o: CBenchmark.c+ gcc -O -c $< -o $@++hugs:+ runhugs -98 QC.hs ++clean:+ rm -f *.o *.hi qc bench bench-nb *~++.PHONY: clean bench bench-nb
+ tests/MemBench.hs view
@@ -0,0 +1,85 @@+{-# OPTIONS_GHC -fffi -fbang-patterns #-}+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 CUInt -> Int -> IO ()+hs_wordwrite ptr bytes = loop 0 0+ where iterations = bytes `div` sizeOf (undefined :: CUInt)+ loop :: Int -> CUInt -> IO ()+ loop !i !n | i == iterations = return ()+ | otherwise = do pokeByteOff ptr i n+ loop (i+1) (n+1)++hs_wordread :: Ptr CUInt -> Int -> IO CUInt+hs_wordread ptr bytes = loop 0 0+ where iterations = bytes `div` sizeOf (undefined :: CUInt)+ loop :: Int -> CUInt -> IO CUInt+ 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)
+ tests/NewBenchmark.hs view
@@ -0,0 +1,625 @@+--+-- benchmark NewBinary+--++module Main where++import System.IO+import Data.Word+import NewBinary++import Control.Exception+import System.CPUTime+import Numeric++mb :: Int+mb = 10++main :: IO ()+main = sequence_ + [ test wordSize chunkSize mb+ | wordSize <- [1,2,4,8]+ , chunkSize <- [1,2,4,8,16] ]++time :: IO a -> IO Double+time action = do+ start <- getCPUTime+ action+ end <- getCPUTime+ return $! (fromIntegral (end - start)) / (10^12)++test :: Int -> Int -> Int -> IO ()+test wordSize chunkSize mb = do+ let bytes :: Int+ bytes = mb * 2^20+ iterations = bytes `div` wordSize+ putStr $ show mb ++ "MB of Word" ++ show (8 * wordSize)+ ++ " in chunks of " ++ show chunkSize ++ ": "+ h <- openBinMem bytes undefined+ start <- tellBin h+ putSeconds <- time $ do+ doPut wordSize chunkSize h iterations+-- BinPtr n _ <- tellBin h+-- print n+ getSeconds <- time $ do+ seekBin h start+ sum <- doGet wordSize chunkSize h iterations+ evaluate sum+-- BinPtr n _ <- tellBin h+-- print (n, sum)+ let putThroughput = fromIntegral mb / putSeconds+ getThroughput = fromIntegral mb / getSeconds+ putStrLn $ showFFloat (Just 2) putThroughput "MB/s write, "+ ++ showFFloat (Just 2) getThroughput "MB/s read"++doPut :: Int -> Int -> BinHandle -> Int -> IO ()+doPut wordSize chunkSize =+ case (wordSize, chunkSize) of+ (1, 1) -> putWord8N1+ (1, 2) -> putWord8N2+ (1, 4) -> putWord8N4+ (1, 8) -> putWord8N8+ (1, 16) -> putWord8N16+ (2, 1) -> putWord16N1+ (2, 2) -> putWord16N2+ (2, 4) -> putWord16N4+ (2, 8) -> putWord16N8+ (2, 16) -> putWord16N16+ (4, 1) -> putWord32N1+ (4, 2) -> putWord32N2+ (4, 4) -> putWord32N4+ (4, 8) -> putWord32N8+ (4, 16) -> putWord32N16+ (8, 1) -> putWord64N1+ (8, 2) -> putWord64N2+ (8, 4) -> putWord64N4+ (8, 8) -> putWord64N8+ (8, 16) -> putWord64N16++putWord8 :: BinHandle -> Word8 -> IO ()+putWord8 = put_+{-# INLINE putWord8 #-}++putWord16be :: BinHandle -> Word16 -> IO ()+putWord16be = put_+{-# INLINE putWord16be #-}++putWord32be :: BinHandle -> Word32 -> IO ()+putWord32be = put_+{-# INLINE putWord32be #-}++putWord64be :: BinHandle -> Word64 -> IO ()+putWord64be = put_+{-# INLINE putWord64be #-}++getWord8 :: BinHandle -> IO Word8+getWord8 = get+{-# INLINE getWord8 #-}++getWord16be :: BinHandle -> IO Word16+getWord16be = get+{-# INLINE getWord16be #-}++getWord32be :: BinHandle -> IO Word32+getWord32be = get+{-# INLINE getWord32be #-}++getWord64be :: BinHandle -> IO Word64+getWord64be = get+{-# INLINE getWord64be #-}++putWord8N1 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 hnd (s+0)+ loop (s+1) (n-1)++putWord8N2 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 hnd (s+0)+ putWord8 hnd (s+1)+ loop (s+2) (n-2)++putWord8N4 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 hnd (s+0)+ putWord8 hnd (s+1)+ putWord8 hnd (s+2)+ putWord8 hnd (s+3)+ loop (s+4) (n-4)++putWord8N8 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 hnd (s+0)+ putWord8 hnd (s+1)+ putWord8 hnd (s+2)+ putWord8 hnd (s+3)+ putWord8 hnd (s+4)+ putWord8 hnd (s+5)+ putWord8 hnd (s+6)+ putWord8 hnd (s+7)+ loop (s+8) (n-8)++putWord8N16 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 hnd (s+0)+ putWord8 hnd (s+1)+ putWord8 hnd (s+2)+ putWord8 hnd (s+3)+ putWord8 hnd (s+4)+ putWord8 hnd (s+5)+ putWord8 hnd (s+6)+ putWord8 hnd (s+7)+ putWord8 hnd (s+8)+ putWord8 hnd (s+9)+ putWord8 hnd (s+10)+ putWord8 hnd (s+11)+ putWord8 hnd (s+12)+ putWord8 hnd (s+13)+ putWord8 hnd (s+14)+ putWord8 hnd (s+15)+ loop (s+16) (n-16)+++putWord16N1 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be hnd (s+0)+ loop (s+1) (n-1)++putWord16N2 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be hnd (s+0)+ putWord16be hnd (s+1)+ loop (s+2) (n-2)++putWord16N4 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be hnd (s+0)+ putWord16be hnd (s+1)+ putWord16be hnd (s+2)+ putWord16be hnd (s+3)+ loop (s+4) (n-4)++putWord16N8 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be hnd (s+0)+ putWord16be hnd (s+1)+ putWord16be hnd (s+2)+ putWord16be hnd (s+3)+ putWord16be hnd (s+4)+ putWord16be hnd (s+5)+ putWord16be hnd (s+6)+ putWord16be hnd (s+7)+ loop (s+8) (n-8)++putWord16N16 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be hnd (s+0)+ putWord16be hnd (s+1)+ putWord16be hnd (s+2)+ putWord16be hnd (s+3)+ putWord16be hnd (s+4)+ putWord16be hnd (s+5)+ putWord16be hnd (s+6)+ putWord16be hnd (s+7)+ putWord16be hnd (s+8)+ putWord16be hnd (s+9)+ putWord16be hnd (s+10)+ putWord16be hnd (s+11)+ putWord16be hnd (s+12)+ putWord16be hnd (s+13)+ putWord16be hnd (s+14)+ putWord16be hnd (s+15)+ loop (s+16) (n-16)+++putWord32N1 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be hnd (s+0)+ loop (s+1) (n-1)++putWord32N2 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be hnd (s+0)+ putWord32be hnd (s+1)+ loop (s+2) (n-2)++putWord32N4 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be hnd (s+0)+ putWord32be hnd (s+1)+ putWord32be hnd (s+2)+ putWord32be hnd (s+3)+ loop (s+4) (n-4)++putWord32N8 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be hnd (s+0)+ putWord32be hnd (s+1)+ putWord32be hnd (s+2)+ putWord32be hnd (s+3)+ putWord32be hnd (s+4)+ putWord32be hnd (s+5)+ putWord32be hnd (s+6)+ putWord32be hnd (s+7)+ loop (s+8) (n-8)++putWord32N16 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be hnd (s+0)+ putWord32be hnd (s+1)+ putWord32be hnd (s+2)+ putWord32be hnd (s+3)+ putWord32be hnd (s+4)+ putWord32be hnd (s+5)+ putWord32be hnd (s+6)+ putWord32be hnd (s+7)+ putWord32be hnd (s+8)+ putWord32be hnd (s+9)+ putWord32be hnd (s+10)+ putWord32be hnd (s+11)+ putWord32be hnd (s+12)+ putWord32be hnd (s+13)+ putWord32be hnd (s+14)+ putWord32be hnd (s+15)+ loop (s+16) (n-16)++putWord64N1 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be hnd (s+0)+ loop (s+1) (n-1)++putWord64N2 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be hnd (s+0)+ putWord64be hnd (s+1)+ loop (s+2) (n-2)++putWord64N4 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be hnd (s+0)+ putWord64be hnd (s+1)+ putWord64be hnd (s+2)+ putWord64be hnd (s+3)+ loop (s+4) (n-4)++putWord64N8 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be hnd (s+0)+ putWord64be hnd (s+1)+ putWord64be hnd (s+2)+ putWord64be hnd (s+3)+ putWord64be hnd (s+4)+ putWord64be hnd (s+5)+ putWord64be hnd (s+6)+ putWord64be hnd (s+7)+ loop (s+8) (n-8)++putWord64N16 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be hnd (s+0)+ putWord64be hnd (s+1)+ putWord64be hnd (s+2)+ putWord64be hnd (s+3)+ putWord64be hnd (s+4)+ putWord64be hnd (s+5)+ putWord64be hnd (s+6)+ putWord64be hnd (s+7)+ putWord64be hnd (s+8)+ putWord64be hnd (s+9)+ putWord64be hnd (s+10)+ putWord64be hnd (s+11)+ putWord64be hnd (s+12)+ putWord64be hnd (s+13)+ putWord64be hnd (s+14)+ putWord64be hnd (s+15)+ loop (s+16) (n-16)++doGet :: Int -> Int -> BinHandle -> Int -> IO Int+doGet wordSize chunkSize hnd =+ case (wordSize, chunkSize) of+ (1, 1) -> fmap fromIntegral . getWord8N1 hnd+ (1, 2) -> fmap fromIntegral . getWord8N2 hnd+ (1, 4) -> fmap fromIntegral . getWord8N4 hnd+ (1, 8) -> fmap fromIntegral . getWord8N8 hnd+ (1, 16) -> fmap fromIntegral . getWord8N16 hnd+ (2, 1) -> fmap fromIntegral . getWord16N1 hnd+ (2, 2) -> fmap fromIntegral . getWord16N2 hnd+ (2, 4) -> fmap fromIntegral . getWord16N4 hnd+ (2, 8) -> fmap fromIntegral . getWord16N8 hnd+ (2, 16) -> fmap fromIntegral . getWord16N16 hnd+ (4, 1) -> fmap fromIntegral . getWord32N1 hnd+ (4, 2) -> fmap fromIntegral . getWord32N2 hnd+ (4, 4) -> fmap fromIntegral . getWord32N4 hnd+ (4, 8) -> fmap fromIntegral . getWord32N8 hnd+ (4, 16) -> fmap fromIntegral . getWord32N16 hnd+ (8, 1) -> fmap fromIntegral . getWord64N1 hnd+ (8, 2) -> fmap fromIntegral . getWord64N2 hnd+ (8, 4) -> fmap fromIntegral . getWord64N4 hnd+ (8, 8) -> fmap fromIntegral . getWord64N8 hnd+ (8, 16) -> fmap fromIntegral . getWord64N16 hnd++getWord8N1 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord8 hnd+ loop (s+s0) (n-1)++getWord8N2 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord8 hnd+ s1 <- getWord8 hnd+ loop (s+s0+s1) (n-2)++getWord8N4 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord8 hnd+ s1 <- getWord8 hnd+ s2 <- getWord8 hnd+ s3 <- getWord8 hnd+ loop (s+s0+s1+s2+s3) (n-4)++getWord8N8 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord8 hnd+ s1 <- getWord8 hnd+ s2 <- getWord8 hnd+ s3 <- getWord8 hnd+ s4 <- getWord8 hnd+ s5 <- getWord8 hnd+ s6 <- getWord8 hnd+ s7 <- getWord8 hnd+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord8N16 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord8 hnd+ s1 <- getWord8 hnd+ s2 <- getWord8 hnd+ s3 <- getWord8 hnd+ s4 <- getWord8 hnd+ s5 <- getWord8 hnd+ s6 <- getWord8 hnd+ s7 <- getWord8 hnd+ s8 <- getWord8 hnd+ s9 <- getWord8 hnd+ s10 <- getWord8 hnd+ s11 <- getWord8 hnd+ s12 <- getWord8 hnd+ s13 <- getWord8 hnd+ s14 <- getWord8 hnd+ s15 <- getWord8 hnd+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)+++getWord16N1 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be hnd+ loop (s+s0) (n-1)++getWord16N2 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be hnd+ s1 <- getWord16be hnd+ loop (s+s0+s1) (n-2)++getWord16N4 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be hnd+ s1 <- getWord16be hnd+ s2 <- getWord16be hnd+ s3 <- getWord16be hnd+ loop (s+s0+s1+s2+s3) (n-4)++getWord16N8 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be hnd+ s1 <- getWord16be hnd+ s2 <- getWord16be hnd+ s3 <- getWord16be hnd+ s4 <- getWord16be hnd+ s5 <- getWord16be hnd+ s6 <- getWord16be hnd+ s7 <- getWord16be hnd+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be hnd+ s1 <- getWord16be hnd+ s2 <- getWord16be hnd+ s3 <- getWord16be hnd+ s4 <- getWord16be hnd+ s5 <- getWord16be hnd+ s6 <- getWord16be hnd+ s7 <- getWord16be hnd+ s8 <- getWord16be hnd+ s9 <- getWord16be hnd+ s10 <- getWord16be hnd+ s11 <- getWord16be hnd+ s12 <- getWord16be hnd+ s13 <- getWord16be hnd+ s14 <- getWord16be hnd+ s15 <- getWord16be hnd+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)+++getWord32N1 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be hnd+ loop (s+s0) (n-1)++getWord32N2 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be hnd+ s1 <- getWord32be hnd+ loop (s+s0+s1) (n-2)++getWord32N4 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be hnd+ s1 <- getWord32be hnd+ s2 <- getWord32be hnd+ s3 <- getWord32be hnd+ loop (s+s0+s1+s2+s3) (n-4)++getWord32N8 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be hnd+ s1 <- getWord32be hnd+ s2 <- getWord32be hnd+ s3 <- getWord32be hnd+ s4 <- getWord32be hnd+ s5 <- getWord32be hnd+ s6 <- getWord32be hnd+ s7 <- getWord32be hnd+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord32N16 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be hnd+ s1 <- getWord32be hnd+ s2 <- getWord32be hnd+ s3 <- getWord32be hnd+ s4 <- getWord32be hnd+ s5 <- getWord32be hnd+ s6 <- getWord32be hnd+ s7 <- getWord32be hnd+ s8 <- getWord32be hnd+ s9 <- getWord32be hnd+ s10 <- getWord32be hnd+ s11 <- getWord32be hnd+ s12 <- getWord32be hnd+ s13 <- getWord32be hnd+ s14 <- getWord32be hnd+ s15 <- getWord32be hnd+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++getWord64N1 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be hnd+ loop (s+s0) (n-1)++getWord64N2 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be hnd+ s1 <- getWord64be hnd+ loop (s+s0+s1) (n-2)++getWord64N4 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be hnd+ s1 <- getWord64be hnd+ s2 <- getWord64be hnd+ s3 <- getWord64be hnd+ loop (s+s0+s1+s2+s3) (n-4)++getWord64N8 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be hnd+ s1 <- getWord64be hnd+ s2 <- getWord64be hnd+ s3 <- getWord64be hnd+ s4 <- getWord64be hnd+ s5 <- getWord64be hnd+ s6 <- getWord64be hnd+ s7 <- getWord64be hnd+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16 hnd = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be hnd+ s1 <- getWord64be hnd+ s2 <- getWord64be hnd+ s3 <- getWord64be hnd+ s4 <- getWord64be hnd+ s5 <- getWord64be hnd+ s6 <- getWord64be hnd+ s7 <- getWord64be hnd+ s8 <- getWord64be hnd+ s9 <- getWord64be hnd+ s10 <- getWord64be hnd+ s11 <- getWord64be hnd+ s12 <- getWord64be hnd+ s13 <- getWord64be hnd+ s14 <- getWord64be hnd+ s15 <- getWord64be hnd+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)
+ tests/NewBinary.hs view
@@ -0,0 +1,1006 @@+{-# OPTIONS -cpp -fglasgow-exts #-}+--+-- (c) The University of Glasgow 2002+--+-- Binary I/O library, with special tweaks for GHC+--+-- Based on the nhc98 Binary library, which is copyright+-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.+-- Under the terms of the license for that software, we must tell you+-- where you can obtain the original version of the Binary library, namely+-- http://www.cs.york.ac.uk/fp/nhc98/++module NewBinary+ ( {-type-} Bin,+ {-class-} Binary(..),+ {-type-} BinHandle(..),++ openBinIO, + openBinIO_,+ openBinMem,+-- closeBin,++-- getUserData,++ seekBin,+ tellBin,+ tellBinByte,+ castBin,++ writeBinMem,+ readBinMem,++ isEOFBin,++ -- for writing instances:+ putByte,+ getByte,++ -- bit stuff+ putBits,+ getBits,+ flushByte,+ finishByte,+ putMaybeInt,+ getMaybeInt,++ -- lazy Bin I/O+ lazyGet,+ lazyPut,++ -- GHC only:+ ByteArray(..),+ getByteArray,+ putByteArray,++-- getBinFileWithDict, -- :: Binary a => FilePath -> IO a+-- putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO ()++ ) where++#include "MachDeps.h"++import GHC.Exts+import GHC.IOBase+import GHC.Real+import Data.Array.IO ( IOUArray )+import Data.Bits+import Data.Int+import Data.Word+import Data.Char+import Control.Monad+import Control.Exception+import Data.Array+import Data.Array.IO+import Data.Array.Base+import System.IO as IO+import System.IO.Error ( mkIOError, eofErrorType )+import GHC.Handle +import System.IO++import GHC.Exts+#if __GLASGOW_HASKELL__ >= 504+import GHC.IOBase+import Data.Word+import Data.Bits+#else+import PrelIOBase+import Word+import Bits+#endif++#ifndef SIZEOF_HSINT+#define SIZEOF_HSINT INT_SIZE_IN_BYTES+#endif++#if __GLASGOW_HASKELL__ < 503+type BinArray = MutableByteArray RealWorld Int+newArray_ bounds = stToIO (newCharArray bounds)+unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)+unsafeRead arr ix = stToIO (readWord8Array arr ix)++hPutArray h arr sz = hPutBufBA h arr sz+hGetArray h sz = hGetBufBA h sz++mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception+mkIOError t location maybe_hdl maybe_filename+ = IOException (IOError maybe_hdl t location ""+ maybe_filename+ )++eofErrorType = EOF++#ifndef SIZEOF_HSINT+#define SIZEOF_HSINT INT_SIZE_IN_BYTES+#endif++#ifndef SIZEOF_HSWORD+#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES+#endif++#else+type BinArray = IOUArray Int Word8+#endif++data BinHandle+ = BinMem { -- binary data stored in an unboxed array+ off_r :: !FastMutInt, -- the current offset+ sz_r :: !FastMutInt, -- size of the array (cached)+ arr_r :: !(IORef BinArray), -- the array (bounds: (0,size-1))+ bit_off_r :: !FastMutInt, -- the bit offset (see end of file)+ bit_cache_r :: !FastMutInt -- the bit cache (see end of file)+ }+ -- XXX: should really store a "high water mark" for dumping out+ -- the binary data to a file.++ | BinIO { -- binary data stored in a file+ off_r :: !FastMutInt, -- the current offset (cached)+ hdl :: !IO.Handle, -- the file handle (must be seekable)+ bit_off_r :: !FastMutInt, -- the bit offset (see end of file)+ bit_cache_r :: !FastMutInt -- the bit cache (see end of file)+ }+ -- cache the file ptr in BinIO; using hTell is too expensive+ -- to call repeatedly. If anyone else is modifying this Handle+ -- at the same time, we'll be screwed.++data Bin a = BinPtr !Int !Int -- byte/bit+ deriving (Eq, Ord, Show, Bounded)++castBin :: Bin a -> Bin b+castBin (BinPtr i j) = BinPtr i j++class Binary a where+ put_ :: BinHandle -> a -> IO ()+ put :: BinHandle -> a -> IO (Bin a)+ get :: BinHandle -> IO a++ -- define one of put_, put. Use of put_ is recommended because it+ -- is more likely that tail-calls can kick in, and we rarely need the+ -- position return value.+ put_ bh a = do put bh a; return ()+ put bh a = do p <- tellBin bh; put_ bh a; return p++putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()+putAt bh p x = do seekBin bh p; put bh x; return ()++getAt :: Binary a => BinHandle -> Bin a -> IO a+getAt bh p = do seekBin bh p; get bh++openBinIO_ :: IO.Handle -> IO BinHandle+openBinIO_ h = openBinIO h noBinHandleUserData++newZeroInt = do r <- newFastMutInt; writeFastMutInt r 0; return r++-- openBinIO :: IO.Handle -> Module -> IO BinHandle+openBinIO :: forall t. Handle -> t -> IO BinHandle+openBinIO h mod = do+ r <- newZeroInt+ o <- newZeroInt+ c <- newZeroInt+-- state <- newWriteState mod+ return (BinIO r h o c)++--openBinMem :: Int -> Module -> IO BinHandle+openBinMem :: forall t. Int -> t -> IO BinHandle+openBinMem size mod+ | size <= 0 = error "Data.Binary.openBinMem: size must be > 0" -- fix, was ">= 0"+ | otherwise = do+ arr <- newArray_ (0,size-1)+ arr_r <- newIORef arr+ ix_r <- newFastMutInt+ writeFastMutInt ix_r 0+ sz_r <- newFastMutInt+ writeFastMutInt sz_r size+ o <- newZeroInt+ c <- newZeroInt+-- state <- newWriteState mod+ return (BinMem ix_r sz_r arr_r o c)++noBinHandleUserData = error "Binary.BinHandle: no user data"++--getUserData :: BinHandle -> BinHandleState+--getUserData bh = state bh++tellBin :: BinHandle -> IO (Bin a)+tellBin (BinIO r _ o _) = do ix <- readFastMutInt r; bix <- readFastMutInt o; return (BinPtr ix bix)+tellBin (BinMem r _ _ o _) = do ix <- readFastMutInt r; bix <- readFastMutInt o; return (BinPtr ix bix)++tellBinByte (BinIO r _ _ _) = do ix <- readFastMutInt r; return ix+tellBinByte (BinMem r _ _ _ _) = do ix <- readFastMutInt r; return ix++seekBin :: BinHandle -> Bin a -> IO ()+seekBin bh@(BinIO ix_r h o c) (BinPtr p bit) = do + writeFastMutInt ix_r p+ writeFastMutInt o 0+ writeFastMutInt c 0+ hSeek h AbsoluteSeek (fromIntegral p)+ when (bit /= 0) $ getBits bh bit >> return ()+ return ()+seekBin h@(BinMem ix_r sz_r a o c) (BinPtr p bit) = do+ sz <- readFastMutInt sz_r+ if (p >= sz)+ then do expandBin h p+ writeFastMutInt ix_r p+ writeFastMutInt o 0+ writeFastMutInt c 0+ when (bit /= 0) $ getBits h bit >> return ()+ return ()++ else do writeFastMutInt ix_r p+ writeFastMutInt o 0+ writeFastMutInt c 0+ when (bit /= 0) $ getBits h bit >> return ()+ return ()++isEOFBin :: BinHandle -> IO Bool+isEOFBin (BinMem ix_r sz_r a _ _) = do+ ix <- readFastMutInt ix_r+ sz <- readFastMutInt sz_r+ return (ix >= sz)+isEOFBin (BinIO ix_r h _ _) = hIsEOF h++writeBinMem :: BinHandle -> FilePath -> IO ()+writeBinMem (BinIO _ _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"+writeBinMem bh@(BinMem ix_r sz_r arr_r bit_off_r bit_cache_r) fn = do+ flushByte bh+ h <- openBinaryFile fn WriteMode+ arr <- readIORef arr_r+ ix <- readFastMutInt ix_r+ hPutArray h arr ix+ hClose h++flushByte :: BinHandle -> IO ()+flushByte bh = do+ bit_off <- readFastMutInt (bit_off_r bh)+ if bit_off == 0+ then return ()+ else putBits bh (8 - bit_off) 0++finishByte :: BinHandle -> IO ()+finishByte bh = do+ bit_off <- readFastMutInt (bit_off_r bh)+ if bit_off == 0+ then return ()+ else getBits bh (8 - bit_off) >> return ()++readBinMem :: FilePath -> IO BinHandle+readBinMem filename = do+ h <- openBinaryFile filename ReadMode+ filesize' <- hFileSize h+ let filesize = fromIntegral filesize'+ arr <- newArray_ (0,filesize-1)+ count <- hGetArray h arr filesize+ when (count /= filesize)+ (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))+ hClose h+ arr_r <- newIORef arr+ ix_r <- newFastMutInt+ writeFastMutInt ix_r 0+ sz_r <- newFastMutInt+ writeFastMutInt sz_r filesize+ bit_off_r <- newZeroInt+ bit_cache_r <- newZeroInt+ return (BinMem {-initReadState-} ix_r sz_r arr_r bit_off_r bit_cache_r)++-- expand the size of the array to include a specified offset+expandBin :: BinHandle -> Int -> IO ()+expandBin (BinMem ix_r sz_r arr_r _ _) off = do+ sz <- readFastMutInt sz_r+ let sz' = head (dropWhile (<= off) (iterate (* 2) sz))+ arr <- readIORef arr_r+ arr' <- newArray_ (0,sz'-1)+ sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i+ | i <- [ 0 .. sz-1 ] ]+ writeFastMutInt sz_r sz'+ writeIORef arr_r arr'+-- hPutStrLn stderr ("expanding to size: " ++ show sz')+ return ()+expandBin (BinIO _ _ _ _) _ = return ()+ -- no need to expand a file, we'll assume they expand by themselves.++-- -----------------------------------------------------------------------------+-- Low-level reading/writing of bytes++putWord8 :: BinHandle -> Word8 -> IO ()+putWord8 h@(BinMem ix_r sz_r arr_r bit_off_r bit_cache_r) w = do+ bit_off <- readFastMutInt bit_off_r+ if bit_off /= 0 then putBits h 8 w else do -- only do standard putWord8 if bit_off == 0+ ix <- readFastMutInt ix_r+ sz <- readFastMutInt sz_r+ -- double the size of the array if it overflows+ if (ix >= sz) + then do expandBin h ix+ putWord8 h w+ else do arr <- readIORef arr_r+ unsafeWrite arr ix w+ writeFastMutInt ix_r (ix+1)+ return ()++putWord8 bh@(BinIO ix_r h bit_off_r bit_cache_r) w = do+ bit_off <- readFastMutInt bit_off_r+ if bit_off /= 0 then putBits bh 8 w else do+ ix <- readFastMutInt ix_r+ hPutChar h (chr (fromIntegral w)) -- XXX not really correct+ writeFastMutInt ix_r (ix+1)+ return ()++putByteNoBits :: BinHandle -> Word8 -> IO ()+putByteNoBits h@(BinMem ix_r sz_r arr_r _ _) w = do+ ix <- readFastMutInt ix_r+ sz <- readFastMutInt sz_r+ -- double the size of the array if it overflows+ if (ix >= sz) + then do expandBin h ix+ putByteNoBits h w+ else do arr <- readIORef arr_r+ unsafeWrite arr ix w+ writeFastMutInt ix_r (ix+1)+ return ()++putByteNoBits bh@(BinIO ix_r h _ _) w = do+ hPutChar h (chr (fromIntegral w)) -- XXX not really correct+ incFastMutInt ix_r+ return ()++getByteNoBits :: BinHandle -> IO Word8+getByteNoBits h@(BinMem ix_r sz_r arr_r _ _) = do+ ix <- readFastMutInt ix_r+ sz <- readFastMutInt sz_r+ when (ix >= sz) $+ throw (IOException $ mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)+ arr <- readIORef arr_r+ w <- unsafeRead arr ix+ writeFastMutInt ix_r (ix+1)+ return w++getByteNoBits bh@(BinIO ix_r h _ _) = do+ c <- hGetChar h+ incFastMutInt ix_r+ return $! (fromIntegral (ord c)) -- XXX not really correct++getWord8 :: BinHandle -> IO Word8+getWord8 h@(BinMem ix_r sz_r arr_r bit_off_r _) = do+ bit_off <- readFastMutInt bit_off_r+ if bit_off /= 0 then getBits h 8 else do+ ix <- readFastMutInt ix_r+ sz <- readFastMutInt sz_r+ when (ix >= sz) $+ throw (IOException $ mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)+ arr <- readIORef arr_r+ w <- unsafeRead arr ix+ writeFastMutInt ix_r (ix+1)+ return w+getWord8 bh@(BinIO ix_r h bit_off_r _) = do+ bit_off <- readFastMutInt bit_off_r+ if bit_off /= 0 then getBits bh 8 else do+ ix <- readFastMutInt ix_r+ c <- hGetChar h+ writeFastMutInt ix_r (ix+1)+ return $! (fromIntegral (ord c)) -- XXX not really correct++putByte :: BinHandle -> Word8 -> IO ()+putByte bh w = put_ bh w++getByte :: BinHandle -> IO Word8+getByte = getWord8++-- -----------------------------------------------------------------------------+-- Bit functions++putBits :: BinHandle -> Int -> Word8 -> IO ()+putBits bh num_bits bits {- | num_bits == 0 = return ()+ | num_bits < 0 = error "putBits cannot write negative numbers of bits"+ | num_bits > 8 = error "putBits cannot write more than 8 bits at a time"+ | otherwise -} = do+ bit_off <- readFastMutInt (bit_off_r bh)+ if num_bits + bit_off < 8+ then do incFastMutIntBy (bit_off_r bh) num_bits+ orFastMutInt (bit_cache_r bh) (bits `shiftL` bit_off)+ else if num_bits + bit_off == 8+ then do writeFastMutInt (bit_off_r bh) 0+ bit_cache <- {-# SCC "bc1" #-} readFastMutInt (bit_cache_r bh) >>= return . fromIntegral+ writeFastMutInt (bit_cache_r bh) 0+ --putByte bh (bit_cache .|. (bits `shiftL` bit_off)) -- won't call putBits because bit_off_r == 0+ putByteNoBits bh (bit_cache .|. (bits `shiftL` bit_off))++ else do let leftover_bits = 8 - bit_off -- we are going over a byte boundary+ bit_cache <- {-# SCC "bc2" #-} readFastMutInt (bit_cache_r bh) >>= \x -> return ({-# SCC "fi" #-} fromIntegral x)+ writeFastMutInt (bit_off_r bh) 0+ writeFastMutInt (bit_cache_r bh) 0+ {- putByte bh (bit_cache .|. (bits `shiftL` bit_off)) -} -- won't call putBits+ putByteNoBits bh (bit_cache .|. (bits `shiftL` bit_off))+ putBits bh (num_bits - leftover_bits) (bits `shiftR` leftover_bits)++getBits :: BinHandle -> Int -> IO Word8+getBits bh num_bits {- | num_bits == 0 = return 0+ | num_bits < 0 = error "getBits cannot read negative numbers of bits"+ | num_bits > 8 = error "getBits cannot read more than 8 bits at a time"+ | otherwise -} = do+ bit_off <- readFastMutInt (bit_off_r bh)+ if bit_off == 0+ then do bit_cache <- getByte bh+ if num_bits == 8+ then do writeFastMutInt (bit_off_r bh) 0+ writeFastMutInt (bit_cache_r bh) 0+ return bit_cache+ else do writeFastMutInt (bit_off_r bh) (fromIntegral num_bits)+ writeFastMutInt (bit_cache_r bh) (fromIntegral bit_cache)+ return (bit_cache .&. bit_mask num_bits)+ else if bit_off + num_bits < 8+ then do incFastMutIntBy (bit_off_r bh) num_bits+ bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral+ return ((bit_cache `shiftR` bit_off) .&. bit_mask num_bits)+ else if bit_off + num_bits == 8+ then do writeFastMutInt (bit_off_r bh) 0+ bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral+ writeFastMutInt (bit_cache_r bh) 0+ return ((bit_cache `shiftR` bit_off) .&. bit_mask num_bits)+ else do let leftover_bits = 8 - bit_off+ bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral+ let bits = (bit_cache `shiftR` bit_off) .&. bit_mask leftover_bits+ writeFastMutInt (bit_cache_r bh) 0+ writeFastMutInt (bit_off_r bh) 0+ {- bit_cache <- getByte bh -}+ -- use a version that doesn't care about bits+ bit_cache <- getByteNoBits bh+ writeFastMutInt (bit_off_r bh) (num_bits - leftover_bits)+ writeFastMutInt (bit_cache_r bh) (fromIntegral bit_cache)+ return (bits .|. ((bit_cache .&. bit_mask (num_bits - leftover_bits)) `shiftL` leftover_bits))++ +bit_mask n = (complement 0) `shiftR` (8 - n)++-- -----------------------------------------------------------------------------+-- Primitve Word writes++instance Binary Word8 where+ put_ = putWord8+ get = getWord8++instance Binary Word16 where+ put_ h w = do -- XXX too slow.. inline putWord8?+ putByte h (fromIntegral (w `shiftR` 8))+ putByte h (fromIntegral (w .&. 0xff))+ get h = do+ w1 <- getWord8 h+ w2 <- getWord8 h+ return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)+++instance Binary Word32 where+ put_ h w = do+ putByte h (fromIntegral (w `shiftR` 24))+ putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))+ putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))+ putByte h (fromIntegral (w .&. 0xff))+ get h = do+ w1 <- getWord8 h+ w2 <- getWord8 h+ w3 <- getWord8 h+ w4 <- getWord8 h+ return $! ((fromIntegral w1 `shiftL` 24) .|. + (fromIntegral w2 `shiftL` 16) .|. + (fromIntegral w3 `shiftL` 8) .|. + (fromIntegral w4))+++instance Binary Word64 where+ put_ h w = do+ putByte h (fromIntegral (w `shiftR` 56))+ putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))+ putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))+ putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))+ putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))+ putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))+ putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff))+ putByte h (fromIntegral (w .&. 0xff))+ get h = do+ w1 <- getWord8 h+ w2 <- getWord8 h+ w3 <- getWord8 h+ w4 <- getWord8 h+ w5 <- getWord8 h+ w6 <- getWord8 h+ w7 <- getWord8 h+ w8 <- getWord8 h+ return $! ((fromIntegral w1 `shiftL` 56) .|. + (fromIntegral w2 `shiftL` 48) .|. + (fromIntegral w3 `shiftL` 40) .|. + (fromIntegral w4 `shiftL` 32) .|. + (fromIntegral w5 `shiftL` 24) .|. + (fromIntegral w6 `shiftL` 16) .|. + (fromIntegral w7 `shiftL` 8) .|. + (fromIntegral w8))++-- -----------------------------------------------------------------------------+-- Primitve Int writes++instance Binary Int8 where+ put_ h w = put_ h (fromIntegral w :: Word8)+ get h = do w <- get h; return $! (fromIntegral (w::Word8))++instance Binary Int16 where+ put_ h w = put_ h (fromIntegral w :: Word16)+ get h = do w <- get h; return $! (fromIntegral (w::Word16))++instance Binary Int32 where+ put_ h w = put_ h (fromIntegral w :: Word32)+ get h = do w <- get h; return $! (fromIntegral (w::Word32))++put31ofInt32 :: BinHandle -> Int32 -> IO ()+put31ofInt32 h i = do+ putBits h 7 (fromIntegral (w `shiftR` 24))+ putBits h 8 (fromIntegral ((w `shiftR` 16) .&. 0xff))+ putBits h 8 (fromIntegral ((w `shiftR` 8) .&. 0xff))+ putBits h 8 (fromIntegral (w .&. 0xff))+ where w = fromIntegral i :: Word32++get31ofInt32 :: BinHandle -> IO Int32+get31ofInt32 h = do+ w1 <- getBits h 7+ w2 <- getWord8 h+ w3 <- getWord8 h+ w4 <- getWord8 h+ return $! ((fromIntegral w1 `shiftL` 24) .|. + (fromIntegral w2 `shiftL` 16) .|. + (fromIntegral w3 `shiftL` 8) .|. + (fromIntegral w4))++instance Binary Int64 where+ put_ h w = put_ h (fromIntegral w :: Word64)+ get h = do w <- get h; return $! (fromIntegral (w::Word64))++-- -----------------------------------------------------------------------------+-- Instances for standard types++instance Binary () where+ put_ bh () = return ()+ get _ = return ()+-- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b)++{- updated for bits+instance Binary Bool where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))+-- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)+-}++instance Binary Bool where+ put_ bh True = putBits bh 1 1+ put_ bh False = putBits bh 1 0+ get bh = do b <- getBits bh 1; return (b == 1)++instance Binary Char where+ put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)+ get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))+-- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)++instance Binary Int where+#if SIZEOF_HSINT == 4+ put_ bh i = put_ bh (fromIntegral i :: Int32)+ get bh = do+ x <- get bh+ return $! (fromIntegral (x :: Int32))+#elif SIZEOF_HSINT == 8+ put_ bh i = put_ bh (fromIntegral i :: Int64)+ get bh = do+ x <- get bh+ return $! (fromIntegral (x :: Int64))+#else+#error "unsupported sizeof(HsInt)"+#endif+-- getF bh = getBitsF bh 32++{-+instance Binary a => Binary [a] where+ put_ bh [] = putByte bh 0+ put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs+ get bh = do h <- getWord8 bh+ case h of+ 0 -> return []+ _ -> do x <- get bh+ xs <- get bh+ return (x:xs)+-}++instance Binary a => Binary [a] where+ put_ bh l = do+ put_ bh (length l)+ mapM (put_ bh) l+ return ()+ get bh = do+ len <- get bh+ mapM (\_ -> get bh) [1..(len::Int)]++instance (Binary a, Binary b) => Binary (a,b) where+ put_ bh (a,b) = do put_ bh a; put_ bh b+ get bh = do a <- get bh+ b <- get bh+ return (a,b)++instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+ put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c+ get bh = do a <- get bh+ b <- get bh+ c <- get bh+ return (a,b,c)++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+ put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d+ get bh = do a <- get bh+ b <- get bh+ c <- get bh+ d <- get bh+ return (a,b,c,d)++instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where+ put_ bh (a,b,c,d,e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e+ get bh = do a <- get bh+ b <- get bh+ c <- get bh+ d <- get bh+ e <- get bh+ return (a,b,c,d,e)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where+ put_ bh (a,b,c,d,e,f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f+ get bh = do a <- get bh+ b <- get bh+ c <- get bh+ d <- get bh+ e <- get bh+ f <- get bh+ return (a,b,c,d,e,f)++instance Binary a => Binary (Maybe a) where+ put_ bh Nothing = putByte bh 0+ put_ bh (Just a) = do putByte bh 1; put_ bh a+ get bh = do h <- getWord8 bh+ case h of+ 0 -> return Nothing+ _ -> do x <- get bh; return (Just x)++putMaybeInt :: BinHandle -> Maybe Int -> IO ()+getMaybeInt :: BinHandle -> IO (Maybe Int)+putMaybeInt bh Nothing = putBits bh 1 0+putMaybeInt bh (Just i) = do putBits bh 1 1; put31ofInt32 bh (fromIntegral i)++getMaybeInt bh = do + b <- getBits bh 1+ case b of+ 0 -> return Nothing+ _ -> do i <- get31ofInt32 bh+ return (Just (fromIntegral i))++{- RULES get = getMaybeInt -}++{- SPECIALIZE put_ :: BinHandle -> Maybe Int -> IO () = putMaybeInt -}+{- SPECIALIZE get :: BinHandle -> IO (Maybe Int) = getMaybeInt -}+++instance (Binary a, Binary b) => Binary (Either a b) where+ put_ bh (Left a) = do putByte bh 0; put_ bh a+ put_ bh (Right b) = do putByte bh 1; put_ bh b+ get bh = do h <- getWord8 bh+ case h of+ 0 -> do a <- get bh ; return (Left a)+ _ -> do b <- get bh ; return (Right b)++instance Binary Integer where+ put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)+ put_ bh (J# s# a#) = do+ p <- putByte bh 1;+ put_ bh (I# s#)+ let sz# = sizeofByteArray# a# -- in *bytes*+ put_ bh (I# sz#) -- in *bytes*+ putByteArray bh a# sz#++ get bh = do+ b <- getByte bh+ case b of+ 0 -> do (I# i#) <- get bh+ return (S# i#)+ _ -> do (I# s#) <- get bh+ sz <- get bh+ (BA a#) <- getByteArray bh sz+ return (J# s# a#)++putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()+putByteArray bh a s# = loop 0#+ where loop n# + | n# ==# s# = return ()+ | otherwise = do+ putByte bh (indexByteArray a n#)+ loop (n# +# 1#)++getByteArray :: BinHandle -> Int -> IO ByteArray+getByteArray bh (I# sz) = do+ (MBA arr) <- newByteArray sz + let loop n+ | n ==# sz = return ()+ | otherwise = do+ w <- getByte bh + writeByteArray arr n w+ loop (n +# 1#)+ loop 0#+ freezeByteArray arr+++data ByteArray = BA ByteArray#+data MBA = MBA (MutableByteArray# RealWorld)++newByteArray :: Int# -> IO MBA+newByteArray sz = IO $ \s ->+ case newByteArray# sz s of { (# s, arr #) ->+ (# s, MBA arr #) }++freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray+freezeByteArray arr = IO $ \s ->+ case unsafeFreezeByteArray# arr s of { (# s, arr #) ->+ (# s, BA arr #) }++writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()++writeByteArray arr i w8 = IO $ \s ->+ case fromIntegral w8 of { W# w# -> + case writeCharArray# arr i (chr# (word2Int# w#)) s of { s ->+ (# s , () #) }}++indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))++instance (Integral a, Binary a) => Binary (Ratio a) where+ put_ bh (a :% b) = do put_ bh a; put_ bh b+ get bh = do a <- get bh; b <- get bh; return (a :% b)++instance Binary (Bin a) where+ put_ bh (BinPtr i j) = put_ bh (i,j)+ get bh = do (i,j) <- get bh; return (BinPtr i j)++-- -----------------------------------------------------------------------------+-- Lazy reading/writing++lazyPut :: Binary a => BinHandle -> a -> IO ()+lazyPut bh a = do+ -- output the obj with a ptr to skip over it:+ pre_a <- tellBin bh+ put_ bh pre_a -- save a slot for the ptr+ put_ bh a -- dump the object+ q <- tellBin bh -- q = ptr to after object+ putAt bh pre_a q -- fill in slot before a with ptr to q+ seekBin bh q -- finally carry on writing at q++lazyGet :: Binary a => BinHandle -> IO a+lazyGet bh = do+ p <- get bh -- a BinPtr+ p_a <- tellBin bh+ a <- unsafeInterleaveIO (getAt bh p_a)+ seekBin bh p -- skip over the object for now+ return a++-- -----------------------------------------------------------------------------+-- BinHandleState+{-+type BinHandleState = + (Module, + IORef Int,+ IORef (UniqFM (Int,FastString)),+ Array Int FastString)++initReadState :: BinHandleState+initReadState = (undef, undef, undef, undef)++newWriteState :: Module -> IO BinHandleState+newWriteState m = do+ j_r <- newIORef 0+ out_r <- newIORef emptyUFM+ return (m,j_r,out_r,undef)++undef = error "Binary.BinHandleState"++-- -----------------------------------------------------------------------------+-- FastString binary interface++getBinFileWithDict :: Binary a => FilePath -> IO a+getBinFileWithDict file_path = do+ bh <- Binary.readBinMem file_path+ magic <- get bh+ when (magic /= binaryInterfaceMagic) $+ throwDyn (ProgramError (+ "magic number mismatch: old/corrupt interface file?"))+ dict_p <- Binary.get bh -- get the dictionary ptr+ data_p <- tellBin bh+ seekBin bh dict_p+ dict <- getDictionary bh+ seekBin bh data_p+ let (mod, j_r, out_r, _) = state bh+ get bh{ state = (mod,j_r,out_r,dict) }++initBinMemSize = (1024*1024) :: Int++binaryInterfaceMagic = 0x1face :: Word32++putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO ()+putBinFileWithDict file_path mod a = do+ bh <- openBinMem initBinMemSize mod+ put_ bh binaryInterfaceMagic+ p <- tellBin bh+ put_ bh p -- placeholder for ptr to dictionary+ put_ bh a+ let (_, j_r, fm_r, _) = state bh+ j <- readIORef j_r+ fm <- readIORef fm_r+ dict_p <- tellBin bh+ putAt bh p dict_p -- fill in the placeholder+ seekBin bh dict_p -- seek back to the end of the file+ putDictionary bh j (constructDictionary j fm)+ writeBinMem bh file_path+ +type Dictionary = Array Int FastString+ -- should be 0-indexed++putDictionary :: BinHandle -> Int -> Dictionary -> IO ()+putDictionary bh sz dict = do+ put_ bh sz+ mapM_ (putFS bh) (elems dict)++getDictionary :: BinHandle -> IO Dictionary+getDictionary bh = do + sz <- get bh+ elems <- sequence (take sz (repeat (getFS bh)))+ return (listArray (0,sz-1) elems)++constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary+constructDictionary j fm = array (0,j-1) (eltsUFM fm)++putFS bh (FastString id l ba) = do+ put_ bh (I# l)+ putByteArray bh ba l+putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)+ -- Note: the length of the FastString is *not* the same as+ -- the size of the ByteArray: the latter is rounded up to a+ -- multiple of the word size.+ +{- -- possible faster version, not quite there yet:+getFS bh@BinMem{} = do+ (I# l) <- get bh+ arr <- readIORef (arr_r bh)+ off <- readFastMutInt (off_r bh)+ return $! (mkFastSubStringBA# arr off l)+-}+getFS bh = do+ (I# l) <- get bh+ (BA ba) <- getByteArray bh (I# l)+ return $! (mkFastSubStringBA# ba 0# l)++instance Binary FastString where+ put_ bh f@(FastString id l ba) =+ case getUserData bh of { (_, j_r, out_r, dict) -> do+ out <- readIORef out_r+ let uniq = getUnique f+ case lookupUFM out uniq of+ Just (j,f) -> put_ bh j+ Nothing -> do+ j <- readIORef j_r+ put_ bh j+ writeIORef j_r (j+1)+ writeIORef out_r (addToUFM out uniq (j,f))+ }+ put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))++ get bh = do + j <- get bh+ case getUserData bh of (_, _, _, arr) -> return (arr ! j)+-}++++{----------------------------------------------------------------------+ ---------- Hal's Notes -----------------------------------------------+ ----------------------------------------------------------------------++We are adding support for ++ putBits :: BinHandle -> Int -> Word8 -> IO ()+ getBits :: BinHandle -> Int -> IO Word8+ flushBits :: BinHandle -> Int -> IO ()+ closeHandle :: BinHandle -> IO ()++where++ `putBits bh num_bits bits' writes the right-most num_bits of bits to+ bh. `getBits bh num_bits` reads num_bits from bh and stores them in+ the right-most positions of the result. flushBits bh n alignes the+ stream to the next 2^n bit boundary. closeHandle flushes all+ remaining bits and closes the handle.++In order to implement this, we need to extend the BinHandles with two+fields: bit_off_r :: Int and bit_cache :: Word8. Based on this, the+basic implementations look something like this:++putBits bh num_bits bits =+ if num_bits + bit_off_r <= 8+ then bit_off_r += num_bits+ add num_bits of bits to the tail of bit_cache+ if bit_off_r == 8+ then write bit_cache and set bit_cache = 0, bit_off_r = 0+ else let leftover_bits = 8 - bit_off_r+ add leftover_bits of bits to tail of bit_cache+ write bit_cache and set bit_cache = 0, bit_off_r = 0+ putBits bh (num_bits - leftover_bits) (bits >> leftover_bits)++(note that this will recurse at most once)++getBits bh num_bits =+ if bit_off_r == 0+ then bit_cache <- read a byte+ bit_off_r = num_bits+ if bit_off_r == 8, set bit_off_r = 0, bit_cache = 0+ else if bit_off_r + num_bits <= 8+ then bit_off_r += num_bits+ bits = bits from bit_off_r -> bit_off_r+num_bits of bit_cache+ if bit_off_r == 8, set bit_off_r = 0, bit_cache = 0+ return bits+ else let leftover_bits = 8 - bit_off_r+ bits = (last leftover_bits from bit_cache) << (num_bits - leftover_bits)+ bit_cache <- read a byte+ bit_off_r = num_bits - leftover_bits+ return (bits || first (num_bits - leftover_bits) of bit_cache)++Now, we must also modify putByte/getByte. In these, we do a quick+check to see if bit_off_r == 0; if it does, then we just execute+normally. Otherwise, we just call putBits/getBits with num_bits=8.++closeHandle bh =+ if bit_off_r == 0+ then close the handle+ else write bit_cache and set bit_cache = 0, bit_off_r =0+ close the handle++-}++------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ < 411+newByteArray# = newCharArray#+#endif++#ifdef __GLASGOW_HASKELL__++data FastMutInt = FastMutInt (MutableByteArray# RealWorld)++newFastMutInt :: IO FastMutInt+newFastMutInt = IO $ \s ->+ case newByteArray# size s of { (# s, arr #) ->+ (# s, FastMutInt arr #) }+ where I# size = SIZEOF_HSINT++readFastMutInt :: FastMutInt -> IO Int+readFastMutInt (FastMutInt arr) = IO $ \s ->+ case readIntArray# arr 0# s of { (# s, i #) ->+ (# s, I# i #) }++writeFastMutInt :: FastMutInt -> Int -> IO ()+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->+ case writeIntArray# arr 0# i s of { s ->+ (# s, () #) }++incFastMutInt :: FastMutInt -> IO Int -- Returns original value+incFastMutInt (FastMutInt arr) = IO $ \s ->+ case readIntArray# arr 0# s of { (# s, i #) ->+ case writeIntArray# arr 0# (i +# 1#) s of { s ->+ (# s, I# i #) } }++incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value+incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s ->+ case readIntArray# arr 0# s of { (# s, i #) ->+ case writeIntArray# arr 0# (i +# n) s of { s ->+ (# s, I# i #) } }++-- we should optimize this: ask SimonM :)+orFastMutInt :: FastMutInt -> Word8 -> IO ()+orFastMutInt fmi w = do+ i <- readFastMutInt fmi+ writeFastMutInt fmi (i .|. (fromIntegral w))++#endif+
+ tests/QC.hs view
@@ -0,0 +1,203 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module Main where++import Data.Binary+import Data.Binary.Put+import Data.Binary.Get++import qualified Data.ByteString as B+import qualified Data.ByteString.Base 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 Data.Array (Array)+import Data.Array.IArray+import Data.Array.Unboxed (UArray)++import Control.Monad+import Foreign+import System.Environment+import System.IO++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)))++-- low level ones:++prop_Word16be = roundTripWith putWord16be getWord16be+prop_Word16le = roundTripWith putWord16le getWord16le++prop_Word32be = roundTripWith putWord32be getWord32be+prop_Word32le = roundTripWith putWord32le getWord32le++prop_Word64be = roundTripWith putWord64be getWord64be+prop_Word64le = roundTripWith putWord64le getWord64le++invariant_lbs :: L.ByteString -> Bool+invariant_lbs (B.LPS []) = True+invariant_lbs (B.LPS xs) = all (not . B.null) 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+ run 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 ()+p = mytest++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 =+-- utils+ [ ("refragment id", p prop_refragment )+ , ("refragment invariant", p prop_refragment_inv )++-- Primitives+ , ("Word16be", p prop_Word16be)+ , ("Word16le", p prop_Word16le)+ , ("Word32be", p prop_Word32be)+ , ("Word32le", p prop_Word32le)+ , ("Word64be", p prop_Word64be)+ , ("Word64le", p prop_Word64le)++-- 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 ))++ ,("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,253 @@+{-# 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.Base 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.Base as L (LazyByteString(..))++-- 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 . B.LPS . 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,49 @@++module BinaryDerive where++import Data.Generics+import Data.List++derive :: (Typeable a, Show 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)+ 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