binary-ext (empty) → 0.8.4.1

raw patch · 12 files changed

+2521/−0 lines, 12 filesdep +Cabaldep +HUnitdep +QuickChecksetup-changed

Dependencies added: Cabal, HUnit, QuickCheck, array, base, binary, bytestring, containers, directory, filepath, ghc-prim, random, test-framework, test-framework-quickcheck2

Files

• LICENSE +30/−0
• README.md +26/−0
• Setup.lhs +3/−0
• binary-ext.cabal +94/−0
• src/Data/Binary/FloatCast.hs +45/−0
• src/Data/Binary/Get/Ext.hs +650/−0
• src/Data/Binary/Get/Ext/Internal.hs +428/−0
• src/Data/Binary/Internal.hs +15/−0
• tests/Action.hs +425/−0
• tests/Arbitrary.hs +23/−0
• tests/File.hs +43/−0
• tests/QC.hs +739/−0

@@ -0,0 +1,30 @@+Copyright (c) Lennart Kolmodin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,26 @@+# binary-ext package #++An alternate with typed errors for ``Data.Binary.Get`` monad from ``binary`` library.++## Building binary-ext ##++Here's how to get the latest version of the repository and build.++    $ git clone https://github.com/A1-Triard/binary-ext.git+    $ cd binary-ext+    $ stack build++Run the test suite.++    $ stack test++## Using binary-ext ##++First:++    import Data.Binary.Put+    import Data.Binary.Get.Ext++and then use the ``Get`` and ``Put`` monads to serialize/deserialize.++More information in the haddock documentation.

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,94 @@+name:            binary-ext+version:         0.8.4.1+license:         BSD3+license-file:    LICENSE+author:          Lennart Kolmodin <kolmodin@gmail.com>+maintainer:      Lennart Kolmodin, Don Stewart <dons00@gmail.com>+homepage:        https://github.com/kolmodin/binary+description:     Efficient, pure binary serialisation using lazy ByteStrings.+                 Haskell values may be encoded to and from binary formats,+                 written to disk as binary, or sent over the network.+                 The format used can be automatically generated, or+                 you can choose to implement a custom format if needed.+                 Serialisation speeds of over 1 G\/sec have been observed,+                 so this library should be suitable for high performance+                 scenarios.+synopsis:        Binary serialisation for Haskell values using lazy ByteStrings+category:        Data, Parsing+stability:       provisional+build-type:      Simple+cabal-version:   >= 1.8+tested-with:     GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3+extra-source-files:+  README.md++source-repository head+  type: git+  location: git://github.com/A1-Triard/binary-ext.git++library+  build-depends:   base >= 4.5.0.0 && < 5, bytestring >= 0.10.2, containers, array, binary+  hs-source-dirs:  src+  exposed-modules: Data.Binary.Get.Ext+                 , Data.Binary.Get.Ext.Internal++  other-modules:   Data.Binary.Internal,+                   Data.Binary.FloatCast+  if impl(ghc <= 7.6)+    -- prior to ghc-7.4 generics lived in ghc-prim+    build-depends: ghc-prim++  ghc-options:     -O2 -Wall -fliberate-case-threshold=1000++  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances++-- Due to circular dependency, we cannot make any of the test-suites+-- depend on the binary library. Instead, for each test-suite,+-- we include the source directory of binary and build-depend on all+-- the dependencies binary has.++test-suite qc+  type:  exitcode-stdio-1.0+  hs-source-dirs: src tests+  main-is: QC.hs+  other-modules: Action+               , Arbitrary+               , Data.Binary.Get.Ext+               , Data.Binary.Get.Ext.Internal+               , Data.Binary.Internal+               , Data.Binary.FloatCast+  build-depends: base >= 4.5.0.0 && < 5+               , binary+               , bytestring >= 0.10.2+               , random>=1.0.1.0+               , test-framework+               , test-framework-quickcheck2 >= 0.3+               , QuickCheck++  -- build dependencies from using binary source rather than depending on the library+  build-depends: array, containers+  ghc-options: -Wall -O2 -threaded+  if impl(ghc <= 7.6)+    -- prior to ghc-7.4 generics lived in ghc-prim+    build-depends: ghc-prim+++test-suite read-write-file+  type:  exitcode-stdio-1.0+  hs-source-dirs: src tests+  main-is: File.hs+  build-depends: base >= 4.5.0.0 && < 5+               , bytestring >= 0.10.2+               , Cabal+               , binary+               , directory+               , filepath+               , HUnit++  -- build dependencies from using binary source rather than depending on the library+  build-depends: array, containers+  ghc-options: -Wall+  if impl(ghc <= 7.6)+    -- prior to ghc-7.4 generics lived in ghc-prim+    build-depends: ghc-prim

@@ -0,0 +1,45 @@++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Trustworthy #-}++-- | This module was written based on+--   <http://hackage.haskell.org/package/reinterpret-cast-0.1.0/docs/src/Data-ReinterpretCast-Internal-ImplArray.html>.+--+--   Implements casting via a 1-elemnt STUArray, as described in+--   <http://stackoverflow.com/a/7002812/263061>.+module Data.Binary.FloatCast+  ( floatToWord+  , wordToFloat+  , doubleToWord+  , wordToDouble+  ) where++import Data.Word (Word32, Word64)+import Data.Array.ST (newArray, readArray, MArray, STUArray)+import Data.Array.Unsafe (castSTUArray)+import GHC.ST (runST, ST)++-- | Reinterpret-casts a `Float` to a `Word32`.+floatToWord :: Float -> Word32+floatToWord x = runST (cast x)+{-# INLINE floatToWord #-}++-- | Reinterpret-casts a `Word32` to a `Float`.+wordToFloat :: Word32 -> Float+wordToFloat x = runST (cast x)+{-# INLINE wordToFloat #-}++-- | Reinterpret-casts a `Double` to a `Word64`.+doubleToWord :: Double -> Word64+doubleToWord x = runST (cast x)+{-# INLINE doubleToWord #-}++-- | Reinterpret-casts a `Word64` to a `Double`.+wordToDouble :: Word64 -> Double+wordToDouble x = runST (cast x)+{-# INLINE wordToDouble #-}++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+{-# INLINE cast #-}

@@ -0,0 +1,650 @@+{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-}+{-# LANGUAGE Trustworthy #-}++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+#include "MachDeps.h"+#endif++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Binary.Get.Ext+-- Copyright   : Lennart Kolmodin+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Lennart Kolmodin <kolmodin@gmail.com>+-- Stability   : experimental+-- Portability : portable to Hugs and GHC.+--+-- The 'Get' monad. A monad for efficiently building structures from+-- encoded lazy ByteStrings.+--+-- Primitives are available to decode words of various sizes, both big and+-- little endian.+--+-- Let's decode binary data representing illustrated here.+-- In this example the values are in little endian.+--+-- > +------------------+--------------+-----------------++-- > | 32 bit timestamp | 32 bit price | 16 bit quantity |+-- > +------------------+--------------+-----------------++--+-- A corresponding Haskell value looks like this:+--+-- @+--data Trade = Trade+--  { timestamp :: !'Word32'+--  , price     :: !'Word32'+--  , qty       :: !'Word16'+--  } deriving ('Show')+-- @+--+-- The fields in @Trade@ are marked as strict (using @!@) since we don't need+-- laziness here. In practise, you would probably consider using the UNPACK+-- pragma as well.+-- <http://www.haskell.org/ghc/docs/latest/html/users_guide/pragmas.html#unpack-pragma>+--+-- Now, let's have a look at a decoder for this format.+--+-- @+--getTrade :: 'Get' Trade+--getTrade = do+--  timestamp <- 'getWord32le'+--  price     <- 'getWord32le'+--  quantity  <- 'getWord16le'+--  return '$!' Trade timestamp price quantity+-- @+--+-- Or even simpler using applicative style:+--+-- @+--getTrade' :: 'Get' Trade+--getTrade' = Trade '<$>' 'getWord32le' '<*>' 'getWord32le' '<*>' 'getWord16le'+-- @+--+-- There are two kinds of ways to execute this decoder, the lazy input+-- method and the incremental input method. Here we will use the lazy+-- input method.+--+-- Let's first define a function that decodes many @Trade@s.+--+-- @+--getTrades :: Get [Trade]+--getTrades = do+--  empty <- 'isEmpty'+--  if empty+--    then return []+--    else do trade <- getTrade+--            trades <- getTrades+--            return (trade:trades)+-- @+--+-- Finally, we run the decoder:+--+-- @+--lazyIOExample :: IO [Trade]+--lazyIOExample = do+--  input <- BL.readFile \"trades.bin\"+--  return ('runGet' getTrades input)+-- @+--+-- This decoder has the downside that it will need to read all the input before+-- it can return. On the other hand, it will not return anything until+-- it knows it could decode without any decoder errors.+--+-- You could also refactor to a left-fold, to decode in a more streaming fashion,+-- and get the following decoder. It will start to return data without knowing+-- that it can decode all input.+--+-- @+--incrementalExample :: BL.ByteString -> [Trade]+--incrementalExample input0 = go decoder input0+--  where+--    decoder = 'runGetIncremental' getTrade+--    go :: 'Decoder' Trade -> BL.ByteString -> [Trade]+--    go ('Done' leftover _consumed trade) input =+--      trade : go decoder (BL.chunk leftover input)+--    go ('Partial' k) input                     =+--      go (k . takeHeadChunk $ input) (dropHeadChunk input)+--    go ('Fail' _leftover _consumed msg) _input =+--      error msg+--+--takeHeadChunk :: BL.ByteString -> Maybe BS.ByteString+--takeHeadChunk lbs =+--  case lbs of+--    (BL.Chunk bs _) -> Just bs+--    _ -> Nothing+--+--dropHeadChunk :: BL.ByteString -> BL.ByteString+--dropHeadChunk lbs =+--  case lbs of+--    (BL.Chunk _ lbs') -> lbs'+--    _ -> BL.Empty+-- @+--+-- The @lazyIOExample@ uses lazy I/O to read the file from the disk, which is+-- not suitable in all applications, and certainly not if you need to read+-- from a socket which has higher likelihood to fail. To address these needs,+-- use the incremental input method like in @incrementalExample@.+-- For an example of how to read incrementally from a Handle,+-- see the implementation of 'decodeFileOrFail' in "Data.Binary".+-----------------------------------------------------------------------------+++module Data.Binary.Get.Ext (++    -- * The Get monad+      Get++    -- * The lazy input interface+    -- $lazyinterface+    , runGetOrFail+    , ByteOffset++    -- * The incremental input interface+    -- $incrementalinterface+    , Decoder(..)+    , runGetIncremental++    -- ** Providing input+    , pushChunk+    , pushChunks+    , pushEndOfInput++    -- * Decoding+    , skip+    , isEmpty+    , bytesRead+    , totalBytesRead+    , isolate+    , lookAhead+    , lookAheadM+    , lookAheadE+    , label+    , onError+    , withError+    , failG++    -- ** ByteStrings+    , getByteString+    , getLazyByteString+    , getLazyByteStringNul+    , getRemainingLazyByteString++    -- ** Decoding Words+    , getWord8++    -- *** Big-endian decoding+    , getWord16be+    , getWord32be+    , getWord64be++    -- *** Little-endian decoding+    , getWord16le+    , getWord32le+    , getWord64le++    -- *** Host-endian, unaligned decoding+    , getWordhost+    , getWord16host+    , getWord32host+    , getWord64host++    -- ** Decoding Ints+    , getInt8++    -- *** Big-endian decoding+    , getInt16be+    , getInt32be+    , getInt64be++    -- *** Little-endian decoding+    , getInt16le+    , getInt32le+    , getInt64le++    -- *** Host-endian, unaligned decoding+    , getInthost+    , getInt16host+    , getInt32host+    , getInt64host++    -- ** Decoding Floats/Doubles+    , getFloatbe+    , getFloatle+    , getFloathost+    , getDoublebe+    , getDoublele+    , getDoublehost++    ) where+#if ! MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import Foreign+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L++import Data.Binary.Get.Ext.Internal hiding ( Decoder(..), runGetIncremental )+import qualified Data.Binary.Get.Ext.Internal as I++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+-- needed for (# unboxing #) with magic hash+import GHC.Base+import GHC.Word+#endif++-- needed for casting words to float/double+import Data.Binary.FloatCast (wordToFloat, wordToDouble)++-- $lazyinterface+-- The lazy interface consumes a single lazy 'L.ByteString'. It's the easiest+-- interface to get started with, but it doesn't support interleaving I\/O and+-- parsing, unless lazy I/O is used.+--+-- There is no way to provide more input other than the initial data. To be+-- able to incrementally give more data, see the incremental input interface.++-- $incrementalinterface+-- The incremental interface gives you more control over how input is+-- provided during parsing. This lets you e.g. interleave parsing and+-- I\/O.+--+-- The incremental interface consumes a strict 'B.ByteString' at a time, each+-- being part of the total amount of input. If your decoder needs more input to+-- finish it will return a 'Partial' with a continuation.+-- If there is no more input, provide it 'Nothing'.+--+-- 'Fail' will be returned if it runs into an error, together with a message,+-- the position and the remaining input.+-- If it succeeds it will return 'Done' with the resulting value,+-- the position and the remaining input.++-- | A decoder procuced by running a 'Get' monad.+data Decoder e a = Fail !B.ByteString {-# UNPACK #-} !ByteOffset (Either String e)+              -- ^ The decoder ran into an error. The decoder either used+              -- 'fail' or was not provided enough input. Contains any+              -- unconsumed input and the number of bytes consumed.+              | Partial (Maybe B.ByteString -> Decoder e a)+              -- ^ The decoder has consumed the available input and needs+              -- more to continue. Provide 'Just' if more input is available+              -- and 'Nothing' otherwise, and you will get a new 'Decoder'.+              | Done !B.ByteString {-# UNPACK #-} !ByteOffset a+              -- ^ The decoder has successfully finished. Except for the+              -- output value you also get any unused input as well as the+              -- number of bytes consumed.++-- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing+-- input, handling decoder errors and to get the output value.+-- Hint: Use the helper functions 'pushChunk', 'pushChunks' and+-- 'pushEndOfInput'.+runGetIncremental :: ByteOffset -> Get e a -> Decoder e a+runGetIncremental base_offset = calculateOffset base_offset . I.runGetIncremental base_offset++calculateOffset :: ByteOffset -> I.Decoder e a -> Decoder e a+calculateOffset base_offset r0 = go r0 0+  where+  go r !acc = case r of+                I.Done inp a -> Done inp (base_offset + (acc - fromIntegral (B.length inp))) a+                I.Fail inp s -> Fail inp (base_offset + (acc - fromIntegral (B.length inp))) s+                I.Partial k ->+                    Partial $ \ms ->+                      case ms of+                        Nothing -> go (k Nothing) acc+                        Just i -> go (k ms) (acc + fromIntegral (B.length i))+                I.BytesRead unused k ->+                    go (k $! (acc - unused)) acc++takeHeadChunk :: L.ByteString -> Maybe B.ByteString+takeHeadChunk lbs =+  case lbs of+    (L.Chunk bs _) -> Just bs+    _ -> Nothing++dropHeadChunk :: L.ByteString -> L.ByteString+dropHeadChunk lbs =+  case lbs of+    (L.Chunk _ lbs') -> lbs'+    _ -> L.Empty++-- | Run a 'Get' monad and return 'Left' on failure and 'Right' on+-- success. In both cases any unconsumed input and the number of bytes+-- consumed is returned. In the case of failure, a human-readable+-- error message is included as well.+runGetOrFail :: ByteOffset -> Get e a -> L.ByteString+             -> Either (L.ByteString, ByteOffset, Either String e) (L.ByteString, ByteOffset, a)+runGetOrFail ge g lbs0 = feedAll (runGetIncremental ge g) lbs0+  where+  feedAll (Done bs pos x) lbs = Right (L.chunk bs lbs, pos, x)+  feedAll (Partial k) lbs = feedAll (k (takeHeadChunk lbs)) (dropHeadChunk lbs)+  feedAll (Fail x pos msg) xs = Left (L.chunk x xs, pos, msg)++-- | An offset, counted in bytes.+type ByteOffset = Int64++-- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it+-- will add the input to 'B.ByteString' of unconsumed input.+--+-- @+--    'runGetIncremental' myParser \`pushChunk\` myInput1 \`pushChunk\` myInput2+-- @+pushChunk :: Decoder e a -> B.ByteString -> Decoder e a+pushChunk r inp =+  case r of+    Done inp0 p a -> Done (inp0 `B.append` inp) p a+    Partial k -> k (Just inp)+    Fail inp0 p s -> Fail (inp0 `B.append` inp) p s+++-- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it+-- will add the input to 'ByteString' of unconsumed input.+--+-- @+--    'runGetIncremental' myParser \`pushChunks\` myLazyByteString+-- @+pushChunks :: Decoder e a -> L.ByteString -> Decoder e a+pushChunks r0 = go r0 . L.toChunks+  where+  go r [] = r+  go (Done inp pos a) xs = Done (B.concat (inp:xs)) pos a+  go (Fail inp pos s) xs = Fail (B.concat (inp:xs)) pos s+  go (Partial k) (x:xs) = go (k (Just x)) xs++-- | Tell a 'Decoder' that there is no more input. This passes 'Nothing' to a+-- 'Partial' decoder, otherwise returns the decoder unchanged.+pushEndOfInput :: Decoder e a -> Decoder e a+pushEndOfInput r =+  case r of+    Done _ _ _ -> r+    Partial k -> k Nothing+    Fail _ _ _ -> r++-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available.+skip :: Int -> Get () ()+skip n = withInputChunks (fromIntegral n) consumeBytes (const ()) failOnEOF++-- | An efficient get method for lazy ByteStrings. Fails if fewer than @n@+-- bytes are left in the input.+getLazyByteString :: Int64 -> Get () L.ByteString+getLazyByteString n0 = withInputChunks n0 consumeBytes L.fromChunks failOnEOF++consumeBytes :: Consume Int64+consumeBytes n str+  | fromIntegral (B.length str) >= n = Right (B.splitAt (fromIntegral n) str)+  | otherwise = Left (n - fromIntegral (B.length str))++consumeUntilNul :: Consume ()+consumeUntilNul _ str =+  case B.break (==0) str of+    (want, rest) | B.null rest -> Left ()+                 | otherwise -> Right (want, B.drop 1 rest)++consumeAll :: Consume ()+consumeAll _ _ = Left ()++resumeOnEOF :: [B.ByteString] -> Get e L.ByteString+resumeOnEOF = return . L.fromChunks++-- | Get a lazy ByteString that is terminated with a NUL byte.+-- The returned string does not contain the NUL byte. Fails+-- if it reaches the end of input without finding a NUL.+getLazyByteStringNul :: Get () L.ByteString+getLazyByteStringNul = withInputChunks () consumeUntilNul L.fromChunks failOnEOF++-- | Get the remaining bytes as a lazy ByteString.+-- Note that this can be an expensive function to use as it forces reading+-- all input and keeping the string in-memory.+getRemainingLazyByteString :: Get e L.ByteString+getRemainingLazyByteString = withInputChunks () consumeAll L.fromChunks resumeOnEOF++------------------------------------------------------------------------+-- Primtives++-- helper, get a raw Ptr onto a strict ByteString copied out of the+-- underlying lazy byteString.++getPtr :: Storable a => Int -> Get () a+getPtr n = readNWith n peek+{-# INLINE getPtr #-}++-- | Read a Word8 from the monad state+getWord8 :: Get () Word8+getWord8 = readN 1 B.unsafeHead+{-# INLINE[2] getWord8 #-}++-- | Read an Int8 from the monad state+getInt8 :: Get () Int8+getInt8 = fromIntegral <$> getWord8+{-# INLINE getInt8 #-}+++-- force GHC to inline getWordXX+{-# RULES+"getWord8/readN" getWord8 = readN 1 B.unsafeHead+"getWord16be/readN" getWord16be = readN 2 word16be+"getWord16le/readN" getWord16le = readN 2 word16le+"getWord32be/readN" getWord32be = readN 4 word32be+"getWord32le/readN" getWord32le = readN 4 word32le+"getWord64be/readN" getWord64be = readN 8 word64be+"getWord64le/readN" getWord64le = readN 8 word64le #-}++-- | Read a Word16 in big endian format+getWord16be :: Get () Word16+getWord16be = readN 2 word16be++word16be :: B.ByteString -> Word16+word16be = \s ->+        (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|.+        (fromIntegral (s `B.unsafeIndex` 1))+{-# INLINE[2] getWord16be #-}+{-# INLINE word16be #-}++-- | Read a Word16 in little endian format+getWord16le :: Get () Word16+getWord16le = readN 2 word16le++word16le :: B.ByteString -> Word16+word16le = \s ->+              (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|.+              (fromIntegral (s `B.unsafeIndex` 0) )+{-# INLINE[2] getWord16le #-}+{-# INLINE word16le #-}++-- | Read a Word32 in big endian format+getWord32be :: Get () Word32+getWord32be = readN 4 word32be++word32be :: B.ByteString -> Word32+word32be = \s ->+              (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) )+{-# INLINE[2] getWord32be #-}+{-# INLINE word32be #-}++-- | Read a Word32 in little endian format+getWord32le :: Get () Word32+getWord32le = readN 4 word32le++word32le :: B.ByteString -> Word32+word32le = \s ->+              (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) )+{-# INLINE[2] getWord32le #-}+{-# INLINE word32le #-}++-- | Read a Word64 in big endian format+getWord64be :: Get () Word64+getWord64be = readN 8 word64be++word64be :: B.ByteString -> Word64+word64be = \s ->+              (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) )+{-# INLINE[2] getWord64be #-}+{-# INLINE word64be #-}++-- | Read a Word64 in little endian format+getWord64le :: Get () Word64+getWord64le = readN 8 word64le++word64le :: B.ByteString -> Word64+word64le = \s ->+              (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[2] getWord64le #-}+{-# INLINE word64le #-}+++-- | Read an Int16 in big endian format.+getInt16be :: Get () Int16+getInt16be = fromIntegral <$> getWord16be+{-# INLINE getInt16be #-}++-- | Read an Int32 in big endian format.+getInt32be :: Get () Int32+getInt32be =  fromIntegral <$> getWord32be+{-# INLINE getInt32be #-}++-- | Read an Int64 in big endian format.+getInt64be :: Get () Int64+getInt64be = fromIntegral <$> getWord64be+{-# INLINE getInt64be #-}+++-- | Read an Int16 in little endian format.+getInt16le :: Get () Int16+getInt16le = fromIntegral <$> getWord16le+{-# INLINE getInt16le #-}++-- | Read an Int32 in little endian format.+getInt32le :: Get () Int32+getInt32le =  fromIntegral <$> getWord32le+{-# INLINE getInt32le #-}++-- | Read an Int64 in little endian format.+getInt64le :: Get () Int64+getInt64le = fromIntegral <$> getWord64le+{-# INLINE getInt64le #-}+++------------------------------------------------------------------------+-- Host-endian reads++-- | /O(1)./ Read a single native machine word. The word is read in+-- host order, host endian form, for the machine you're on. On a 64 bit+-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes.+getWordhost :: Get () Word+getWordhost = getPtr (sizeOf (undefined :: Word))+{-# INLINE getWordhost #-}++-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness.+getWord16host :: Get () Word16+getWord16host = getPtr (sizeOf (undefined :: Word16))+{-# INLINE getWord16host #-}++-- | /O(1)./ Read a Word32 in native host order and host endianness.+getWord32host :: Get () Word32+getWord32host = getPtr  (sizeOf (undefined :: Word32))+{-# INLINE getWord32host #-}++-- | /O(1)./ Read a Word64 in native host order and host endianess.+getWord64host   :: Get () Word64+getWord64host = getPtr  (sizeOf (undefined :: Word64))+{-# INLINE getWord64host #-}++-- | /O(1)./ Read a single native machine word in native host+-- order. It works in the same way as 'getWordhost'.+getInthost :: Get () Int+getInthost = getPtr (sizeOf (undefined :: Int))+{-# INLINE getInthost #-}++-- | /O(1)./ Read a 2 byte Int16 in native host order and host endianness.+getInt16host :: Get () Int16+getInt16host = getPtr (sizeOf (undefined :: Int16))+{-# INLINE getInt16host #-}++-- | /O(1)./ Read an Int32 in native host order and host endianness.+getInt32host :: Get () Int32+getInt32host = getPtr  (sizeOf (undefined :: Int32))+{-# INLINE getInt32host #-}++-- | /O(1)./ Read an Int64 in native host order and host endianess.+getInt64host   :: Get () Int64+getInt64host = getPtr  (sizeOf (undefined :: Int64))+{-# INLINE getInt64host #-}+++------------------------------------------------------------------------+-- Double/Float reads++-- | Read a 'Float' in big endian IEEE-754 format.+getFloatbe :: Get () Float+getFloatbe = wordToFloat <$> getWord32be+{-# INLINE getFloatbe #-}++-- | Read a 'Float' in little endian IEEE-754 format.+getFloatle :: Get () Float+getFloatle = wordToFloat <$> getWord32le+{-# INLINE getFloatle #-}++-- | Read a 'Float' in IEEE-754 format and host endian.+getFloathost :: Get () Float+getFloathost = wordToFloat <$> getWord32host+{-# INLINE getFloathost #-}++-- | Read a 'Double' in big endian IEEE-754 format.+getDoublebe :: Get () Double+getDoublebe = wordToDouble <$> getWord64be+{-# INLINE getDoublebe #-}++-- | Read a 'Double' in little endian IEEE-754 format.+getDoublele :: Get () Double+getDoublele = wordToDouble <$> getWord64le+{-# INLINE getDoublele #-}++-- | Read a 'Double' in IEEE-754 format and host endian.+getDoublehost :: Get () Double+getDoublehost = wordToDouble <$> getWord64host+{-# INLINE getDoublehost #-}++------------------------------------------------------------------------+-- Unchecked shifts++shiftl_w16 :: Word16 -> Int -> Word16+shiftl_w32 :: Word32 -> Int -> Word32+shiftl_w64 :: Word64 -> Int -> Word64++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#`   i)+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#`   i)++#if WORD_SIZE_IN_BITS < 64+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)++#else+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)+#endif++#else+shiftl_w16 = shiftL+shiftl_w32 = shiftL+shiftl_w64 = shiftL+#endif

@@ -0,0 +1,428 @@+{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns, TypeFamilies #-}++-- CPP C style pre-precessing, the #if defined lines+-- RankNTypes forall r. statement+-- MagicHash the (# unboxing #), also needs GHC.primitives++module Data.Binary.Get.Ext.Internal (++    -- * The Get e type+      Get+    , runCont+    , Decoder(..)+    , runGetIncremental++    , readN+    , readNWith++    -- * Parsing+    , bytesRead+    , totalBytesRead+    , isolate++    -- * With input chunks+    , withInputChunks+    , Consume+    , failOnEOF++    , get+    , put+    , ensureN++    -- * Utility+    , isEmpty+    , failG+    , lookAhead+    , lookAheadM+    , lookAheadE+    , label+    , onError+    , withError++    -- ** ByteStrings+    , getByteString++    ) where++import Foreign+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B++import Control.Applicative+import Control.Monad+#if MIN_VERSION_base(4,9,0)+import qualified Control.Monad.Fail as Fail+#endif++import Data.Binary.Internal ( accursedUnutterablePerformIO )++-- Kolmodin 20100427: at zurihac we discussed of having partial take a+-- "Maybe ByteString" and implemented it in this way.+-- The reasoning was that you could accidently provide an empty bytestring,+-- and it should not terminate the decoding (empty would mean eof).+-- However, I'd say that it's also a risk that you get stuck in a loop,+-- where you keep providing an empty string. Anyway, no new input should be+-- rare, as the RTS should only wake you up if you actually have some data+-- to read from your fd.++-- | A decoder produced by running a 'Get' monad.+data Decoder e a = Fail !B.ByteString (Either String e)+              -- ^ The decoder ran into an error. The decoder either used+              -- 'fail' or was not provided enough input.+              | Partial (Maybe B.ByteString -> Decoder e a)+              -- ^ The decoder has consumed the available input and needs+              -- more to continue. Provide 'Just' if more input is available+              -- and 'Nothing' otherwise, and you will get a new 'Decoder'.+              | Done !B.ByteString a+              -- ^ The decoder has successfully finished. Except for the+              -- output value you also get the unused input.+              | BytesRead {-# UNPACK #-} !Int64 (Int64 -> Decoder e a)+              -- ^ The decoder needs to know the current position in the input.+              -- Given the number of bytes remaning in the decoder, the outer+              -- decoder runner needs to calculate the position and+              -- resume the decoding.++-- unrolled codensity/state monad+newtype Get e a = C { runCont :: forall r. Int64 -> B.ByteString -> Success e a r -> Decoder e r }++type Success e a r = B.ByteString -> a -> Decoder e r++instance Monad (Get e) where+  return = pure+  (>>=) = bindG+#if MIN_VERSION_base(4,9,0)+  fail = Fail.fail++instance Fail.MonadFail (Get e) where+#endif+  fail = failG_++bindG :: Get e a -> (a -> Get e b) -> Get e b+bindG (C c) f = C $ \ge i ks -> c ge i (\i' a -> (runCont (f a)) ge i' ks)+{-# INLINE bindG #-}++failG_ :: String -> Get e a+failG_ str = C $ \_ i _ks -> Fail i $ Left str++failG :: e -> Get e a+failG err = C $ \_ i _ks -> Fail i $ Right err++apG :: Get e (a -> b) -> Get e a -> Get e b+apG d e = do+  b <- d+  a <- e+  return (b a)+{-# INLINE [0] apG #-}++fmapG :: (a -> b) -> Get e a -> Get e b+fmapG f m = C $ \ge i ks -> runCont m ge i (\i' a -> ks i' (f a))+{-# INLINE fmapG #-}++instance Applicative (Get e) where+  pure = \x -> C $ \_ s ks -> ks s x+  {-# INLINE [0] pure #-}+  (<*>) = apG+  {-# INLINE (<*>) #-}++instance MonadPlus (Get e) where+  mzero = empty+  mplus = (<|>)++instance Functor (Get e) where+  fmap = fmapG++instance Functor (Decoder e) where+  fmap f (Done s a) = Done s (f a)+  fmap f (Partial k) = Partial (fmap f . k)+  fmap _ (Fail s err) = Fail s err+  fmap f (BytesRead b k) = BytesRead b (fmap f . k)++instance (Show e, Show a) => Show (Decoder e a) where+  show (Fail _ err) = "Fail: " ++ show err+  show (Partial _) = "Partial _"+  show (Done _ a) = "Done: " ++ show a+  show (BytesRead _ _) = "BytesRead"++-- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing+-- input, handling decoding errors and to get the output value.+runGetIncremental :: Int64 -> Get e a -> Decoder e a+runGetIncremental ge g = noMeansNo $+  runCont g ge B.empty (\i a -> Done i a)++-- | Make sure we don't have to pass Nothing to a Partial twice.+-- This way we don't need to pass around an EOF value in the Get e monad, it+-- can safely ask several times if it needs to.+noMeansNo :: Decoder e a -> Decoder e a+noMeansNo r0 = go r0+  where+  go r =+    case r of+      Partial k -> Partial $ \ms ->+                    case ms of+                      Just _ -> go (k ms)+                      Nothing -> neverAgain (k ms)+      BytesRead n k -> BytesRead n (go . k)+      Done _ _ -> r+      Fail _ _ -> r+  neverAgain r =+    case r of+      Partial k -> neverAgain (k Nothing)+      BytesRead n k -> BytesRead n (neverAgain . k)+      Fail _ _ -> r+      Done _ _ -> r++prompt :: B.ByteString -> Decoder e a -> (B.ByteString -> Decoder e a) -> Decoder e a+prompt inp kf ks = prompt' kf (\inp' -> ks (inp `B.append` inp'))++prompt' :: Decoder e a -> (B.ByteString -> Decoder e a) -> Decoder e a+prompt' kf ks =+  let loop =+        Partial $ \sm ->+          case sm of+            Just s | B.null s -> loop+                   | otherwise -> ks s+            Nothing -> kf+  in loop+  +getBaseOffset :: Get e Int64+getBaseOffset = C $ \ge s ks -> ks s ge++-- | Get e the total number of bytes read to this point.+totalBytesRead :: Get e Int64+totalBytesRead = do+  base_offset <- getBaseOffset+  offset <- bytesRead+  return $ base_offset + offset++-- | Get e the total number of bytes read to this point.+bytesRead :: Get e Int64+bytesRead = C $ \_ inp k -> BytesRead (fromIntegral $ B.length inp) (k inp)++-- | Isolate a decoder to operate with a fixed number of bytes, and fail if+-- fewer bytes were consumed, or more bytes were attempted to be consumed.+-- If the given decoder fails, 'isolate' will also fail.+-- Offset from 'bytesRead' will be relative to the start of 'isolate', not the+-- absolute of the input.+isolate :: Int   -- ^ The number of bytes that must be consumed+        -> Get e a -- ^ The decoder to isolate+        -> (Int -> e) -- ^ The error if fewer bytes were consumed+        -> Get e a+isolate n0 act err+  | n0 < 0 = fail "isolate: negative size"+  | otherwise = do+    ge <- getBaseOffset+    offset <- bytesRead+    go n0 (runCont act (ge + offset) B.empty Done)+  where+  go !n (Done left x)+    | n == 0 && B.null left = return x+    | otherwise = do+        pushFront left+        let consumed = n0 - n - B.length left+        failG $ err consumed+  go 0 (Partial resume) = go 0 (resume Nothing)+  go n (Partial resume) = do+    inp <- C $ \_ inp k -> do+      let takeLimited str =+            let (inp', out) = B.splitAt n str in+            k out (Just inp')+      case not (B.null inp) of+        True -> takeLimited inp+        False -> prompt inp (k B.empty Nothing) takeLimited+    case inp of+      Nothing -> go n (resume Nothing)+      Just str -> go (n - B.length str) (resume (Just str))+  go _ (Fail bs (Right ferr)) = pushFront bs >> failG ferr+  go _ (Fail bs (Left ferr)) = pushFront bs >> failG_ ferr+  go n (BytesRead r resume) =+    go n (resume $! fromIntegral n0 - fromIntegral n - r)++type Consume s = s -> B.ByteString -> Either s (B.ByteString, B.ByteString)++withInputChunks :: s -> Consume s -> ([B.ByteString] -> b) -> ([B.ByteString] -> Get e b) -> Get e b+withInputChunks initS consume onSucc onFail = go initS []+  where+  go state acc = C $ \ge inp ks ->+    case consume state inp of+      Left state' -> do+        let acc' = inp : acc+        prompt'+          (runCont (onFail (reverse acc')) ge B.empty ks)+          (\str' -> runCont (go state' acc') ge str' ks)+      Right (want,rest) -> do+        ks rest (onSucc (reverse (want:acc)))++failOnEOF :: [B.ByteString] -> Get () a+failOnEOF bs = C $ \_ _ _ -> Fail (B.concat bs) $ Right ()++-- | Test whether all input has been consumed, i.e. there are no remaining+-- undecoded bytes.+isEmpty :: Get e Bool+isEmpty = C $ \_ inp ks ->+    if B.null inp+      then prompt inp (ks inp True) (\inp' -> ks inp' False)+      else ks inp False++instance Alternative (Get e) where+  empty = C $ \_ inp _ks -> Fail inp $ Left "Data.Binary.Get(Alternative).empty"+  {-# INLINE empty #-}+  (<|>) f g = do+    (decoder, bs) <- runAndKeepTrack f+    case decoder of+      Done inp x -> C $ \_ _ ks -> ks inp x+      Fail _ _ -> pushBack bs >> g+      _ -> error "Binary: impossible"+  {-# INLINE (<|>) #-}+  some p = (:) <$> p <*> many p+  {-# INLINE some #-}+  many p = do+    v <- (Just <$> p) <|> pure Nothing+    case v of+      Nothing -> pure []+      Just x -> (:) x <$> many p+  {-# INLINE many #-}++-- | Run a decoder and keep track of all the input it consumes.+-- Once it's finished, return the final decoder (always 'Done' or 'Fail'),+-- and unconsume all the the input the decoder required to run.+-- Any additional chunks which was required to run the decoder+-- will also be returned.+runAndKeepTrack :: Get e a -> Get e (Decoder e a, [B.ByteString])+runAndKeepTrack g = C $ \ge inp ks ->+  let r0 = runCont g ge inp (\inp' a -> Done inp' a)+      go !acc r = case r of+                    Done inp' a -> ks inp (Done inp' a, reverse acc)+                    Partial k -> Partial $ \minp -> go (maybe acc (:acc) minp) (k minp)+                    Fail inp' s -> ks inp (Fail inp' s, reverse acc)+                    BytesRead unused k -> BytesRead unused (go acc . k)+  in go [] r0+{-# INLINE runAndKeepTrack #-}++pushBack :: [B.ByteString] -> Get e ()+pushBack [] = C $ \_  inp ks -> ks inp ()+pushBack bs = C $ \_  inp ks -> ks (B.concat (inp : bs)) ()+{-# INLINE pushBack #-}++pushFront :: B.ByteString -> Get e ()+pushFront bs = C $ \_  inp ks -> ks (B.append bs inp) ()+{-# INLINE pushFront #-}++-- | Run the given decoder, but without consuming its input. If the given+-- decoder fails, then so will this function.+--+-- /Since: 0.7.0.0/+lookAhead :: Get e a -> Get e a+lookAhead g = do+  (decoder, bs) <- runAndKeepTrack g+  case decoder of+    Done _ a -> pushBack bs >> return a+    Fail inp s -> C $ \_ _ _ -> Fail inp s+    _ -> error "Binary: impossible"++-- | Run the given decoder, and only consume its input if it returns 'Just'.+-- If 'Nothing' is returned, the input will be unconsumed.+-- If the given decoder fails, then so will this function.+--+-- /Since: 0.7.0.0/+lookAheadM :: Get e (Maybe a) -> Get e (Maybe a)+lookAheadM g = do+  let g' = maybe (Left ()) Right <$> g+  either (const Nothing) Just <$> lookAheadE g'++-- | Run the given decoder, and only consume its input if it returns 'Right'.+-- If 'Left' is returned, the input will be unconsumed.+-- If the given decoder fails, then so will this function.+lookAheadE :: Get e (Either a b) -> Get e (Either a b)+lookAheadE g = do+  (decoder, bs) <- runAndKeepTrack g+  case decoder of+    Done _ (Left x) -> pushBack bs >> return (Left x)+    Done inp (Right x) -> C $ \_ _ ks -> ks inp (Right x)+    Fail inp s -> C $ \_ _ _ -> Fail inp s+    _ -> error "Binary: impossible"++--- | Label a decoder. If the decoder fails, the label will be appended on+--- a new line to the error message string.+label :: String -> Get String a -> Get String a+label msg = onError (\x -> x ++ "\n" ++ msg)++-- | Convert decoder error. If the decoder fails, the given function will be applied+-- to the error message.+onError :: (e -> e') -> Get e a -> Get e' a+onError msg decoder = C $ \ge inp ks ->+  let r0 = runCont decoder ge inp (\inp' a -> Done inp' a)+      go r = case r of+                 Done inp' a -> ks inp' a+                 Partial k -> Partial (go . k)+                 Fail inp' (Left s) -> Fail inp' $ Left s+                 Fail inp' (Right s) -> Fail inp' $ Right $ msg s+                 BytesRead u k -> BytesRead u (go . k)+  in go r0+  +-- | Set decoder error. If the decoder fails, the given error will be used+-- as the error message.+withError :: Get () a -> e -> Get e a+withError decoder msg = onError (const msg) decoder++------------------------------------------------------------------------+-- ByteStrings+--++-- | An efficient get method for strict ByteStrings. Fails if fewer than @n@+-- bytes are left in the input. If @n <= 0@ then the empty string is returned.+getByteString :: Int -> Get () B.ByteString+getByteString n | n > 0 = readN n (B.unsafeTake n)+                | otherwise = return B.empty+{-# INLINE getByteString #-}++-- | Get e the current chunk.+get :: Get e B.ByteString+get = C $ \_ inp ks -> ks inp inp++-- | Replace the current chunk.+put :: B.ByteString -> Get e ()+put s = C $ \_ _inp ks -> ks s ()++-- | Return at least @n@ bytes, maybe more. If not enough data is available+-- the computation will escape with 'Partial'.+readN :: Int -> (B.ByteString -> a) -> Get () a+readN !n f = ensureN n >> unsafeReadN n f+{-# INLINE [0] readN #-}++{-# RULES++"readN/readN merge" forall n m f g.+  apG (readN n f) (readN m g) = readN (n+m) (\bs -> f bs $ g (B.unsafeDrop n bs)) #-}++-- | Ensure that there are at least @n@ bytes available. If not, the+-- computation will escape with 'Partial'.+ensureN :: Int -> Get () ()+ensureN !n0 = C $ \ge inp ks -> do+  if B.length inp >= n0+    then ks inp ()+    else runCont (withInputChunks n0 enoughChunks onSucc onFail >>= put) ge inp ks+  where -- might look a bit funny, but plays very well with GHC's inliner.+        -- GHC won't inline recursive functions, so we make ensureN non-recursive+    enoughChunks n str+      | B.length str >= n = Right (str,B.empty)+      | otherwise = Left (n - B.length str)+    -- Sometimes we will produce leftovers lists of the form [B.empty, nonempty]+    -- where `nonempty` is a non-empty ByteString. In this case we can avoid a copy+    -- by simply dropping the empty prefix. In principle ByteString might want+    -- to gain this optimization as well+    onSucc = B.concat . dropWhile B.null+    onFail bss = C $ \_ _ _ -> Fail (B.concat bss) $ Right ()+{-# INLINE ensureN #-}++unsafeReadN :: Int -> (B.ByteString -> a) -> Get () a+unsafeReadN !n f = C $ \_ inp ks -> do+  ks (B.unsafeDrop n inp) $! f inp -- strict return++-- | @readNWith n f@ where @f@ must be deterministic and not have side effects.+readNWith :: Int -> (Ptr a -> IO a) -> Get () a+readNWith n f = do+    -- It should be safe to use accursedUnutterablePerformIO here.+    -- The action must be deterministic and not have any external side effects.+    -- It depends on the value of the ByteString so the value dependencies look OK.+    readN n $ \s -> accursedUnutterablePerformIO $ B.unsafeUseAsCString s (f . castPtr)+{-# INLINE readNWith #-}

@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}++module Data.Binary.Internal + ( accursedUnutterablePerformIO ) where++#if MIN_VERSION_bytestring(0,10,6)+import Data.ByteString.Internal( accursedUnutterablePerformIO )+#else+import Data.ByteString.Internal( inlinePerformIO )++{-# INLINE accursedUnutterablePerformIO #-}+-- | You must be truly desperate to come to me for help.+accursedUnutterablePerformIO :: IO a -> a+accursedUnutterablePerformIO = inlinePerformIO+#endif

@@ -0,0 +1,425 @@+{-# LANGUAGE PatternGuards #-}+module Action where++import Control.Applicative+import Control.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Char+import Data.Int+import Data.List (intersperse, nub)++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++import Arbitrary ()+import qualified Data.Binary.Get.Ext as Binary++tests :: [Test]+tests = [ testProperty "action" prop_action+        , testProperty "label" prop_label+        , testProperty "fail" prop_fail ]++data Action+  = Actions [Action]+  | GetByteString Int+  | GetByteStringL Int+  | Skip Int+  | Isolate Int [Action]+  | Try [Action] [Action]+  | Label String [Action]+  | LookAhead [Action]+  -- | First argument is True if this action returns Just, otherwise False.+  | LookAheadM Bool [Action]+  -- | First argument is True if this action returns Right, otherwise Left.+  | LookAheadE Bool [Action]+  | BytesRead+  | Fail+  deriving (Show, Eq)++instance Arbitrary Action where+  arbitrary = fmap Actions (gen_actions False)+  shrink action =+    case action of+      Actions [a] -> [a]+      Actions as -> [ Actions as' | as' <- shrink as ]+      BytesRead -> []+      Fail -> []+      GetByteString n -> [ GetByteString n' | n' <- shrink n ]+      GetByteStringL n -> [ GetByteStringL n' | n' <- shrink n ]+      Skip n -> [ Skip n' | n' <- shrink n ]+      Isolate n as -> nub $ Actions as :+        [ Isolate n' as' | (n',as') <- shrink (n,as)+                         , n' >= 0+                         , n' <= max_len as' + 1 ]+      Label str a -> Actions a : [ Label str a' | a' <- shrink a ]+      LookAhead a -> Actions a : [ LookAhead a' | a' <- shrink a ]+      LookAheadM b a -> Actions a : [ LookAheadM b a' | a' <- shrink a ]+      LookAheadE b a -> Actions a : [ LookAheadE b a' | a' <- shrink a ]+      Try [Fail] b -> Actions b : [ Try [Fail] b' | b' <- shrink b ]+      Try a b ->+        [Actions a | not (willFail' a)]+        ++ [ Try a' b' | (a',b') <- shrink (a,b) ]++willFail :: Int -> [Action] -> Bool+willFail inp xxs =+  case eval inp xxs of+    EFail {} -> True+    _ -> False++willFail' :: [Action] -> Bool+willFail' = willFail maxBound++-- | The maximum length of input decoder can request.+-- The decoder may end up using less, but never more.+-- This way, you know how much input to generate for running a decoder test.+max_len :: [Action] -> Int+max_len [] = 0+max_len (x:xs) =+  case x of+    Actions xs' -> max_len (xs' ++ xs)+    BytesRead -> max_len xs+    Fail -> 0+    GetByteString n -> n + max_len xs+    GetByteStringL n -> n + max_len xs+    Skip n -> n + max_len xs+    Isolate n xs'+      | Just _ <- actual_len' [Isolate n xs'] -> n + max_len xs+      | otherwise -> n+    Label _ xs' -> max_len (xs' ++ xs)+    LookAhead xs'+      | willFail' xs' -> max_len xs'+      | otherwise -> max (max_len xs') (max_len xs)+    LookAheadM consume xs'+      | consume -> max_len (xs' ++ xs)+      | otherwise -> max_len (LookAhead xs' : xs)+    LookAheadE consume xs'+      | consume -> max_len (xs' ++ xs)+      | otherwise -> max_len (LookAhead xs' : xs)+    Try a b+      | willFail' a && willFail' b -> max (max_len a) (max_len b)+      | willFail' a -> max (max_len a) (max_len b) + max_len xs+      | otherwise ->  max_len (a ++ xs)++-- | The actual length of input that will be consumed when+-- a decoder is executed, or Nothing if the decoder will fail.+actual_len :: Int -> [Action] -> Maybe Int+actual_len inp xs =+  case eval inp xs of+    ESuccess inp' -> Just (inp - inp')+    _ -> Nothing++actual_len' :: [Action] -> Maybe Int+actual_len' = actual_len maxBound++randomInput :: Int -> Gen L.ByteString+randomInput 0 = return L.empty+randomInput n = do+  m <- choose (1, min n 10)+  s <- vectorOf m $ choose ('a', 'z')+  let b = B.pack $ map (fromIntegral.ord) s+  rest <- randomInput (n-m)+  return (L.append (L.fromChunks [b]) rest)++-- | Build binary programs and compare running them to running a (hopefully)+-- identical model.+-- Tests that 'bytesRead' returns correct values when used together with '<|>'+-- and 'fail'.+prop_action :: Property+prop_action =+  forAllShrink (gen_actions False) shrink $ \ actions ->+    let max_len_input = max_len actions in+    forAll (randomInput max_len_input) $ \ lbs ->+      let allInput = B.concat (L.toChunks lbs) in+      case Binary.runGetOrFail 0 (execute allInput actions) lbs of+        Right (_inp, _off, _x) -> True+        Left (_inp, _off, _msg) -> True++-- | When a decoder aborts with 'fail', check that all relevant uses of 'label'+-- are respected.+prop_label :: Property+prop_label =+  forAllShrink (gen_actions True) shrink $ \ actions ->+    let max_len_input = max_len actions in+    forAll (randomInput max_len_input) $ \ lbs ->+      let allInput = B.concat (L.toChunks lbs) in+      collect (failReason $ eval max_len_input actions) $+      case Binary.runGetOrFail 0 (execute allInput actions) lbs of+        Left (_, _, Left e) -> error $ "Internal error " ++ e+        Left (_inp, _off, Right msg) ->+          let lbls = case collectLabels max_len_input actions of+                         Just lbls' -> lbls'+                         Nothing -> error ("expected labels, got: " ++ msg)+              expectedMsg = concat $ intersperse "\n" lbls+          in expectedMsg === msg+        Right (_inp, _off, _value) -> label "test case without 'fail'" $ True++-- | When a decoder aborts with 'fail', check the fail position and+-- remaining input.+prop_fail :: Property+prop_fail =+  forAllShrink (gen_actions True) shrink $ \ actions ->+    let max_len_input = max_len actions in+    forAll (randomInput max_len_input) $ \ lbs ->+      let allInput = B.concat (L.toChunks lbs) in+      collect (failReason $ eval max_len_input actions) $+      case Binary.runGetOrFail 0 (execute allInput actions) lbs of+        Left (inp, off, _msg) ->+          case () of+            _ | Just off /= findFailPosition max_len_input actions ->+                  error ("fail position incorrect, expected " +++                         show (findFailPosition max_len_input actions) +++                         " but got " ++ show off)+              | inp /= L.drop (fromIntegral off) lbs ->+                  error $ "remaining output incorrect, was: " ++ show inp +++                    ", should hav been: " ++ show (L.drop (fromIntegral off) lbs)+              | otherwise -> property True+        Right (_inp, _off, _value) -> label "test case without 'fail'" $ property True++-- | Collect all the labels up to a 'fail', or Nothing if the+-- decoder will not fail.+collectLabels :: Int -> [Action] -> Maybe [String]+collectLabels inp xxs =+  case eval inp xxs of+    EFail _ lbls _ -> Just lbls+    _ -> Nothing++-- | Finds at which byte offset the decoder will fail,+-- or Nothing if it won't fail.+findFailPosition :: Int -> [Action] -> Maybe Binary.ByteOffset+findFailPosition inp xxs =+  case eval inp xxs of+    EFail _ _ inp' -> return (fromIntegral (inp-inp'))+    _ -> Nothing++failReason :: Eval -> String+failReason (EFail fr _ _) = show fr+failReason _ = "NoFail"++-- | The result of an evaluation.+data Eval = ESuccess Int+          -- ^ The evalutation completed successfully. Contains the number of+          -- remaining bytes of the input.+          | EFail FailReason [String] Int+          -- ^ The evaluation completed with a failure. Contains the labels up+          -- to the failure, and the number of remaining bytes of the input.+          deriving (Show,Eq)++data FailReason+  = FRFail+  | FRIsolateTooMuch+  | FRIsolateTooLittle+  | FRTooMuch+  deriving (Show,Eq)++-- | Given the number of input bytes and a list of actions, evaluate the+-- actions and return whether the actions succeeed or fail.+eval :: Int -> [Action] -> Eval+eval inp0 = go inp0 []+  where+    step :: Int -> Int -> [String] -> [Action] -> Eval+    step inp n lbls xs+      | inp - n < 0 =+          let msg = "not enough bytes"+          in EFail FRTooMuch (msg:lbls) inp+      | otherwise = go (inp-n) lbls xs+    go :: Int -> [String] -> [Action] -> Eval+    go inp _lbls [] = ESuccess inp+    go inp lbls (x:xs) =+      case x of+        Actions xs' -> go inp lbls (xs'++xs)+        BytesRead -> go inp lbls xs+        Fail -> EFail FRFail ("fail":lbls) inp+        GetByteString n -> step inp n lbls xs+        GetByteStringL n -> step inp n lbls xs+        Skip n -> step inp n lbls xs+        Isolate n xs'+          | n > inp ->+              case go inp lbls xs' of+                ESuccess inp' ->+                  let msg = "isolate: the decoder consumed " ++ show (inp - inp') +++                            " bytes which is less than the expected " ++ (show n) +++                            " bytes"+                   in EFail FRTooMuch (msg:lbls) inp'+                efail -> efail+          | otherwise ->+              case go n lbls xs' of+                EFail fr lbls' inp' -> EFail fr lbls' (inp - n + inp')+                ESuccess 0          -> go (inp-n) lbls xs+                ESuccess inp'       ->+                  let msg = "isolate: the decoder consumed " ++ show (n - inp') +++                            " bytes which is less than the expected " ++ (show n) +++                            " bytes"+                  in EFail FRIsolateTooLittle (msg:lbls) (inp - n + inp')+        Label str xs' ->+          case go inp (str:lbls) xs' of+            EFail fr lbls' inp' -> EFail fr lbls' inp'+            ESuccess inp' -> go inp' lbls xs+        LookAhead xs'+          | EFail fr lbls' inp' <- go inp lbls xs' -> EFail fr lbls' inp'+          | otherwise -> go inp lbls xs+        LookAheadM consume xs'+          | consume -> go inp lbls (xs'++xs)+          | otherwise -> go inp lbls (LookAhead xs' : xs)+        LookAheadE consume xs'+          | consume -> go inp lbls (xs'++xs)+          | otherwise -> go inp lbls (LookAhead xs' : xs)+        Try a b ->+          case go inp lbls a of+            ESuccess inp' -> go inp' lbls     xs+            EFail {}      -> go inp  lbls (b++xs)++getLazyByteString :: Int64 -> Binary.Get String L.ByteString+getLazyByteString = (`Binary.withError` "not enough bytes") . Binary.getLazyByteString++skip :: Int -> Binary.Get String ()+skip = (`Binary.withError` "not enough bytes") . Binary.skip++isolate :: Int -> Binary.Get String a -> Binary.Get String a+isolate n decoder =+  Binary.isolate n decoder (msg n)+  where+    msg n0 consumed+      =  "isolate: the decoder consumed " ++ show consumed ++ " bytes"+      ++ " which is less than the expected " ++ show n0 ++ " bytes"++getByteString :: Int -> Binary.Get String B.ByteString+getByteString = (`Binary.withError` "not enough bytes") . Binary.getByteString++-- | Execute (run) the model.+-- First argument is all the input that will be used when executing+-- this decoder. It is used in this function to compare the expected+-- value with the actual value from the decoder functions.+-- The second argument is the model - the actions we will execute.+execute :: B.ByteString -> [Action] -> Binary.Get String ()+execute inp acts0 = go 0 acts0 >> return ()+  where+  inp_len = B.length inp+  go _ [] = return ()+  go pos (x:xs) =+    case x of+      Actions a -> go pos (a++xs)+      GetByteString n -> do+        -- Run the operation in the Get monad...+        actual <- getByteString n+        let expected = B.take n . B.drop pos $ inp+        -- ... and compare that we got what we expected.+        when (actual /= expected) $ error $+          "execute(getByteString): actual /= expected at pos " ++ show pos +++          ", got: " ++ show actual ++ ", expected: " ++ show expected+        go (pos+n) xs+      GetByteStringL n -> do+        -- Run the operation in the Get monad...+        actual <- L.toStrict <$> getLazyByteString (fromIntegral n)+        let expected = B.take n . B.drop pos $ inp+        -- ... and compare that we got what we expected.+        when (actual /= expected) $ error $+          "execute(getLazyByteString): actual /= expected at pos " ++ show pos +++          ", got: " ++ show actual ++ ", expected: " ++ show expected+        go (pos+n) xs+      Skip n -> do+        skip n+        go (pos+n) xs+      BytesRead -> do+        pos' <- Binary.bytesRead+        if pos == fromIntegral pos'+          then go pos xs+          else error $ "execute(bytesRead): expected " +++            show pos ++ " but got " ++ show pos'+      Fail -> Binary.failG "fail"+      Isolate n as -> do+        let str = B.take n (B.drop pos inp)+        _ <- isolate n (execute str as)+        when (willFail (inp_len - pos) [Isolate n as]) $+          error "expected isolate to fail"+        go (pos + n) xs+      Label str as -> do+        len <- Binary.label str (leg pos as)+        go (pos+len) xs+      LookAhead a -> do+        _ <- Binary.lookAhead (go pos a)+        go pos xs+      LookAheadM b a -> do+        let f True = Just <$> leg pos a+            f False = go pos a >> return Nothing+        len <- Binary.lookAheadM (f b)+        case len of+          Nothing -> go pos xs+          Just offset -> go (pos+offset) xs+      LookAheadE b a -> do+        let f True = Right <$> leg pos a+            f False = go pos a >> return (Left ())+        len <- Binary.lookAheadE (f b)+        case len of+          Left _ -> go pos xs+          Right offset -> go (pos+offset) xs+      Try a b -> do+        offset <- leg pos a <|> leg pos b+        go (pos+offset) xs+  leg pos t = do+    go pos t+    case actual_len (inp_len - pos) t of+      Nothing -> error "impossible: branch should have failed"+      Just offset -> return offset++gen_actions :: Bool -> Gen [Action]+gen_actions genFail = do+  acts <- sized (go False)+  return acts+  where+  go :: Bool -> Int -> Gen [Action]+  go     _ 0 = return []+  go inTry s = oneof $ [ do n <- choose (0,10)+                            (:) (GetByteString n) <$> go inTry (s-1)+                       , do n <- choose (0,10)+                            (:) (GetByteStringL n) <$> go inTry (s-1)+                       , do n <- choose (0,10)+                            (:) (Skip n) <$> go inTry (s-1)+                       , do (:) BytesRead <$> go inTry (s-1)+                       , do t1 <- go True (s `div` 2)+                            t2 <- go inTry (s `div` 2)+                            (:) (Try t1 t2) <$> go inTry (s `div` 2)+                       , do t <- go inTry (s`div`2)+                            (:) (LookAhead t) <$> go inTry (s-1)+                       , do t <- go inTry (s`div`2)+                            b <- arbitrary+                            (:) (LookAheadM b t) <$> go inTry (s-1)+                       , do t <- go inTry (s`div`2)+                            b <- arbitrary+                            (:) (LookAheadE b t) <$> go inTry (s-1)+                       , do t <- go inTry (s`div`2)+                            Positive n <- arbitrary :: Gen (Positive Int)+                            (:) (Label ("some label: " ++ show n) t) <$> go inTry (s-1)+                       , do t <- resize (s`div`2) (gen_isolate (genFail || inTry))+                            (:) t <$> go inTry (s-1)+                       ] ++ [frequency [(if inTry || genFail then 1 else 0, return [Fail])+                                        ,(9                               , go inTry s)]]++gen_isolate :: Bool -> Gen Action+gen_isolate genFail = gen_actions genFail >>= go+  where+  go t0 = do+    -- We can isolate the decoder with three different ranges;+    --  * give too few bytes -> isolate will fail+    --  * give exactly right amount of bytes -> isolate+    --    will succeed if the given decoder succeeds+    --  * give too many bytes -> isolate will fail+    -- Here we generate Isolates that belong to the different+    -- buckets.+    let t = t0+        tooFewBytes n = do+          n' <- choose (0, n)+          return (n',t)+        requiredBytes n = return (n,t)+        tooManyBytes n = do+          n' <- choose (n+1, n+10)+          return (n+n',t)+    let trees+          | Just n <- actual_len' t = oneof $+              [ requiredBytes n ] +++              [ tooFewBytes n | genFail ] +++              [ tooManyBytes n | genFail ]+          | otherwise = return (max_len t, t)+    (n,t') <- trees+    return (Isolate n t')

@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Arbitrary where++import Test.QuickCheck++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+#if MIN_VERSION_bytestring(0,10,4)+import qualified Data.ByteString.Short as S+#endif++instance Arbitrary L.ByteString where+  arbitrary = fmap L.fromChunks arbitrary++instance Arbitrary B.ByteString where+  arbitrary = B.pack `fmap` arbitrary++#if MIN_VERSION_bytestring(0,10,4)+instance Arbitrary S.ShortByteString where+  arbitrary = S.toShort `fmap` arbitrary+#endif

@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+module Main where++#if ! MIN_VERSION_base(4,8,0)+import           Control.Applicative+#endif++import           System.Directory          (getTemporaryDirectory)+import           System.FilePath           ((</>))+import           Test.HUnit++import           Distribution.Simple.Utils (withTempDirectory)+import           Distribution.Verbosity    (silent)++import           Data.Binary++data Foo = Bar !Word32 !Word32 !Word32 deriving (Eq, Show)++instance Binary Foo where+  get = Bar <$> get <*> get <*> get+  put (Bar a b c) = put (a,b,c)++exampleData :: [Foo]+exampleData = make bytes+  where+    make (a:b:c:xs) = Bar a b c : make xs+    make _ = []+    bytes = take (256*1024) (cycle [minBound..maxBound])++readWriteTest :: Test+readWriteTest = TestCase $ do+  tmpDir <- getTemporaryDirectory+  withTempDirectory silent tmpDir "foo-dir" $ \dir -> do+    let fn = dir </> "foo.bin"+    encodeFile fn exampleData+    content <- decodeFile fn+    -- It'd be nice to use lsof to verify that 'fn' isn't still open.+    exampleData @=? content++main :: IO ()+main = do +  _ <- runTestTT readWriteTest+  return ()

@@ -0,0 +1,739 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-}+module Main ( main ) where++#if MIN_VERSION_base(4,8,0)+#define HAS_NATURAL+#endif++#if MIN_VERSION_base(4,7,0)+#define HAS_FIXED_CONSTRUCTOR+#endif++import Control.Applicative+import Control.Exception as C (SomeException, catch, evaluate)+import Control.Monad (unless)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L+import Data.Int+import Data.Ratio+import System.IO.Unsafe++#ifdef HAS_NATURAL+import Numeric.Natural+#endif++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck++import qualified Action (tests)+import Arbitrary ()+import Data.Binary hiding (Get, get, getWord8)+import Data.Binary.Get.Ext hiding+  ( getLazyByteString, getLazyByteStringNul, getWord8+  , getWord16le, getWord16be, getWord16host+  , getWord32le, getWord32be, getWord32host+  , getWord64le, getWord64be, getWord64host+  , getWordhost, getByteString+  , getInt8+  , getInt16be, getInt16le, getInt16host+  , getInt32be, getInt32le, getInt32host+  , getInt64be, getInt64le, getInt64host+  , getInthost+  )+import qualified Data.Binary.Get.Ext as Binary+  ( getLazyByteString, getLazyByteStringNul, getWord8+  , getWord16le, getWord16be, getWord16host+  , getWord32le, getWord32be, getWord32host+  , getWord64le, getWord64be, getWord64host+  , getWordhost, getByteString+  , getInt8+  , getInt16be, getInt16le, getInt16host+  , getInt32be, getInt32le, getInt32host+  , getInt64be, getInt64le, getInt64host+  , getInthost+  )+import Data.Binary.Put++------------------------------------------------------------------------++roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool+roundTrip a f = a ==+    {-# SCC "decode.refragment.encode" #-} decode (f (encode a))++runGet :: Get String a -> L.ByteString -> a+runGet decoder inp =+  case runGetOrFail 0 decoder inp of+    Right (_, _, a) -> a+    Left (_, pos, msg) -> error $ "Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ show msg++withStringError :: Get () a -> Get String a+withStringError = (`withError` "not enough bytes")++getByteString :: Int -> Get String B.ByteString+getByteString = withStringError . Binary.getByteString++getWord8 :: Get String Word8+getWord8 = withStringError Binary.getWord8++getWord16be :: Get String Word16+getWord16be = withStringError Binary.getWord16be++getWord16le :: Get String Word16+getWord16le = withStringError Binary.getWord16le++getWord16host :: Get String Word16+getWord16host = withStringError Binary.getWord16host++getWord32be :: Get String Word32+getWord32be = withStringError Binary.getWord32be++getWord32le :: Get String Word32+getWord32le = withStringError Binary.getWord32le++getWord32host :: Get String Word32+getWord32host = withStringError Binary.getWord32host++getWord64be :: Get String Word64+getWord64be = withStringError Binary.getWord64be++getWord64le :: Get String Word64+getWord64le = withStringError Binary.getWord64le++getWord64host :: Get String Word64+getWord64host = withStringError Binary.getWord64host++getWordhost :: Get String Word+getWordhost = withStringError Binary.getWordhost++getInt8 :: Get String Int8+getInt8 = withStringError Binary.getInt8++getInt16be :: Get String Int16+getInt16be = withStringError Binary.getInt16be++getInt16le :: Get String Int16+getInt16le = withStringError Binary.getInt16le++getInt16host :: Get String Int16+getInt16host = withStringError Binary.getInt16host++getInt32be :: Get String Int32+getInt32be = withStringError Binary.getInt32be++getInt32le :: Get String Int32+getInt32le = withStringError Binary.getInt32le++getInt32host :: Get String Int32+getInt32host = withStringError Binary.getInt32host++getInt64be :: Get String Int64+getInt64be = withStringError Binary.getInt64be++getInt64le :: Get String Int64+getInt64le = withStringError Binary.getInt64le++getInt64host :: Get String Int64+getInt64host = withStringError Binary.getInt64host++getInthost :: Get String Int+getInthost = withStringError Binary.getInthost++roundTripWith ::  Eq a => (a -> Put) -> Get String a -> a -> Property+roundTripWith putter getter x =+    forAll positiveList $ \xs ->+    x == runGet getter (refragment xs (runPut (putter x)))++-- make sure that a test fails+mustThrowError :: B a+mustThrowError a = unsafePerformIO $+    C.catch (do _ <- C.evaluate a+                return False)+            (\(_e :: SomeException) -> return True)++-- low level ones:+--+-- Words++prop_Word8 :: Word8 -> Property+prop_Word8 = roundTripWith putWord8 getWord8++prop_Word16be :: Word16 -> Property+prop_Word16be = roundTripWith putWord16be getWord16be++prop_Word16le :: Word16 -> Property+prop_Word16le = roundTripWith putWord16le getWord16le++prop_Word16host :: Word16 -> Property+prop_Word16host = roundTripWith putWord16host getWord16host++prop_Word32be :: Word32 -> Property+prop_Word32be = roundTripWith putWord32be getWord32be++prop_Word32le :: Word32 -> Property+prop_Word32le = roundTripWith putWord32le getWord32le++prop_Word32host :: Word32 -> Property+prop_Word32host = roundTripWith putWord32host getWord32host++prop_Word64be :: Word64 -> Property+prop_Word64be = roundTripWith putWord64be getWord64be++prop_Word64le :: Word64 -> Property+prop_Word64le = roundTripWith putWord64le getWord64le++prop_Word64host :: Word64 -> Property+prop_Word64host = roundTripWith putWord64host getWord64host++prop_Wordhost :: Word -> Property+prop_Wordhost = roundTripWith putWordhost getWordhost++-- Ints++prop_Int8 :: Int8 -> Property+prop_Int8 = roundTripWith putInt8 getInt8++prop_Int16be :: Int16 -> Property+prop_Int16be = roundTripWith putInt16be getInt16be++prop_Int16le :: Int16 -> Property+prop_Int16le = roundTripWith putInt16le getInt16le++prop_Int16host :: Int16 -> Property+prop_Int16host = roundTripWith putInt16host getInt16host++prop_Int32be :: Int32 -> Property+prop_Int32be = roundTripWith putInt32be getInt32be++prop_Int32le :: Int32 -> Property+prop_Int32le = roundTripWith putInt32le getInt32le++prop_Int32host :: Int32 -> Property+prop_Int32host = roundTripWith putInt32host getInt32host++prop_Int64be :: Int64 -> Property+prop_Int64be = roundTripWith putInt64be getInt64be++prop_Int64le :: Int64 -> Property+prop_Int64le = roundTripWith putInt64le getInt64le++prop_Int64host :: Int64 -> Property+prop_Int64host = roundTripWith putInt64host getInt64host++prop_Inthost :: Int -> Property+prop_Inthost = roundTripWith putInthost getInthost++{-+-- Floats and Doubles++prop_Floatbe :: Float -> Property+prop_Floatbe = roundTripWith putFloatbe getFloatbe++prop_Floatle :: Float -> Property+prop_Floatle = roundTripWith putFloatle getFloatle++prop_Floathost :: Float -> Property+prop_Floathost = roundTripWith putFloathost getFloathost++prop_Doublebe :: Double -> Property+prop_Doublebe = roundTripWith putDoublebe getDoublebe++prop_Doublele :: Double -> Property+prop_Doublele = roundTripWith putDoublele getDoublele++prop_Doublehost :: Double -> Property+prop_Doublehost = roundTripWith putDoublehost getDoublehost+-}++-- done, partial and fail++-- | Test partial results.+-- May or may not use the whole input, check conditions for the different+-- outcomes.+prop_partial :: L.ByteString -> Property+prop_partial lbs = forAll (choose (0, L.length lbs * 2)) $ \skipN ->+  let result = pushChunks (runGetIncremental 0 decoder) lbs+      decoder = do+        s <- getByteString (fromIntegral skipN)+        return (L.fromChunks [s])+  in case result of+       Partial _ -> L.length lbs < skipN+       Done unused _pos value ->+         and [ L.length value == skipN+             , L.append value (L.fromChunks [unused]) == lbs+             ]+       Fail _ _ _ -> False++-- | Fail a decoder and make sure the result is sane.+prop_fail :: L.ByteString -> String -> Property+prop_fail lbs msg = forAll (choose (0, L.length lbs)) $ \pos ->+  let result = pushChunks (runGetIncremental 0 decoder) lbs+      decoder = do+        -- use part of the input...+        _ <- getByteString (fromIntegral pos)+        -- ... then fail+        failG msg+  in case result of+     Fail unused pos' msg' ->+       and [ pos == pos'+           , Right msg == msg'+           , L.length lbs - pos == fromIntegral (B.length unused)+           , L.fromChunks [unused] `L.isSuffixOf` lbs+           ]+     _ -> False -- wuut?++-- read negative length+prop_getByteString_negative :: Int -> Property+prop_getByteString_negative n =+  n < 1 ==>+    runGet (getByteString n) L.empty == B.empty+++prop_bytesRead :: L.ByteString -> Property+prop_bytesRead lbs =+  forAll (makeChunks 0 totalLength) $ \chunkSizes ->+  let result = pushChunks (runGetIncremental 0 decoder) lbs+      decoder = do+        -- Read some data and invoke bytesRead several times.+        -- Each time, check that the values are what we expect.+        flip mapM_ chunkSizes $ \(total, step) -> do+          _ <- getByteString (fromIntegral step)+          n <- bytesRead+          unless (n == total) $ fail "unexpected position"+        bytesRead+  in case result of+       Done unused pos value ->+         and [ value == totalLength+             , pos == value+             , B.null unused+             ]+       Partial _ -> False+       Fail _ _ _ -> False+  where+    totalLength = L.length lbs+    makeChunks total i+      | i == 0 = return []+      | otherwise = do+          n <- choose (0,i)+          let total' = total + n+          rest <- makeChunks total' (i - n)+          return ((total',n):rest)+++-- | We're trying to guarantee that the Decoder will not ask for more input+-- with Partial if it has been given Nothing once.+-- In this test we're making the decoder return 'Partial' to get more+-- input, and to get knownledge of the current position using 'BytesRead'.+-- Both of these operations, when used with the <|> operator, result internally+-- in that the decoder return with Partial and BytesRead multiple times,+-- in which case we need to keep track of if the user has passed Nothing to a+-- Partial in the past.+prop_partialOnlyOnce :: Property+prop_partialOnlyOnce = property $+  let result = runGetIncremental 0 (decoder <|> decoder)+      decoder = do+        0 <- bytesRead+        _ <- getWord8 -- this will make the decoder return with Partial+        return "shouldn't get here"+  in case result of+       -- we expect Partial followed by Fail+       Partial k -> case k Nothing of -- push down a Nothing+                      Fail _ _ _ -> True+                      Partial _ -> error $ "partial twice! oh noes!"+                      Done _ _ _ -> error $ "we're not supposed to be done."+       _ -> error $ "not partial, error!"++-- read too much+prop_readTooMuch :: (Eq a, Binary a) => a -> Bool+prop_readTooMuch x = mustThrowError $ x == a && x /= b+  where+    -- encode 'a', but try to read 'b' too+    (a,b) = decode (encode x)+    _types = [a,b]++-- In binary-0.5 the Get monad looked like+--+-- > data S = S {-# UNPACK #-} !B.ByteString+-- >            L.ByteString+-- >            {-# UNPACK #-} !Int64+-- >+-- > newtype Get a = Get { unGet :: S -> (# a, S #) }+--+-- with a helper function+--+-- > mkState :: L.ByteString -> Int64 -> S+-- > mkState l = case l of+-- >     L.Empty      -> S B.empty L.empty+-- >     L.Chunk x xs -> S x xs+--+-- Note that mkState is strict in its first argument. This goes wrong in this+-- function:+--+-- > getBytes :: Int -> Get B.ByteString+-- > getBytes n = do+-- >     S s ss bytes <- traceNumBytes n $ get+-- >     if n <= B.length s+-- >         then do let (consume,rest) = B.splitAt n s+-- >                 put $! S rest ss (bytes + fromIntegral n)+-- >                 return $! consume+-- >         else+-- >               case L.splitAt (fromIntegral n) (s `join` ss) of+-- >                 (consuming, rest) ->+-- >                     do let now = B.concat . L.toChunks $ consuming+-- >                        put $ mkState rest (bytes + fromIntegral n)+-- >                        -- forces the next chunk before this one is returned+-- >                        if (B.length now < n)+-- >                          then+-- >                             fail "too few bytes"+-- >                          else+-- >                             return now+--+-- Consider the else-branch of this function; suppose we ask for n bytes;+-- the call to L.splitAt gives us a lazy bytestring 'consuming' of precisely @n@+-- bytes (unless we don't have enough data, in which case we fail); but then+-- the strict evaluation of mkState on 'rest' means we look ahead too far.+--+-- Although this is all done completely differently in binary-0.7 it is+-- important that the same bug does not get introduced in some other way. The+-- test is basically the same test that already exists in this test suite,+-- verifying that+--+-- > decode . refragment . encode == id+--+-- However, we use a different 'refragment', one that introduces an exception+-- as the tail of the bytestring after rechunking. If we don't look ahead too+-- far then this should make no difference, but if we do then this will throw+-- an exception (for instance, in binary-0.5, this will throw an exception for+-- certain rechunkings, but not for others).+--+-- To make sure that the property holds no matter what refragmentation we use,+-- we test exhaustively for a single chunk, and all ways to break the string+-- into 2, 3 and 4 chunks.+prop_lookAheadIndepOfChunking :: (Eq a, Binary a) => a -> Property+prop_lookAheadIndepOfChunking testInput =+   forAll (testCuts (L.length (encode testInput))) $+     roundTrip testInput . rechunk+  where+    testCuts :: forall a. (Num a, Enum a) => a -> Gen [a]+    testCuts len = elements $ [ [] ]+                           ++ [ [i]+                              | i <- [0 .. len] ]+                           ++ [ [i, j]+                              | i <- [0 .. len]+                              , j <- [0 .. len - i] ]+                           ++ [ [i, j, k]+                              | i <- [0 .. len]+                              , j <- [0 .. len - i]+                              , k <- [0 .. len - i - j] ]++    -- Rechunk a bytestring, leaving the tail as an exception rather than Empty+    rechunk :: forall a. Integral a => [a] -> L.ByteString -> L.ByteString+    rechunk cuts = fromChunks . cut cuts . B.concat . L.toChunks+      where+        cut :: [a] -> B.ByteString -> [B.ByteString]+        cut []     bs = [bs]+        cut (i:is) bs = let (bs0, bs1) = B.splitAt (fromIntegral i) bs+                        in bs0 : cut is bs1++        fromChunks :: [B.ByteString] ->  L.ByteString+        fromChunks []       = error "Binary should not have to ask for this chunk!"+        fromChunks (bs:bss) = L.Chunk bs (fromChunks bss)++-- String utilities++getLazyByteString :: Int64 -> Get String L.ByteString+getLazyByteString = (`withError` "not enough bytes") . Binary.getLazyByteString++getLazyByteStringNul :: Get String L.ByteString+getLazyByteStringNul = Binary.getLazyByteStringNul `withError` "not enough bytes"++prop_getLazyByteString :: L.ByteString -> Property+prop_getLazyByteString lbs = forAll (choose (0, 2 * L.length lbs)) $ \len ->+  let result = pushChunks (runGetIncremental 0 decoder) lbs+      decoder = getLazyByteString len+  in case result of+       Done unused _pos value ->+         and [ value == L.take len lbs+             , L.fromChunks [unused] == L.drop len lbs+             ]+       Partial _ -> len > L.length lbs+       _ -> False++prop_getLazyByteStringNul :: Word16 -> [Int] -> Property+prop_getLazyByteStringNul count0 fragments = count >= 0 ==>+  forAll (choose (0, count)) $ \pos ->+  let lbs = case L.splitAt pos (L.replicate count 65) of+              (start,end) -> refragment fragments $ L.concat [start, L.singleton 0, end]+      result = pushEndOfInput $ pushChunks (runGetIncremental 0 getLazyByteStringNul) lbs+  in case result of+       Done unused pos' value ->+         and [ value == L.take pos lbs+             , pos + 1 == pos' -- 1 for the NUL+             , L.fromChunks [unused] == L.drop (pos + 1) lbs+             ]+       _ -> False+  where+  count = fromIntegral count0 -- to make the generated numbers a bit smaller++-- | Same as prop_getLazyByteStringNul, but without any NULL in the string.+prop_getLazyByteStringNul_noNul :: Word16 -> [Int] -> Property+prop_getLazyByteStringNul_noNul count0 fragments = count >= 0 ==>+  let lbs = refragment fragments $ L.replicate count 65+      result = pushEndOfInput $ pushChunks (runGetIncremental 0 getLazyByteStringNul) lbs+  in case result of+       Fail _ _ _ -> True+       _ -> False+  where+  count = fromIntegral count0 -- to make the generated numbers a bit smaller++prop_getRemainingLazyByteString :: L.ByteString -> Property+prop_getRemainingLazyByteString lbs = property $+  let result = pushEndOfInput $ pushChunks (runGetIncremental 0 getRemainingLazyByteString) lbs+  in case result of+    Done unused pos value ->+      and [ value == lbs+          , B.null unused+          , fromIntegral pos == L.length lbs+          ]+    _ -> False++-- sanity:++invariant_lbs :: L.ByteString -> Bool+invariant_lbs (L.Empty)      = True+invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs++prop_invariant :: (Binary a) => a -> Bool+prop_invariant = invariant_lbs . encode++-- refragment a lazy bytestring's chunks+refragment :: [Int] -> L.ByteString -> L.ByteString+refragment [] lbs = lbs+refragment (x:xs) lbs =+    let x' = fromIntegral . (+1) . abs $ x+        rest = refragment xs (L.drop x' lbs) in+    L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lbs]) rest++-- check identity of refragmentation+prop_refragment :: L.ByteString -> [Int] -> Bool+prop_refragment lbs xs = lbs == refragment xs lbs++-- check that refragmention still hold invariant+prop_refragment_inv :: L.ByteString -> [Int] -> Bool+prop_refragment_inv lbs xs = invariant_lbs $ refragment xs lbs++main :: IO ()+main = defaultMain tests++------------------------------------------------------------------------++genInteger :: Gen Integer+genInteger = do+  b <- arbitrary+  if b then genIntegerSmall else genIntegerSmall++genIntegerSmall :: Gen Integer+genIntegerSmall = arbitrary++genIntegerBig :: Gen Integer+genIntegerBig = do+  x <- arbitrarySizedIntegral :: Gen Integer+  -- arbitrarySizedIntegral generates numbers smaller than+  -- (maxBound :: Word32), so let's make them bigger to better test+  -- the Binary instance.+  return (x + fromIntegral (maxBound :: Word32))++#ifdef HAS_NATURAL+genNatural :: Gen Natural+genNatural = do+  b <- arbitrary+  if b then genNaturalSmall else genNaturalBig++genNaturalSmall :: Gen Natural+genNaturalSmall = arbitrarySizedNatural++genNaturalBig :: Gen Natural+genNaturalBig = do+  x <- arbitrarySizedNatural :: Gen Natural+  -- arbitrarySizedNatural generates numbers smaller than+  -- (maxBound :: Word64), so let's make them bigger to better test+  -- the Binary instance.+  return (x + fromIntegral (maxBound :: Word64))+#endif++------------------------------------------------------------------------++#if !MIN_VERSION_base(4,7,0)+instance Show Fingerprint where+  show (Fingerprint x1 x2) = show (x1,x2)+#endif++type T a = a -> Property+type B a = a -> Bool++p :: (Testable p) => p -> Property+p = property++test    :: (Eq a, Binary a) => a -> Property+test a  = forAll positiveList (roundTrip a . refragment)++test' :: (Show a, Arbitrary a) => String -> (a -> Property) -> ([a] -> Property) -> Test+test' desc prop propList =+  testGroup desc [+    testProperty desc prop,+    testProperty ("[" ++ desc ++ "]") propList+  ]++testWithGen :: (Show a, Eq a, Binary a) => String -> Gen a -> Test+testWithGen desc gen =+  testGroup desc [+    testProperty desc (forAll gen test),+    testProperty ("[" ++ desc ++ "]") (forAll (listOf gen) test)+  ]++positiveList :: Gen [Int]+positiveList = fmap (filter (/=0) . map abs) $ arbitrary++tests :: [Test]+tests =+        [ testGroup "Utils"+            [ testProperty "refragment id" (p prop_refragment)+            , testProperty "refragment invariant" (p prop_refragment_inv)+            ]++        , testGroup "Boundaries"+            [ testProperty "read to much"         (p (prop_readTooMuch :: B Word8))+            , testProperty "read negative length" (p (prop_getByteString_negative :: T Int))+            , -- Arbitrary test input+              let testInput :: [Int] ; testInput = [0 .. 10]+              in testProperty "look-ahead independent of chunking" (p (prop_lookAheadIndepOfChunking testInput))+            ]++        , testGroup "Partial"+            [ testProperty "partial" (p prop_partial)+            , testProperty "fail"    (p prop_fail)+            , testProperty "bytesRead" (p prop_bytesRead)+            , testProperty "partial only once" (p prop_partialOnlyOnce)+            ]++        , testGroup "Model"+            Action.tests++        , testGroup "Primitives"+            [ testProperty "Word8"      (p prop_Word8)+            , testProperty "Word16be"   (p prop_Word16be)+            , testProperty "Word16le"   (p prop_Word16le)+            , testProperty "Word16host" (p prop_Word16host)+            , testProperty "Word32be"   (p prop_Word32be)+            , testProperty "Word32le"   (p prop_Word32le)+            , testProperty "Word32host" (p prop_Word32host)+            , testProperty "Word64be"   (p prop_Word64be)+            , testProperty "Word64le"   (p prop_Word64le)+            , testProperty "Word64host" (p prop_Word64host)+            , testProperty "Wordhost"   (p prop_Wordhost)+              -- Int+            , testProperty "Int8"       (p prop_Int8)+            , testProperty "Int16be"    (p prop_Int16be)+            , testProperty "Int16le"    (p prop_Int16le)+            , testProperty "Int16host"  (p prop_Int16host)+            , testProperty "Int32be"    (p prop_Int32be)+            , testProperty "Int32le"    (p prop_Int32le)+            , testProperty "Int32host"  (p prop_Int32host)+            , testProperty "Int64be"    (p prop_Int64be)+            , testProperty "Int64le"    (p prop_Int64le)+            , testProperty "Int64host"  (p prop_Int64host)+            , testProperty "Inthost"    (p prop_Inthost)+{-+              -- Float/Double+            , testProperty "Floatbe"    (p prop_Floatbe)+            , testProperty "Floatle"    (p prop_Floatle)+            , testProperty "Floathost"  (p prop_Floathost)+            , testProperty "Doublebe"   (p prop_Doublebe)+            , testProperty "Doublele"   (p prop_Doublele)+            , testProperty "Doublehost" (p prop_Doublehost)+-}+            ]++        , testGroup "String utils"+            [ testProperty "getLazyByteString"          prop_getLazyByteString+            , testProperty "getLazyByteStringNul"       prop_getLazyByteStringNul+            , testProperty "getLazyByteStringNul No Null" prop_getLazyByteStringNul_noNul+            , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString+            ]++        , testGroup "Using Binary class, refragmented ByteString"+            [ test' "()"          (test :: T ()         ) test+            , test' "Bool"        (test :: T Bool       ) test+            , test' "Char"        (test :: T Char       ) test+            , test' "Ordering"    (test :: T Ordering   ) test+            , test' "Ratio Int"   (test :: T (Ratio Int)) test++            , test' "Word"        (test :: T Word  ) test+            , test' "Word8"       (test :: T Word8 ) test+            , test' "Word16"      (test :: T Word16) test+            , test' "Word32"      (test :: T Word32) test+            , test' "Word64"      (test :: T Word64) test++            , test' "Int"         (test :: T Int  ) test+            , test' "Int8"        (test :: T Int8 ) test+            , test' "Int16"       (test :: T Int16) test+            , test' "Int32"       (test :: T Int32) test+            , test' "Int64"       (test :: T Int64) test++            , testWithGen "Integer mixed" genInteger+            , testWithGen "Integer small" genIntegerSmall+            , testWithGen "Integer big"   genIntegerBig++#ifdef HAS_NATURAL+            , testWithGen "Natural mixed" genNatural+            , testWithGen "Natural small" genNaturalSmall+            , testWithGen "Natural big"   genNaturalBig+#endif++            , test' "Float"       (test :: T Float ) test+            , test' "Double"      (test :: T Double) test++            , test' "((), ())"            (test :: T ((), ())            ) test+            , test' "(Word8, Word32)"     (test :: T (Word8, Word32)     ) test+            , test' "(Int8, Int32)"       (test :: T (Int8,  Int32)      ) test+            , test' "(Int32, [Int])"      (test :: T (Int32, [Int])      ) test+            , test' "Maybe Int8"          (test :: T (Maybe Int8)        ) test+            , test' "Either Int8 Int16"   (test :: T (Either Int8 Int16) ) test++            , test' "(Int, ByteString)"+                    (test     :: T (Int, B.ByteString)   ) test+            , test' "[(Int, ByteString)]"+                    (test     :: T [(Int, B.ByteString)] ) test++            , test' "(Maybe Int64, Bool, [Int])"+                    (test :: T (Maybe Int64, Bool, [Int])) test+            , test' "(Maybe Word8, Bool, [Int], Either Bool Word8)"+                    (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8)) test+            , test' "(Maybe Word16, Bool, [Int], Either Bool Word16, Int)"+                    (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int)) test++{-+            , test' "(Int,Int,Int,Int,Int,Int)"+                      (test :: T (Int,Int,Int,Int,Int,Int)) test+            , test' "(Int,Int,Int,Int,Int,Int,Int)"+                      (test :: T (Int,Int,Int,Int,Int,Int,Int)) test+            , test' "(Int,Int,Int,Int,Int,Int,Int,Int)"+                      (test :: T (Int,Int,Int,Int,Int,Int,Int,Int)) test+            , test' "(Int,Int,Int,Int,Int,Int,Int,Int,Int)"+                      (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int)) test+            , test' "(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)"+                      (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)) test+-}++            , test' "B.ByteString" (test :: T B.ByteString) test+            , test' "L.ByteString" (test :: T L.ByteString) test+            ]++        , testGroup "Invariants" $ map (uncurry testProperty)+            [ ("B.ByteString invariant",   p (prop_invariant :: B B.ByteString                 ))+            , ("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString]               ))+            , ("L.ByteString invariant",   p (prop_invariant :: B L.ByteString                 ))+            , ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString]               ))+            ]+        ]