{-# 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 = [t] -> Put
forall a. Binary a => [a] -> Put
defaultPutList

    default put :: (Generic t, GBinaryPut (Rep t)) => t -> Put
    put = Rep t Any -> Put
forall k (f :: k -> *) (t :: k). GBinaryPut f => f t -> Put
gput (Rep t Any -> Put) -> (t -> Rep t Any) -> t -> Put
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, GBinaryGet (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
`fmap` Get (Rep t Any)
forall k (f :: k -> *) (t :: k). GBinaryGet f => Get (f t)
gget

{-# INLINE defaultPutList #-}
defaultPutList :: Binary a => [a] -> Put
defaultPutList :: [a] -> Put
defaultPutList [a]
xs = Int -> Put
forall t. Binary t => t -> Put
put ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> (a -> Put) -> [a] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Put
forall t. Binary t => t -> Put
put [a]
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     = Void -> Put
forall a. Void -> a
absurd
    get :: Get Void
get     = Get Void
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 ()  = Put
forall a. Monoid a => a
mempty
    get :: Get ()
get     = () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Bools are encoded as a byte in the range 0 .. 1
instance Binary Bool where
    put :: Bool -> Put
put     = Word8 -> Put
putWord8 (Word8 -> Put) -> (Bool -> Word8) -> Bool -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Bool -> Int) -> Bool -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum
    get :: Get Bool
get     = Get Word8
getWord8 Get Word8 -> (Word8 -> Get Bool) -> Get Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get Bool
forall a (m :: * -> *).
(Eq a, Num a, MonadFail m, Show a) =>
a -> m Bool
toBool
      where
        toBool :: a -> m Bool
toBool a
0 = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        toBool a
1 = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        toBool a
c = String -> m Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Could not map value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
c String -> String -> String
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 (Word8 -> Put) -> (Ordering -> Word8) -> Ordering -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Ordering -> Int) -> Ordering -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ordering -> Int
forall a. Enum a => a -> Int
fromEnum
    get :: Get Ordering
get     = Get Word8
getWord8 Get Word8 -> (Word8 -> Get Ordering) -> Get Ordering
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get Ordering
forall a (m :: * -> *).
(Eq a, Num a, MonadFail m, Show a) =>
a -> m Ordering
toOrd
      where
        toOrd :: a -> m Ordering
toOrd a
0 = Ordering -> m Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
LT
        toOrd a
1 = Ordering -> m Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
EQ
        toOrd a
2 = Ordering -> m Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
GT
        toOrd a
c = String -> m Ordering
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Could not map value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
c String -> String -> String
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 =
        Int -> Put
forall t. Binary t => t -> Put
put ([Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
xs)
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (FixedPrim Word8 -> [Word8] -> Builder
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 =
        Int -> Put
forall t. Binary t => t -> Put
put ([Word16] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word16]
xs)
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (FixedPrim Word16 -> [Word16] -> Builder
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 =
        Int -> Put
forall t. Binary t => t -> Put
put ([Word32] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word32]
xs)
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (FixedPrim Word32 -> [Word32] -> Builder
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 =
        Int -> Put
forall t. Binary t => t -> Put
put ([Word64] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word64]
xs)
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (FixedPrim Word64 -> [Word64] -> Builder
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 =
        Int -> Put
forall t. Binary t => t -> Put
put ([Int8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int8]
xs)
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (FixedPrim Int8 -> [Int8] -> Builder
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 =
        Int -> Put
forall t. Binary t => t -> Put
put ([Int16] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int16]
xs)
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (FixedPrim Int16 -> [Int16] -> Builder
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 =
        Int -> Put
forall t. Binary t => t -> Put
put ([Int32] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int32]
xs)
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (FixedPrim Int32 -> [Int32] -> Builder
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 =
        Int -> Put
forall t. Binary t => t -> Put
put ([Int64] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int64]
xs)
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (FixedPrim Int64 -> [Int64] -> Builder
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 (Word64 -> Put) -> (Word -> Word64) -> Word -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    {-# INLINE putList #-}
    putList :: [Word] -> Put
putList [Word]
xs =
        Int -> Put
forall t. Binary t => t -> Put
put ([Word] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word]
xs)
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (FixedPrim Word64 -> [Word64] -> Builder
forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Word64
Prim.word64BE ((Word -> Word64) -> [Word] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word]
xs))
    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
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 (Int64 -> Put) -> (Int -> Int64) -> Int -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    {-# INLINE putList #-}
    putList :: [Int] -> Put
putList [Int]
xs =
        Int -> Put
forall t. Binary t => t -> Put
put ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs)
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Builder -> Put
putBuilder (FixedPrim Int64 -> [Int64] -> Builder
forall a. FixedPrim a -> [a] -> Builder
Prim.primMapListFixed FixedPrim Int64
Prim.int64BE ((Int -> Int64) -> [Int] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int]
xs))
    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
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 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 =
        Builder -> Put
putBuilder (FixedPrim (Word8, Int32) -> (Word8, Int32) -> Builder
forall a. FixedPrim a -> a -> Builder
Prim.primFixed (FixedPrim Word8
Prim.word8 FixedPrim Word8 -> FixedPrim Int32 -> FixedPrim (Word8, Int32)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
Prim.>*< FixedPrim Int32
Prim.int32BE) (Word8
0, Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n))
     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 =
        Word8 -> Put
putWord8 Word8
1
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Word8 -> Put
forall t. Binary t => t -> Put
put Word8
sign
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> [Word8] -> Put
forall t. Binary t => t -> Put
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

    {-# INLINE get #-}
    get :: Get Integer
get = do
        Word8
tag <- Get Word8
forall t. Binary t => Get t
get :: Get Word8
        case Word8
tag of
            Word8
0 -> (Int32 -> Integer) -> Get Int32 -> Get Integer
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Int32
forall t. Binary t => Get t
get :: Get SmallInt)
            Word8
_ -> do Word8
sign  <- Get Word8
forall t. Binary t => Get t
get
                    [Word8]
bytes <- Get [Word8]
forall t. Binary t => Get t
get
                    let v :: Integer
v = [Word8] -> Integer
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

-- | @since 0.8.0.0
#ifdef HAS_FIXED_CONSTRUCTOR
instance Binary (Fixed.Fixed a) where
  put :: Fixed a -> Put
put (Fixed.MkFixed Integer
a) = Integer -> Put
forall t. Binary t => t -> Put
put Integer
a
  get :: Get (Fixed a)
get = Integer -> Fixed a
forall k (a :: k). Integer -> Fixed a
Fixed.MkFixed (Integer -> Fixed a) -> Get Integer -> Get (Fixed a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Get Integer
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 :: 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   = (a -> Word8 -> a) -> a -> [Word8] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> Word8 -> a
forall a a. (Bits a, Integral a, Num a) => a -> a -> a
unstep a
0 ([Word8] -> a) -> ([Word8] -> [Word8]) -> [Word8] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [Word8]
forall a. [a] -> [a]
reverse
  where
    unstep :: a -> a -> a
unstep a
a a
b = 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

#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 Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
hi =
        Word8 -> Put
putWord8 Word8
0
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Word64 -> Put
forall t. Binary t => t -> Put
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 =
        Word8 -> Put
putWord8 Word8
1
        Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> [Word8] -> Put
forall t. Binary t => t -> Put
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. Binary 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. Binary t => Get t
get :: Get NaturalWord)
            Word8
_ -> do [Word8]
bytes <- Get [Word8]
forall t. Binary 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

{-

--
-- 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 = a -> Put
forall t. Binary t => t -> Put
put (Ratio a -> a
forall a. Ratio a -> a
R.numerator Ratio a
r) Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> a -> Put
forall t. Binary t => t -> Put
put (Ratio a -> a
forall a. Ratio a -> a
R.denominator Ratio a
r)
    get :: Get (Ratio a)
get = (a -> a -> Ratio a) -> Get a -> Get a -> Get (Ratio a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
(R.%) Get a
forall t. Binary t => Get t
get Get a
forall t. Binary t => Get t
get

instance Binary a => Binary (Complex a) where
    {-# INLINE put #-}
    put :: Complex a -> Put
put (a
r :+ a
i) = (a, a) -> Put
forall t. Binary t => t -> Put
put (a
r, a
i)
    {-# INLINE get #-}
    get :: Get (Complex a)
get = (\(a
r,a
i) -> a
r a -> a -> Complex a
forall a. a -> a -> Complex a
:+ a
i) ((a, a) -> Complex a) -> Get (a, a) -> Get (Complex a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (a, a)
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 = Int -> Put
forall t. Binary t => t -> Put
put (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> String -> Put
putStringUtf8 String
str
    get :: Get Char
get = do
        let getByte :: Get Int
getByte = (Word8 -> Int) -> Get Word8 -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word8 -> Int) Get Word8
forall t. Binary t => Get t
get
            shiftL6 :: Int -> Int
shiftL6 = (Int -> Int -> Int) -> Int -> Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
6 :: Int -> Int
        Int
w <- Get Int
getByte
        Int
r <- case () of
                ()
_ | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x80  -> Int -> Get Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
w
                  | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xe0  -> do
                                    Int
x <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    Int -> Get Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0xc0 Int
w))
                  | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xf0  -> do
                                    Int
x <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    Int
y <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    Int -> Get Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
y Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6
                                            (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0xe0 Int
w)))
                  | Bool
otherwise -> do
                                Int
x <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                Int
y <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                Int
z <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                Int -> Get Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
z Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (Int
y Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6
                                        (Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int
shiftL6 (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0xf0 Int
w))))
        Int -> Get Char
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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x10ffff = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$! Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Enum a => a -> Int
fromEnum a
w
          | Bool
otherwise = String -> m a
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)           = a -> Put
forall t. Binary t => t -> Put
put a
a Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> b -> Put
forall t. Binary t => t -> Put
put b
b
    {-# INLINE get #-}
    get :: Get (a, b)
get                 = (a -> b -> (a, b)) -> Get a -> Get b -> Get (a, b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) Get a
forall t. Binary t => Get t
get Get b
forall t. Binary t => Get t
get

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

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

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

--
-- and now just recurse:
--

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

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

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

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

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

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

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

instance Binary a => Binary [a] where
    put :: [a] -> Put
put = [a] -> Put
forall a. Binary a => [a] -> Put
putList
    get :: Get [a]
get = do Int
n <- Get Int
forall t. Binary t => Get t
get :: Get Int
             Int -> Get [a]
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 :: Int -> Get [a]
getMany Int
n = [a] -> Int -> Get [a]
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 = [a] -> Get [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Get [a]) -> [a] -> Get [a]
forall a b. (a -> b) -> a -> b
$! [a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs
    go [a]
xs t
i = do a
x <- Get a
forall t. Binary t => Get t
get
                 -- we must seq x to avoid stack overflows due to laziness in
                 -- (>>=)
                 a
x a -> Get [a] -> Get [a]
`seq` [a] -> t -> Get [a]
go (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) (t
it -> t -> t
forall 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 Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> a -> Put
forall t. Binary t => t -> Put
put a
x
    get :: Get (Maybe a)
get = do
        Word8
w <- Get Word8
getWord8
        case Word8
w of
            Word8
0 -> Maybe a -> Get (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
            Word8
_ -> (a -> Maybe a) -> Get a -> Get (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just Get a
forall t. Binary t => Get t
get

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

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

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

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


#if MIN_VERSION_bytestring(0,10,4)
instance Binary BS.ShortByteString where
   put :: ShortByteString -> Put
put ShortByteString
bs = Int -> Put
forall t. Binary t => t -> Put
put (ShortByteString -> Int
BS.length ShortByteString
bs)
            Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> ShortByteString -> Put
putShortByteString ShortByteString
bs
   get :: Get ShortByteString
get = Get Int
forall t. Binary t => Get t
get Get Int -> (Int -> Get ShortByteString) -> Get ShortByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ByteString -> ShortByteString)
-> Get ByteString -> Get ShortByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ShortByteString
BS.toShort (Get ByteString -> Get ShortByteString)
-> (Int -> Get ByteString) -> Int -> Get ShortByteString
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 = Int -> Put
forall t. Binary t => t -> Put
put (Set a -> Int
forall a. Set a -> Int
Set.size Set a
s) Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> (a -> Put) -> [a] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Put
forall t. Binary t => t -> Put
put (Set a -> [a]
forall a. Set a -> [a]
Set.toAscList Set a
s)
    get :: Get (Set a)
get   = ([a] -> Set a) -> Get [a] -> Get (Set a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [a] -> Set a
forall a. [a] -> Set a
Set.fromDistinctAscList Get [a]
forall t. Binary t => Get t
get

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

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

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

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

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

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

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

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

instance Binary Float where
    put :: Float -> Put
put Float
f = (Integer, Int) -> Put
forall t. Binary t => t -> Put
put (Float -> (Integer, Int)
forall a. RealFloat a => a -> (Integer, Int)
decodeFloat Float
f)
    get :: Get Float
get   =  do
        Integer
x <- Get Integer
forall t. Binary t => Get t
get
        Int
y <- Get Int
forall t. Binary t => Get t
get
        Float -> Get Float
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> Get Float) -> Float -> Get Float
forall a b. (a -> b) -> a -> b
$! Integer -> Int -> Float
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) = e -> Put
forall t. Binary t => t -> Put
put e
r Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> [Tree e] -> Put
forall t. Binary t => t -> Put
put [Tree e]
s
    get :: Get (Tree e)
get = (e -> [Tree e] -> Tree e) -> Get e -> Get [Tree e] -> Get (Tree e)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 e -> [Tree e] -> Tree e
forall a. a -> Forest a -> Tree a
T.Node Get e
forall t. Binary t => Get t
get Get [Tree e]
forall t. Binary t => Get t
get

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

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

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

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

-- | @since 0.7.6.0
instance Binary Fingerprint where
    put :: Fingerprint -> Put
put (Fingerprint Word64
x1 Word64
x2) = Word64 -> Put
forall t. Binary t => t -> Put
put Word64
x1 Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Word64 -> Put
forall t. Binary t => t -> Put
put Word64
x2
    get :: Get Fingerprint
get = do
        Word64
x1 <- Get Word64
forall t. Binary t => Get t
get
        Word64
x2 <- Get Word64
forall t. Binary t => Get t
get
        Fingerprint -> Get Fingerprint
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint -> Get Fingerprint) -> Fingerprint -> Get Fingerprint
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) = [Int] -> Put
forall t. Binary t => t -> Put
put [Int]
br Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> [String] -> Put
forall t. Binary t => t -> Put
put [String]
tags
    get :: Get Version
get = [Int] -> [String] -> Version
Version ([Int] -> [String] -> Version)
-> Get [Int] -> Get ([String] -> Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [Int]
forall t. Binary t => Get t
get Get ([String] -> Version) -> Get [String] -> Get Version
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [String]
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 = (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
Monoid.Dual Get a
forall t. Binary t => Get t
get
  put :: Dual a -> Put
put = a -> Put
forall t. Binary t => t -> Put
put (a -> Put) -> (Dual a -> a) -> Dual a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dual a -> a
forall a. Dual a -> a
Monoid.getDual

-- | @since 0.8.4.0
instance Binary Monoid.All where
  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
Monoid.All Get Bool
forall t. Binary t => Get t
get
  put :: All -> Put
put = Bool -> Put
forall t. Binary t => t -> Put
put (Bool -> Put) -> (All -> Bool) -> All -> 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 = (Bool -> Any) -> Get Bool -> Get Any
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Any
Monoid.Any Get Bool
forall t. Binary t => Get t
get
  put :: Any -> Put
put = Bool -> Put
forall t. Binary t => t -> Put
put (Bool -> Put) -> (Any -> Bool) -> Any -> 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 = (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
Monoid.Sum Get a
forall t. Binary t => Get t
get
  put :: Sum a -> Put
put = a -> Put
forall t. Binary t => t -> Put
put (a -> Put) -> (Sum a -> a) -> Sum a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum a -> a
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 = (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
Monoid.Product Get a
forall t. Binary t => Get t
get
  put :: Product a -> Put
put = a -> Put
forall t. Binary t => t -> Put
put (a -> Put) -> (Product a -> a) -> Product a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Product a -> a
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 = (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
Monoid.First Get (Maybe a)
forall t. Binary t => Get t
get
  put :: First a -> Put
put = Maybe a -> Put
forall t. Binary t => t -> Put
put (Maybe a -> Put) -> (First a -> Maybe a) -> First a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First a -> Maybe a
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 = (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
Monoid.Last Get (Maybe a)
forall t. Binary t => Get t
get
  put :: Last a -> Put
put = Maybe a -> Put
forall t. Binary t => t -> Put
put (Maybe a -> Put) -> (Last a -> Maybe a) -> Last a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Last a -> Maybe a
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 = (f a -> Alt f a) -> Get (f a) -> Get (Alt f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> Alt f a
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Monoid.Alt Get (f a)
forall t. Binary t => Get t
get
  put :: Alt f a -> Put
put = f a -> Put
forall t. Binary t => t -> Put
put (f a -> Put) -> (Alt f a -> f a) -> Alt f a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt f a -> f a
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 = (a -> Min a) -> Get a -> Get (Min a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Min a
forall a. a -> Min a
Semigroup.Min Get a
forall t. Binary t => Get t
get
  put :: Min a -> Put
put = a -> Put
forall t. Binary t => t -> Put
put (a -> Put) -> (Min a -> a) -> Min a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Min a -> a
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 = (a -> Max a) -> Get a -> Get (Max a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Max a
forall a. a -> Max a
Semigroup.Max Get a
forall t. Binary t => Get t
get
  put :: Max a -> Put
put = a -> Put
forall t. Binary t => t -> Put
put (a -> Put) -> (Max a -> a) -> Max a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Max a -> a
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 = (a -> First a) -> Get a -> Get (First a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> First a
forall a. a -> First a
Semigroup.First Get a
forall t. Binary t => Get t
get
  put :: First a -> Put
put = a -> Put
forall t. Binary t => t -> Put
put (a -> Put) -> (First a -> a) -> First a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. First a -> a
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 = (a -> Last a) -> Get a -> Get (Last a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Last a
forall a. a -> Last a
Semigroup.Last Get a
forall t. Binary t => Get t
get
  put :: Last a -> Put
put = a -> Put
forall t. Binary t => t -> Put
put (a -> Put) -> (Last a -> a) -> Last a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Last a -> a
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 :: Get (Option a)
get = (Maybe a -> Option a) -> Get (Maybe a) -> Get (Option a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe a -> Option a
forall a. Maybe a -> Option a
Semigroup.Option Get (Maybe a)
forall t. Binary t => Get t
get
  put :: Option a -> Put
put = Maybe a -> Put
forall t. Binary t => t -> Put
put (Maybe a -> Put) -> (Option a -> Maybe a) -> Option a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Option a -> Maybe a
forall a. Option a -> Maybe a
Semigroup.getOption
#endif

-- | @since 0.8.4.0
instance Binary m => Binary (Semigroup.WrappedMonoid m) where
  get :: Get (WrappedMonoid m)
get = (m -> WrappedMonoid m) -> Get m -> Get (WrappedMonoid m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap m -> WrappedMonoid m
forall m. m -> WrappedMonoid m
Semigroup.WrapMonoid Get m
forall t. Binary t => Get t
get
  put :: WrappedMonoid m -> Put
put = m -> Put
forall t. Binary t => t -> Put
put (m -> Put) -> (WrappedMonoid m -> m) -> WrappedMonoid m -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedMonoid m -> m
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                     = (a -> b -> Arg a b) -> Get a -> Get b -> Get (Arg a b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 a -> b -> Arg a b
forall a b. a -> b -> Arg a b
Semigroup.Arg Get a
forall t. Binary t => Get t
get Get b
forall t. Binary t => Get t
get
  put :: Arg a b -> Put
put (Semigroup.Arg a
a b
b) = a -> Put
forall t. Binary t => t -> Put
put a
a Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> b -> Put
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 <- Get [a]
forall t. Binary t => Get t
get
      case [a]
list of
        [] -> String -> Get (NonEmpty a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"NonEmpty is empty!"
        a
x:[a]
xs -> NonEmpty a -> Get (NonEmpty a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
NE.:| [a]
xs)
  put :: NonEmpty a -> Put
put = [a] -> Put
forall t. Binary t => t -> Put
put ([a] -> Put) -> (NonEmpty a -> [a]) -> NonEmpty a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
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 (Word8 -> Put) -> (VecCount -> Word8) -> VecCount -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (VecCount -> Int) -> VecCount -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VecCount -> Int
forall a. Enum a => a -> Int
fromEnum
    get :: Get VecCount
get = Int -> VecCount
forall a. Enum a => Int -> a
toEnum (Int -> VecCount) -> (Word8 -> Int) -> Word8 -> VecCount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> VecCount) -> Get Word8 -> Get VecCount
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 (Word8 -> Put) -> (VecElem -> Word8) -> VecElem -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (VecElem -> Int) -> VecElem -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VecElem -> Int
forall a. Enum a => a -> Int
fromEnum
    get :: Get VecElem
get = Int -> VecElem
forall a. Enum a => Int -> a
toEnum (Int -> VecElem) -> (Word8 -> Int) -> Word8 -> VecElem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> VecElem) -> Get Word8 -> Get VecElem
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 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VecCount -> Put
forall t. Binary t => t -> Put
put VecCount
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VecElem -> Put
forall t. Binary t => t -> Put
put VecElem
b
    put (TupleRep [RuntimeRep]
reps) = Word8 -> Put
putWord8 Word8
1 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [RuntimeRep] -> Put
forall t. Binary t => t -> Put
put [RuntimeRep]
reps
    put (SumRep [RuntimeRep]
reps)   = Word8 -> Put
putWord8 Word8
2 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [RuntimeRep] -> Put
forall t. Binary t => t -> Put
put [RuntimeRep]
reps
#if __GLASGOW_HASKELL__ >= 901
    put (BoxedRep Lifted)   = putWord8 3
    put (BoxedRep Unlifted) = putWord8 4
#else
    put RuntimeRep
LiftedRep       = Word8 -> Put
putWord8 Word8
3
    put RuntimeRep
UnliftedRep     = Word8 -> Put
putWord8 Word8
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 (VecCount -> VecElem -> RuntimeRep)
-> Get VecCount -> Get (VecElem -> RuntimeRep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get VecCount
forall t. Binary t => Get t
get Get (VecElem -> RuntimeRep) -> Get VecElem -> Get RuntimeRep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get VecElem
forall t. Binary t => Get t
get
          Word8
1  -> [RuntimeRep] -> RuntimeRep
TupleRep ([RuntimeRep] -> RuntimeRep) -> Get [RuntimeRep] -> Get RuntimeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [RuntimeRep]
forall t. Binary t => Get t
get
          Word8
2  -> [RuntimeRep] -> RuntimeRep
SumRep ([RuntimeRep] -> RuntimeRep) -> Get [RuntimeRep] -> Get RuntimeRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [RuntimeRep]
forall t. Binary t => Get t
get
#if __GLASGOW_HASKELL__ >= 901
          3  -> pure (BoxedRep Lifted)
          4  -> pure (BoxedRep Unlifted)
#else
          Word8
3  -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
LiftedRep
          Word8
4  -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
UnliftedRep
#endif
          Word8
5  -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
IntRep
          Word8
6  -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
WordRep
          Word8
7  -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int64Rep
          Word8
8  -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word64Rep
          Word8
9  -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
AddrRep
          Word8
10 -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
FloatRep
          Word8
11 -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
DoubleRep
#if __GLASGOW_HASKELL__ >= 807
          Word8
12 -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int8Rep
          Word8
13 -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word8Rep
          Word8
14 -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int16Rep
          Word8
15 -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word16Rep
#if __GLASGOW_HASKELL__ >= 809
          Word8
16 -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int32Rep
          Word8
17 -> RuntimeRep -> Get RuntimeRep
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word32Rep
#endif
#endif
          Word8
_  -> String -> Get RuntimeRep
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
        String -> Put
forall t. Binary t => t -> Put
put (TyCon -> String
tyConPackage TyCon
tc)
        String -> Put
forall t. Binary t => t -> Put
put (TyCon -> String
tyConModule TyCon
tc)
        String -> Put
forall t. Binary t => t -> Put
put (TyCon -> String
tyConName TyCon
tc)
        Int -> Put
forall t. Binary t => t -> Put
put (TyCon -> Int
tyConKindArgs TyCon
tc)
        KindRep -> Put
forall t. Binary t => t -> Put
put (TyCon -> KindRep
tyConKindRep TyCon
tc)
    get :: Get TyCon
get = String -> String -> String -> Int -> KindRep -> TyCon
mkTyCon (String -> String -> String -> Int -> KindRep -> TyCon)
-> Get String -> Get (String -> String -> Int -> KindRep -> TyCon)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get String
forall t. Binary t => Get t
get Get (String -> String -> Int -> KindRep -> TyCon)
-> Get String -> Get (String -> Int -> KindRep -> TyCon)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get String
forall t. Binary t => Get t
get Get (String -> Int -> KindRep -> TyCon)
-> Get String -> Get (Int -> KindRep -> TyCon)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get String
forall t. Binary t => Get t
get Get (Int -> KindRep -> TyCon) -> Get Int -> Get (KindRep -> TyCon)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int
forall t. Binary t => Get t
get Get (KindRep -> TyCon) -> Get KindRep -> Get TyCon
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get KindRep
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 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TyCon -> Put
forall t. Binary t => t -> Put
put TyCon
tc Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [KindRep] -> Put
forall t. Binary t => t -> Put
put [KindRep]
k
    put (KindRepVar Int
bndr) = Word8 -> Put
putWord8 Word8
1 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Put
forall t. Binary t => t -> Put
put Int
bndr
    put (KindRepApp KindRep
a KindRep
b) = Word8 -> Put
putWord8 Word8
2 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KindRep -> Put
forall t. Binary t => t -> Put
put KindRep
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KindRep -> Put
forall t. Binary t => t -> Put
put KindRep
b
    put (KindRepFun KindRep
a KindRep
b) = Word8 -> Put
putWord8 Word8
3 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KindRep -> Put
forall t. Binary t => t -> Put
put KindRep
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KindRep -> Put
forall t. Binary t => t -> Put
put KindRep
b
    put (KindRepTYPE RuntimeRep
r) = Word8 -> Put
putWord8 Word8
4 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RuntimeRep -> Put
forall t. Binary t => t -> Put
put RuntimeRep
r
    put (KindRepTypeLit TypeLitSort
sort String
r) = Word8 -> Put
putWord8 Word8
5 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TypeLitSort -> Put
forall t. Binary t => t -> Put
put TypeLitSort
sort Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Put
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 (TyCon -> [KindRep] -> KindRep)
-> Get TyCon -> Get ([KindRep] -> KindRep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get TyCon
forall t. Binary t => Get t
get Get ([KindRep] -> KindRep) -> Get [KindRep] -> Get KindRep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [KindRep]
forall t. Binary t => Get t
get
          Word8
1 -> Int -> KindRep
KindRepVar (Int -> KindRep) -> Get Int -> Get KindRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall t. Binary t => Get t
get
          Word8
2 -> KindRep -> KindRep -> KindRep
KindRepApp (KindRep -> KindRep -> KindRep)
-> Get KindRep -> Get (KindRep -> KindRep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get KindRep
forall t. Binary t => Get t
get Get (KindRep -> KindRep) -> Get KindRep -> Get KindRep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get KindRep
forall t. Binary t => Get t
get
          Word8
3 -> KindRep -> KindRep -> KindRep
KindRepFun (KindRep -> KindRep -> KindRep)
-> Get KindRep -> Get (KindRep -> KindRep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get KindRep
forall t. Binary t => Get t
get Get (KindRep -> KindRep) -> Get KindRep -> Get KindRep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get KindRep
forall t. Binary t => Get t
get
          Word8
4 -> RuntimeRep -> KindRep
KindRepTYPE (RuntimeRep -> KindRep) -> Get RuntimeRep -> Get KindRep
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get RuntimeRep
forall t. Binary t => Get t
get
          Word8
5 -> TypeLitSort -> String -> KindRep
KindRepTypeLit (TypeLitSort -> String -> KindRep)
-> Get TypeLitSort -> Get (String -> KindRep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get TypeLitSort
forall t. Binary t => Get t
get Get (String -> KindRep) -> Get String -> Get KindRep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get String
forall t. Binary t => Get t
get
          Word8
_ -> String -> Get KindRep
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 TypeLitChar = putWord8 2
#endif
    get :: Get TypeLitSort
get = do
        Word8
tag <- Get Word8
getWord8
        case Word8
tag of
          Word8
0 -> TypeLitSort -> Get TypeLitSort
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeLitSort
TypeLitSymbol
          Word8
1 -> TypeLitSort -> Get TypeLitSort
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeLitSort
TypeLitNat
#ifdef HAS_TYPELITS_CHAR
          2 -> pure TypeLitChar
#endif
          Word8
_ -> String -> Get TypeLitSort
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"GHCi.TH.Binary.putTypeLitSort: invalid tag"

putTypeRep :: TypeRep a -> Put
putTypeRep :: TypeRep a -> Put
putTypeRep TypeRep a
rep  -- Handle Type specially since it's so common
  | Just a :~~: *
HRefl <- TypeRep a
rep TypeRep a -> TypeRep * -> Maybe (a :~~: *)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` (TypeRep *
forall k (a :: k). Typeable a => TypeRep a
typeRep :: TypeRep Type)
  = Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0 :: Word8)
putTypeRep (Con' TyCon
con [SomeTypeRep]
ks) = do
    Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
1 :: Word8)
    TyCon -> Put
forall t. Binary t => t -> Put
put TyCon
con
    [SomeTypeRep] -> Put
forall t. Binary t => t -> Put
put [SomeTypeRep]
ks
putTypeRep (App TypeRep a
f TypeRep b
x) = do
    Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
2 :: Word8)
    TypeRep a -> Put
forall k (a :: k). TypeRep a -> Put
putTypeRep TypeRep a
f
    TypeRep b -> Put
forall k (a :: k). TypeRep a -> Put
putTypeRep TypeRep b
x
#if __GLASGOW_HASKELL__ < 903
-- N.B. This pattern never matches,
-- even on versions of GHC older than 9.3:
-- a `Fun` typerep will match with the `App` pattern.
-- This match is kept solely for pattern-match warnings,
-- which are incorrect on GHC prior to 9.3.
putTypeRep (Fun TypeRep arg
arg TypeRep res
res) = do
    Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
3 :: Word8)
    TypeRep arg -> Put
forall k (a :: k). TypeRep a -> Put
putTypeRep TypeRep arg
arg
    TypeRep res -> Put
forall k (a :: k). TypeRep a -> Put
putTypeRep TypeRep res
res
#endif

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

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

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