{-# 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 Prelude hiding (Foldable(..))
import Data.Foldable (Foldable(..))

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)

-- 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 t. Rep t t -> 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 x. t -> Rep t x
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
forall x. Rep t x -> t
to (Rep t Any -> t) -> Get (Rep t Any) -> Get t
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Get (Rep t Any)
forall t. Get (Rep t t)
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 = Int -> Put
forall t. Binary t => t -> Put
put ([a] -> Int
forall a. [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 a. Get a
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 a. a -> Get a
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 a b. Get a -> (a -> Get b) -> Get b
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        toBool a
1 = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        toBool a
c = String -> m Bool
forall a. String -> m a
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 a b. Get a -> (a -> Get b) -> Get b
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
LT
        toOrd a
1 = Ordering -> m Ordering
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
EQ
        toOrd a
2 = Ordering -> m Ordering
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
GT
        toOrd a
c = String -> m Ordering
forall a. String -> m a
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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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
        tag <- Get Word8
forall t. Binary t => Get t
get :: Get Word8
        case tag of
            Word8
0 -> (Int32 -> Integer) -> Get Int32 -> Get Integer
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Int32
forall t. Binary t => Get t
get :: Get SmallInt)
            Word8
_ -> do sign  <- Get Word8
forall t. Binary t => Get t
get
                    bytes <- get
                    let v = [Word8] -> Integer
forall a. (Integral a, Bits a) => [Word8] -> a
roll [Word8]
bytes
                    return $! if sign == (1 :: Word8) then v else - v

-- | @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 :: forall a. (Integral a, Bits a) => a -> [Word8]
unroll = (a -> Maybe (Word8, a)) -> a -> [Word8]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr a -> Maybe (Word8, a)
forall {b} {a}. (Integral b, Num a, Bits b) => b -> Maybe (a, b)
step
  where
    step :: b -> Maybe (a, b)
step b
0 = Maybe (a, b)
forall a. Maybe a
Nothing
    step b
i = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
i, b
i b -> Int -> b
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)

roll :: (Integral a, Bits a) => [Word8] -> a
roll :: forall a. (Integral a, Bits a) => [Word8] -> a
roll   = (a -> Word8 -> a) -> a -> [Word8] -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
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
        tag <- Get Word8
forall t. Binary t => Get t
get :: Get Word8
        case tag of
            Word8
0 -> (Word64 -> Natural) -> Get Word64 -> Get Natural
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Get Word64
forall t. Binary t => Get t
get :: Get NaturalWord)
            Word8
_ -> do bytes <- Get [Word8]
forall t. Binary t => Get t
get
                    return $! roll 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 a. [a] -> 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
        w <- Get Int
getByte
        r <- case () of
                ()
_ | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x80  -> Int -> Get Int
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
w
                  | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xe0  -> do
                                    x <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    return (x .|. shiftL6 (xor 0xc0 w))
                  | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xf0  -> do
                                    x <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                    y <- liftM (xor 0x80) getByte
                                    return (y .|. shiftL6 (x .|. shiftL6
                                            (xor 0xe0 w)))
                  | Bool
otherwise -> do
                                x <- (Int -> Int) -> Get Int -> Get Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor Int
0x80) Get Int
getByte
                                y <- liftM (xor 0x80) getByte
                                z <- liftM (xor 0x80) getByte
                                return (z .|. shiftL6 (y .|. shiftL6
                                        (x .|. shiftL6 (xor 0xf0 w))))
        getChr 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 a. 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 a. 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,(b,c,d,e,f)) <- Get (a, (b, c, d, e, f))
forall t. Binary t => Get t
get ; return (a,b,c,d,e,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,(b,c,d,e,f,g)) <- Get (a, (b, c, d, e, f, g))
forall t. Binary t => Get t
get ; return (a,b,c,d,e,f,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,(b,c,d,e,f,g,h)) <- Get (a, (b, c, d, e, f, g, h))
forall t. Binary t => Get t
get ; return (a,b,c,d,e,f,g,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,(b,c,d,e,f,g,h,i)) <- Get (a, (b, c, d, e, f, g, h, i))
forall t. Binary t => Get t
get ; return (a,b,c,d,e,f,g,h,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,(b,c,d,e,f,g,h,i,j)) <- Get (a, (b, c, d, e, f, g, h, i, j))
forall t. Binary t => Get t
get ; return (a,b,c,d,e,f,g,h,i,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 n <- Get Int
forall t. Binary t => Get t
get :: Get Int
             getMany 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 = [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 a. 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 x <- Get a
forall t. Binary t => Get t
get
                 -- we must seq x to avoid stack overflows due to laziness in
                 -- (>>=)
                 x `seq` go (x:xs) (i-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
        w <- Get Word8
getWord8
        case w of
            Word8
0 -> Maybe a -> Get (Maybe a)
forall a. a -> Get 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
        w <- Get Word8
getWord8
        case 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 a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ByteString
getByteString

--
-- 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 a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int64 -> Get ByteString
getLazyByteString


#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 a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ByteString -> ShortByteString)
-> Get ByteString -> Get ShortByteString
forall a b. (a -> b) -> Get a -> Get b
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 n <- Get Int
forall t. Binary t => Get t
get :: Get Int
             rep Seq.empty n 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 a. a -> m 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)
forall a b. a -> b -> b
`seq` t
n t -> m (Seq a) -> m (Seq a)
forall a b. a -> b -> b
`seq` do
                           x <- m a
g
                           rep (xs Seq.|> x) (n-1) g

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

-- | Uses non-IEEE754 encoding. Does not round-trip NaN.
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
        x <- Get Integer
forall t. Binary t => Get t
get
        y <- get
        return $! encodeFloat x y

-- | Uses non-IEEE754 encoding. Does not round-trip NaN.
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
        x <- Get Integer
forall t. Binary t => Get t
get
        y <- get
        return $! encodeFloat x 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 -> [Tree 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 i. Ix i => 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 i. Ix i => 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
        bs <- Get (i, i)
forall t. Binary t => Get t
get
        n  <- get                  -- read the length
        xs <- getMany n            -- now the elems.
        return (listArray bs 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 i. Ix i => 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 i. Ix i => 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
        bs <- Get (i, i)
forall t. Binary t => Get t
get
        n  <- get
        xs <- getMany n
        return (listArray bs 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
        x1 <- Get Word64
forall t. Binary t => Get t
get
        x2 <- get
        return $! Fingerprint x1 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 a b. Get (a -> b) -> Get a -> Get b
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 a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Dual a
forall a. a -> Dual a
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 a b. (a -> b) -> Get a -> Get b
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 a b. (a -> b) -> Get a -> Get b
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 a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Sum a
forall a. a -> Sum a
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 a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Product a
forall a. a -> Product a
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 a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe a -> First a
forall a. Maybe a -> First a
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 a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe a -> Last a
forall a. Maybe a -> Last a
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 a b. (a -> b) -> Get a -> Get b
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 a b. (a -> b) -> Get a -> Get b
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 a b. (a -> b) -> Get a -> Get b
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 a b. (a -> b) -> Get a -> Get b
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 a b. (a -> b) -> Get a -> Get b
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 = 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 = (m -> WrappedMonoid m) -> Get m -> Get (WrappedMonoid m)
forall a b. (a -> b) -> Get a -> Get b
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
      list <- Get [a]
forall t. Binary t => Get t
get
      case list of
        [] -> String -> Get (NonEmpty a)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"NonEmpty is empty!"
        a
x:[a]
xs -> NonEmpty a -> Get (NonEmpty a)
forall a. a -> Get 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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 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
        tag <- Get Word8
getWord8
        case 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 a b. Get (a -> b) -> Get a -> Get b
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
          Word8
3  -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Levity -> RuntimeRep
BoxedRep Levity
Lifted)
          Word8
4  -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Levity -> RuntimeRep
BoxedRep Levity
Unlifted)
#else
          3  -> pure LiftedRep
          4  -> pure UnliftedRep
#endif
          Word8
5  -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
IntRep
          Word8
6  -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
WordRep
          Word8
7  -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int64Rep
          Word8
8  -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word64Rep
          Word8
9  -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
AddrRep
          Word8
10 -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
FloatRep
          Word8
11 -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
DoubleRep
#if __GLASGOW_HASKELL__ >= 807
          Word8
12 -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int8Rep
          Word8
13 -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word8Rep
          Word8
14 -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int16Rep
          Word8
15 -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word16Rep
#if __GLASGOW_HASKELL__ >= 809
          Word8
16 -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Int32Rep
          Word8
17 -> RuntimeRep -> Get RuntimeRep
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RuntimeRep
Word32Rep
#endif
#endif
          Word8
_  -> String -> Get RuntimeRep
forall a. String -> Get a
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 a b. Get (a -> b) -> Get a -> Get b
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 a b. Get (a -> b) -> Get a -> Get b
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 a b. Get (a -> b) -> Get a -> Get b
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 a b. Get (a -> b) -> Get a -> Get b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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
        tag <- Get Word8
getWord8
        case 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 a b. Get (a -> b) -> Get a -> Get b
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 a b. Get (a -> b) -> Get a -> Get b
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 a b. Get (a -> b) -> Get a -> Get b
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 a b. Get (a -> b) -> Get a -> Get b
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 a. String -> Get a
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
        tag <- Get Word8
getWord8
        case tag of
          Word8
0 -> TypeLitSort -> Get TypeLitSort
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeLitSort
TypeLitSymbol
          Word8
1 -> TypeLitSort -> Get TypeLitSort
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeLitSort
TypeLitNat
#ifdef HAS_TYPELITS_CHAR
          Word8
2 -> TypeLitSort -> Get TypeLitSort
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeLitSort
TypeLitChar
#endif
          Word8
_ -> String -> Get TypeLitSort
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"GHCi.TH.Binary.putTypeLitSort: invalid tag"

putTypeRep :: TypeRep a -> Put
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 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 arg res) = do
    put (3 :: Word8)
    putTypeRep arg
    putTypeRep res
#endif

getSomeTypeRep :: Get SomeTypeRep
getSomeTypeRep :: Get SomeTypeRep
getSomeTypeRep = do
    tag <- Get Word8
forall t. Binary t => Get t
get :: Get Word8
    case tag of
        Word8
0 -> SomeTypeRep -> Get SomeTypeRep
forall a. a -> Get a
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 con <- Get TyCon
forall t. Binary t => Get t
get :: Get TyCon
                ks <- get :: Get [SomeTypeRep]
                return $ SomeTypeRep $ mkTrCon con ks
        Word8
2 -> do SomeTypeRep f <- Get SomeTypeRep
getSomeTypeRep
                SomeTypeRep x <- getSomeTypeRep
                case typeRepKind 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 a. a -> Get a
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 a. 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 rep <- Get SomeTypeRep
getSomeTypeRep
        case rep `eqTypeRep` expected of
          Just a :~~: a
HRefl -> TypeRep a -> Get (TypeRep a)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeRep a
TypeRep a
rep
          Maybe (a :~~: a)
Nothing    -> String -> Get (TypeRep a)
forall a. String -> Get 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