{-# 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 Any)
forall (f :: * -> *) a. GSerializePut f => Putter (f a)
gPut Putter (Rep t Any) -> (t -> Rep t Any) -> Putter t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Rep t Any
forall a x. Generic a => a -> Rep a x
from

    default get :: (Generic t, GSerializeGet (Rep t)) => Get t
    get = Rep t Any -> t
forall a x. Generic a => Rep a x -> a
to (Rep t Any -> t) -> Get (Rep t Any) -> Get t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Rep t Any)
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 :: 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 :: 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 :: 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 :: 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 :: a -> Get a
expect a
x = Get a
forall t. Serialize t => Get t
get Get a -> (a -> Get a) -> Get a
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 (m :: * -> *) a. Monad m => a -> m a
return a
x else 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 (m :: * -> *) a. Monad m => a -> m a
return ()
    get :: Get ()
get     = () -> Get ()
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False
boolFromWord8 Word8
1 = Bool -> Get Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
boolFromWord8 Word8
w = String -> Get Bool
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 (m :: * -> *) a. Monad m => a -> m a
return Ordering
LT
orderingFromWord8 Word8
1 = Ordering -> Get Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
EQ
orderingFromWord8 Word8
2 = Ordering -> Get Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
GT
orderingFromWord8 Word8
w = String -> Get Ordering
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
        Word8
tag <- Get Word8
forall t. Serialize 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. Serialize t => Get t
get :: Get SmallInt)
            Word8
_ -> do Word8
sign  <- Get Word8
forall t. Serialize t => Get t
get
                    [Word8]
bytes <- Get [Word8]
forall t. Serialize t => Get t
get
                    let v :: Integer
v = [Word8] -> Integer
forall a. (Integral a, Bits a) => [Word8] -> a
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 :: (Integral a, Bits a) => a -> [Word8]
unroll :: 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 :: [Word8] -> a
roll   = (Word8 -> a -> a) -> a -> [Word8] -> a
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 :: 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
            | 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
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 (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
        Word8
tag <- Get Word8
forall t. Serialize t => Get t
get :: Get Word8
        case Word8
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 [Word8]
bytes <- Get [Word8]
forall t. Serialize t => Get t
get
                    Natural -> Get Natural
forall (m :: * -> *) a. Monad m => a -> m a
return (Natural -> Get Natural) -> Natural -> Get Natural
forall a b. (a -> b) -> a -> b
$! [Word8] -> Natural
forall a. (Integral a, Bits a) => [Word8] -> a
roll [Word8]
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
        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))))
        case Int -> Either String Char
chrEither Int
r of
            Right Char
r' ->
                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
$! Char
r'
            Left String
err ->
                String -> Get Char
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 (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 (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 (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 (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 (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 (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 (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 (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 (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
a,(b
b,c
c,d
d,e
e,f
f)) <- Get (a, (b, c, d, e, f))
forall t. Serialize 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 (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
a,(b
b,c
c,d
d,e
e,f
f,g
g)) <- Get (a, (b, c, d, e, f, g))
forall t. Serialize 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 (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
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. Serialize 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 (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
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. Serialize 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 (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
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. Serialize 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)

------------------------------------------------------------------------
-- 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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 :: Putter (M1 i c a a)
gPut = Putter (a a)
forall (f :: * -> *) a. GSerializePut f => Putter (f a)
gPut Putter (a a) -> (M1 i c a a -> a a) -> Putter (M1 i c a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c a a -> a a
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
    {-# INLINE gPut #-}

instance GSerializeGet a => GSerializeGet (M1 i c a) where
    gGet :: 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 (f :: * -> *) a. GSerializeGet f => Get (f a)
gGet
    {-# INLINE gGet #-}

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

instance Serialize a => GSerializeGet (K1 i a) where
    gGet :: 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 :: Putter (U1 a)
gPut U1 a
_ = Putter ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    {-# INLINE gPut #-}

instance GSerializeGet U1 where
    gGet :: Get (U1 a)
gGet   = U1 a -> Get (U1 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 :: Putter (V1 a)
gPut V1 a
v = V1 a
v V1 a -> Put -> Put
`seq` String -> Put
forall a. HasCallStack => String -> a
error String
"GSerializePut.V1"
    {-# INLINE gPut #-}

-- | Always fails to deserialize
instance GSerializeGet V1 where
    gGet :: Get (V1 a)
gGet   = String -> Get (V1 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 :: Putter ((:*:) a b a)
gPut (a a
a :*: b a
b) = Putter (a a)
forall (f :: * -> *) a. GSerializePut f => Putter (f a)
gPut a a
a Put -> Put -> Put
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> 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 :: 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 (f :: * -> *) a. GSerializeGet f => Get (f a)
gGet  Get (b a -> (:*:) a b a) -> Get (b a) -> Get ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 :: 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 :: 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 :: 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 :: 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 (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 (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 :: 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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Putter (C1 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 :: 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 (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 (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 :: 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 (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 (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 :: word -> word -> Get (C1 c a a)
getSum word
_ word
_ = Get (C1 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 {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