{-# LANGUAGE CPP, FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Trustworthy #-}

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif

#if MIN_VERSION_base(4,16,0)
#define HAS_TYPELITS_CHAR
#endif

#if MIN_VERSION_base(4,8,0)
#define HAS_NATURAL
#define HAS_VOID
#endif

#if MIN_VERSION_base(4,7,0)
#define HAS_FIXED_CONSTRUCTOR
#endif

-----------------------------------------------------------------------------
-- |
-- Module      : Data.Binary.Class
-- Copyright   : Lennart Kolmodin
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Lennart Kolmodin <kolmodin@gmail.com>
-- Stability   : unstable
-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances
--
-- Typeclass and instances for binary serialization.
--
-----------------------------------------------------------------------------

module Data.Binary.Class (

    -- * The Binary class
      Binary(..)

    -- * Support for generics
    , GBinaryGet(..)
    , GBinaryPut(..)

    ) where

import Data.Word
import Data.Bits
import Data.Int
import Data.Complex (Complex(..))
#ifdef HAS_VOID
import Data.Void
#endif

import Data.Binary.Put
import Data.Binary.Get

#if ! MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Monoid (mempty)
#endif
import qualified Data.Monoid as Monoid
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity (Identity (..))
#endif
#if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup     as Semigroup
#endif
import Control.Monad

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder.Prim as Prim

import Data.List    (unfoldr, foldl')

-- And needed for the instances:
#if MIN_VERSION_base(4,10,0)
import Type.Reflection
import Type.Reflection.Unsafe
import Data.Kind (Type)
import GHC.Exts (RuntimeRep(..), VecCount, VecElem)
#endif
import qualified Data.ByteString as B
#if MIN_VERSION_bytestring(0,10,4)
import qualified Data.ByteString.Short as BS
#endif
import qualified Data.Map        as Map
import qualified Data.Set        as Set
import qualified Data.IntMap     as IntMap
import qualified Data.IntSet     as IntSet
import qualified Data.Ratio      as R

import qualified Data.Tree as T

import Data.Array.Unboxed

import GHC.Generics

#ifdef HAS_NATURAL
import Numeric.Natural
#endif

import qualified Data.Fixed as Fixed

#if __GLASGOW_HASKELL__ >= 901
import GHC.Exts (Levity(Lifted,Unlifted))
#endif

--
-- This isn't available in older Hugs or older GHC
--
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Fold

import GHC.Fingerprint

import Data.Version (Version(..))

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

-- Factored into two classes because this makes GHC optimize the
-- instances faster.  This doesn't matter for builds of binary,
-- but it matters a lot for end-users who write 'instance Binary T'.
-- See also: https://ghc.haskell.org/trac/ghc/ticket/9630
class GBinaryPut f where
    gput :: f t -> Put

class GBinaryGet f where
    gget :: Get (f t)

-- | The 'Binary' class provides 'put' and 'get', methods to encode and
-- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and
-- 'Show' classes for textual representation of Haskell types, and is
-- suitable for serialising Haskell values to disk, over the network.
--
-- For decoding and generating simple external binary formats (e.g. C
-- structures), Binary may be used, but in general is not suitable
-- for complex protocols. Instead use the 'Put' and 'Get' primitives
-- directly.
--
-- Instances of Binary should satisfy the following property:
--
-- > decode . encode == id
--
-- That is, the 'get' and 'put' methods should be the inverse of each
-- other. A range of instances are provided for basic Haskell types.
--
class Binary t where
    -- | Encode a value in the Put monad.
    put :: t -> Put
    -- | Decode a value in the Get monad
    get :: Get t

    -- | Encode a list of values in the Put monad.
    -- The default implementation may be overridden to be more efficient
    -- but must still have the same encoding format.
    putList :: [t] -> Put
    putList = forall a. Binary a => [a] -> Put
defaultPutList

    default put :: (Generic t, GBinaryPut (Rep t)) => t -> Put
    put = forall {k} (f :: k -> *) (t :: k). GBinaryPut f => f t -> Put
gput forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

    default get :: (Generic t, GBinaryGet (Rep t)) => Get t
    get = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall {k} (f :: k -> *) (t :: k). GBinaryGet f => Get (f t)
gget

{-# INLINE defaultPutList #-}
defaultPutList :: Binary a => [a] -> Put
defaultPutList :: forall a. Binary a => [a] -> Put
defaultPutList [a]
xs = forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall t. Binary t => t -> Put
put [a]
xs

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

#ifdef HAS_VOID
-- Void never gets written nor reconstructed since it's impossible to have a
-- value of that type

-- | @since 0.8.0.0
instance Binary Void where
    put :: Void -> Put
put     = forall a. Void -> a
absurd
    get :: Get Void
get     = forall (m :: * -> *) a. MonadPlus m => m a
mzero
#endif

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

-- Bools are encoded as a byte in the range 0 .. 1
instance Binary Bool where
    put :: Bool -> Put
put     = Word8 -> Put
putWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
    get :: Get Bool
get     = Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} {m :: * -> *}.
(Eq a, Num a, MonadFail m, Show a) =>
a -> m Bool
toBool
      where
        toBool :: a -> m Bool
toBool a
0 = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        toBool a
1 = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        toBool a
c = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Could not map value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
c forall a. [a] -> [a] -> [a]
++ String
" to Bool")

-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
instance Binary Ordering where
    put :: Ordering -> Put
put     = Word8 -> Put
putWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
    get :: Get Ordering
get     = Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} {m :: * -> *}.
(Eq a, Num a, MonadFail m, Show a) =>
a -> m Ordering
toOrd
      where
        toOrd :: a -> m Ordering
toOrd a
0 = forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
LT
        toOrd a
1 = forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
EQ
        toOrd a
2 = forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
GT
        toOrd a
c = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Could not map value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
c forall a. [a] -> [a] -> [a]
++ String
" to Ordering")

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

-- Words8s are written as bytes
instance Binary Word8 where
    put :: Word8 -> Put
put     = Word8 -> Put
putWord8
    {-# INLINE putList #-}
    putList :: [Word8] -> Put
putList [Word8]
xs =
        forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
xs)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Word8
Prim.word8 [Word8]
xs)
    get :: Get Word8
get     = Get Word8
getWord8

-- Words16s are written as 2 bytes in big-endian (network) order
instance Binary Word16 where
    put :: Word16 -> Put
put     = Word16 -> Put
putWord16be
    {-# INLINE putList #-}
    putList :: [Word16] -> Put
putList [Word16]
xs =
        forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word16]
xs)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Word16
Prim.word16BE [Word16]
xs)
    get :: Get Word16
get     = Get Word16
getWord16be

-- Words32s are written as 4 bytes in big-endian (network) order
instance Binary Word32 where
    put :: Word32 -> Put
put     = Word32 -> Put
putWord32be
    {-# INLINE putList #-}
    putList :: [Word32] -> Put
putList [Word32]
xs =
        forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word32]
xs)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Word32
Prim.word32BE [Word32]
xs)
    get :: Get Word32
get     = Get Word32
getWord32be

-- Words64s are written as 8 bytes in big-endian (network) order
instance Binary Word64 where
    put :: Word64 -> Put
put     = Word64 -> Put
putWord64be
    {-# INLINE putList #-}
    putList :: [Word64] -> Put
putList [Word64]
xs =
        forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word64]
xs)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Word64
Prim.word64BE [Word64]
xs)
    get :: Get Word64
get     = Get Word64
getWord64be

-- Int8s are written as a single byte.
instance Binary Int8 where
    put :: Int8 -> Put
put     = Int8 -> Put
putInt8
    {-# INLINE putList #-}
    putList :: [Int8] -> Put
putList [Int8]
xs =
        forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int8]
xs)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Int8
Prim.int8 [Int8]
xs)
    get :: Get Int8
get     = Get Int8
getInt8

-- Int16s are written as a 2 bytes in big endian format
instance Binary Int16 where
    put :: Int16 -> Put
put     = Int16 -> Put
putInt16be
    {-# INLINE putList #-}
    putList :: [Int16] -> Put
putList [Int16]
xs =
        forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int16]
xs)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Int16
Prim.int16BE [Int16]
xs)
    get :: Get Int16
get     = Get Int16
getInt16be

-- Int32s are written as a 4 bytes in big endian format
instance Binary Int32 where
    put :: Int32 -> Put
put     = Int32 -> Put
putInt32be
    {-# INLINE putList #-}
    putList :: [Int32] -> Put
putList [Int32]
xs =
        forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int32]
xs)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Int32
Prim.int32BE [Int32]
xs)
    get :: Get Int32
get     = Get Int32
getInt32be

-- Int64s are written as a 8 bytes in big endian format
instance Binary Int64 where
    put :: Int64 -> Put
put     = Int64 -> Put
putInt64be
    {-# INLINE putList #-}
    putList :: [Int64] -> Put
putList [Int64]
xs =
        forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int64]
xs)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Int64
Prim.int64BE [Int64]
xs)
    get :: Get Int64
get     = Get Int64
getInt64be

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

-- Words are are written as Word64s, that is, 8 bytes in big endian format
instance Binary Word where
    put :: Word -> Put
put     = Word64 -> Put
putWord64be forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    {-# INLINE putList #-}
    putList :: [Word] -> Put
putList [Word]
xs =
        forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
xs)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Word64
Prim.word64BE (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word]
xs))
    get :: Get Word
get     = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word64
getWord64be

-- Ints are are written as Int64s, that is, 8 bytes in big endian format
instance Binary Int where
    put :: Int -> Put
put     = Int64 -> Put
putInt64be forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    {-# INLINE putList #-}
    putList :: [Int] -> Put
putList [Int]
xs =
        forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs)
        forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Int64
Prim.int64BE (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int]
xs))
    get :: Get Int
get     = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Int64
getInt64be

------------------------------------------------------------------------
--
-- Portable, and pretty efficient, serialisation of Integer
--

-- Fixed-size type for a subset of Integer
type SmallInt = Int32

-- Integers are encoded in two ways: if they fit inside a SmallInt,
-- they're written as a byte tag, and that value.  If the Integer value
-- is too large to fit in a SmallInt, it is written as a byte array,
-- along with a sign and length field.

instance Binary Integer where

    {-# INLINE put #-}
    put :: Integer -> Put
put Integer
n | Integer
n forall a. Ord a => a -> a -> Bool
>= Integer
lo Bool -> Bool -> Bool
&& Integer
n forall a. Ord a => a -> a -> Bool
<= Integer
hi =
        Builder -> Put
putBuilder (forall a. FixedPrim a -> a -> Builder
Prim.primFixed (FixedPrim Word8
Prim.word8 forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
Prim.>*< FixedPrim Int32
Prim.int32BE) (Word8
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n))
     where
        lo :: Integer
lo = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
minBound :: SmallInt) :: Integer
        hi :: Integer
hi = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: SmallInt) :: Integer

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

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

-- | @since 0.8.0.0
#ifdef HAS_FIXED_CONSTRUCTOR
instance Binary (Fixed.Fixed a) where
  put :: Fixed a -> Put
put (Fixed.MkFixed Integer
a) = forall t. Binary t => t -> Put
put Integer
a
  get :: Get (Fixed a)
get = forall k (a :: k). Integer -> Fixed a
Fixed.MkFixed forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall t. Binary t => Get t
get
#else
instance forall a. Fixed.HasResolution a => Binary (Fixed.Fixed a) where
  -- Using undefined :: Maybe a as a proxy, as Data.Proxy is introduced only in base-4.7
  put x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer)
  get = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftM` get
#endif

--
-- 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 = forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr forall {b} {a}. (Integral b, Num a, Bits b) => b -> Maybe (a, b)
step
  where
    step :: b -> Maybe (a, b)
step b
0 = forall a. Maybe a
Nothing
    step b
i = forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral b
i, b
i 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   = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a} {a}. (Bits a, Integral a, Num a) => a -> a -> a
unstep a
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  where
    unstep :: a -> a -> a
unstep a
a a
b = a
a forall a. Bits a => a -> Int -> a
`shiftL` Int
8 forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b

#ifdef HAS_NATURAL
-- Fixed-size type for a subset of Natural
type NaturalWord = Word64

-- | @since 0.7.3.0
instance Binary Natural where
    {-# INLINE put #-}
    put :: Natural -> Put
put Natural
n | Natural
n forall a. Ord a => a -> a -> Bool
<= Natural
hi =
        Word8 -> Put
putWord8 Word8
0
        forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n :: NaturalWord)  -- fast path
     where
        hi :: Natural
hi = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: NaturalWord) :: Natural

    put Natural
n =
        Word8 -> Put
putWord8 Word8
1
        forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put (forall a. (Integral a, Bits a) => a -> [Word8]
unroll (forall a. Num a => a -> a
abs Natural
n))         -- unroll the bytes

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

{-

--
-- An efficient, raw serialisation for Integer (GHC only)
--

-- TODO  This instance is not architecture portable.  GMP stores numbers as
-- arrays of machine sized words, so the byte format is not portable across
-- architectures with different endianness and word size.

import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)
import GHC.Base     hiding (ord, chr)
import GHC.Prim
import GHC.Ptr (Ptr(..))
import GHC.IOBase (IO(..))

instance Binary Integer where
    put (S# i)    = putWord8 0 >> put (I# i)
    put (J# s ba) = do
        putWord8 1
        put (I# s)
        put (BA ba)

    get = do
        b <- getWord8
        case b of
            0 -> do (I# i#) <- get
                    return (S# i#)
            _ -> do (I# s#) <- get
                    (BA a#) <- get
                    return (J# s# a#)

instance Binary ByteArray where

    -- Pretty safe.
    put (BA ba) =
        let sz   = sizeofByteArray# ba   -- (primitive) in *bytes*
            addr = byteArrayContents# ba
            bs   = unsafePackAddress (I# sz) addr
        in put bs   -- write as a ByteString. easy, yay!

    -- Pretty scary. Should be quick though
    get = do
        (fp, off, n@(I# sz)) <- liftM toForeignPtr get      -- so decode a ByteString
        assert (off == 0) $ return $ unsafePerformIO $ do
            (MBA arr) <- newByteArray sz                    -- and copy it into a ByteArray#
            let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?
            withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)
            freezeByteArray arr

-- wrapper for ByteArray#
data ByteArray = BA  {-# UNPACK #-} !ByteArray#
data MBA       = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)

newByteArray :: Int# -> IO MBA
newByteArray sz = IO $ \s ->
  case newPinnedByteArray# sz s of { (# s', arr #) ->
  (# s', MBA arr #) }

freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
freezeByteArray arr = IO $ \s ->
  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
  (# s', BA arr' #) }

-}

instance (Binary a,Integral a) => Binary (R.Ratio a) where
    put :: Ratio a -> Put
put Ratio a
r = forall t. Binary t => t -> Put
put (forall a. Ratio a -> a
R.numerator Ratio a
r) forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put (forall a. Ratio a -> a
R.denominator Ratio a
r)
    get :: Get (Ratio a)
get = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Integral a => a -> a -> Ratio a
(R.%) forall t. Binary t => Get t
get forall t. Binary t => Get t
get

instance Binary a => Binary (Complex a) where
    {-# INLINE put #-}
    put :: Complex a -> Put
put (a
r :+ a
i) = forall t. Binary t => t -> Put
put (a
r, a
i)
    {-# INLINE get #-}
    get :: Get (Complex a)
get = (\(a
r,a
i) -> a
r forall a. a -> a -> Complex a
:+ a
i) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get

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

-- Char is serialised as UTF-8
instance Binary Char where
    put :: Char -> Put
put = Char -> Put
putCharUtf8
    putList :: String -> Put
putList String
str = forall t. Binary t => t -> Put
put (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) forall a. Semigroup a => a -> a -> a
<> String -> Put
putStringUtf8 String
str
    get :: Get Char
get = do
        let getByte :: Get Int
getByte = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word8 -> Int) forall t. Binary t => Get t
get
            shiftL6 :: Int -> Int
shiftL6 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Bits a => a -> Int -> a
shiftL Int
6 :: Int -> Int
        Int
w <- Get Int
getByte
        Int
r <- case () of
                ()
_ | Int
w forall a. Ord a => a -> a -> Bool
< Int
0x80  -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
w
                  | Int
w forall a. Ord a => a -> a -> Bool
< Int
0xe0  -> do
                                    Int
x <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (forall a. Bits a => a -> a -> a
xor Int
0xc0 Int
w))
                  | Int
w forall a. Ord a => a -> a -> Bool
< Int
0xf0  -> do
                                    Int
x <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    Int
y <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    forall (m :: * -> *) a. Monad m => a -> m a
return (Int
y forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (Int
x forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6
                                            (forall a. Bits a => a -> a -> a
xor Int
0xe0 Int
w)))
                  | Bool
otherwise -> do
                                Int
x <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                Int
y <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                Int
z <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                forall (m :: * -> *) a. Monad m => a -> m a
return (Int
z forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (Int
y forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6
                                        (Int
x forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (forall a. Bits a => a -> a -> a
xor Int
0xf0 Int
w))))
        forall {a} {m :: * -> *} {a}.
(Ord a, Num a, Enum a, Enum a, MonadFail m) =>
a -> m a
getChr Int
r
      where
        getChr :: a -> m a
getChr a
w
          | a
w forall a. Ord a => a -> a -> Bool
<= a
0x10ffff = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum a
w
          | Bool
otherwise = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a valid Unicode code point!"

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

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

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

instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
    {-# INLINE put #-}
    put :: (a, b, c, d) -> Put
put (a
a,b
b,c
c,d
d)       = forall t. Binary t => t -> Put
put a
a forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put b
b forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put c
c forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put d
d
    {-# INLINE get #-}
    get :: Get (a, b, c, d)
get                 = 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 (,,,) forall t. Binary t => Get t
get forall t. Binary t => Get t
get forall t. Binary t => Get t
get forall t. Binary t => Get t
get

instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
    {-# INLINE put #-}
    put :: (a, b, c, d, e) -> Put
put (a
a,b
b,c
c,d
d,e
e)     = forall t. Binary t => t -> Put
put a
a forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put b
b forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put c
c forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put d
d forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put e
e
    {-# INLINE get #-}
    get :: Get (a, b, c, d, e)
get                 = 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 (,,,,) forall t. Binary t => Get t
get forall t. Binary t => Get t
get forall t. Binary t => Get t
get forall t. Binary t => Get t
get forall t. Binary t => Get t
get

--
-- and now just recurse:
--

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)
        => Binary (a,b,c,d,e,f) where
    {-# INLINE put #-}
    put :: (a, b, c, d, e, f) -> Put
put (a
a,b
b,c
c,d
d,e
e,f
f)   = forall t. Binary t => t -> Put
put (a
a,(b
b,c
c,d
d,e
e,f
f))
    {-# INLINE get #-}
    get :: Get (a, b, c, d, e, f)
get                 = do (a
a,(b
b,c
c,d
d,e
e,f
f)) <- forall t. Binary t => Get t
get ; forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f)

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)
        => Binary (a,b,c,d,e,f,g) where
    {-# INLINE put #-}
    put :: (a, b, c, d, e, f, g) -> Put
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g) = forall t. Binary t => t -> Put
put (a
a,(b
b,c
c,d
d,e
e,f
f,g
g))
    {-# INLINE get #-}
    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)) <- forall t. Binary t => Get t
get ; forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f,g
g)

instance (Binary a, Binary b, Binary c, Binary d, Binary e,
          Binary f, Binary g, Binary h)
        => Binary (a,b,c,d,e,f,g,h) where
    {-# INLINE put #-}
    put :: (a, b, c, d, e, f, g, h) -> Put
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h) = forall t. Binary t => t -> Put
put (a
a,(b
b,c
c,d
d,e
e,f
f,g
g,h
h))
    {-# INLINE get #-}
    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)) <- forall t. Binary t => Get t
get ; forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h)

instance (Binary a, Binary b, Binary c, Binary d, Binary e,
          Binary f, Binary g, Binary h, Binary i)
        => Binary (a,b,c,d,e,f,g,h,i) where
    {-# INLINE put #-}
    put :: (a, b, c, d, e, f, g, h, i) -> Put
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i) = forall t. Binary t => t -> Put
put (a
a,(b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i))
    {-# INLINE get #-}
    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)) <- forall t. Binary t => Get t
get ; forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i)

instance (Binary a, Binary b, Binary c, Binary d, Binary e,
          Binary f, Binary g, Binary h, Binary i, Binary j)
        => Binary (a,b,c,d,e,f,g,h,i,j) where
    {-# INLINE put #-}
    put :: (a, b, c, d, e, f, g, h, i, j) -> Put
put (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j) = forall t. Binary t => t -> Put
put (a
a,(b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j))
    {-# INLINE get #-}
    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)) <- forall t. Binary t => Get t
get ; forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f,g
g,h
h,i
i,j
j)

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

#if MIN_VERSION_base(4,8,0)
instance Binary a => Binary (Identity a) where
  put :: Identity a -> Put
put (Identity a
x) = forall t. Binary t => t -> Put
put a
x
  get :: Get (Identity a)
get = forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get
#endif

instance Binary a => Binary [a] where
    put :: [a] -> Put
put = forall a. Binary a => [a] -> Put
putList
    get :: Get [a]
get = do Int
n <- forall t. Binary t => Get t
get :: Get Int
             forall a. Binary a => Int -> Get [a]
getMany Int
n

-- | @'getMany' n@ get @n@ elements in order, without blowing the stack.
getMany :: Binary a => Int -> Get [a]
getMany :: forall a. Binary a => Int -> Get [a]
getMany Int
n = forall {t} {a}. (Eq t, Num t, Binary a) => [a] -> t -> Get [a]
go [] Int
n
 where
    go :: [a] -> t -> Get [a]
go [a]
xs t
0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. [a] -> [a]
reverse [a]
xs
    go [a]
xs t
i = do a
x <- forall t. Binary t => Get t
get
                 -- we must seq x to avoid stack overflows due to laziness in
                 -- (>>=)
                 a
x seq :: forall a b. a -> b -> b
`seq` [a] -> t -> Get [a]
go (a
xforall a. a -> [a] -> [a]
:[a]
xs) (t
iforall a. Num a => a -> a -> a
-t
1)
{-# INLINE getMany #-}

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

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

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

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

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


#if MIN_VERSION_bytestring(0,10,4)
instance Binary BS.ShortByteString where
   put :: ShortByteString -> Put
put ShortByteString
bs = forall t. Binary t => t -> Put
put (ShortByteString -> Int
BS.length ShortByteString
bs)
            forall a. Semigroup a => a -> a -> a
<> ShortByteString -> Put
putShortByteString ShortByteString
bs
   get :: Get ShortByteString
get = forall t. Binary t => Get t
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ShortByteString
BS.toShort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Get ByteString
getByteString
#endif

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

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

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

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

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

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

--
-- This is valid Hugs, but you need the most recent Hugs
--

instance (Binary e) => Binary (Seq.Seq e) where
    put :: Seq e -> Put
put Seq e
s = forall t. Binary t => t -> Put
put (forall a. Seq a -> Int
Seq.length Seq e
s) forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Fold.mapM_ forall t. Binary t => t -> Put
put Seq e
s
    get :: Get (Seq e)
get = do Int
n <- forall t. Binary t => Get t
get :: Get Int
             forall {t} {m :: * -> *} {a}.
(Eq t, Num t, Monad m) =>
Seq a -> t -> m a -> m (Seq a)
rep forall a. Seq a
Seq.empty Int
n forall t. Binary t => Get t
get
      where rep :: Seq a -> t -> m a -> m (Seq a)
rep Seq a
xs t
0 m a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Seq a
xs
            rep Seq a
xs t
n m a
g = Seq a
xs seq :: forall a b. a -> b -> b
`seq` t
n seq :: forall a b. a -> b -> b
`seq` do
                           a
x <- m a
g
                           Seq a -> t -> m a -> m (Seq a)
rep (Seq a
xs forall a. Seq a -> a -> Seq a
Seq.|> a
x) (t
nforall a. Num a => a -> a -> a
-t
1) m a
g

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

instance Binary Double where
    put :: Double -> Put
put Double
d = forall t. Binary t => t -> Put
put (forall a. RealFloat a => a -> (Integer, Int)
decodeFloat Double
d)
    get :: Get Double
get   = do
        Integer
x <- forall t. Binary t => Get t
get
        Int
y <- forall t. Binary t => Get t
get
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
x Int
y

instance Binary Float where
    put :: Float -> Put
put Float
f = forall t. Binary t => t -> Put
put (forall a. RealFloat a => a -> (Integer, Int)
decodeFloat Float
f)
    get :: Get Float
get   =  do
        Integer
x <- forall t. Binary t => Get t
get
        Int
y <- forall t. Binary t => Get t
get
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
x Int
y

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

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

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

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

--
-- The IArray UArray e constraint is non portable. Requires flexible instances
--
instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
    put :: UArray i e -> Put
put UArray i e
a =
        forall t. Binary t => t -> Put
put (forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray i e
a)
        forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put (forall a. Ix a => (a, a) -> Int
rangeSize forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray i e
a) -- now write the length
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall t. Binary t => t -> Put
put (forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray i e
a)
    get :: Get (UArray i e)
get = do
        (i, i)
bs <- forall t. Binary t => Get t
get
        Int
n  <- forall t. Binary t => Get t
get
        [e]
xs <- forall a. Binary a => Int -> Get [a]
getMany Int
n
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (i, i)
bs [e]
xs)

------------------------------------------------------------------------
-- Fingerprints

-- | @since 0.7.6.0
instance Binary Fingerprint where
    put :: Fingerprint -> Put
put (Fingerprint Word64
x1 Word64
x2) = forall t. Binary t => t -> Put
put Word64
x1 forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put Word64
x2
    get :: Get Fingerprint
get = do
        Word64
x1 <- forall t. Binary t => Get t
get
        Word64
x2 <- forall t. Binary t => Get t
get
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Word64 -> Word64 -> Fingerprint
Fingerprint Word64
x1 Word64
x2

------------------------------------------------------------------------
-- Version

-- | @since 0.8.0.0
instance Binary Version where
    put :: Version -> Put
put (Version [Int]
br [String]
tags) = forall t. Binary t => t -> Put
put [Int]
br forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put [String]
tags
    get :: Get Version
get = [Int] -> [String] -> Version
Version forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get

------------------------------------------------------------------------
-- Data.Monoid datatypes

-- | @since 0.8.4.0
instance Binary a => Binary (Monoid.Dual a) where
  get :: Get (Dual a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Dual a
Monoid.Dual forall t. Binary t => Get t
get
  put :: Dual a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Dual a -> a
Monoid.getDual

-- | @since 0.8.4.0
instance Binary Monoid.All where
  get :: Get All
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> All
Monoid.All forall t. Binary t => Get t
get
  put :: All -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. All -> Bool
Monoid.getAll

-- | @since 0.8.4.0
instance Binary Monoid.Any where
  get :: Get Any
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Any
Monoid.Any forall t. Binary t => Get t
get
  put :: Any -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Bool
Monoid.getAny

-- | @since 0.8.4.0
instance Binary a => Binary (Monoid.Sum a) where
  get :: Get (Sum a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Sum a
Monoid.Sum forall t. Binary t => Get t
get
  put :: Sum a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Sum a -> a
Monoid.getSum

-- | @since 0.8.4.0
instance Binary a => Binary (Monoid.Product a) where
  get :: Get (Product a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Product a
Monoid.Product forall t. Binary t => Get t
get
  put :: Product a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Product a -> a
Monoid.getProduct

-- | @since 0.8.4.0
instance Binary a => Binary (Monoid.First a) where
  get :: Get (First a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> First a
Monoid.First forall t. Binary t => Get t
get
  put :: First a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. First a -> Maybe a
Monoid.getFirst

-- | @since 0.8.4.0
instance Binary a => Binary (Monoid.Last a) where
  get :: Get (Last a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Last a
Monoid.Last forall t. Binary t => Get t
get
  put :: Last a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Last a -> Maybe a
Monoid.getLast

#if MIN_VERSION_base(4,8,0)
-- | @since 0.8.4.0
instance Binary (f a) => Binary (Monoid.Alt f a) where
  get :: Get (Alt f a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (f :: k -> *) (a :: k). f a -> Alt f a
Monoid.Alt forall t. Binary t => Get t
get
  put :: Alt f a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). Alt f a -> f a
Monoid.getAlt
#endif

#if MIN_VERSION_base(4,9,0)
------------------------------------------------------------------------
-- Data.Semigroup datatypes

-- | @since 0.8.4.0
instance Binary a => Binary (Semigroup.Min a) where
  get :: Get (Min a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Min a
Semigroup.Min forall t. Binary t => Get t
get
  put :: Min a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Min a -> a
Semigroup.getMin

-- | @since 0.8.4.0
instance Binary a => Binary (Semigroup.Max a) where
  get :: Get (Max a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Max a
Semigroup.Max forall t. Binary t => Get t
get
  put :: Max a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Max a -> a
Semigroup.getMax

-- | @since 0.8.4.0
instance Binary a => Binary (Semigroup.First a) where
  get :: Get (First a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> First a
Semigroup.First forall t. Binary t => Get t
get
  put :: First a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. First a -> a
Semigroup.getFirst

-- | @since 0.8.4.0
instance Binary a => Binary (Semigroup.Last a) where
  get :: Get (Last a)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Last a
Semigroup.Last forall t. Binary t => Get t
get
  put :: Last a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Last a -> a
Semigroup.getLast

#if __GLASGOW_HASKELL__ < 901
-- | @since 0.8.4.0
instance Binary a => Binary (Semigroup.Option a) where
  get = fmap Semigroup.Option get
  put = put . Semigroup.getOption
#endif

-- | @since 0.8.4.0
instance Binary m => Binary (Semigroup.WrappedMonoid m) where
  get :: Get (WrappedMonoid m)
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall m. m -> WrappedMonoid m
Semigroup.WrapMonoid forall t. Binary t => Get t
get
  put :: WrappedMonoid m -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. WrappedMonoid m -> m
Semigroup.unwrapMonoid

-- | @since 0.8.4.0
instance (Binary a, Binary b) => Binary (Semigroup.Arg a b) where
  get :: Get (Arg a b)
get                     = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a b. a -> b -> Arg a b
Semigroup.Arg forall t. Binary t => Get t
get forall t. Binary t => Get t
get
  put :: Arg a b -> Put
put (Semigroup.Arg a
a b
b) = forall t. Binary t => t -> Put
put a
a forall a. Semigroup a => a -> a -> a
<> forall t. Binary t => t -> Put
put b
b

------------------------------------------------------------------------
-- Non-empty lists

-- | @since 0.8.4.0
instance Binary a => Binary (NE.NonEmpty a) where
  get :: Get (NonEmpty a)
get = do
      [a]
list <- forall t. Binary t => Get t
get
      case [a]
list of
        [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"NonEmpty is empty!"
        a
x:[a]
xs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x forall a. a -> [a] -> NonEmpty a
NE.:| [a]
xs)
  put :: NonEmpty a -> Put
put = forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList
#endif

------------------------------------------------------------------------
-- Typeable/Reflection

#if MIN_VERSION_base(4,10,0)

-- $typeable-instances
--
-- 'Binary' instances for GHC's "Type.Reflection", "Data.Typeable", and
-- kind-system primitives are only provided with @base-4.10.0@ (shipped with GHC
-- 8.2.1). In prior GHC releases some of these instances were provided by
-- 'GHCi.TH.Binary' in the @ghci@ package.
--
-- These include instances for,
--
-- * 'VecCount'
-- * 'VecElem'
-- * 'RuntimeRep'
-- * 'KindRep'
-- * 'TypeLitSort'
-- * 'TyCon'
-- * 'TypeRep'
-- * 'SomeTypeRep' (also known as 'Data.Typeable.TypeRep')
--

-- | @since 0.8.5.0
instance Binary VecCount where
    put :: VecCount -> Put
put = Word8 -> Put
putWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
    get :: Get VecCount
get = forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8

-- | @since 0.8.5.0
instance Binary VecElem where
    put :: VecElem -> Put
put = Word8 -> Put
putWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
    get :: Get VecElem
get = forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8

-- | @since 0.8.5.0
instance Binary RuntimeRep where
    put :: RuntimeRep -> Put
put (VecRep VecCount
a VecElem
b)    = Word8 -> Put
putWord8 Word8
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put VecCount
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put VecElem
b
    put (TupleRep [RuntimeRep]
reps) = Word8 -> Put
putWord8 Word8
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put [RuntimeRep]
reps
    put (SumRep [RuntimeRep]
reps)   = Word8 -> Put
putWord8 Word8
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put [RuntimeRep]
reps
#if __GLASGOW_HASKELL__ >= 901
    put (BoxedRep Levity
Lifted)   = Word8 -> Put
putWord8 Word8
3
    put (BoxedRep Levity
Unlifted) = Word8 -> Put
putWord8 Word8
4
#else
    put LiftedRep       = putWord8 3
    put UnliftedRep     = putWord8 4
#endif
    put RuntimeRep
IntRep          = Word8 -> Put
putWord8 Word8
5
    put RuntimeRep
WordRep         = Word8 -> Put
putWord8 Word8
6
    put RuntimeRep
Int64Rep        = Word8 -> Put
putWord8 Word8
7
    put RuntimeRep
Word64Rep       = Word8 -> Put
putWord8 Word8
8
    put RuntimeRep
AddrRep         = Word8 -> Put
putWord8 Word8
9
    put RuntimeRep
FloatRep        = Word8 -> Put
putWord8 Word8
10
    put RuntimeRep
DoubleRep       = Word8 -> Put
putWord8 Word8
11
#if __GLASGOW_HASKELL__ >= 807
    put RuntimeRep
Int8Rep         = Word8 -> Put
putWord8 Word8
12
    put RuntimeRep
Word8Rep        = Word8 -> Put
putWord8 Word8
13
    put RuntimeRep
Int16Rep        = Word8 -> Put
putWord8 Word8
14
    put RuntimeRep
Word16Rep       = Word8 -> Put
putWord8 Word8
15
#if __GLASGOW_HASKELL__ >= 809
    put RuntimeRep
Int32Rep        = Word8 -> Put
putWord8 Word8
16
    put RuntimeRep
Word32Rep       = Word8 -> Put
putWord8 Word8
17
#endif
#endif

    get :: Get RuntimeRep
get = do
        Word8
tag <- Get Word8
getWord8
        case Word8
tag of
          Word8
0  -> VecCount -> VecElem -> RuntimeRep
VecRep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get
          Word8
1  -> [RuntimeRep] -> RuntimeRep
TupleRep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get
          Word8
2  -> [RuntimeRep] -> RuntimeRep
SumRep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get
#if __GLASGOW_HASKELL__ >= 901
          Word8
3  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Levity -> RuntimeRep
BoxedRep Levity
Lifted)
          Word8
4  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Levity -> RuntimeRep
BoxedRep Levity
Unlifted)
#else
          3  -> pure LiftedRep
          4  -> pure UnliftedRep
#endif
          Word8
5  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
IntRep
          Word8
6  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
WordRep
          Word8
7  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int64Rep
          Word8
8  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word64Rep
          Word8
9  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
AddrRep
          Word8
10 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
FloatRep
          Word8
11 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
DoubleRep
#if __GLASGOW_HASKELL__ >= 807
          Word8
12 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int8Rep
          Word8
13 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word8Rep
          Word8
14 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int16Rep
          Word8
15 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word16Rep
#if __GLASGOW_HASKELL__ >= 809
          Word8
16 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int32Rep
          Word8
17 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word32Rep
#endif
#endif
          Word8
_  -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"GHCi.TH.Binary.putRuntimeRep: invalid tag"

-- | @since 0.8.5.0
instance Binary TyCon where
    put :: TyCon -> Put
put TyCon
tc = do
        forall t. Binary t => t -> Put
put (TyCon -> String
tyConPackage TyCon
tc)
        forall t. Binary t => t -> Put
put (TyCon -> String
tyConModule TyCon
tc)
        forall t. Binary t => t -> Put
put (TyCon -> String
tyConName TyCon
tc)
        forall t. Binary t => t -> Put
put (TyCon -> Int
tyConKindArgs TyCon
tc)
        forall t. Binary t => t -> Put
put (TyCon -> KindRep
tyConKindRep TyCon
tc)
    get :: Get TyCon
get = String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get

-- | @since 0.8.5.0
instance Binary KindRep where
    put :: KindRep -> Put
put (KindRepTyConApp TyCon
tc [KindRep]
k) = Word8 -> Put
putWord8 Word8
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put TyCon
tc forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put [KindRep]
k
    put (KindRepVar Int
bndr) = Word8 -> Put
putWord8 Word8
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Int
bndr
    put (KindRepApp KindRep
a KindRep
b) = Word8 -> Put
putWord8 Word8
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put KindRep
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put KindRep
b
    put (KindRepFun KindRep
a KindRep
b) = Word8 -> Put
putWord8 Word8
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put KindRep
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put KindRep
b
    put (KindRepTYPE RuntimeRep
r) = Word8 -> Put
putWord8 Word8
4 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put RuntimeRep
r
    put (KindRepTypeLit TypeLitSort
sort String
r) = Word8 -> Put
putWord8 Word8
5 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put TypeLitSort
sort forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put String
r

    get :: Get KindRep
get = do
        Word8
tag <- Get Word8
getWord8
        case Word8
tag of
          Word8
0 -> TyCon -> [KindRep] -> KindRep
KindRepTyConApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get
          Word8
1 -> Int -> KindRep
KindRepVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get
          Word8
2 -> KindRep -> KindRep -> KindRep
KindRepApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get
          Word8
3 -> KindRep -> KindRep -> KindRep
KindRepFun forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get
          Word8
4 -> RuntimeRep -> KindRep
KindRepTYPE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get
          Word8
5 -> TypeLitSort -> String -> KindRep
KindRepTypeLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get
          Word8
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"GHCi.TH.Binary.putKindRep: invalid tag"

-- | @since 0.8.5.0
instance Binary TypeLitSort where
    put :: TypeLitSort -> Put
put TypeLitSort
TypeLitSymbol = Word8 -> Put
putWord8 Word8
0
    put TypeLitSort
TypeLitNat = Word8 -> Put
putWord8 Word8
1
#ifdef HAS_TYPELITS_CHAR
    put TypeLitSort
TypeLitChar = Word8 -> Put
putWord8 Word8
2
#endif
    get :: Get TypeLitSort
get = do
        Word8
tag <- Get Word8
getWord8
        case Word8
tag of
          Word8
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeLitSort
TypeLitSymbol
          Word8
1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeLitSort
TypeLitNat
#ifdef HAS_TYPELITS_CHAR
          Word8
2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeLitSort
TypeLitChar
#endif
          Word8
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"GHCi.TH.Binary.putTypeLitSort: invalid tag"

putTypeRep :: TypeRep a -> Put
-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
-- relations.
-- See Note [Mutually recursive representations of primitive types]
putTypeRep :: forall {k} (a :: k). TypeRep a -> Put
putTypeRep TypeRep a
rep  -- Handle Type specially since it's so common
  | Just a :~~: *
HRefl <- TypeRep a
rep forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` (forall {k} (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep Type)
  = forall t. Binary t => t -> Put
put (Word8
0 :: Word8)
putTypeRep (Con' TyCon
con [SomeTypeRep]
ks) = do
    forall t. Binary t => t -> Put
put (Word8
1 :: Word8)
    forall t. Binary t => t -> Put
put TyCon
con
    forall t. Binary t => t -> Put
put [SomeTypeRep]
ks
putTypeRep (App TypeRep a
f TypeRep b
x) = do
    forall t. Binary t => t -> Put
put (Word8
2 :: Word8)
    forall {k} (a :: k). TypeRep a -> Put
putTypeRep TypeRep a
f
    forall {k} (a :: k). TypeRep a -> Put
putTypeRep TypeRep b
x
putTypeRep (Fun TypeRep arg
arg TypeRep res
res) = do
    forall t. Binary t => t -> Put
put (Word8
3 :: Word8)
    forall {k} (a :: k). TypeRep a -> Put
putTypeRep TypeRep arg
arg
    forall {k} (a :: k). TypeRep a -> Put
putTypeRep TypeRep res
res

getSomeTypeRep :: Get SomeTypeRep
getSomeTypeRep :: Get SomeTypeRep
getSomeTypeRep = do
    Word8
tag <- forall t. Binary t => Get t
get :: Get Word8
    case Word8
tag of
        Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (forall {k} (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep Type)
        Word8
1 -> do TyCon
con <- forall t. Binary t => Get t
get :: Get TyCon
                [SomeTypeRep]
ks <- forall t. Binary t => Get t
get :: Get [SomeTypeRep]
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep forall a b. (a -> b) -> a -> b
$ forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
mkTrCon TyCon
con [SomeTypeRep]
ks
        Word8
2 -> do SomeTypeRep TypeRep a
f <- Get SomeTypeRep
getSomeTypeRep
                SomeTypeRep TypeRep a
x <- Get SomeTypeRep
getSomeTypeRep
                case forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
f of
                  Fun TypeRep arg
arg TypeRep res
res ->
                      case TypeRep arg
arg forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
x of
                        Just arg :~~: k
HRefl -> do
                            case forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep res
res forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` (forall {k} (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep Type) of
                                Just TYPE r2 :~~: *
HRefl -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep forall a b. (a -> b) -> a -> b
$ forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep a -> TypeRep b -> TypeRep (a b)
mkTrApp TypeRep a
f TypeRep a
x
                                Maybe (TYPE r2 :~~: *)
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> [String] -> m a
failure String
"Kind mismatch" []
                        Maybe (arg :~~: k)
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> [String] -> m a
failure String
"Kind mismatch"
                             [ String
"Found argument of kind:      " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
x)
                             , String
"Where the constructor:       " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeRep a
f
                             , String
"Expects an argument of kind: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeRep arg
arg
                             ]
                  TypeRep k
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> [String] -> m a
failure String
"Applied non-arrow type"
                       [ String
"Applied type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeRep a
f
                       , String
"To argument:  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeRep a
x
                       ]
        Word8
3 -> do SomeTypeRep TypeRep a
arg <- Get SomeTypeRep
getSomeTypeRep
                SomeTypeRep TypeRep a
res <- Get SomeTypeRep
getSomeTypeRep
                case forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
arg forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` (forall {k} (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep Type) of
                  Just k :~~: *
HRefl ->
                      case forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind TypeRep a
res forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` (forall {k} (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep Type) of
                        Just k :~~: *
HRefl -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep forall a b. (a -> b) -> a -> b
$ forall k (fun :: k) arg res.
(k ~ *, fun ~~ (arg -> res)) =>
TypeRep arg -> TypeRep res -> TypeRep fun
Fun TypeRep a
arg TypeRep a
res
                        Maybe (k :~~: *)
Nothing -> forall {m :: * -> *} {a}. MonadFail m => String -> [String] -> m a
failure String
"Kind mismatch" []
                  Maybe (k :~~: *)
Nothing -> forall {m :: * -> *} {a}. MonadFail m => String -> [String] -> m a
failure String
"Kind mismatch" []
        Word8
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> [String] -> m a
failure String
"Invalid SomeTypeRep" []
  where
    failure :: String -> [String] -> m a
failure String
description [String]
info =
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ [ String
"GHCi.TH.Binary.getSomeTypeRep: "forall a. [a] -> [a] -> [a]
++String
description ]
                      forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (String
"    "forall a. [a] -> [a] -> [a]
++) [String]
info

instance Typeable a => Binary (TypeRep (a :: k)) where
    put :: TypeRep a -> Put
put = forall {k} (a :: k). TypeRep a -> Put
putTypeRep
    get :: Get (TypeRep a)
get = do
        SomeTypeRep TypeRep a
rep <- Get SomeTypeRep
getSomeTypeRep
        case TypeRep a
rep forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` TypeRep a
expected of
          Just a :~~: a
HRefl -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeRep a
rep
          Maybe (a :~~: a)
Nothing    -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                        [ String
"GHCi.TH.Binary: Type mismatch"
                        , String
"    Deserialized type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeRep a
rep
                        , String
"    Expected type:     " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show TypeRep a
expected
                        ]
     where expected :: TypeRep a
expected = forall {k} (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep a

instance Binary SomeTypeRep where
    put :: SomeTypeRep -> Put
put (SomeTypeRep TypeRep a
rep) = forall {k} (a :: k). TypeRep a -> Put
putTypeRep TypeRep a
rep
    get :: Get SomeTypeRep
get = Get SomeTypeRep
getSomeTypeRep
#endif