{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures
           , TypeOperators
           , BangPatterns
           , KindSignatures
           , ScopedTypeVariables #-}

#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif

-----------------------------------------------------------------------------
-- |
-- Module      : Data.Serialize
-- Copyright   : Lennart Kolmodin, Galois Inc. 2009
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Trevor Elliott <trevor@galois.com>
-- Stability   :
-- Portability :
--
-----------------------------------------------------------------------------

module Data.Serialize (

    -- * The Serialize class
      Serialize(..)

    -- $example

    -- * Serialize serialisation
    , encode, encodeLazy
    , decode, decodeLazy

    , expect
    , module Data.Serialize.Get
    , module Data.Serialize.Put
    , module Data.Serialize.IEEE754

    -- * Generic deriving
    , GSerializePut(..)
    , GSerializeGet(..)
    ) where

import Data.Serialize.Put
import Data.Serialize.Get
import Data.Serialize.IEEE754

import Control.Monad
import Data.Array.Unboxed
import Data.ByteString (ByteString)
import Data.Char    (chr,ord)
import Data.List    (unfoldr)
import Data.Word
import Foreign

-- And needed for the instances:
import qualified Data.ByteString       as B
import qualified Data.ByteString.Lazy  as L
import qualified Data.ByteString.Short as S
import qualified Data.Map              as Map
import qualified Data.Monoid           as M
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 qualified Data.Sequence         as Seq

import GHC.Generics

#if !(MIN_VERSION_base(4,8,0))
import Control.Applicative ((*>),(<*>),(<$>),pure)
#endif

#if MIN_VERSION_base(4,8,0)
import Numeric.Natural
#endif

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


-- | If your compiler has support for the @DeriveGeneric@ and
-- @DefaultSignatures@ language extensions (@ghc >= 7.2.1@), the 'put' and 'get'
-- methods will have default generic implementations.
--
-- To use this option, simply add a @deriving 'Generic'@ clause to your datatype
-- and declare a 'Serialize' instance for it without giving a definition for
-- 'put' and 'get'.
class Serialize t where
    -- | Encode a value in the Put monad.
    put :: Putter t
    -- | Decode a value in the Get monad
    get :: Get t

    default put :: (Generic t, GSerializePut (Rep t)) => Putter t
    put = Putter (Rep t (ZonkAny 0))
forall a. Putter (Rep t a)
forall (f :: * -> *) a. GSerializePut f => Putter (f a)
gPut Putter (Rep t (ZonkAny 0)) -> (t -> Rep t (ZonkAny 0)) -> Putter t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Rep t (ZonkAny 0)
forall x. t -> Rep t x
forall a x. Generic a => a -> Rep a x
from

    default get :: (Generic t, GSerializeGet (Rep t)) => Get t
    get = Rep t (ZonkAny 1) -> t
forall a x. Generic a => Rep a x -> a
forall x. Rep t x -> t
to (Rep t (ZonkAny 1) -> t) -> Get (Rep t (ZonkAny 1)) -> Get t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Rep t (ZonkAny 1))
forall a. Get (Rep t a)
forall (f :: * -> *) a. GSerializeGet f => Get (f a)
gGet

------------------------------------------------------------------------
-- Wrappers to run the underlying monad

-- | Encode a value using binary serialization to a strict ByteString.
encode :: Serialize a => a -> ByteString
encode :: forall a. Serialize a => 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. Serialize t => Putter t
put

-- | Encode a value using binary serialization to a lazy ByteString.
encodeLazy :: Serialize a => a -> L.ByteString
encodeLazy :: forall a. Serialize a => a -> ByteString
encodeLazy  = Put -> ByteString
runPutLazy (Put -> ByteString) -> (a -> Put) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Put
forall t. Serialize t => Putter t
put

-- | Decode a value from a strict ByteString, reconstructing the original
-- structure.
decode :: Serialize a => ByteString -> Either String a
decode :: forall a. Serialize a => ByteString -> Either String a
decode = Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
runGet Get a
forall t. Serialize t => Get t
get

-- | Decode a value from a lazy ByteString, reconstructing the original
-- structure.
decodeLazy :: Serialize a => L.ByteString -> Either String a
decodeLazy :: forall a. Serialize a => ByteString -> Either String a
decodeLazy  = Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
runGetLazy Get a
forall t. Serialize t => Get t
get


------------------------------------------------------------------------
-- Combinators

-- | Perform an action, failing if the read result does not match the argument
--   provided.
expect :: (Eq a, Serialize a) => a -> Get a
expect :: forall a. (Eq a, Serialize a) => a -> Get a
expect a
x = Get a
forall t. Serialize t => Get t
get Get a -> (a -> Get a) -> Get a
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
y -> if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y then a -> Get a
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x else Get a
forall a. Get a
forall (m :: * -> *) a. MonadPlus m => m a
mzero


------------------------------------------------------------------------
-- Simple instances

-- The () type need never be written to disk: values of singleton type
-- can be reconstructed from the type alone
instance Serialize () where
    put :: Putter ()
put ()  = Putter ()
forall a. a -> PutM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    get :: Get ()
get     = () -> Get ()
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{-# INLINE boolToWord8 #-}
boolToWord8 :: Bool -> Word8
boolToWord8 :: Bool -> Word8
boolToWord8 Bool
False = Word8
0
boolToWord8 Bool
True = Word8
1

{-# INLINE boolFromWord8 #-}
boolFromWord8 :: Word8 -> Get Bool
boolFromWord8 :: Word8 -> Get Bool
boolFromWord8 Word8
0 = Bool -> Get Bool
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
boolFromWord8 Word8
1 = Bool -> Get Bool
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
boolFromWord8 Word8
w = String -> Get Bool
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid Bool encoding " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
w)

{-# INLINE orderingToWord8 #-}
orderingToWord8 :: Ordering -> Word8
orderingToWord8 :: Ordering -> Word8
orderingToWord8 Ordering
LT = Word8
0
orderingToWord8 Ordering
EQ = Word8
1
orderingToWord8 Ordering
GT = Word8
2

{-# INLINE orderingFromWord8 #-}
orderingFromWord8 :: Word8 -> Get Ordering
orderingFromWord8 :: Word8 -> Get Ordering
orderingFromWord8 Word8
0 = Ordering -> Get Ordering
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
LT
orderingFromWord8 Word8
1 = Ordering -> Get Ordering
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
EQ
orderingFromWord8 Word8
2 = Ordering -> Get Ordering
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
GT
orderingFromWord8 Word8
w = String -> Get Ordering
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid Ordering encoding " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
w)

-- Bools are encoded as a byte in the range 0 .. 1
instance Serialize Bool where
    put :: Putter Bool
put     = Putter Word8
putWord8 Putter Word8 -> (Bool -> Word8) -> Putter Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Word8
boolToWord8
    get :: Get Bool
get     = Word8 -> Get Bool
boolFromWord8 (Word8 -> Get Bool) -> Get Word8 -> Get Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8

-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
instance Serialize Ordering where
    put :: Putter Ordering
put     = Putter Word8
putWord8 Putter Word8 -> (Ordering -> Word8) -> Putter Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ordering -> Word8
orderingToWord8
    get :: Get Ordering
get     = Word8 -> Get Ordering
orderingFromWord8 (Word8 -> Get Ordering) -> Get Word8 -> Get Ordering
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
getWord8

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

-- Words8s are written as bytes
instance Serialize Word8 where
    put :: Putter Word8
put     = Putter Word8
putWord8
    get :: Get Word8
get     = Get Word8
getWord8

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

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

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

-- Int8s are written as a single byte.
instance Serialize Int8 where
    put :: Putter Int8
put     = Putter Int8
putInt8
    get :: Get Int8
get     = Get Int8
getInt8

-- Int16s are written as a 2 bytes in big endian format
instance Serialize Int16 where
    put :: Putter Int16
put     = Putter Int16
putInt16be
    get :: Get Int16
get     = Get Int16
getInt16be

-- Int32s are written as a 4 bytes in big endian format
instance Serialize Int32 where
    put :: Putter Int32
put     = Putter Int32
putInt32be
    get :: Get Int32
get     = Get Int32
getInt32be

-- Int64s are written as a 8 bytes in big endian format
instance Serialize Int64 where
    put :: Putter Int64
put     = Putter Int64
putInt64be
    get :: Get Int64
get     = Get Int64
getInt64be

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

-- Words are are written as Word64s, that is, 8 bytes in big endian format
instance Serialize Word where
    put :: Putter Word
put Word
i   = Putter Word64
forall t. Serialize t => Putter t
put (Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i :: Word64)
    get :: Get Word
get     = (Word64 -> Word) -> Get Word64 -> Get Word
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Word64
forall t. Serialize t => Get t
get :: Get Word64)

-- Ints are are written as Int64s, that is, 8 bytes in big endian format
instance Serialize Int where
    put :: Putter Int
put Int
i   = Putter Int64
forall t. Serialize t => Putter t
put (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i :: Int64)
    get :: Get Int
get     = (Int64 -> Int) -> Get Int64 -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Int64
forall t. Serialize t => Get t
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 Serialize Integer where

    put :: Putter Integer
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
        Putter Word8
putWord8 Word8
0
        Putter Int32
forall t. Serialize t => Putter t
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
        Putter Word8
putWord8 Word8
1
        Putter Word8
forall t. Serialize t => Putter t
put Word8
sign
        let len :: Int
len = ((Integer -> Int
forall a. (Ord a, Integral a) => a -> Int
nrBits (Integer -> Integer
forall a. Num a => a -> a
abs Integer
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8)
        Putter Word64
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        Putter Word8 -> [Word8] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Putter Word8
forall t. Serialize t => Putter t
put (Integer -> [Word8]
forall a. (Integral a, Bits a) => a -> [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

    get :: Get Integer
get = do
        tag <- Get Word8
forall t. Serialize t => Get t
get :: Get Word8
        case 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. Serialize t => Get t
get :: Get SmallInt)
            Word8
_ -> do sign  <- Get Word8
forall t. Serialize t => Get t
get
                    bytes <- get
                    let v = [Word8] -> Integer
forall a. (Integral a, Bits a) => [Word8] -> a
roll [Word8]
bytes
                    return $! if sign == (1 :: Word8) then v else - v

--
-- Fold and unfold an Integer to and from a list of its bytes
--
unroll :: (Integral a, Bits a) => a -> [Word8]
unroll :: forall a. (Integral a, Bits a) => a -> [Word8]
unroll = (a -> Maybe (Word8, a)) -> a -> [Word8]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr a -> Maybe (Word8, a)
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 :: (Integral a, Bits a) => [Word8] -> a
roll :: forall a. (Integral a, Bits a) => [Word8] -> a
roll   = (Word8 -> a -> a) -> a -> [Word8] -> a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Word8 -> a -> a
forall {a} {a}. (Bits a, Integral a, Num a) => a -> a -> a
unstep a
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

nrBits :: (Ord a, Integral a) => a -> Int
nrBits :: forall a. (Ord a, Integral a) => a -> Int
nrBits a
k =
    let expMax :: Int
expMax = (Int -> Bool) -> (Int -> Int) -> Int -> Int
forall a. (a -> Bool) -> (a -> a) -> a -> a
until (\Int
e -> a
2 a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
k) (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Int
1
        findNr :: Int -> Int -> Int
        findNr :: Int -> Int -> Int
findNr Int
lo Int
hi
            | Int
mid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lo    = Int
hi
            | a
2 a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
mid a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
k = Int -> Int -> Int
findNr Int
mid Int
hi
            | Bool
otherwise    = Int -> Int -> Int
findNr Int
lo Int
mid
         where mid :: Int
mid = (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hi) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
    in Int -> Int -> Int
findNr (Int
expMax Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int
expMax

instance (Serialize a,Integral a) => Serialize (R.Ratio a) where
    put :: Putter (Ratio a)
put Ratio a
r = Putter a
forall t. Serialize t => Putter t
put (Ratio a -> a
forall a. Ratio a -> a
R.numerator Ratio a
r) Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter a
forall t. Serialize t => Putter t
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. Serialize t => Get t
get Get a
forall t. Serialize t => Get t
get

#if MIN_VERSION_base(4,8,0)
-- Fixed-size type for a subset of Natural
type NaturalWord = Word64

instance Serialize Natural where
    {-# INLINE put #-}
    put :: Putter Natural
put Natural
n | Natural
n Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
hi = do
        Putter Word8
putWord8 Word8
0
        Putter Word64
forall t. Serialize t => Putter t
put (Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n :: NaturalWord)  -- fast path
     where
        hi :: Natural
hi = Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: NaturalWord) :: Natural

    put Natural
n = do
        Putter Word8
putWord8 Word8
1
        let len :: Int
len = ((Natural -> Int
forall a. (Ord a, Integral a) => a -> Int
nrBits (Natural -> Natural
forall a. Num a => a -> a
abs Natural
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8)
        Putter Word64
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        Putter Word8 -> [Word8] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Putter Word8
forall t. Serialize t => Putter t
put (Natural -> [Word8]
forall a. (Integral a, Bits a) => a -> [Word8]
unroll (Natural -> Natural
forall a. Num a => a -> a
abs Natural
n))         -- unroll the bytes

    {-# INLINE get #-}
    get :: Get Natural
get = do
        tag <- Get Word8
forall t. Serialize t => Get t
get :: Get Word8
        case tag of
            Word8
0 -> (Word64 -> Natural) -> Get Word64 -> Get Natural
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Word64
forall t. Serialize t => Get t
get :: Get NaturalWord)
            Word8
_ -> do bytes <- Get [Word8]
forall t. Serialize t => Get t
get
                    return $! roll bytes
#endif

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

-- Safely wrap `chr` to avoid exceptions.
-- `chr` source: http://hackage.haskell.org/package/base-4.7.0.2/docs/src/GHC-Char.html#chr
chrEither :: Int -> Either String Char
chrEither :: Int -> Either String Char
chrEither Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10FFFF = Char -> Either String Char
forall a b. b -> Either a b
Right (Int -> Char
chr Int
i) -- Or: C# (chr# i#)
  | Bool
otherwise =
     String -> Either String Char
forall a b. a -> Either a b
Left (String
"bad argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)

-- Char is serialised as UTF-8
instance Serialize Char where
    put :: Putter Char
put Char
a | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x7f     = Putter Word8
forall t. Serialize t => Putter t
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 Putter Word8
forall t. Serialize t => Putter t
put (Word8
0xc0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
y)
                               Putter Word8
forall t. Serialize t => Putter t
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 Putter Word8
forall t. Serialize t => Putter t
put (Word8
0xe0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
x)
                               Putter Word8
forall t. Serialize t => Putter t
put (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
y)
                               Putter Word8
forall t. Serialize t => Putter t
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 Putter Word8
forall t. Serialize t => Putter t
put (Word8
0xf0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
w)
                               Putter Word8
forall t. Serialize t => Putter t
put (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
x)
                               Putter Word8
forall t. Serialize t => Putter t
put (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
y)
                               Putter Word8
forall t. Serialize t => Putter t
put (Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
z)
          | Bool
otherwise     = String -> Put
forall a. HasCallStack => String -> a
error String
"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. Serialize 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
        w <- Get Int
getByte
        r <- case () of
                ()
_ | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x80  -> Int -> Get Int
forall a. a -> Get a
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
                                    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
                                    return (x .|. shiftL6 (xor 0xc0 w))
                  | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xf0  -> do
                                    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
                                    y <- liftM (xor 0x80) getByte
                                    return (y .|. shiftL6 (x .|. shiftL6
                                            (xor 0xe0 w)))
                  | Bool
otherwise -> do
                                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
                                y <- liftM (xor 0x80) getByte
                                z <- liftM (xor 0x80) getByte
                                return (z .|. shiftL6 (y .|. shiftL6
                                        (x .|. shiftL6 (xor 0xf0 w))))
        case chrEither r of
            Right Char
r' ->
                Char -> Get Char
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Get Char) -> Char -> Get Char
forall a b. (a -> b) -> a -> b
$! Char
r'
            Left String
err ->
                String -> Get Char
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err

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

instance (Serialize a, Serialize b) => Serialize (a,b) where
    put :: Putter (a, b)
put = Putter a -> Putter b -> Putter (a, b)
forall a b. Putter a -> Putter b -> Putter (a, b)
putTwoOf Putter a
forall t. Serialize t => Putter t
put Putter b
forall t. Serialize t => Putter t
put
    get :: Get (a, b)
get = Get a -> Get b -> Get (a, b)
forall a b. Get a -> Get b -> Get (a, b)
getTwoOf Get a
forall t. Serialize t => Get t
get Get b
forall t. Serialize t => Get t
get

instance (Serialize a, Serialize b, Serialize c) => Serialize (a,b,c) where
    put :: Putter (a, b, c)
put (a
a,b
b,c
c)         = Putter a
forall t. Serialize t => Putter t
put a
a Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter b
forall t. Serialize t => Putter t
put b
b Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter c
forall t. Serialize t => Putter t
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. Serialize t => Get t
get Get b
forall t. Serialize t => Get t
get Get c
forall t. Serialize t => Get t
get

instance (Serialize a, Serialize b, Serialize c, Serialize d)
        => Serialize (a,b,c,d) where
    put :: Putter (a, b, c, d)
put (a
a,b
b,c
c,d
d)       = Putter a
forall t. Serialize t => Putter t
put a
a Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter b
forall t. Serialize t => Putter t
put b
b Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter c
forall t. Serialize t => Putter t
put c
c Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter d
forall t. Serialize t => Putter t
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. Serialize t => Get t
get Get b
forall t. Serialize t => Get t
get Get c
forall t. Serialize t => Get t
get Get d
forall t. Serialize t => Get t
get

instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e)
        => Serialize (a,b,c,d,e) where
    put :: Putter (a, b, c, d, e)
put (a
a,b
b,c
c,d
d,e
e)     = Putter a
forall t. Serialize t => Putter t
put a
a Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter b
forall t. Serialize t => Putter t
put b
b Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter c
forall t. Serialize t => Putter t
put c
c Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter d
forall t. Serialize t => Putter t
put d
d Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter e
forall t. Serialize t => Putter t
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. Serialize t => Get t
get Get b
forall t. Serialize t => Get t
get Get c
forall t. Serialize t => Get t
get Get d
forall t. Serialize t => Get t
get Get e
forall t. Serialize t => Get t
get

--
-- and now just recurse:
--

instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e
         , Serialize f)
        => Serialize (a,b,c,d,e,f) where
    put :: Putter (a, b, c, d, e, f)
put (a
a,b
b,c
c,d
d,e
e,f
f)   = Putter (a, (b, c, d, e, f))
forall t. Serialize t => Putter t
put (a
a,(b
b,c
c,d
d,e
e,f
f))
    get :: Get (a, b, c, d, e, f)
get                 = do (a,(b,c,d,e,f)) <- Get (a, (b, c, d, e, f))
forall t. Serialize t => Get t
get ; return (a,b,c,d,e,f)

instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e
         , Serialize f, Serialize g)
        => Serialize (a,b,c,d,e,f,g) where
    put :: Putter (a, b, c, d, e, f, g)
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g) = Putter (a, (b, c, d, e, f, g))
forall t. Serialize t => Putter t
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,(b,c,d,e,f,g)) <- Get (a, (b, c, d, e, f, g))
forall t. Serialize t => Get t
get ; return (a,b,c,d,e,f,g)

instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e,
          Serialize f, Serialize g, Serialize h)
        => Serialize (a,b,c,d,e,f,g,h) where
    put :: Putter (a, b, c, d, e, f, g, h)
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h) = Putter (a, (b, c, d, e, f, g, h))
forall t. Serialize t => Putter t
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,(b,c,d,e,f,g,h)) <- Get (a, (b, c, d, e, f, g, h))
forall t. Serialize t => Get t
get
                               return (a,b,c,d,e,f,g,h)

instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e,
          Serialize f, Serialize g, Serialize h, Serialize i)
        => Serialize (a,b,c,d,e,f,g,h,i) where
    put :: Putter (a, b, c, d, e, f, g, h, i)
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i) = Putter (a, (b, c, d, e, f, g, h, i))
forall t. Serialize t => Putter t
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,(b,c,d,e,f,g,h,i)) <- Get (a, (b, c, d, e, f, g, h, i))
forall t. Serialize t => Get t
get
                                 return (a,b,c,d,e,f,g,h,i)

instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e,
          Serialize f, Serialize g, Serialize h, Serialize i, Serialize j)
        => Serialize (a,b,c,d,e,f,g,h,i,j) where
    put :: Putter (a, b, c, d, e, f, g, h, i, j)
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j) = Putter (a, (b, c, d, e, f, g, h, i, j))
forall t. Serialize t => Putter t
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,(b,c,d,e,f,g,h,i,j)) <- Get (a, (b, c, d, e, f, g, h, i, j))
forall t. Serialize t => Get t
get
                                   return (a,b,c,d,e,f,g,h,i,j)

------------------------------------------------------------------------
-- Monoid newtype wrappers

instance Serialize a => Serialize (M.Dual a) where
    put :: Putter (Dual a)
put = Putter a
forall t. Serialize t => Putter t
put Putter a -> (Dual a -> a) -> Putter (Dual a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dual a -> a
forall a. Dual a -> a
M.getDual
    get :: Get (Dual a)
get = (a -> Dual a) -> Get a -> Get (Dual a)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Dual a
forall a. a -> Dual a
M.Dual Get a
forall t. Serialize t => Get t
get

instance Serialize M.All where
    put :: Putter All
put = Putter Bool
forall t. Serialize t => Putter t
put Putter Bool -> (All -> Bool) -> Putter All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. All -> Bool
M.getAll
    get :: Get All
get = (Bool -> All) -> Get Bool -> Get All
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> All
M.All Get Bool
forall t. Serialize t => Get t
get

instance Serialize M.Any where
    put :: Putter Any
put = Putter Bool
forall t. Serialize t => Putter t
put Putter Bool -> (Any -> Bool) -> Putter Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Bool
M.getAny
    get :: Get Any
get = (Bool -> Any) -> Get Bool -> Get Any
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Any
M.Any Get Bool
forall t. Serialize t => Get t
get

instance Serialize a => Serialize (M.Sum a) where
    put :: Putter (Sum a)
put = Putter a
forall t. Serialize t => Putter t
put Putter a -> (Sum a -> a) -> Putter (Sum a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum a -> a
forall a. Sum a -> a
M.getSum
    get :: Get (Sum a)
get = (a -> Sum a) -> Get a -> Get (Sum a)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Sum a
forall a. a -> Sum a
M.Sum Get a
forall t. Serialize t => Get t
get

instance Serialize a => Serialize (M.Product a) where
    put :: Putter (Product a)
put = Putter a
forall t. Serialize t => Putter t
put Putter a -> (Product a -> a) -> Putter (Product a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Product a -> a
forall a. Product a -> a
M.getProduct
    get :: Get (Product a)
get = (a -> Product a) -> Get a -> Get (Product a)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Product a
forall a. a -> Product a
M.Product Get a
forall t. Serialize t => Get t
get

instance Serialize a => Serialize (M.First a) where
    put :: Putter (First a)
put = Putter (Maybe a)
forall t. Serialize t => Putter t
put Putter (Maybe a) -> (First a -> Maybe a) -> Putter (First a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First a -> Maybe a
forall a. First a -> Maybe a
M.getFirst
    get :: Get (First a)
get = (Maybe a -> First a) -> Get (Maybe a) -> Get (First a)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe a -> First a
forall a. Maybe a -> First a
M.First Get (Maybe a)
forall t. Serialize t => Get t
get

instance Serialize a => Serialize (M.Last a) where
    put :: Putter (Last a)
put = Putter (Maybe a)
forall t. Serialize t => Putter t
put Putter (Maybe a) -> (Last a -> Maybe a) -> Putter (Last a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Last a -> Maybe a
forall a. Last a -> Maybe a
M.getLast
    get :: Get (Last a)
get = (Maybe a -> Last a) -> Get (Maybe a) -> Get (Last a)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe a -> Last a
forall a. Maybe a -> Last a
M.Last Get (Maybe a)
forall t. Serialize t => Get t
get

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

instance Serialize a => Serialize [a] where
    put :: Putter [a]
put = Putter a -> Putter [a]
forall a. Putter a -> Putter [a]
putListOf Putter a
forall t. Serialize t => Putter t
put
    get :: Get [a]
get = Get a -> Get [a]
forall a. Get a -> Get [a]
getListOf Get a
forall t. Serialize t => Get t
get

instance (Serialize a) => Serialize (Maybe a) where
    put :: Putter (Maybe a)
put = Putter a -> Putter (Maybe a)
forall a. Putter a -> Putter (Maybe a)
putMaybeOf Putter a
forall t. Serialize t => Putter t
put
    get :: Get (Maybe a)
get = Get a -> Get (Maybe a)
forall a. Get a -> Get (Maybe a)
getMaybeOf Get a
forall t. Serialize t => Get t
get

instance (Serialize a, Serialize b) => Serialize (Either a b) where
    put :: Putter (Either a b)
put = Putter a -> Putter b -> Putter (Either a b)
forall a b. Putter a -> Putter b -> Putter (Either a b)
putEitherOf Putter a
forall t. Serialize t => Putter t
put Putter b
forall t. Serialize t => Putter t
put
    get :: Get (Either a b)
get = Get a -> Get b -> Get (Either a b)
forall a b. Get a -> Get b -> Get (Either a b)
getEitherOf Get a
forall t. Serialize t => Get t
get Get b
forall t. Serialize t => Get t
get

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

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

instance Serialize L.ByteString where
    put :: Putter ByteString
put ByteString
bs = do Putter Int64
forall t. Serialize t => Putter t
put (ByteString -> Int64
L.length ByteString
bs :: Int64)
                Putter ByteString
putLazyByteString ByteString
bs
    get :: Get ByteString
get    = Get Int64
forall t. Serialize t => Get t
get Get Int64 -> (Int64 -> Get ByteString) -> Get ByteString
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int64 -> Get ByteString
getLazyByteString

instance Serialize S.ShortByteString where
    put :: Putter ShortByteString
put ShortByteString
sbs = do Putter Int
forall t. Serialize t => Putter t
put (ShortByteString -> Int
S.length ShortByteString
sbs)
                 Putter ShortByteString
putShortByteString ShortByteString
sbs
    get :: Get ShortByteString
get     = Get Int
forall t. Serialize t => Get t
get Get Int -> (Int -> Get ShortByteString) -> Get ShortByteString
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ShortByteString
getShortByteString


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

instance (Ord a, Serialize a) => Serialize (Set.Set a) where
    put :: Putter (Set a)
put = Putter a -> Putter (Set a)
forall a. Putter a -> Putter (Set a)
putSetOf Putter a
forall t. Serialize t => Putter t
put
    get :: Get (Set a)
get = Get a -> Get (Set a)
forall a. Ord a => Get a -> Get (Set a)
getSetOf Get a
forall t. Serialize t => Get t
get

instance (Ord k, Serialize k, Serialize e) => Serialize (Map.Map k e) where
    put :: Putter (Map k e)
put = Putter k -> Putter e -> Putter (Map k e)
forall k a. Putter k -> Putter a -> Putter (Map k a)
putMapOf Putter k
forall t. Serialize t => Putter t
put Putter e
forall t. Serialize t => Putter t
put
    get :: Get (Map k e)
get = Get k -> Get e -> Get (Map k e)
forall k a. Ord k => Get k -> Get a -> Get (Map k a)
getMapOf Get k
forall t. Serialize t => Get t
get Get e
forall t. Serialize t => Get t
get

instance Serialize IntSet.IntSet where
    put :: Putter IntSet
put = Putter Int -> Putter IntSet
putIntSetOf Putter Int
forall t. Serialize t => Putter t
put
    get :: Get IntSet
get = Get Int -> Get IntSet
getIntSetOf Get Int
forall t. Serialize t => Get t
get

instance (Serialize e) => Serialize (IntMap.IntMap e) where
    put :: Putter (IntMap e)
put = Putter Int -> Putter e -> Putter (IntMap e)
forall a. Putter Int -> Putter a -> Putter (IntMap a)
putIntMapOf Putter Int
forall t. Serialize t => Putter t
put Putter e
forall t. Serialize t => Putter t
put
    get :: Get (IntMap e)
get = Get Int -> Get e -> Get (IntMap e)
forall a. Get Int -> Get a -> Get (IntMap a)
getIntMapOf Get Int
forall t. Serialize t => Get t
get Get e
forall t. Serialize t => Get t
get

------------------------------------------------------------------------
-- Queues and Sequences

instance (Serialize e) => Serialize (Seq.Seq e) where
    put :: Putter (Seq e)
put = Putter e -> Putter (Seq e)
forall a. Putter a -> Putter (Seq a)
putSeqOf Putter e
forall t. Serialize t => Putter t
put
    get :: Get (Seq e)
get = Get e -> Get (Seq e)
forall a. Get a -> Get (Seq a)
getSeqOf Get e
forall t. Serialize t => Get t
get

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

instance Serialize Double where
    put :: Putter Double
put = Putter Double
putFloat64be
    get :: Get Double
get = Get Double
getFloat64be

instance Serialize Float where
    put :: Putter Float
put = Putter Float
putFloat32be
    get :: Get Float
get = Get Float
getFloat32be

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

instance (Serialize e) => Serialize (T.Tree e) where
    put :: Putter (Tree e)
put = Putter e -> Putter (Tree e)
forall a. Putter a -> Putter (Tree a)
putTreeOf Putter e
forall t. Serialize t => Putter t
put
    get :: Get (Tree e)
get = Get e -> Get (Tree e)
forall a. Get a -> Get (Tree a)
getTreeOf Get e
forall t. Serialize t => Get t
get

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

instance (Serialize i, Ix i, Serialize e) => Serialize (Array i e) where
    put :: Putter (Array i e)
put = Putter i -> Putter e -> Putter (Array i e)
forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
Putter i -> Putter e -> Putter (a i e)
putIArrayOf Putter i
forall t. Serialize t => Putter t
put Putter e
forall t. Serialize t => Putter t
put
    get :: Get (Array i e)
get = Get i -> Get e -> Get (Array i e)
forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
Get i -> Get e -> Get (a i e)
getIArrayOf Get i
forall t. Serialize t => Get t
get Get e
forall t. Serialize t => Get t
get

--
-- The IArray UArray e constraint is non portable. Requires flexible instances
--
instance (Serialize i, Ix i, Serialize e, IArray UArray e)
  => Serialize (UArray i e) where
    put :: Putter (UArray i e)
put = Putter i -> Putter e -> Putter (UArray i e)
forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
Putter i -> Putter e -> Putter (a i e)
putIArrayOf Putter i
forall t. Serialize t => Putter t
put Putter e
forall t. Serialize t => Putter t
put
    get :: Get (UArray i e)
get = Get i -> Get e -> Get (UArray i e)
forall i (a :: * -> * -> *) e.
(Ix i, IArray a e) =>
Get i -> Get e -> Get (a i e)
getIArrayOf Get i
forall t. Serialize t => Get t
get Get e
forall t. Serialize t => Get t
get

------------------------------------------------------------------------
-- Generic Serialze

class GSerializePut f where
    gPut :: Putter (f a)

class GSerializeGet f where
    gGet :: Get (f a)

instance GSerializePut a => GSerializePut (M1 i c a) where
    gPut :: forall a. Putter (M1 i c a a)
gPut = Putter (a a)
forall a. Putter (a a)
forall (f :: * -> *) a. GSerializePut f => Putter (f a)
gPut Putter (a a) -> (M1 i c a a -> a a) -> M1 i c a a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c a a -> a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
    {-# INLINE gPut #-}

instance GSerializeGet a => GSerializeGet (M1 i c a) where
    gGet :: forall a. Get (M1 i c a a)
gGet = a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 i c a a) -> Get (a a) -> Get (M1 i c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (a a)
forall a. Get (a a)
forall (f :: * -> *) a. GSerializeGet f => Get (f a)
gGet
    {-# INLINE gGet #-}

instance Serialize a => GSerializePut (K1 i a) where
    gPut :: forall a. Putter (K1 i a a)
gPut = Putter a
forall t. Serialize t => Putter t
put Putter a -> (K1 i a a -> a) -> K1 i a a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a a -> a
forall k i c (p :: k). K1 i c p -> c
unK1
    {-# INLINE gPut #-}

instance Serialize a => GSerializeGet (K1 i a) where
    gGet :: forall a. Get (K1 i a a)
gGet = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a) -> Get a -> Get (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
forall t. Serialize t => Get t
get
    {-# INLINE gGet #-}

instance GSerializePut U1 where
    gPut :: forall a. Putter (U1 a)
gPut U1 a
_ = Putter ()
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    {-# INLINE gPut #-}

instance GSerializeGet U1 where
    gGet :: forall a. Get (U1 a)
gGet   = U1 a -> Get (U1 a)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
    {-# INLINE gGet #-}

-- | Always fails to serialize
instance GSerializePut V1 where
    gPut :: forall a. Putter (V1 a)
gPut V1 a
v = V1 a
v V1 a -> Put -> Put
forall a b. a -> b -> b
`seq` String -> Put
forall a. HasCallStack => String -> a
error String
"GSerializePut.V1"
    {-# INLINE gPut #-}

-- | Always fails to deserialize
instance GSerializeGet V1 where
    gGet :: forall a. Get (V1 a)
gGet   = String -> Get (V1 a)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"GSerializeGet.V1"
    {-# INLINE gGet #-}

instance (GSerializePut a, GSerializePut b) => GSerializePut (a :*: b) where
    gPut :: forall a. Putter ((:*:) a b a)
gPut (a a
a :*: b a
b) = Putter (a a)
forall a. Putter (a a)
forall (f :: * -> *) a. GSerializePut f => Putter (f a)
gPut a a
a Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter (b a)
forall a. Putter (b a)
forall (f :: * -> *) a. GSerializePut f => Putter (f a)
gPut b a
b
    {-# INLINE gPut #-}

instance (GSerializeGet a, GSerializeGet b) => GSerializeGet (a :*: b) where
    gGet :: forall a. Get ((:*:) a b a)
gGet = a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a)
-> Get (a a) -> Get (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (a a)
forall a. Get (a a)
forall (f :: * -> *) a. GSerializeGet f => Get (f a)
gGet  Get (b a -> (:*:) a b a) -> Get (b a) -> Get ((:*:) a b a)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (b a)
forall a. Get (b a)
forall (f :: * -> *) a. GSerializeGet f => Get (f a)
gGet
    {-# INLINE gGet #-}

-- The following GSerialize* 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 ( PutSum        a, PutSum        b
         , SumSize       a, SumSize       b) => GSerializePut (a :+: b) where
    gPut :: forall a. Putter ((:+:) a b a)
gPut | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)
         | Bool
otherwise = String -> Word64 -> Putter ((:+:) a b a)
forall size error. Show size => String -> size -> error
sizeError String
"encode" Word64
size
      where
        size :: Word64
size = Tagged (a :+: b) Word64 -> Word64
forall (s :: * -> *) b. Tagged s b -> b
unTagged (Tagged (a :+: b) Word64
forall (f :: * -> *). SumSize f => Tagged f Word64
sumSize :: Tagged (a :+: b) Word64)
    {-# INLINE gPut #-}

instance ( GetSum        a, GetSum        b
         , SumSize       a, SumSize       b) => GSerializeGet (a :+: b) where
    gGet :: forall a. Get ((:+:) a b a)
gGet | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)
         | Bool
otherwise = String -> Word64 -> Get ((:+:) a b a)
forall size error. Show size => String -> size -> error
sizeError String
"decode" Word64
size
      where
        size :: Word64
size = Tagged (a :+: b) Word64 -> Word64
forall (s :: * -> *) b. Tagged s b -> b
unTagged (Tagged (a :+: b) Word64
forall (f :: * -> *). SumSize f => Tagged f Word64
sumSize :: Tagged (a :+: b) Word64)
    {-# INLINE gGet #-}

sizeError :: Show size => String -> size -> error
sizeError :: forall size error. Show size => String -> size -> error
sizeError String
s size
size = String -> error
forall a. HasCallStack => String -> a
error (String -> error) -> String -> error
forall a b. (a -> b) -> a -> b
$ String
"Can't " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" a type with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ size -> String
forall a. Show a => a -> String
show size
size String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" constructors"

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

class PutSum f where
    putSum :: (Num word, Bits word, Serialize word) => word -> word -> Putter (f a)

instance (PutSum a, PutSum b) => PutSum (a :+: b) where
    putSum :: forall word a.
(Num word, Bits word, Serialize word) =>
word -> word -> Putter ((:+:) a b a)
putSum !word
code !word
size (:+:) a b a
s = case (:+:) a b a
s of
                             L1 a a
x -> word -> word -> Putter (a a)
forall word a.
(Num word, Bits word, Serialize word) =>
word -> word -> Putter (a a)
forall (f :: * -> *) word a.
(PutSum f, Num word, Bits word, Serialize word) =>
word -> word -> Putter (f a)
putSum word
code           word
sizeL a a
x
                             R1 b a
x -> word -> word -> Putter (b a)
forall word a.
(Num word, Bits word, Serialize word) =>
word -> word -> Putter (b a)
forall (f :: * -> *) word a.
(PutSum f, Num word, Bits word, Serialize word) =>
word -> word -> Putter (f a)
putSum (word
code word -> word -> word
forall a. Num a => a -> a -> a
+ word
sizeL) word
sizeR b a
x
        where
#if MIN_VERSION_base(4,5,0)
          sizeL :: word
sizeL = word
size word -> Int -> word
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1
#else
          sizeL = size `shiftR` 1
#endif
          sizeR :: word
sizeR = word
size word -> word -> word
forall a. Num a => a -> a -> a
- word
sizeL
    {-# INLINE putSum #-}

instance GSerializePut a => PutSum (C1 c a) where
    putSum :: forall word a.
(Num word, Bits word, Serialize word) =>
word -> word -> Putter (C1 c a a)
putSum !word
code word
_ C1 c a a
x = Putter word
forall t. Serialize t => Putter t
put word
code Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter (C1 c a a)
forall a. Putter (M1 C c a a)
forall (f :: * -> *) a. GSerializePut f => Putter (f a)
gPut C1 c a a
x
    {-# INLINE putSum #-}

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

checkGetSum :: (Ord word, Num word, Bits word, GetSum f)
            => word -> word -> Get (f a)
checkGetSum :: forall word (f :: * -> *) a.
(Ord word, Num word, Bits word, GetSum f) =>
word -> word -> Get (f a)
checkGetSum word
size word
code | word
code word -> word -> Bool
forall a. Ord a => a -> a -> Bool
< word
size = word -> word -> Get (f a)
forall word a.
(Ord word, Num word, Bits word) =>
word -> word -> Get (f a)
forall (f :: * -> *) word a.
(GetSum f, Ord word, Num word, Bits word) =>
word -> word -> Get (f a)
getSum word
code word
size
                      | Bool
otherwise   = String -> Get (f a)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unknown encoding for constructor"
{-# INLINE checkGetSum #-}

class GetSum f where
    getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)

instance (GetSum a, GetSum b) => GetSum (a :+: b) where
    getSum :: forall word a.
(Ord word, Num word, Bits word) =>
word -> word -> Get ((:+:) a b a)
getSum !word
code !word
size | word
code word -> word -> Bool
forall a. Ord a => a -> a -> Bool
< word
sizeL = a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a a -> (:+:) a b a) -> Get (a a) -> Get ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> word -> word -> Get (a a)
forall word a.
(Ord word, Num word, Bits word) =>
word -> word -> Get (a a)
forall (f :: * -> *) word a.
(GetSum f, Ord word, Num word, Bits word) =>
word -> word -> Get (f a)
getSum word
code           word
sizeL
                       | Bool
otherwise    = b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b a -> (:+:) a b a) -> Get (b a) -> Get ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> word -> word -> Get (b a)
forall word a.
(Ord word, Num word, Bits word) =>
word -> word -> Get (b a)
forall (f :: * -> *) word a.
(GetSum f, Ord word, Num word, Bits word) =>
word -> word -> Get (f a)
getSum (word
code word -> word -> word
forall a. Num a => a -> a -> a
- word
sizeL) word
sizeR
        where
#if MIN_VERSION_base(4,5,0)
          sizeL :: word
sizeL = word
size word -> Int -> word
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1
#else
          sizeL = size `shiftR` 1
#endif
          sizeR :: word
sizeR = word
size word -> word -> word
forall a. Num a => a -> a -> a
- word
sizeL
    {-# INLINE getSum #-}

instance GSerializeGet a => GetSum (C1 c a) where
    getSum :: forall word a.
(Ord word, Num word, Bits word) =>
word -> word -> Get (C1 c a a)
getSum word
_ word
_ = Get (M1 C c a a)
forall a. Get (M1 C c a a)
forall (f :: * -> *) a. GSerializeGet f => Get (f a)
gGet
    {-# INLINE getSum #-}

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

class SumSize f where
    sumSize :: Tagged f Word64

newtype Tagged (s :: * -> *) b = Tagged {forall (s :: * -> *) b. Tagged s b -> b
unTagged :: b}

instance (SumSize a, SumSize b) => SumSize (a :+: b) where
    sumSize :: Tagged (a :+: b) Word64
sumSize = Word64 -> Tagged (a :+: b) Word64
forall (s :: * -> *) b. b -> Tagged s b
Tagged (Word64 -> Tagged (a :+: b) Word64)
-> Word64 -> Tagged (a :+: b) Word64
forall a b. (a -> b) -> a -> b
$ Tagged a Word64 -> Word64
forall (s :: * -> *) b. Tagged s b -> b
unTagged (Tagged a Word64
forall (f :: * -> *). SumSize f => Tagged f Word64
sumSize :: Tagged a Word64) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+
                       Tagged b Word64 -> Word64
forall (s :: * -> *) b. Tagged s b -> b
unTagged (Tagged b Word64
forall (f :: * -> *). SumSize f => Tagged f Word64
sumSize :: Tagged b Word64)

instance SumSize (C1 c a) where
    sumSize :: Tagged (C1 c a) Word64
sumSize = Word64 -> Tagged (C1 c a) Word64
forall (s :: * -> *) b. b -> Tagged s b
Tagged Word64
1