diff --git a/.hgignore b/.hgignore new file mode 100644 --- /dev/null +++ b/.hgignore @@ -0,0 +1,5 @@ +^dist$ +syntax: glob +.*.swp +*~ +\#* diff --git a/benchmarks/Builder.hs b/benchmarks/Builder.hs --- a/benchmarks/Builder.hs +++ b/benchmarks/Builder.hs @@ -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 diff --git a/benchmarks/Get.hs b/benchmarks/Get.hs --- a/benchmarks/Get.hs +++ b/benchmarks/Get.hs @@ -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 () diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,12 +1,12 @@ name: binary -version: 0.6.2.0 +version: 0.6.3.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin maintainer: Lennart Kolmodin, Don Stewart 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 - diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs --- a/src/Data/Binary.hs +++ b/src/Data/Binary.hs @@ -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: --- . --- --- 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. diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Class.hs @@ -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 +-- 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) diff --git a/src/Data/Binary/Generic.hs b/src/Data/Binary/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Generic.hs @@ -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 +-- 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 diff --git a/tests/Action.hs b/tests/Action.hs new file mode 100644 --- /dev/null +++ b/tests/Action.hs @@ -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 ] diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Arbitrary.hs @@ -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) diff --git a/tests/QC.hs b/tests/QC.hs --- a/tests/QC.hs +++ b/tests/QC.hs @@ -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) -