Class.hs 32 KB
Newer Older
1
{-# LANGUAGE CPP, FlexibleContexts #-}
2
{-# LANGUAGE DefaultSignatures #-}
3 4 5 6
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Trustworthy #-}
Lennart Kolmodin's avatar
Lennart Kolmodin committed
7

8 9 10 11
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif

Lennart Kolmodin's avatar
Lennart Kolmodin committed
12 13
#if MIN_VERSION_base(4,8,0)
#define HAS_NATURAL
14
#define HAS_VOID
Lennart Kolmodin's avatar
Lennart Kolmodin committed
15 16
#endif

17 18 19 20
#if MIN_VERSION_base(4,7,0)
#define HAS_FIXED_CONSTRUCTOR
#endif

21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
-----------------------------------------------------------------------------
-- |
-- 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(..)

40
    -- * Support for generics
41 42
    , GBinaryGet(..)
    , GBinaryPut(..)
43

44 45 46
    ) where

import Data.Word
47 48
import Data.Bits
import Data.Int
49
import Data.Complex (Complex(..))
50
#ifdef HAS_VOID
Brian McKenna's avatar
Brian McKenna committed
51
import Data.Void
52
#endif
53 54 55 56

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

57 58
#if ! MIN_VERSION_base(4,8,0)
import Control.Applicative
59
import Data.Monoid (mempty)
60
#endif
61
import qualified Data.Monoid as Monoid
David Eichmann's avatar
David Eichmann committed
62
#if !MIN_VERSION_base(4,11,0)
63
import Data.Monoid ((<>))
David Eichmann's avatar
David Eichmann committed
64
#endif
65 66 67
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity (Identity (..))
#endif
68 69 70 71
#if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup     as Semigroup
#endif
72 73 74 75
import Control.Monad

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

78
import Data.List    (unfoldr, foldl')
79 80

-- And needed for the instances:
81 82 83 84 85 86
#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
87
import qualified Data.ByteString as B
88 89 90
#if MIN_VERSION_bytestring(0,10,4)
import qualified Data.ByteString.Short as BS
#endif
91 92 93 94 95 96 97 98 99 100
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

101 102
import GHC.Generics

Lennart Kolmodin's avatar
Lennart Kolmodin committed
103 104 105
#ifdef HAS_NATURAL
import Numeric.Natural
#endif
106 107 108

import qualified Data.Fixed as Fixed

109 110 111 112 113 114
--
-- This isn't available in older Hugs or older GHC
--
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Fold

115 116
import GHC.Fingerprint

Oleg Grenrus's avatar
Oleg Grenrus committed
117 118
import Data.Version (Version(..))

119 120
------------------------------------------------------------------------

121 122 123 124 125
-- 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
126
    gput :: f t -> Put
127 128

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

131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
-- | 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

Lennart Kolmodin's avatar
Lennart Kolmodin committed
154 155 156
    -- | 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.
157 158 159
    putList :: [t] -> Put
    putList = defaultPutList

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

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

166 167
{-# INLINE defaultPutList #-}
defaultPutList :: Binary a => [a] -> Put
168
defaultPutList xs = put (length xs) <> mapM_ put xs
169

170 171 172
------------------------------------------------------------------------
-- Simple instances

173
#ifdef HAS_VOID
Brian McKenna's avatar
Brian McKenna committed
174 175
-- Void never gets written nor reconstructed since it's impossible to have a
-- value of that type
Oleg Grenrus's avatar
Oleg Grenrus committed
176

Alec Theriault's avatar
Alec Theriault committed
177
-- | @since 0.8.0.0
Brian McKenna's avatar
Brian McKenna committed
178 179 180
instance Binary Void where
    put     = absurd
    get     = mzero
181
#endif
Brian McKenna's avatar
Brian McKenna committed
182

183 184 185
-- The () type need never be written to disk: values of singleton type
-- can be reconstructed from the type alone
instance Binary () where
186
    put ()  = mempty
187 188 189 190 191
    get     = return ()

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

-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
instance Binary Ordering where
    put     = putWord8 . fromIntegral . fromEnum
201 202 203 204 205 206
    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")
207 208 209 210 211 212 213

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

-- Words8s are written as bytes
instance Binary Word8 where
    put     = putWord8
214
    {-# INLINE putList #-}
215
    putList xs =
216
        put (length xs)
217
        <> putBuilder (Prim.primMapListFixed Prim.word8 xs)
218 219 220 221 222
    get     = getWord8

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

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

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

-- Int8s are written as a single byte.
instance Binary Int8 where
249
    put     = putInt8
250
    {-# INLINE putList #-}
251
    putList xs =
252
        put (length xs)
253
        <> putBuilder (Prim.primMapListFixed Prim.int8 xs)
254
    get     = getInt8
255 256 257

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

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

274
-- Int64s are written as a 8 bytes in big endian format
275
instance Binary Int64 where
276
    put     = putInt64be
277
    {-# INLINE putList #-}
278
    putList xs =
279
        put (length xs)
280
        <> putBuilder (Prim.primMapListFixed Prim.int64BE xs)
281
    get     = getInt64be
282 283 284 285 286

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

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

-- Ints are are written as Int64s, that is, 8 bytes in big endian format
instance Binary Int where
296
    put     = putInt64be . fromIntegral
297
    {-# INLINE putList #-}
298
    putList xs =
299
        put (length xs)
300
        <> putBuilder (Prim.primMapListFixed Prim.int64BE (map fromIntegral xs))
301
    get     = liftM fromIntegral getInt64be
302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318

------------------------------------------------------------------------
--
-- 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 #-}
319 320
    put n | n >= lo && n <= hi =
        putBuilder (Prim.primFixed (Prim.word8 Prim.>*< Prim.int32BE) (0, fromIntegral n))
321 322 323 324
     where
        lo = fromIntegral (minBound :: SmallInt) :: Integer
        hi = fromIntegral (maxBound :: SmallInt) :: Integer

325
    put n =
326
        putWord8 1
327 328
        <> put sign
        <> put (unroll (abs n))         -- unroll the bytes
329 330 331 332 333 334 335 336 337 338 339 340 341
     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

Alec Theriault's avatar
Alec Theriault committed
342
-- | @since 0.8.0.0
343 344 345 346 347 348 349 350 351 352 353
#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

354 355 356
--
-- Fold and unfold an Integer to and from a list of its bytes
--
357
unroll :: (Integral a, Bits a) => a -> [Word8]
358 359 360 361 362
unroll = unfoldr step
  where
    step 0 = Nothing
    step i = Just (fromIntegral i, i `shiftR` 8)

363
roll :: (Integral a, Bits a) => [Word8] -> a
364
roll   = foldl' unstep 0 . reverse
365
  where
366
    unstep a b = a `shiftL` 8 .|. fromIntegral b
367

Lennart Kolmodin's avatar
Lennart Kolmodin committed
368 369 370 371
#ifdef HAS_NATURAL
-- Fixed-size type for a subset of Natural
type NaturalWord = Word64

Alec Theriault's avatar
Alec Theriault committed
372
-- | @since 0.7.3.0
Lennart Kolmodin's avatar
Lennart Kolmodin committed
373 374
instance Binary Natural where
    {-# INLINE put #-}
375
    put n | n <= hi =
Lennart Kolmodin's avatar
Lennart Kolmodin committed
376
        putWord8 0
377
        <> put (fromIntegral n :: NaturalWord)  -- fast path
Lennart Kolmodin's avatar
Lennart Kolmodin committed
378 379 380
     where
        hi = fromIntegral (maxBound :: NaturalWord) :: Natural

381
    put n =
Lennart Kolmodin's avatar
Lennart Kolmodin committed
382
        putWord8 1
383
        <> put (unroll (abs n))         -- unroll the bytes
Lennart Kolmodin's avatar
Lennart Kolmodin committed
384 385 386 387 388 389 390 391 392 393

    {-# INLINE get #-}
    get = do
        tag <- get :: Get Word8
        case tag of
            0 -> liftM fromIntegral (get :: Get NaturalWord)
            _ -> do bytes <- get
                    return $! roll bytes
#endif

394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460
{-

--
-- 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
461
    put r = put (R.numerator r) <> put (R.denominator r)
462 463
    get = liftM2 (R.%) get get

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

470 471 472 473
------------------------------------------------------------------------

-- Char is serialised as UTF-8
instance Binary Char where
474
    put = putCharUtf8
475
    putList str = put (length str) <> putStringUtf8 str
476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495
    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))))
ttuegel's avatar
ttuegel committed
496 497 498 499 500
        getChr r
      where
        getChr w
          | w <= 0x10ffff = return $! toEnum $ fromEnum w
          | otherwise = fail "Not a valid Unicode code point!"
501 502 503 504 505

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

instance (Binary a, Binary b) => Binary (a,b) where
506
    {-# INLINE put #-}
507
    put (a,b)           = put a <> put b
508
    {-# INLINE get #-}
509 510 511
    get                 = liftM2 (,) get get

instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
512
    {-# INLINE put #-}
513
    put (a,b,c)         = put a <> put b <> put c
514
    {-# INLINE get #-}
515 516 517
    get                 = liftM3 (,,) get get get

instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
518
    {-# INLINE put #-}
519
    put (a,b,c,d)       = put a <> put b <> put c <> put d
520
    {-# INLINE get #-}
521 522 523
    get                 = liftM4 (,,,) get get get get

instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
524
    {-# INLINE put #-}
525
    put (a,b,c,d,e)     = put a <> put b <> put c <> put d <> put e
526
    {-# INLINE get #-}
527 528 529 530 531 532 533 534
    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
535
    {-# INLINE put #-}
536
    put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))
537
    {-# INLINE get #-}
538 539 540 541
    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
542
    {-# INLINE put #-}
543
    put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))
544
    {-# INLINE get #-}
545 546 547 548 549
    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
550
    {-# INLINE put #-}
551
    put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))
552
    {-# INLINE get #-}
553 554 555 556 557
    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
558
    {-# INLINE put #-}
559
    put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))
560
    {-# INLINE get #-}
561 562 563 564 565
    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
566
    {-# INLINE put #-}
567
    put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))
568
    {-# INLINE get #-}
569 570 571 572 573
    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

574 575 576 577 578 579
#if MIN_VERSION_base(4,8,0)
instance Binary a => Binary (Identity a) where
  put (Identity x) = put x
  get = Identity <$> get
#endif

580
instance Binary a => Binary [a] where
581 582 583
    put = putList
    get = do n <- get :: Get Int
             getMany n
584

Alec Theriault's avatar
Alec Theriault committed
585
-- | @'getMany' n@ get @n@ elements in order, without blowing the stack.
586 587 588 589 590 591 592 593 594 595 596 597
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
598
    put (Just x) = putWord8 1 <> put x
599 600 601 602 603 604 605
    get = do
        w <- getWord8
        case w of
            0 -> return Nothing
            _ -> liftM Just get

instance (Binary a, Binary b) => Binary (Either a b) where
606 607
    put (Left  a) = putWord8 0 <> put a
    put (Right b) = putWord8 1 <> put b
608 609 610 611 612 613 614 615 616 617
    get = do
        w <- getWord8
        case w of
            0 -> liftM Left  get
            _ -> liftM Right get

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

instance Binary B.ByteString where
618 619
    put bs = put (B.length bs)
             <> putByteString bs
620 621 622 623 624 625 626 627
    get    = get >>= getByteString

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

632 633 634

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

640 641 642
------------------------------------------------------------------------
-- Maps and Sets

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

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

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

instance (Binary e) => Binary (IntMap.IntMap e) where
656
    put m = put (IntMap.size m) <> mapM_ put (IntMap.toAscList m)
657 658 659 660 661 662 663 664 665 666
    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
667
    put s = put (Seq.length s) <> Fold.mapM_ put s
668 669 670 671 672 673 674 675 676 677 678 679
    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)
680 681 682 683
    get   = do
        x <- get
        y <- get
        return $! encodeFloat x y
684 685 686

instance Binary Float where
    put f = put (decodeFloat f)
687 688 689 690
    get   =  do
        x <- get
        y <- get
        return $! encodeFloat x y
691 692 693 694 695

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

instance (Binary e) => Binary (T.Tree e) where
696
    put (T.Node r s) = put r <> put s
697 698 699 700 701 702
    get = liftM2 T.Node get get

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

instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
703
    put a =
704
        put (bounds a)
705 706
        <> put (rangeSize $ bounds a) -- write the length
        <> mapM_ put (elems a)        -- now the elems.
707 708 709 710 711 712 713 714 715 716
    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
717
    put a =
718
        put (bounds a)
719 720
        <> put (rangeSize $ bounds a) -- now write the length
        <> mapM_ put (elems a)
721 722 723 724 725
    get = do
        bs <- get
        n  <- get
        xs <- getMany n
        return (listArray bs xs)
726 727 728 729

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

Alec Theriault's avatar
Alec Theriault committed
730
-- | @since 0.7.6.0
731
instance Binary Fingerprint where
732
    put (Fingerprint x1 x2) = put x1 <> put x2
733 734 735
    get = do
        x1 <- get
        x2 <- get
736
        return $! Fingerprint x1 x2
Oleg Grenrus's avatar
Oleg Grenrus committed
737 738 739 740

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

Alec Theriault's avatar
Alec Theriault committed
741
-- | @since 0.8.0.0
Oleg Grenrus's avatar
Oleg Grenrus committed
742
instance Binary Version where
743
    put (Version br tags) = put br <> put tags
744
    get = Version <$> get <*> get
745 746 747 748

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

Alec Theriault's avatar
Alec Theriault committed
749
-- | @since 0.8.4.0
750 751 752 753
instance Binary a => Binary (Monoid.Dual a) where
  get = fmap Monoid.Dual get
  put = put . Monoid.getDual

Alec Theriault's avatar
Alec Theriault committed
754
-- | @since 0.8.4.0
755 756 757 758
instance Binary Monoid.All where
  get = fmap Monoid.All get
  put = put . Monoid.getAll

Alec Theriault's avatar
Alec Theriault committed
759
-- | @since 0.8.4.0
760 761 762 763
instance Binary Monoid.Any where
  get = fmap Monoid.Any get
  put = put . Monoid.getAny

Alec Theriault's avatar
Alec Theriault committed
764
-- | @since 0.8.4.0
765 766 767 768
instance Binary a => Binary (Monoid.Sum a) where
  get = fmap Monoid.Sum get
  put = put . Monoid.getSum

Alec Theriault's avatar
Alec Theriault committed
769
-- | @since 0.8.4.0
770 771 772 773
instance Binary a => Binary (Monoid.Product a) where
  get = fmap Monoid.Product get
  put = put . Monoid.getProduct

Alec Theriault's avatar
Alec Theriault committed
774
-- | @since 0.8.4.0
775 776 777 778
instance Binary a => Binary (Monoid.First a) where
  get = fmap Monoid.First get
  put = put . Monoid.getFirst

Alec Theriault's avatar
Alec Theriault committed
779
-- | @since 0.8.4.0
780 781 782 783 784
instance Binary a => Binary (Monoid.Last a) where
  get = fmap Monoid.Last get
  put = put . Monoid.getLast

#if MIN_VERSION_base(4,8,0)
Alec Theriault's avatar
Alec Theriault committed
785
-- | @since 0.8.4.0
786 787 788 789 790 791 792 793 794
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

Alec Theriault's avatar
Alec Theriault committed
795
-- | @since 0.8.4.0
796 797 798 799
instance Binary a => Binary (Semigroup.Min a) where
  get = fmap Semigroup.Min get
  put = put . Semigroup.getMin

Alec Theriault's avatar
Alec Theriault committed
800
-- | @since 0.8.4.0
801 802 803 804
instance Binary a => Binary (Semigroup.Max a) where
  get = fmap Semigroup.Max get
  put = put . Semigroup.getMax

Alec Theriault's avatar
Alec Theriault committed
805
-- | @since 0.8.4.0
806 807 808 809
instance Binary a => Binary (Semigroup.First a) where
  get = fmap Semigroup.First get
  put = put . Semigroup.getFirst

Alec Theriault's avatar
Alec Theriault committed
810
-- | @since 0.8.4.0
811 812 813 814
instance Binary a => Binary (Semigroup.Last a) where
  get = fmap Semigroup.Last get
  put = put . Semigroup.getLast

Alec Theriault's avatar
Alec Theriault committed
815
-- | @since 0.8.4.0
816 817 818 819
instance Binary a => Binary (Semigroup.Option a) where
  get = fmap Semigroup.Option get
  put = put . Semigroup.getOption

Alec Theriault's avatar
Alec Theriault committed
820
-- | @since 0.8.4.0
821 822 823 824
instance Binary m => Binary (Semigroup.WrappedMonoid m) where
  get = fmap Semigroup.WrapMonoid get
  put = put . Semigroup.unwrapMonoid

Alec Theriault's avatar
Alec Theriault committed
825
-- | @since 0.8.4.0
826 827 828 829 830 831 832
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

Alec Theriault's avatar
Alec Theriault committed
833
-- | @since 0.8.4.0
834
instance Binary a => Binary (NE.NonEmpty a) where
835 836 837
  get = do
      list <- get
      case list of
838
        [] -> fail "NonEmpty is empty!"
839
        x:xs -> pure (x NE.:| xs)
840 841
  put = put . NE.toList
#endif
842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866

------------------------------------------------------------------------
-- 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')
--

Alec Theriault's avatar
Alec Theriault committed
867
-- | @since 0.8.5.0
868 869 870 871
instance Binary VecCount where
    put = putWord8 . fromIntegral . fromEnum
    get = toEnum . fromIntegral <$> getWord8

Alec Theriault's avatar
Alec Theriault committed
872
-- | @since 0.8.5.0
873 874 875 876
instance Binary VecElem where
    put = putWord8 . fromIntegral . fromEnum
    get = toEnum . fromIntegral <$> getWord8

Alec Theriault's avatar
Alec Theriault committed
877
-- | @since 0.8.5.0
878 879 880 881 882 883 884 885 886 887 888 889 890
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
891 892 893
#if __GLASGOW_HASKELL__ >= 807
    put Int8Rep         = putWord8 12
    put Word8Rep        = putWord8 13
Ben Gamari's avatar
Ben Gamari committed
894 895
    put Int16Rep        = putWord8 14
    put Word16Rep       = putWord8 15
John Ericson's avatar
John Ericson committed
896 897 898 899
#if __GLASGOW_HASKELL__ >= 809
    put Int32Rep        = putWord8 16
    put Word32Rep       = putWord8 17
#endif
900
#endif
901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916

    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
917 918 919
#if __GLASGOW_HASKELL__ >= 807
          12 -> pure Int8Rep
          13 -> pure Word8Rep
Ben Gamari's avatar
Ben Gamari committed
920 921
          14 -> pure Int16Rep
          15 -> pure Word16Rep
John Ericson's avatar
John Ericson committed
922 923 924 925
#if __GLASGOW_HASKELL__ >= 809
          16 -> pure Int32Rep
          17 -> pure Word32Rep
#endif
926
#endif
927 928
          _  -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag"

Alec Theriault's avatar
Alec Theriault committed
929
-- | @since 0.8.5.0
930 931 932 933 934 935 936 937 938
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

Alec Theriault's avatar
Alec Theriault committed
939
-- | @since 0.8.5.0
940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958
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"

Alec Theriault's avatar
Alec Theriault committed
959
-- | @since 0.8.5.0
960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047
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

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