content: {-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      : Data.Binary
  -- Copyright   : Lennart Kolmodin
  -- License     : BSD3-style (see LICENSE)
  -- 
  -- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
  -- Stability   : unstable
  -- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances
  --
  -- Binary serialisation of Haskell values to and from lazy ByteStrings.
  -- The Binary library provides methods for encoding Haskell values as
  -- streams of bytes directly in memory. The resulting @ByteString@ can
  -- then be written to disk, sent over the network, or futher processed
  -- (for example, compressed with gzip).
  --
  -- The 'Binary' package is notable in that it provides both pure, and
  -- high performance serialisation.
  --
  -- Values are always encoded in network order (big endian) form, and
  -- encoded data should be portable across machine endianess, word size,
  -- or compiler version. For example, data encoded using the Binary class
  -- could be written from GHC, and read back in Hugs.
  --
  -----------------------------------------------------------------------------
  
  module Data.Binary (
  
      -- * The Binary class
        Binary(..)
  
      -- $example
  
      -- * The Get and Put monads
      , Get
      , Put
  
      -- * Useful helpers for writing instances
      , putWord8
      , getWord8
  
      -- * Binary serialisation
      , encode                    -- :: Binary a => a -> ByteString
      , decode                    -- :: Binary a => ByteString -> a
  
      -- * IO functions for serialisation
      , encodeFile                -- :: Binary a => FilePath -> a -> IO ()
      , decodeFile                -- :: Binary a => FilePath -> IO a
  
      , encodeFile_               -- :: FilePath -> Put   -> IO ()
      , decodeFile_               -- :: FilePath -> Get a -> IO a
  
  -- Lazy put and get
  --  , lazyPut
  --  , lazyGet
  
      , module Data.Word -- useful
  
      ) where
  
  #include "MachDeps.h"
  
  import Data.Word
  
  import Data.Binary.Put
  import Data.Binary.Get
  import Data.Binary.IEEE754 ( putFloat64be, getFloat64be)
  import Control.Monad
  import Control.Exception
  import Foreign
  import System.IO
  
  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 parsing 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:
  --
  -- > data Exp = IntE Int
  -- >          | OpE  String Exp Exp
  -- >    deriving Show
  --
  -- We can encode values of this type into bytestrings using the
  -- following instance, which proceeds by recursively breaking down the
  -- structure to serialise:
  --
  -- > instance Binary Exp where
  -- >       put (IntE i)          = do put (0 :: Word8)
  -- >                                  put i
  -- >       put (OpE s e1 e2)     = do put (1 :: Word8)
  -- >                                  put s
  -- >                                  put e1
  -- >                                  put e2
  -- > 
  -- >       get = do t <- get :: Get Word8
  -- >                case t of
  -- >                     0 -> do i <- get
  -- >                             return (IntE i)
  -- >                     1 -> do s  <- get
  -- >                             e1 <- get
  -- >                             e2 <- get
  -- >                             return (OpE s e1 e2)
  --
  -- Note how we write an initial tag byte to indicate each variant of the
  -- data type.
  --
  -- 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
  --
  -- > > let e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
  -- > > let v = encode e
  --
  -- Where 'v' is a binary encoded data structure. To reconstruct the
  -- original data, we use 'decode'
  --
  -- > > decode v :: Exp
  -- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
  --
  -- The lazy ByteString that results from 'encode' can be written to
  -- disk, and read from disk using Data.ByteString.Lazy IO functions,
  -- such as hPutStr or writeFile:
  --
  -- > > writeFile "/tmp/exp.txt" (encode e)
  --
  -- And read back with:
  --
  -- > > readFile "/tmp/exp.txt" >>= return . decode :: IO Exp
  -- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
  --
  -- We can also directly serialise a value to and from a Handle, or a file:
  -- 
  -- > > v <- decodeFile  "/tmp/exp.txt" :: IO Exp
  -- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
  --
  -- And write a value to disk
  --
  -- > > encodeFile "/tmp/a.txt" v
  --
  
  ------------------------------------------------------------------------
  -- Wrappers to run the underlying monad
  
  -- | Encode a value using binary serialisation to a lazy ByteString.
  --
  encode :: Binary a => a -> ByteString
  encode = runPut . put
  {-# INLINE encode #-}
  
  -- | Decode a value from a lazy ByteString, reconstructing the original structure.
  --
  decode :: Binary a => ByteString -> a
  decode = runGet get
  
  ------------------------------------------------------------------------
  -- Convenience IO operations
  
  -- | Lazily serialise a value to a file
  --
  -- This is just a convenience function, it's defined simply as:
  --
  -- > encodeFile f = B.writeFile f . encode
  --
  -- So for example if you wanted to compress as well, you could use:
  --
  -- > B.writeFile f . compress . encode
  --
  encodeFile :: Binary a => FilePath -> a -> IO ()
  encodeFile f v = L.writeFile f (encode v)
  
  encodeFile_ :: FilePath -> Put -> IO ()
  encodeFile_ f m = L.writeFile f (runPut m)
  
  -- | Lazily reconstruct a value previously written to a file.
  --
  -- This is just a convenience function, it's defined simply as:
  --
  -- > decodeFile f = return . decode =<< B.readFile f
  --
  -- So for example if you wanted to decompress as well, you could use:
  --
  -- > return . decode . decompress =<< B.readFile f
  --
  decodeFile :: Binary a => FilePath -> IO a
  decodeFile f = bracket (openBinaryFile f ReadMode) hClose $ \h -> do
      s <- L.hGetContents h
      evaluate $ runGet get s
  
  decodeFile_ :: FilePath -> Get a -> IO a
  decodeFile_ f m = bracket (openBinaryFile f ReadMode) hClose $ \h -> do
      s <- L.hGetContents h
      evaluate $ runGet m s
  
  -- needs bytestring 0.9.1.x to work 
  
  ------------------------------------------------------------------------
  -- Lazy put and get
  
  -- lazyPut :: (Binary a) => a -> Put
  -- lazyPut a = put (encode a)
  
  -- 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 8 bytes in big endian format
  instance Binary Int64 where
      put i   = put (fromIntegral i :: Word64)
      get     = liftM fromIntegral (get :: Get Word64)
  
  ------------------------------------------------------------------------
  
  -- Words are written as sequence of bytes. The last bit of each
  -- byte indicates whether there are more bytes to be read
  instance Binary Word where
      put i | i <=               0x7f = do put  a
            | i <=             0x3fff = do put (a .|. 0x80)
                                           put  b
            | i <=           0x1fffff = do put (a .|. 0x80)
                                           put (b .|. 0x80)
                                           put  c
            | i <=          0xfffffff = do put (a .|. 0x80)
                                           put (b .|. 0x80)
                                           put (c .|. 0x80)
                                           put  d
  -- -- #if WORD_SIZE_IN_BITS < 64
            | otherwise               = do put (a .|. 0x80)
                                           put (b .|. 0x80)
                                           put (c .|. 0x80)
                                           put (d .|. 0x80)
                                           put  e
  {-
  -- Restricted to 32 bits even on 64-bit systems, so that negative
  -- Ints are written as 5 bytes instead of 10 bytes (TH 2013-02-13)
  --#else
            | i <=        0x7ffffffff = do put (a .|. 0x80)
                                           put (b .|. 0x80)
                                           put (c .|. 0x80)
                                           put (d .|. 0x80)
                                           put  e
            | i <=      0x3ffffffffff = do put (a .|. 0x80)
                                           put (b .|. 0x80)
                                           put (c .|. 0x80)
                                           put (d .|. 0x80)
                                           put (e .|. 0x80)
                                           put  f
            | i <=    0x1ffffffffffff = do put (a .|. 0x80)
                                           put (b .|. 0x80)
                                           put (c .|. 0x80)
                                           put (d .|. 0x80)
                                           put (e .|. 0x80)
                                           put (f .|. 0x80)
                                           put  g
            | i <=   0xffffffffffffff = do put (a .|. 0x80)
                                           put (b .|. 0x80)
                                           put (c .|. 0x80)
                                           put (d .|. 0x80)
                                           put (e .|. 0x80)
                                           put (f .|. 0x80)
                                           put (g .|. 0x80)
                                           put  h
            | i <=   0xffffffffffffff = do put (a .|. 0x80)
                                           put (b .|. 0x80)
                                           put (c .|. 0x80)
                                           put (d .|. 0x80)
                                           put (e .|. 0x80)
                                           put (f .|. 0x80)
                                           put (g .|. 0x80)
                                           put  h
            | i <= 0x7fffffffffffffff = do put (a .|. 0x80)
                                           put (b .|. 0x80)
                                           put (c .|. 0x80)
                                           put (d .|. 0x80)
                                           put (e .|. 0x80)
                                           put (f .|. 0x80)
                                           put (g .|. 0x80)
                                           put (h .|. 0x80)
                                           put  j
            | otherwise               = do put (a .|. 0x80)
                                           put (b .|. 0x80)
                                           put (c .|. 0x80)
                                           put (d .|. 0x80)
                                           put (e .|. 0x80)
                                           put (f .|. 0x80)
                                           put (g .|. 0x80)
                                           put (h .|. 0x80)
                                           put (j .|. 0x80)
                                           put  k
  -- #endif
  -}
            where
              a = fromIntegral (       i    .&. 0x7f) :: Word8
              b = fromIntegral (shiftR i  7 .&. 0x7f) :: Word8
              c = fromIntegral (shiftR i 14 .&. 0x7f) :: Word8
              d = fromIntegral (shiftR i 21 .&. 0x7f) :: Word8
              e = fromIntegral (shiftR i 28 .&. 0x7f) :: Word8
  {-
              f = fromIntegral (shiftR i 35 .&. 0x7f) :: Word8
              g = fromIntegral (shiftR i 42 .&. 0x7f) :: Word8
              h = fromIntegral (shiftR i 49 .&. 0x7f) :: Word8
              j = fromIntegral (shiftR i 56 .&. 0x7f) :: Word8
              k = fromIntegral (shiftR i 63 .&. 0x7f) :: Word8
  -}
      get = do i <- getWord8
               (if i <= 0x7f
                  then return (fromIntegral i)
                  else do n <- get
                          return $ (n `shiftL` 7) .|. (fromIntegral (i .&. 0x7f)))
  
  -- Int has the same representation as Word
  instance Binary Int where
      put i   = put (fromIntegral i :: Word)
      get     = liftM toInt32 (get :: Get Word)
        where
         -- restrict to 32 bits (for PGF portability, TH 2013-02-13)
         toInt32 w = fromIntegral (fromIntegral w::Int32)::Int
  
  ------------------------------------------------------------------------
  -- 
  -- 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 endianess 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
                  xs <- replicateM n get
                  return xs
  
  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 Double where
      put = putFloat64be
      get = getFloat64be
  
  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 <- replicateM n get     -- 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 <- replicateM n get
          return (listArray bs xs)
  