b44001ddfecf9ef63f1a4477aea544b1a8bee91f
[packages/binary.git] / src / Data / Binary / Class.hs
1 {-# LANGUAGE CPP, FlexibleContexts #-}
2 {-# LANGUAGE DefaultSignatures #-}
3 {-# LANGUAGE GADTs #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE PatternGuards #-}
6 {-# LANGUAGE Trustworthy #-}
7
8 #if __GLASGOW_HASKELL__ >= 706
9 {-# LANGUAGE PolyKinds #-}
10 #endif
11
12 #if MIN_VERSION_base(4,8,0)
13 #define HAS_NATURAL
14 #define HAS_VOID
15 #endif
16
17 #if MIN_VERSION_base(4,7,0)
18 #define HAS_FIXED_CONSTRUCTOR
19 #endif
20
21 -----------------------------------------------------------------------------
22 -- |
23 -- Module : Data.Binary.Class
24 -- Copyright : Lennart Kolmodin
25 -- License : BSD3-style (see LICENSE)
26 --
27 -- Maintainer : Lennart Kolmodin <kolmodin@gmail.com>
28 -- Stability : unstable
29 -- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances
30 --
31 -- Typeclass and instances for binary serialization.
32 --
33 -----------------------------------------------------------------------------
34
35 module Data.Binary.Class (
36
37 -- * The Binary class
38 Binary(..)
39
40 -- * Support for generics
41 , GBinaryGet(..)
42 , GBinaryPut(..)
43
44 ) where
45
46 import Data.Word
47 import Data.Bits
48 import Data.Int
49 import Data.Complex (Complex(..))
50 #ifdef HAS_VOID
51 import Data.Void
52 #endif
53
54 import Data.Binary.Put
55 import Data.Binary.Get
56
57 #if ! MIN_VERSION_base(4,8,0)
58 import Control.Applicative
59 import Data.Monoid (mempty)
60 #endif
61 import qualified Data.Monoid as Monoid
62 import Data.Monoid ((<>))
63 #if MIN_VERSION_base(4,8,0)
64 import Data.Functor.Identity (Identity (..))
65 #endif
66 #if MIN_VERSION_base(4,9,0)
67 import qualified Data.List.NonEmpty as NE
68 import qualified Data.Semigroup as Semigroup
69 #endif
70 import Control.Monad
71
72 import Data.ByteString.Lazy (ByteString)
73 import qualified Data.ByteString.Lazy as L
74 import qualified Data.ByteString.Builder.Prim as Prim
75
76 import Data.List (unfoldr, foldl')
77
78 -- And needed for the instances:
79 #if MIN_VERSION_base(4,10,0)
80 import Type.Reflection
81 import Type.Reflection.Unsafe
82 import Data.Kind (Type)
83 import GHC.Exts (RuntimeRep(..), VecCount, VecElem)
84 #endif
85 import qualified Data.ByteString as B
86 #if MIN_VERSION_bytestring(0,10,4)
87 import qualified Data.ByteString.Short as BS
88 #endif
89 import qualified Data.Map as Map
90 import qualified Data.Set as Set
91 import qualified Data.IntMap as IntMap
92 import qualified Data.IntSet as IntSet
93 import qualified Data.Ratio as R
94
95 import qualified Data.Tree as T
96
97 import Data.Array.Unboxed
98
99 import GHC.Generics
100
101 #ifdef HAS_NATURAL
102 import Numeric.Natural
103 #endif
104
105 import qualified Data.Fixed as Fixed
106
107 --
108 -- This isn't available in older Hugs or older GHC
109 --
110 import qualified Data.Sequence as Seq
111 import qualified Data.Foldable as Fold
112
113 import GHC.Fingerprint
114
115 import Data.Version (Version(..))
116
117 ------------------------------------------------------------------------
118
119 -- Factored into two classes because this makes GHC optimize the
120 -- instances faster. This doesn't matter for builds of binary,
121 -- but it matters a lot for end-users who write 'instance Binary T'.
122 -- See also: https://ghc.haskell.org/trac/ghc/ticket/9630
123 class GBinaryPut f where
124 gput :: f t -> Put
125
126 class GBinaryGet f where
127 gget :: Get (f t)
128
129 -- | The 'Binary' class provides 'put' and 'get', methods to encode and
130 -- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and
131 -- 'Show' classes for textual representation of Haskell types, and is
132 -- suitable for serialising Haskell values to disk, over the network.
133 --
134 -- For decoding and generating simple external binary formats (e.g. C
135 -- structures), Binary may be used, but in general is not suitable
136 -- for complex protocols. Instead use the 'Put' and 'Get' primitives
137 -- directly.
138 --
139 -- Instances of Binary should satisfy the following property:
140 --
141 -- > decode . encode == id
142 --
143 -- That is, the 'get' and 'put' methods should be the inverse of each
144 -- other. A range of instances are provided for basic Haskell types.
145 --
146 class Binary t where
147 -- | Encode a value in the Put monad.
148 put :: t -> Put
149 -- | Decode a value in the Get monad
150 get :: Get t
151
152 -- | Encode a list of values in the Put monad.
153 -- The default implementation may be overridden to be more efficient
154 -- but must still have the same encoding format.
155 putList :: [t] -> Put
156 putList = defaultPutList
157
158 default put :: (Generic t, GBinaryPut (Rep t)) => t -> Put
159 put = gput . from
160
161 default get :: (Generic t, GBinaryGet (Rep t)) => Get t
162 get = to `fmap` gget
163
164 {-# INLINE defaultPutList #-}
165 defaultPutList :: Binary a => [a] -> Put
166 defaultPutList xs = put (length xs) <> mapM_ put xs
167
168 ------------------------------------------------------------------------
169 -- Simple instances
170
171 #ifdef HAS_VOID
172 -- Void never gets written nor reconstructed since it's impossible to have a
173 -- value of that type
174
175 -- | /Since: 0.8.0.0/
176 instance Binary Void where
177 put = absurd
178 get = mzero
179 #endif
180
181 -- The () type need never be written to disk: values of singleton type
182 -- can be reconstructed from the type alone
183 instance Binary () where
184 put () = mempty
185 get = return ()
186
187 -- Bools are encoded as a byte in the range 0 .. 1
188 instance Binary Bool where
189 put = putWord8 . fromIntegral . fromEnum
190 get = getWord8 >>= toBool
191 where
192 toBool 0 = return False
193 toBool 1 = return True
194 toBool c = fail ("Could not map value " ++ show c ++ " to Bool")
195
196 -- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
197 instance Binary Ordering where
198 put = putWord8 . fromIntegral . fromEnum
199 get = getWord8 >>= toOrd
200 where
201 toOrd 0 = return LT
202 toOrd 1 = return EQ
203 toOrd 2 = return GT
204 toOrd c = fail ("Could not map value " ++ show c ++ " to Ordering")
205
206 ------------------------------------------------------------------------
207 -- Words and Ints
208
209 -- Words8s are written as bytes
210 instance Binary Word8 where
211 put = putWord8
212 {-# INLINE putList #-}
213 putList xs =
214 put (length xs)
215 <> putBuilder (Prim.primMapListFixed Prim.word8 xs)
216 get = getWord8
217
218 -- Words16s are written as 2 bytes in big-endian (network) order
219 instance Binary Word16 where
220 put = putWord16be
221 {-# INLINE putList #-}
222 putList xs =
223 put (length xs)
224 <> putBuilder (Prim.primMapListFixed Prim.word16BE xs)
225 get = getWord16be
226
227 -- Words32s are written as 4 bytes in big-endian (network) order
228 instance Binary Word32 where
229 put = putWord32be
230 {-# INLINE putList #-}
231 putList xs =
232 put (length xs)
233 <> putBuilder (Prim.primMapListFixed Prim.word32BE xs)
234 get = getWord32be
235
236 -- Words64s are written as 8 bytes in big-endian (network) order
237 instance Binary Word64 where
238 put = putWord64be
239 {-# INLINE putList #-}
240 putList xs =
241 put (length xs)
242 <> putBuilder (Prim.primMapListFixed Prim.word64BE xs)
243 get = getWord64be
244
245 -- Int8s are written as a single byte.
246 instance Binary Int8 where
247 put = putInt8
248 {-# INLINE putList #-}
249 putList xs =
250 put (length xs)
251 <> putBuilder (Prim.primMapListFixed Prim.int8 xs)
252 get = getInt8
253
254 -- Int16s are written as a 2 bytes in big endian format
255 instance Binary Int16 where
256 put = putInt16be
257 {-# INLINE putList #-}
258 putList xs =
259 put (length xs)
260 <> putBuilder (Prim.primMapListFixed Prim.int16BE xs)
261 get = getInt16be
262
263 -- Int32s are written as a 4 bytes in big endian format
264 instance Binary Int32 where
265 put = putInt32be
266 {-# INLINE putList #-}
267 putList xs =
268 put (length xs)
269 <> putBuilder (Prim.primMapListFixed Prim.int32BE xs)
270 get = getInt32be
271
272 -- Int64s are written as a 8 bytes in big endian format
273 instance Binary Int64 where
274 put = putInt64be
275 {-# INLINE putList #-}
276 putList xs =
277 put (length xs)
278 <> putBuilder (Prim.primMapListFixed Prim.int64BE xs)
279 get = getInt64be
280
281 ------------------------------------------------------------------------
282
283 -- Words are are written as Word64s, that is, 8 bytes in big endian format
284 instance Binary Word where
285 put = putWord64be . fromIntegral
286 {-# INLINE putList #-}
287 putList xs =
288 put (length xs)
289 <> putBuilder (Prim.primMapListFixed Prim.word64BE (map fromIntegral xs))
290 get = liftM fromIntegral getWord64be
291
292 -- Ints are are written as Int64s, that is, 8 bytes in big endian format
293 instance Binary Int where
294 put = putInt64be . fromIntegral
295 {-# INLINE putList #-}
296 putList xs =
297 put (length xs)
298 <> putBuilder (Prim.primMapListFixed Prim.int64BE (map fromIntegral xs))
299 get = liftM fromIntegral getInt64be
300
301 ------------------------------------------------------------------------
302 --
303 -- Portable, and pretty efficient, serialisation of Integer
304 --
305
306 -- Fixed-size type for a subset of Integer
307 type SmallInt = Int32
308
309 -- Integers are encoded in two ways: if they fit inside a SmallInt,
310 -- they're written as a byte tag, and that value. If the Integer value
311 -- is too large to fit in a SmallInt, it is written as a byte array,
312 -- along with a sign and length field.
313
314 instance Binary Integer where
315
316 {-# INLINE put #-}
317 put n | n >= lo && n <= hi =
318 putBuilder (Prim.primFixed (Prim.word8 Prim.>*< Prim.int32BE) (0, fromIntegral n))
319 where
320 lo = fromIntegral (minBound :: SmallInt) :: Integer
321 hi = fromIntegral (maxBound :: SmallInt) :: Integer
322
323 put n =
324 putWord8 1
325 <> put sign
326 <> put (unroll (abs n)) -- unroll the bytes
327 where
328 sign = fromIntegral (signum n) :: Word8
329
330 {-# INLINE get #-}
331 get = do
332 tag <- get :: Get Word8
333 case tag of
334 0 -> liftM fromIntegral (get :: Get SmallInt)
335 _ -> do sign <- get
336 bytes <- get
337 let v = roll bytes
338 return $! if sign == (1 :: Word8) then v else - v
339
340 -- | /Since: 0.8.0.0/
341 #ifdef HAS_FIXED_CONSTRUCTOR
342 instance Binary (Fixed.Fixed a) where
343 put (Fixed.MkFixed a) = put a
344 get = Fixed.MkFixed `liftM` get
345 #else
346 instance forall a. Fixed.HasResolution a => Binary (Fixed.Fixed a) where
347 -- Using undefined :: Maybe a as a proxy, as Data.Proxy is introduced only in base-4.7
348 put x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer)
349 get = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftM` get
350 #endif
351
352 --
353 -- Fold and unfold an Integer to and from a list of its bytes
354 --
355 unroll :: (Integral a, Bits a) => a -> [Word8]
356 unroll = unfoldr step
357 where
358 step 0 = Nothing
359 step i = Just (fromIntegral i, i `shiftR` 8)
360
361 roll :: (Integral a, Bits a) => [Word8] -> a
362 roll = foldl' unstep 0 . reverse
363 where
364 unstep a b = a `shiftL` 8 .|. fromIntegral b
365
366 #ifdef HAS_NATURAL
367 -- Fixed-size type for a subset of Natural
368 type NaturalWord = Word64
369
370 -- | /Since: 0.7.3.0/
371 instance Binary Natural where
372 {-# INLINE put #-}
373 put n | n <= hi =
374 putWord8 0
375 <> put (fromIntegral n :: NaturalWord) -- fast path
376 where
377 hi = fromIntegral (maxBound :: NaturalWord) :: Natural
378
379 put n =
380 putWord8 1
381 <> put (unroll (abs n)) -- unroll the bytes
382
383 {-# INLINE get #-}
384 get = do
385 tag <- get :: Get Word8
386 case tag of
387 0 -> liftM fromIntegral (get :: Get NaturalWord)
388 _ -> do bytes <- get
389 return $! roll bytes
390 #endif
391
392 {-
393
394 --
395 -- An efficient, raw serialisation for Integer (GHC only)
396 --
397
398 -- TODO This instance is not architecture portable. GMP stores numbers as
399 -- arrays of machine sized words, so the byte format is not portable across
400 -- architectures with different endianness and word size.
401
402 import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)
403 import GHC.Base hiding (ord, chr)
404 import GHC.Prim
405 import GHC.Ptr (Ptr(..))
406 import GHC.IOBase (IO(..))
407
408 instance Binary Integer where
409 put (S# i) = putWord8 0 >> put (I# i)
410 put (J# s ba) = do
411 putWord8 1
412 put (I# s)
413 put (BA ba)
414
415 get = do
416 b <- getWord8
417 case b of
418 0 -> do (I# i#) <- get
419 return (S# i#)
420 _ -> do (I# s#) <- get
421 (BA a#) <- get
422 return (J# s# a#)
423
424 instance Binary ByteArray where
425
426 -- Pretty safe.
427 put (BA ba) =
428 let sz = sizeofByteArray# ba -- (primitive) in *bytes*
429 addr = byteArrayContents# ba
430 bs = unsafePackAddress (I# sz) addr
431 in put bs -- write as a ByteString. easy, yay!
432
433 -- Pretty scary. Should be quick though
434 get = do
435 (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString
436 assert (off == 0) $ return $ unsafePerformIO $ do
437 (MBA arr) <- newByteArray sz -- and copy it into a ByteArray#
438 let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?
439 withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)
440 freezeByteArray arr
441
442 -- wrapper for ByteArray#
443 data ByteArray = BA {-# UNPACK #-} !ByteArray#
444 data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)
445
446 newByteArray :: Int# -> IO MBA
447 newByteArray sz = IO $ \s ->
448 case newPinnedByteArray# sz s of { (# s', arr #) ->
449 (# s', MBA arr #) }
450
451 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
452 freezeByteArray arr = IO $ \s ->
453 case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
454 (# s', BA arr' #) }
455
456 -}
457
458 instance (Binary a,Integral a) => Binary (R.Ratio a) where
459 put r = put (R.numerator r) <> put (R.denominator r)
460 get = liftM2 (R.%) get get
461
462 instance Binary a => Binary (Complex a) where
463 {-# INLINE put #-}
464 put (r :+ i) = put (r, i)
465 {-# INLINE get #-}
466 get = (\(r,i) -> r :+ i) <$> get
467
468 ------------------------------------------------------------------------
469
470 -- Char is serialised as UTF-8
471 instance Binary Char where
472 put = putCharUtf8
473 putList str = put (length str) <> putStringUtf8 str
474 get = do
475 let getByte = liftM (fromIntegral :: Word8 -> Int) get
476 shiftL6 = flip shiftL 6 :: Int -> Int
477 w <- getByte
478 r <- case () of
479 _ | w < 0x80 -> return w
480 | w < 0xe0 -> do
481 x <- liftM (xor 0x80) getByte
482 return (x .|. shiftL6 (xor 0xc0 w))
483 | w < 0xf0 -> do
484 x <- liftM (xor 0x80) getByte
485 y <- liftM (xor 0x80) getByte
486 return (y .|. shiftL6 (x .|. shiftL6
487 (xor 0xe0 w)))
488 | otherwise -> do
489 x <- liftM (xor 0x80) getByte
490 y <- liftM (xor 0x80) getByte
491 z <- liftM (xor 0x80) getByte
492 return (z .|. shiftL6 (y .|. shiftL6
493 (x .|. shiftL6 (xor 0xf0 w))))
494 getChr r
495 where
496 getChr w
497 | w <= 0x10ffff = return $! toEnum $ fromEnum w
498 | otherwise = fail "Not a valid Unicode code point!"
499
500 ------------------------------------------------------------------------
501 -- Instances for the first few tuples
502
503 instance (Binary a, Binary b) => Binary (a,b) where
504 {-# INLINE put #-}
505 put (a,b) = put a <> put b
506 {-# INLINE get #-}
507 get = liftM2 (,) get get
508
509 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
510 {-# INLINE put #-}
511 put (a,b,c) = put a <> put b <> put c
512 {-# INLINE get #-}
513 get = liftM3 (,,) get get get
514
515 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
516 {-# INLINE put #-}
517 put (a,b,c,d) = put a <> put b <> put c <> put d
518 {-# INLINE get #-}
519 get = liftM4 (,,,) get get get get
520
521 instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
522 {-# INLINE put #-}
523 put (a,b,c,d,e) = put a <> put b <> put c <> put d <> put e
524 {-# INLINE get #-}
525 get = liftM5 (,,,,) get get get get get
526
527 --
528 -- and now just recurse:
529 --
530
531 instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)
532 => Binary (a,b,c,d,e,f) where
533 {-# INLINE put #-}
534 put (a,b,c,d,e,f) = put (a,(b,c,d,e,f))
535 {-# INLINE get #-}
536 get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)
537
538 instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)
539 => Binary (a,b,c,d,e,f,g) where
540 {-# INLINE put #-}
541 put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))
542 {-# INLINE get #-}
543 get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)
544
545 instance (Binary a, Binary b, Binary c, Binary d, Binary e,
546 Binary f, Binary g, Binary h)
547 => Binary (a,b,c,d,e,f,g,h) where
548 {-# INLINE put #-}
549 put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))
550 {-# INLINE get #-}
551 get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)
552
553 instance (Binary a, Binary b, Binary c, Binary d, Binary e,
554 Binary f, Binary g, Binary h, Binary i)
555 => Binary (a,b,c,d,e,f,g,h,i) where
556 {-# INLINE put #-}
557 put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))
558 {-# INLINE get #-}
559 get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)
560
561 instance (Binary a, Binary b, Binary c, Binary d, Binary e,
562 Binary f, Binary g, Binary h, Binary i, Binary j)
563 => Binary (a,b,c,d,e,f,g,h,i,j) where
564 {-# INLINE put #-}
565 put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))
566 {-# INLINE get #-}
567 get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)
568
569 ------------------------------------------------------------------------
570 -- Container types
571
572 #if MIN_VERSION_base(4,8,0)
573 instance Binary a => Binary (Identity a) where
574 put (Identity x) = put x
575 get = Identity <$> get
576 #endif
577
578 instance Binary a => Binary [a] where
579 put = putList
580 get = do n <- get :: Get Int
581 getMany n
582
583 -- | 'getMany n' get 'n' elements in order, without blowing the stack.
584 getMany :: Binary a => Int -> Get [a]
585 getMany n = go [] n
586 where
587 go xs 0 = return $! reverse xs
588 go xs i = do x <- get
589 -- we must seq x to avoid stack overflows due to laziness in
590 -- (>>=)
591 x `seq` go (x:xs) (i-1)
592 {-# INLINE getMany #-}
593
594 instance (Binary a) => Binary (Maybe a) where
595 put Nothing = putWord8 0
596 put (Just x) = putWord8 1 <> put x
597 get = do
598 w <- getWord8
599 case w of
600 0 -> return Nothing
601 _ -> liftM Just get
602
603 instance (Binary a, Binary b) => Binary (Either a b) where
604 put (Left a) = putWord8 0 <> put a
605 put (Right b) = putWord8 1 <> put b
606 get = do
607 w <- getWord8
608 case w of
609 0 -> liftM Left get
610 _ -> liftM Right get
611
612 ------------------------------------------------------------------------
613 -- ByteStrings (have specially efficient instances)
614
615 instance Binary B.ByteString where
616 put bs = put (B.length bs)
617 <> putByteString bs
618 get = get >>= getByteString
619
620 --
621 -- Using old versions of fps, this is a type synonym, and non portable
622 --
623 -- Requires 'flexible instances'
624 --
625 instance Binary ByteString where
626 put bs = put (fromIntegral (L.length bs) :: Int)
627 <> putLazyByteString bs
628 get = get >>= getLazyByteString
629
630
631 #if MIN_VERSION_bytestring(0,10,4)
632 instance Binary BS.ShortByteString where
633 put bs = put (BS.length bs)
634 <> putShortByteString bs
635 get = get >>= fmap BS.toShort . getByteString
636 #endif
637
638 ------------------------------------------------------------------------
639 -- Maps and Sets
640
641 instance (Binary a) => Binary (Set.Set a) where
642 put s = put (Set.size s) <> mapM_ put (Set.toAscList s)
643 get = liftM Set.fromDistinctAscList get
644
645 instance (Binary k, Binary e) => Binary (Map.Map k e) where
646 put m = put (Map.size m) <> mapM_ put (Map.toAscList m)
647 get = liftM Map.fromDistinctAscList get
648
649 instance Binary IntSet.IntSet where
650 put s = put (IntSet.size s) <> mapM_ put (IntSet.toAscList s)
651 get = liftM IntSet.fromDistinctAscList get
652
653 instance (Binary e) => Binary (IntMap.IntMap e) where
654 put m = put (IntMap.size m) <> mapM_ put (IntMap.toAscList m)
655 get = liftM IntMap.fromDistinctAscList get
656
657 ------------------------------------------------------------------------
658 -- Queues and Sequences
659
660 --
661 -- This is valid Hugs, but you need the most recent Hugs
662 --
663
664 instance (Binary e) => Binary (Seq.Seq e) where
665 put s = put (Seq.length s) <> Fold.mapM_ put s
666 get = do n <- get :: Get Int
667 rep Seq.empty n get
668 where rep xs 0 _ = return $! xs
669 rep xs n g = xs `seq` n `seq` do
670 x <- g
671 rep (xs Seq.|> x) (n-1) g
672
673 ------------------------------------------------------------------------
674 -- Floating point
675
676 instance Binary Double where
677 put d = put (decodeFloat d)
678 get = do
679 x <- get
680 y <- get
681 return $! encodeFloat x y
682
683 instance Binary Float where
684 put f = put (decodeFloat f)
685 get = do
686 x <- get
687 y <- get
688 return $! encodeFloat x y
689
690 ------------------------------------------------------------------------
691 -- Trees
692
693 instance (Binary e) => Binary (T.Tree e) where
694 put (T.Node r s) = put r <> put s
695 get = liftM2 T.Node get get
696
697 ------------------------------------------------------------------------
698 -- Arrays
699
700 instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
701 put a =
702 put (bounds a)
703 <> put (rangeSize $ bounds a) -- write the length
704 <> mapM_ put (elems a) -- now the elems.
705 get = do
706 bs <- get
707 n <- get -- read the length
708 xs <- getMany n -- now the elems.
709 return (listArray bs xs)
710
711 --
712 -- The IArray UArray e constraint is non portable. Requires flexible instances
713 --
714 instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
715 put a =
716 put (bounds a)
717 <> put (rangeSize $ bounds a) -- now write the length
718 <> mapM_ put (elems a)
719 get = do
720 bs <- get
721 n <- get
722 xs <- getMany n
723 return (listArray bs xs)
724
725 ------------------------------------------------------------------------
726 -- Fingerprints
727
728 -- | /Since: 0.7.6.0/
729 instance Binary Fingerprint where
730 put (Fingerprint x1 x2) = put x1 <> put x2
731 get = do
732 x1 <- get
733 x2 <- get
734 return $! Fingerprint x1 x2
735
736 ------------------------------------------------------------------------
737 -- Version
738
739 -- | /Since: 0.8.0.0/
740 instance Binary Version where
741 put (Version br tags) = put br <> put tags
742 get = Version <$> get <*> get
743
744 ------------------------------------------------------------------------
745 -- Data.Monoid datatypes
746
747 -- | /Since: 0.8.4.0/
748 instance Binary a => Binary (Monoid.Dual a) where
749 get = fmap Monoid.Dual get
750 put = put . Monoid.getDual
751
752 -- | /Since: 0.8.4.0/
753 instance Binary Monoid.All where
754 get = fmap Monoid.All get
755 put = put . Monoid.getAll
756
757 -- | /Since: 0.8.4.0/
758 instance Binary Monoid.Any where
759 get = fmap Monoid.Any get
760 put = put . Monoid.getAny
761
762 -- | /Since: 0.8.4.0/
763 instance Binary a => Binary (Monoid.Sum a) where
764 get = fmap Monoid.Sum get
765 put = put . Monoid.getSum
766
767 -- | /Since: 0.8.4.0/
768 instance Binary a => Binary (Monoid.Product a) where
769 get = fmap Monoid.Product get
770 put = put . Monoid.getProduct
771
772 -- | /Since: 0.8.4.0/
773 instance Binary a => Binary (Monoid.First a) where
774 get = fmap Monoid.First get
775 put = put . Monoid.getFirst
776
777 -- | /Since: 0.8.4.0/
778 instance Binary a => Binary (Monoid.Last a) where
779 get = fmap Monoid.Last get
780 put = put . Monoid.getLast
781
782 #if MIN_VERSION_base(4,8,0)
783 -- | /Since: 0.8.4.0/
784 instance Binary (f a) => Binary (Monoid.Alt f a) where
785 get = fmap Monoid.Alt get
786 put = put . Monoid.getAlt
787 #endif
788
789 #if MIN_VERSION_base(4,9,0)
790 ------------------------------------------------------------------------
791 -- Data.Semigroup datatypes
792
793 -- | /Since: 0.8.4.0/
794 instance Binary a => Binary (Semigroup.Min a) where
795 get = fmap Semigroup.Min get
796 put = put . Semigroup.getMin
797
798 -- | /Since: 0.8.4.0/
799 instance Binary a => Binary (Semigroup.Max a) where
800 get = fmap Semigroup.Max get
801 put = put . Semigroup.getMax
802
803 -- | /Since: 0.8.4.0/
804 instance Binary a => Binary (Semigroup.First a) where
805 get = fmap Semigroup.First get
806 put = put . Semigroup.getFirst
807
808 -- | /Since: 0.8.4.0/
809 instance Binary a => Binary (Semigroup.Last a) where
810 get = fmap Semigroup.Last get
811 put = put . Semigroup.getLast
812
813 -- | /Since: 0.8.4.0/
814 instance Binary a => Binary (Semigroup.Option a) where
815 get = fmap Semigroup.Option get
816 put = put . Semigroup.getOption
817
818 -- | /Since: 0.8.4.0/
819 instance Binary m => Binary (Semigroup.WrappedMonoid m) where
820 get = fmap Semigroup.WrapMonoid get
821 put = put . Semigroup.unwrapMonoid
822
823 -- | /Since: 0.8.4.0/
824 instance (Binary a, Binary b) => Binary (Semigroup.Arg a b) where
825 get = liftM2 Semigroup.Arg get get
826 put (Semigroup.Arg a b) = put a <> put b
827
828 ------------------------------------------------------------------------
829 -- Non-empty lists
830
831 -- | /Since: 0.8.4.0/
832 instance Binary a => Binary (NE.NonEmpty a) where
833 get = fmap NE.fromList get
834 put = put . NE.toList
835 #endif
836
837 ------------------------------------------------------------------------
838 -- Typeable/Reflection
839
840 #if MIN_VERSION_base(4,10,0)
841
842 -- $typeable-instances
843 --
844 -- 'Binary' instances for GHC's "Type.Reflection", "Data.Typeable", and
845 -- kind-system primitives are only provided with @base-4.10.0@ (shipped with GHC
846 -- 8.2.1). In prior GHC releases some of these instances were provided by
847 -- 'GHCi.TH.Binary' in the @ghci@ package.
848 --
849 -- These include instances for,
850 --
851 -- * 'VecCount'
852 -- * 'VecElem'
853 -- * 'RuntimeRep'
854 -- * 'KindRep'
855 -- * 'TypeLitSort'
856 -- * 'TyCon'
857 -- * 'TypeRep'
858 -- * 'SomeTypeRep' (also known as 'Data.Typeable.TypeRep')
859 --
860
861 -- | @since 0.8.5.0. See #typeable-instances#
862 instance Binary VecCount where
863 put = putWord8 . fromIntegral . fromEnum
864 get = toEnum . fromIntegral <$> getWord8
865
866 -- | @since 0.8.5.0. See #typeable-instances#
867 instance Binary VecElem where
868 put = putWord8 . fromIntegral . fromEnum
869 get = toEnum . fromIntegral <$> getWord8
870
871 -- | @since 0.8.5.0. See #typeable-instances#
872 instance Binary RuntimeRep where
873 put (VecRep a b) = putWord8 0 >> put a >> put b
874 put (TupleRep reps) = putWord8 1 >> put reps
875 put (SumRep reps) = putWord8 2 >> put reps
876 put LiftedRep = putWord8 3
877 put UnliftedRep = putWord8 4
878 put IntRep = putWord8 5
879 put WordRep = putWord8 6
880 put Int64Rep = putWord8 7
881 put Word64Rep = putWord8 8
882 put AddrRep = putWord8 9
883 put FloatRep = putWord8 10
884 put DoubleRep = putWord8 11
885 #if __GLASGOW_HASKELL__ >= 807
886 put Int8Rep = putWord8 12
887 put Word8Rep = putWord8 13
888 #endif
889
890 get = do
891 tag <- getWord8
892 case tag of
893 0 -> VecRep <$> get <*> get
894 1 -> TupleRep <$> get
895 2 -> SumRep <$> get
896 3 -> pure LiftedRep
897 4 -> pure UnliftedRep
898 5 -> pure IntRep
899 6 -> pure WordRep
900 7 -> pure Int64Rep
901 8 -> pure Word64Rep
902 9 -> pure AddrRep
903 10 -> pure FloatRep
904 11 -> pure DoubleRep
905 #if __GLASGOW_HASKELL__ >= 807
906 12 -> pure Int8Rep
907 13 -> pure Word8Rep
908 #endif
909 _ -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag"
910
911 -- | @since 0.8.5.0. See #typeable-instances#
912 instance Binary TyCon where
913 put tc = do
914 put (tyConPackage tc)
915 put (tyConModule tc)
916 put (tyConName tc)
917 put (tyConKindArgs tc)
918 put (tyConKindRep tc)
919 get = mkTyCon <$> get <*> get <*> get <*> get <*> get
920
921 -- | @since 0.8.5.0. See #typeable-instances#
922 instance Binary KindRep where
923 put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k
924 put (KindRepVar bndr) = putWord8 1 >> put bndr
925 put (KindRepApp a b) = putWord8 2 >> put a >> put b
926 put (KindRepFun a b) = putWord8 3 >> put a >> put b
927 put (KindRepTYPE r) = putWord8 4 >> put r
928 put (KindRepTypeLit sort r) = putWord8 5 >> put sort >> put r
929
930 get = do
931 tag <- getWord8
932 case tag of
933 0 -> KindRepTyConApp <$> get <*> get
934 1 -> KindRepVar <$> get
935 2 -> KindRepApp <$> get <*> get
936 3 -> KindRepFun <$> get <*> get
937 4 -> KindRepTYPE <$> get
938 5 -> KindRepTypeLit <$> get <*> get
939 _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag"
940
941 -- | @since 0.8.5.0. See #typeable-instances#
942 instance Binary TypeLitSort where
943 put TypeLitSymbol = putWord8 0
944 put TypeLitNat = putWord8 1
945 get = do
946 tag <- getWord8
947 case tag of
948 0 -> pure TypeLitSymbol
949 1 -> pure TypeLitNat
950 _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag"
951
952 putTypeRep :: TypeRep a -> Put
953 -- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
954 -- relations.
955 -- See Note [Mutually recursive representations of primitive types]
956 putTypeRep rep -- Handle Type specially since it's so common
957 | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
958 = put (0 :: Word8)
959 putTypeRep (Con' con ks) = do
960 put (1 :: Word8)
961 put con
962 put ks
963 putTypeRep (App f x) = do
964 put (2 :: Word8)
965 putTypeRep f
966 putTypeRep x
967 putTypeRep (Fun arg res) = do
968 put (3 :: Word8)
969 putTypeRep arg
970 putTypeRep res
971 putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible"
972
973 getSomeTypeRep :: Get SomeTypeRep
974 getSomeTypeRep = do
975 tag <- get :: Get Word8
976 case tag of
977 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
978 1 -> do con <- get :: Get TyCon
979 ks <- get :: Get [SomeTypeRep]
980 return $ SomeTypeRep $ mkTrCon con ks
981 2 -> do SomeTypeRep f <- getSomeTypeRep
982 SomeTypeRep x <- getSomeTypeRep
983 case typeRepKind f of
984 Fun arg res ->
985 case arg `eqTypeRep` typeRepKind x of
986 Just HRefl -> do
987 case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
988 Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
989 _ -> failure "Kind mismatch" []
990 _ -> failure "Kind mismatch"
991 [ "Found argument of kind: " ++ show (typeRepKind x)
992 , "Where the constructor: " ++ show f
993 , "Expects an argument of kind: " ++ show arg
994 ]
995 _ -> failure "Applied non-arrow type"
996 [ "Applied type: " ++ show f
997 , "To argument: " ++ show x
998 ]
999 3 -> do SomeTypeRep arg <- getSomeTypeRep
1000 SomeTypeRep res <- getSomeTypeRep
1001 case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of
1002 Just HRefl ->
1003 case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
1004 Just HRefl -> return $ SomeTypeRep $ Fun arg res
1005 Nothing -> failure "Kind mismatch" []
1006 Nothing -> failure "Kind mismatch" []
1007 _ -> failure "Invalid SomeTypeRep" []
1008 where
1009 failure description info =
1010 fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ]
1011 ++ map (" "++) info
1012
1013 instance Typeable a => Binary (TypeRep (a :: k)) where
1014 put = putTypeRep
1015 get = do
1016 SomeTypeRep rep <- getSomeTypeRep
1017 case rep `eqTypeRep` expected of
1018 Just HRefl -> pure rep
1019 Nothing -> fail $ unlines
1020 [ "GHCi.TH.Binary: Type mismatch"
1021 , " Deserialized type: " ++ show rep
1022 , " Expected type: " ++ show expected
1023 ]
1024 where expected = typeRep :: TypeRep a
1025
1026 instance Binary SomeTypeRep where
1027 put (SomeTypeRep rep) = putTypeRep rep
1028 get = getSomeTypeRep
1029 #endif
1030