binary 0.2 → 0.3
raw patch · 14 files changed
+1951/−717 lines, 14 filesnew-uploader
Files
- README +43/−3
- binary.cabal +7/−4
- src/Data/Binary.hs +57/−0
- src/Data/Binary/Builder.hs +54/−1
- src/Data/Binary/Get.hs +224/−98
- src/Data/Binary/Put.hs +41/−2
- tests/Benchmark.hs +1461/−589
- tests/CBenchmark.c +6/−6
- tests/CBenchmark.h +2/−2
- tests/HeapUse.hs +17/−0
- tests/Makefile +7/−0
- tests/MemBench.hs +10/−10
- tests/QC.hs +12/−0
- tools/derive/BinaryDerive.hs +10/−2
README view
@@ -12,9 +12,9 @@ Building: - runhaskell Setup.hs configure- runhaskell Setup.hs build- runhaskell Setup.hs install+ runhaskell Setup.lhs configure+ runhaskell Setup.lhs build+ runhaskell Setup.lhs install First: import Data.Binary@@ -22,6 +22,40 @@ and then write an instance of Binary for the type you wish to serialise. More information in the haddock documentation. +Deriving:++It is possible to mechanically derive new instances of Binary for your+types, if they support the Data and Typeable classes. A script is+provided in tools/derive. Here's an example of its use.++ $ cd binary + $ cd tools/derive ++ $ ghci -fglasgow-exts BinaryDerive.hs++ *BinaryDerive> :l Example.hs ++ *Main> deriveM (undefined :: Drinks)++ 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+ Contributors: Lennart Kolmodin@@ -32,3 +66,9 @@ Björn Bringert Ross Paterson Einar Karttunen+ John Meacham+ Ulf Norell+ Tomasz Zielonka+ Stefan Karrmann+ Bryan O'Sullivan+ Florian Weimer
binary.cabal view
@@ -1,11 +1,14 @@ name: binary-version: 0.2+version: 0.3 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+homepage: http://www.cse.unsw.edu.au/~dons/binary.html+description: Efficient, pure binary serialisation using lazy ByteStrings.+ Haskell values may be encoded to and form binary formats, + written to disk as binary, or set over the network.+synopsis: Binary serialization for Haskell values using lazy ByteStrings category: Data, Parsing build-depends: base -- ghc 6.4 also needs package fps@@ -13,7 +16,7 @@ Data.Binary.Put, Data.Binary.Get, Data.Binary.Builder-extensions: ForeignFunctionInterface,CPP,FlexibleInstances+extensions: CPP,FlexibleInstances hs-source-dirs: src ghc-options: -O2 -Wall -Werror -fliberate-case-threshold=1000 extra-source-files: README
src/Data/Binary.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Binary@@ -76,6 +77,7 @@ import qualified Data.Set as Set import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet+import qualified Data.Ratio as R import qualified Data.Tree as T @@ -144,6 +146,46 @@ -- Note how we write an initial tag byte to indicate each variant of the -- data type. --+-- We can simplify the writing of 'get' instances using monadic+-- combinators:+-- +-- > get = do tag <- getWord8+-- > case tag of+-- > 0 -> liftM IntE get+-- > 1 -> liftM3 OpE get get get+--+-- The generation of Binary instances has been automated by a script+-- using Scrap Your Boilerplate generics. Use the script here:+-- <http://darcs.haskell.org/binary/tools/derive/BinaryDerive.hs>.+--+-- To derive the instance for a type, load this script into GHCi, and+-- bring your type into scope. Your type can then have its Binary+-- instances derived as follows:+--+-- > $ ghci -fglasgow-exts BinaryDerive.hs+-- > *BinaryDerive> :l Example.hs+-- > *Main> deriveM (undefined :: Drinks)+-- >+-- > 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+-- >+-- -- To serialise this to a bytestring, we use 'encode', which packs the -- data structure into a binary format, in a lazy bytestring --@@ -421,6 +463,10 @@ -} +instance (Binary a,Integral a) => Binary (R.Ratio a) where+ put r = put (R.numerator r) >> put (R.denominator r)+ get = liftM2 (R.%) get get+ ------------------------------------------------------------------------ -- Char is serialised as UTF-8@@ -597,6 +643,17 @@ get = fmap Seq.fromList get #endif++------------------------------------------------------------------------+-- Floating point++instance Binary Double where+ put d = put (decodeFloat d)+ get = liftM2 encodeFloat get get++instance Binary Float where+ put f = put (decodeFloat f)+ get = liftM2 encodeFloat get get ------------------------------------------------------------------------ -- Trees
src/Data/Binary/Builder.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fglasgow-exts #-} -- for unboxed shifts @@ -46,6 +47,12 @@ , putWord32le -- :: Word32 -> Builder , putWord64le -- :: Word64 -> Builder + -- ** Host-endian, unaligned writes+ , putWordhost -- :: Word -> Builder+ , putWord16host -- :: Word16 -> Builder+ , putWord32host -- :: Word32 -> Builder+ , putWord64host -- :: Word64 -> Builder+ ) where import Foreign@@ -124,7 +131,6 @@ -- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ -- fromLazyByteString :: L.ByteString -> Builder-fromLazyByteString (S.LPS []) = empty fromLazyByteString (S.LPS bss) = flush `append` mapBuilder (bss ++) ------------------------------------------------------------------------@@ -209,7 +215,22 @@ return $! Buffer fp 0 0 size ------------------------------------------------------------------------+-- Aligned, host order writes of storable values +-- | Ensure that @n@ many bytes are available, and then use @f@ to write some+-- storable values into the memory.+writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder+writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f)+{-# INLINE [1] writeNbytes #-}++writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer+writeNBufferBytes 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 writeNBufferBytes #-}++------------------------------------------------------------------------+ -- -- We rely on the fromIntegral to do the right masking for us. -- The inlining here is critical, and can be worth 4x performance@@ -320,6 +341,38 @@ -- on a little endian machine: -- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)++------------------------------------------------------------------------+-- Unaligned, word size ops++-- | /O(1)./ A Builder taking a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putWordhost :: Word -> Builder+putWordhost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w)+{-# INLINE putWordhost #-}++-- | Write a Word16 in native host order and host endianness.+-- 2 bytes will be written, unaligned.+putWord16host :: Word16 -> Builder+putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16)+{-# INLINE putWord16host #-}++-- | Write a Word32 in native host order and host endianness.+-- 4 bytes will be written, unaligned.+putWord32host :: Word32 -> Builder+putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32)+{-# INLINE putWord32host #-}++-- | Write a Word64 in native host order.+-- On a 32 bit machine we write two host order Word32s, in big endian form.+-- 8 bytes will be written, unaligned.+putWord64host :: Word64 -> Builder+putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w)+{-# INLINE putWord64host #-} ------------------------------------------------------------------------ -- Unchecked shifts
src/Data/Binary/Get.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fglasgow-exts #-} -- for unboxed shifts @@ -25,6 +26,7 @@ -- * The Get type Get , runGet+ , runGetState -- * Parsing , skip@@ -33,6 +35,9 @@ , lookAheadM , lookAheadE , uncheckedLookAhead++ -- * Utility+ , bytesRead , getBytes , remaining , isEmpty@@ -43,20 +48,27 @@ -- ** ByteStrings , getByteString , getLazyByteString+ , getRemainingLazyByteString -- ** Big-endian reads , getWord16be- , getWord16le , getWord32be+ , getWord64be -- ** Little-endian reads+ , getWord16le , getWord32le- , getWord64be , getWord64le + -- ** Host-endian, unaligned reads+ , getWordhost+ , getWord16host+ , getWord32host+ , getWord64host+ ) where -import Control.Monad (liftM,when)+import Control.Monad (when) import Data.Maybe (isNothing) import qualified Data.ByteString as B@@ -65,6 +77,10 @@ import Foreign +-- used by splitAtST+import Control.Monad.ST+import Data.STRef+ #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base import GHC.Word@@ -72,11 +88,12 @@ #endif -- | The parse state-data S = S {-# UNPACK #-} !L.ByteString -- the rest of the input- {-# UNPACK #-} !Int64 -- bytes read+data S = S {-# UNPACK #-} !B.ByteString -- current chunk+ 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 ) }+newtype Get a = Get { unGet :: S -> (a, S) } instance Functor Get where fmap f m = Get (\s -> let (a, s') = unGet m s@@ -98,30 +115,54 @@ ------------------------------------------------------------------------ +initState :: L.ByteString -> S+initState (B.LPS xs) =+ case xs of+ [] -> S B.empty L.empty 0+ (x:xs') -> S x (B.LPS xs') 0+{-# INLINE initState #-}++mkState :: L.ByteString -> Int64 -> S+mkState (B.LPS xs) =+ case xs of+ [] -> S B.empty L.empty+ (x:xs') -> S x (B.LPS xs')+{-# INLINE mkState #-}+ -- | 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+runGet m str = case unGet m (initState str) of (a, _) -> a +-- | Run the Get monad applies a 'get'-based parser on the input+-- ByteString. Additional to the result of get it returns the number of+-- consumed bytes and the rest of the input.+runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64)+runGetState m str off =+ case unGet m (mkState str off) of+ (a, S s ss newOff) -> (a, s `join` ss, newOff)+ ------------------------------------------------------------------------ failDesc :: String -> Get a failDesc err = do- S _ bytes <- get+ 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 n = readN (fromIntegral n) (const ()) --- | Skip ahead @n@ bytes. -uncheckedSkip :: Int -> Get ()+-- | Skip ahead @n@ bytes. No error if there isn't enough bytes.+uncheckedSkip :: Int64 -> Get () uncheckedSkip n = do- S s bytes <- get- let rest = L.drop (fromIntegral n) s- put $! S rest (bytes + (fromIntegral n))- return ()+ S s ss bytes <- get+ if fromIntegral (B.length s) >= n+ then put (S (B.drop (fromIntegral n) s) ss (bytes + n))+ else do+ let rest = L.drop (n - fromIntegral (B.length s)) ss+ put $! mkState rest (bytes + n) --- | Run @ga@, but return withou consuming its input.+-- | Run @ga@, but return without consuming its input. -- Fails if @ga@ fails. lookAhead :: Get a -> Get a lookAhead ga = do@@ -130,7 +171,7 @@ put s return a --- | Like 'lookAhead', but consume the input if @g@ returns 'Just _'.+-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. -- Fails if @gma@ fails. lookAheadM :: Get (Maybe a) -> Get (Maybe a) lookAheadM gma = do@@ -140,7 +181,7 @@ put s return ma --- | Like 'lookAhead', but consume the input if @g@ returns 'Right _'.+-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. -- Fails if @gea@ fails. lookAheadE :: Get (Either a b) -> Get (Either a b) lookAheadE gea = do@@ -152,149 +193,234 @@ return ea -- | Get the next up to @n@ bytes as a lazy ByteString, without consuming them. -uncheckedLookAhead :: Int -> Get L.ByteString+uncheckedLookAhead :: Int64 -> Get L.ByteString uncheckedLookAhead n = do- S s _ <- get- return $ L.take (fromIntegral n) s+ S s ss _ <- get+ if n <= fromIntegral (B.length s)+ then return (L.fromChunks [B.take (fromIntegral n) s])+ else return $ L.take n (s `join` ss) +------------------------------------------------------------------------+-- Utility++-- | Get the total number of bytes read to this point.+bytesRead :: Get Int64+bytesRead = do+ S _ _ b <- get+ return b+ -- | Get the number of remaining unparsed bytes. -- Useful for checking whether all input has been consumed. -- Note that this forces the rest of the input. remaining :: Get Int64 remaining = do- S s _ <- get- return (L.length s)+ S s ss _ <- get+ return (fromIntegral (B.length s) + L.length ss) -- | Test whether all input has been consumed, -- i.e. there are no remaining unparsed bytes. isEmpty :: Get Bool isEmpty = do- S s _ <- get- return (L.null s)+ S s ss _ <- get+ return (B.null s && L.null ss) --------------------------------------------------------------------------- Helpers+-- Utility with ByteStrings --- 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 #-}+-- | An efficient 'get' method for strict ByteStrings. Fails if fewer+-- than @n@ bytes are left in the input.+getByteString :: Int -> Get B.ByteString+getByteString n = readN n id+{-# INLINE getByteString #-} --- | Pull up to @n@ bytes from the input. -getBytes :: Int -> Get L.ByteString+-- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than+-- @n@ bytes are left in the input.+getLazyByteString :: Int64 -> Get L.ByteString+getLazyByteString n = do+ S s ss bytes <- get+ let big = s `join` ss+ case splitAtST n big of+ (consume, rest) -> do put $ mkState rest (bytes + n)+ return consume+{-# INLINE getLazyByteString #-}++-- | Get the remaining bytes as a lazy ByteString+getRemainingLazyByteString :: Get L.ByteString+getRemainingLazyByteString = do+ S s ss _ <- get+ return (s `join` ss)++------------------------------------------------------------------------+-- Helpers++-- | Pull @n@ bytes from the input, as a strict ByteString.+getBytes :: Int -> Get B.ByteString getBytes n = do- S s bytes <- get- let (consuming, rest) = L.splitAt (fromIntegral n) s- put $! S rest (bytes + (fromIntegral n))- return consuming+ S s ss bytes <- get+ if n <= B.length s+ then do let (consume,rest) = B.splitAt n s+ put $! S rest ss (bytes + fromIntegral n)+ return $! consume+ else+ case L.splitAt (fromIntegral n) (s `join` ss) of+ (consuming, rest) ->+ do let now = B.concat . L.toChunks $ consuming+ put $! mkState rest (bytes + fromIntegral n)+ -- forces the next chunk before this one is returned+ when (B.length now < n) $+ fail "too few bytes"+ return now {-# INLINE getBytes #-} -- ^ important +join :: B.ByteString -> L.ByteString -> L.ByteString+join bb (B.LPS lb)+ | B.null bb = B.LPS lb+ | otherwise = B.LPS (bb:lb)+ -- don't use L.append, it's strict in it's second argument :/+{-# INLINE join #-}++-- | Split a ByteString. If the first result is consumed before the --+-- second, this runs in constant heap space.+--+-- You must force the returned tuple for that to work, e.g.+-- +-- > case splitAtST n xs of+-- > (ys,zs) -> consume ys ... consume zs+--+splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString)+splitAtST i p | i <= 0 = (L.empty, p)+splitAtST i (B.LPS ps) = runST (+ do r <- newSTRef undefined+ xs <- first r i ps+ ys <- unsafeInterleaveST (readSTRef r)+ return (B.LPS xs, B.LPS ys))+ where first r 0 xs = writeSTRef r xs >> return []+ first r _ [] = writeSTRef r [] >> return []+ first r n (x:xs)+ | n < l = do writeSTRef r (B.drop (fromIntegral n) x : xs)+ return [B.take (fromIntegral n) x]+ | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs)))+ fmap (x:) $ unsafeInterleaveST (first r (n - l) xs)+ where l = fromIntegral (B.length x) +{-# INLINE splitAtST #-}+ -- 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)+-- yielding a value. If less than @n@ bytes are available, fail with an+-- error. This wraps @getBytes@.+readN :: Int -> (B.ByteString -> a) -> Get a+readN n f = fmap f $ getBytes n {-# INLINE readN #-} -- ^ important ------------------------------------------------------------------------+-- Primtives --- | An efficient 'get' method for strict ByteStrings-getByteString :: Int -> Get B.ByteString-getByteString n = readN (fromIntegral n) (B.concat . L.toChunks)-{-# INLINE getByteString #-}+-- helper, get a raw Ptr onto a strict ByteString copied out of the+-- underlying lazy byteString. So many indirections from the raw parser+-- state that my head hurts... --- | 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 #-}+getPtr :: Storable a => Int -> Get a+getPtr n = do+ (fp,o,_) <- readN n B.toForeignPtr+ return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)+{-# INLINE getPtr #-} --------------------------------------------------------------------------- Primtives -- | Read a Word8 from the monad state getWord8 :: Get Word8-getWord8 = readN 1 L.head+getWord8 = getPtr (sizeOf (undefined :: Word8)) {-# 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))+ s <- readN 2 id+ return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|.+ (fromIntegral (s `B.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+ s <- readN 2 id+ return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|.+ (fromIntegral (s `B.index` 0) ) {-# 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) )+ s <- readN 4 id+ return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|.+ (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|.+ (fromIntegral (s `B.index` 2) `shiftl_w32` 8) .|.+ (fromIntegral (s `B.index` 3) ) {-# INLINE getWord32be #-} -- | 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)+ s <- readN 4 id+ return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|.+ (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|.+ (fromIntegral (s `B.index` 1) `shiftl_w32` 8) .|.+ (fromIntegral (s `B.index` 0) ) {-# INLINE getWord32le #-} -- | 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) )+ s <- readN 8 id+ return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|.+ (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|.+ (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|.+ (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|.+ (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|.+ (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|.+ (fromIntegral (s `B.index` 6) `shiftl_w64` 8) .|.+ (fromIntegral (s `B.index` 7) ) {-# INLINE getWord64be #-} -- | 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)+ s <- readN 8 id+ return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|.+ (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|.+ (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|.+ (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|.+ (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|.+ (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|.+ (fromIntegral (s `B.index` 1) `shiftl_w64` 8) .|.+ (fromIntegral (s `B.index` 0) ) {-# INLINE getWord64le #-}++------------------------------------------------------------------------+-- Host-endian reads++-- | /O(1)./ Read a single native machine word. The word is read in+-- host order, host endian form, for the machine you're on. On a 64 bit+-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes.+getWordhost :: Get Word+getWordhost = getPtr (sizeOf (undefined :: Word))+{-# INLINE getWordhost #-}++-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness.+getWord16host :: Get Word16+getWord16host = getPtr (sizeOf (undefined :: Word16))+{-# INLINE getWord16host #-}++-- | /O(1)./ Read a Word32 in native host order and host endianness.+getWord32host :: Get Word32+getWord32host = getPtr (sizeOf (undefined :: Word32))+{-# INLINE getWord32host #-}++-- | /O(1)./ Read a Word64 in native host order and host endianess.+getWord64host :: Get Word64+getWord64host = getPtr (sizeOf (undefined :: Word64))+{-# INLINE getWord64host #-} ------------------------------------------------------------------------ -- Unchecked shifts
src/Data/Binary/Put.hs view
@@ -16,6 +16,7 @@ -- * The Put type Put+ , PutM(..) , runPut -- * Flushing the implicit parse state@@ -36,6 +37,12 @@ , putWord32le , putWord64le + -- * Host-endian, unaligned writes+ , putWordhost -- :: Word -> Put+ , putWord16host -- :: Word16 -> Put+ , putWord32host -- :: Word32 -> Put+ , putWord64host -- :: Word64 -> Put+ ) where import Data.Binary.Builder (Builder, toLazyByteString)@@ -47,9 +54,10 @@ ------------------------------------------------------------------------ --- | The Put types. A Writer monad over the efficient Builder monoid.--- Put merely lifts Builder into a monad+-- | The PutM type. A Writer monad over the efficient Builder monoid. newtype PutM a = Put { unPut :: (a, Builder) }++-- | Put merely lifts Builder into a Write monad, applied to (). type Put = PutM () instance Functor PutM where@@ -124,3 +132,34 @@ putWord64le :: Word64 -> Put putWord64le = tell . B.putWord64le {-# INLINE putWord64le #-}++------------------------------------------------------------------------++-- | /O(1)./ Write a single native machine word. The word is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or word sized machines, without conversion.+--+putWordhost :: Word -> Put+putWordhost = tell . B.putWordhost+{-# INLINE putWordhost #-}++-- | /O(1)./ Write a Word16 in native host order and host endianness.+-- For portability issues see @putWordhost@.+putWord16host :: Word16 -> Put+putWord16host = tell . B.putWord16host+{-# INLINE putWord16host #-}++-- | /O(1)./ Write a Word32 in native host order and host endianness.+-- For portability issues see @putWordhost@.+putWord32host :: Word32 -> Put+putWord32host = tell . B.putWord32host+{-# INLINE putWord32host #-}++-- | /O(1)./ Write a Word64 in native host order+-- On a 32 bit machine we write two host order Word32s, in big endian form.+-- For portability issues see @putWordhost@.+putWord64host :: Word64 -> Put+putWord64host = tell . B.putWord64host+{-# INLINE putWord64host #-}
tests/Benchmark.hs view
@@ -1,590 +1,1462 @@-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+{-# OPTIONS -fbang-patterns #-}+module Main (main) where++import qualified Data.ByteString.Lazy as L+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get++import Control.Exception+import System.CPUTime+import Numeric+import Text.Printf++import MemBench++data Endian+ = Big+ | Little+ | Host+ deriving (Eq,Ord,Show)++mb :: Int+mb = 10++main :: IO ()+main = do+ memBench (mb*10)+ putStrLn ""+ putStrLn "Binary (de)serialisation benchmarks:"++ -- do bytewise + sequence_+ [ test wordSize chunkSize Host mb+ | wordSize <- [1]+ , chunkSize <- [1,2,4,8,16]+ ]++ -- now Word16 .. Word64+ sequence_+ [ test wordSize chunkSize end mb+ | wordSize <- [2,4,8]+ , chunkSize <- [1,2,4,8,16]+ , end <- [Host,Big,Little]+ ]++------------------------------------------------------------------------++time :: IO a -> IO Double+time action = do+ start <- getCPUTime+ action+ end <- getCPUTime+ return $! (fromIntegral (end - start)) / (10^12)++------------------------------------------------------------------------++test :: Int -> Int -> Endian -> Int -> IO ()+test wordSize chunkSize end mb = do+ let bytes :: Int+ bytes = mb * 2^20+ iterations = bytes `div` wordSize+ bs = runPut (doPut wordSize chunkSize end iterations)+ sum = runGet (doGet wordSize chunkSize end iterations) bs++ case (chunkSize,end) of (1,Host) -> putStrLn "" ; _ -> return ()++ printf "%dMB of Word%-2d in chunks of %2d (%6s endian): "+ (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end)++ putSeconds <- time $ evaluate (L.length bs)+ getSeconds <- time $ evaluate sum+-- print (L.length bs, sum)+ let putThroughput = fromIntegral mb / putSeconds+ getThroughput = fromIntegral mb / getSeconds++ printf "%6.1f MB/s write, %6.1f MB/s read, %5.1f get/put-ratio\n"+ putThroughput+ getThroughput+ (getThroughput/putThroughput)++------------------------------------------------------------------------++doPut :: Int -> Int -> Endian -> Int -> Put+doPut wordSize chunkSize end = case (wordSize, chunkSize, end) of+ (1, 1,_) -> putWord8N1+ (1, 2,_) -> putWord8N2+ (1, 4,_) -> putWord8N4+ (1, 8,_) -> putWord8N8+ (1, 16, _) -> putWord8N16++ (2, 1, Big) -> putWord16N1Big+ (2, 2, Big) -> putWord16N2Big+ (2, 4, Big) -> putWord16N4Big+ (2, 8, Big) -> putWord16N8Big+ (2, 16, Big) -> putWord16N16Big+ (2, 1, Little) -> putWord16N1Little+ (2, 2, Little) -> putWord16N2Little+ (2, 4, Little) -> putWord16N4Little+ (2, 8, Little) -> putWord16N8Little+ (2, 16, Little) -> putWord16N16Little+ (2, 1, Host) -> putWord16N1Host+ (2, 2, Host) -> putWord16N2Host+ (2, 4, Host) -> putWord16N4Host+ (2, 8, Host) -> putWord16N8Host+ (2, 16, Host) -> putWord16N16Host++ (4, 1, Big) -> putWord32N1Big+ (4, 2, Big) -> putWord32N2Big+ (4, 4, Big) -> putWord32N4Big+ (4, 8, Big) -> putWord32N8Big+ (4, 16, Big) -> putWord32N16Big+ (4, 1, Little) -> putWord32N1Little+ (4, 2, Little) -> putWord32N2Little+ (4, 4, Little) -> putWord32N4Little+ (4, 8, Little) -> putWord32N8Little+ (4, 16, Little) -> putWord32N16Little+ (4, 1, Host) -> putWord32N1Host+ (4, 2, Host) -> putWord32N2Host+ (4, 4, Host) -> putWord32N4Host+ (4, 8, Host) -> putWord32N8Host+ (4, 16, Host) -> putWord32N16Host++ (8, 1, Host) -> putWord64N1Host+ (8, 2, Host) -> putWord64N2Host+ (8, 4, Host) -> putWord64N4Host+ (8, 8, Host) -> putWord64N8Host+ (8, 16, Host) -> putWord64N16Host+ (8, 1, Big) -> putWord64N1Big+ (8, 2, Big) -> putWord64N2Big+ (8, 4, Big) -> putWord64N4Big+ (8, 8, Big) -> putWord64N8Big+ (8, 16, Big) -> putWord64N16Big+ (8, 1, Little) -> putWord64N1Little+ (8, 2, Little) -> putWord64N2Little+ (8, 4, Little) -> putWord64N4Little+ (8, 8, Little) -> putWord64N8Little+ (8, 16, Little) -> putWord64N16Little++------------------------------------------------------------------------++doGet :: Int -> Int -> Endian -> Int -> Get Int+doGet wordSize chunkSize end =+ case (wordSize, chunkSize, end) of+ (1, 1,_) -> fmap fromIntegral . getWord8N1+ (1, 2,_) -> fmap fromIntegral . getWord8N2+ (1, 4,_) -> fmap fromIntegral . getWord8N4+ (1, 8,_) -> fmap fromIntegral . getWord8N8+ (1, 16,_) -> fmap fromIntegral . getWord8N16++ (2, 1,Big) -> fmap fromIntegral . getWord16N1Big+ (2, 2,Big) -> fmap fromIntegral . getWord16N2Big+ (2, 4,Big) -> fmap fromIntegral . getWord16N4Big+ (2, 8,Big) -> fmap fromIntegral . getWord16N8Big+ (2, 16,Big) -> fmap fromIntegral . getWord16N16Big+ (2, 1,Little) -> fmap fromIntegral . getWord16N1Little+ (2, 2,Little) -> fmap fromIntegral . getWord16N2Little+ (2, 4,Little) -> fmap fromIntegral . getWord16N4Little+ (2, 8,Little) -> fmap fromIntegral . getWord16N8Little+ (2, 16,Little) -> fmap fromIntegral . getWord16N16Little+ (2, 1,Host) -> fmap fromIntegral . getWord16N1Host+ (2, 2,Host) -> fmap fromIntegral . getWord16N2Host+ (2, 4,Host) -> fmap fromIntegral . getWord16N4Host+ (2, 8,Host) -> fmap fromIntegral . getWord16N8Host+ (2, 16,Host) -> fmap fromIntegral . getWord16N16Host++ (4, 1,Big) -> fmap fromIntegral . getWord32N1Big+ (4, 2,Big) -> fmap fromIntegral . getWord32N2Big+ (4, 4,Big) -> fmap fromIntegral . getWord32N4Big+ (4, 8,Big) -> fmap fromIntegral . getWord32N8Big+ (4, 16,Big) -> fmap fromIntegral . getWord32N16Big+ (4, 1,Little) -> fmap fromIntegral . getWord32N1Little+ (4, 2,Little) -> fmap fromIntegral . getWord32N2Little+ (4, 4,Little) -> fmap fromIntegral . getWord32N4Little+ (4, 8,Little) -> fmap fromIntegral . getWord32N8Little+ (4, 16,Little) -> fmap fromIntegral . getWord32N16Little+ (4, 1,Host) -> fmap fromIntegral . getWord32N1Host+ (4, 2,Host) -> fmap fromIntegral . getWord32N2Host+ (4, 4,Host) -> fmap fromIntegral . getWord32N4Host+ (4, 8,Host) -> fmap fromIntegral . getWord32N8Host+ (4, 16,Host) -> fmap fromIntegral . getWord32N16Host++ (8, 1,Host) -> fmap fromIntegral . getWord64N1Host+ (8, 2,Host) -> fmap fromIntegral . getWord64N2Host+ (8, 4,Host) -> fmap fromIntegral . getWord64N4Host+ (8, 8,Host) -> fmap fromIntegral . getWord64N8Host+ (8, 16,Host) -> fmap fromIntegral . getWord64N16Host+ (8, 1,Big) -> fmap fromIntegral . getWord64N1Big+ (8, 2,Big) -> fmap fromIntegral . getWord64N2Big+ (8, 4,Big) -> fmap fromIntegral . getWord64N4Big+ (8, 8,Big) -> fmap fromIntegral . getWord64N8Big+ (8, 16,Big) -> fmap fromIntegral . getWord64N16Big+ (8, 1,Little) -> fmap fromIntegral . getWord64N1Little+ (8, 2,Little) -> fmap fromIntegral . getWord64N2Little+ (8, 4,Little) -> fmap fromIntegral . getWord64N4Little+ (8, 8,Little) -> fmap fromIntegral . getWord64N8Little+ (8, 16,Little) -> fmap fromIntegral . getWord64N16Little++------------------------------------------------------------------------++putWord8N1 bytes = loop 0 0+ where loop :: Word8 -> Int -> Put+ loop !s !n | n == bytes = return ()+ | otherwise = do putWord8 s+ loop (s+1) (n+1)++putWord8N2 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 (s+0)+ putWord8 (s+1)+ loop (s+2) (n-2)++putWord8N4 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 (s+0)+ putWord8 (s+1)+ putWord8 (s+2)+ putWord8 (s+3)+ loop (s+4) (n-4)++putWord8N8 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 (s+0)+ putWord8 (s+1)+ putWord8 (s+2)+ putWord8 (s+3)+ putWord8 (s+4)+ putWord8 (s+5)+ putWord8 (s+6)+ putWord8 (s+7)+ loop (s+8) (n-8)++putWord8N16 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord8 (s+0)+ putWord8 (s+1)+ putWord8 (s+2)+ putWord8 (s+3)+ putWord8 (s+4)+ putWord8 (s+5)+ putWord8 (s+6)+ putWord8 (s+7)+ putWord8 (s+8)+ putWord8 (s+9)+ putWord8 (s+10)+ putWord8 (s+11)+ putWord8 (s+12)+ putWord8 (s+13)+ putWord8 (s+14)+ putWord8 (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------+-- Big endian, word16 writes++putWord16N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be (s+0)+ loop (s+1) (n-1)++putWord16N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be (s+0)+ putWord16be (s+1)+ loop (s+2) (n-2)++putWord16N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be (s+0)+ putWord16be (s+1)+ putWord16be (s+2)+ putWord16be (s+3)+ loop (s+4) (n-4)++putWord16N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be (s+0)+ putWord16be (s+1)+ putWord16be (s+2)+ putWord16be (s+3)+ putWord16be (s+4)+ putWord16be (s+5)+ putWord16be (s+6)+ putWord16be (s+7)+ loop (s+8) (n-8)++putWord16N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16be (s+0)+ putWord16be (s+1)+ putWord16be (s+2)+ putWord16be (s+3)+ putWord16be (s+4)+ putWord16be (s+5)+ putWord16be (s+6)+ putWord16be (s+7)+ putWord16be (s+8)+ putWord16be (s+9)+ putWord16be (s+10)+ putWord16be (s+11)+ putWord16be (s+12)+ putWord16be (s+13)+ putWord16be (s+14)+ putWord16be (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------+-- Little endian, word16 writes++putWord16N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16le (s+0)+ loop (s+1) (n-1)++putWord16N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16le (s+0)+ putWord16le (s+1)+ loop (s+2) (n-2)++putWord16N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16le (s+0)+ putWord16le (s+1)+ putWord16le (s+2)+ putWord16le (s+3)+ loop (s+4) (n-4)++putWord16N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16le (s+0)+ putWord16le (s+1)+ putWord16le (s+2)+ putWord16le (s+3)+ putWord16le (s+4)+ putWord16le (s+5)+ putWord16le (s+6)+ putWord16le (s+7)+ loop (s+8) (n-8)++putWord16N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16le (s+0)+ putWord16le (s+1)+ putWord16le (s+2)+ putWord16le (s+3)+ putWord16le (s+4)+ putWord16le (s+5)+ putWord16le (s+6)+ putWord16le (s+7)+ putWord16le (s+8)+ putWord16le (s+9)+ putWord16le (s+10)+ putWord16le (s+11)+ putWord16le (s+12)+ putWord16le (s+13)+ putWord16le (s+14)+ putWord16le (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------+-- Host endian, unaligned, word16 writes++putWord16N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16host (s+0)+ loop (s+1) (n-1)++putWord16N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16host (s+0)+ putWord16host (s+1)+ loop (s+2) (n-2)++putWord16N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16host (s+0)+ putWord16host (s+1)+ putWord16host (s+2)+ putWord16host (s+3)+ loop (s+4) (n-4)++putWord16N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16host (s+0)+ putWord16host (s+1)+ putWord16host (s+2)+ putWord16host (s+3)+ putWord16host (s+4)+ putWord16host (s+5)+ putWord16host (s+6)+ putWord16host (s+7)+ loop (s+8) (n-8)++putWord16N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord16host (s+0)+ putWord16host (s+1)+ putWord16host (s+2)+ putWord16host (s+3)+ putWord16host (s+4)+ putWord16host (s+5)+ putWord16host (s+6)+ putWord16host (s+7)+ putWord16host (s+8)+ putWord16host (s+9)+ putWord16host (s+10)+ putWord16host (s+11)+ putWord16host (s+12)+ putWord16host (s+13)+ putWord16host (s+14)+ putWord16host (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be (s+0)+ loop (s+1) (n-1)++putWord32N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be (s+0)+ putWord32be (s+1)+ loop (s+2) (n-2)++putWord32N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be (s+0)+ putWord32be (s+1)+ putWord32be (s+2)+ putWord32be (s+3)+ loop (s+4) (n-4)++putWord32N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be (s+0)+ putWord32be (s+1)+ putWord32be (s+2)+ putWord32be (s+3)+ putWord32be (s+4)+ putWord32be (s+5)+ putWord32be (s+6)+ putWord32be (s+7)+ loop (s+8) (n-8)++putWord32N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32be (s+0)+ putWord32be (s+1)+ putWord32be (s+2)+ putWord32be (s+3)+ putWord32be (s+4)+ putWord32be (s+5)+ putWord32be (s+6)+ putWord32be (s+7)+ putWord32be (s+8)+ putWord32be (s+9)+ putWord32be (s+10)+ putWord32be (s+11)+ putWord32be (s+12)+ putWord32be (s+13)+ putWord32be (s+14)+ putWord32be (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32le (s+0)+ loop (s+1) (n-1)++putWord32N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32le (s+0)+ putWord32le (s+1)+ loop (s+2) (n-2)++putWord32N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32le (s+0)+ putWord32le (s+1)+ putWord32le (s+2)+ putWord32le (s+3)+ loop (s+4) (n-4)++putWord32N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32le (s+0)+ putWord32le (s+1)+ putWord32le (s+2)+ putWord32le (s+3)+ putWord32le (s+4)+ putWord32le (s+5)+ putWord32le (s+6)+ putWord32le (s+7)+ loop (s+8) (n-8)++putWord32N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32le (s+0)+ putWord32le (s+1)+ putWord32le (s+2)+ putWord32le (s+3)+ putWord32le (s+4)+ putWord32le (s+5)+ putWord32le (s+6)+ putWord32le (s+7)+ putWord32le (s+8)+ putWord32le (s+9)+ putWord32le (s+10)+ putWord32le (s+11)+ putWord32le (s+12)+ putWord32le (s+13)+ putWord32le (s+14)+ putWord32le (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord32N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32host (s+0)+ loop (s+1) (n-1)++putWord32N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32host (s+0)+ putWord32host (s+1)+ loop (s+2) (n-2)++putWord32N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32host (s+0)+ putWord32host (s+1)+ putWord32host (s+2)+ putWord32host (s+3)+ loop (s+4) (n-4)++putWord32N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32host (s+0)+ putWord32host (s+1)+ putWord32host (s+2)+ putWord32host (s+3)+ putWord32host (s+4)+ putWord32host (s+5)+ putWord32host (s+6)+ putWord32host (s+7)+ loop (s+8) (n-8)++putWord32N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord32host (s+0)+ putWord32host (s+1)+ putWord32host (s+2)+ putWord32host (s+3)+ putWord32host (s+4)+ putWord32host (s+5)+ putWord32host (s+6)+ putWord32host (s+7)+ putWord32host (s+8)+ putWord32host (s+9)+ putWord32host (s+10)+ putWord32host (s+11)+ putWord32host (s+12)+ putWord32host (s+13)+ putWord32host (s+14)+ putWord32host (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be (s+0)+ loop (s+1) (n-1)++putWord64N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be (s+0)+ putWord64be (s+1)+ loop (s+2) (n-2)++putWord64N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be (s+0)+ putWord64be (s+1)+ putWord64be (s+2)+ putWord64be (s+3)+ loop (s+4) (n-4)++putWord64N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be (s+0)+ putWord64be (s+1)+ putWord64be (s+2)+ putWord64be (s+3)+ putWord64be (s+4)+ putWord64be (s+5)+ putWord64be (s+6)+ putWord64be (s+7)+ loop (s+8) (n-8)++putWord64N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64be (s+0)+ putWord64be (s+1)+ putWord64be (s+2)+ putWord64be (s+3)+ putWord64be (s+4)+ putWord64be (s+5)+ putWord64be (s+6)+ putWord64be (s+7)+ putWord64be (s+8)+ putWord64be (s+9)+ putWord64be (s+10)+ putWord64be (s+11)+ putWord64be (s+12)+ putWord64be (s+13)+ putWord64be (s+14)+ putWord64be (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64le (s+0)+ loop (s+1) (n-1)++putWord64N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64le (s+0)+ putWord64le (s+1)+ loop (s+2) (n-2)++putWord64N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64le (s+0)+ putWord64le (s+1)+ putWord64le (s+2)+ putWord64le (s+3)+ loop (s+4) (n-4)++putWord64N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64le (s+0)+ putWord64le (s+1)+ putWord64le (s+2)+ putWord64le (s+3)+ putWord64le (s+4)+ putWord64le (s+5)+ putWord64le (s+6)+ putWord64le (s+7)+ loop (s+8) (n-8)++putWord64N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64le (s+0)+ putWord64le (s+1)+ putWord64le (s+2)+ putWord64le (s+3)+ putWord64le (s+4)+ putWord64le (s+5)+ putWord64le (s+6)+ putWord64le (s+7)+ putWord64le (s+8)+ putWord64le (s+9)+ putWord64le (s+10)+ putWord64le (s+11)+ putWord64le (s+12)+ putWord64le (s+13)+ putWord64le (s+14)+ putWord64le (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------++putWord64N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64host (s+0)+ loop (s+1) (n-1)++putWord64N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64host (s+0)+ putWord64host (s+1)+ loop (s+2) (n-2)++putWord64N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64host (s+0)+ putWord64host (s+1)+ putWord64host (s+2)+ putWord64host (s+3)+ loop (s+4) (n-4)++putWord64N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64host (s+0)+ putWord64host (s+1)+ putWord64host (s+2)+ putWord64host (s+3)+ putWord64host (s+4)+ putWord64host (s+5)+ putWord64host (s+6)+ putWord64host (s+7)+ loop (s+8) (n-8)++putWord64N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop _ 0 = return ()+ loop s n = do+ putWord64host (s+0)+ putWord64host (s+1)+ putWord64host (s+2)+ putWord64host (s+3)+ putWord64host (s+4)+ putWord64host (s+5)+ putWord64host (s+6)+ putWord64host (s+7)+ putWord64host (s+8)+ putWord64host (s+9)+ putWord64host (s+10)+ putWord64host (s+11)+ putWord64host (s+12)+ putWord64host (s+13)+ putWord64host (s+14)+ putWord64host (s+15)+ loop (s+16) (n-16)++------------------------------------------------------------------------+------------------------------------------------------------------------++getWord8N1 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord8+ loop (s+s0) (n-1)++getWord8N2 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord8+ s1 <- getWord8+ loop (s+s0+s1) (n-2)++getWord8N4 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord8+ s1 <- getWord8+ s2 <- getWord8+ s3 <- getWord8+ loop (s+s0+s1+s2+s3) (n-4)++getWord8N8 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord8+ s1 <- getWord8+ s2 <- getWord8+ s3 <- getWord8+ s4 <- getWord8+ s5 <- getWord8+ s6 <- getWord8+ s7 <- getWord8+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord8N16 = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord8+ s1 <- getWord8+ s2 <- getWord8+ s3 <- getWord8+ s4 <- getWord8+ s5 <- getWord8+ s6 <- getWord8+ s7 <- getWord8+ s8 <- getWord8+ s9 <- getWord8+ s10 <- getWord8+ s11 <- getWord8+ s12 <- getWord8+ s13 <- getWord8+ s14 <- getWord8+ s15 <- getWord8+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be+ loop (s+s0) (n-1)++getWord16N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be+ s1 <- getWord16be+ loop (s+s0+s1) (n-2)++getWord16N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be+ s1 <- getWord16be+ s2 <- getWord16be+ s3 <- getWord16be+ loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be+ s1 <- getWord16be+ s2 <- getWord16be+ s3 <- getWord16be+ s4 <- getWord16be+ s5 <- getWord16be+ s6 <- getWord16be+ s7 <- getWord16be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16be+ s1 <- getWord16be+ s2 <- getWord16be+ s3 <- getWord16be+ s4 <- getWord16be+ s5 <- getWord16be+ s6 <- getWord16be+ s7 <- getWord16be+ s8 <- getWord16be+ s9 <- getWord16be+ s10 <- getWord16be+ s11 <- getWord16be+ s12 <- getWord16be+ s13 <- getWord16be+ s14 <- getWord16be+ s15 <- getWord16be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16le+ loop (s+s0) (n-1)++getWord16N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16le+ s1 <- getWord16le+ loop (s+s0+s1) (n-2)++getWord16N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16le+ s1 <- getWord16le+ s2 <- getWord16le+ s3 <- getWord16le+ loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16le+ s1 <- getWord16le+ s2 <- getWord16le+ s3 <- getWord16le+ s4 <- getWord16le+ s5 <- getWord16le+ s6 <- getWord16le+ s7 <- getWord16le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16le+ s1 <- getWord16le+ s2 <- getWord16le+ s3 <- getWord16le+ s4 <- getWord16le+ s5 <- getWord16le+ s6 <- getWord16le+ s7 <- getWord16le+ s8 <- getWord16le+ s9 <- getWord16le+ s10 <- getWord16le+ s11 <- getWord16le+ s12 <- getWord16le+ s13 <- getWord16le+ s14 <- getWord16le+ s15 <- getWord16le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord16N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16host+ loop (s+s0) (n-1)++getWord16N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16host+ s1 <- getWord16host+ loop (s+s0+s1) (n-2)++getWord16N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16host+ s1 <- getWord16host+ s2 <- getWord16host+ s3 <- getWord16host+ loop (s+s0+s1+s2+s3) (n-4)++getWord16N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16host+ s1 <- getWord16host+ s2 <- getWord16host+ s3 <- getWord16host+ s4 <- getWord16host+ s5 <- getWord16host+ s6 <- getWord16host+ s7 <- getWord16host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord16N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord16host+ s1 <- getWord16host+ s2 <- getWord16host+ s3 <- getWord16host+ s4 <- getWord16host+ s5 <- getWord16host+ s6 <- getWord16host+ s7 <- getWord16host+ s8 <- getWord16host+ s9 <- getWord16host+ s10 <- getWord16host+ s11 <- getWord16host+ s12 <- getWord16host+ s13 <- getWord16host+ s14 <- getWord16host+ s15 <- getWord16host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be+ loop (s+s0) (n-1)++getWord32N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be+ s1 <- getWord32be+ loop (s+s0+s1) (n-2)++getWord32N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be+ s1 <- getWord32be+ s2 <- getWord32be+ s3 <- getWord32be+ loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be+ s1 <- getWord32be+ s2 <- getWord32be+ s3 <- getWord32be+ s4 <- getWord32be+ s5 <- getWord32be+ s6 <- getWord32be+ s7 <- getWord32be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32be+ s1 <- getWord32be+ s2 <- getWord32be+ s3 <- getWord32be+ s4 <- getWord32be+ s5 <- getWord32be+ s6 <- getWord32be+ s7 <- getWord32be+ s8 <- getWord32be+ s9 <- getWord32be+ s10 <- getWord32be+ s11 <- getWord32be+ s12 <- getWord32be+ s13 <- getWord32be+ s14 <- getWord32be+ s15 <- getWord32be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32le+ loop (s+s0) (n-1)++getWord32N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32le+ s1 <- getWord32le+ loop (s+s0+s1) (n-2)++getWord32N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32le+ s1 <- getWord32le+ s2 <- getWord32le+ s3 <- getWord32le+ loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32le+ s1 <- getWord32le+ s2 <- getWord32le+ s3 <- getWord32le+ s4 <- getWord32le+ s5 <- getWord32le+ s6 <- getWord32le+ s7 <- getWord32le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32le+ s1 <- getWord32le+ s2 <- getWord32le+ s3 <- getWord32le+ s4 <- getWord32le+ s5 <- getWord32le+ s6 <- getWord32le+ s7 <- getWord32le+ s8 <- getWord32le+ s9 <- getWord32le+ s10 <- getWord32le+ s11 <- getWord32le+ s12 <- getWord32le+ s13 <- getWord32le+ s14 <- getWord32le+ s15 <- getWord32le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord32N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32host+ loop (s+s0) (n-1)++getWord32N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32host+ s1 <- getWord32host+ loop (s+s0+s1) (n-2)++getWord32N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32host+ s1 <- getWord32host+ s2 <- getWord32host+ s3 <- getWord32host+ loop (s+s0+s1+s2+s3) (n-4)++getWord32N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32host+ s1 <- getWord32host+ s2 <- getWord32host+ s3 <- getWord32host+ s4 <- getWord32host+ s5 <- getWord32host+ s6 <- getWord32host+ s7 <- getWord32host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++-- getWordhostN16 = loop 0+getWord32N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord32host+ s1 <- getWord32host+ s2 <- getWord32host+ s3 <- getWord32host+ s4 <- getWord32host+ s5 <- getWord32host+ s6 <- getWord32host+ s7 <- getWord32host+ s8 <- getWord32host+ s9 <- getWord32host+ s10 <- getWord32host+ s11 <- getWord32host+ s12 <- getWord32host+ s13 <- getWord32host+ s14 <- getWord32host+ s15 <- getWord32host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be+ loop (s+s0) (n-1)++getWord64N2Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be+ s1 <- getWord64be+ loop (s+s0+s1) (n-2)++getWord64N4Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be+ s1 <- getWord64be+ s2 <- getWord64be+ s3 <- getWord64be+ loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be+ s1 <- getWord64be+ s2 <- getWord64be+ s3 <- getWord64be+ s4 <- getWord64be+ s5 <- getWord64be+ s6 <- getWord64be+ s7 <- getWord64be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Big = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64be+ s1 <- getWord64be+ s2 <- getWord64be+ s3 <- getWord64be+ s4 <- getWord64be+ s5 <- getWord64be+ s6 <- getWord64be+ s7 <- getWord64be+ s8 <- getWord64be+ s9 <- getWord64be+ s10 <- getWord64be+ s11 <- getWord64be+ s12 <- getWord64be+ s13 <- getWord64be+ s14 <- getWord64be+ s15 <- getWord64be+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64le+ loop (s+s0) (n-1)++getWord64N2Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64le+ s1 <- getWord64le+ loop (s+s0+s1) (n-2)++getWord64N4Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64le+ s1 <- getWord64le+ s2 <- getWord64le+ s3 <- getWord64le+ loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64le+ s1 <- getWord64le+ s2 <- getWord64le+ s3 <- getWord64le+ s4 <- getWord64le+ s5 <- getWord64le+ s6 <- getWord64le+ s7 <- getWord64le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Little = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64le+ s1 <- getWord64le+ s2 <- getWord64le+ s3 <- getWord64le+ s4 <- getWord64le+ s5 <- getWord64le+ s6 <- getWord64le+ s7 <- getWord64le+ s8 <- getWord64le+ s9 <- getWord64le+ s10 <- getWord64le+ s11 <- getWord64le+ s12 <- getWord64le+ s13 <- getWord64le+ s14 <- getWord64le+ s15 <- getWord64le+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)++------------------------------------------------------------------------++getWord64N1Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64host+ loop (s+s0) (n-1)++getWord64N2Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64host+ s1 <- getWord64host+ loop (s+s0+s1) (n-2)++getWord64N4Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64host+ s1 <- getWord64host+ s2 <- getWord64host+ s3 <- getWord64host+ loop (s+s0+s1+s2+s3) (n-4)++getWord64N8Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64host+ s1 <- getWord64host+ s2 <- getWord64host+ s3 <- getWord64host+ s4 <- getWord64host+ s5 <- getWord64host+ s6 <- getWord64host+ s7 <- getWord64host+ loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)++getWord64N16Host = loop 0+ where loop s n | s `seq` n `seq` False = undefined+ loop s 0 = return s+ loop s n = do+ s0 <- getWord64host+ s1 <- getWord64host+ s2 <- getWord64host+ s3 <- getWord64host+ s4 <- getWord64host+ s5 <- getWord64host+ s6 <- getWord64host+ s7 <- getWord64host+ s8 <- getWord64host+ s9 <- getWord64host+ s10 <- getWord64host+ s11 <- getWord64host+ s12 <- getWord64host+ s13 <- getWord64host+ s14 <- getWord64host+ s15 <- getWord64host loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)
tests/CBenchmark.c view
@@ -19,19 +19,19 @@ return n; } -void wordwrite(unsigned int *a, int bytes) {- unsigned int n = 0;+void wordwrite(unsigned long *a, int bytes) {+ unsigned long n = 0; int i = 0;- int iterations = bytes / sizeof(unsigned int) ;+ int iterations = bytes / sizeof(unsigned long) ; while (i < iterations) { a[i++] = n++; } } -unsigned int wordread(unsigned int *a, int bytes) {- unsigned int n = 0;+unsigned int wordread(unsigned long *a, int bytes) {+ unsigned long n = 0; int i = 0;- int iterations = bytes / sizeof(unsigned int);+ int iterations = bytes / sizeof(unsigned long); while (i < iterations) { n += a[i++]; }
tests/CBenchmark.h view
@@ -1,4 +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);+void wordwrite(unsigned long *a, int bytes);+unsigned int wordread(unsigned long *a, int bytes);
+ tests/HeapUse.hs view
@@ -0,0 +1,17 @@+-- Checks heap behavior of getBytes++import Data.Binary.Get (runGet, getBytes)++import Control.Monad (liftM)+import qualified Data.ByteString.Lazy as L++main = do+ let x = (L.take 110000042 $ L.iterate (+1) 0)+ mapM_ (print . L.length) (chunks 20000000 x)++chunks n = runGet (unfoldM f)+ where f = do x <- getBytes 20000000 + return $ if L.null x then Nothing else Just x++unfoldM :: Monad m => m (Maybe a) -> m [a]+unfoldM f = f >>= maybe (return []) (\x -> liftM (x:) (unfoldM f))
tests/Makefile view
@@ -21,6 +21,13 @@ hugs: runhugs -98 QC.hs ++HeapUse: HeapUse.hs+ ghc --make -O $^ -fasm -o $@++heap: HeapUse+ ./HeapUse +RTS -M10M -t/dev/stderr -RTS+ clean: rm -f *.o *.hi qc bench bench-nb *~
tests/MemBench.hs view
@@ -33,7 +33,7 @@ bench "words read " hs_wordread hs_bytewrite :: Ptr CUChar -> Int -> IO ()-hs_bytewrite ptr bytes = loop 0 0+hs_bytewrite !ptr bytes = loop 0 0 where iterations = bytes loop :: Int -> CUChar -> IO () loop !i !n | i == iterations = return ()@@ -41,25 +41,25 @@ loop (i+1) (n+1) hs_byteread :: Ptr CUChar -> Int -> IO CUChar-hs_byteread ptr bytes = loop 0 0+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 ()+hs_wordwrite :: Ptr CULong -> Int -> IO ()+hs_wordwrite !ptr bytes = loop 0 0+ where iterations = bytes `div` sizeOf (undefined :: CULong)+ loop :: Int -> CULong -> IO () loop !i !n | i == iterations = return () | otherwise = do pokeByteOff ptr i n loop (i+1) (n+1) -hs_wordread :: Ptr CUInt -> Int -> IO CUInt-hs_wordread ptr bytes = loop 0 0- where iterations = bytes `div` sizeOf (undefined :: CUInt)- loop :: Int -> CUInt -> IO CUInt+hs_wordread :: Ptr CULong -> Int -> IO CULong+hs_wordread !ptr bytes = loop 0 0+ where iterations = bytes `div` sizeOf (undefined :: CULong)+ loop :: Int -> CULong -> IO CULong loop !i !n | i == iterations = return n | otherwise = do x <- peekByteOff ptr i loop (i+1) (n+x)
tests/QC.hs view
@@ -42,13 +42,18 @@ prop_Word16be = roundTripWith putWord16be getWord16be prop_Word16le = roundTripWith putWord16le getWord16le+prop_Word16host = roundTripWith putWord16host getWord16host prop_Word32be = roundTripWith putWord32be getWord32be prop_Word32le = roundTripWith putWord32le getWord32le+prop_Word32host = roundTripWith putWord32host getWord32host prop_Word64be = roundTripWith putWord64be getWord64be prop_Word64le = roundTripWith putWord64le getWord64le+prop_Word64host = roundTripWith putWord64host getWord64host +prop_Wordhost = roundTripWith putWordhost getWordhost+ invariant_lbs :: L.ByteString -> Bool invariant_lbs (B.LPS []) = True invariant_lbs (B.LPS xs) = all (not . B.null) xs@@ -112,10 +117,14 @@ -- Primitives , ("Word16be", p prop_Word16be) , ("Word16le", p prop_Word16le)+ , ("Word16host", p prop_Word16host) , ("Word32be", p prop_Word32be) , ("Word32le", p prop_Word32le)+ , ("Word32host", p prop_Word32host) , ("Word64be", p prop_Word64be) , ("Word64le", p prop_Word64le)+ , ("Word64host", p prop_Word64host)+ , ("Wordhost", p prop_Wordhost) -- higher level ones using the Binary class ,("()", p (test :: T () ))@@ -135,6 +144,9 @@ ,("Word", p (test :: T Word )) ,("Int", p (test :: T Int )) ,("Integer", p (test :: T Integer ))++ ,("Float", p (test :: T Float ))+ ,("Double", p (test :: T Double )) ,("Char", p (test :: T Char ))
tools/derive/BinaryDerive.hs view
@@ -1,10 +1,14 @@+{-# OPTIONS -fglasgow-exts #-} module BinaryDerive where import Data.Generics import Data.List -derive :: (Typeable a, Show a, Data a) => a -> String+deriveM :: (Typeable a, Data a) => a -> IO ()+deriveM (a :: a) = mapM_ putStrLn . lines $ derive (undefined :: a)++derive :: (Typeable a, Data a) => a -> String derive x = "instance " ++ context ++ "Binary " ++ inst ++ " where\n" ++ concat putDefs ++ getDefs@@ -39,7 +43,11 @@ (if length constrs > 1 then " get = do\n tag_ <- getWord8\n case tag_ of\n" else " get =")- ++ concatMap ((++"\n")) (map getDef constrs)+ ++ concatMap ((++"\n")) (map getDef constrs) +++ (if length constrs > 1+ then " _ -> fail \"no parse\""+ else ""+ ) getDef (n, (name, ps)) = let wrap = if ps /= 0 then ("("++) . (++")") else id in