cereal 0.4.1.1 → 0.5.0.0

raw patch · 16 files changed

+760/−2225 lines, 16 filesdep +QuickCheckdep +cerealdep +test-frameworkdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, cereal, test-framework, test-framework-quickcheck2

Dependency ranges changed: base, bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• cereal.cabal +29/−27
• src/Data/Serialize.hs +42/−6
• src/Data/Serialize/Builder.hs +0/−429
• src/Data/Serialize/Get.hs +232/−64
• src/Data/Serialize/IEEE754.hs +13/−2
• src/Data/Serialize/Put.hs +80/−31
• tests/Benchmark.hs +0/−1462
• tests/CBenchmark.c +0/−39
• tests/CBenchmark.h +0/−4
• tests/GetTests.hs +278/−0
• tests/Main.hs +13/−0
• tests/Makefile +0/−23
• tests/MemBench.hs +0/−85
• tests/RoundTrip.hs +63/−0
• tests/Tests.hs +0/−53

@@ -0,0 +1,10 @@++0.5.0.0+=======++* Switch to using the builder provided by the `ByteString` package+* Change the encoding of Float and Double with the Serialize class to use the+  `Data.Serialize.IEEE754` module+* Add support for encoding and decoding `ShortByteString`+* New and improved test suite thanks to Kei Hibino+* Fix two bugs involving the `lookAhead` combinator and partial chunks.

@@ -1,5 +1,5 @@ name:                   cereal-version:                0.4.1.1+version:                0.5.0.0 license:                BSD3 license-file:           LICENSE author:                 Lennart Kolmodin <kolmodin@dtek.chalmers.se>,@@ -10,49 +10,51 @@ category:               Data, Parsing stability:              provisional build-type:             Simple-cabal-version:          >= 1.6+cabal-version:          >= 1.10 synopsis:               A binary serialization library-extra-source-files:     tests/Benchmark.hs,-                        tests/CBenchmark.c,-                        tests/CBenchmark.h,-                        tests/Makefile,-                        tests/MemBench.hs,-                        tests/Tests.hs+homepage:               https://github.com/GaloisInc/cereal+ description:   A binary serialization library, similar to binary, that introduces an isolate   primitive for parser isolation, and labeled blocks for better error messages. +extra-source-files:     CHANGELOG.md+ source-repository head   type:     git   location: git://github.com/GaloisInc/cereal.git -flag split-base-        default: True- library-        build-depends:          bytestring-        if flag(split-base)-                build-depends:  base == 4.*, containers, array-        else-                build-depends:  base < 3.0+        default-language:       Haskell2010 -        if impl(ghc >= 7.2.1)-                cpp-options:    -DGENERICS-                build-depends:  ghc-prim >= 0.2+        build-depends:          bytestring >= 0.10.0.0,+                                base == 4.*, containers, array,+                                ghc-prim >= 0.2          hs-source-dirs:         src          exposed-modules:        Data.Serialize,                                 Data.Serialize.Put,                                 Data.Serialize.Get,-                                Data.Serialize.Builder,                                 Data.Serialize.IEEE754 -        extensions:             CPP,-                                FlexibleContexts,-                                FlexibleInstances,-                                Rank2Types,-                                MagicHash-         ghc-options:            -Wall -O2 -funbox-strict-fields-        ghc-prof-options:       -prof -auto-all+++test-suite test-cereal+        default-language:       Haskell2010++        type:                   exitcode-stdio-1.0++        build-depends:          base == 4.*,+                                bytestring,+                                QuickCheck,+                                test-framework,+                                test-framework-quickcheck2,+                                cereal++        main-is:                Main.hs+        other-modules:          RoundTrip+                                GetTests++        hs-source-dirs:         tests

@@ -10,6 +10,10 @@            , ScopedTypeVariables #-} #endif +#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif+ ----------------------------------------------------------------------------- -- | -- Module      : Data.Serialize@@ -65,9 +69,16 @@  #ifdef GENERICS import GHC.Generics+#endif++#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((*>),(<*>),(<$>),pure) #endif +#if MIN_VERSION_base(4,8,0)+import Numeric.Natural+#endif+ ------------------------------------------------------------------------  @@ -238,13 +249,13 @@ -- -- Fold and unfold an Integer to and from a list of its bytes ---unroll :: Integer -> [Word8]+unroll :: (Integral a, Num a, Bits a) => a -> [Word8] unroll = unfoldr step   where     step 0 = Nothing     step i = Just (fromIntegral i, i `shiftR` 8) -roll :: [Word8] -> Integer+roll :: (Integral a, Num a, Bits a) => [Word8] -> a roll   = foldr unstep 0   where     unstep b a = a `shiftL` 8 .|. fromIntegral b@@ -253,6 +264,31 @@     put r = put (R.numerator r) >> put (R.denominator r)     get = liftM2 (R.%) get get +#if MIN_VERSION_base(4,8,0)+-- Fixed-size type for a subset of Natural+type NaturalWord = Word64++instance Serialize Natural where+    {-# INLINE put #-}+    put n | n <= hi = do+        putWord8 0+        put (fromIntegral n :: NaturalWord)  -- fast path+     where+        hi = fromIntegral (maxBound :: NaturalWord) :: Natural++    put n = do+        putWord8 1+        put (unroll (abs n))         -- unroll the bytes++    {-# INLINE get #-}+    get = do+        tag <- get :: Get Word8+        case tag of+            0 -> liftM fromIntegral (get :: Get NaturalWord)+            _ -> do bytes <- get+                    return $! roll bytes+#endif+ ------------------------------------------------------------------------  -- Safely wrap `chr` to avoid exceptions. @@ -458,12 +494,12 @@ -- Floating point  instance Serialize Double where-    put d = put (decodeFloat d)-    get   = liftM2 encodeFloat get get+    put = putFloat64be+    get = getFloat64be  instance Serialize Float where-    put f = put (decodeFloat f)-    get   = liftM2 encodeFloat get get+    put = putFloat32be+    get = getFloat32be  ------------------------------------------------------------------------ -- Trees

@@ -1,429 +0,0 @@-{-# LANGUAGE CPP       #-}-{-# LANGUAGE MagicHash #-}--- for unboxed shifts---------------------------------------------------------------------------------- |--- Module      : Data.Serialize.Builder--- Copyright   : Lennart Kolmodin, Ross Paterson, Galois Inc. 2009--- License     : BSD3-style (see LICENSE)--- --- Maintainer  : Trevor Elliott <trevor@galois.com>--- Stability   :--- Portability :------ Efficient construction of lazy bytestrings.-----------------------------------------------------------------------------------#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-#include "MachDeps.h"-#endif--module Data.Serialize.Builder (--    -- * The Builder type-      Builder-    , toByteString-    , 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--  ) where--import Data.Monoid-import Data.Word-import Foreign.ForeignPtr-import Foreign.Ptr (Ptr,plusPtr)-import Foreign.Storable-import System.IO.Unsafe (unsafePerformIO)-import qualified Data.ByteString          as S-import qualified Data.ByteString.Lazy     as L-import qualified Data.ByteString.Internal as S--#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)-import GHC.Base (Int(..), uncheckedShiftRL#)-import GHC.Word (Word32(..),Word16(..),Word64(..))--#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608-import GHC.Word (uncheckedShiftRL64#)-#endif-#else-import Data.Word-#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----------------------------------------------------------------------------toByteString :: Builder -> S.ByteString-toByteString m = S.concat $ unsafePerformIO $ do-  buf <- newBuffer defaultSize-  return (runBuilder (m `append` flush) (const []) buf)---- | /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 -> S.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--#else-shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)-#endif--#else-shiftr_w16 = shiftR-shiftr_w32 = shiftR-shiftr_w64 = shiftR-#endif

@@ -29,8 +29,11 @@     , runGetLazy     , runGetState     , runGetLazyState++    -- ** Incremental interface     , Result(..)     , runGetPartial+    , runGetChunk      -- * Parsing     , ensure@@ -50,20 +53,31 @@      -- * Parsing particular types     , getWord8+    , getInt8      -- ** ByteStrings     , getByteString     , getLazyByteString +#if MIN_VERSION_bytestring(0,10,4)+    , getShortByteString+#endif+     -- ** Big-endian reads     , getWord16be     , getWord32be     , getWord64be+    , getInt16be+    , getInt32be+    , getInt64be      -- ** Little-endian reads     , getWord16le     , getWord32le     , getWord64le+    , getInt16le+    , getInt32le+    , getInt64le      -- ** Host-endian, unaligned reads     , getWordhost@@ -83,16 +97,19 @@     , getIntSetOf     , getMaybeOf     , getEitherOf+    , getNested    ) where -import Control.Applicative (Applicative(..),Alternative(..))-import Control.Monad (unless,when,ap,MonadPlus(..),liftM2)+import qualified Control.Applicative as A+import qualified Control.Monad as M+import Control.Monad (unless) import Data.Array.IArray (IArray,listArray) import Data.Ix (Ix) import Data.List (intercalate) import Data.Maybe (isNothing,fromMaybe) import Foreign+import System.IO.Unsafe (unsafeDupablePerformIO)  import qualified Data.ByteString          as B import qualified Data.ByteString.Internal as B@@ -106,6 +123,11 @@ import qualified Data.Tree                as T  +#if MIN_VERSION_bytestring(0,10,4)+import qualified Data.ByteString.Short as BS+#endif++ #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base import GHC.Word@@ -143,8 +165,17 @@ type Input  = B.ByteString type Buffer = Maybe B.ByteString +emptyBuffer :: Buffer+emptyBuffer  = Just B.empty++extendBuffer :: Buffer -> B.ByteString -> Buffer+extendBuffer buf chunk =+  do bs <- buf+     return (bs `B.append` chunk)+{-# INLINE extendBuffer #-}+ append :: Buffer -> Buffer -> Buffer-append l r = B.append `fmap` l <*> r+append l r = B.append `fmap` l A.<*> r {-# INLINE append #-}  bufferBytes :: Buffer -> B.ByteString@@ -166,38 +197,57 @@   Incomplete mb -> fromMaybe 0 mb  instance Functor Get where-    fmap p m =-      Get $ \s0 b0 m0 kf ks ->-        let ks' s1 b1 m1 a = ks s1 b1 m1 (p a)-         in unGet m s0 b0 m0 kf ks'+    fmap p m =        Get $ \ s0 b0 m0 kf ks ->+      unGet m s0 b0 m0 kf $ \ s1 b1 m1 a     -> ks s1 b1 m1 (p a) -instance Applicative Get where+instance A.Applicative Get where     pure  = return-    (<*>) = ap+    {-# INLINE pure #-} -instance Alternative Get where+    f <*> x =         Get $ \ s0 b0 m0 kf ks ->+      unGet f s0 b0 m0 kf $ \ s1 b1 m1 g     ->+      unGet x s1 b1 m1 kf $ \ s2 b2 m2 y     -> ks s2 b2 m2 (g y)+    {-# INLINE (<*>) #-}++instance A.Alternative Get where     empty = failDesc "empty"-    (<|>) = mplus+    {-# INLINE empty #-} +    (<|>) = M.mplus+    {-# INLINE (<|>) #-}+ -- Definition directly from Control.Monad.State.Strict instance Monad Get where     return a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a+    {-# INLINE return #-} -    m >>= g  =-      Get $ \s0 b0 m0 kf ks ->-        let ks' s1 b1 m1 a = unGet (g a) s1 b1 m1 kf ks-         in unGet m s0 b0 m0 kf ks'+    m >>= g  =        Get $ \ s0 b0 m0 kf ks ->+      unGet m s0 b0 m0 kf $ \ s1 b1 m1 a     -> unGet (g a) s1 b1 m1 kf ks+    {-# INLINE (>>=) #-} +    m >> k =          Get $ \ s0 b0 m0 kf ks ->+      unGet m s0 b0 m0 kf $ \ s1 b1 m1 _     -> unGet k s1 b1 m1 kf ks+    {-# INLINE (>>) #-}+     fail     = failDesc+    {-# INLINE fail #-} -instance MonadPlus Get where++instance M.MonadPlus Get where     mzero     = failDesc "mzero"+    {-# INLINE mzero #-}+     mplus a b =       Get $ \s0 b0 m0 kf ks ->-        let kf' _ b1 m1 _ _ = unGet b (s0 `B.append` bufferBytes b1)-                                      (b0 `append` b1) m1 kf ks-         in unGet a s0 (Just B.empty) m0 kf' ks+        let ks' s1 b1        = ks s1 (b0 `append` b1)+            kf' _  b1 m1     = kf (s0 `B.append` bufferBytes b1)+                                  (b0 `append` b1) m1+            try _  b1 m1 _ _ = unGet b (s0 `B.append` bufferBytes b1)+                                       b1 m1 kf' ks'+         in unGet a s0 emptyBuffer m0 try ks'+    {-# INLINE mplus #-} + ------------------------------------------------------------------------  formatTrace :: [String] -> String@@ -234,10 +284,17 @@     Partial{} -> Left "Failed reading: Internal error: unexpected Partial." {-# INLINE runGet #-} +-- | Run the get monad on a single chunk, providing an optional length for the+-- remaining, unseen input, with Nothing indicating that it's not clear how much+-- input is left.  For example, with a lazy ByteString, the optional length+-- represents the sum of the lengths of all remaining chunks.+runGetChunk :: Get a -> Maybe Int -> B.ByteString -> Result a+runGetChunk m mbLen str = unGet m str Nothing (Incomplete mbLen) failK finalK+{-# INLINE runGetChunk #-}+ -- | Run the Get monad applies a 'get'-based parser on the input ByteString runGetPartial :: Get a -> B.ByteString -> Result a-runGetPartial m str =-  unGet m str Nothing (Incomplete Nothing) failK finalK+runGetPartial m = runGetChunk m Nothing {-# INLINE runGetPartial #-}  -- | Run the Get monad applies a 'get'-based parser on the input@@ -267,9 +324,16 @@ -- Lazy Get --------------------------------------------------------------------  runGetLazy' :: Get a -> L.ByteString -> (Either String a,L.ByteString)-runGetLazy' m lstr = loop (Partial (runGetPartial m)) (L.toChunks lstr)+runGetLazy' m lstr =+  case L.toChunks lstr of+    [c]  -> wrapStrict (runGetState' m c       0)+    []   -> wrapStrict (runGetState' m B.empty 0)+    c:cs -> loop (runGetChunk m (Just (len - B.length c)) c) cs   where+  len = fromIntegral (L.length lstr) +  wrapStrict (e,s) = (e,L.fromChunks [s])+   loop result chunks = case result of      Fail str rest -> (Left str, L.fromChunks (rest : chunks))@@ -318,7 +382,7 @@ --   is required to consume all the bytes that it is isolated to. isolate :: Int -> Get a -> Get a isolate n m = do-  when (n < 0) (fail "Attempted to isolate a negative number of bytes")+  M.when (n < 0) (fail "Attempted to isolate a negative number of bytes")   s <- ensure n   let (s',rest) = B.splitAt n s   put s'@@ -337,10 +401,13 @@     Incomplete mb -> Partial $ \s ->       if B.null s       then kf s0 b0 m0 ["demandInput"] "too few bytes"-      else let update l = l - B.length s-               s1 = s0 `B.append` s-               b1 = b0 `append` Just s-            in ks s1 b1 (Incomplete (update `fmap` mb)) ()+      else let s1 = s0 `B.append` s+               b1 = extendBuffer b0 s+               mb' = case mb of+                       Just l  -> Just $! l - B.length s+                       Nothing -> Nothing+            in b1  `seq`+               mb' `seq` ks s1 b1 (Incomplete mb') ()  failDesc :: String -> Get a failDesc err = do@@ -363,8 +430,11 @@ -- Fails if @ga@ fails. lookAhead :: Get a -> Get a lookAhead ga = Get $ \ s0 b0 m0 kf ks ->-  let ks' _s1 b1 = ks (s0 `B.append` bufferBytes b1) (b0 `append` b1)-   in unGet ga s0 (Just B.empty) m0 kf ks'+  -- the new continuation extends the old input with the new buffered bytes, and+  -- appends the new buffer to the old one, if there was one.+  let ks' _ b1 = ks (s0 `B.append` bufferBytes b1) (b0 `append` b1)+      kf' _ b1 = kf s0 (b0 `append` b1)+   in unGet ga s0 emptyBuffer m0 kf' ks'  -- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. -- Fails if @gma@ fails.@@ -372,7 +442,7 @@ lookAheadM gma = do     s <- get     ma <- gma-    when (isNothing ma) (put s)+    M.when (isNothing ma) (put s)     return ma  -- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'.@@ -425,7 +495,14 @@ getLazyByteString n = f `fmap` getByteString (fromIntegral n)   where f bs = L.fromChunks [bs] +#if MIN_VERSION_bytestring(0,10,4)+getShortByteString :: Int -> Get BS.ShortByteString+getShortByteString n = do+  bs <- getBytes n+  return $! BS.toShort bs+#endif + ------------------------------------------------------------------------ -- Helpers @@ -453,73 +530,157 @@ getPtr n = do     (fp,o,_) <- B.toForeignPtr `fmap` getBytes n     let k p = peek (castPtr (p `plusPtr` o))-    return (B.inlinePerformIO (withForeignPtr fp k))+    return (unsafeDupablePerformIO (withForeignPtr fp k)) {-# INLINE getPtr #-} +-----------------------------------------------------------------------++-- | Read a Int8 from the monad state+getInt8 :: Get Int8+getInt8 = do+    s <- getBytes 1+    return $! fromIntegral (B.unsafeHead s)++-- | Read a Int16 in big endian format+getInt16be :: Get Int16+getInt16be = do+    s <- getBytes 2+    return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 8) .|.+              (fromIntegral (s `B.unsafeIndex` 1) )++-- | Read a Int16 in little endian format+getInt16le :: Get Int16+getInt16le = do+    s <- getBytes 2+    return $! (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )++-- | Read a Int32 in big endian format+getInt32be :: Get Int32+getInt32be = do+    s <- getBytes 4+    return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftL`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 3) )++-- | Read a Int32 in little endian format+getInt32le :: Get Int32+getInt32le = do+    s <- getBytes 4+    return $! (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftL`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )++-- | Read a Int64 in big endian format+getInt64be :: Get Int64+getInt64be = do+    s <- getBytes 8+    return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 56) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 48) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 40) .|.+              (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 32) .|.+              (fromIntegral (s `B.unsafeIndex` 4) `shiftL` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 5) `shiftL` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 6) `shiftL`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 7) )++-- | Read a Int64 in little endian format+getInt64le :: Get Int64+getInt64le = do+    s <- getBytes 8+    return $! (fromIntegral (s `B.unsafeIndex` 7) `shiftL` 56) .|.+              (fromIntegral (s `B.unsafeIndex` 6) `shiftL` 48) .|.+              (fromIntegral (s `B.unsafeIndex` 5) `shiftL` 40) .|.+              (fromIntegral (s `B.unsafeIndex` 4) `shiftL` 32) .|.+              (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftL` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftL`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )++{-# INLINE getInt8    #-}+{-# INLINE getInt16be #-}+{-# INLINE getInt16le #-}+{-# INLINE getInt32be #-}+{-# INLINE getInt32le #-}+{-# INLINE getInt64be #-}+{-# INLINE getInt64le #-}+ ------------------------------------------------------------------------  -- | Read a Word8 from the monad state getWord8 :: Get Word8-getWord8 = getPtr (sizeOf (undefined :: Word8))+getWord8 = do+    s <- getBytes 1+    return (B.unsafeHead s)  -- | Read a Word16 in big endian format getWord16be :: Get Word16 getWord16be = do     s <- getBytes 2-    return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|.-              (fromIntegral (s `B.index` 1))+    return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|.+              (fromIntegral (s `B.unsafeIndex` 1))  -- | Read a Word16 in little endian format getWord16le :: Get Word16 getWord16le = do     s <- getBytes 2-    return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|.-              (fromIntegral (s `B.index` 0) )+    return $! (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )  -- | Read a Word32 in big endian format getWord32be :: Get Word32 getWord32be = do     s <- getBytes 4-    return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|.-              (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|.-              (fromIntegral (s `B.index` 2) `shiftl_w32`  8) .|.-              (fromIntegral (s `B.index` 3) )+    return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 3) )  -- | Read a Word32 in little endian format getWord32le :: Get Word32 getWord32le = do     s <- getBytes 4-    return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|.-              (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|.-              (fromIntegral (s `B.index` 1) `shiftl_w32`  8) .|.-              (fromIntegral (s `B.index` 0) )+    return $! (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )  -- | Read a Word64 in big endian format getWord64be :: Get Word64 getWord64be = do     s <- getBytes 8-    return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|.-              (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|.-              (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|.-              (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|.-              (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|.-              (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|.-              (fromIntegral (s `B.index` 6) `shiftl_w64`  8) .|.-              (fromIntegral (s `B.index` 7) )+    return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|.+              (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|.+              (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 7) )  -- | Read a Word64 in little endian format getWord64le :: Get Word64 getWord64le = do     s <- getBytes 8-    return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|.-              (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|.-              (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|.-              (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|.-              (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|.-              (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|.-              (fromIntegral (s `B.index` 1) `shiftl_w64`  8) .|.-              (fromIntegral (s `B.index` 0) )+    return $! (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|.+              (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|.+              (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|.+              (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|.+              (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|.+              (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|.+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64`  8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) ) +{-# INLINE getWord8    #-}+{-# INLINE getWord16be #-}+{-# INLINE getWord16le #-}+{-# INLINE getWord32be #-}+{-# INLINE getWord32le #-}+{-# INLINE getWord64be #-}+{-# INLINE getWord64le #-}+ ------------------------------------------------------------------------ -- Host-endian reads @@ -575,7 +736,7 @@ -- Containers ------------------------------------------------------------------  getTwoOf :: Get a -> Get b -> Get (a,b)-getTwoOf ma mb = liftM2 (,) ma mb+getTwoOf ma mb = M.liftM2 (,) ma mb  -- | Get a list in the following format: --   Word64 (big endian format)@@ -585,7 +746,7 @@ getListOf :: Get a -> Get [a] getListOf m = go [] =<< getWord64be   where-  go as 0 = return (reverse as)+  go as 0 = return $! reverse as   go as i = do x <- m                x `seq` go (x:as) (i - 1) @@ -597,7 +758,7 @@ --   ... --   element n getIArrayOf :: (Ix i, IArray a e) => Get i -> Get e -> Get (a i e)-getIArrayOf ix e = liftM2 listArray (getTwoOf ix ix) (getListOf e)+getIArrayOf ix e = M.liftM2 listArray (getTwoOf ix ix) (getListOf e)  -- | Get a sequence in the following format: --   Word64 (big endian format)@@ -614,7 +775,7 @@  -- | Read as a list of lists. getTreeOf :: Get a -> Get (T.Tree a)-getTreeOf m = liftM2 T.Node m (getListOf (getTreeOf m))+getTreeOf m = M.liftM2 T.Node m (getListOf (getTreeOf m))  -- | Read as a list of pairs of key and element. getMapOf :: Ord k => Get k -> Get a -> Get (Map.Map k a)@@ -651,3 +812,10 @@   case tag of     0 -> Left  `fmap` ma     _ -> Right `fmap` mb++-- | Read in a length and then read a nested structure+--   of that length.+getNested :: Get Int -> Get a -> Get a+getNested getLen getVal = do+    n <- getLen+    isolate n getVal

@@ -1,6 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++#ifndef MIN_VERSION_array+#define MIN_VERSION_array(x,y,z) 1+#endif+ -- | IEEE-754 parsing, as described in this stack-overflow article: -- -- <http://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-float/7002812#7002812>@@ -21,7 +29,6 @@  ) where -import Control.Applicative ( (<$>) ) import Control.Monad.ST ( runST, ST )  import Data.Array.ST ( newArray, readArray, MArray, STUArray )@@ -29,7 +36,11 @@ import Data.Serialize.Get import Data.Serialize.Put -#if __GLASGOW_HASKELL__ >= 704+#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ( (<$>) )+#endif++#if MIN_VERSION_array(0,4,0) import Data.Array.Unsafe (castSTUArray) #else import Data.Array.ST (castSTUArray)

@@ -1,3 +1,13 @@+{-# LANGUAGE CPP #-}++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 0+#endif++#ifndef MIN_VERSION_bytestring+#define MIN_VERSION_bytestring(x,y,z) 0+#endif+ ----------------------------------------------------------------------------- -- | -- Module      : Data.Serialize.Put@@ -33,6 +43,10 @@     , putByteString     , putLazyByteString +#if MIN_VERSION_bytestring(0,10,4)+    , putShortByteString+#endif+     -- * Big-endian primitives     , putWord16be     , putWord32be@@ -61,16 +75,31 @@     , putIntSetOf     , putMaybeOf     , putEitherOf+    , putNested    ) where -import Data.Serialize.Builder (Builder, toByteString, toLazyByteString)-import qualified Data.Serialize.Builder as B -import Control.Applicative+#if MIN_VERSION_bytestring(0,10,2)+import           Data.ByteString.Builder (Builder, toLazyByteString)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Extra as B+#elif MIN_VERSION_bytestring(0,10,0)+import           Data.ByteString.Lazy.Builder (Builder, toLazyByteString)+import qualified Data.ByteString.Lazy.Builder as B+import qualified Data.ByteString.Lazy.Builder.Extras as B+#else+#error "cereal requires bytestring >= 0.10.0.0"+#endif++#if MIN_VERSION_bytestring(0,10,4)+import qualified Data.ByteString.Short as BS+#endif++import qualified Control.Applicative as A import Data.Array.Unboxed-import Data.Monoid-import Data.Foldable (foldMap)+import qualified Data.Monoid as M+import qualified Data.Foldable as F import Data.Word import qualified Data.ByteString        as S import qualified Data.ByteString.Lazy   as L@@ -81,6 +110,11 @@ import qualified Data.Set               as Set import qualified Data.Tree              as T +#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative+import Data.Foldable (foldMap)+import Data.Monoid+#endif  ------------------------------------------------------------------------ @@ -103,35 +137,35 @@         {-# INLINE fmap #-}  -instance Applicative PutM where+instance A.Applicative PutM where         pure    = return         {-# INLINE pure #-}          m <*> k = Put $             let PairS f w  = unPut m                 PairS x w' = unPut k-            in PairS (f x) (w `mappend` w')+            in PairS (f x) (w `M.mappend` w')         {-# INLINE (<*>) #-}   instance Monad PutM where-    return a = Put (PairS a mempty)+    return a = Put (PairS a M.mempty)     {-# INLINE return #-}      m >>= k  = Put $         let PairS a w  = unPut m             PairS b w' = unPut (k a)-        in PairS b (w `mappend` w')+        in PairS b (w `M.mappend` w')     {-# INLINE (>>=) #-}      m >> k  = Put $         let PairS _ w  = unPut m             PairS b w' = unPut k-        in PairS b (w `mappend` w')+        in PairS b (w `M.mappend` w')     {-# INLINE (>>) #-}  tell :: Putter Builder-tell b = Put $ PairS () b+tell b = Put $! PairS () b {-# INLINE tell #-}  putBuilder :: Putter Builder@@ -145,12 +179,12 @@  -- | Run the 'Put' monad with a serialiser runPut :: Put -> S.ByteString-runPut = toByteString . sndS . unPut+runPut = L.toStrict . runPutLazy {-# INLINE runPut #-}  -- | Run the 'Put' monad with a serialiser and get its result runPutM :: PutM a -> (a, S.ByteString)-runPutM (Put (PairS f s)) = (f, toByteString s)+runPutM (Put (PairS f s)) = (f, L.toStrict (toLazyByteString s)) {-# INLINE runPutM #-}  -- | Run the 'Put' monad with a serialiser@@ -173,49 +207,54 @@  -- | Efficiently write a byte into the output buffer putWord8            :: Putter Word8-putWord8            = tell . B.singleton+putWord8            = tell . B.word8 {-# INLINE putWord8 #-}  -- | An efficient primitive to write a strict ByteString into the output buffer. -- It flushes the current buffer, and writes the argument into a new chunk. putByteString       :: Putter S.ByteString-putByteString       = tell . B.fromByteString+putByteString       = tell . B.byteString {-# INLINE putByteString #-} +#if MIN_VERSION_bytestring(0,10,4)+putShortByteString  :: Putter BS.ShortByteString+putShortByteString   = tell . B.shortByteString+#endif+ -- | Write a lazy ByteString efficiently, simply appending the lazy -- ByteString chunks to the output buffer putLazyByteString   :: Putter L.ByteString-putLazyByteString   = tell . B.fromLazyByteString+putLazyByteString   = tell . B.lazyByteString {-# INLINE putLazyByteString #-}  -- | Write a Word16 in big endian format putWord16be         :: Putter Word16-putWord16be         = tell . B.putWord16be+putWord16be         = tell . B.word16BE {-# INLINE putWord16be #-}  -- | Write a Word16 in little endian format putWord16le         :: Putter Word16-putWord16le         = tell . B.putWord16le+putWord16le         = tell . B.word16LE {-# INLINE putWord16le #-}  -- | Write a Word32 in big endian format putWord32be         :: Putter Word32-putWord32be         = tell . B.putWord32be+putWord32be         = tell . B.word32BE {-# INLINE putWord32be #-}  -- | Write a Word32 in little endian format putWord32le         :: Putter Word32-putWord32le         = tell . B.putWord32le+putWord32le         = tell . B.word32LE {-# INLINE putWord32le #-}  -- | Write a Word64 in big endian format putWord64be         :: Putter Word64-putWord64be         = tell . B.putWord64be+putWord64be         = tell . B.word64BE {-# INLINE putWord64be #-}  -- | Write a Word64 in little endian format putWord64le         :: Putter Word64-putWord64le         = tell . B.putWord64le+putWord64le         = tell . B.word64LE {-# INLINE putWord64le #-}  ------------------------------------------------------------------------@@ -227,26 +266,26 @@ -- different endian or word sized machines, without conversion. -- putWordhost         :: Putter Word-putWordhost         = tell . B.putWordhost+putWordhost         = tell . B.wordHost {-# INLINE putWordhost #-}  -- | /O(1)./ Write a Word16 in native host order and host endianness. -- For portability issues see @putWordhost@. putWord16host       :: Putter Word16-putWord16host       = tell . B.putWord16host+putWord16host       = tell . B.word16Host {-# INLINE putWord16host #-}  -- | /O(1)./ Write a Word32 in native host order and host endianness. -- For portability issues see @putWordhost@. putWord32host       :: Putter Word32-putWord32host       = tell . B.putWord32host+putWord32host       = tell . B.word32Host {-# INLINE putWord32host #-}  -- | /O(1)./ Write a Word64 in native host order -- On a 32 bit machine we write two host order Word32s, in big endian form. -- For portability issues see @putWordhost@. putWord64host       :: Putter Word64-putWord64host       = tell . B.putWord64host+putWord64host       = tell . B.word64Host {-# INLINE putWord64host #-}  @@ -254,8 +293,8 @@  encodeListOf :: (a -> Builder) -> [a] -> Builder encodeListOf f = -- allow inlining with just a single argument-    \xs ->  execPut (putWord64be (fromIntegral $ length xs)) `mappend`-            foldMap f xs+    \xs ->  execPut (putWord64be (fromIntegral $ length xs)) `M.mappend`+            F.foldMap f xs {-# INLINE encodeListOf #-}  putTwoOf :: Putter a -> Putter b -> Putter (a,b)@@ -263,7 +302,9 @@ {-# INLINE putTwoOf #-}  putListOf :: Putter a -> Putter [a]-putListOf pa = tell . encodeListOf (execPut . pa)+putListOf pa = \l -> do+  putWord64be (fromIntegral (length l))+  mapM_ pa l {-# INLINE putListOf #-}  putIArrayOf :: (Ix i, IArray a e) => Putter i -> Putter e -> Putter (a i e)@@ -275,14 +316,14 @@ putSeqOf :: Putter a -> Putter (Seq.Seq a) putSeqOf pa = \s -> do     putWord64be (fromIntegral $ Seq.length s) -    tell (foldMap (execPut . pa) s)+    F.mapM_ pa s {-# INLINE putSeqOf #-}  putTreeOf :: Putter a -> Putter (T.Tree a) putTreeOf pa =      tell . go   where-    go (T.Node x cs) = execPut (pa x) `mappend` encodeListOf go cs+    go (T.Node x cs) = execPut (pa x) `M.mappend` encodeListOf go cs {-# INLINE putTreeOf #-}  putMapOf :: Ord k => Putter k -> Putter a -> Putter (Map.Map k a)@@ -310,3 +351,11 @@ putEitherOf pa _  (Left a)  = putWord8 0 >> pa a putEitherOf _  pb (Right b) = putWord8 1 >> pb b {-# INLINE putEitherOf #-}++-- | Put a nested structure by first putting a length+--   field and then putting the encoded value.+putNested :: Putter Int -> Put -> Put+putNested putLen putVal = do+    let bs = runPut putVal+    putLen (S.length bs)+    putByteString bs

@@ -1,1462 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Main (main) where--import qualified Data.ByteString as L-import Data.Serialize-import Data.Serialize.Put-import Data.Serialize.Get--import Control.Exception-import Data.Word-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)

@@ -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;-}

@@ -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);

@@ -0,0 +1,278 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}++module GetTests (tests) where++import           Control.Applicative+import           Control.Monad+import           Data.Word+import           Data.Function+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LB+import           Data.Serialize.Get+import           Test.Framework (Test(),testGroup)+import           Test.Framework.Providers.QuickCheck2 (testProperty)+import           Test.QuickCheck as QC+++-- Data to express Get parser to generate+data GetD+  = Get8+  | Eof+  | Get16be+  | Get32be+  | Get64be+  | Get16le+  | Get32le+  | Get64le+  | GetD  :*>   GetD+  | GetD  :<|>  GetD+  | LookAhead GetD+  | Skip Int+  deriving Show++-- Get parser generator+buildGet :: GetD -> Get ()+buildGet = d  where+  d Get8           =  getWord8    *> pure ()+  d Eof            =  guard =<< isEmpty+  d Get16be        =  getWord16be *> pure ()+  d Get32be        =  getWord32be *> pure ()+  d Get64be        =  getWord64be *> pure ()+  d Get16le        =  getWord16le *> pure ()+  d Get32le        =  getWord32le *> pure ()+  d Get64le        =  getWord64le *> pure ()+  d (x :*>  y)     =  d x *>  d y+  d (x :<|> y)     =  d x <|> d y+  d (LookAhead x)  =  lookAhead $ d x+  d (Skip i)       =  skip i++-- Randomly generate parser+genGetD :: Gen GetD+genGetD =+    oneof $+    [ pure g+    | g <- [ Get8, Eof+           , Get16be, Get32be, Get64be+           , Get16le, Get32le, Get64le+           ]+    ] +++    [ (:*>)     <$> genGetD <*> genGetD+    , (:<|>)    <$> genGetD <*> genGetD+    , LookAhead <$> genGetD+    , Skip      <$> choose (0, 10)+    ]++instance Arbitrary GetD where+  arbitrary = genGetD++instance Arbitrary (Get ()) where+  arbitrary = buildGet <$> genGetD++newtype R a =+  R { unR :: Either String a }+  deriving Show+++-- Ignore equality of error message string+instance Eq a => Eq (R a) where+  (==)  =  (==) `on` either (const Nothing) Just . unR++data Chunks = Chunks [[Word8]] deriving (Eq, Show)++mkChunks :: Word -> Chunks+mkChunks n = Chunks . take (fromIntegral n) $ cycle [ [x] | x <- [0 .. 255] ]++instance Arbitrary Chunks where+  arbitrary = mkChunks <$> choose (0, 512)+++testLength :: Word+testLength = 255++-- Equality between strict and lazy parsing+eqStrictLazy :: GetD -> Property+eqStrictLazy getD =+  conjoin+  [ counterexample (show in0) $ R (runGet parser sb) == R (runGetLazy parser lb)+  | n <- [0 .. testLength]+  , let Chunks in0 = mkChunks n+        lb = LB.fromChunks [ BS.pack c | c <- in0 ]+        sb = BS.pack $ concat in0+  ]+  where+    parser = buildGet getD++-- Remaining length equality between strict and lazy parsing+remainingStrictLazy :: GetD -> Property+remainingStrictLazy getD =+  conjoin+  [ counterexample (show in0) $ R (runGet parser sb) == R (runGetLazy parser lb)+  | n <- [0 .. testLength]+  , let Chunks in0 = mkChunks n+        lb = LB.fromChunks [ BS.pack c | c <- in0 ]+        sb = BS.pack $ concat in0+  ]+  where+    parser = buildGet getD *> remaining++isEmpty2 :: Get Bool+isEmpty2 = do+  lookAhead getWord8 *> pure False+  <|>+  pure True++-- Compare with chunks+(==~) :: Eq a => Get a -> Get a -> Property+p1 ==~ p2 =+  conjoin+  [ counterexample (show in0) $ R (runGetLazy p1 s) == R (runGetLazy p2 s)+  | n <- [0 .. testLength]+  , let Chunks in0 = mkChunks n+        s = LB.fromChunks [ BS.pack c | c <- in0 ]+  ]++(==!) :: Eq a => Get a -> Get a -> Property+p1 ==! p2 =+  conjoin+  [ counterexample (show s) $ R (runGet p1 s) == R (runGet p2 s)+  | n <- [0 .. testLength]+  , let Chunks in0 = mkChunks n+        s = BS.pack $ concat in0+  ]++infix 2 ==~, ==!++-- Equality between two eof definition - lazy+eqEof :: GetD -> Property+eqEof getD =+    x *> isEmpty ==~ x *> isEmpty2+  where+    x = buildGet getD++-- Equality between two eof definition - strict+eqEof' :: GetD -> Property+eqEof' getD =+    x *> isEmpty ==! x *> isEmpty2+  where+    x = buildGet getD+++monadIdL :: GetD -> Property+monadIdL getD =+    (return () >>= const x) ==~ x+  where+    x = buildGet getD++monadIdL' :: GetD -> Property+monadIdL' getD =+    (return () >>= const x) ==! x+  where+    x = buildGet getD++monadIdR :: GetD -> Property+monadIdR getD =+    (x >>= return) ==~ x+  where+    x = buildGet getD++monadIdR' :: GetD -> Property+monadIdR' getD =+    (x >>= return) ==! x+  where+    x = buildGet getD++monadAssoc :: GetD -> GetD -> GetD -> Property+monadAssoc p1 p2 p3 =+    (x >> (y >> z)) ==~ (x >> y >> z)+  where+    x = buildGet p1+    y = buildGet p2+    z = buildGet p3++monadAssoc' :: GetD -> GetD -> GetD -> Property+monadAssoc' p1 p2 p3 =+    (x >> (y >> z)) ==! (x >> y >> z)+  where+    x = buildGet p1+    y = buildGet p2+    z = buildGet p3++alterIdL :: GetD -> Property+alterIdL getD =+    empty <|> x ==~ x+  where+    x = buildGet getD++alterIdL' :: GetD -> Property+alterIdL' getD =+    empty <|> x ==! x+  where+    x = buildGet getD++alterIdR :: GetD -> Property+alterIdR getD =+    x <|> empty ==~ x+  where+    x = buildGet getD++alterIdR' :: GetD -> Property+alterIdR' getD =+    x <|> empty ==! x+  where+    x = buildGet getD++alterAssoc :: GetD -> GetD -> GetD -> Property+alterAssoc p1 p2 p3 =+    x <|> y <|> z ==~ x <|> (y <|> z)+  where+    x = buildGet p1+    y = buildGet p2+    z = buildGet p3++alterAssoc' :: GetD -> GetD -> GetD -> Property+alterAssoc' p1 p2 p3 =+    x <|> y <|> z ==! x <|> (y <|> z)+  where+    x = buildGet p1+    y = buildGet p2+    z = buildGet p3++alterDistr :: GetD -> GetD -> GetD -> Property+alterDistr p1 p2 p3 =+    x *> (y <|> z) ==~ x *> y <|> x *> z+  where+    x = buildGet p1+    y = buildGet p2+    z = buildGet p3++alterDistr' :: GetD -> GetD -> GetD -> Property+alterDistr' p1 p2 p3 =+    x *> (y <|> z) ==! x *> y <|> x *> z+  where+    x = buildGet p1+    y = buildGet p2+    z = buildGet p3+++tests :: Test+tests  = testGroup "GetTests"+  [ testProperty "lazy   - monad left id"          monadIdL+  , testProperty "strict - monad left id"          monadIdL'+  , testProperty "lazy   - monad right id"         monadIdR+  , testProperty "strict - monad right id"         monadIdR'+  , testProperty "lazy   - monad assoc"            monadAssoc+  , testProperty "strict - monad assoc"            monadAssoc'+  , testProperty "strict lazy - equality"          eqStrictLazy+  , testProperty "strict lazy - remaining equality"remainingStrictLazy+  , testProperty "lazy   - two eof"                eqEof+  , testProperty "strict - two eof"                eqEof'+  , testProperty "lazy   - alternative left Id"    alterIdL+  , testProperty "strict - alternative left Id"    alterIdL'+  , testProperty "lazy   - alternative right Id"   alterIdR+  , testProperty "strict - alternative right Id"   alterIdR'+  , testProperty "lazy   - alternative assoc"      alterAssoc+  , testProperty "strict - alternative assoc"      alterAssoc'+  , testProperty "lazy   - alternative distr"      alterDistr+  , testProperty "strict - alternative distr"      alterDistr'+  ]

@@ -0,0 +1,13 @@+module Main where++import qualified GetTests+import qualified RoundTrip++import Test.Framework.Runners.Console+++main :: IO ()+main  = defaultMain+  [ GetTests.tests+  , RoundTrip.tests+  ]

@@ -1,23 +0,0 @@-GHC	= ghc -O2 -fforce-recomp -i../src--all: bench qc--bench:: Benchmark.hs MemBench.hs CBenchmark.o-	$(GHC) -fliberate-case-threshold=1000 --make Benchmark.hs CBenchmark.o -o $@-	./$@ 100--bench-prof: Benchmark.hs MemBench.hs CBenchmark.o-	$(GHC) -prof -auto-all -rtsopts --make Benchmark.hs CBenchmark.o -o $@-	./$@ 100 +RTS -p--CBenchmark.o: CBenchmark.c-	gcc -O3 -c $< -o $@--qc: Tests.hs-	$(GHC) --make $< -o $@-	./$@--clean:-	$(RM) *.o *.hi bench qc--.PHONY: clean bench bench-nb

@@ -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)

@@ -0,0 +1,63 @@+{-# LANGUAGE ExistentialQuantification #-}++--------------------------------------------------------------------------------+-- |+-- Module      : +-- Copyright   : (c) Galois, Inc, 2009+-- License     : AllRightsReserved+--+-- Maintainer  : Trevor Elliott <trevor@galois.com>+-- Stability   : +-- Portability : +--+module RoundTrip where++import Data.Serialize+import Data.Serialize.Get+import Data.Serialize.Put+import Data.Serialize.IEEE754+import Data.Word (Word8,Word16,Word32,Word64)+import System.Exit (ExitCode(..), exitSuccess, exitWith)+import Test.QuickCheck as QC++import Test.Framework (Test(),testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+++roundTrip :: Eq a => Putter a -> Get a -> a -> Bool+roundTrip p g a = res == Right a+  where res = runGet g (runPut (p a))++-- | Did a call to 'quickCheckResult' succeed?+isSuccess :: QC.Result -> Bool+isSuccess (Success _ _ _) = True+isSuccess _ = False++tests :: Test+tests  = testGroup "Round Trip"+  [ testProperty "Word8        Round Trip" $ roundTrip putWord8      getWord8+  , testProperty "Word16be     Round Trip" $ roundTrip putWord16be   getWord16be+  , testProperty "Word16le     Round Trip" $ roundTrip putWord16le   getWord16le+  , testProperty "Word32be     Round Trip" $ roundTrip putWord32be   getWord32be+  , testProperty "Word32le     Round Trip" $ roundTrip putWord32le   getWord32le+  , testProperty "Word64be     Round Trip" $ roundTrip putWord64be   getWord64be+  , testProperty "Word64le     Round Trip" $ roundTrip putWord64le   getWord64le+  , testProperty "Word16host   Round Trip" $ roundTrip putWord16host getWord16host+  , testProperty "Word32host   Round Trip" $ roundTrip putWord32host getWord32host+  , testProperty "Word64host   Round Trip" $ roundTrip putWord64host getWord64host+  , testProperty "Float32le    Round Trip" $ roundTrip putFloat32le  getFloat32le+  , testProperty "Float32be    Round Trip" $ roundTrip putFloat32be  getFloat32be+  , testProperty "Float64le    Round Trip" $ roundTrip putFloat64le  getFloat64le+  , testProperty "Float64be    Round Trip" $ roundTrip putFloat64be  getFloat64be++    -- Containers+  , testProperty "(Word8,Word8) Round Trip"+    $ roundTrip (putTwoOf putWord8 putWord8) (getTwoOf getWord8 getWord8)+  , testProperty "[Word8] Round Trip"+    $ roundTrip (putListOf putWord8) (getListOf getWord8)+  , testProperty "Maybe Word8 Round Trip"+    $ roundTrip (putMaybeOf putWord8) (getMaybeOf getWord8)+  , testProperty "Either Word8 Word16be Round Trip "+    $ roundTrip (putEitherOf putWord8 putWord16be)+                (getEitherOf getWord8 getWord16be)+  ]

@@ -1,53 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}------------------------------------------------------------------------------------- |--- Module      : --- Copyright   : (c) Galois, Inc, 2009--- License     : AllRightsReserved------ Maintainer  : Trevor Elliott <trevor@galois.com>--- Stability   : --- Portability : -----import Data.Serialize-import Data.Serialize.Get-import Data.Serialize.Put-import Data.Serialize.IEEE754-import Data.Word (Word8,Word16,Word32,Word64)-import Test.QuickCheck as QC---roundTrip :: Eq a => Putter a -> Get a -> a -> Bool-roundTrip p g a = res == Right a-  where res = runGet g (runPut (p a))--main :: IO ()-main  = mapM_ quickCheck-  [ QC.label "Word8         Round Trip" $ roundTrip putWord8      getWord8-  , QC.label "Word16be      Round Trip" $ roundTrip putWord16be   getWord16be-  , QC.label "Word16le      Round Trip" $ roundTrip putWord16le   getWord16le-  , QC.label "Word32be      Round Trip" $ roundTrip putWord32be   getWord32be-  , QC.label "Word32le      Round Trip" $ roundTrip putWord32le   getWord32le-  , QC.label "Word64be      Round Trip" $ roundTrip putWord64be   getWord64be-  , QC.label "Word64le      Round Trip" $ roundTrip putWord64le   getWord64le-  , QC.label "Word16host    Round Trip" $ roundTrip putWord16host getWord16host-  , QC.label "Word32host    Round Trip" $ roundTrip putWord32host getWord32host-  , QC.label "Word64host    Round Trip" $ roundTrip putWord64host getWord64host-  , QC.label "Float32le     Round Trip" $ roundTrip putFloat32le  getFloat32le-  , QC.label "Float32be     Round Trip" $ roundTrip putFloat32be  getFloat32be-  , QC.label "Float64le     Round Trip" $ roundTrip putFloat64le  getFloat64le-  , QC.label "Float64be     Round Trip" $ roundTrip putFloat64be  getFloat64be--    -- Containers-  , QC.label "(Word8,Word8) Round Trip"-    $ roundTrip (putTwoOf putWord8 putWord8) (getTwoOf getWord8 getWord8)-  , QC.label "[Word8] Round Trip"-    $ roundTrip (putListOf putWord8) (getListOf getWord8)-  , QC.label "Maybe Word8 Round Trip"-    $ roundTrip (putMaybeOf putWord8) (getMaybeOf getWord8)-  , QC.label "Either Word8 Word16be Round Trip "-    $ roundTrip (putEitherOf putWord8 putWord16be)-                (getEitherOf getWord8 getWord16be)-  ]