cereal 0.3.5.2 → 0.5.8.3
raw patch · 16 files changed
Files
- CHANGELOG.md +53/−0
- cereal.cabal +48/−31
- src/Data/Serialize.hs +211/−61
- src/Data/Serialize/Builder.hs +0/−429
- src/Data/Serialize/Get.hs +346/−145
- src/Data/Serialize/IEEE754.hs +26/−25
- src/Data/Serialize/Put.hs +212/−40
- 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
+ CHANGELOG.md view
@@ -0,0 +1,53 @@+0.5.8.3+=======+* GHC 9.4.1 compatibility++0.5.8.1+=======+* GHC 8.8.1 compatibility++0.5.8.0+=======+* Added ShortByteString instances++0.5.7.0+=======+* Added `runPutMBuilder`++0.5.6.0+=======+* Added GSerializeGet and GSerializePut instances for V1++0.5.5.0+=======+* Added Semigroup instances++0.5.4.0+=======++* Allow building with older versions of GHC (thanks to Ryan Scott!)+* Additional putters for ints (thanks to Andrew Martin!)++0.5.2.0+======++* Implement the AMP recommended refactoring for the Functor/Applicative/Monad+ hierarchy for Get and PutM (thanks to Herbert Valerio Riedel!)+* Unconditionally support GHC generics (thanks to Eric Mertens!)+* Split the GSerialize class in two, to deal with a GHC bug (thanks Austin Seipp!)+* No longer use Enum in the Serialize instance for Bool (thanks Francesco Mazzoli!)++0.5.1.0+=======++* Re-enable GHC.Generics support which was accidentally removed in 0.5.0.0++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.
cereal.cabal view
@@ -1,61 +1,78 @@ name: cereal-version: 0.3.5.2+version: 0.5.8.3 license: BSD3 license-file: LICENSE author: Lennart Kolmodin <kolmodin@dtek.chalmers.se>, Galois Inc., Lemmih <lemmih@gmail.com>, Bas van Dijk <v.dijk.bas@gmail.com>-maintainer: Trevor Elliott <trevor@galois.com>+maintainer: Eric Mertens <emertens@galois.com> 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+tested-with: GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2+ description: A binary serialization library, similar to binary, that introduces an isolate- primitive for parser isolation, and replaces the asynchronous errors with a- user-handleable Either type. Similar to binary in performance, but uses a- strict ByteString instead of a lazy ByteString, thus restricting it to- operating on finite inputs.+ 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+flag bytestring-builder+ description:+ Decides whether to use an older version of bytestring along with bytestring-builder or just a newer version of bytestring.+ .+ This flag normally toggles automatically but you can use `-fbytestring-builder` or `-f-bytestring-builder` to explicitly change it.+ default: False+ manual: False 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: base >= 4.4 && < 5, containers, array,+ ghc-prim >= 0.2 + if !impl(ghc >= 8.0)+ build-depends: fail == 4.9.*++ if flag(bytestring-builder)+ build-depends: bytestring >= 0.9 && < 0.10.4,+ bytestring-builder >= 0.10.4 && < 1+ else+ build-depends: bytestring >= 0.10.4 && < 1+ 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-options: -Wall -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 >= 0.9,+ QuickCheck,+ test-framework,+ test-framework-quickcheck2,+ cereal++ main-is: Main.hs+ other-modules: RoundTrip+ GetTests++ hs-source-dirs: tests
src/Data/Serialize.hs view
@@ -1,14 +1,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-}--#ifdef GENERICS {-# LANGUAGE DefaultSignatures , TypeOperators , BangPatterns , KindSignatures- , ScopedTypeVariables- #-}+ , ScopedTypeVariables #-}++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1 #endif -----------------------------------------------------------------------------@@ -16,7 +16,7 @@ -- Module : Data.Serialize -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE)--- +-- -- Maintainer : Trevor Elliott <trevor@galois.com> -- Stability : -- Portability :@@ -34,9 +34,14 @@ , encode, encodeLazy , decode, decodeLazy + , expect , module Data.Serialize.Get , module Data.Serialize.Put , module Data.Serialize.IEEE754++ -- * Generic deriving+ , GSerializePut(..)+ , GSerializeGet(..) ) where import Data.Serialize.Put@@ -52,21 +57,28 @@ import Foreign -- And needed for the instances:-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import qualified Data.Ratio as R-import qualified Data.Tree as T-import qualified Data.Sequence as Seq+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as S+import qualified Data.Map as Map+import qualified Data.Monoid as M+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Ratio as R+import qualified Data.Tree as T+import qualified Data.Sequence as Seq -#ifdef GENERICS import GHC.Generics++#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((*>),(<*>),(<$>),pure) #endif +#if MIN_VERSION_base(4,8,0)+import Numeric.Natural+#endif+ ------------------------------------------------------------------------ @@ -83,13 +95,11 @@ -- | Decode a value in the Get monad get :: Get t -#ifdef GENERICS- default put :: (Generic t, GSerialize (Rep t)) => Putter t+ default put :: (Generic t, GSerializePut (Rep t)) => Putter t put = gPut . from - default get :: (Generic t, GSerialize (Rep t)) => Get t+ default get :: (Generic t, GSerializeGet (Rep t)) => Get t get = to <$> gGet-#endif ------------------------------------------------------------------------ -- Wrappers to run the underlying monad@@ -112,7 +122,17 @@ decodeLazy :: Serialize a => L.ByteString -> Either String a decodeLazy = runGetLazy get + ------------------------------------------------------------------------+-- Combinators++-- | Perform an action, failing if the read result does not match the argument+-- provided.+expect :: (Eq a, Serialize a) => a -> Get a+expect x = get >>= \y -> if x == y then return x else mzero+++------------------------------------------------------------------------ -- Simple instances -- The () type need never be written to disk: values of singleton type@@ -121,15 +141,39 @@ put () = return () get = return () +{-# INLINE boolToWord8 #-}+boolToWord8 :: Bool -> Word8+boolToWord8 False = 0+boolToWord8 True = 1++{-# INLINE boolFromWord8 #-}+boolFromWord8 :: Word8 -> Get Bool+boolFromWord8 0 = return False+boolFromWord8 1 = return True+boolFromWord8 w = fail ("Invalid Bool encoding " ++ show w)++{-# INLINE orderingToWord8 #-}+orderingToWord8 :: Ordering -> Word8+orderingToWord8 LT = 0+orderingToWord8 EQ = 1+orderingToWord8 GT = 2++{-# INLINE orderingFromWord8 #-}+orderingFromWord8 :: Word8 -> Get Ordering+orderingFromWord8 0 = return LT+orderingFromWord8 1 = return EQ+orderingFromWord8 2 = return GT+orderingFromWord8 w = fail ("Invalid Ordering encoding " ++ show w)+ -- Bools are encoded as a byte in the range 0 .. 1 instance Serialize Bool where- put = putWord8 . fromIntegral . fromEnum- get = liftM (toEnum . fromIntegral) getWord8+ put = putWord8 . boolToWord8+ get = boolFromWord8 =<< getWord8 -- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 instance Serialize Ordering where- put = putWord8 . fromIntegral . fromEnum- get = liftM (toEnum . fromIntegral) getWord8+ put = putWord8 . orderingToWord8+ get = orderingFromWord8 =<< getWord8 ------------------------------------------------------------------------ -- Words and Ints@@ -156,23 +200,23 @@ -- Int8s are written as a single byte. instance Serialize Int8 where- put i = put (fromIntegral i :: Word8)- get = liftM fromIntegral (get :: Get Word8)+ put = putInt8+ get = getInt8 -- Int16s are written as a 2 bytes in big endian format instance Serialize Int16 where- put i = put (fromIntegral i :: Word16)- get = liftM fromIntegral (get :: Get Word16)+ put = putInt16be+ get = getInt16be -- Int32s are written as a 4 bytes in big endian format instance Serialize Int32 where- put i = put (fromIntegral i :: Word32)- get = liftM fromIntegral (get :: Get Word32)+ put = putInt32be+ get = getInt32be -- Int64s are written as a 8 bytes in big endian format instance Serialize Int64 where- put i = put (fromIntegral i :: Word64)- get = liftM fromIntegral (get :: Get Word64)+ put = putInt64be+ get = getInt64be ------------------------------------------------------------------------ @@ -187,7 +231,7 @@ get = liftM fromIntegral (get :: Get Int64) --------------------------------------------------------------------------- +-- -- Portable, and pretty efficient, serialisation of Integer -- @@ -211,7 +255,9 @@ put n = do putWord8 1 put sign- put (unroll (abs n)) -- unroll the bytes+ let len = ((nrBits (abs n) + 7) `div` 8)+ putWord64be (fromIntegral len)+ mapM_ put (unroll (abs n)) -- unroll the bytes where sign = fromIntegral (signum n) :: Word8 @@ -227,23 +273,69 @@ -- -- Fold and unfold an Integer to and from a list of its bytes ---unroll :: Integer -> [Word8]+unroll :: (Integral 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, Bits a) => [Word8] -> a roll = foldr unstep 0 where unstep b a = a `shiftL` 8 .|. fromIntegral b +nrBits :: (Ord a, Integral a) => a -> Int+nrBits k =+ let expMax = until (\e -> 2 ^ e > k) (* 2) 1+ findNr :: Int -> Int -> Int+ findNr lo hi+ | mid == lo = hi+ | 2 ^ mid <= k = findNr mid hi+ | otherwise = findNr lo mid+ where mid = (lo + hi) `div` 2+ in findNr (expMax `div` 2) expMax+ instance (Serialize a,Integral a) => Serialize (R.Ratio a) where 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+ let len = ((nrBits (abs n) + 7) `div` 8)+ putWord64be (fromIntegral len)+ mapM_ 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.+-- `chr` source: http://hackage.haskell.org/package/base-4.7.0.2/docs/src/GHC-Char.html#chr+chrEither :: Int -> Either String Char+chrEither i+ | i <= 0x10FFFF = Right (chr i) -- Or: C# (chr# i#)+ | otherwise =+ Left ("bad argument: " ++ show i)+ -- Char is serialised as UTF-8 instance Serialize Char where put a | c <= 0x7f = put (fromIntegral c :: Word8)@@ -285,7 +377,11 @@ z <- liftM (xor 0x80) getByte return (z .|. shiftL6 (y .|. shiftL6 (x .|. shiftL6 (xor 0xf0 w))))- return $! chr r+ case chrEither r of+ Right r' ->+ return $! r'+ Left err ->+ fail err ------------------------------------------------------------------------ -- Instances for the first few tuples@@ -308,7 +404,7 @@ put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e get = liftM5 (,,,,) get get get get get --- +-- -- and now just recurse: -- @@ -346,6 +442,37 @@ return (a,b,c,d,e,f,g,h,i,j) ------------------------------------------------------------------------+-- Monoid newtype wrappers++instance Serialize a => Serialize (M.Dual a) where+ put = put . M.getDual+ get = fmap M.Dual get++instance Serialize M.All where+ put = put . M.getAll+ get = fmap M.All get++instance Serialize M.Any where+ put = put . M.getAny+ get = fmap M.Any get++instance Serialize a => Serialize (M.Sum a) where+ put = put . M.getSum+ get = fmap M.Sum get++instance Serialize a => Serialize (M.Product a) where+ put = put . M.getProduct+ get = fmap M.Product get++instance Serialize a => Serialize (M.First a) where+ put = put . M.getFirst+ get = fmap M.First get++instance Serialize a => Serialize (M.Last a) where+ put = put . M.getLast+ get = fmap M.Last get++------------------------------------------------------------------------ -- Container types instance Serialize a => Serialize [a] where@@ -373,7 +500,12 @@ putLazyByteString bs get = get >>= getLazyByteString +instance Serialize S.ShortByteString where+ put sbs = do put (S.length sbs)+ putShortByteString sbs+ get = get >>= getShortByteString + ------------------------------------------------------------------------ -- Maps and Sets @@ -404,12 +536,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@@ -433,39 +565,58 @@ put = putIArrayOf put put get = getIArrayOf get get -#ifdef GENERICS ------------------------------------------------------------------------ -- Generic Serialze -class GSerialize f where+class GSerializePut f where gPut :: Putter (f a)++class GSerializeGet f where gGet :: Get (f a) -instance GSerialize a => GSerialize (M1 i c a) where+instance GSerializePut a => GSerializePut (M1 i c a) where gPut = gPut . unM1- gGet = M1 <$> gGet {-# INLINE gPut #-}++instance GSerializeGet a => GSerializeGet (M1 i c a) where+ gGet = M1 <$> gGet {-# INLINE gGet #-} -instance Serialize a => GSerialize (K1 i a) where+instance Serialize a => GSerializePut (K1 i a) where gPut = put . unK1- gGet = K1 <$> get {-# INLINE gPut #-}++instance Serialize a => GSerializeGet (K1 i a) where+ gGet = K1 <$> get {-# INLINE gGet #-} -instance GSerialize U1 where+instance GSerializePut U1 where gPut _ = pure ()+ {-# INLINE gPut #-}++instance GSerializeGet U1 where gGet = pure U1+ {-# INLINE gGet #-}++-- | Always fails to serialize+instance GSerializePut V1 where+ gPut v = v `seq` error "GSerializePut.V1" {-# INLINE gPut #-}++-- | Always fails to deserialize+instance GSerializeGet V1 where+ gGet = fail "GSerializeGet.V1" {-# INLINE gGet #-} -instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where+instance (GSerializePut a, GSerializePut b) => GSerializePut (a :*: b) where gPut (a :*: b) = gPut a *> gPut b- gGet = (:*:) <$> gGet <*> gGet {-# INLINE gPut #-}++instance (GSerializeGet a, GSerializeGet b) => GSerializeGet (a :*: b) where+ gGet = (:*:) <$> gGet <*> gGet {-# INLINE gGet #-} --- The following GSerialize instance for sums has support for serializing types+-- The following GSerialize* instance for sums has support for serializing types -- with up to 2^64-1 constructors. It will use the minimal number of bytes -- needed to encode the constructor. For example when a type has 2^8 -- constructors or less it will use a single byte to encode the constructor. If@@ -475,20 +626,20 @@ #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) -instance ( PutSum a, PutSum b- , GetSum a, GetSum b- , GSerialize a, GSerialize b- , SumSize a, SumSize b) => GSerialize (a :+: b) where+instance ( PutSum a, PutSum b+ , SumSize a, SumSize b) => GSerializePut (a :+: b) where gPut | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) | otherwise = sizeError "encode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64)+ {-# INLINE gPut #-} +instance ( GetSum a, GetSum b+ , SumSize a, SumSize b) => GSerializeGet (a :+: b) where gGet | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) | otherwise = sizeError "decode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64)- {-# INLINE gPut #-} {-# INLINE gGet #-} sizeError :: Show size => String -> size -> error@@ -499,7 +650,7 @@ class PutSum f where putSum :: (Num word, Bits word, Serialize word) => word -> word -> Putter (f a) -instance (PutSum a, PutSum b, GSerialize a, GSerialize b) => PutSum (a :+: b) where+instance (PutSum a, PutSum b) => PutSum (a :+: b) where putSum !code !size s = case s of L1 x -> putSum code sizeL x R1 x -> putSum (code + sizeL) sizeR x@@ -512,7 +663,7 @@ sizeR = size - sizeL {-# INLINE putSum #-} -instance GSerialize a => PutSum (C1 c a) where+instance GSerializePut a => PutSum (C1 c a) where putSum !code _ x = put code *> gPut x {-# INLINE putSum #-} @@ -527,7 +678,7 @@ class GetSum f where getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) -instance (GetSum a, GetSum b, GSerialize a, GSerialize b) => GetSum (a :+: b) where+instance (GetSum a, GetSum b) => GetSum (a :+: b) where getSum !code !size | code < sizeL = L1 <$> getSum code sizeL | otherwise = R1 <$> getSum (code - sizeL) sizeR where@@ -539,7 +690,7 @@ sizeR = size - sizeL {-# INLINE getSum #-} -instance GSerialize a => GetSum (C1 c a) where+instance GSerializeGet a => GetSum (C1 c a) where getSum _ _ = gGet {-# INLINE getSum #-} @@ -556,4 +707,3 @@ instance SumSize (C1 c a) where sumSize = Tagged 1-#endif
− src/Data/Serialize/Builder.hs
@@ -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-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
src/Data/Serialize/Get.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- |@@ -29,8 +30,11 @@ , runGetLazy , runGetState , runGetLazyState++ -- ** Incremental interface , Result(..) , runGetPartial+ , runGetChunk -- * Parsing , ensure@@ -42,6 +46,7 @@ , lookAheadM , lookAheadE , uncheckedLookAhead+ , bytesRead -- * Utility , getBytes@@ -50,20 +55,28 @@ -- * Parsing particular types , getWord8+ , getInt8 -- ** ByteStrings , getByteString , getLazyByteString+ , getShortByteString -- ** Big-endian reads , getWord16be , getWord32be , getWord64be+ , getInt16be+ , getInt32be+ , getInt64be -- ** Little-endian reads , getWord16le , getWord32le , getWord64le+ , getInt16le+ , getInt32le+ , getInt64le -- ** Host-endian, unaligned reads , getWordhost@@ -83,21 +96,25 @@ , 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 qualified Control.Monad.Fail as Fail 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 import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Short as BS import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map@@ -105,14 +122,13 @@ import qualified Data.Set as Set import qualified Data.Tree as T - #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base import GHC.Word #endif -- | The result of a parse.-data Result r = Fail String+data Result r = Fail String B.ByteString -- ^ The parse failed. The 'String' is the -- message describing the error, if any. | Partial (B.ByteString -> Result r)@@ -125,26 +141,35 @@ -- the parse succeeded. instance Show r => Show (Result r) where- show (Fail msg) = "Fail " ++ show msg- show (Partial _) = "Partial _"- show (Done r bs) = "Done " ++ show r ++ " " ++ show bs+ show (Fail msg _) = "Fail " ++ show msg+ show (Partial _) = "Partial _"+ show (Done r bs) = "Done " ++ show r ++ " " ++ show bs instance Functor Result where- fmap _ (Fail msg) = Fail msg- fmap f (Partial k) = Partial (fmap f . k)- fmap f (Done r bs) = Done (f r) bs+ fmap _ (Fail msg rest) = Fail msg rest+ fmap f (Partial k) = Partial (fmap f . k)+ fmap f (Done r bs) = Done (f r) bs -- | The Get monad is an Exception and State monad. newtype Get a = Get { unGet :: forall r. Input -> Buffer -> More- -> Failure r -> Success a r- -> Result r }+ -> Int -> Failure r+ -> Success a r -> Result r } 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@@ -152,7 +177,7 @@ {-# INLINE bufferBytes #-} type Failure r = Input -> Buffer -> More -> [String] -> String -> Result r-type Success a r = Input -> Buffer -> More -> a -> Result r+type Success a r = Input -> Buffer -> More -> Int -> a -> Result r -- | Have we read all available input? data More@@ -166,38 +191,65 @@ 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 w0 kf ks ->+ unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 a -> ks s1 b1 m1 w1 (p a) -instance Applicative Get where- pure = return- (<*>) = ap+instance A.Applicative Get where+ pure a = Get $ \ s0 b0 m0 w _ ks -> ks s0 b0 m0 w a+ {-# INLINE pure #-} -instance Alternative Get where+ f <*> x = Get $ \ s0 b0 m0 w0 kf ks ->+ unGet f s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 g ->+ unGet x s1 b1 m1 w1 kf $ \ s2 b2 m2 w2 y -> ks s2 b2 m2 w2 (g y)+ {-# INLINE (<*>) #-}++ m *> k = Get $ \ s0 b0 m0 w0 kf ks ->+ unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 _ -> unGet k s1 b1 m1 w1 kf ks+ {-# 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+ return = A.pure+ {-# 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 w0 kf ks ->+ unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 a -> unGet (g a) s1 b1 m1 w1 kf ks+ {-# INLINE (>>=) #-} + (>>) = (A.*>)+ {-# INLINE (>>) #-}++#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+ {-# INLINE fail #-}+#endif++instance Fail.MonadFail Get where fail = failDesc+ {-# INLINE fail #-} -instance MonadPlus Get where+instance M.MonadPlus Get where mzero = failDesc "mzero"+ {-# INLINE mzero #-}+-- TODO: Test this! 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+ Get $ \s0 b0 m0 w0 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 w0 kf' ks'+ in unGet a s0 emptyBuffer m0 w0 try ks'+ {-# INLINE mplus #-} + ------------------------------------------------------------------------ formatTrace :: [String] -> String@@ -205,73 +257,93 @@ formatTrace ls = "From:\t" ++ intercalate "\n\t" ls ++ "\n" get :: Get B.ByteString-get = Get (\s0 b0 m0 _ k -> k s0 b0 m0 s0)+get = Get (\s0 b0 m0 w _ k -> k s0 b0 m0 w s0) {-# INLINE get #-} -put :: B.ByteString -> Get ()-put s = Get (\_ b0 m _ k -> k s b0 m ())+put :: B.ByteString -> Int -> Get ()+put s !w = Get (\_ b0 m _ _ k -> k s b0 m w ()) {-# INLINE put #-} label :: String -> Get a -> Get a label l m =- Get $ \ s0 b0 m0 kf ks ->+ Get $ \ s0 b0 m0 w0 kf ks -> let kf' s1 b1 m1 ls = kf s1 b1 m1 (l:ls)- in unGet m s0 b0 m0 kf' ks+ in unGet m s0 b0 m0 w0 kf' ks finalK :: Success a a-finalK s _ _ a = Done a s+finalK s _ _ _ a = Done a s failK :: Failure a-failK _ _ _ ls s = Fail (unlines [s, formatTrace ls])+failK s b _ ls msg =+ Fail (unlines [msg, formatTrace ls]) (s `B.append` bufferBytes b) -- | Run the Get monad applies a 'get'-based parser on the input ByteString runGet :: Get a -> B.ByteString -> Either String a runGet m str =- case unGet m str Nothing Complete failK finalK of- Fail i -> Left i+ case unGet m str Nothing Complete 0 failK finalK of+ Fail i _ -> Left i Done a _ -> Right a 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) 0 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--- ByteString. Additional to the result of get it returns the number of--- consumed bytes and the rest of the input.+-- ByteString, starting at the specified offset. In addition to the result of get+-- it returns the rest of the input. runGetState :: Get a -> B.ByteString -> Int -> Either String (a, B.ByteString)-runGetState m str off =- case unGet m (B.drop off str) Nothing Complete failK finalK of- Fail i -> Left i- Done a bs -> Right (a, bs)- Partial{} -> Left "Failed reading: Internal error: unexpected Partial."+runGetState m str off = case runGetState' m str off of+ (Right a,bs) -> Right (a,bs)+ (Left i,_) -> Left i {-# INLINE runGetState #-} +-- | Run the Get monad applies a 'get'-based parser on the input+-- ByteString, starting at the specified offset. In addition to the result of get+-- it returns the rest of the input, even in the event of a failure.+runGetState' :: Get a -> B.ByteString -> Int+ -> (Either String a, B.ByteString)+runGetState' m str off =+ case unGet m (B.drop off str) Nothing Complete 0 failK finalK of+ Fail i bs -> (Left i,bs)+ Done a bs -> (Right a, bs)+ Partial{} -> (Left "Failed reading: Internal error: unexpected Partial.",B.empty)+{-# INLINE runGetState' #-} ++ -- Lazy Get -------------------------------------------------------------------- runGetLazy' :: Get a -> L.ByteString -> (Either String a,L.ByteString)-runGetLazy' m lstr = loop run (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- remLen c = fromIntegral (L.length lstr) - B.length c- run str = unGet m str Nothing (Incomplete (Just (remLen str))) failK finalK+ len = fromIntegral (L.length lstr) - loop k chunks = case chunks of+ wrapStrict (e,s) = (e,L.fromChunks [s]) - c:cs -> case k c of- Fail str -> (Left str,L.empty)- Partial k' -> loop k' cs- Done r c' -> (Right r,L.fromChunks (c':cs))+ loop result chunks = case result of - [] -> case k B.empty of- Fail str -> (Left str,L.empty)- Partial k' -> (Left "Failed reading: Internal error: unexpected end of input",L.empty)- Done r c' -> (Right r,L.empty)+ Fail str rest -> (Left str, L.fromChunks (rest : chunks))+ Partial k -> case chunks of+ c:cs -> loop (k c) cs+ [] -> loop (k B.empty) [] + Done r rest -> (Right r, L.fromChunks (rest : chunks)) {-# INLINE runGetLazy' #-} -- | Run the Get monad over a Lazy ByteString. Note that this will not run the@@ -292,80 +364,97 @@ -- | If at least @n@ bytes of input are available, return the current -- input, otherwise fail.-ensure :: Int -> Get B.ByteString-ensure n = n `seq` Get $ \ s0 b0 m0 kf ks ->- if B.length s0 >= n- then ks s0 b0 m0 s0- else unGet (demandInput >> ensureRec n) s0 b0 m0 kf ks {-# INLINE ensure #-}+ensure :: Int -> Get B.ByteString+ensure n0 = n0 `seq` Get $ \ s0 b0 m0 w0 kf ks -> let+ n' = n0 - B.length s0+ in if n' <= 0+ then ks s0 b0 m0 w0 s0+ else getMore n' s0 [] b0 m0 w0 kf ks+ where+ -- The "accumulate and concat" pattern here is important not to incur+ -- in quadratic behavior, see <https://github.com/GaloisInc/cereal/issues/48> --- | If at least @n@ bytes of input are available, return the current--- input, otherwise fail.-ensureRec :: Int -> Get B.ByteString-ensureRec n = Get $ \s0 b0 m0 kf ks ->- if B.length s0 >= n- then ks s0 b0 m0 s0- else unGet (demandInput >> ensureRec n) s0 b0 m0 kf ks+ finalInput s0 ss = B.concat (reverse (s0 : ss))+ finalBuffer b0 s0 ss = extendBuffer b0 (B.concat (reverse (init (s0 : ss))))+ getMore !n s0 ss b0 m0 w0 kf ks = let+ tooFewBytes = let+ !s = finalInput s0 ss+ !b = finalBuffer b0 s0 ss+ in kf s b m0 ["demandInput"] "too few bytes"+ in case m0 of+ Complete -> tooFewBytes+ Incomplete mb -> Partial $ \s ->+ if B.null s+ then tooFewBytes+ else let+ !mb' = case mb of+ Just l -> Just $! l - B.length s+ Nothing -> Nothing+ in checkIfEnough n s (s0 : ss) b0 (Incomplete mb') w0 kf ks + checkIfEnough !n s0 ss b0 m0 w0 kf ks = let+ n' = n - B.length s0+ in if n' <= 0+ then let+ !s = finalInput s0 ss+ !b = finalBuffer b0 s0 ss+ in ks s b m0 w0 s+ else getMore n' s0 ss b0 m0 w0 kf ks+ -- | Isolate an action to operating within a fixed block of bytes. The action -- 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'+ cur <- bytesRead+ put s' cur a <- m used <- get unless (B.null used) (fail "not all bytes parsed in isolate")- put rest+ put rest (cur + n) return a --- | Immediately demand more input via a 'Partial' continuation--- result.-demandInput :: Get ()-demandInput = Get $ \s0 b0 m0 kf ks ->- case m0 of- Complete -> kf s0 b0 m0 ["demandInput"] "too few bytes"- 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)) ()- failDesc :: String -> Get a failDesc err = do let msg = "Failed reading: " ++ err- Get (\s0 b0 m0 kf _ -> kf s0 b0 m0 [] msg)+ Get (\s0 b0 m0 _ kf _ -> kf s0 b0 m0 [] msg) -- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. skip :: Int -> Get () skip n = do s <- ensure n- put (B.drop n s)+ cur <- bytesRead+ put (B.drop n s) (cur + n) --- | Skip ahead @n@ bytes. No error if there isn't enough bytes.+-- | Skip ahead up to @n@ bytes in the current chunk. No error if there aren't+-- enough bytes, or if less than @n@ bytes are skipped. uncheckedSkip :: Int -> Get () uncheckedSkip n = do s <- get- put (B.drop n s)+ cur <- bytesRead+ put (B.drop n s) (cur + n) -- | Run @ga@, but return without consuming its input. -- 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'+lookAhead ga = Get $ \ s0 b0 m0 w0 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 w0 kf' ks' -- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. -- Fails if @gma@ fails. lookAheadM :: Get (Maybe a) -> Get (Maybe a) lookAheadM gma = do s <- get+ pre <- bytesRead ma <- gma- when (isNothing ma) (put s)+ M.when (isNothing ma) (put s pre) return ma -- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'.@@ -373,13 +462,15 @@ lookAheadE :: Get (Either a b) -> Get (Either a b) lookAheadE gea = do s <- get+ pre <- bytesRead ea <- gea case ea of- Left _ -> put s+ Left _ -> put s pre _ -> return () return ea --- | Get the next up to @n@ bytes as a ByteString, without consuming them.+-- | Get the next up to @n@ bytes as a ByteString until end of this chunk,+-- without consuming them. uncheckedLookAhead :: Int -> Get B.ByteString uncheckedLookAhead n = do s <- get@@ -394,14 +485,14 @@ -- WARNING: when run with @runGetPartial@, remaining will only return the number -- of bytes that are remaining in the current input. remaining :: Get Int-remaining = Get (\ s0 b0 m0 _ ks -> ks s0 b0 m0 (B.length s0 + moreLength m0))+remaining = Get (\ s0 b0 m0 w0 _ ks -> ks s0 b0 m0 w0 (B.length s0 + moreLength m0)) -- | Test whether all input has been consumed. -- -- WARNING: when run with @runGetPartial@, isEmpty will only tell you if you're -- at the end of the current chunk. isEmpty :: Get Bool-isEmpty = Get (\ s0 b0 m0 _ ks -> ks s0 b0 m0 (B.null s0 && moreLength m0 == 0))+isEmpty = Get (\ s0 b0 m0 w0 _ ks -> ks s0 b0 m0 w0 (B.null s0 && moreLength m0 == 0)) ------------------------------------------------------------------------ -- Utility with ByteStrings@@ -418,7 +509,12 @@ getLazyByteString n = f `fmap` getByteString (fromIntegral n) where f bs = L.fromChunks [bs] +getShortByteString :: Int -> Get BS.ShortByteString+getShortByteString n = do+ bs <- getBytes n+ return $! BS.toShort bs + ------------------------------------------------------------------------ -- Helpers @@ -430,7 +526,8 @@ let consume = B.unsafeTake n s rest = B.unsafeDrop n s -- (consume,rest) = B.splitAt n s- put rest+ cur <- bytesRead+ put rest (cur + n) return consume {-# INLINE getBytes #-} @@ -446,73 +543,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 @@ -530,7 +711,7 @@ getWord32host :: Get Word32 getWord32host = getPtr (sizeOf (undefined :: Word32)) --- | /O(1)./ Read a Word64 in native host order and host endianess.+-- | /O(1)./ Read a Word64 in native host order and host endianness. getWord64host :: Get Word64 getWord64host = getPtr (sizeOf (undefined :: Word64)) @@ -542,8 +723,13 @@ shiftl_w64 :: Word64 -> Int -> Word64 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#if MIN_VERSION_base(4,16,0)+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftLWord16#` i)+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftLWord32#` i)+#else shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)+#endif #if WORD_SIZE_IN_BITS < 64 shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)@@ -555,8 +741,12 @@ #endif #else+#if MIN_VERSION_base(4,17,0)+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)+#else shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) #endif+#endif #else shiftl_w16 = shiftL@@ -568,7 +758,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)@@ -578,7 +768,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) @@ -590,7 +780,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)@@ -607,23 +797,23 @@ -- | 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)-getMapOf k m = Map.fromDistinctAscList `fmap` getListOf (getTwoOf k m)+getMapOf k m = Map.fromList `fmap` getListOf (getTwoOf k m) -- | Read as a list of pairs of int and element. getIntMapOf :: Get Int -> Get a -> Get (IntMap.IntMap a)-getIntMapOf i m = IntMap.fromDistinctAscList `fmap` getListOf (getTwoOf i m)+getIntMapOf i m = IntMap.fromList `fmap` getListOf (getTwoOf i m) -- | Read as a list of elements. getSetOf :: Ord a => Get a -> Get (Set.Set a)-getSetOf m = Set.fromDistinctAscList `fmap` getListOf m+getSetOf m = Set.fromList `fmap` getListOf m -- | Read as a list of ints. getIntSetOf :: Get Int -> Get IntSet.IntSet-getIntSetOf m = IntSet.fromDistinctAscList `fmap` getListOf m+getIntSetOf m = IntSet.fromList `fmap` getListOf m -- | Read in a Maybe in the following format: -- Word8 (0 for Nothing, anything else for Just)@@ -644,3 +834,14 @@ 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++-- | Get the number of bytes read up to this point+bytesRead :: Get Int+bytesRead = Get (\i b m w _ k -> k i b m w w)
src/Data/Serialize/IEEE754.hs view
@@ -1,8 +1,14 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} +#ifndef MIN_VERSION_base+#define MIN_VERSION_base(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+-- <http://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-float/7002812#7002812> module Data.Serialize.IEEE754 ( @@ -20,14 +26,19 @@ ) where -import Control.Applicative ( (<$>) )-import Control.Monad.ST ( runST, ST )--import Data.Array.ST ( newArray, castSTUArray, readArray, MArray, STUArray ) import Data.Word ( Word32, Word64 ) import Data.Serialize.Get import Data.Serialize.Put+import qualified Data.ByteString.Builder as Builder+import System.IO.Unsafe (unsafeDupablePerformIO)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (peek, poke)+import Foreign.Ptr (castPtr, Ptr) +#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ( (<$>) )+#endif+ -- | Read a Float in little endian IEEE-754 format getFloat32le :: Get Float getFloat32le = wordToFloat <$> getWord32le@@ -46,38 +57,28 @@ -- | Write a Float in little endian IEEE-754 format putFloat32le :: Float -> Put-putFloat32le = putWord32le . floatToWord+putFloat32le = putBuilder . Builder.floatLE -- | Write a Float in big endian IEEE-754 format putFloat32be :: Float -> Put-putFloat32be = putWord32be . floatToWord+putFloat32be = putBuilder . Builder.floatBE -- | Write a Double in little endian IEEE-754 format putFloat64le :: Double -> Put-putFloat64le = putWord64le . doubleToWord+putFloat64le = putBuilder . Builder.doubleLE -- | Write a Double in big endian IEEE-754 format putFloat64be :: Double -> Put-putFloat64be = putWord64be . doubleToWord+putFloat64be = putBuilder . Builder.doubleBE {-# INLINE wordToFloat #-} wordToFloat :: Word32 -> Float-wordToFloat x = runST (cast x)--{-# INLINE floatToWord #-}-floatToWord :: Float -> Word32-floatToWord x = runST (cast x)+wordToFloat w = unsafeDupablePerformIO $ alloca $ \(ptr :: Ptr Word32) -> do+ poke ptr w+ peek (castPtr ptr) {-# INLINE wordToDouble #-} wordToDouble :: Word64 -> Double-wordToDouble x = runST (cast x)--{-# INLINE doubleToWord #-}-doubleToWord :: Double -> Word64-doubleToWord x = runST (cast x)--{-# INLINE cast #-}-cast :: (MArray (STUArray s) a (ST s),- MArray (STUArray s) b (ST s)) =>- a -> ST s b-cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0+wordToDouble w = unsafeDupablePerformIO $ alloca $ \(ptr :: Ptr Word64) -> do+ poke ptr w+ peek (castPtr ptr)
src/Data/Serialize/Put.hs view
@@ -1,9 +1,21 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}++#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 -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE)--- +-- -- Maintainer : Trevor Elliott <trevor@galois.com> -- Stability : -- Portability :@@ -22,6 +34,7 @@ , runPutM , runPutLazy , runPutMLazy+ , runPutMBuilder , putBuilder , execPut @@ -30,24 +43,36 @@ -- * Primitives , putWord8+ , putInt8 , putByteString , putLazyByteString+ , putShortByteString -- * Big-endian primitives , putWord16be , putWord32be , putWord64be+ , putInt16be+ , putInt32be+ , putInt64be -- * Little-endian primitives , putWord16le , putWord32le , putWord64le+ , putInt16le+ , putInt32le+ , putInt64le -- * Host-endian, unaligned writes , putWordhost , putWord16host , putWord32host , putWord64host+ , putInthost+ , putInt16host+ , putInt32host+ , putInt64host -- * Containers , putTwoOf@@ -61,17 +86,25 @@ , putIntSetOf , putMaybeOf , putEitherOf+ , putNested ) where -import Data.Serialize.Builder (Builder, toByteString, toLazyByteString)-import qualified Data.Serialize.Builder as B -import Control.Applicative+import Data.ByteString.Builder (Builder, toLazyByteString)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Extra as B+import qualified Data.ByteString.Short as BS++import qualified Control.Applicative as A import Data.Array.Unboxed-import Data.Monoid-import Data.Foldable (foldMap)+#if MIN_VERSION_base(4,9,0)+import qualified Data.Semigroup as M+#endif+import qualified Data.Monoid as M+import qualified Data.Foldable as F import Data.Word+import Data.Int import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.IntMap as IntMap@@ -81,10 +114,23 @@ 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 +#if !(MIN_VERSION_bytestring(0,10,0))+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.Ptr (plusPtr)+import qualified Data.ByteString.Internal as S+import qualified Data.ByteString.Lazy.Internal as L+#endif+ ------------------------------------------------------------------------ --- XXX Strict in builder only. +-- XXX Strict in builder only. data PairS a = PairS a !Builder sndS :: PairS a -> Builder@@ -103,35 +149,53 @@ {-# INLINE fmap #-} -instance Applicative PutM where- pure = return+instance A.Applicative PutM where+ pure a = Put (PairS a M.mempty) {-# 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 (<*>) #-} + m *> k = Put $+ let PairS _ w = unPut m+ PairS b w' = unPut k+ in PairS b (w `M.mappend` w')+ {-# INLINE (*>) #-} + instance Monad PutM where- return a = Put (PairS a mempty)+ return = pure {-# 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')+ (>>) = (*>) {-# INLINE (>>) #-} +#if MIN_VERSION_base(4,9,0)+instance M.Semigroup (PutM ()) where+ (<>) = (*>)+ {-# INLINE (<>) #-}+#endif++instance Monoid (PutM ()) where+ mempty = pure ()+ {-# INLINE mempty #-}++#if !(MIN_VERSION_base(4,11,0))+ mappend = (*>)+ {-# INLINE mappend #-}+#endif+ tell :: Putter Builder-tell b = Put $ PairS () b+tell b = Put $! PairS () b {-# INLINE tell #-} putBuilder :: Putter Builder@@ -145,12 +209,12 @@ -- | Run the 'Put' monad with a serialiser runPut :: Put -> S.ByteString-runPut = toByteString . sndS . unPut+runPut = lazyToStrictByteString . 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, lazyToStrictByteString (toLazyByteString s)) {-# INLINE runPutM #-} -- | Run the 'Put' monad with a serialiser@@ -163,6 +227,11 @@ runPutMLazy (Put (PairS f s)) = (f, toLazyByteString s) {-# INLINE runPutMLazy #-} +-- | Run the 'Put' monad and get the result and underlying 'Builder'+runPutMBuilder :: PutM a -> (a, Builder)+runPutMBuilder (Put (PairS f s)) = (f, s)+{-# INLINE runPutMBuilder #-}+ ------------------------------------------------------------------------ -- | Pop the ByteString we have constructed so far, if any, yielding a@@ -173,49 +242,57 @@ -- | Efficiently write a byte into the output buffer putWord8 :: Putter Word8-putWord8 = tell . B.singleton+putWord8 = tell . B.word8 {-# INLINE putWord8 #-} +-- | Efficiently write an int into the output buffer+putInt8 :: Putter Int8+putInt8 = tell . B.int8+{-# INLINE putInt8 #-}+ -- | 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 #-} +putShortByteString :: Putter BS.ShortByteString+putShortByteString = tell . B.shortByteString+ -- | 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,35 +304,96 @@ -- 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 #-} +-- | Write a Int16 in big endian format+putInt16be :: Putter Int16+putInt16be = tell . B.int16BE+{-# INLINE putInt16be #-} +-- | Write a Int16 in little endian format+putInt16le :: Putter Int16+putInt16le = tell . B.int16LE+{-# INLINE putInt16le #-}++-- | Write a Int32 in big endian format+putInt32be :: Putter Int32+putInt32be = tell . B.int32BE+{-# INLINE putInt32be #-}++-- | Write a Int32 in little endian format+putInt32le :: Putter Int32+putInt32le = tell . B.int32LE+{-# INLINE putInt32le #-}++-- | Write a Int64 in big endian format+putInt64be :: Putter Int64+putInt64be = tell . B.int64BE+{-# INLINE putInt64be #-}++-- | Write a Int64 in little endian format+putInt64le :: Putter Int64+putInt64le = tell . B.int64LE+{-# INLINE putInt64le #-}++------------------------------------------------------------------------++-- | /O(1)./ Write a single native machine int. The int is+-- written in host order, host endian form, for the machine you're on.+-- On a 64 bit machine the Int is an 8 byte value, on a 32 bit machine,+-- 4 bytes. Values written this way are not portable to+-- different endian or int sized machines, without conversion.+--+putInthost :: Putter Int+putInthost = tell . B.intHost+{-# INLINE putInthost #-}++-- | /O(1)./ Write a Int16 in native host order and host endianness.+-- For portability issues see @putInthost@.+putInt16host :: Putter Int16+putInt16host = tell . B.int16Host+{-# INLINE putInt16host #-}++-- | /O(1)./ Write a Int32 in native host order and host endianness.+-- For portability issues see @putInthost@.+putInt32host :: Putter Int32+putInt32host = tell . B.int32Host+{-# INLINE putInt32host #-}++-- | /O(1)./ Write a Int64 in native host order+-- On a 32 bit machine we write two host order Int32s, in big endian form.+-- For portability issues see @putInthost@.+putInt64host :: Putter Int64+putInt64host = tell . B.int64Host+{-# INLINE putInt64host #-}++ -- Containers ------------------------------------------------------------------ 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 +401,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)@@ -274,18 +414,18 @@ putSeqOf :: Putter a -> Putter (Seq.Seq a) putSeqOf pa = \s -> do- putWord64be (fromIntegral $ Seq.length s) - tell (foldMap (execPut . pa) s)+ putWord64be (fromIntegral $ Seq.length s)+ F.mapM_ pa s {-# INLINE putSeqOf #-} putTreeOf :: Putter a -> Putter (T.Tree a)-putTreeOf pa = +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)+putMapOf :: Putter k -> Putter a -> Putter (Map.Map k a) putMapOf pk pa = putListOf (putTwoOf pk pa) . Map.toAscList {-# INLINE putMapOf #-} @@ -310,3 +450,35 @@ 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++-------------------------------------------------------------------------------+-- pre-bytestring-0.10 compatibility+-------------------------------------------------------------------------------++{-# INLINE lazyToStrictByteString #-}+lazyToStrictByteString :: L.ByteString -> S.ByteString+#if MIN_VERSION_bytestring(0,10,0)+lazyToStrictByteString = L.toStrict+#else+lazyToStrictByteString = packChunks++-- packChunks is taken from the blaze-builder package.++-- | Pack the chunks of a lazy bytestring into a single strict bytestring.+packChunks :: L.ByteString -> S.ByteString+packChunks lbs = S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs)+ where+ copyChunks !L.Empty !_pf = return ()+ copyChunks !(L.Chunk (S.PS fpbuf o l) lbs') !pf = do+ withForeignPtr fpbuf $ \pbuf ->+ copyBytes pf (pbuf `plusPtr` o) l+ copyChunks lbs' (pf `plusPtr` l)+#endif
− tests/Benchmark.hs
@@ -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)
− tests/CBenchmark.c
@@ -1,39 +0,0 @@-#include "CBenchmark.h"--void bytewrite(unsigned char *a, int bytes) {- unsigned char n = 0;- int i = 0;- int iterations = bytes;- while (i < iterations) {- a[i++] = n++;- }-}--unsigned char byteread(unsigned char *a, int bytes) {- unsigned char n = 0;- int i = 0;- int iterations = bytes;- while (i < iterations) {- n += a[i++];- }- return n;-}--void wordwrite(unsigned long *a, int bytes) {- unsigned long n = 0;- int i = 0;- int iterations = bytes / sizeof(unsigned long) ;- while (i < iterations) {- a[i++] = n++;- }-}--unsigned int wordread(unsigned long *a, int bytes) {- unsigned long n = 0;- int i = 0;- int iterations = bytes / sizeof(unsigned long);- while (i < iterations) {- n += a[i++];- }- return n;-}
− tests/CBenchmark.h
@@ -1,4 +0,0 @@-void bytewrite(unsigned char *a, int bytes);-unsigned char byteread(unsigned char *a, int bytes);-void wordwrite(unsigned long *a, int bytes);-unsigned int wordread(unsigned long *a, int bytes);
+ tests/GetTests.hs view
@@ -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'+ ]
+ tests/Main.hs view
@@ -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+ ]
− tests/Makefile
@@ -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
− tests/MemBench.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}-module MemBench (memBench) where--import Foreign-import Foreign.C--import Control.Exception-import System.CPUTime-import Numeric--memBench :: Int -> IO ()-memBench mb = do- let bytes = mb * 2^20- allocaBytes bytes $ \ptr -> do- let bench label test = do- seconds <- time $ test (castPtr ptr) (fromIntegral bytes)- let throughput = fromIntegral mb / seconds- putStrLn $ show mb ++ "MB of " ++ label- ++ " in " ++ showFFloat (Just 3) seconds "s, at: "- ++ showFFloat (Just 1) throughput "MB/s"- bench "setup " c_wordwrite- putStrLn ""- putStrLn "C memory throughput benchmarks:"- bench "bytes written" c_bytewrite- bench "bytes read " c_byteread- bench "words written" c_wordwrite- bench "words read " c_wordread- putStrLn ""- putStrLn "Haskell memory throughput benchmarks:"- bench "bytes written" hs_bytewrite- bench "bytes read " hs_byteread- bench "words written" hs_wordwrite- bench "words read " hs_wordread--hs_bytewrite :: Ptr CUChar -> Int -> IO ()-hs_bytewrite !ptr bytes = loop 0 0- where iterations = bytes- loop :: Int -> CUChar -> IO ()- loop !i !n | i == iterations = return ()- | otherwise = do pokeByteOff ptr i n- loop (i+1) (n+1)--hs_byteread :: Ptr CUChar -> Int -> IO CUChar-hs_byteread !ptr bytes = loop 0 0- where iterations = bytes- loop :: Int -> CUChar -> IO CUChar- loop !i !n | i == iterations = return n- | otherwise = do x <- peekByteOff ptr i- loop (i+1) (n+x)--hs_wordwrite :: Ptr CULong -> Int -> IO ()-hs_wordwrite !ptr bytes = loop 0 0- where iterations = bytes `div` sizeOf (undefined :: CULong)- loop :: Int -> CULong -> IO ()- loop !i !n | i == iterations = return ()- | otherwise = do pokeByteOff ptr i n- loop (i+1) (n+1)--hs_wordread :: Ptr CULong -> Int -> IO CULong-hs_wordread !ptr bytes = loop 0 0- where iterations = bytes `div` sizeOf (undefined :: CULong)- loop :: Int -> CULong -> IO CULong- loop !i !n | i == iterations = return n- | otherwise = do x <- peekByteOff ptr i- loop (i+1) (n+x)---foreign import ccall unsafe "CBenchmark.h byteread"- c_byteread :: Ptr CUChar -> CInt -> IO ()--foreign import ccall unsafe "CBenchmark.h bytewrite"- c_bytewrite :: Ptr CUChar -> CInt -> IO ()--foreign import ccall unsafe "CBenchmark.h wordread"- c_wordread :: Ptr CUInt -> CInt -> IO ()--foreign import ccall unsafe "CBenchmark.h wordwrite"- c_wordwrite :: Ptr CUInt -> CInt -> IO ()--time :: IO a -> IO Double-time action = do- start <- getCPUTime- action- end <- getCPUTime- return $! (fromIntegral (end - start)) / (10^12)
+ tests/RoundTrip.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ExistentialQuantification #-}++--------------------------------------------------------------------------------+-- |+-- Module : +-- Copyright : (c) Galois, Inc, 2009+-- License : BSD3+--+-- 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)+ ]
− tests/Tests.hs
@@ -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)- ]