binary 0.5.0.2 → 0.5.1.0
raw patch · 22 files changed
+575/−4514 lines, 22 filesnew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Data.Binary.Builder: instance Monoid Builder
+ Data.Binary.Builder: putCharUtf8 :: Char -> Builder
+ Data.Binary.Builder.Internal: writeAtMost :: Int -> (Ptr Word8 -> IO Int) -> Builder
+ Data.Binary.Builder.Internal: writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
Files
- binary.cabal +5/−2
- docs/hcar/binary-Lb.tex +0/−48
- src/Data/Binary.hs +3/−1
- src/Data/Binary/Builder.hs +7/−377
- src/Data/Binary/Builder/Base.hs +512/−0
- src/Data/Binary/Builder/Internal.hs +27/−0
- src/Data/Binary/Get.hs +15/−12
- src/Data/Binary/Put.hs +6/−1
- tests/Benchmark.hs +0/−1461
- tests/CBenchmark.c +0/−39
- tests/CBenchmark.h +0/−4
- tests/HeapUse.hs +0/−17
- tests/Makefile +0/−34
- tests/MemBench.hs +0/−85
- tests/NewBenchmark.hs +0/−625
- tests/NewBinary.hs +0/−1006
- tests/Parallel.hs +0/−147
- tests/QC.hs +0/−244
- tests/QuickCheckUtils.hs +0/−258
- todo +0/−28
- tools/derive/BinaryDerive.hs +0/−57
- tools/derive/Example.hs +0/−68
binary.cabal view
@@ -1,8 +1,8 @@ name: binary-version: 0.5.0.2+version: 0.5.1.0 license: BSD3 license-file: LICENSE-author: Lennart Kolmodin <kolmodin@dtek.chalmers.se>+author: Lennart Kolmodin <kolmodin@gmail.com> maintainer: Lennart Kolmodin, Don Stewart <dons@galois.com> homepage: http://code.haskell.org/binary/ description: Efficient, pure binary serialisation using lazy ByteStrings.@@ -48,6 +48,9 @@ Data.Binary.Put, Data.Binary.Get, Data.Binary.Builder+ Data.Binary.Builder.Internal++ other-modules: Data.Binary.Builder.Base extensions: CPP, FlexibleContexts
− docs/hcar/binary-Lb.tex
@@ -1,48 +0,0 @@-\begin{hcarentry}{binary}-\label{binary}-\report{Lennart Kolmodin}-\status{active}-\participants{Duncan Coutts, Don Stewart, Binary Strike Team}-\makeheader--The Binary Strike Team is pleased to announce yet a release of a new,-pure, efficient binary serialisation library.--The `binary' package provides efficient serialisation of Haskell values-to and from lazy ByteStrings. ByteStrings constructed this way may then-be written to disk, written to the network, or further processed (e.g.-stored in memory directly, or compressed in memory with zlib or bzlib).--The binary library has been heavily tuned for performance, particularly for-writing speed. Throughput of up to 160M/s has been achieved in practice, and-in general speed is on par or better than NewBinary, with the advantage of a-pure interface. Efforts are underway to improve performance still further.-Plans are also taking shape for a parser combinator library on top of-binary, for bit parsing and foreign structure parsing (e.g. network-protocols).--Data.Derive~\cref{derive} has support for automatically generating Binary-instances, allowing to read and write your data structures with little fuzz.--Binary was developed by a team of 8 during the Haskell Hackathon in Oxford-2007, and since then has about 15 people contributed code and many more-given feedback and cheerleading on \verb|#haskell|.--The package is cabalized and available through Hackage~\cref{hackagedb}.-% to editors: ref. to cabal?--\FurtherReading-\begin{compactitem}-\item Homepage-- \url{http://code.haskell.org/binary/}-\item Hackage-- \url{http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary}-\item Development version-- \texttt{darcs get --partial}-- \url{http://code.haskell.org/binary}-\end{compactitem}-\end{hcarentry}
src/Data/Binary.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Binary@@ -63,7 +66,6 @@ import Control.Monad import Foreign-import System.IO import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L
src/Data/Binary/Builder.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fglasgow-exts #-}--- for unboxed shifts-+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Builder@@ -16,10 +15,6 @@ -- ----------------------------------------------------------------------------- -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-#include "MachDeps.h"-#endif- module Data.Binary.Builder ( -- * The Builder type@@ -53,374 +48,9 @@ , putWord32host -- :: Word32 -> Builder , putWord64host -- :: Word64 -> Builder - ) where--import Foreign-import Data.Monoid-import Data.Word-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L--#ifdef BYTESTRING_IN_BASE-import Data.ByteString.Base (inlinePerformIO)-import qualified Data.ByteString.Base as S-#else-import Data.ByteString.Internal (inlinePerformIO)-import qualified Data.ByteString.Internal as S-import qualified Data.ByteString.Lazy.Internal as L-#endif--#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-import GHC.Base-import GHC.Word (Word32(..),Word16(..),Word64(..))--#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608-import GHC.Word (uncheckedShiftRL64#)-#endif-#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- {-# INLINE mempty #-}- mappend = append- {-# INLINE mappend #-}------------------------------------------------------------------------------ | /O(1)./ The empty Builder, satisfying------ * @'toLazyByteString' 'empty' = 'L.empty'@----empty :: Builder-empty = Builder id-{-# INLINE empty #-}---- | /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)-{-# INLINE append #-}---- | /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 :)-{-# INLINE fromByteString #-}---- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying------ * @'toLazyByteString' ('fromLazyByteString' bs) = bs@----fromLazyByteString :: L.ByteString -> Builder-fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++)-{-# INLINE fromLazyByteString #-}------------------------------------------------------------------------------ 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 = L.fromChunks $ unsafePerformIO $ 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 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-{-# INLINE newBuffer #-}----------------------------------------------------------------------------- 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 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------- | 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)----------------------------------------------------------------------------- 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--{-# INLINE shiftr_w16 #-}-shiftr_w16 :: Word16 -> Int -> Word16-{-# INLINE shiftr_w32 #-}-shiftr_w32 :: Word32 -> Int -> Word32-{-# INLINE shiftr_w64 #-}-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)--#if __GLASGOW_HASKELL__ <= 606--- Exported by GHC.Word in GHC 6.8 and higher-foreign import ccall unsafe "stg_uncheckedShiftRL64"- uncheckedShiftRL64# :: Word64# -> Int# -> Word64#-#endif+ -- ** Unicode+ , putCharUtf8 -#else-shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)-#endif+ ) where -#else-shiftr_w16 = shiftR-shiftr_w32 = shiftR-shiftr_w64 = shiftR-#endif+import Data.Binary.Builder.Base
+ src/Data/Binary/Builder/Base.hs view
@@ -0,0 +1,512 @@+{-# LANGUAGE BangPatterns, CPP, MagicHash #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Data.Binary.Builder.Base+-- 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+--+-- A module exporting types and functions that are shared by+-- 'Data.Binary.Builder' and 'Data.Binary.Builder.Internal'.+--+-----------------------------------------------------------------------------++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#include "MachDeps.h"+#endif++module Data.Binary.Builder.Base (+ -- * 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++ -- ** Host-endian, unaligned writes+ , putWordhost -- :: Word -> Builder+ , putWord16host -- :: Word16 -> Builder+ , putWord32host -- :: Word32 -> Builder+ , putWord64host -- :: Word64 -> Builder++ -- ** Unicode+ , putCharUtf8++ -- * Low-level construction of Builders+ , writeN+ , writeAtMost+ ) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Monoid+import Data.Word+import Foreign++#ifdef BYTESTRING_IN_BASE+import Data.ByteString.Base (inlinePerformIO)+import qualified Data.ByteString.Base as S+import qualified Data.ByteString.Lazy.Base as L+#else+import Data.ByteString.Internal (inlinePerformIO)+import qualified Data.ByteString.Internal as S+import qualified Data.ByteString.Lazy.Internal as L+#endif++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base+import GHC.Word (Word32(..),Word16(..),Word64(..))+# if WORD_SIZE_IN_BITS < 64+import GHC.Word (uncheckedShiftRL64#)+# endif+#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 {+ runBuilder :: (Buffer -> IO L.ByteString)+ -> Buffer+ -> IO L.ByteString+ }++instance Monoid Builder where+ mempty = empty+ {-# INLINE mempty #-}+ mappend = append+ {-# INLINE mappend #-}+ mconcat = foldr mappend mempty+ {-# INLINE mconcat #-}++------------------------------------------------------------------------++-- | /O(1)./ The empty Builder, satisfying+--+-- * @'toLazyByteString' 'empty' = 'L.empty'@+--+empty :: Builder+empty = Builder (\ k b -> k b)+{-# INLINE empty #-}++-- | /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)+{-# INLINE [0] append #-}++-- | /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 (L.Chunk bs)+{-# INLINE fromByteString #-}++-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying+--+-- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@+--+fromLazyByteString :: L.ByteString -> Builder+fromLazyByteString bss = flush `append` mapBuilder (bss `L.append`)+{-# INLINE fromLazyByteString #-}++------------------------------------------------------------------------++-- 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 = unsafePerformIO $ do+ buf <- newBuffer defaultSize+ runBuilder (m `append` flush) (const (return L.Empty)) buf+{-# INLINE toLazyByteString #-}++-- | /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 -- Invariant (from Data.ByteString.Lazy)+ then k buf+ else let !b = Buffer p (o+u) 0 l+ !bs = S.PS p o u+ in return $! L.Chunk bs (inlinePerformIO (k b))++------------------------------------------------------------------------++--+-- 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+withBuffer :: (Buffer -> IO Buffer) -> Builder+withBuffer f = Builder $ \ k buf -> f buf >>= k+{-# INLINE withBuffer #-}++-- | 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 :: (L.ByteString -> L.ByteString) -> Builder+mapBuilder f = Builder (fmap 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` withBuffer (const (newBuffer (max n defaultSize)))+{-# INLINE [0] ensureFree #-}++-- | Ensure that @n@ bytes are available, and then use @f@ to write at+-- most @n@ bytes into memory. @f@ must return the actual number of+-- bytes written.+writeAtMost :: Int -> (Ptr Word8 -> IO Int) -> Builder+writeAtMost n f = ensureFree n `append` withBuffer (writeBuffer f)+{-# INLINE [0] writeAtMost #-}++-- | Ensure that @n@ bytes are available, and then use @f@ to write+-- exactly @n@ bytes into memory.+writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder+writeN n f = writeAtMost n (\ p -> f p >> return n)+{-# INLINE writeN #-}++writeBuffer :: (Ptr Word8 -> IO Int) -> Buffer -> IO Buffer+writeBuffer f (Buffer fp o u l) = do+ n <- withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))+ return $! Buffer fp o (u+n) (l-n)+{-# INLINE writeBuffer #-}++newBuffer :: Int -> IO Buffer+newBuffer size = do+ fp <- S.mallocByteString size+ return $! Buffer fp 0 0 size+{-# INLINE newBuffer #-}++------------------------------------------------------------------------++--+-- 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)++------------------------------------------------------------------------+-- 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 =+ writeN (sizeOf (undefined :: Word)) (\p -> poke (castPtr 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 =+ writeN (sizeOf (undefined :: Word16)) (\p -> poke (castPtr 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 =+ writeN (sizeOf (undefined :: Word32)) (\p -> poke (castPtr 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 =+ writeN (sizeOf (undefined :: Word64)) (\p -> poke (castPtr p) w)+{-# INLINE putWord64host #-}++------------------------------------------------------------------------+-- Unicode++-- Code lifted from the text package by Bryan O'Sullivan.++-- | Write a character using UTF-8 encoding.+putCharUtf8 :: Char -> Builder+putCharUtf8 x = writeAtMost 4 $ \ p -> case undefined of+ _ | n <= 0x7F -> poke p c >> return 1+ | n <= 0x07FF -> do+ poke p a2+ poke (p `plusPtr` 1) b2+ return 2+ | n <= 0xFFFF -> do+ poke p a3+ poke (p `plusPtr` 1) b3+ poke (p `plusPtr` 2) c3+ return 3+ | otherwise -> do+ poke p a4+ poke (p `plusPtr` 1) b4+ poke (p `plusPtr` 2) c4+ poke (p `plusPtr` 3) d4+ return 4+ where+ n = ord x+ c = fromIntegral n+ (a2,b2) = ord2 x+ (a3,b3,c3) = ord3 x+ (a4,b4,c4,d4) = ord4 x++ord2 :: Char -> (Word8,Word8)+ord2 c = (x1,x2)+ where+ n = ord c+ x1 = fromIntegral $ (n `shiftR` 6) + 0xC0+ x2 = fromIntegral $ (n .&. 0x3F) + 0x80++ord3 :: Char -> (Word8,Word8,Word8)+ord3 c = (x1,x2,x3)+ where+ n = ord c+ x1 = fromIntegral $ (n `shiftR` 12) + 0xE0+ x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80+ x3 = fromIntegral $ (n .&. 0x3F) + 0x80++ord4 :: Char -> (Word8,Word8,Word8,Word8)+ord4 c = (x1,x2,x3,x4)+ where+ n = ord c+ x1 = fromIntegral $ (n `shiftR` 18) + 0xF0+ x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80+ x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80+ x4 = fromIntegral $ (n .&. 0x3F) + 0x80++------------------------------------------------------------------------+-- Unchecked shifts++{-# INLINE shiftr_w16 #-}+shiftr_w16 :: Word16 -> Int -> Word16+{-# INLINE shiftr_w32 #-}+shiftr_w32 :: Word32 -> Int -> Word32+{-# INLINE shiftr_w64 #-}+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)+# else+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)+# endif++#else+shiftr_w16 = shiftR+shiftr_w32 = shiftR+shiftr_w64 = shiftR+#endif++------------------------------------------------------------------------+-- Some nice rules for Builder++#if __GLASGOW_HASKELL__ >= 700+-- In versions of GHC prior to 7.0 these rules would make GHC believe+-- that 'writeN' and 'ensureFree' are recursive and the rules wouldn't+-- fire.+{-# RULES++"append/writeAtMost" forall a b (f::Ptr Word8 -> IO Int)+ (g::Ptr Word8 -> IO Int) ws.+ append (writeAtMost a f) (append (writeAtMost b g) ws) =+ append (writeAtMost (a+b) (\p -> f p >>= \n ->+ g (p `plusPtr` n) >>= \m ->+ let s = n+m in s `seq` return s)) ws++"writeAtMost/writeAtMost" forall a b (f::Ptr Word8 -> IO Int)+ (g::Ptr Word8 -> IO Int).+ append (writeAtMost a f) (writeAtMost b g) =+ writeAtMost (a+b) (\p -> f p >>= \n ->+ g (p `plusPtr` n) >>= \m ->+ let s = n+m in s `seq` return s)++"ensureFree/ensureFree" forall a b .+ append (ensureFree a) (ensureFree b) = ensureFree (max a b)++"flush/flush"+ append flush flush = flush++ #-}+#endif
+ src/Data/Binary/Builder/Internal.hs view
@@ -0,0 +1,27 @@+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Data.Binary.Builder.Internal+-- 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+--+-- A module containing semi-public 'Builder' internals that exposes+-- low level construction functions. Modules which extend the+-- 'Builder' system will need to use this module while ideally most+-- users will be able to make do with the public interface modules.+--+-----------------------------------------------------------------------------++module Data.Binary.Builder.Internal (+ -- * Low-level construction of Builders+ writeN+ , writeAtMost+ ) where++import Data.Binary.Builder.Base
src/Data/Binary/Get.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fglasgow-exts #-}--- for unboxed shifts+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}+-- MagicHash, UnboxedTuples for unboxed shifts+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif ----------------------------------------------------------------------------- -- |@@ -370,16 +372,17 @@ return (xs, ys)) where- first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty- first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty-- first r n (L.Chunk x xs)- | n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs)- return $ L.Chunk (B.take (fromIntegral n) x) L.Empty- | otherwise = do writeSTRef r (L.drop (n - l) xs)- liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs)+ first :: STRef s L.ByteString -> Int64 -> L.ByteString -> ST s L.ByteString+ first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty+ first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty - where l = fromIntegral (B.length x)+ first r n (L.Chunk x xs)+ | n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs)+ return $ L.Chunk (B.take (fromIntegral n) x) L.Empty+ | otherwise = do writeSTRef r (L.drop (n - l) xs)+ liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs)+ where + l = fromIntegral (B.length x) #else splitAtST i (B.LPS ps) = runST ( do r <- newSTRef undefined
src/Data/Binary/Put.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Put@@ -64,7 +69,7 @@ ------------------------------------------------------------------------ -- XXX Strict in buffer only. -data PairS a = PairS a {-# UNPACK #-}!Builder+data PairS a = PairS a !Builder sndS :: PairS a -> Builder sndS (PairS _ b) = b
− tests/Benchmark.hs
@@ -1,1461 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Main (main) where--import qualified Data.ByteString.Lazy as L-import Data.Binary-import Data.Binary.Put-import Data.Binary.Get--import Control.Exception-import System.CPUTime-import Numeric-import Text.Printf-import System.Environment--import MemBench--data Endian- = Big- | Little- | Host- deriving (Eq,Ord,Show)--main :: IO ()-main = do- mb <- getArgs >>= readIO . head- memBench (mb*10) - putStrLn ""- putStrLn "Binary (de)serialisation benchmarks:"-- -- do bytewise - sequence_- [ test wordSize chunkSize Host mb- | wordSize <- [1]- , chunkSize <- [16] --1,2,4,8,16]- ]-- -- now Word16 .. Word64- sequence_- [ test wordSize chunkSize end mb- | wordSize <- [2,4,8]- , chunkSize <- [16]- , end <- [Host] -- ,Big,Little]- ]----------------------------------------------------------------------------time :: IO a -> IO Double-time action = do- start <- getCPUTime- action- end <- getCPUTime- return $! (fromIntegral (end - start)) / (10^12)----------------------------------------------------------------------------test :: Int -> Int -> Endian -> Int -> IO ()-test wordSize chunkSize end mb = do- let bytes :: Int- bytes = mb * 2^20- iterations = bytes `div` wordSize- bs = runPut (doPut wordSize chunkSize end iterations)- sum = runGet (doGet wordSize chunkSize end iterations) bs-- case (chunkSize,end) of (1,Host) -> putStrLn "" ; _ -> return ()-- printf "%dMB of Word%-2d in chunks of %2d (%6s endian): "- (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end)-- putSeconds <- time $ evaluate (L.length bs)- getSeconds <- time $ evaluate sum--- print (L.length bs, sum)- let putThroughput = fromIntegral mb / putSeconds- getThroughput = fromIntegral mb / getSeconds-- printf "%6.1f MB/s write, %6.1f MB/s read, %5.1f get/put-ratio\n"- putThroughput- getThroughput- (getThroughput/putThroughput)----------------------------------------------------------------------------doPut :: Int -> Int -> Endian -> Int -> Put-doPut wordSize chunkSize end = case (wordSize, chunkSize, end) of- (1, 1,_) -> putWord8N1- (1, 2,_) -> putWord8N2- (1, 4,_) -> putWord8N4- (1, 8,_) -> putWord8N8- (1, 16, _) -> putWord8N16-- (2, 1, Big) -> putWord16N1Big- (2, 2, Big) -> putWord16N2Big- (2, 4, Big) -> putWord16N4Big- (2, 8, Big) -> putWord16N8Big- (2, 16, Big) -> putWord16N16Big- (2, 1, Little) -> putWord16N1Little- (2, 2, Little) -> putWord16N2Little- (2, 4, Little) -> putWord16N4Little- (2, 8, Little) -> putWord16N8Little- (2, 16, Little) -> putWord16N16Little- (2, 1, Host) -> putWord16N1Host- (2, 2, Host) -> putWord16N2Host- (2, 4, Host) -> putWord16N4Host- (2, 8, Host) -> putWord16N8Host- (2, 16, Host) -> putWord16N16Host-- (4, 1, Big) -> putWord32N1Big- (4, 2, Big) -> putWord32N2Big- (4, 4, Big) -> putWord32N4Big- (4, 8, Big) -> putWord32N8Big- (4, 16, Big) -> putWord32N16Big- (4, 1, Little) -> putWord32N1Little- (4, 2, Little) -> putWord32N2Little- (4, 4, Little) -> putWord32N4Little- (4, 8, Little) -> putWord32N8Little- (4, 16, Little) -> putWord32N16Little- (4, 1, Host) -> putWord32N1Host- (4, 2, Host) -> putWord32N2Host- (4, 4, Host) -> putWord32N4Host- (4, 8, Host) -> putWord32N8Host- (4, 16, Host) -> putWord32N16Host-- (8, 1, Host) -> putWord64N1Host- (8, 2, Host) -> putWord64N2Host- (8, 4, Host) -> putWord64N4Host- (8, 8, Host) -> putWord64N8Host- (8, 16, Host) -> putWord64N16Host- (8, 1, Big) -> putWord64N1Big- (8, 2, Big) -> putWord64N2Big- (8, 4, Big) -> putWord64N4Big- (8, 8, Big) -> putWord64N8Big- (8, 16, Big) -> putWord64N16Big- (8, 1, Little) -> putWord64N1Little- (8, 2, Little) -> putWord64N2Little- (8, 4, Little) -> putWord64N4Little- (8, 8, Little) -> putWord64N8Little- (8, 16, Little) -> putWord64N16Little----------------------------------------------------------------------------doGet :: Int -> Int -> Endian -> Int -> Get Int-doGet wordSize chunkSize end =- case (wordSize, chunkSize, end) of- (1, 1,_) -> fmap fromIntegral . getWord8N1- (1, 2,_) -> fmap fromIntegral . getWord8N2- (1, 4,_) -> fmap fromIntegral . getWord8N4- (1, 8,_) -> fmap fromIntegral . getWord8N8- (1, 16,_) -> fmap fromIntegral . getWord8N16-- (2, 1,Big) -> fmap fromIntegral . getWord16N1Big- (2, 2,Big) -> fmap fromIntegral . getWord16N2Big- (2, 4,Big) -> fmap fromIntegral . getWord16N4Big- (2, 8,Big) -> fmap fromIntegral . getWord16N8Big- (2, 16,Big) -> fmap fromIntegral . getWord16N16Big- (2, 1,Little) -> fmap fromIntegral . getWord16N1Little- (2, 2,Little) -> fmap fromIntegral . getWord16N2Little- (2, 4,Little) -> fmap fromIntegral . getWord16N4Little- (2, 8,Little) -> fmap fromIntegral . getWord16N8Little- (2, 16,Little) -> fmap fromIntegral . getWord16N16Little- (2, 1,Host) -> fmap fromIntegral . getWord16N1Host- (2, 2,Host) -> fmap fromIntegral . getWord16N2Host- (2, 4,Host) -> fmap fromIntegral . getWord16N4Host- (2, 8,Host) -> fmap fromIntegral . getWord16N8Host- (2, 16,Host) -> fmap fromIntegral . getWord16N16Host-- (4, 1,Big) -> fmap fromIntegral . getWord32N1Big- (4, 2,Big) -> fmap fromIntegral . getWord32N2Big- (4, 4,Big) -> fmap fromIntegral . getWord32N4Big- (4, 8,Big) -> fmap fromIntegral . getWord32N8Big- (4, 16,Big) -> fmap fromIntegral . getWord32N16Big- (4, 1,Little) -> fmap fromIntegral . getWord32N1Little- (4, 2,Little) -> fmap fromIntegral . getWord32N2Little- (4, 4,Little) -> fmap fromIntegral . getWord32N4Little- (4, 8,Little) -> fmap fromIntegral . getWord32N8Little- (4, 16,Little) -> fmap fromIntegral . getWord32N16Little- (4, 1,Host) -> fmap fromIntegral . getWord32N1Host- (4, 2,Host) -> fmap fromIntegral . getWord32N2Host- (4, 4,Host) -> fmap fromIntegral . getWord32N4Host- (4, 8,Host) -> fmap fromIntegral . getWord32N8Host- (4, 16,Host) -> fmap fromIntegral . getWord32N16Host-- (8, 1,Host) -> fmap fromIntegral . getWord64N1Host- (8, 2,Host) -> fmap fromIntegral . getWord64N2Host- (8, 4,Host) -> fmap fromIntegral . getWord64N4Host- (8, 8,Host) -> fmap fromIntegral . getWord64N8Host- (8, 16,Host) -> fmap fromIntegral . getWord64N16Host- (8, 1,Big) -> fmap fromIntegral . getWord64N1Big- (8, 2,Big) -> fmap fromIntegral . getWord64N2Big- (8, 4,Big) -> fmap fromIntegral . getWord64N4Big- (8, 8,Big) -> fmap fromIntegral . getWord64N8Big- (8, 16,Big) -> fmap fromIntegral . getWord64N16Big- (8, 1,Little) -> fmap fromIntegral . getWord64N1Little- (8, 2,Little) -> fmap fromIntegral . getWord64N2Little- (8, 4,Little) -> fmap fromIntegral . getWord64N4Little- (8, 8,Little) -> fmap fromIntegral . getWord64N8Little- (8, 16,Little) -> fmap fromIntegral . getWord64N16Little----------------------------------------------------------------------------putWord8N1 bytes = loop 0 0- where loop :: Word8 -> Int -> Put- loop !s !n | n == bytes = return ()- | otherwise = do putWord8 s- loop (s+1) (n+1)--putWord8N2 = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord8 (s+0)- putWord8 (s+1)- loop (s+2) (n-2)--putWord8N4 = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord8 (s+0)- putWord8 (s+1)- putWord8 (s+2)- putWord8 (s+3)- loop (s+4) (n-4)--putWord8N8 = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord8 (s+0)- putWord8 (s+1)- putWord8 (s+2)- putWord8 (s+3)- putWord8 (s+4)- putWord8 (s+5)- putWord8 (s+6)- putWord8 (s+7)- loop (s+8) (n-8)--putWord8N16 = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord8 (s+0)- putWord8 (s+1)- putWord8 (s+2)- putWord8 (s+3)- putWord8 (s+4)- putWord8 (s+5)- putWord8 (s+6)- putWord8 (s+7)- putWord8 (s+8)- putWord8 (s+9)- putWord8 (s+10)- putWord8 (s+11)- putWord8 (s+12)- putWord8 (s+13)- putWord8 (s+14)- putWord8 (s+15)- loop (s+16) (n-16)----------------------------------------------------------------------------- Big endian, word16 writes--putWord16N1Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16be (s+0)- loop (s+1) (n-1)--putWord16N2Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16be (s+0)- putWord16be (s+1)- loop (s+2) (n-2)--putWord16N4Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16be (s+0)- putWord16be (s+1)- putWord16be (s+2)- putWord16be (s+3)- loop (s+4) (n-4)--putWord16N8Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16be (s+0)- putWord16be (s+1)- putWord16be (s+2)- putWord16be (s+3)- putWord16be (s+4)- putWord16be (s+5)- putWord16be (s+6)- putWord16be (s+7)- loop (s+8) (n-8)--putWord16N16Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16be (s+0)- putWord16be (s+1)- putWord16be (s+2)- putWord16be (s+3)- putWord16be (s+4)- putWord16be (s+5)- putWord16be (s+6)- putWord16be (s+7)- putWord16be (s+8)- putWord16be (s+9)- putWord16be (s+10)- putWord16be (s+11)- putWord16be (s+12)- putWord16be (s+13)- putWord16be (s+14)- putWord16be (s+15)- loop (s+16) (n-16)----------------------------------------------------------------------------- Little endian, word16 writes--putWord16N1Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16le (s+0)- loop (s+1) (n-1)--putWord16N2Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16le (s+0)- putWord16le (s+1)- loop (s+2) (n-2)--putWord16N4Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16le (s+0)- putWord16le (s+1)- putWord16le (s+2)- putWord16le (s+3)- loop (s+4) (n-4)--putWord16N8Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16le (s+0)- putWord16le (s+1)- putWord16le (s+2)- putWord16le (s+3)- putWord16le (s+4)- putWord16le (s+5)- putWord16le (s+6)- putWord16le (s+7)- loop (s+8) (n-8)--putWord16N16Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16le (s+0)- putWord16le (s+1)- putWord16le (s+2)- putWord16le (s+3)- putWord16le (s+4)- putWord16le (s+5)- putWord16le (s+6)- putWord16le (s+7)- putWord16le (s+8)- putWord16le (s+9)- putWord16le (s+10)- putWord16le (s+11)- putWord16le (s+12)- putWord16le (s+13)- putWord16le (s+14)- putWord16le (s+15)- loop (s+16) (n-16)----------------------------------------------------------------------------- Host endian, unaligned, word16 writes--putWord16N1Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16host (s+0)- loop (s+1) (n-1)--putWord16N2Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16host (s+0)- putWord16host (s+1)- loop (s+2) (n-2)--putWord16N4Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16host (s+0)- putWord16host (s+1)- putWord16host (s+2)- putWord16host (s+3)- loop (s+4) (n-4)--putWord16N8Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16host (s+0)- putWord16host (s+1)- putWord16host (s+2)- putWord16host (s+3)- putWord16host (s+4)- putWord16host (s+5)- putWord16host (s+6)- putWord16host (s+7)- loop (s+8) (n-8)--putWord16N16Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord16host (s+0)- putWord16host (s+1)- putWord16host (s+2)- putWord16host (s+3)- putWord16host (s+4)- putWord16host (s+5)- putWord16host (s+6)- putWord16host (s+7)- putWord16host (s+8)- putWord16host (s+9)- putWord16host (s+10)- putWord16host (s+11)- putWord16host (s+12)- putWord16host (s+13)- putWord16host (s+14)- putWord16host (s+15)- loop (s+16) (n-16)----------------------------------------------------------------------------putWord32N1Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32be (s+0)- loop (s+1) (n-1)--putWord32N2Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32be (s+0)- putWord32be (s+1)- loop (s+2) (n-2)--putWord32N4Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32be (s+0)- putWord32be (s+1)- putWord32be (s+2)- putWord32be (s+3)- loop (s+4) (n-4)--putWord32N8Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32be (s+0)- putWord32be (s+1)- putWord32be (s+2)- putWord32be (s+3)- putWord32be (s+4)- putWord32be (s+5)- putWord32be (s+6)- putWord32be (s+7)- loop (s+8) (n-8)--putWord32N16Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32be (s+0)- putWord32be (s+1)- putWord32be (s+2)- putWord32be (s+3)- putWord32be (s+4)- putWord32be (s+5)- putWord32be (s+6)- putWord32be (s+7)- putWord32be (s+8)- putWord32be (s+9)- putWord32be (s+10)- putWord32be (s+11)- putWord32be (s+12)- putWord32be (s+13)- putWord32be (s+14)- putWord32be (s+15)- loop (s+16) (n-16)----------------------------------------------------------------------------putWord32N1Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32le (s+0)- loop (s+1) (n-1)--putWord32N2Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32le (s+0)- putWord32le (s+1)- loop (s+2) (n-2)--putWord32N4Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32le (s+0)- putWord32le (s+1)- putWord32le (s+2)- putWord32le (s+3)- loop (s+4) (n-4)--putWord32N8Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32le (s+0)- putWord32le (s+1)- putWord32le (s+2)- putWord32le (s+3)- putWord32le (s+4)- putWord32le (s+5)- putWord32le (s+6)- putWord32le (s+7)- loop (s+8) (n-8)--putWord32N16Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32le (s+0)- putWord32le (s+1)- putWord32le (s+2)- putWord32le (s+3)- putWord32le (s+4)- putWord32le (s+5)- putWord32le (s+6)- putWord32le (s+7)- putWord32le (s+8)- putWord32le (s+9)- putWord32le (s+10)- putWord32le (s+11)- putWord32le (s+12)- putWord32le (s+13)- putWord32le (s+14)- putWord32le (s+15)- loop (s+16) (n-16)----------------------------------------------------------------------------putWord32N1Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32host (s+0)- loop (s+1) (n-1)--putWord32N2Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32host (s+0)- putWord32host (s+1)- loop (s+2) (n-2)--putWord32N4Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32host (s+0)- putWord32host (s+1)- putWord32host (s+2)- putWord32host (s+3)- loop (s+4) (n-4)--putWord32N8Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32host (s+0)- putWord32host (s+1)- putWord32host (s+2)- putWord32host (s+3)- putWord32host (s+4)- putWord32host (s+5)- putWord32host (s+6)- putWord32host (s+7)- loop (s+8) (n-8)--putWord32N16Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord32host (s+0)- putWord32host (s+1)- putWord32host (s+2)- putWord32host (s+3)- putWord32host (s+4)- putWord32host (s+5)- putWord32host (s+6)- putWord32host (s+7)- putWord32host (s+8)- putWord32host (s+9)- putWord32host (s+10)- putWord32host (s+11)- putWord32host (s+12)- putWord32host (s+13)- putWord32host (s+14)- putWord32host (s+15)- loop (s+16) (n-16)----------------------------------------------------------------------------putWord64N1Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64be (s+0)- loop (s+1) (n-1)--putWord64N2Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64be (s+0)- putWord64be (s+1)- loop (s+2) (n-2)--putWord64N4Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64be (s+0)- putWord64be (s+1)- putWord64be (s+2)- putWord64be (s+3)- loop (s+4) (n-4)--putWord64N8Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64be (s+0)- putWord64be (s+1)- putWord64be (s+2)- putWord64be (s+3)- putWord64be (s+4)- putWord64be (s+5)- putWord64be (s+6)- putWord64be (s+7)- loop (s+8) (n-8)--putWord64N16Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64be (s+0)- putWord64be (s+1)- putWord64be (s+2)- putWord64be (s+3)- putWord64be (s+4)- putWord64be (s+5)- putWord64be (s+6)- putWord64be (s+7)- putWord64be (s+8)- putWord64be (s+9)- putWord64be (s+10)- putWord64be (s+11)- putWord64be (s+12)- putWord64be (s+13)- putWord64be (s+14)- putWord64be (s+15)- loop (s+16) (n-16)----------------------------------------------------------------------------putWord64N1Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64le (s+0)- loop (s+1) (n-1)--putWord64N2Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64le (s+0)- putWord64le (s+1)- loop (s+2) (n-2)--putWord64N4Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64le (s+0)- putWord64le (s+1)- putWord64le (s+2)- putWord64le (s+3)- loop (s+4) (n-4)--putWord64N8Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64le (s+0)- putWord64le (s+1)- putWord64le (s+2)- putWord64le (s+3)- putWord64le (s+4)- putWord64le (s+5)- putWord64le (s+6)- putWord64le (s+7)- loop (s+8) (n-8)--putWord64N16Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64le (s+0)- putWord64le (s+1)- putWord64le (s+2)- putWord64le (s+3)- putWord64le (s+4)- putWord64le (s+5)- putWord64le (s+6)- putWord64le (s+7)- putWord64le (s+8)- putWord64le (s+9)- putWord64le (s+10)- putWord64le (s+11)- putWord64le (s+12)- putWord64le (s+13)- putWord64le (s+14)- putWord64le (s+15)- loop (s+16) (n-16)----------------------------------------------------------------------------putWord64N1Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64host (s+0)- loop (s+1) (n-1)--putWord64N2Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64host (s+0)- putWord64host (s+1)- loop (s+2) (n-2)--putWord64N4Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64host (s+0)- putWord64host (s+1)- putWord64host (s+2)- putWord64host (s+3)- loop (s+4) (n-4)--putWord64N8Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64host (s+0)- putWord64host (s+1)- putWord64host (s+2)- putWord64host (s+3)- putWord64host (s+4)- putWord64host (s+5)- putWord64host (s+6)- putWord64host (s+7)- loop (s+8) (n-8)--putWord64N16Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop _ 0 = return ()- loop s n = do- putWord64host (s+0)- putWord64host (s+1)- putWord64host (s+2)- putWord64host (s+3)- putWord64host (s+4)- putWord64host (s+5)- putWord64host (s+6)- putWord64host (s+7)- putWord64host (s+8)- putWord64host (s+9)- putWord64host (s+10)- putWord64host (s+11)- putWord64host (s+12)- putWord64host (s+13)- putWord64host (s+14)- putWord64host (s+15)- loop (s+16) (n-16)-----------------------------------------------------------------------------------------------------------------------------------------------------getWord8N1 = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord8- loop (s+s0) (n-1)--getWord8N2 = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord8- s1 <- getWord8- loop (s+s0+s1) (n-2)--getWord8N4 = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord8- s1 <- getWord8- s2 <- getWord8- s3 <- getWord8- loop (s+s0+s1+s2+s3) (n-4)--getWord8N8 = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord8- s1 <- getWord8- s2 <- getWord8- s3 <- getWord8- s4 <- getWord8- s5 <- getWord8- s6 <- getWord8- s7 <- getWord8- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)--getWord8N16 = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord8- s1 <- getWord8- s2 <- getWord8- s3 <- getWord8- s4 <- getWord8- s5 <- getWord8- s6 <- getWord8- s7 <- getWord8- s8 <- getWord8- s9 <- getWord8- s10 <- getWord8- s11 <- getWord8- s12 <- getWord8- s13 <- getWord8- s14 <- getWord8- s15 <- getWord8- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)----------------------------------------------------------------------------getWord16N1Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16be- loop (s+s0) (n-1)--getWord16N2Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16be- s1 <- getWord16be- loop (s+s0+s1) (n-2)--getWord16N4Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16be- s1 <- getWord16be- s2 <- getWord16be- s3 <- getWord16be- loop (s+s0+s1+s2+s3) (n-4)--getWord16N8Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16be- s1 <- getWord16be- s2 <- getWord16be- s3 <- getWord16be- s4 <- getWord16be- s5 <- getWord16be- s6 <- getWord16be- s7 <- getWord16be- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)--getWord16N16Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16be- s1 <- getWord16be- s2 <- getWord16be- s3 <- getWord16be- s4 <- getWord16be- s5 <- getWord16be- s6 <- getWord16be- s7 <- getWord16be- s8 <- getWord16be- s9 <- getWord16be- s10 <- getWord16be- s11 <- getWord16be- s12 <- getWord16be- s13 <- getWord16be- s14 <- getWord16be- s15 <- getWord16be- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)----------------------------------------------------------------------------getWord16N1Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16le- loop (s+s0) (n-1)--getWord16N2Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16le- s1 <- getWord16le- loop (s+s0+s1) (n-2)--getWord16N4Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16le- s1 <- getWord16le- s2 <- getWord16le- s3 <- getWord16le- loop (s+s0+s1+s2+s3) (n-4)--getWord16N8Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16le- s1 <- getWord16le- s2 <- getWord16le- s3 <- getWord16le- s4 <- getWord16le- s5 <- getWord16le- s6 <- getWord16le- s7 <- getWord16le- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)--getWord16N16Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16le- s1 <- getWord16le- s2 <- getWord16le- s3 <- getWord16le- s4 <- getWord16le- s5 <- getWord16le- s6 <- getWord16le- s7 <- getWord16le- s8 <- getWord16le- s9 <- getWord16le- s10 <- getWord16le- s11 <- getWord16le- s12 <- getWord16le- s13 <- getWord16le- s14 <- getWord16le- s15 <- getWord16le- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)----------------------------------------------------------------------------getWord16N1Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16host- loop (s+s0) (n-1)--getWord16N2Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16host- s1 <- getWord16host- loop (s+s0+s1) (n-2)--getWord16N4Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16host- s1 <- getWord16host- s2 <- getWord16host- s3 <- getWord16host- loop (s+s0+s1+s2+s3) (n-4)--getWord16N8Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16host- s1 <- getWord16host- s2 <- getWord16host- s3 <- getWord16host- s4 <- getWord16host- s5 <- getWord16host- s6 <- getWord16host- s7 <- getWord16host- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)--getWord16N16Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord16host- s1 <- getWord16host- s2 <- getWord16host- s3 <- getWord16host- s4 <- getWord16host- s5 <- getWord16host- s6 <- getWord16host- s7 <- getWord16host- s8 <- getWord16host- s9 <- getWord16host- s10 <- getWord16host- s11 <- getWord16host- s12 <- getWord16host- s13 <- getWord16host- s14 <- getWord16host- s15 <- getWord16host- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)----------------------------------------------------------------------------getWord32N1Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32be- loop (s+s0) (n-1)--getWord32N2Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32be- s1 <- getWord32be- loop (s+s0+s1) (n-2)--getWord32N4Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32be- s1 <- getWord32be- s2 <- getWord32be- s3 <- getWord32be- loop (s+s0+s1+s2+s3) (n-4)--getWord32N8Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32be- s1 <- getWord32be- s2 <- getWord32be- s3 <- getWord32be- s4 <- getWord32be- s5 <- getWord32be- s6 <- getWord32be- s7 <- getWord32be- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)---- getWordhostN16 = loop 0-getWord32N16Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32be- s1 <- getWord32be- s2 <- getWord32be- s3 <- getWord32be- s4 <- getWord32be- s5 <- getWord32be- s6 <- getWord32be- s7 <- getWord32be- s8 <- getWord32be- s9 <- getWord32be- s10 <- getWord32be- s11 <- getWord32be- s12 <- getWord32be- s13 <- getWord32be- s14 <- getWord32be- s15 <- getWord32be- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)----------------------------------------------------------------------------getWord32N1Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32le- loop (s+s0) (n-1)--getWord32N2Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32le- s1 <- getWord32le- loop (s+s0+s1) (n-2)--getWord32N4Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32le- s1 <- getWord32le- s2 <- getWord32le- s3 <- getWord32le- loop (s+s0+s1+s2+s3) (n-4)--getWord32N8Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32le- s1 <- getWord32le- s2 <- getWord32le- s3 <- getWord32le- s4 <- getWord32le- s5 <- getWord32le- s6 <- getWord32le- s7 <- getWord32le- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)---- getWordhostN16 = loop 0-getWord32N16Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32le- s1 <- getWord32le- s2 <- getWord32le- s3 <- getWord32le- s4 <- getWord32le- s5 <- getWord32le- s6 <- getWord32le- s7 <- getWord32le- s8 <- getWord32le- s9 <- getWord32le- s10 <- getWord32le- s11 <- getWord32le- s12 <- getWord32le- s13 <- getWord32le- s14 <- getWord32le- s15 <- getWord32le- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)----------------------------------------------------------------------------getWord32N1Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32host- loop (s+s0) (n-1)--getWord32N2Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32host- s1 <- getWord32host- loop (s+s0+s1) (n-2)--getWord32N4Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32host- s1 <- getWord32host- s2 <- getWord32host- s3 <- getWord32host- loop (s+s0+s1+s2+s3) (n-4)--getWord32N8Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32host- s1 <- getWord32host- s2 <- getWord32host- s3 <- getWord32host- s4 <- getWord32host- s5 <- getWord32host- s6 <- getWord32host- s7 <- getWord32host- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)---- getWordhostN16 = loop 0-getWord32N16Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord32host- s1 <- getWord32host- s2 <- getWord32host- s3 <- getWord32host- s4 <- getWord32host- s5 <- getWord32host- s6 <- getWord32host- s7 <- getWord32host- s8 <- getWord32host- s9 <- getWord32host- s10 <- getWord32host- s11 <- getWord32host- s12 <- getWord32host- s13 <- getWord32host- s14 <- getWord32host- s15 <- getWord32host- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)----------------------------------------------------------------------------getWord64N1Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64be- loop (s+s0) (n-1)--getWord64N2Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64be- s1 <- getWord64be- loop (s+s0+s1) (n-2)--getWord64N4Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64be- s1 <- getWord64be- s2 <- getWord64be- s3 <- getWord64be- loop (s+s0+s1+s2+s3) (n-4)--getWord64N8Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64be- s1 <- getWord64be- s2 <- getWord64be- s3 <- getWord64be- s4 <- getWord64be- s5 <- getWord64be- s6 <- getWord64be- s7 <- getWord64be- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)--getWord64N16Big = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64be- s1 <- getWord64be- s2 <- getWord64be- s3 <- getWord64be- s4 <- getWord64be- s5 <- getWord64be- s6 <- getWord64be- s7 <- getWord64be- s8 <- getWord64be- s9 <- getWord64be- s10 <- getWord64be- s11 <- getWord64be- s12 <- getWord64be- s13 <- getWord64be- s14 <- getWord64be- s15 <- getWord64be- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)----------------------------------------------------------------------------getWord64N1Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64le- loop (s+s0) (n-1)--getWord64N2Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64le- s1 <- getWord64le- loop (s+s0+s1) (n-2)--getWord64N4Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64le- s1 <- getWord64le- s2 <- getWord64le- s3 <- getWord64le- loop (s+s0+s1+s2+s3) (n-4)--getWord64N8Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64le- s1 <- getWord64le- s2 <- getWord64le- s3 <- getWord64le- s4 <- getWord64le- s5 <- getWord64le- s6 <- getWord64le- s7 <- getWord64le- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)--getWord64N16Little = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64le- s1 <- getWord64le- s2 <- getWord64le- s3 <- getWord64le- s4 <- getWord64le- s5 <- getWord64le- s6 <- getWord64le- s7 <- getWord64le- s8 <- getWord64le- s9 <- getWord64le- s10 <- getWord64le- s11 <- getWord64le- s12 <- getWord64le- s13 <- getWord64le- s14 <- getWord64le- s15 <- getWord64le- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)----------------------------------------------------------------------------getWord64N1Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64host- loop (s+s0) (n-1)--getWord64N2Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64host- s1 <- getWord64host- loop (s+s0+s1) (n-2)--getWord64N4Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64host- s1 <- getWord64host- s2 <- getWord64host- s3 <- getWord64host- loop (s+s0+s1+s2+s3) (n-4)--getWord64N8Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64host- s1 <- getWord64host- s2 <- getWord64host- s3 <- getWord64host- s4 <- getWord64host- s5 <- getWord64host- s6 <- getWord64host- s7 <- getWord64host- loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)--getWord64N16Host = loop 0- where loop s n | s `seq` n `seq` False = undefined- loop s 0 = return s- loop s n = do- s0 <- getWord64host- s1 <- getWord64host- s2 <- getWord64host- s3 <- getWord64host- s4 <- getWord64host- s5 <- getWord64host- s6 <- getWord64host- s7 <- getWord64host- s8 <- getWord64host- s9 <- getWord64host- s10 <- getWord64host- s11 <- getWord64host- s12 <- getWord64host- s13 <- getWord64host- s14 <- getWord64host- s15 <- getWord64host- loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)
− tests/CBenchmark.c
@@ -1,39 +0,0 @@-#include "CBenchmark.h"--void bytewrite(unsigned char *a, int bytes) {- unsigned char n = 0;- int i = 0;- int iterations = bytes;- while (i < iterations) {- a[i++] = n++;- }-}--unsigned char byteread(unsigned char *a, int bytes) {- unsigned char n = 0;- int i = 0;- int iterations = bytes;- while (i < iterations) {- n += a[i++];- }- return n;-}--void wordwrite(unsigned long *a, int bytes) {- unsigned long n = 0;- int i = 0;- int iterations = bytes / sizeof(unsigned long) ;- while (i < iterations) {- a[i++] = n++;- }-}--unsigned int wordread(unsigned long *a, int bytes) {- unsigned long n = 0;- int i = 0;- int iterations = bytes / sizeof(unsigned long);- while (i < iterations) {- n += a[i++];- }- return n;-}
− tests/CBenchmark.h
@@ -1,4 +0,0 @@-void bytewrite(unsigned char *a, int bytes);-unsigned char byteread(unsigned char *a, int bytes);-void wordwrite(unsigned long *a, int bytes);-unsigned int wordread(unsigned long *a, int bytes);
− tests/HeapUse.hs
@@ -1,17 +0,0 @@--- 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
@@ -1,34 +0,0 @@-all: compiled- -interpreted:- runhaskell QC.hs 1000--compiled:- ghc --make -fhpc -O QC.hs -o qc -no-recomp -threaded- ./qc 500 +RTS -qw -N2--bench:: Benchmark.hs MemBench.hs CBenchmark.o- ghc --make -O2 -fliberate-case-threshold=1000 -fasm Benchmark.hs CBenchmark.o -o bench -fforce-recomp- ./bench 100--bench-nb::- ghc --make -O2 -fliberate-case-threshold=1000 NewBenchmark.hs -fasm -o bench-nb- ./bench-nb --CBenchmark.o: CBenchmark.c- gcc -O3 -c $< -o $@--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 *~--.PHONY: clean bench bench-nb
− tests/MemBench.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}-module MemBench (memBench) where--import Foreign-import Foreign.C--import Control.Exception-import System.CPUTime-import Numeric--memBench :: Int -> IO ()-memBench mb = do- let bytes = mb * 2^20- allocaBytes bytes $ \ptr -> do- let bench label test = do- seconds <- time $ test (castPtr ptr) (fromIntegral bytes)- let throughput = fromIntegral mb / seconds- putStrLn $ show mb ++ "MB of " ++ label- ++ " in " ++ showFFloat (Just 3) seconds "s, at: "- ++ showFFloat (Just 1) throughput "MB/s"- bench "setup " c_wordwrite- putStrLn ""- putStrLn "C memory throughput benchmarks:"- bench "bytes written" c_bytewrite- bench "bytes read " c_byteread- bench "words written" c_wordwrite- bench "words read " c_wordread- putStrLn ""- putStrLn "Haskell memory throughput benchmarks:"- bench "bytes written" hs_bytewrite- bench "bytes read " hs_byteread- bench "words written" hs_wordwrite- bench "words read " hs_wordread--hs_bytewrite :: Ptr CUChar -> Int -> IO ()-hs_bytewrite !ptr bytes = loop 0 0- where iterations = bytes- loop :: Int -> CUChar -> IO ()- loop !i !n | i == iterations = return ()- | otherwise = do pokeByteOff ptr i n- loop (i+1) (n+1)--hs_byteread :: Ptr CUChar -> Int -> IO CUChar-hs_byteread !ptr bytes = loop 0 0- where iterations = bytes- loop :: Int -> CUChar -> IO CUChar- loop !i !n | i == iterations = return n- | otherwise = do x <- peekByteOff ptr i- loop (i+1) (n+x)--hs_wordwrite :: Ptr CULong -> Int -> IO ()-hs_wordwrite !ptr bytes = loop 0 0- where iterations = bytes `div` sizeOf (undefined :: CULong)- loop :: Int -> CULong -> IO ()- loop !i !n | i == iterations = return ()- | otherwise = do pokeByteOff ptr i n- loop (i+1) (n+1)--hs_wordread :: Ptr CULong -> Int -> IO CULong-hs_wordread !ptr bytes = loop 0 0- where iterations = bytes `div` sizeOf (undefined :: CULong)- loop :: Int -> CULong -> IO CULong- loop !i !n | i == iterations = return n- | otherwise = do x <- peekByteOff ptr i- loop (i+1) (n+x)---foreign import ccall unsafe "CBenchmark.h byteread"- c_byteread :: Ptr CUChar -> CInt -> IO ()--foreign import ccall unsafe "CBenchmark.h bytewrite"- c_bytewrite :: Ptr CUChar -> CInt -> IO ()--foreign import ccall unsafe "CBenchmark.h wordread"- c_wordread :: Ptr CUInt -> CInt -> IO ()--foreign import ccall unsafe "CBenchmark.h wordwrite"- c_wordwrite :: Ptr CUInt -> CInt -> IO ()--time :: IO a -> IO Double-time action = do- start <- getCPUTime- action- end <- getCPUTime- return $! (fromIntegral (end - start)) / (10^12)
− tests/NewBenchmark.hs
@@ -1,625 +0,0 @@------ 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
@@ -1,1006 +0,0 @@-{-# 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/Parallel.hs
@@ -1,147 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Test.QuickCheck.Parallel--- Copyright : (c) Don Stewart 2006--- License : BSD-style (see the file LICENSE)--- --- Maintainer : dons@cse.unsw.edu.au--- Stability : experimental--- Portability : non-portable (uses Control.Exception, Control.Concurrent)------ A parallel batch driver for running QuickCheck on threaded or SMP systems.--- See the /Example.hs/ file for a complete overview.-----module Parallel (- pRun,- pDet,- pNon- ) where--import Test.QuickCheck-import Data.List-import Control.Concurrent-import Control.Exception hiding (evaluate)-import System.Random-import System.IO (hFlush,stdout)-import Text.Printf--type Name = String-type Depth = Int-type Test = (Name, Depth -> IO String)---- | Run a list of QuickCheck properties in parallel chunks, using--- 'n' Haskell threads (first argument), and test to a depth of 'd'--- (second argument). Compile your application with '-threaded' and run--- with the SMP runtime's '-N4' (or however many OS threads you want to--- donate), for best results.------ > import Test.QuickCheck.Parallel--- >--- > do n <- getArgs >>= readIO . head--- > pRun n 1000 [ ("sort1", pDet prop_sort1) ]------ Will run 'n' threads over the property list, to depth 1000.----pRun :: Int -> Int -> [Test] -> IO ()-pRun n depth tests = do- chan <- newChan- ps <- getChanContents chan- work <- newMVar tests-- forM_ [1..n] $ forkIO . thread work chan-- let wait xs i- | i >= n = return () -- done- | otherwise = case xs of- Nothing : xs -> wait xs $! i+1- Just s : xs -> putStr s >> hFlush stdout >> wait xs i- wait ps 0-- where- thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO ()- thread work chan me = loop- where- loop = do- job <- modifyMVar work $ \jobs -> return $ case jobs of- [] -> ([], Nothing)- (j:js) -> (js, Just j)- case job of- Nothing -> writeChan chan Nothing -- done- Just (name,prop) -> do- v <- prop depth- writeChan chan . Just $ printf "%d: %-25s: %s" me name v- loop----- | Wrap a property, and run it on a deterministic set of data-pDet :: Testable a => a -> Int -> IO String-pDet a n = mycheck Det defaultConfig- { configMaxTest = n- , configEvery = \n args -> unlines args } a---- | Wrap a property, and run it on a non-deterministic set of data-pNon :: Testable a => a -> Int -> IO String-pNon a n = mycheck NonDet defaultConfig- { configMaxTest = n- , configEvery = \n args -> unlines args } a--data Mode = Det | NonDet----------------------------------------------------------------------------mycheck :: Testable a => Mode -> Config -> a -> IO String-mycheck Det config a = do- let rnd = mkStdGen 99 -- deterministic- mytests config (evaluate a) rnd 0 0 []--mycheck NonDet config a = do- rnd <- newStdGen -- different each run- mytests config (evaluate a) rnd 0 0 []--mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String-mytests config gen rnd0 ntest nfail stamps- | ntest == configMaxTest config = do done "OK," ntest stamps- | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps- | otherwise = do- case ok result of- Nothing ->- mytests config gen rnd1 ntest (nfail+1) stamps- Just True ->- mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)- Just False ->- return ( "Falsifiable after "- ++ show ntest- ++ " tests:\n"- ++ unlines (arguments result)- )- where- result = generate (configSize config ntest) rnd2 gen- (rnd1,rnd2) = split rnd0--done :: String -> Int -> [[String]] -> IO String-done mesg ntest stamps =- return ( mesg ++ " " ++ show ntest ++ " tests" ++ table )- where- table = display- . map entry- . reverse- . sort- . map pairLength- . group- . sort- . filter (not . null)- $ stamps-- display [] = ".\n"- display [x] = " (" ++ x ++ ").\n"- display xs = ".\n" ++ unlines (map (++ ".") xs)-- pairLength xss@(xs:_) = (length xss, xs)- entry (n, xs) = percentage n ntest- ++ " "- ++ concat (intersperse ", " xs)-- percentage n m = show ((100 * n) `div` m) ++ "%"--forM_ = flip mapM_
− tests/QC.hs
@@ -1,244 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-module Main where--import Data.Binary-import Data.Binary.Put-import Data.Binary.Get--import Parallel--import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Unsafe as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Internal as L-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet--import Data.Array (Array)-import Data.Array.IArray-import Data.Array.Unboxed (UArray)--import qualified Control.OldException as C (catch,evaluate)-import Control.Monad-import Foreign-import System.Environment-import System.IO-import System.IO.Unsafe--import Test.QuickCheck hiding (test)-import QuickCheckUtils-import Text.Printf---- import qualified Data.Sequence as Seq----------------------------------------------------------------------------roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool-roundTrip a f = a ==- {-# SCC "decode.refragment.encode" #-} decode (f (encode a))--roundTripWith put get x =- forAll positiveList $ \xs ->- x == runGet get (refragment xs (runPut (put x)))---- make sure that a test fails-errorish :: B a-errorish a = unsafePerformIO $- C.catch (do C.evaluate a- return False)- (\_ -> return True)---- low level ones:--prop_Word16be = roundTripWith putWord16be getWord16be-prop_Word16le = roundTripWith putWord16le getWord16le-prop_Word16host = roundTripWith putWord16host getWord16host--prop_Word32be = roundTripWith putWord32be getWord32be-prop_Word32le = roundTripWith putWord32le getWord32le-prop_Word32host = roundTripWith putWord32host getWord32host--prop_Word64be = roundTripWith putWord64be getWord64be-prop_Word64le = roundTripWith putWord64le getWord64le-prop_Word64host = roundTripWith putWord64host getWord64host--prop_Wordhost = roundTripWith putWordhost getWordhost---- read too much:--prop_bookworm x = errorish $ x == a && x /= b- where- (a,b) = decode (encode x)---- sanity:--invariant_lbs :: L.ByteString -> Bool-invariant_lbs (L.Empty) = True-invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs--prop_invariant :: (Binary a) => a -> Bool-prop_invariant = invariant_lbs . encode---- be lazy!---- doesn't do fair testing of lazy put/get.--- tons of untested cases---- lazyTrip :: (Binary a, Eq a) => a -> Property--- lazyTrip a = forAll positiveList $ \xs ->--- a == (runGet lazyGet . refragment xs . runPut . lazyPut $ a)---- refragment a lazy bytestring's chunks-refragment :: [Int] -> L.ByteString -> L.ByteString-refragment [] lps = lps-refragment (x:xs) lps =- let x' = fromIntegral . (+1) . abs $ x- rest = refragment xs (L.drop x' lps) in- L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest---- check identity of refragmentation-prop_refragment lps xs = lps == refragment xs lps---- check that refragmention still hold invariant-prop_refragment_inv lps xs = invariant_lbs $ refragment xs lps--main :: IO ()-main = do- hSetBuffering stdout NoBuffering- s <- getArgs- let x = if null s then 100 else read (head s)- pRun 2 x tests--{--run :: [(String, Int -> IO ())] -> IO ()-run tests = do- x <- getArgs- let n = if null x then 100 else read . head $ x- mapM_ (\(s,a) -> printf "%-50s" s >> a n) tests--}----------------------------------------------------------------------------type T a = a -> Property-type B a = a -> Bool--p :: Testable a => a -> Int -> IO String-p = pNon--test :: (Eq a, Binary a) => a -> Property-test a = forAll positiveList (roundTrip a . refragment)--positiveList :: Gen [Int]-positiveList = fmap (filter (/=0) . map abs) $ arbitrary---- tests :: [(String, Int -> IO String)]-tests =--- utils- [ ("refragment id", p prop_refragment )- , ("refragment invariant", p prop_refragment_inv )---- boundaries- , ("read to much", p (prop_bookworm :: B Word8 ))---- Primitives- , ("Word16be", p prop_Word16be)- , ("Word16le", p prop_Word16le)- , ("Word16host", p prop_Word16host)- , ("Word32be", p prop_Word32be)- , ("Word32le", p prop_Word32le)- , ("Word32host", p prop_Word32host)- , ("Word64be", p prop_Word64be)- , ("Word64le", p prop_Word64le)- , ("Word64host", p prop_Word64host)- , ("Wordhost", p prop_Wordhost)---- higher level ones using the Binary class- ,("()", p (test :: T () ))- ,("Bool", p (test :: T Bool ))- ,("Ordering", p (test :: T Ordering ))-- ,("Word8", p (test :: T Word8 ))- ,("Word16", p (test :: T Word16 ))- ,("Word32", p (test :: T Word32 ))- ,("Word64", p (test :: T Word64 ))-- ,("Int8", p (test :: T Int8 ))- ,("Int16", p (test :: T Int16 ))- ,("Int32", p (test :: T Int32 ))- ,("Int64", p (test :: T Int64 ))-- ,("Word", p (test :: T Word ))- ,("Int", p (test :: T Int ))- ,("Integer", p (test :: T Integer ))-- ,("Float", p (test :: T Float ))- ,("Double", p (test :: T Double ))-- ,("Char", p (test :: T Char ))-- ,("[()]", p (test :: T [()] ))- ,("[Word8]", p (test :: T [Word8] ))- ,("[Word32]", p (test :: T [Word32] ))- ,("[Word64]", p (test :: T [Word64] ))- ,("[Word]", p (test :: T [Word] ))- ,("[Int]", p (test :: T [Int] ))- ,("[Integer]", p (test :: T [Integer] ))- ,("String", p (test :: T String ))-- ,("((), ())", p (test :: T ((), ()) ))- ,("(Word8, Word32)", p (test :: T (Word8, Word32) ))- ,("(Int8, Int32)", p (test :: T (Int8, Int32) ))- ,("(Int32, [Int])", p (test :: T (Int32, [Int]) ))-- ,("Maybe Int8", p (test :: T (Maybe Int8) ))- ,("Either Int8 Int16", p (test :: T (Either Int8 Int16) ))-- ,("(Maybe Word8, Bool, [Int], Either Bool Word8)",- p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))-- ,("(Int, ByteString)", p (test :: T (Int, B.ByteString) ))--- ,("Lazy (Int, ByteString)", p (lazyTrip :: T (Int, B.ByteString) ))- ,("[(Int, ByteString)]", p (test :: T [(Int, B.ByteString)] ))--- ,("Lazy [(Int, ByteString)]", p (lazyTrip :: T [(Int, B.ByteString)] ))----- ,("Lazy IntMap", p (lazyTrip :: T IntSet.IntSet ))- ,("IntSet", p (test :: T IntSet.IntSet ))- ,("IntMap ByteString", p (test :: T (IntMap.IntMap B.ByteString) ))-- ,("B.ByteString", p (test :: T B.ByteString ))- ,("L.ByteString", p (test :: T L.ByteString ))-- ,("B.ByteString invariant", p (prop_invariant :: B B.ByteString ))- ,("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString] ))- ,("L.ByteString invariant", p (prop_invariant :: B L.ByteString ))- ,("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] ))- ,("IntMap invariant", p (prop_invariant :: B (IntMap.IntMap B.ByteString) ))-- ,("Set Word32", p (test :: T (Set.Set Word32) ))- ,("Map Word16 Int", p (test :: T (Map.Map Word16 Int) ))-- ,("(Maybe Int64, Bool, [Int])", p (test :: T (Maybe Int64, Bool, [Int])))--{------- Big tuples lack an Arbitrary instance in Hugs/QuickCheck----- ,("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",- p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) ))-- ,("(Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int)", p (roundTrip :: (Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int) -> Bool))-- ,("(Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int)", p (roundTrip :: (Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int) -> Bool))--}---- GHC only:--- ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))---- Obsolete--- ,("ensureLeft/Fail", mytest (shouldFail (decode L.empty :: Either ParseError Int)))- ]
− tests/QuickCheckUtils.hs
@@ -1,258 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------ Uses multi-param type classes----module QuickCheckUtils where--import Control.Monad--import Test.QuickCheck.Batch-import Test.QuickCheck-import Text.Show.Functions--import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as B-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Lazy as L-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet--import qualified Control.Exception as C (evaluate)--import Control.Monad ( liftM2 )-import Data.Char-import Data.List-import Data.Word-import Data.Int-import System.Random-import System.IO---- import Control.Concurrent-import System.Mem-import System.CPUTime-import Text.Printf--import qualified Data.ByteString as P-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Internal as L---- import qualified Data.Sequence as Seq---- Enable this to get verbose test output. Including the actual tests.-debug = False--mytest :: Testable a => a -> Int -> IO ()-mytest a n = mycheck defaultConfig- { configMaxTest=n- , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a--mycheck :: Testable a => Config -> a -> IO ()-mycheck config a = do- rnd <- newStdGen- performGC -- >> threadDelay 100- t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0- printf " %0.3f seconds\n" (t :: Double)- hFlush stdout--time :: a -> IO (a , Double)-time a = do- start <- getCPUTime- v <- C.evaluate a- v `seq` return ()- end <- getCPUTime- return (v, ( (fromIntegral (end - start)) / (10^12)))--mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO Double-mytests config gen rnd0 ntest nfail stamps t0- | ntest == configMaxTest config = do done "OK," ntest stamps- return t0-- | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps- return t0-- | otherwise = do- (result,t1) <- time (generate (configSize config ntest) rnd2 gen)-- putStr (configEvery config ntest (arguments result)) >> hFlush stdout- case ok result of- Nothing ->- mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1)- Just True ->- mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1)- Just False -> do- putStr ( "Falsifiable after "- ++ show ntest- ++ " tests:\n"- ++ unlines (arguments result)- ) >> hFlush stdout- return t0-- where- (rnd1,rnd2) = split rnd0--done :: String -> Int -> [[String]] -> IO ()-done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )- where- table = display- . map entry- . reverse- . sort- . map pairLength- . group- . sort- . filter (not . null)- $ stamps-- display [] = ". "- display [x] = " (" ++ x ++ "). "- display xs = ".\n" ++ unlines (map (++ ".") xs)-- pairLength xss@(xs:_) = (length xss, xs)- entry (n, xs) = percentage n ntest- ++ " "- ++ concat (intersperse ", " xs)-- percentage n m = show ((100 * n) `div` m) ++ "%"----------------------------------------------------------------------------instance Random Word8 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Int8 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word16 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Int16 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word32 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Int32 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Word64 where- randomR = integralRandomR- random = randomR (minBound,maxBound)--instance Random Int64 where- randomR = integralRandomR- random = randomR (minBound,maxBound)----------------------------------------------------------------------------integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)-integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,- fromIntegral b :: Integer) g of- (x,g) -> (fromIntegral x, g)----------------------------------------------------------------------------instance Arbitrary Word8 where- arbitrary = choose (0, 2^8-1)- coarbitrary w = variant 0--instance Arbitrary Word16 where- arbitrary = choose (0, 2^16-1)- coarbitrary = undefined--instance Arbitrary Word32 where--- arbitrary = choose (0, 2^32-1)- arbitrary = choose (minBound, maxBound)- coarbitrary = undefined--instance Arbitrary Word64 where--- arbitrary = choose (0, 2^64-1)- arbitrary = choose (minBound, maxBound)- coarbitrary = undefined--instance Arbitrary Int8 where--- arbitrary = choose (0, 2^8-1)- arbitrary = choose (minBound, maxBound)- coarbitrary w = variant 0--instance Arbitrary Int16 where--- arbitrary = choose (0, 2^16-1)- arbitrary = choose (minBound, maxBound)- coarbitrary = undefined--instance Arbitrary Int32 where--- arbitrary = choose (0, 2^32-1)- arbitrary = choose (minBound, maxBound)- coarbitrary = undefined--instance Arbitrary Int64 where--- arbitrary = choose (0, 2^64-1)- arbitrary = choose (minBound, maxBound)- coarbitrary = undefined--instance Arbitrary Word where- arbitrary = choose (minBound, maxBound)- coarbitrary w = variant 0----------------------------------------------------------------------------instance Arbitrary Char where- arbitrary = choose (maxBound, minBound)- coarbitrary = undefined--{--instance Arbitrary a => Arbitrary (Maybe a) where- arbitrary = oneof [ return Nothing, liftM Just arbitrary]- coarbitrary = undefined- -}--instance Arbitrary Ordering where- arbitrary = oneof [ return LT,return GT,return EQ ]- coarbitrary = undefined--{--instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where- arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary]- coarbitrary = undefined- -}--instance Arbitrary IntSet.IntSet where- arbitrary = fmap IntSet.fromList arbitrary- coarbitrary = undefined--instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where- arbitrary = fmap IntMap.fromList arbitrary- coarbitrary = undefined--instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where- arbitrary = fmap Set.fromList arbitrary- coarbitrary = undefined--instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where- arbitrary = fmap Map.fromList arbitrary- coarbitrary = undefined--{--instance (Arbitrary a) => Arbitrary (Seq.Seq a) where- arbitrary = fmap Seq.fromList arbitrary- coarbitrary = undefined--}--instance Arbitrary L.ByteString where- arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant.- coarbitrary s = coarbitrary (L.unpack s)--instance Arbitrary B.ByteString where- arbitrary = B.pack `fmap` arbitrary- coarbitrary s = coarbitrary (B.unpack s)
− todo
@@ -1,28 +0,0 @@-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
− tools/derive/BinaryDerive.hs
@@ -1,57 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--module BinaryDerive where--import Data.Generics-import Data.List--deriveM :: (Typeable a, Data a) => a -> IO ()-deriveM (a :: a) = mapM_ putStrLn . lines $ derive (undefined :: a)--derive :: (Typeable a, Data a) => a -> String-derive x = - "instance " ++ context ++ "Binary " ++ inst ++ " where\n" ++- concat putDefs ++ getDefs- where- context- | nTypeChildren > 0 =- wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => "- | otherwise = ""- inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters- wrap x = if nTypeChildren > 0 then "("++x++")" else x - join sep lst = concat $ intersperse sep lst- nTypeChildren = length typeChildren- typeLetters = take nTypeChildren manyLetters- manyLetters = map (:[]) ['a'..'z']- (typeName,typeChildren) = splitTyConApp (typeOf x)- constrs :: [(Int, (String, Int))]- constrs = zip [0..] $ map gen $ dataTypeConstrs (dataTypeOf x)- gen con = ( showConstr con- , length $ gmapQ undefined $ fromConstr con `asTypeOf` x- )- putDefs = map ((++"\n") . putDef) constrs- putDef (n, (name, ps)) =- let wrap = if ps /= 0 then ("("++) . (++")") else id- pattern = name ++ concatMap (' ':) (take ps manyLetters)- in- " put " ++ wrap pattern ++" = "- ++ concat [ "putWord8 " ++ show n | length constrs > 1 ]- ++ concat [ " >> " | length constrs > 1 && ps > 0 ]- ++ concat [ "return ()" | length constrs == 1 && ps == 0 ]- ++ join " >> " (map ("put "++) (take ps manyLetters))- getDefs =- (if length constrs > 1- then " get = do\n tag_ <- getWord8\n case tag_ of\n"- else " get =")- ++ concatMap ((++"\n")) (map getDef constrs) ++- (if length constrs > 1- then " _ -> fail \"no parse\""- else ""- )- getDef (n, (name, ps)) =- let wrap = if ps /= 0 then ("("++) . (++")") else id- in- concat [ " " ++ show n ++ " ->" | length constrs > 1 ]- ++ concatMap (\x -> " get >>= \\"++x++" ->") (take ps manyLetters)- ++ " return "- ++ wrap (name ++ concatMap (" "++) (take ps manyLetters))
− tools/derive/Example.hs
@@ -1,68 +0,0 @@--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