{-# 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 :: a -> ByteString
encode = Put -> ByteString
runPut (Put -> ByteString) -> (a -> Put) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Put
forall t. Binary t => t -> Put
put
{-# INLINE encode #-}

-- | Decode a value from a lazy ByteString, reconstructing the original structure.
--
decode :: Binary a => ByteString -> a
decode :: ByteString -> a
decode = Get a -> ByteString -> a
forall a. Get a -> ByteString -> a
runGet Get a
forall t. Binary t => Get t
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 :: FilePath -> a -> IO ()
encodeFile FilePath
f a
v = FilePath -> ByteString -> IO ()
L.writeFile FilePath
f (a -> ByteString
forall a. Binary a => a -> ByteString
encode a
v)

encodeFile_ :: FilePath -> Put -> IO ()
encodeFile_ :: FilePath -> Put -> IO ()
encodeFile_ FilePath
f Put
m = FilePath -> ByteString -> IO ()
L.writeFile FilePath
f (Put -> ByteString
runPut Put
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 :: FilePath -> IO a
decodeFile FilePath
f = IO Handle -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
f IOMode
ReadMode) Handle -> IO ()
hClose ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    ByteString
s <- Handle -> IO ByteString
L.hGetContents Handle
h
    a -> IO a
forall a. a -> IO a
evaluate (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ Get a -> ByteString -> a
forall a. Get a -> ByteString -> a
runGet Get a
forall t. Binary t => Get t
get ByteString
s

decodeFile_ :: FilePath -> Get a -> IO a
decodeFile_ :: FilePath -> Get a -> IO a
decodeFile_ FilePath
f Get a
m = IO Handle -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
f IOMode
ReadMode) Handle -> IO ()
hClose ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    ByteString
s <- Handle -> IO ByteString
L.hGetContents Handle
h
    a -> IO a
forall a. a -> IO a
evaluate (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ Get a -> ByteString -> a
forall a. Get a -> ByteString -> a
runGet Get a
m ByteString
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 :: () -> Put
put ()  = () -> Put
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    get :: Get ()
get     = () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Bools are encoded as a byte in the range 0 .. 1
instance Binary Bool where
    put :: Bool -> Put
put     = Word8 -> Put
putWord8 (Word8 -> Put) -> (Bool -> Word8) -> Bool -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Bool -> Int) -> Bool -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum
    get :: Get Bool
get     = (Word8 -> Bool) -> Get Word8 -> Get Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Bool
forall a. Enum a => Int -> a
toEnum (Int -> Bool) -> (Word8 -> Int) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Get Word8
getWord8

-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
instance Binary Ordering where
    put :: Ordering -> Put
put     = Word8 -> Put
putWord8 (Word8 -> Put) -> (Ordering -> Word8) -> Ordering -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Ordering -> Int) -> Ordering -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ordering -> Int
forall a. Enum a => a -> Int
fromEnum
    get :: Get Ordering
get     = (Word8 -> Ordering) -> Get Word8 -> Get Ordering
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Ordering
forall a. Enum a => Int -> a
toEnum (Int -> Ordering) -> (Word8 -> Int) -> Word8 -> Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Get Word8
getWord8

------------------------------------------------------------------------
-- Words and Ints

-- Words8s are written as bytes
instance Binary Word8 where
    put :: Word8 -> Put
put     = Word8 -> Put
putWord8
    get :: Get Word8
get     = Get Word8
getWord8

-- Words16s are written as 2 bytes in big-endian (network) order
instance Binary Word16 where
    put :: Word16 -> Put
put     = Word16 -> Put
putWord16be
    get :: Get Word16
get     = Get Word16
getWord16be

-- Words32s are written as 4 bytes in big-endian (network) order
instance Binary Word32 where
    put :: Word32 -> Put
put     = Word32 -> Put
putWord32be
    get :: Get Word32
get     = Get Word32
getWord32be

-- Words64s are written as 8 bytes in big-endian (network) order
instance Binary Word64 where
    put :: Word64 -> Put
put     = Word64 -> Put
putWord64be
    get :: Get Word64
get     = Get Word64
getWord64be

-- Int8s are written as a single byte.
instance Binary Int8 where
    put :: Int8 -> Put
put Int8
i   = Word8 -> Put
forall t. Binary t => t -> Put
put (Int8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
i :: Word8)
    get :: Get Int8
get     = (Word8 -> Int8) -> Get Word8 -> Get Int8
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word8 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Word8
forall t. Binary t => Get t
get :: Get Word8)

-- Int16s are written as a 2 bytes in big endian format
instance Binary Int16 where
    put :: Int16 -> Put
put Int16
i   = Word16 -> Put
forall t. Binary t => t -> Put
put (Int16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i :: Word16)
    get :: Get Int16
get     = (Word16 -> Int16) -> Get Word16 -> Get Int16
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word16 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Word16
forall t. Binary t => Get t
get :: Get Word16)

-- Int32s are written as a 4 bytes in big endian format
instance Binary Int32 where
    put :: Int32 -> Put
put Int32
i   = Word32 -> Put
forall t. Binary t => t -> Put
put (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i :: Word32)
    get :: Get Int32
get     = (Word32 -> Int32) -> Get Word32 -> Get Int32
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Word32
forall t. Binary t => Get t
get :: Get Word32)

-- Int64s are written as a 8 bytes in big endian format
instance Binary Int64 where
    put :: Int64 -> Put
put Int64
i   = Word64 -> Put
forall t. Binary t => t -> Put
put (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i :: Word64)
    get :: Get Int64
get     = (Word64 -> Int64) -> Get Word64 -> Get Int64
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Word64
forall t. Binary t => Get t
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 :: Word -> Put
put Word
i | Word
i Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<=               Word
0x7f = do Word8 -> Put
forall t. Binary t => t -> Put
put  Word8
a
          | Word
i Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<=             Word
0x3fff = do Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
a Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80)
                                         Word8 -> Put
forall t. Binary t => t -> Put
put  Word8
b
          | Word
i Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<=           Word
0x1fffff = do Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
a Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80)
                                         Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80)
                                         Word8 -> Put
forall t. Binary t => t -> Put
put  Word8
c
          | Word
i Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<=          Word
0xfffffff = do Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
a Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80)
                                         Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80)
                                         Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80)
                                         Word8 -> Put
forall t. Binary t => t -> Put
put  Word8
d
-- -- #if WORD_SIZE_IN_BITS < 64
          | Bool
otherwise               = do Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
a Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80)
                                         Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80)
                                         Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80)
                                         Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
d Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
0x80)
                                         Word8 -> Put
forall t. Binary t => t -> Put
put  Word8
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 :: Word8
a = Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (       Word
i    Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x7f) :: Word8
            b :: Word8
b = Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
shiftR Word
i  Int
7 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x7f) :: Word8
            c :: Word8
c = Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
shiftR Word
i Int
14 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x7f) :: Word8
            d :: Word8
d = Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
shiftR Word
i Int
21 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
0x7f) :: Word8
            e :: Word8
e = Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int -> Word
forall a. Bits a => a -> Int -> a
shiftR Word
i Int
28 Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
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 :: Get Word
get = do Word8
i <- Get Word8
getWord8
             (if Word8
i Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x7f
                then Word -> Get Word
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i)
                else do Word
n <- Get Word
forall t. Binary t => Get t
get
                        Word -> Get Word
forall (m :: * -> *) a. Monad m => a -> m a
return (Word -> Get Word) -> Word -> Get Word
forall a b. (a -> b) -> a -> b
$ (Word
n Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
7) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
i Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f)))

-- Int has the same representation as Word
instance Binary Int where
    put :: Int -> Put
put Int
i   = Word -> Put
forall t. Binary t => t -> Put
put (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i :: Word)
    get :: Get Int
get     = (Word -> Int) -> Get Word -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word -> Int
forall a. Integral a => a -> Int
toInt32 (Get Word
forall t. Binary t => Get t
get :: Get Word)
      where
       -- restrict to 32 bits (for PGF portability, TH 2013-02-13)
       toInt32 :: a -> Int
toInt32 a
w = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
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 :: Integer -> Put
put Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
lo Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
hi = do
        Word8 -> Put
putWord8 Word8
0
        Int32 -> Put
forall t. Binary t => t -> Put
put (Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n :: SmallInt)  -- fast path
     where
        lo :: Integer
lo = Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
minBound :: SmallInt) :: Integer
        hi :: Integer
hi = Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
maxBound :: SmallInt) :: Integer

    put Integer
n = do
        Word8 -> Put
putWord8 Word8
1
        Word8 -> Put
forall t. Binary t => t -> Put
put Word8
sign
        [Word8] -> Put
forall t. Binary t => t -> Put
put (Integer -> [Word8]
unroll (Integer -> Integer
forall a. Num a => a -> a
abs Integer
n))         -- unroll the bytes
     where
        sign :: Word8
sign = Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Integer
forall a. Num a => a -> a
signum Integer
n) :: Word8

    {-# INLINE get #-}
    get :: Get Integer
get = do
        Word8
tag <- Get Word8
forall t. Binary t => Get t
get :: Get Word8
        case Word8
tag of
            Word8
0 -> (Int32 -> Integer) -> Get Int32 -> Get Integer
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Int32
forall t. Binary t => Get t
get :: Get SmallInt)
            Word8
_ -> do Word8
sign  <- Get Word8
forall t. Binary t => Get t
get
                    [Word8]
bytes <- Get [Word8]
forall t. Binary t => Get t
get
                    let v :: Integer
v = [Word8] -> Integer
roll [Word8]
bytes
                    Integer -> Get Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Get Integer) -> Integer -> Get Integer
forall a b. (a -> b) -> a -> b
$! if Word8
sign Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== (Word8
1 :: Word8) then Integer
v else - Integer
v

--
-- Fold and unfold an Integer to and from a list of its bytes
--
unroll :: Integer -> [Word8]
unroll :: Integer -> [Word8]
unroll = (Integer -> Maybe (Word8, Integer)) -> Integer -> [Word8]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr Integer -> Maybe (Word8, Integer)
forall b a. (Integral b, Num a, Bits b) => b -> Maybe (a, b)
step
  where
    step :: b -> Maybe (a, b)
step b
0 = Maybe (a, b)
forall a. Maybe a
Nothing
    step b
i = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
i, b
i b -> Int -> b
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)

roll :: [Word8] -> Integer
roll :: [Word8] -> Integer
roll   = (Word8 -> Integer -> Integer) -> Integer -> [Word8] -> Integer
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word8 -> Integer -> Integer
forall a a. (Bits a, Integral a, Num a) => a -> a -> a
unstep Integer
0
  where
    unstep :: a -> a -> a
unstep a
b a
a = a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 a -> a -> a
forall a. Bits a => a -> a -> a
.|. a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
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 :: Ratio a -> Put
put Ratio a
r = a -> Put
forall t. Binary t => t -> Put
put (Ratio a -> a
forall a. Ratio a -> a
R.numerator Ratio a
r) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Put
forall t. Binary t => t -> Put
put (Ratio a -> a
forall a. Ratio a -> a
R.denominator Ratio a
r)
    get :: Get (Ratio a)
get = (a -> a -> Ratio a) -> Get a -> Get a -> Get (Ratio a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
(R.%) Get a
forall t. Binary t => Get t
get Get a
forall t. Binary t => Get t
get

------------------------------------------------------------------------

-- Char is serialised as UTF-8
instance Binary Char where
    put :: Char -> Put
put Char
a | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7f     = Word8 -> Put
forall t. Binary t => t -> Put
put (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c :: Word8)
          | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7ff    = do Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0xc0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
y)
                               Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
z)
          | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xffff   = do Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0xe0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
x)
                               Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
y)
                               Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
z)
          | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10ffff = do Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0xf0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
w)
                               Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
x)
                               Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
y)
                               Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
z)
          | Bool
otherwise     = FilePath -> Put
forall a. HasCallStack => FilePath -> a
error FilePath
"Not a valid Unicode code point"
     where
        c :: Int
c = Char -> Int
ord Char
a
        z, y, x, w :: Word8
        z :: Word8
z = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c           Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3f)
        y :: Word8
y = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
c Int
6  Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3f)
        x :: Word8
x = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
c Int
12 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3f)
        w :: Word8
w = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
c Int
18 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x7)

    get :: Get Char
get = do
        let getByte :: Get Int
getByte = (Word8 -> Int) -> Get Word8 -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word8 -> Int) Get Word8
forall t. Binary t => Get t
get
            shiftL6 :: Int -> Int
shiftL6 = (Int -> Int -> Int) -> Int -> Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
6 :: Int -> Int
        Int
w <- Get Int
getByte
        Int
r <- case () of
                ()
_ | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x80  -> Int -> Get Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
w
                  | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xe0  -> do
                                    Int
x <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    Int -> Get Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0xc0 Int
w))
                  | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xf0  -> do
                                    Int
x <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    Int
y <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    Int -> Get Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
y Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6
                                            (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0xe0 Int
w)))
                  | Bool
otherwise -> do
                                Int
x <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                Int
y <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                Int
z <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                Int -> Get Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
z Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (Int
y Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6
                                        (Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0xf0 Int
w))))
        Char -> Get Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Get Char) -> Char -> Get Char
forall a b. (a -> b) -> a -> b
$! Int -> Char
chr Int
r

------------------------------------------------------------------------
-- Instances for the first few tuples

instance (Binary a, Binary b) => Binary (a,b) where
    put :: (a, b) -> Put
put (a
a,b
b)           = a -> Put
forall t. Binary t => t -> Put
put a
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Put
forall t. Binary t => t -> Put
put b
b
    get :: Get (a, b)
get                 = (a -> b -> (a, b)) -> Get a -> Get b -> Get (a, b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Get a
forall t. Binary t => Get t
get Get b
forall t. Binary t => Get t
get

instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
    put :: (a, b, c) -> Put
put (a
a,b
b,c
c)         = a -> Put
forall t. Binary t => t -> Put
put a
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Put
forall t. Binary t => t -> Put
put b
b Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> Put
forall t. Binary t => t -> Put
put c
c
    get :: Get (a, b, c)
get                 = (a -> b -> c -> (a, b, c))
-> Get a -> Get b -> Get c -> Get (a, b, c)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (,,) Get a
forall t. Binary t => Get t
get Get b
forall t. Binary t => Get t
get Get c
forall t. Binary t => Get t
get

instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
    put :: (a, b, c, d) -> Put
put (a
a,b
b,c
c,d
d)       = a -> Put
forall t. Binary t => t -> Put
put a
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Put
forall t. Binary t => t -> Put
put b
b Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> Put
forall t. Binary t => t -> Put
put c
c Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> d -> Put
forall t. Binary t => t -> Put
put d
d
    get :: Get (a, b, c, d)
get                 = (a -> b -> c -> d -> (a, b, c, d))
-> Get a -> Get b -> Get c -> Get d -> Get (a, b, c, d)
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (,,,) Get a
forall t. Binary t => Get t
get Get b
forall t. Binary t => Get t
get Get c
forall t. Binary t => Get t
get Get d
forall t. Binary t => Get t
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
put (a
a,b
b,c
c,d
d,e
e)     = a -> Put
forall t. Binary t => t -> Put
put a
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Put
forall t. Binary t => t -> Put
put b
b Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> Put
forall t. Binary t => t -> Put
put c
c Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> d -> Put
forall t. Binary t => t -> Put
put d
d Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> e -> Put
forall t. Binary t => t -> Put
put e
e
    get :: Get (a, b, c, d, e)
get                 = (a -> b -> c -> d -> e -> (a, b, c, d, e))
-> Get a -> Get b -> Get c -> Get d -> Get e -> Get (a, b, c, d, e)
forall (m :: * -> *) a1 a2 a3 a4 a5 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> a5 -> r)
-> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
liftM5 (,,,,) Get a
forall t. Binary t => Get t
get Get b
forall t. Binary t => Get t
get Get c
forall t. Binary t => Get t
get Get d
forall t. Binary t => Get t
get Get e
forall t. Binary t => Get t
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
put (a
a,b
b,c
c,d
d,e
e,f
f)   = (a, (b, c, d, e, f)) -> Put
forall t. Binary t => t -> Put
put (a
a,(b
b,c
c,d
d,e
e,f
f))
    get :: Get (a, b, c, d, e, f)
get                 = do (a
a,(b
b,c
c,d
d,e
e,f
f)) <- Get (a, (b, c, d, e, f))
forall t. Binary t => Get t
get ; (a, b, c, d, e, f) -> Get (a, b, c, d, e, f)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
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
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g) = (a, (b, c, d, e, f, g)) -> Put
forall t. Binary t => t -> Put
put (a
a,(b
b,c
c,d
d,e
e,f
f,g
g))
    get :: Get (a, b, c, d, e, f, g)
get                 = do (a
a,(b
b,c
c,d
d,e
e,f
f,g
g)) <- Get (a, (b, c, d, e, f, g))
forall t. Binary t => Get t
get ; (a, b, c, d, e, f, g) -> Get (a, b, c, d, e, f, g)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f,g
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
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h) = (a, (b, c, d, e, f, g, h)) -> Put
forall t. Binary t => t -> Put
put (a
a,(b
b,c
c,d
d,e
e,f
f,g
g,h
h))
    get :: Get (a, b, c, d, e, f, g, h)
get                   = do (a
a,(b
b,c
c,d
d,e
e,f
f,g
g,h
h)) <- Get (a, (b, c, d, e, f, g, h))
forall t. Binary t => Get t
get ; (a, b, c, d, e, f, g, h) -> Get (a, b, c, d, e, f, g, h)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
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
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i) = (a, (b, c, d, e, f, g, h, i)) -> Put
forall t. Binary t => t -> Put
put (a
a,(b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i))
    get :: Get (a, b, c, d, e, f, g, h, i)
get                     = do (a
a,(b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i)) <- Get (a, (b, c, d, e, f, g, h, i))
forall t. Binary t => Get t
get ; (a, b, c, d, e, f, g, h, i) -> Get (a, b, c, d, e, f, g, h, i)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
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
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j) = (a, (b, c, d, e, f, g, h, i, j)) -> Put
forall t. Binary t => t -> Put
put (a
a,(b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j))
    get :: Get (a, b, c, d, e, f, g, h, i, j)
get                       = do (a
a,(b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j)) <- Get (a, (b, c, d, e, f, g, h, i, j))
forall t. Binary t => Get t
get ; (a, b, c, d, e, f, g, h, i, j)
-> Get (a, b, c, d, e, f, g, h, i, j)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j)

------------------------------------------------------------------------
-- Container types

instance Binary a => Binary [a] where
    put :: [a] -> Put
put [a]
l  = Int -> Put
forall t. Binary t => t -> Put
put ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a -> Put) -> [a] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Put
forall t. Binary t => t -> Put
put [a]
l
    get :: Get [a]
get    = do Int
n <- Get Int
forall t. Binary t => Get t
get :: Get Int
                [a]
xs <- Int -> Get a -> Get [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Get a
forall t. Binary t => Get t
get
                [a] -> Get [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
xs

instance (Binary a) => Binary (Maybe a) where
    put :: Maybe a -> Put
put Maybe a
Nothing  = Word8 -> Put
putWord8 Word8
0
    put (Just a
x) = Word8 -> Put
putWord8 Word8
1 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Put
forall t. Binary t => t -> Put
put a
x
    get :: Get (Maybe a)
get = do
        Word8
w <- Get Word8
getWord8
        case Word8
w of
            Word8
0 -> Maybe a -> Get (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
            Word8
_ -> (a -> Maybe a) -> Get a -> Get (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just Get a
forall t. Binary t => Get t
get

instance (Binary a, Binary b) => Binary (Either a b) where
    put :: Either a b -> Put
put (Left  a
a) = Word8 -> Put
putWord8 Word8
0 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Put
forall t. Binary t => t -> Put
put a
a
    put (Right b
b) = Word8 -> Put
putWord8 Word8
1 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Put
forall t. Binary t => t -> Put
put b
b
    get :: Get (Either a b)
get = do
        Word8
w <- Get Word8
getWord8
        case Word8
w of
            Word8
0 -> (a -> Either a b) -> Get a -> Get (Either a b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Either a b
forall a b. a -> Either a b
Left  Get a
forall t. Binary t => Get t
get
            Word8
_ -> (b -> Either a b) -> Get b -> Get (Either a b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM b -> Either a b
forall a b. b -> Either a b
Right Get b
forall t. Binary t => Get t
get

------------------------------------------------------------------------
-- ByteStrings (have specially efficient instances)

instance Binary B.ByteString where
    put :: ByteString -> Put
put ByteString
bs = do Int -> Put
forall t. Binary t => t -> Put
put (ByteString -> Int
B.length ByteString
bs)
                ByteString -> Put
putByteString ByteString
bs
    get :: Get ByteString
get    = Get Int
forall t. Binary t => Get t
get Get Int -> (Int -> Get ByteString) -> Get ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ByteString
getByteString

--
-- Using old versions of fps, this is a type synonym, and non portable
-- 
-- Requires 'flexible instances'
--
instance Binary ByteString where
    put :: ByteString -> Put
put ByteString
bs = do Int -> Put
forall t. Binary t => t -> Put
put (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
L.length ByteString
bs) :: Int)
                ByteString -> Put
putLazyByteString ByteString
bs
    get :: Get ByteString
get    = Get Int64
forall t. Binary t => Get t
get Get Int64 -> (Int64 -> Get ByteString) -> Get ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int64 -> Get ByteString
getLazyByteString

------------------------------------------------------------------------
-- Maps and Sets

instance (Ord a, Binary a) => Binary (Set.Set a) where
    put :: Set a -> Put
put Set a
s = Int -> Put
forall t. Binary t => t -> Put
put (Set a -> Int
forall a. Set a -> Int
Set.size Set a
s) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a -> Put) -> [a] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Put
forall t. Binary t => t -> Put
put (Set a -> [a]
forall a. Set a -> [a]
Set.toAscList Set a
s)
    get :: Get (Set a)
get   = ([a] -> Set a) -> Get [a] -> Get (Set a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [a] -> Set a
forall a. [a] -> Set a
Set.fromDistinctAscList Get [a]
forall t. Binary t => Get t
get

instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where
    put :: Map k e -> Put
put Map k e
m = Int -> Put
forall t. Binary t => t -> Put
put (Map k e -> Int
forall k a. Map k a -> Int
Map.size Map k e
m) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((k, e) -> Put) -> [(k, e)] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (k, e) -> Put
forall t. Binary t => t -> Put
put (Map k e -> [(k, e)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map k e
m)
    get :: Get (Map k e)
get   = ([(k, e)] -> Map k e) -> Get [(k, e)] -> Get (Map k e)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(k, e)] -> Map k e
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList Get [(k, e)]
forall t. Binary t => Get t
get

instance Binary IntSet.IntSet where
    put :: IntSet -> Put
put IntSet
s = Int -> Put
forall t. Binary t => t -> Put
put (IntSet -> Int
IntSet.size IntSet
s) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Int -> Put) -> [Int] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> Put
forall t. Binary t => t -> Put
put (IntSet -> [Int]
IntSet.toAscList IntSet
s)
    get :: Get IntSet
get   = ([Int] -> IntSet) -> Get [Int] -> Get IntSet
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Int] -> IntSet
IntSet.fromDistinctAscList Get [Int]
forall t. Binary t => Get t
get

instance (Binary e) => Binary (IntMap.IntMap e) where
    put :: IntMap e -> Put
put IntMap e
m = Int -> Put
forall t. Binary t => t -> Put
put (IntMap e -> Int
forall a. IntMap a -> Int
IntMap.size IntMap e
m) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((Int, e) -> Put) -> [(Int, e)] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, e) -> Put
forall t. Binary t => t -> Put
put (IntMap e -> [(Int, e)]
forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap e
m)
    get :: Get (IntMap e)
get   = ([(Int, e)] -> IntMap e) -> Get [(Int, e)] -> Get (IntMap e)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(Int, e)] -> IntMap e
forall a. [(Int, a)] -> IntMap a
IntMap.fromDistinctAscList Get [(Int, e)]
forall t. Binary t => Get t
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 :: Seq e -> Put
put Seq e
s = Int -> Put
forall t. Binary t => t -> Put
put (Seq e -> Int
forall a. Seq a -> Int
Seq.length Seq e
s) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (e -> Put) -> Seq e -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Fold.mapM_ e -> Put
forall t. Binary t => t -> Put
put Seq e
s
    get :: Get (Seq e)
get = do Int
n <- Get Int
forall t. Binary t => Get t
get :: Get Int
             Seq e -> Int -> Get e -> Get (Seq e)
forall t (m :: * -> *) a.
(Eq t, Num t, Monad m) =>
Seq a -> t -> m a -> m (Seq a)
rep Seq e
forall a. Seq a
Seq.empty Int
n Get e
forall t. Binary t => Get t
get
      where rep :: Seq a -> t -> m a -> m (Seq a)
rep Seq a
xs t
0 m a
_ = Seq a -> m (Seq a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seq a -> m (Seq a)) -> Seq a -> m (Seq a)
forall a b. (a -> b) -> a -> b
$! Seq a
xs
            rep Seq a
xs t
n m a
g = Seq a
xs Seq a -> m (Seq a) -> m (Seq a)
`seq` t
n t -> m (Seq a) -> m (Seq a)
`seq` do
                           a
x <- m a
g
                           Seq a -> t -> m a -> m (Seq a)
rep (Seq a
xs Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
Seq.|> a
x) (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) m a
g

#endif

------------------------------------------------------------------------
-- Floating point

-- instance Binary Double where
--     put d = put (decodeFloat d)
--     get   = liftM2 encodeFloat get get

instance Binary Double where
    put :: Double -> Put
put = Double -> Put
putFloat64be
    get :: Get Double
get = Get Double
getFloat64be

instance Binary Float where
    put :: Float -> Put
put Float
f = (Integer, Int) -> Put
forall t. Binary t => t -> Put
put (Float -> (Integer, Int)
forall a. RealFloat a => a -> (Integer, Int)
decodeFloat Float
f)
    get :: Get Float
get   = (Integer -> Int -> Float) -> Get Integer -> Get Int -> Get Float
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Integer -> Int -> Float
forall a. RealFloat a => Integer -> Int -> a
encodeFloat Get Integer
forall t. Binary t => Get t
get Get Int
forall t. Binary t => Get t
get

------------------------------------------------------------------------
-- Trees

instance (Binary e) => Binary (T.Tree e) where
    put :: Tree e -> Put
put (T.Node e
r Forest e
s) = e -> Put
forall t. Binary t => t -> Put
put e
r Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Forest e -> Put
forall t. Binary t => t -> Put
put Forest e
s
    get :: Get (Tree e)
get = (e -> Forest e -> Tree e)
-> Get e -> Get (Forest e) -> Get (Tree e)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 e -> Forest e -> Tree e
forall a. a -> Forest a -> Tree a
T.Node Get e
forall t. Binary t => Get t
get Get (Forest e)
forall t. Binary t => Get t
get

------------------------------------------------------------------------
-- Arrays

instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
    put :: Array i e -> Put
put Array i e
a = do
        (i, i) -> Put
forall t. Binary t => t -> Put
put (Array i e -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array i e
a)
        Int -> Put
forall t. Binary t => t -> Put
put ((i, i) -> Int
forall a. Ix a => (a, a) -> Int
rangeSize ((i, i) -> Int) -> (i, i) -> Int
forall a b. (a -> b) -> a -> b
$ Array i e -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array i e
a) -- write the length
        (e -> Put) -> [e] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ e -> Put
forall t. Binary t => t -> Put
put (Array i e -> [e]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems Array i e
a)        -- now the elems.
    get :: Get (Array i e)
get = do
        (i, i)
bs <- Get (i, i)
forall t. Binary t => Get t
get
        Int
n  <- Get Int
forall t. Binary t => Get t
get                  -- read the length
        [e]
xs <- Int -> Get e -> Get [e]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Get e
forall t. Binary t => Get t
get     -- now the elems.
        Array i e -> Get (Array i e)
forall (m :: * -> *) a. Monad m => a -> m a
return ((i, i) -> [e] -> Array i e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (i, i)
bs [e]
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 :: UArray i e -> Put
put UArray i e
a = do
        (i, i) -> Put
forall t. Binary t => t -> Put
put (UArray i e -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray i e
a)
        Int -> Put
forall t. Binary t => t -> Put
put ((i, i) -> Int
forall a. Ix a => (a, a) -> Int
rangeSize ((i, i) -> Int) -> (i, i) -> Int
forall a b. (a -> b) -> a -> b
$ UArray i e -> (i, i)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray i e
a) -- now write the length
        (e -> Put) -> [e] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ e -> Put
forall t. Binary t => t -> Put
put (UArray i e -> [e]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray i e
a)
    get :: Get (UArray i e)
get = do
        (i, i)
bs <- Get (i, i)
forall t. Binary t => Get t
get
        Int
n  <- Get Int
forall t. Binary t => Get t
get
        [e]
xs <- Int -> Get e -> Get [e]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Get e
forall t. Binary t => Get t
get
        UArray i e -> Get (UArray i e)
forall (m :: * -> *) a. Monad m => a -> m a
return ((i, i) -> [e] -> UArray i e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (i, i)
bs [e]
xs)