diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/cereal.cabal b/cereal.cabal --- a/cereal.cabal +++ b/cereal.cabal @@ -1,61 +1,78 @@ name: cereal -version: 0.3.5.2 +version: 0.5.8.3 license: BSD3 license-file: LICENSE author: Lennart Kolmodin , Galois Inc., Lemmih , Bas van Dijk -maintainer: Trevor Elliott +maintainer: Eric Mertens 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 diff --git a/src/Data/Serialize.hs b/src/Data/Serialize.hs --- a/src/Data/Serialize.hs +++ b/src/Data/Serialize.hs @@ -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 -- 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 diff --git a/src/Data/Serialize/Builder.hs b/src/Data/Serialize/Builder.hs deleted file mode 100644 --- a/src/Data/Serialize/Builder.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Serialize/Get.hs b/src/Data/Serialize/Get.hs --- a/src/Data/Serialize/Get.hs +++ b/src/Data/Serialize/Get.hs @@ -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 --- | 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) diff --git a/src/Data/Serialize/IEEE754.hs b/src/Data/Serialize/IEEE754.hs --- a/src/Data/Serialize/IEEE754.hs +++ b/src/Data/Serialize/IEEE754.hs @@ -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 +-- 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) diff --git a/src/Data/Serialize/Put.hs b/src/Data/Serialize/Put.hs --- a/src/Data/Serialize/Put.hs +++ b/src/Data/Serialize/Put.hs @@ -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 -- 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 diff --git a/tests/Benchmark.hs b/tests/Benchmark.hs deleted file mode 100644 --- a/tests/Benchmark.hs +++ /dev/null @@ -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) diff --git a/tests/CBenchmark.c b/tests/CBenchmark.c deleted file mode 100644 --- a/tests/CBenchmark.c +++ /dev/null @@ -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; -} diff --git a/tests/CBenchmark.h b/tests/CBenchmark.h deleted file mode 100644 --- a/tests/CBenchmark.h +++ /dev/null @@ -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); diff --git a/tests/GetTests.hs b/tests/GetTests.hs new file mode 100644 --- /dev/null +++ b/tests/GetTests.hs @@ -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' + ] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 + ] diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 --- a/tests/Makefile +++ /dev/null @@ -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 diff --git a/tests/MemBench.hs b/tests/MemBench.hs deleted file mode 100644 --- a/tests/MemBench.hs +++ /dev/null @@ -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) diff --git a/tests/RoundTrip.hs b/tests/RoundTrip.hs new file mode 100644 --- /dev/null +++ b/tests/RoundTrip.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : +-- Copyright : (c) Galois, Inc, 2009 +-- License : BSD3 +-- +-- Maintainer : Trevor Elliott +-- 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) + ] diff --git a/tests/Tests.hs b/tests/Tests.hs deleted file mode 100644 --- a/tests/Tests.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} - --------------------------------------------------------------------------------- --- | --- Module : --- Copyright : (c) Galois, Inc, 2009 --- License : AllRightsReserved --- --- Maintainer : Trevor Elliott --- 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) - ]