binary 0.6.2.0 → 0.6.3.0

raw patch · 10 files changed

+900/−575 lines, 10 filesdep +ghc-primPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ghc-prim

API changes (from Hackage documentation)

Files

• .hgignore +5/−0
• benchmarks/Builder.hs +7/−7
• benchmarks/Get.hs +3/−1
• binary.cabal +10/−6
• src/Data/Binary.hs +32/−514
• src/Data/Binary/Class.hs +542/−0
• src/Data/Binary/Generic.hs +134/−0
• tests/Action.hs +106/−0
• tests/Arbitrary.hs +54/−0
• tests/QC.hs +7/−47

@@ -0,0 +1,5 @@+^dist$+syntax: glob+.*.swp+*~+\#*

@@ -24,14 +24,14 @@ instance NFData S.ByteString #endif -data B = forall a. NFData a => B a--instance NFData B where-    rnf (B b) = rnf b- main :: IO ()-main = defaultMainWith defaultConfig-    (liftIO . evaluate $ rnf [B word8s, B smallByteString, B largeByteString])+main = do+  evaluate $ rnf+    [ rnf word8s+    , rnf smallByteString+    , rnf largeByteString+    ]+  defaultMain     [ -- Test GHC loop optimization of continuation based code.       bench "[Word8]" $ whnf (run . fromWord8s) word8s 

@@ -22,8 +22,10 @@ import Data.Binary.Get import Data.Binary ( get ) -#if __GLASGOW_HASKELL__ < 706+#if !MIN_VERSION_bytestring(0,10,0) instance NFData S.ByteString+instance NFData L.ByteString where+  rnf = rnf . L.toChunks #endif  main :: IO ()

@@ -1,12 +1,12 @@ name:            binary-version:         0.6.2.0+version:         0.6.3.0 license:         BSD3 license-file:    LICENSE author:          Lennart Kolmodin <kolmodin@gmail.com> maintainer:      Lennart Kolmodin, Don Stewart <dons@galois.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, +                 Haskell values may be encoded to and from binary formats,                  written to disk as binary, or sent over the network.                  Serialisation speeds of over 1 G\/sec have been observed,                  so this library should be suitable for high performance@@ -36,10 +36,15 @@                    Data.Binary.Builder,                    Data.Binary.Builder.Internal -  other-modules:   Data.Binary.Builder.Base+  other-modules:   Data.Binary.Builder.Base,+                   Data.Binary.Class -  extensions:      CPP,-                   FlexibleContexts+  if impl(ghc >= 7.2.1)+    cpp-options: -DGENERICS+    other-modules: Data.Binary.Generic+    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 @@ -97,4 +102,3 @@     deepseq,     mtl   ghc-options: -O2-

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif@@ -26,15 +26,24 @@ -- or compiler version. For example, data encoded using the 'Binary' class -- could be written from GHC, and read back in Hugs. --+-- You can either provide a hand written implementation of the 'Binary' class,+-- or derive one using the generic support. See 'GBinary'.+-- -----------------------------------------------------------------------------  module Data.Binary (      -- * The Binary class       Binary(..)-+    -- ** Example     -- $example +#ifdef GENERICS+    -- * Generic support+    -- $generics+    , GBinary(..)+#endif+     -- * The Get and Put monads     , Get     , Put@@ -61,63 +70,18 @@  import Data.Word +import Data.Binary.Class import Data.Binary.Put import Data.Binary.Get--import Control.Monad-import Foreign+#ifdef GENERICS+import Data.Binary.Generic ()+#endif  import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L -import Data.Char    (chr,ord)-import Data.List    (unfoldr)---- And needed for the instances:-import qualified Data.ByteString as B-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 Data.Array.Unboxed------- This isn't available in older Hugs or older GHC----#if __GLASGOW_HASKELL__ >= 606-import qualified Data.Sequence as Seq-import qualified Data.Foldable as Fold-#endif- ------------------------------------------------------------------------ --- | The 'Binary' class provides 'put' and 'get', methods to encode and--- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and--- 'Show' classes for textual representation of Haskell types, and is--- suitable for serialising Haskell values to disk, over the network.------ For decoding and generating simple external binary formats (e.g. C--- structures), Binary may be used, but in general is not suitable--- for complex protocols. Instead use the 'Put' and 'Get' primitives--- directly.------ Instances of Binary should satisfy the following property:------ > decode . encode == id------ That is, the 'get' and 'put' methods should be the inverse of each--- other. A range of instances are provided for basic Haskell types. ----class Binary t where-    -- | Encode a value in the Put monad.-    put :: t -> Put-    -- | Decode a value in the Get monad-    get :: Get t- -- $example -- To serialise a custom type, an instance of Binary for that type is -- required. For example, suppose we have a data structure:@@ -137,7 +101,7 @@ -- >                                  put s -- >                                  put e1 -- >                                  put e2--- > +-- > -- >       get = do t <- get :: Get Word8 -- >                case t of -- >                     0 -> do i <- get@@ -152,44 +116,12 @@ -- -- We can simplify the writing of 'get' instances using monadic -- combinators:--- +-- -- >       get = do tag <- getWord8 -- >                case tag of -- >                    0 -> liftM  IntE get -- >                    1 -> liftM3 OpE  get get get ----- The generation of Binary instances has been automated by a script--- using Scrap Your Boilerplate generics. Use the script here:---  <http://darcs.haskell.org/binary/tools/derive/BinaryDerive.hs>.------ To derive the instance for a type, load this script into GHCi, and--- bring your type into scope. Your type can then have its Binary--- instances derived as follows:------ > $ ghci -fglasgow-exts BinaryDerive.hs--- > *BinaryDerive> :l Example.hs--- > *Main> deriveM (undefined :: Drinks)--- >--- > instance Binary Main.Drinks where--- >      put (Beer a) = putWord8 0 >> put a--- >      put Coffee = putWord8 1--- >      put Tea = putWord8 2--- >      put EnergyDrink = putWord8 3--- >      put Water = putWord8 4--- >      put Wine = putWord8 5--- >      put Whisky = putWord8 6--- >      get = do--- >        tag_ <- getWord8--- >        case tag_ of--- >          0 -> get >>= \a -> return (Beer a)--- >          1 -> return Coffee--- >          2 -> return Tea--- >          3 -> return EnergyDrink--- >          4 -> return Water--- >          5 -> return Wine--- >          6 -> return Whisky--- >--- -- To serialise this to a bytestring, we use 'encode', which packs the -- data structure into a binary format, in a lazy bytestring --@@ -287,435 +219,21 @@ -- lazyGet :: (Binary a) => Get a -- lazyGet = fmap decode get ---------------------------------------------------------------------------- Simple instances---- The () type need never be written to disk: values of singleton type--- can be reconstructed from the type alone-instance Binary () where-    put ()  = return ()-    get     = return ()---- Bools are encoded as a byte in the range 0 .. 1-instance Binary Bool where-    put     = putWord8 . fromIntegral . fromEnum-    get     = liftM (toEnum . fromIntegral) getWord8---- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2-instance Binary Ordering where-    put     = putWord8 . fromIntegral . fromEnum-    get     = liftM (toEnum . fromIntegral) getWord8----------------------------------------------------------------------------- Words and Ints---- Words8s are written as bytes-instance Binary Word8 where-    put     = putWord8-    get     = getWord8---- Words16s are written as 2 bytes in big-endian (network) order-instance Binary Word16 where-    put     = putWord16be-    get     = getWord16be---- Words32s are written as 4 bytes in big-endian (network) order-instance Binary Word32 where-    put     = putWord32be-    get     = getWord32be---- Words64s are written as 8 bytes in big-endian (network) order-instance Binary Word64 where-    put     = putWord64be-    get     = getWord64be---- Int8s are written as a single byte.-instance Binary Int8 where-    put i   = put (fromIntegral i :: Word8)-    get     = liftM fromIntegral (get :: Get Word8)---- Int16s are written as a 2 bytes in big endian format-instance Binary Int16 where-    put i   = put (fromIntegral i :: Word16)-    get     = liftM fromIntegral (get :: Get Word16)---- Int32s are written as a 4 bytes in big endian format-instance Binary Int32 where-    put i   = put (fromIntegral i :: Word32)-    get     = liftM fromIntegral (get :: Get Word32)---- Int64s are written as a 4 bytes in big endian format-instance Binary Int64 where-    put i   = put (fromIntegral i :: Word64)-    get     = liftM fromIntegral (get :: Get Word64)------------------------------------------------------------------------------ Words are are written as Word64s, that is, 8 bytes in big endian format-instance Binary Word where-    put i   = put (fromIntegral i :: Word64)-    get     = liftM fromIntegral (get :: Get Word64)---- Ints are are written as Int64s, that is, 8 bytes in big endian format-instance Binary Int where-    put i   = put (fromIntegral i :: Int64)-    get     = liftM fromIntegral (get :: Get Int64)----------------------------------------------------------------------------- --- Portable, and pretty efficient, serialisation of Integer------- Fixed-size type for a subset of Integer-type SmallInt = Int32---- Integers are encoded in two ways: if they fit inside a SmallInt,--- they're written as a byte tag, and that value.  If the Integer value--- is too large to fit in a SmallInt, it is written as a byte array,--- along with a sign and length field.--instance Binary Integer where--    {-# INLINE put #-}-    put n | n >= lo && n <= hi = do-        putWord8 0-        put (fromIntegral n :: SmallInt)  -- fast path-     where-        lo = fromIntegral (minBound :: SmallInt) :: Integer-        hi = fromIntegral (maxBound :: SmallInt) :: Integer--    put n = do-        putWord8 1-        put sign-        put (unroll (abs n))         -- unroll the bytes-     where-        sign = fromIntegral (signum n) :: Word8--    {-# INLINE get #-}-    get = do-        tag <- get :: Get Word8-        case tag of-            0 -> liftM fromIntegral (get :: Get SmallInt)-            _ -> do sign  <- get-                    bytes <- get-                    let v = roll bytes-                    return $! if sign == (1 :: Word8) then v else - v------- Fold and unfold an Integer to and from a list of its bytes----unroll :: Integer -> [Word8]-unroll = unfoldr step-  where-    step 0 = Nothing-    step i = Just (fromIntegral i, i `shiftR` 8)--roll :: [Word8] -> Integer-roll   = foldr unstep 0-  where-    unstep b a = a `shiftL` 8 .|. fromIntegral b--{-------- An efficient, raw serialisation for Integer (GHC only)------- TODO  This instance is not architecture portable.  GMP stores numbers as--- arrays of machine sized words, so the byte format is not portable across--- architectures with different endianness and word size.--import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)-import GHC.Base     hiding (ord, chr)-import GHC.Prim-import GHC.Ptr (Ptr(..))-import GHC.IOBase (IO(..))--instance Binary Integer where-    put (S# i)    = putWord8 0 >> put (I# i)-    put (J# s ba) = do-        putWord8 1-        put (I# s)-        put (BA ba)--    get = do-        b <- getWord8-        case b of-            0 -> do (I# i#) <- get-                    return (S# i#)-            _ -> do (I# s#) <- get-                    (BA a#) <- get-                    return (J# s# a#)--instance Binary ByteArray where--    -- Pretty safe.-    put (BA ba) =-        let sz   = sizeofByteArray# ba   -- (primitive) in *bytes*-            addr = byteArrayContents# ba-            bs   = unsafePackAddress (I# sz) addr-        in put bs   -- write as a ByteString. easy, yay!--    -- Pretty scary. Should be quick though-    get = do-        (fp, off, n@(I# sz)) <- liftM toForeignPtr get      -- so decode a ByteString-        assert (off == 0) $ return $ unsafePerformIO $ do-            (MBA arr) <- newByteArray sz                    -- and copy it into a ByteArray#-            let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?-            withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)-            freezeByteArray arr---- wrapper for ByteArray#-data ByteArray = BA  {-# UNPACK #-} !ByteArray#-data MBA       = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)--newByteArray :: Int# -> IO MBA-newByteArray sz = IO $ \s ->-  case newPinnedByteArray# sz s of { (# s', arr #) ->-  (# s', MBA arr #) }--freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray-freezeByteArray arr = IO $ \s ->-  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->-  (# s', BA arr' #) }---}--instance (Binary a,Integral a) => Binary (R.Ratio a) where-    put r = put (R.numerator r) >> put (R.denominator r)-    get = liftM2 (R.%) get get------------------------------------------------------------------------------ Char is serialised as UTF-8-instance Binary Char where-    put a | c <= 0x7f     = put (fromIntegral c :: Word8)-          | c <= 0x7ff    = do put (0xc0 .|. y)-                               put (0x80 .|. z)-          | c <= 0xffff   = do put (0xe0 .|. x)-                               put (0x80 .|. y)-                               put (0x80 .|. z)-          | c <= 0x10ffff = do put (0xf0 .|. w)-                               put (0x80 .|. x)-                               put (0x80 .|. y)-                               put (0x80 .|. z)-          | otherwise     = error "Not a valid Unicode code point"-     where-        c = ord a-        z, y, x, w :: Word8-        z = fromIntegral (c           .&. 0x3f)-        y = fromIntegral (shiftR c 6  .&. 0x3f)-        x = fromIntegral (shiftR c 12 .&. 0x3f)-        w = fromIntegral (shiftR c 18 .&. 0x7)--    get = do-        let getByte = liftM (fromIntegral :: Word8 -> Int) get-            shiftL6 = flip shiftL 6 :: Int -> Int-        w <- getByte-        r <- case () of-                _ | w < 0x80  -> return w-                  | w < 0xe0  -> do-                                    x <- liftM (xor 0x80) getByte-                                    return (x .|. shiftL6 (xor 0xc0 w))-                  | w < 0xf0  -> do-                                    x <- liftM (xor 0x80) getByte-                                    y <- liftM (xor 0x80) getByte-                                    return (y .|. shiftL6 (x .|. shiftL6-                                            (xor 0xe0 w)))-                  | otherwise -> do-                                x <- liftM (xor 0x80) getByte-                                y <- liftM (xor 0x80) getByte-                                z <- liftM (xor 0x80) getByte-                                return (z .|. shiftL6 (y .|. shiftL6-                                        (x .|. shiftL6 (xor 0xf0 w))))-        return $! chr r----------------------------------------------------------------------------- Instances for the first few tuples--instance (Binary a, Binary b) => Binary (a,b) where-    put (a,b)           = put a >> put b-    get                 = liftM2 (,) get get--instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where-    put (a,b,c)         = put a >> put b >> put c-    get                 = liftM3 (,,) get get get--instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where-    put (a,b,c,d)       = put a >> put b >> put c >> put d-    get                 = liftM4 (,,,) get get get get--instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where-    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:-----instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)-        => Binary (a,b,c,d,e,f) where-    put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))-    get                 = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)--instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)-        => Binary (a,b,c,d,e,f,g) where-    put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))-    get                 = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)--instance (Binary a, Binary b, Binary c, Binary d, Binary e,-          Binary f, Binary g, Binary h)-        => Binary (a,b,c,d,e,f,g,h) where-    put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))-    get                   = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)--instance (Binary a, Binary b, Binary c, Binary d, Binary e,-          Binary f, Binary g, Binary h, Binary i)-        => Binary (a,b,c,d,e,f,g,h,i) where-    put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))-    get                     = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)--instance (Binary a, Binary b, Binary c, Binary d, Binary e,-          Binary f, Binary g, Binary h, Binary i, Binary j)-        => Binary (a,b,c,d,e,f,g,h,i,j) where-    put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))-    get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)----------------------------------------------------------------------------- Container types--instance Binary a => Binary [a] where-    put l  = put (length l) >> mapM_ put l-    get    = do n <- get :: Get Int-                getMany n---- | 'getMany n' get 'n' elements in order, without blowing the stack.-getMany :: Binary a => Int -> Get [a]-getMany n = go [] n- where-    go xs 0 = return $! reverse xs-    go xs i = do x <- get-                 -- we must seq x to avoid stack overflows due to laziness in-                 -- (>>=)-                 x `seq` go (x:xs) (i-1)-{-# INLINE getMany #-}--instance (Binary a) => Binary (Maybe a) where-    put Nothing  = putWord8 0-    put (Just x) = putWord8 1 >> put x-    get = do-        w <- getWord8-        case w of-            0 -> return Nothing-            _ -> liftM Just get--instance (Binary a, Binary b) => Binary (Either a b) where-    put (Left  a) = putWord8 0 >> put a-    put (Right b) = putWord8 1 >> put b-    get = do-        w <- getWord8-        case w of-            0 -> liftM Left  get-            _ -> liftM Right get----------------------------------------------------------------------------- ByteStrings (have specially efficient instances)--instance Binary B.ByteString where-    put bs = do put (B.length bs)-                putByteString bs-    get    = get >>= getByteString------- Using old versions of fps, this is a type synonym, and non portable--- --- Requires 'flexible instances'----instance Binary ByteString where-    put bs = do put (fromIntegral (L.length bs) :: Int)-                putLazyByteString bs-    get    = get >>= getLazyByteString----------------------------------------------------------------------------- Maps and Sets--instance (Ord a, Binary a) => Binary (Set.Set a) where-    put s = put (Set.size s) >> mapM_ put (Set.toAscList s)-    get   = liftM Set.fromDistinctAscList get--instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where-    put m = put (Map.size m) >> mapM_ put (Map.toAscList m)-    get   = liftM Map.fromDistinctAscList get--instance Binary IntSet.IntSet where-    put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s)-    get   = liftM IntSet.fromDistinctAscList get--instance (Binary e) => Binary (IntMap.IntMap e) where-    put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m)-    get   = liftM IntMap.fromDistinctAscList get----------------------------------------------------------------------------- Queues and Sequences--#if __GLASGOW_HASKELL__ >= 606------ This is valid Hugs, but you need the most recent Hugs+-- $generics ----instance (Binary e) => Binary (Seq.Seq e) where-    put s = put (Seq.length s) >> Fold.mapM_ put s-    get = do n <- get :: Get Int-             rep Seq.empty n get-      where rep xs 0 _ = return $! xs-            rep xs n g = xs `seq` n `seq` do-                           x <- g-                           rep (xs Seq.|> x) (n-1) g--#endif----------------------------------------------------------------------------- Floating point--instance Binary Double where-    put d = put (decodeFloat d)-    get   = liftM2 encodeFloat get get--instance Binary Float where-    put f = put (decodeFloat f)-    get   = liftM2 encodeFloat get get----------------------------------------------------------------------------- Trees--instance (Binary e) => Binary (T.Tree e) where-    put (T.Node r s) = put r >> put s-    get = liftM2 T.Node get get----------------------------------------------------------------------------- Arrays--instance (Binary i, Ix i, Binary e) => Binary (Array i e) where-    put a = do-        put (bounds a)-        put (rangeSize $ bounds a) -- write the length-        mapM_ put (elems a)        -- now the elems.-    get = do-        bs <- get-        n  <- get                  -- read the length-        xs <- getMany n            -- now the elems.-        return (listArray bs xs)-+-- Beginning with GHC 7.2, it is possible to use binary serialization+-- without writing any instance boilerplate code. ----- The IArray UArray e constraint is non portable. Requires flexible instances+-- > {-# LANGUAGE DeriveGeneric #-}+-- >+-- > import Data.Binary+-- > import GHC.Generics (Generic)+-- >+-- > data Foo = Foo+-- >          deriving (Generic)+-- >+-- > -- GHC will automatically fill out the instance+-- > instance Binary Foo ---instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where-    put a = do-        put (bounds a)-        put (rangeSize $ bounds a) -- now write the length-        mapM_ put (elems a)-    get = do-        bs <- get-        n  <- get-        xs <- getMany n-        return (listArray bs xs)+-- This mechanism makes use of GHC's efficient built-in generics+-- support.

@@ -0,0 +1,542 @@+{-# LANGUAGE CPP, FlexibleContexts #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+#ifdef GENERICS+{-# LANGUAGE DefaultSignatures #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      : Data.Binary.Class+-- Copyright   : Lennart Kolmodin+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Lennart Kolmodin <kolmodin@gmail.com>+-- Stability   : unstable+-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances+--+-- Typeclass and instances for binary serialization.+--+-----------------------------------------------------------------------------++module Data.Binary.Class (++    -- * The Binary class+      Binary(..)++#ifdef GENERICS+    -- * Support for generics+    , GBinary(..)+#endif++    ) where++import Data.Word++import Data.Binary.Put+import Data.Binary.Get++import Control.Monad+import Foreign++import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as L++import Data.Char    (chr,ord)+import Data.List    (unfoldr)++-- And needed for the instances:+import qualified Data.ByteString as B+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 Data.Array.Unboxed++#ifdef GENERICS+import GHC.Generics+#endif++--+-- This isn't available in older Hugs or older GHC+--+#if __GLASGOW_HASKELL__ >= 606+import qualified Data.Sequence as Seq+import qualified Data.Foldable as Fold+#endif++------------------------------------------------------------------------++#ifdef GENERICS+class GBinary f where+    gput :: f t -> Put+    gget :: Get (f t)+#endif++-- | The 'Binary' class provides 'put' and 'get', methods to encode and+-- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and+-- 'Show' classes for textual representation of Haskell types, and is+-- suitable for serialising Haskell values to disk, over the network.+--+-- For decoding and generating simple external binary formats (e.g. C+-- structures), Binary may be used, but in general is not suitable+-- for complex protocols. Instead use the 'Put' and 'Get' primitives+-- directly.+--+-- Instances of Binary should satisfy the following property:+--+-- > decode . encode == id+--+-- That is, the 'get' and 'put' methods should be the inverse of each+-- other. A range of instances are provided for basic Haskell types.+--+class Binary t where+    -- | Encode a value in the Put monad.+    put :: t -> Put+    -- | Decode a value in the Get monad+    get :: Get t++#ifdef GENERICS+    default put :: (Generic t, GBinary (Rep t)) => t -> Put+    put = gput . from++    default get :: (Generic t, GBinary (Rep t)) => Get t+    get = to `fmap` gget+#endif++------------------------------------------------------------------------+-- Simple instances++-- The () type need never be written to disk: values of singleton type+-- can be reconstructed from the type alone+instance Binary () where+    put ()  = return ()+    get     = return ()++-- Bools are encoded as a byte in the range 0 .. 1+instance Binary Bool where+    put     = putWord8 . fromIntegral . fromEnum+    get     = liftM (toEnum . fromIntegral) getWord8++-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2+instance Binary Ordering where+    put     = putWord8 . fromIntegral . fromEnum+    get     = liftM (toEnum . fromIntegral) getWord8++------------------------------------------------------------------------+-- Words and Ints++-- Words8s are written as bytes+instance Binary Word8 where+    put     = putWord8+    get     = getWord8++-- Words16s are written as 2 bytes in big-endian (network) order+instance Binary Word16 where+    put     = putWord16be+    get     = getWord16be++-- Words32s are written as 4 bytes in big-endian (network) order+instance Binary Word32 where+    put     = putWord32be+    get     = getWord32be++-- Words64s are written as 8 bytes in big-endian (network) order+instance Binary Word64 where+    put     = putWord64be+    get     = getWord64be++-- Int8s are written as a single byte.+instance Binary Int8 where+    put i   = put (fromIntegral i :: Word8)+    get     = liftM fromIntegral (get :: Get Word8)++-- Int16s are written as a 2 bytes in big endian format+instance Binary Int16 where+    put i   = put (fromIntegral i :: Word16)+    get     = liftM fromIntegral (get :: Get Word16)++-- Int32s are written as a 4 bytes in big endian format+instance Binary Int32 where+    put i   = put (fromIntegral i :: Word32)+    get     = liftM fromIntegral (get :: Get Word32)++-- Int64s are written as a 4 bytes in big endian format+instance Binary Int64 where+    put i   = put (fromIntegral i :: Word64)+    get     = liftM fromIntegral (get :: Get Word64)++------------------------------------------------------------------------++-- Words are are written as Word64s, that is, 8 bytes in big endian format+instance Binary Word where+    put i   = put (fromIntegral i :: Word64)+    get     = liftM fromIntegral (get :: Get Word64)++-- Ints are are written as Int64s, that is, 8 bytes in big endian format+instance Binary Int where+    put i   = put (fromIntegral i :: Int64)+    get     = liftM fromIntegral (get :: Get Int64)++------------------------------------------------------------------------+--+-- Portable, and pretty efficient, serialisation of Integer+--++-- Fixed-size type for a subset of Integer+type SmallInt = Int32++-- Integers are encoded in two ways: if they fit inside a SmallInt,+-- they're written as a byte tag, and that value.  If the Integer value+-- is too large to fit in a SmallInt, it is written as a byte array,+-- along with a sign and length field.++instance Binary Integer where++    {-# INLINE put #-}+    put n | n >= lo && n <= hi = do+        putWord8 0+        put (fromIntegral n :: SmallInt)  -- fast path+     where+        lo = fromIntegral (minBound :: SmallInt) :: Integer+        hi = fromIntegral (maxBound :: SmallInt) :: Integer++    put n = do+        putWord8 1+        put sign+        put (unroll (abs n))         -- unroll the bytes+     where+        sign = fromIntegral (signum n) :: Word8++    {-# INLINE get #-}+    get = do+        tag <- get :: Get Word8+        case tag of+            0 -> liftM fromIntegral (get :: Get SmallInt)+            _ -> do sign  <- get+                    bytes <- get+                    let v = roll bytes+                    return $! if sign == (1 :: Word8) then v else - v++--+-- Fold and unfold an Integer to and from a list of its bytes+--+unroll :: Integer -> [Word8]+unroll = unfoldr step+  where+    step 0 = Nothing+    step i = Just (fromIntegral i, i `shiftR` 8)++roll :: [Word8] -> Integer+roll   = foldr unstep 0+  where+    unstep b a = a `shiftL` 8 .|. fromIntegral b++{-++--+-- An efficient, raw serialisation for Integer (GHC only)+--++-- TODO  This instance is not architecture portable.  GMP stores numbers as+-- arrays of machine sized words, so the byte format is not portable across+-- architectures with different endianness and word size.++import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)+import GHC.Base     hiding (ord, chr)+import GHC.Prim+import GHC.Ptr (Ptr(..))+import GHC.IOBase (IO(..))++instance Binary Integer where+    put (S# i)    = putWord8 0 >> put (I# i)+    put (J# s ba) = do+        putWord8 1+        put (I# s)+        put (BA ba)++    get = do+        b <- getWord8+        case b of+            0 -> do (I# i#) <- get+                    return (S# i#)+            _ -> do (I# s#) <- get+                    (BA a#) <- get+                    return (J# s# a#)++instance Binary ByteArray where++    -- Pretty safe.+    put (BA ba) =+        let sz   = sizeofByteArray# ba   -- (primitive) in *bytes*+            addr = byteArrayContents# ba+            bs   = unsafePackAddress (I# sz) addr+        in put bs   -- write as a ByteString. easy, yay!++    -- Pretty scary. Should be quick though+    get = do+        (fp, off, n@(I# sz)) <- liftM toForeignPtr get      -- so decode a ByteString+        assert (off == 0) $ return $ unsafePerformIO $ do+            (MBA arr) <- newByteArray sz                    -- and copy it into a ByteArray#+            let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?+            withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)+            freezeByteArray arr++-- wrapper for ByteArray#+data ByteArray = BA  {-# UNPACK #-} !ByteArray#+data MBA       = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)++newByteArray :: Int# -> IO MBA+newByteArray sz = IO $ \s ->+  case newPinnedByteArray# sz s of { (# s', arr #) ->+  (# s', MBA arr #) }++freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray+freezeByteArray arr = IO $ \s ->+  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->+  (# s', BA arr' #) }++-}++instance (Binary a,Integral a) => Binary (R.Ratio a) where+    put r = put (R.numerator r) >> put (R.denominator r)+    get = liftM2 (R.%) get get++------------------------------------------------------------------------++-- Char is serialised as UTF-8+instance Binary Char where+    put a | c <= 0x7f     = put (fromIntegral c :: Word8)+          | c <= 0x7ff    = do put (0xc0 .|. y)+                               put (0x80 .|. z)+          | c <= 0xffff   = do put (0xe0 .|. x)+                               put (0x80 .|. y)+                               put (0x80 .|. z)+          | c <= 0x10ffff = do put (0xf0 .|. w)+                               put (0x80 .|. x)+                               put (0x80 .|. y)+                               put (0x80 .|. z)+          | otherwise     = error "Not a valid Unicode code point"+     where+        c = ord a+        z, y, x, w :: Word8+        z = fromIntegral (c           .&. 0x3f)+        y = fromIntegral (shiftR c 6  .&. 0x3f)+        x = fromIntegral (shiftR c 12 .&. 0x3f)+        w = fromIntegral (shiftR c 18 .&. 0x7)++    get = do+        let getByte = liftM (fromIntegral :: Word8 -> Int) get+            shiftL6 = flip shiftL 6 :: Int -> Int+        w <- getByte+        r <- case () of+                _ | w < 0x80  -> return w+                  | w < 0xe0  -> do+                                    x <- liftM (xor 0x80) getByte+                                    return (x .|. shiftL6 (xor 0xc0 w))+                  | w < 0xf0  -> do+                                    x <- liftM (xor 0x80) getByte+                                    y <- liftM (xor 0x80) getByte+                                    return (y .|. shiftL6 (x .|. shiftL6+                                            (xor 0xe0 w)))+                  | otherwise -> do+                                x <- liftM (xor 0x80) getByte+                                y <- liftM (xor 0x80) getByte+                                z <- liftM (xor 0x80) getByte+                                return (z .|. shiftL6 (y .|. shiftL6+                                        (x .|. shiftL6 (xor 0xf0 w))))+        return $! chr r++------------------------------------------------------------------------+-- Instances for the first few tuples++instance (Binary a, Binary b) => Binary (a,b) where+    put (a,b)           = put a >> put b+    get                 = liftM2 (,) get get++instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where+    put (a,b,c)         = put a >> put b >> put c+    get                 = liftM3 (,,) get get get++instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where+    put (a,b,c,d)       = put a >> put b >> put c >> put d+    get                 = liftM4 (,,,) get get get get++instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where+    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:+--++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)+        => Binary (a,b,c,d,e,f) where+    put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))+    get                 = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)++instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)+        => Binary (a,b,c,d,e,f,g) where+    put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))+    get                 = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+          Binary f, Binary g, Binary h)+        => Binary (a,b,c,d,e,f,g,h) where+    put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))+    get                   = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+          Binary f, Binary g, Binary h, Binary i)+        => Binary (a,b,c,d,e,f,g,h,i) where+    put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))+    get                     = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)++instance (Binary a, Binary b, Binary c, Binary d, Binary e,+          Binary f, Binary g, Binary h, Binary i, Binary j)+        => Binary (a,b,c,d,e,f,g,h,i,j) where+    put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))+    get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)++------------------------------------------------------------------------+-- Container types++instance Binary a => Binary [a] where+    put l  = put (length l) >> mapM_ put l+    get    = do n <- get :: Get Int+                getMany n++-- | 'getMany n' get 'n' elements in order, without blowing the stack.+getMany :: Binary a => Int -> Get [a]+getMany n = go [] n+ where+    go xs 0 = return $! reverse xs+    go xs i = do x <- get+                 -- we must seq x to avoid stack overflows due to laziness in+                 -- (>>=)+                 x `seq` go (x:xs) (i-1)+{-# INLINE getMany #-}++instance (Binary a) => Binary (Maybe a) where+    put Nothing  = putWord8 0+    put (Just x) = putWord8 1 >> put x+    get = do+        w <- getWord8+        case w of+            0 -> return Nothing+            _ -> liftM Just get++instance (Binary a, Binary b) => Binary (Either a b) where+    put (Left  a) = putWord8 0 >> put a+    put (Right b) = putWord8 1 >> put b+    get = do+        w <- getWord8+        case w of+            0 -> liftM Left  get+            _ -> liftM Right get++------------------------------------------------------------------------+-- ByteStrings (have specially efficient instances)++instance Binary B.ByteString where+    put bs = do put (B.length bs)+                putByteString bs+    get    = get >>= getByteString++--+-- Using old versions of fps, this is a type synonym, and non portable+--+-- Requires 'flexible instances'+--+instance Binary ByteString where+    put bs = do put (fromIntegral (L.length bs) :: Int)+                putLazyByteString bs+    get    = get >>= getLazyByteString++------------------------------------------------------------------------+-- Maps and Sets++instance (Ord a, Binary a) => Binary (Set.Set a) where+    put s = put (Set.size s) >> mapM_ put (Set.toAscList s)+    get   = liftM Set.fromDistinctAscList get++instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where+    put m = put (Map.size m) >> mapM_ put (Map.toAscList m)+    get   = liftM Map.fromDistinctAscList get++instance Binary IntSet.IntSet where+    put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s)+    get   = liftM IntSet.fromDistinctAscList get++instance (Binary e) => Binary (IntMap.IntMap e) where+    put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m)+    get   = liftM IntMap.fromDistinctAscList get++------------------------------------------------------------------------+-- Queues and Sequences++#if __GLASGOW_HASKELL__ >= 606+--+-- This is valid Hugs, but you need the most recent Hugs+--++instance (Binary e) => Binary (Seq.Seq e) where+    put s = put (Seq.length s) >> Fold.mapM_ put s+    get = do n <- get :: Get Int+             rep Seq.empty n get+      where rep xs 0 _ = return $! xs+            rep xs n g = xs `seq` n `seq` do+                           x <- g+                           rep (xs Seq.|> x) (n-1) g++#endif++------------------------------------------------------------------------+-- Floating point++instance Binary Double where+    put d = put (decodeFloat d)+    get   = liftM2 encodeFloat get get++instance Binary Float where+    put f = put (decodeFloat f)+    get   = liftM2 encodeFloat get get++------------------------------------------------------------------------+-- Trees++instance (Binary e) => Binary (T.Tree e) where+    put (T.Node r s) = put r >> put s+    get = liftM2 T.Node get get++------------------------------------------------------------------------+-- Arrays++instance (Binary i, Ix i, Binary e) => Binary (Array i e) where+    put a = do+        put (bounds a)+        put (rangeSize $ bounds a) -- write the length+        mapM_ put (elems a)        -- now the elems.+    get = do+        bs <- get+        n  <- get                  -- read the length+        xs <- getMany n            -- now the elems.+        return (listArray bs xs)++--+-- The IArray UArray e constraint is non portable. Requires flexible instances+--+instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where+    put a = do+        put (bounds a)+        put (rangeSize $ bounds a) -- now write the length+        mapM_ put (elems a)+    get = do+        bs <- get+        n  <- get+        xs <- getMany n+        return (listArray bs xs)

@@ -0,0 +1,134 @@+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,+    ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Binary.Generic+-- Copyright   : Bryan O'Sullivan+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Bryan O'Sullivan <bos@serpentine.com>+-- Stability   : unstable+-- Portability : Only works with GHC 7.2 and newer+--+-- Instances for supporting GHC generics.+--+-----------------------------------------------------------------------------+module Data.Binary.Generic+    (+    ) where++import Control.Applicative+import Data.Binary.Class+import Data.Binary.Get+import Data.Binary.Put+import Data.Bits+import Data.Word+import GHC.Generics++-- Type without constructors+instance GBinary V1 where+    gput _ = return ()+    gget   = return undefined++-- Constructor without arguments+instance GBinary U1 where+    gput U1 = return ()+    gget    = return U1++-- Product: constructor with parameters+instance (GBinary a, GBinary b) => GBinary (a :*: b) where+    gput (x :*: y) = gput x >> gput y+    gget = (:*:) <$> gget <*> gget++-- Metadata (constructor name, etc)+instance GBinary a => GBinary (M1 i c a) where+    gput = gput . unM1+    gget = M1 <$> gget++-- Constants, additional parameters, and rank-1 recursion+instance Binary a => GBinary (K1 i a) where+    gput = put . unK1+    gget = K1 <$> get++-- Borrowed from the cereal package.++-- The following GBinary 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 it has 2^16 constructors or less it will+-- use two bytes, and so on till 2^64-1.++#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)+#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)+#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)++instance ( GSum     a, GSum     b+         , GBinary a, GBinary b+         , SumSize    a, SumSize    b) => GBinary (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 #-}++    gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)+         | otherwise = sizeError "decode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word64)+    {-# INLINE gget #-}++sizeError :: Show size => String -> size -> error+sizeError s size =+    error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"++------------------------------------------------------------------------++checkGetSum :: (Ord word, Num word, Bits word, GSum f)+            => word -> word -> Get (f a)+checkGetSum size code | code < size = getSum code size+                      | otherwise   = fail "Unknown encoding for constructor"+{-# INLINE checkGetSum #-}++class GSum f where+    getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)+    putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put++instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where+    getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL+                       | otherwise    = R1 <$> getSum (code - sizeL) sizeR+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL+    {-# INLINE getSum #-}++    putSum !code !size s = case s of+                             L1 x -> putSum code           sizeL x+                             R1 x -> putSum (code + sizeL) sizeR x+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL+    {-# INLINE putSum #-}++instance GBinary a => GSum (C1 c a) where+    getSum _ _ = gget+    {-# INLINE getSum #-}++    putSum !code _ x = put code *> gput x+    {-# INLINE putSum #-}++------------------------------------------------------------------------++class SumSize f where+    sumSize :: Tagged f Word64++newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}++instance (SumSize a, SumSize b) => SumSize (a :+: b) where+    sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) ++                       unTagged (sumSize :: Tagged b Word64)++instance SumSize (C1 c a) where+    sumSize = Tagged 1

@@ -0,0 +1,106 @@+{-# LANGUAGE BangPatterns #-}+module Action where++import Control.Applicative+import Test.QuickCheck++import qualified Data.ByteString.Lazy as L++import qualified Data.Binary.Get as Binary++import Arbitrary()++data Action+  = GetByteString Int+  | Try [Action] [Action]+  | BytesRead+  | Fail+  deriving (Show, Eq)++instance Arbitrary Action where+  shrink action =+    case action of+      GetByteString n -> [ GetByteString n' | n' <- shrink n, n > 0 ]+      BytesRead -> []+      Fail -> []+      Try a b ->+        [ Try a' b' | a' <- shrink a, b' <- shrink b ]+        ++ [ Try a' b | a' <- shrink a ]+        ++ [ Try a b' | b' <- shrink b ]++willFail :: [Action] -> Bool+willFail [] = False+willFail (x:xs) =+  case x of+    GetByteString _ -> willFail xs+    Try a b -> (willFail a && willFail b) || willFail xs+    BytesRead -> willFail xs+    Fail -> True++max_len :: [Action] -> Int+max_len [] = 0+max_len (x:xs) =+  case x of+    GetByteString n -> n + max_len xs+    BytesRead -> max_len xs+    Fail -> 0+    Try a b -> max (max_len a) (max_len b) + max_len xs++actual_len :: [Action] -> Maybe Int+actual_len = go 0+  where+  go !s [] = Just s+  go !s (x:xs) =+    case x of+      GetByteString n -> go (s+n) xs+      Fail -> Nothing+      BytesRead -> go s xs+      Try a b | not (willFail a) -> liftA2 (+) (go s a) (actual_len xs)+              | not (willFail b) -> liftA2 (+) (go s b) (actual_len xs)+              | otherwise -> Nothing++-- | 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 shrink $ \ actions ->+    forAll arbitrary $ \ lbs ->+      L.length lbs >= fromIntegral (max_len actions) ==>+        case Binary.runGet (eval actions) lbs of+          () -> True++eval :: [Action] -> Binary.Get ()+eval = go 0+  where+  go _ [] = return ()+  go pos (x:xs) =+    case x of+      GetByteString n ->+        Binary.getByteString n >> go (pos+n) xs+      BytesRead -> do+        pos' <- Binary.bytesRead+        if (pos == fromIntegral pos')+          then go pos xs+          else error $ "expected " ++ show pos ++ " but got " ++ show pos'+      Fail -> fail "fail"+      Try a b -> do+        len <- leg pos a <|> leg pos b+        case len of+          Nothing -> error "got Nothing, but we're still here..."+          Just offset -> go (pos+offset) xs+  leg pos t = go pos t >> return (actual_len t)++gen_actions :: Gen [Action]+gen_actions = sized (go False)+  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 (:) 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)+                       ] ++ [ return [Fail] | inTry ]

@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Arbitrary where++import Test.QuickCheck++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++instance Arbitrary L.ByteString where+    arbitrary     = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant.++instance Arbitrary B.ByteString where+  arbitrary = B.pack `fmap` arbitrary++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+          Arbitrary f) =>+         Arbitrary (a,b,c,d,e,f) where+  arbitrary = do+    (a,b,c,d,e) <- arbitrary+    f <- arbitrary+    return (a,b,c,d,e,f)++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+          Arbitrary f, Arbitrary g) =>+         Arbitrary (a,b,c,d,e,f,g) where+  arbitrary = do+    (a,b,c,d,e) <- arbitrary+    (f,g) <- arbitrary+    return (a,b,c,d,e,f,g)++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+          Arbitrary f, Arbitrary g, Arbitrary h) =>+         Arbitrary (a,b,c,d,e,f,g,h) where+  arbitrary = do+    (a,b,c,d,e) <- arbitrary+    (f,g,h) <- arbitrary+    return (a,b,c,d,e,f,g,h)++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+          Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i) =>+         Arbitrary (a,b,c,d,e,f,g,h,i) where+  arbitrary = do+    (a,b,c,d,e) <- arbitrary+    (f,g,h,i) <- arbitrary+    return (a,b,c,d,e,f,g,h,i)++instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,+          Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i, Arbitrary j) =>+         Arbitrary (a,b,c,d,e,f,g,h,i,j) where+  arbitrary = do+    (a,b,c,d,e) <- arbitrary+    (f,g,h,i,j) <- arbitrary+    return (a,b,c,d,e,f,g,h,i,j)

@@ -39,6 +39,9 @@ import Test.Framework.Providers.QuickCheck2 -- import Data.Monoid +import Action (prop_action)+import Arbitrary()+ ------------------------------------------------------------------------  roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool@@ -310,6 +313,10 @@             , testProperty "partial only once" (p prop_partialOnlyOnce)             ] +        , testGroup "Model"+            [ testProperty "action" Action.prop_action+            ]+         , testGroup "Primitives"             [ testProperty "Word16be"   (p prop_Word16be)             , testProperty "Word16le"   (p prop_Word16le)@@ -413,50 +420,3 @@  -- GHC only: --      ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))--instance Arbitrary L.ByteString where-    arbitrary     = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant.--instance Arbitrary B.ByteString where-  arbitrary = B.pack `fmap` arbitrary--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,-          Arbitrary f) =>-         Arbitrary (a,b,c,d,e,f) where-  arbitrary = do-    (a,b,c,d,e) <- arbitrary-    f <- arbitrary-    return (a,b,c,d,e,f)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,-          Arbitrary f, Arbitrary g) =>-         Arbitrary (a,b,c,d,e,f,g) where-  arbitrary = do-    (a,b,c,d,e) <- arbitrary-    (f,g) <- arbitrary-    return (a,b,c,d,e,f,g)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,-          Arbitrary f, Arbitrary g, Arbitrary h) =>-         Arbitrary (a,b,c,d,e,f,g,h) where-  arbitrary = do-    (a,b,c,d,e) <- arbitrary-    (f,g,h) <- arbitrary-    return (a,b,c,d,e,f,g,h)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,-          Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i) =>-         Arbitrary (a,b,c,d,e,f,g,h,i) where-  arbitrary = do-    (a,b,c,d,e) <- arbitrary-    (f,g,h,i) <- arbitrary-    return (a,b,c,d,e,f,g,h,i)--instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e,-          Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i, Arbitrary j) =>-         Arbitrary (a,b,c,d,e,f,g,h,i,j) where-  arbitrary = do-    (a,b,c,d,e) <- arbitrary-    (f,g,h,i,j) <- arbitrary-    return (a,b,c,d,e,f,g,h,i,j)-