src/Data/Binary/Class.hs

    {-# 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,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

    --
    -- 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 = defaultPutList

        default put :: (Generic t, GBinaryPut (Rep t)) => t -> Put
        put = gput . from

        default get :: (Generic t, GBinaryGet (Rep t)) => Get t
        get = to `fmap` gget

    {-# INLINE defaultPutList #-}
    defaultPutList :: Binary a => [a] -> Put
    defaultPutList xs = put (length xs) <> mapM_ put 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     = absurd
        get     = 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 ()  = mempty
        get     = return ()

    -- Bools are encoded as a byte in the range 0 .. 1
    instance Binary Bool where
        put     = putWord8 . fromIntegral . fromEnum
        get     = getWord8 >>= toBool
          where
            toBool 0 = return False
            toBool 1 = return True
            toBool c = fail ("Could not map value " ++ show c ++ " to Bool")

    -- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
    instance Binary Ordering where
        put     = putWord8 . fromIntegral . fromEnum
        get     = getWord8 >>= toOrd
          where
            toOrd 0 = return LT
            toOrd 1 = return EQ
            toOrd 2 = return GT
            toOrd c = fail ("Could not map value " ++ show c ++ " to Ordering")

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

    -- Words8s are written as bytes
    instance Binary Word8 where
        put     = putWord8
        {-# INLINE putList #-}
        putList xs =
            put (length xs)
            <> putBuilder (Prim.primMapListFixed Prim.word8 xs)
        get     = getWord8

    -- Words16s are written as 2 bytes in big-endian (network) order
    instance Binary Word16 where
        put     = putWord16be
        {-# INLINE putList #-}
        putList xs =
            put (length xs)
            <> putBuilder (Prim.primMapListFixed Prim.word16BE xs)
        get     = getWord16be

    -- Words32s are written as 4 bytes in big-endian (network) order
    instance Binary Word32 where
        put     = putWord32be
        {-# INLINE putList #-}
        putList xs =
            put (length xs)
            <> putBuilder (Prim.primMapListFixed Prim.word32BE xs)
        get     = getWord32be

    -- Words64s are written as 8 bytes in big-endian (network) order
    instance Binary Word64 where
        put     = putWord64be
        {-# INLINE putList #-}
        putList xs =
            put (length xs)
            <> putBuilder (Prim.primMapListFixed Prim.word64BE xs)
        get     = getWord64be

    -- Int8s are written as a single byte.
    instance Binary Int8 where
        put     = putInt8
        {-# INLINE putList #-}
        putList xs =
            put (length xs)
            <> putBuilder (Prim.primMapListFixed Prim.int8 xs)
        get     = getInt8

    -- Int16s are written as a 2 bytes in big endian format
    instance Binary Int16 where
        put     = putInt16be
        {-# INLINE putList #-}
        putList xs =
            put (length xs)
            <> putBuilder (Prim.primMapListFixed Prim.int16BE xs)
        get     = getInt16be

    -- Int32s are written as a 4 bytes in big endian format
    instance Binary Int32 where
        put     = putInt32be
        {-# INLINE putList #-}
        putList xs =
            put (length xs)
            <> putBuilder (Prim.primMapListFixed Prim.int32BE xs)
        get     = getInt32be

    -- Int64s are written as a 8 bytes in big endian format
    instance Binary Int64 where
        put     = putInt64be
        {-# INLINE putList #-}
        putList xs =
            put (length xs)
            <> putBuilder (Prim.primMapListFixed Prim.int64BE xs)
        get     = getInt64be

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

    -- Words are are written as Word64s, that is, 8 bytes in big endian format
    instance Binary Word where
        put     = putWord64be . fromIntegral
        {-# INLINE putList #-}
        putList xs =
            put (length xs)
            <> putBuilder (Prim.primMapListFixed Prim.word64BE (map fromIntegral xs))
        get     = liftM fromIntegral getWord64be

    -- Ints are are written as Int64s, that is, 8 bytes in big endian format
    instance Binary Int where
        put     = putInt64be . fromIntegral
        {-# INLINE putList #-}
        putList xs =
            put (length xs)
            <> putBuilder (Prim.primMapListFixed Prim.int64BE (map fromIntegral xs))
        get     = liftM fromIntegral 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 n | n >= lo && n <= hi =
            putBuilder (Prim.primFixed (Prim.word8 Prim.>*< Prim.int32BE) (0, fromIntegral n))
         where
            lo = fromIntegral (minBound :: SmallInt) :: Integer
            hi = fromIntegral (maxBound :: SmallInt) :: Integer

        put n =
            putWord8 1
            <> put sign
            <> put (unroll (abs n))         -- unroll the bytes
         where
            sign = fromIntegral (signum n) :: Word8

        {-# INLINE get #-}
        get = do
            tag <- get :: Get Word8
            case tag of
                0 -> liftM fromIntegral (get :: Get SmallInt)
                _ -> do sign  <- get
                        bytes <- get
                        let v = roll 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.MkFixed a) = put a
      get = Fixed.MkFixed `liftM` 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 = unfoldr step
      where
        step 0 = Nothing
        step i = Just (fromIntegral i, i `shiftR` 8)

    roll :: (Integral a, Bits a) => [Word8] -> a
    roll   = foldl' unstep 0 . reverse
      where
        unstep a b = a `shiftL` 8 .|. fromIntegral 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 n | n <= hi =
            putWord8 0
            <> put (fromIntegral n :: NaturalWord)  -- fast path
         where
            hi = fromIntegral (maxBound :: NaturalWord) :: Natural

        put n =
            putWord8 1
            <> put (unroll (abs n))         -- unroll the bytes

        {-# INLINE get #-}
        get = do
            tag <- get :: Get Word8
            case tag of
                0 -> liftM fromIntegral (get :: Get NaturalWord)
                _ -> do bytes <- 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 r = put (R.numerator r) <> put (R.denominator r)
        get = liftM2 (R.%) get get

    instance Binary a => Binary (Complex a) where
        {-# INLINE put #-}
        put (r :+ i) = put (r, i)
        {-# INLINE get #-}
        get = (\(r,i) -> r :+ i) <$> get

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

    -- Char is serialised as UTF-8
    instance Binary Char where
        put = putCharUtf8
        putList str = put (length str) <> putStringUtf8 str
        get = do
            let getByte = liftM (fromIntegral :: Word8 -> Int) get
                shiftL6 = flip shiftL 6 :: Int -> Int
            w <- getByte
            r <- case () of
                    _ | w < 0x80  -> return w
                      | w < 0xe0  -> do
                                        x <- liftM (xor 0x80) getByte
                                        return (x .|. shiftL6 (xor 0xc0 w))
                      | w < 0xf0  -> do
                                        x <- liftM (xor 0x80) getByte
                                        y <- liftM (xor 0x80) getByte
                                        return (y .|. shiftL6 (x .|. shiftL6
                                                (xor 0xe0 w)))
                      | otherwise -> do
                                    x <- liftM (xor 0x80) 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 w
              | w <= 0x10ffff = return $! toEnum $ fromEnum w
              | otherwise = fail "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 a <> put b
        {-# INLINE get #-}
        get                 = liftM2 (,) get get

    instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
        {-# INLINE put #-}
        put (a,b,c)         = put a <> put b <> put c
        {-# INLINE get #-}
        get                 = liftM3 (,,) get get get

    instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
        {-# INLINE put #-}
        put (a,b,c,d)       = put a <> put b <> put c <> put d
        {-# INLINE get #-}
        get                 = liftM4 (,,,) get get get 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 a <> put b <> put c <> put d <> put e
        {-# INLINE get #-}
        get                 = liftM5 (,,,,) get get get get 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 (a,(b,c,d,e,f))
        {-# INLINE get #-}
        get                 = do (a,(b,c,d,e,f)) <- 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 (a,(b,c,d,e,f,g))
        {-# INLINE get #-}
        get                 = do (a,(b,c,d,e,f,g)) <- 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 (a,(b,c,d,e,f,g,h))
        {-# INLINE get #-}
        get                   = do (a,(b,c,d,e,f,g,h)) <- 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 (a,(b,c,d,e,f,g,h,i))
        {-# INLINE get #-}
        get                     = do (a,(b,c,d,e,f,g,h,i)) <- 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 (a,(b,c,d,e,f,g,h,i,j))
        {-# INLINE get #-}
        get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- 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 x) = put x
      get = Identity <$> get
    #endif

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

    -- | 'getMany n' get 'n' elements in order, without blowing the stack.
    getMany :: Binary a => Int -> Get [a]
    getMany n = go [] n
     where
        go xs 0 = return $! reverse xs
        go xs i = do x <- 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 Nothing  = putWord8 0
        put (Just x) = putWord8 1 <> put x
        get = do
            w <- getWord8
            case w of
                0 -> return Nothing
                _ -> liftM Just get

    instance (Binary a, Binary b) => Binary (Either a b) where
        put (Left  a) = putWord8 0 <> put a
        put (Right b) = putWord8 1 <> put b
        get = do
            w <- getWord8
            case w of
                0 -> liftM Left  get
                _ -> liftM Right get

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

    instance Binary B.ByteString where
        put bs = put (B.length bs)
                 <> putByteString bs
        get    = get >>= getByteString

    --
    -- Using old versions of fps, this is a type synonym, and non portable
    --
    -- Requires 'flexible instances'
    --
    instance Binary ByteString where
        put bs = put (fromIntegral (L.length bs) :: Int)
                 <> putLazyByteString bs
        get    = get >>= getLazyByteString

    #if MIN_VERSION_bytestring(0,10,4)
    instance Binary BS.ShortByteString where
       put bs = put (BS.length bs)
                <> putShortByteString bs
       get = get >>= fmap BS.toShort . getByteString
    #endif

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

    instance (Binary a) => Binary (Set.Set a) where
        put s = put (Set.size s) <> mapM_ put (Set.toAscList s)
        get   = liftM Set.fromDistinctAscList get

    instance (Binary k, Binary e) => Binary (Map.Map k e) where
        put m = put (Map.size m) <> mapM_ put (Map.toAscList m)
        get   = liftM Map.fromDistinctAscList get

    instance Binary IntSet.IntSet where
        put s = put (IntSet.size s) <> mapM_ put (IntSet.toAscList s)
        get   = liftM IntSet.fromDistinctAscList get

    instance (Binary e) => Binary (IntMap.IntMap e) where
        put m = put (IntMap.size m) <> mapM_ put (IntMap.toAscList m)
        get   = liftM IntMap.fromDistinctAscList get

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

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

    instance (Binary e) => Binary (Seq.Seq e) where
        put s = put (Seq.length s) <> Fold.mapM_ put s
        get = do n <- get :: Get Int
                 rep Seq.empty n get
          where rep xs 0 _ = return $! xs
                rep xs n g = xs `seq` n `seq` do
                               x <- g
                               rep (xs Seq.|> x) (n-1) g

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

    instance Binary Double where
        put d = put (decodeFloat d)
        get   = do
            x <- get
            y <- get
            return $! encodeFloat x y

    instance Binary Float where
        put f = put (decodeFloat f)
        get   =  do
            x <- get
            y <- get
            return $! encodeFloat x y

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

    instance (Binary e) => Binary (T.Tree e) where
        put (T.Node r s) = put r <> put s
        get = liftM2 T.Node get get

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

    instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
        put a =
            put (bounds a)
            <> put (rangeSize $ bounds a) -- write the length
            <> mapM_ put (elems a)        -- now the elems.
        get = do
            bs <- 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 a =
            put (bounds a)
            <> put (rangeSize $ bounds a) -- now write the length
            <> mapM_ put (elems a)
        get = do
            bs <- get
            n  <- get
            xs <- getMany n
            return (listArray bs xs)

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

    -- | /Since: 0.7.6.0/
    instance Binary Fingerprint where
        put (Fingerprint x1 x2) = put x1 <> put x2
        get = do
            x1 <- get
            x2 <- get
            return $! Fingerprint x1 x2

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

    -- | /Since: 0.8.0.0/
    instance Binary Version where
        put (Version br tags) = put br <> put tags
        get = Version <$> get <*> get

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

    -- | /Since: 0.8.4.0/
    instance Binary a => Binary (Monoid.Dual a) where
      get = fmap Monoid.Dual get
      put = put . Monoid.getDual

    -- | /Since: 0.8.4.0/
    instance Binary Monoid.All where
      get = fmap Monoid.All get
      put = put . Monoid.getAll

    -- | /Since: 0.8.4.0/
    instance Binary Monoid.Any where
      get = fmap Monoid.Any get
      put = put . Monoid.getAny

    -- | /Since: 0.8.4.0/
    instance Binary a => Binary (Monoid.Sum a) where
      get = fmap Monoid.Sum get
      put = put . Monoid.getSum

    -- | /Since: 0.8.4.0/
    instance Binary a => Binary (Monoid.Product a) where
      get = fmap Monoid.Product get
      put = put . Monoid.getProduct

    -- | /Since: 0.8.4.0/
    instance Binary a => Binary (Monoid.First a) where
      get = fmap Monoid.First get
      put = put . Monoid.getFirst

    -- | /Since: 0.8.4.0/
    instance Binary a => Binary (Monoid.Last a) where
      get = fmap Monoid.Last get
      put = put . 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 = fmap Monoid.Alt get
      put = put . 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 = fmap Semigroup.Min get
      put = put . Semigroup.getMin

    -- | /Since: 0.8.4.0/
    instance Binary a => Binary (Semigroup.Max a) where
      get = fmap Semigroup.Max get
      put = put . Semigroup.getMax

    -- | /Since: 0.8.4.0/
    instance Binary a => Binary (Semigroup.First a) where
      get = fmap Semigroup.First get
      put = put . Semigroup.getFirst

    -- | /Since: 0.8.4.0/
    instance Binary a => Binary (Semigroup.Last a) where
      get = fmap Semigroup.Last get
      put = put . Semigroup.getLast

    -- | /Since: 0.8.4.0/
    instance Binary a => Binary (Semigroup.Option a) where
      get = fmap Semigroup.Option get
      put = put . Semigroup.getOption

    -- | /Since: 0.8.4.0/
    instance Binary m => Binary (Semigroup.WrappedMonoid m) where
      get = fmap Semigroup.WrapMonoid get
      put = put . Semigroup.unwrapMonoid

    -- | /Since: 0.8.4.0/
    instance (Binary a, Binary b) => Binary (Semigroup.Arg a b) where
      get                     = liftM2 Semigroup.Arg get get
      put (Semigroup.Arg a b) = put a <> put b

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

    -- | /Since: 0.8.4.0/
    instance Binary a => Binary (NE.NonEmpty a) where
      get = fmap NE.fromList get
      put = put . 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. See #typeable-instances#
    instance Binary VecCount where
        put = putWord8 . fromIntegral . fromEnum
        get = toEnum . fromIntegral <$> getWord8

    -- | @since 0.8.5.0. See #typeable-instances#
    instance Binary VecElem where
        put = putWord8 . fromIntegral . fromEnum
        get = toEnum . fromIntegral <$> getWord8

    -- | @since 0.8.5.0. See #typeable-instances#
    instance Binary RuntimeRep where
        put (VecRep a b)    = putWord8 0 >> put a >> put b
        put (TupleRep reps) = putWord8 1 >> put reps
        put (SumRep reps)   = putWord8 2 >> put reps
        put LiftedRep       = putWord8 3
        put UnliftedRep     = putWord8 4
        put IntRep          = putWord8 5
        put WordRep         = putWord8 6
        put Int64Rep        = putWord8 7
        put Word64Rep       = putWord8 8
        put AddrRep         = putWord8 9
        put FloatRep        = putWord8 10
        put DoubleRep       = putWord8 11
    #if __GLASGOW_HASKELL__ >= 807
        put Int8Rep         = putWord8 12
        put Word8Rep        = putWord8 13
        put Int16Rep        = putWord8 14
        put Word16Rep       = putWord8 15
    #endif

        get = do
            tag <- getWord8
            case tag of
              0  -> VecRep <$> get <*> get
              1  -> TupleRep <$> get
              2  -> SumRep <$> get
              3  -> pure LiftedRep
              4  -> pure UnliftedRep
              5  -> pure IntRep
              6  -> pure WordRep
              7  -> pure Int64Rep
              8  -> pure Word64Rep
              9  -> pure AddrRep
              10 -> pure FloatRep
              11 -> pure DoubleRep
    #if __GLASGOW_HASKELL__ >= 807
              12 -> pure Int8Rep
              13 -> pure Word8Rep
              14 -> pure Int16Rep
              15 -> pure Word16Rep
    #endif
              _  -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag"

    -- | @since 0.8.5.0. See #typeable-instances#
    instance Binary TyCon where
        put tc = do
            put (tyConPackage tc)
            put (tyConModule tc)
            put (tyConName tc)
            put (tyConKindArgs tc)
            put (tyConKindRep tc)
        get = mkTyCon <$> get <*> get <*> get <*> get <*> get

    -- | @since 0.8.5.0. See #typeable-instances#
    instance Binary KindRep where
        put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k
        put (KindRepVar bndr) = putWord8 1 >> put bndr
        put (KindRepApp a b) = putWord8 2 >> put a >> put b
        put (KindRepFun a b) = putWord8 3 >> put a >> put b
        put (KindRepTYPE r) = putWord8 4 >> put r
        put (KindRepTypeLit sort r) = putWord8 5 >> put sort >> put r

        get = do
            tag <- getWord8
            case tag of
              0 -> KindRepTyConApp <$> get <*> get
              1 -> KindRepVar <$> get
              2 -> KindRepApp <$> get <*> get
              3 -> KindRepFun <$> get <*> get
              4 -> KindRepTYPE <$> get
              5 -> KindRepTypeLit <$> get <*> get
              _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag"

    -- | @since 0.8.5.0. See #typeable-instances#
    instance Binary TypeLitSort where
        put TypeLitSymbol = putWord8 0
        put TypeLitNat = putWord8 1
        get = do
            tag <- getWord8
            case tag of
              0 -> pure TypeLitSymbol
              1 -> pure TypeLitNat
              _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag"

    putTypeRep :: TypeRep a -> Put
    -- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
    -- relations.
    -- See Note [Mutually recursive representations of primitive types]
    putTypeRep rep  -- Handle Type specially since it's so common
      | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
      = put (0 :: Word8)
    putTypeRep (Con' con ks) = do
        put (1 :: Word8)
        put con
        put ks
    putTypeRep (App f x) = do
        put (2 :: Word8)
        putTypeRep f
        putTypeRep x
    putTypeRep (Fun arg res) = do
        put (3 :: Word8)
        putTypeRep arg
        putTypeRep res
    putTypeRep _ = error "GHCi.TH.Binary.putTypeRep: Impossible"

    getSomeTypeRep :: Get SomeTypeRep
    getSomeTypeRep = do
        tag <- get :: Get Word8
        case tag of
            0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
            1 -> do con <- get :: Get TyCon
                    ks <- get :: Get [SomeTypeRep]
                    return $ SomeTypeRep $ mkTrCon con ks
            2 -> do SomeTypeRep f <- getSomeTypeRep
                    SomeTypeRep x <- getSomeTypeRep
                    case typeRepKind f of
                      Fun arg res ->
                          case arg `eqTypeRep` typeRepKind x of
                            Just HRefl -> do
                                case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
                                    Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
                                    _ -> failure "Kind mismatch" []
                            _ -> failure "Kind mismatch"
                                 [ "Found argument of kind:      " ++ show (typeRepKind x)
                                 , "Where the constructor:       " ++ show f
                                 , "Expects an argument of kind: " ++ show arg
                                 ]
                      _ -> failure "Applied non-arrow type"
                           [ "Applied type: " ++ show f
                           , "To argument:  " ++ show x
                           ]
            3 -> do SomeTypeRep arg <- getSomeTypeRep
                    SomeTypeRep res <- getSomeTypeRep
                    case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of
                      Just HRefl ->
                          case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
                            Just HRefl -> return $ SomeTypeRep $ Fun arg res
                            Nothing -> failure "Kind mismatch" []
                      Nothing -> failure "Kind mismatch" []
            _ -> failure "Invalid SomeTypeRep" []
      where
        failure description info =
            fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ]
                          ++ map ("    "++) info

    instance Typeable a => Binary (TypeRep (a :: k)) where
        put = putTypeRep
        get = do
            SomeTypeRep rep <- getSomeTypeRep
            case rep `eqTypeRep` expected of
              Just HRefl -> pure rep
              Nothing    -> fail $ unlines
                            [ "GHCi.TH.Binary: Type mismatch"
                            , "    Deserialized type: " ++ show rep
                            , "    Expected type:     " ++ show expected
                            ]
         where expected = typeRep :: TypeRep a

    instance Binary SomeTypeRep where
        put (SomeTypeRep rep) = putTypeRep rep
        get = getSomeTypeRep
    #endif