never executed always true always false
1
2 {-# LANGUAGE CPP #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE PolyKinds #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE GADTs #-}
7 {-# LANGUAGE BangPatterns #-}
8 {-# LANGUAGE StandaloneDeriving #-}
9 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
10 {-# LANGUAGE UnboxedTuples #-}
11
12 {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
13 #if MIN_VERSION_base(4,16,0)
14 #define HAS_TYPELITCHAR
15 #endif
16 -- We always optimise this, otherwise performance of a non-optimised
17 -- compiler is severely affected
18
19 --
20 -- (c) The University of Glasgow 2002-2006
21 --
22 -- Binary I/O library, with special tweaks for GHC
23 --
24 -- Based on the nhc98 Binary library, which is copyright
25 -- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
26 -- Under the terms of the license for that software, we must tell you
27 -- where you can obtain the original version of the Binary library, namely
28 -- http://www.cs.york.ac.uk/fp/nhc98/
29
30 module GHC.Utils.Binary
31 ( {-type-} Bin,
32 {-class-} Binary(..),
33 {-type-} BinHandle,
34 SymbolTable, Dictionary,
35
36 BinData(..), dataHandle, handleData,
37
38 openBinMem,
39 -- closeBin,
40
41 seekBin,
42 tellBin,
43 castBin,
44 withBinBuffer,
45
46 foldGet,
47
48 writeBinMem,
49 readBinMem,
50
51 putAt, getAt,
52
53 -- * For writing instances
54 putByte,
55 getByte,
56
57 -- * Variable length encodings
58 putULEB128,
59 getULEB128,
60 putSLEB128,
61 getSLEB128,
62
63 -- * Fixed length encoding
64 FixedLengthEncoding(..),
65
66 -- * Lazy Binary I/O
67 lazyGet,
68 lazyPut,
69
70 -- * User data
71 UserData(..), getUserData, setUserData,
72 newReadState, newWriteState,
73 putDictionary, getDictionary, putFS,
74 ) where
75
76 import GHC.Prelude
77
78 import {-# SOURCE #-} GHC.Types.Name (Name)
79 import GHC.Data.FastString
80 import GHC.Utils.Panic.Plain
81 import GHC.Types.Unique.FM
82 import GHC.Data.FastMutInt
83 import GHC.Utils.Fingerprint
84 import GHC.Types.SrcLoc
85 import qualified GHC.Data.Strict as Strict
86
87 import Control.DeepSeq
88 import Foreign hiding (shiftL, shiftR)
89 import Data.Array
90 import Data.Array.IO
91 import Data.Array.Unsafe
92 import Data.ByteString (ByteString)
93 import qualified Data.ByteString.Internal as BS
94 import qualified Data.ByteString.Unsafe as BS
95 import Data.IORef
96 import Data.Char ( ord, chr )
97 import Data.Time
98 import Data.List (unfoldr)
99 import Data.Set (Set)
100 import qualified Data.Set as Set
101 import Control.Monad ( when, (<$!>), unless, forM_ )
102 import System.IO as IO
103 import System.IO.Unsafe ( unsafeInterleaveIO )
104 import System.IO.Error ( mkIOError, eofErrorType )
105 import GHC.Real ( Ratio(..) )
106 #if MIN_VERSION_base(4,15,0)
107 import GHC.ForeignPtr ( unsafeWithForeignPtr )
108 #endif
109
110 type BinArray = ForeignPtr Word8
111
112 #if !MIN_VERSION_base(4,15,0)
113 unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
114 unsafeWithForeignPtr = withForeignPtr
115 #endif
116
117 ---------------------------------------------------------------
118 -- BinData
119 ---------------------------------------------------------------
120
121 data BinData = BinData Int BinArray
122
123 instance NFData BinData where
124 rnf (BinData sz _) = rnf sz
125
126 instance Binary BinData where
127 put_ bh (BinData sz dat) = do
128 put_ bh sz
129 putPrim bh sz $ \dest ->
130 unsafeWithForeignPtr dat $ \orig ->
131 copyBytes dest orig sz
132 --
133 get bh = do
134 sz <- get bh
135 dat <- mallocForeignPtrBytes sz
136 getPrim bh sz $ \orig ->
137 unsafeWithForeignPtr dat $ \dest ->
138 copyBytes dest orig sz
139 return (BinData sz dat)
140
141 dataHandle :: BinData -> IO BinHandle
142 dataHandle (BinData size bin) = do
143 ixr <- newFastMutInt 0
144 szr <- newFastMutInt size
145 binr <- newIORef bin
146 return (BinMem noUserData ixr szr binr)
147
148 handleData :: BinHandle -> IO BinData
149 handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
150
151 ---------------------------------------------------------------
152 -- BinHandle
153 ---------------------------------------------------------------
154
155 data BinHandle
156 = BinMem { -- binary data stored in an unboxed array
157 bh_usr :: UserData, -- sigh, need parameterized modules :-)
158 _off_r :: !FastMutInt, -- the current offset
159 _sz_r :: !FastMutInt, -- size of the array (cached)
160 _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
161 }
162 -- XXX: should really store a "high water mark" for dumping out
163 -- the binary data to a file.
164
165 getUserData :: BinHandle -> UserData
166 getUserData bh = bh_usr bh
167
168 setUserData :: BinHandle -> UserData -> BinHandle
169 setUserData bh us = bh { bh_usr = us }
170
171 -- | Get access to the underlying buffer.
172 --
173 -- It is quite important that no references to the 'ByteString' leak out of the
174 -- continuation lest terrible things happen.
175 withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a
176 withBinBuffer (BinMem _ ix_r _ arr_r) action = do
177 arr <- readIORef arr_r
178 ix <- readFastMutInt ix_r
179 withForeignPtr arr $ \ptr ->
180 BS.unsafePackCStringLen (castPtr ptr, ix) >>= action
181
182
183 ---------------------------------------------------------------
184 -- Bin
185 ---------------------------------------------------------------
186
187 newtype Bin a = BinPtr Int
188 deriving (Eq, Ord, Show, Bounded)
189
190 castBin :: Bin a -> Bin b
191 castBin (BinPtr i) = BinPtr i
192
193 ---------------------------------------------------------------
194 -- class Binary
195 ---------------------------------------------------------------
196
197 -- | Do not rely on instance sizes for general types,
198 -- we use variable length encoding for many of them.
199 class Binary a where
200 put_ :: BinHandle -> a -> IO ()
201 put :: BinHandle -> a -> IO (Bin a)
202 get :: BinHandle -> IO a
203
204 -- define one of put_, put. Use of put_ is recommended because it
205 -- is more likely that tail-calls can kick in, and we rarely need the
206 -- position return value.
207 put_ bh a = do _ <- put bh a; return ()
208 put bh a = do p <- tellBin bh; put_ bh a; return p
209
210 putAt :: Binary a => BinHandle -> Bin a -> a -> IO ()
211 putAt bh p x = do seekBin bh p; put_ bh x; return ()
212
213 getAt :: Binary a => BinHandle -> Bin a -> IO a
214 getAt bh p = do seekBin bh p; get bh
215
216 openBinMem :: Int -> IO BinHandle
217 openBinMem size
218 | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
219 | otherwise = do
220 arr <- mallocForeignPtrBytes size
221 arr_r <- newIORef arr
222 ix_r <- newFastMutInt 0
223 sz_r <- newFastMutInt size
224 return (BinMem noUserData ix_r sz_r arr_r)
225
226 tellBin :: BinHandle -> IO (Bin a)
227 tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
228
229 seekBin :: BinHandle -> Bin a -> IO ()
230 seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do
231 sz <- readFastMutInt sz_r
232 if (p >= sz)
233 then do expandBin h p; writeFastMutInt ix_r p
234 else writeFastMutInt ix_r p
235
236 writeBinMem :: BinHandle -> FilePath -> IO ()
237 writeBinMem (BinMem _ ix_r _ arr_r) fn = do
238 h <- openBinaryFile fn WriteMode
239 arr <- readIORef arr_r
240 ix <- readFastMutInt ix_r
241 unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix
242 hClose h
243
244 readBinMem :: FilePath -> IO BinHandle
245 -- Return a BinHandle with a totally undefined State
246 readBinMem filename = do
247 h <- openBinaryFile filename ReadMode
248 filesize' <- hFileSize h
249 let filesize = fromIntegral filesize'
250 arr <- mallocForeignPtrBytes filesize
251 count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize
252 when (count /= filesize) $
253 error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
254 hClose h
255 arr_r <- newIORef arr
256 ix_r <- newFastMutInt 0
257 sz_r <- newFastMutInt filesize
258 return (BinMem noUserData ix_r sz_r arr_r)
259
260 -- expand the size of the array to include a specified offset
261 expandBin :: BinHandle -> Int -> IO ()
262 expandBin (BinMem _ _ sz_r arr_r) !off = do
263 !sz <- readFastMutInt sz_r
264 let !sz' = getSize sz
265 arr <- readIORef arr_r
266 arr' <- mallocForeignPtrBytes sz'
267 withForeignPtr arr $ \old ->
268 withForeignPtr arr' $ \new ->
269 copyBytes new old sz
270 writeFastMutInt sz_r sz'
271 writeIORef arr_r arr'
272 where
273 getSize :: Int -> Int
274 getSize !sz
275 | sz > off
276 = sz
277 | otherwise
278 = getSize (sz * 2)
279
280 foldGet
281 :: Binary a
282 => Word -- n elements
283 -> BinHandle
284 -> b -- initial accumulator
285 -> (Word -> a -> b -> IO b)
286 -> IO b
287 foldGet n bh init_b f = go 0 init_b
288 where
289 go i b
290 | i == n = return b
291 | otherwise = do
292 a <- get bh
293 b' <- f i a b
294 go (i+1) b'
295
296
297 -- -----------------------------------------------------------------------------
298 -- Low-level reading/writing of bytes
299
300 -- | Takes a size and action writing up to @size@ bytes.
301 -- After the action has run advance the index to the buffer
302 -- by size bytes.
303 putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
304 putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do
305 ix <- readFastMutInt ix_r
306 sz <- readFastMutInt sz_r
307 when (ix + size > sz) $
308 expandBin h (ix + size)
309 arr <- readIORef arr_r
310 unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix)
311 writeFastMutInt ix_r (ix + size)
312
313 -- -- | Similar to putPrim but advances the index by the actual number of
314 -- -- bytes written.
315 -- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO ()
316 -- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do
317 -- ix <- readFastMutInt ix_r
318 -- sz <- readFastMutInt sz_r
319 -- when (ix + size > sz) $
320 -- expandBin h (ix + size)
321 -- arr <- readIORef arr_r
322 -- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)
323 -- writeFastMutInt ix_r (ix + written)
324
325 getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
326 getPrim (BinMem _ ix_r sz_r arr_r) size f = do
327 ix <- readFastMutInt ix_r
328 sz <- readFastMutInt sz_r
329 when (ix + size > sz) $
330 ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)
331 arr <- readIORef arr_r
332 w <- unsafeWithForeignPtr arr $ \p -> f (p `plusPtr` ix)
333 -- This is safe WRT #17760 as we we guarantee that the above line doesn't
334 -- diverge
335 writeFastMutInt ix_r (ix + size)
336 return w
337
338 putWord8 :: BinHandle -> Word8 -> IO ()
339 putWord8 h !w = putPrim h 1 (\op -> poke op w)
340
341 getWord8 :: BinHandle -> IO Word8
342 getWord8 h = getPrim h 1 peek
343
344 putWord16 :: BinHandle -> Word16 -> IO ()
345 putWord16 h w = putPrim h 2 (\op -> do
346 pokeElemOff op 0 (fromIntegral (w `shiftR` 8))
347 pokeElemOff op 1 (fromIntegral (w .&. 0xFF))
348 )
349
350 getWord16 :: BinHandle -> IO Word16
351 getWord16 h = getPrim h 2 (\op -> do
352 w0 <- fromIntegral <$> peekElemOff op 0
353 w1 <- fromIntegral <$> peekElemOff op 1
354 return $! w0 `shiftL` 8 .|. w1
355 )
356
357 putWord32 :: BinHandle -> Word32 -> IO ()
358 putWord32 h w = putPrim h 4 (\op -> do
359 pokeElemOff op 0 (fromIntegral (w `shiftR` 24))
360 pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
361 pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF))
362 pokeElemOff op 3 (fromIntegral (w .&. 0xFF))
363 )
364
365 getWord32 :: BinHandle -> IO Word32
366 getWord32 h = getPrim h 4 (\op -> do
367 w0 <- fromIntegral <$> peekElemOff op 0
368 w1 <- fromIntegral <$> peekElemOff op 1
369 w2 <- fromIntegral <$> peekElemOff op 2
370 w3 <- fromIntegral <$> peekElemOff op 3
371
372 return $! (w0 `shiftL` 24) .|.
373 (w1 `shiftL` 16) .|.
374 (w2 `shiftL` 8) .|.
375 w3
376 )
377
378 putWord64 :: BinHandle -> Word64 -> IO ()
379 putWord64 h w = putPrim h 8 (\op -> do
380 pokeElemOff op 0 (fromIntegral (w `shiftR` 56))
381 pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))
382 pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF))
383 pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF))
384 pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF))
385 pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
386 pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF))
387 pokeElemOff op 7 (fromIntegral (w .&. 0xFF))
388 )
389
390 getWord64 :: BinHandle -> IO Word64
391 getWord64 h = getPrim h 8 (\op -> do
392 w0 <- fromIntegral <$> peekElemOff op 0
393 w1 <- fromIntegral <$> peekElemOff op 1
394 w2 <- fromIntegral <$> peekElemOff op 2
395 w3 <- fromIntegral <$> peekElemOff op 3
396 w4 <- fromIntegral <$> peekElemOff op 4
397 w5 <- fromIntegral <$> peekElemOff op 5
398 w6 <- fromIntegral <$> peekElemOff op 6
399 w7 <- fromIntegral <$> peekElemOff op 7
400
401 return $! (w0 `shiftL` 56) .|.
402 (w1 `shiftL` 48) .|.
403 (w2 `shiftL` 40) .|.
404 (w3 `shiftL` 32) .|.
405 (w4 `shiftL` 24) .|.
406 (w5 `shiftL` 16) .|.
407 (w6 `shiftL` 8) .|.
408 w7
409 )
410
411 putByte :: BinHandle -> Word8 -> IO ()
412 putByte bh !w = putWord8 bh w
413
414 getByte :: BinHandle -> IO Word8
415 getByte h = getWord8 h
416
417 -- -----------------------------------------------------------------------------
418 -- Encode numbers in LEB128 encoding.
419 -- Requires one byte of space per 7 bits of data.
420 --
421 -- There are signed and unsigned variants.
422 -- Do NOT use the unsigned one for signed values, at worst it will
423 -- result in wrong results, at best it will lead to bad performance
424 -- when coercing negative values to an unsigned type.
425 --
426 -- We mark them as SPECIALIZE as it's extremely critical that they get specialized
427 -- to their specific types.
428 --
429 -- TODO: Each use of putByte performs a bounds check,
430 -- we should use putPrimMax here. However it's quite hard to return
431 -- the number of bytes written into putPrimMax without allocating an
432 -- Int for it, while the code below does not allocate at all.
433 -- So we eat the cost of the bounds check instead of increasing allocations
434 -- for now.
435
436 -- Unsigned numbers
437 {-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-}
438 {-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-}
439 {-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-}
440 {-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-}
441 {-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-}
442 {-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-}
443 {-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-}
444 {-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-}
445 putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()
446 putULEB128 bh w =
447 #if defined(DEBUG)
448 (if w < 0 then panic "putULEB128: Signed number" else id) $
449 #endif
450 go w
451 where
452 go :: a -> IO ()
453 go w
454 | w <= (127 :: a)
455 = putByte bh (fromIntegral w :: Word8)
456 | otherwise = do
457 -- bit 7 (8th bit) indicates more to come.
458 let !byte = setBit (fromIntegral w) 7 :: Word8
459 putByte bh byte
460 go (w `unsafeShiftR` 7)
461
462 {-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-}
463 {-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-}
464 {-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-}
465 {-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-}
466 {-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-}
467 {-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-}
468 {-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-}
469 {-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-}
470 getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a
471 getULEB128 bh =
472 go 0 0
473 where
474 go :: Int -> a -> IO a
475 go shift w = do
476 b <- getByte bh
477 let !hasMore = testBit b 7
478 let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a
479 if hasMore
480 then do
481 go (shift+7) val
482 else
483 return $! val
484
485 -- Signed numbers
486 {-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-}
487 {-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-}
488 {-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-}
489 {-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-}
490 {-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-}
491 {-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-}
492 {-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-}
493 {-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-}
494 putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()
495 putSLEB128 bh initial = go initial
496 where
497 go :: a -> IO ()
498 go val = do
499 let !byte = fromIntegral (clearBit val 7) :: Word8
500 let !val' = val `unsafeShiftR` 7
501 let !signBit = testBit byte 6
502 let !done =
503 -- Unsigned value, val' == 0 and last value can
504 -- be discriminated from a negative number.
505 ((val' == 0 && not signBit) ||
506 -- Signed value,
507 (val' == -1 && signBit))
508
509 let !byte' = if done then byte else setBit byte 7
510 putByte bh byte'
511
512 unless done $ go val'
513
514 {-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-}
515 {-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-}
516 {-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-}
517 {-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-}
518 {-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-}
519 {-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-}
520 {-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-}
521 {-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-}
522 getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a
523 getSLEB128 bh = do
524 (val,shift,signed) <- go 0 0
525 if signed && (shift < finiteBitSize val )
526 then return $! ((complement 0 `unsafeShiftL` shift) .|. val)
527 else return val
528 where
529 go :: Int -> a -> IO (a,Int,Bool)
530 go shift val = do
531 byte <- getByte bh
532 let !byteVal = fromIntegral (clearBit byte 7) :: a
533 let !val' = val .|. (byteVal `unsafeShiftL` shift)
534 let !more = testBit byte 7
535 let !shift' = shift+7
536 if more
537 then go (shift') val'
538 else do
539 let !signed = testBit byte 6
540 return (val',shift',signed)
541
542 -- -----------------------------------------------------------------------------
543 -- Fixed length encoding instances
544
545 -- Sometimes words are used to represent a certain bit pattern instead
546 -- of a number. Using FixedLengthEncoding we will write the pattern as
547 -- is to the interface file without the variable length encoding we usually
548 -- apply.
549
550 -- | Encode the argument in it's full length. This is different from many default
551 -- binary instances which make no guarantee about the actual encoding and
552 -- might do things use variable length encoding.
553 newtype FixedLengthEncoding a = FixedLengthEncoding { unFixedLength :: a }
554
555 instance Binary (FixedLengthEncoding Word8) where
556 put_ h (FixedLengthEncoding x) = putByte h x
557 get h = FixedLengthEncoding <$> getByte h
558
559 instance Binary (FixedLengthEncoding Word16) where
560 put_ h (FixedLengthEncoding x) = putWord16 h x
561 get h = FixedLengthEncoding <$> getWord16 h
562
563 instance Binary (FixedLengthEncoding Word32) where
564 put_ h (FixedLengthEncoding x) = putWord32 h x
565 get h = FixedLengthEncoding <$> getWord32 h
566
567 instance Binary (FixedLengthEncoding Word64) where
568 put_ h (FixedLengthEncoding x) = putWord64 h x
569 get h = FixedLengthEncoding <$> getWord64 h
570
571 -- -----------------------------------------------------------------------------
572 -- Primitive Word writes
573
574 instance Binary Word8 where
575 put_ bh !w = putWord8 bh w
576 get = getWord8
577
578 instance Binary Word16 where
579 put_ = putULEB128
580 get = getULEB128
581
582 instance Binary Word32 where
583 put_ = putULEB128
584 get = getULEB128
585
586 instance Binary Word64 where
587 put_ = putULEB128
588 get = getULEB128
589
590 -- -----------------------------------------------------------------------------
591 -- Primitive Int writes
592
593 instance Binary Int8 where
594 put_ h w = put_ h (fromIntegral w :: Word8)
595 get h = do w <- get h; return $! (fromIntegral (w::Word8))
596
597 instance Binary Int16 where
598 put_ = putSLEB128
599 get = getSLEB128
600
601 instance Binary Int32 where
602 put_ = putSLEB128
603 get = getSLEB128
604
605 instance Binary Int64 where
606 put_ h w = putSLEB128 h w
607 get h = getSLEB128 h
608
609 -- -----------------------------------------------------------------------------
610 -- Instances for standard types
611
612 instance Binary () where
613 put_ _ () = return ()
614 get _ = return ()
615
616 instance Binary Bool where
617 put_ bh b = putByte bh (fromIntegral (fromEnum b))
618 get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
619
620 instance Binary Char where
621 put_ bh c = put_ bh (fromIntegral (ord c) :: Word32)
622 get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
623
624 instance Binary Int where
625 put_ bh i = put_ bh (fromIntegral i :: Int64)
626 get bh = do
627 x <- get bh
628 return $! (fromIntegral (x :: Int64))
629
630 instance Binary a => Binary [a] where
631 put_ bh l = do
632 let len = length l
633 put_ bh len
634 mapM_ (put_ bh) l
635 get bh = do
636 len <- get bh :: IO Int -- Int is variable length encoded so only
637 -- one byte for small lists.
638 let loop 0 = return []
639 loop n = do a <- get bh; as <- loop (n-1); return (a:as)
640 loop len
641
642 instance Binary a => Binary (Set a) where
643 put_ bh a = put_ bh (Set.toAscList a)
644 get bh = Set.fromDistinctAscList <$> get bh
645
646 instance (Ix a, Binary a, Binary b) => Binary (Array a b) where
647 put_ bh arr = do
648 put_ bh $ bounds arr
649 put_ bh $ elems arr
650 get bh = do
651 bounds <- get bh
652 xs <- get bh
653 return $ listArray bounds xs
654
655 instance (Binary a, Binary b) => Binary (a,b) where
656 put_ bh (a,b) = do put_ bh a; put_ bh b
657 get bh = do a <- get bh
658 b <- get bh
659 return (a,b)
660
661 instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
662 put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
663 get bh = do a <- get bh
664 b <- get bh
665 c <- get bh
666 return (a,b,c)
667
668 instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
669 put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
670 get bh = do a <- get bh
671 b <- get bh
672 c <- get bh
673 d <- get bh
674 return (a,b,c,d)
675
676 instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where
677 put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e;
678 get bh = do a <- get bh
679 b <- get bh
680 c <- get bh
681 d <- get bh
682 e <- get bh
683 return (a,b,c,d,e)
684
685 instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where
686 put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f;
687 get bh = do a <- get bh
688 b <- get bh
689 c <- get bh
690 d <- get bh
691 e <- get bh
692 f <- get bh
693 return (a,b,c,d,e,f)
694
695 instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where
696 put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g
697 get bh = do a <- get bh
698 b <- get bh
699 c <- get bh
700 d <- get bh
701 e <- get bh
702 f <- get bh
703 g <- get bh
704 return (a,b,c,d,e,f,g)
705
706 instance Binary a => Binary (Maybe a) where
707 put_ bh Nothing = putByte bh 0
708 put_ bh (Just a) = do putByte bh 1; put_ bh a
709 get bh = do h <- getWord8 bh
710 case h of
711 0 -> return Nothing
712 _ -> do x <- get bh; return (Just x)
713
714 instance Binary a => Binary (Strict.Maybe a) where
715 put_ bh Strict.Nothing = putByte bh 0
716 put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a
717 get bh =
718 do h <- getWord8 bh
719 case h of
720 0 -> return Strict.Nothing
721 _ -> do x <- get bh; return (Strict.Just x)
722
723 instance (Binary a, Binary b) => Binary (Either a b) where
724 put_ bh (Left a) = do putByte bh 0; put_ bh a
725 put_ bh (Right b) = do putByte bh 1; put_ bh b
726 get bh = do h <- getWord8 bh
727 case h of
728 0 -> do a <- get bh ; return (Left a)
729 _ -> do b <- get bh ; return (Right b)
730
731 instance Binary UTCTime where
732 put_ bh u = do put_ bh (utctDay u)
733 put_ bh (utctDayTime u)
734 get bh = do day <- get bh
735 dayTime <- get bh
736 return $ UTCTime { utctDay = day, utctDayTime = dayTime }
737
738 instance Binary Day where
739 put_ bh d = put_ bh (toModifiedJulianDay d)
740 get bh = do i <- get bh
741 return $ ModifiedJulianDay { toModifiedJulianDay = i }
742
743 instance Binary DiffTime where
744 put_ bh dt = put_ bh (toRational dt)
745 get bh = do r <- get bh
746 return $ fromRational r
747
748 {-
749 Finally - a reasonable portable Integer instance.
750
751 We used to encode values in the Int32 range as such,
752 falling back to a string of all things. In either case
753 we stored a tag byte to discriminate between the two cases.
754
755 This made some sense as it's highly portable but also not very
756 efficient.
757
758 However GHC stores a surprisingly large number off large Integer
759 values. In the examples looked at between 25% and 50% of Integers
760 serialized were outside of the Int32 range.
761
762 Consider a valie like `2724268014499746065`, some sort of hash
763 actually generated by GHC.
764 In the old scheme this was encoded as a list of 19 chars. This
765 gave a size of 77 Bytes, one for the length of the list and 76
766 since we encode chars as Word32 as well.
767
768 We can easily do better. The new plan is:
769
770 * Start with a tag byte
771 * 0 => Int64 (LEB128 encoded)
772 * 1 => Negative large interger
773 * 2 => Positive large integer
774 * Followed by the value:
775 * Int64 is encoded as usual
776 * Large integers are encoded as a list of bytes (Word8).
777 We use Data.Bits which defines a bit order independent of the representation.
778 Values are stored LSB first.
779
780 This means our example value `2724268014499746065` is now only 10 bytes large.
781 * One byte tag
782 * One byte for the length of the [Word8] list.
783 * 8 bytes for the actual date.
784
785 The new scheme also does not depend in any way on
786 architecture specific details.
787
788 We still use this scheme even with LEB128 available,
789 as it has less overhead for truly large numbers. (> maxBound :: Int64)
790
791 The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal
792 -}
793
794 instance Binary Integer where
795 put_ bh i
796 | i >= lo64 && i <= hi64 = do
797 putWord8 bh 0
798 put_ bh (fromIntegral i :: Int64)
799 | otherwise = do
800 if i < 0
801 then putWord8 bh 1
802 else putWord8 bh 2
803 put_ bh (unroll $ abs i)
804 where
805 lo64 = fromIntegral (minBound :: Int64)
806 hi64 = fromIntegral (maxBound :: Int64)
807 get bh = do
808 int_kind <- getWord8 bh
809 case int_kind of
810 0 -> fromIntegral <$!> (get bh :: IO Int64)
811 -- Large integer
812 1 -> negate <$!> getInt
813 2 -> getInt
814 _ -> panic "Binary Integer - Invalid byte"
815 where
816 getInt :: IO Integer
817 getInt = roll <$!> (get bh :: IO [Word8])
818
819 unroll :: Integer -> [Word8]
820 unroll = unfoldr step
821 where
822 step 0 = Nothing
823 step i = Just (fromIntegral i, i `shiftR` 8)
824
825 roll :: [Word8] -> Integer
826 roll = foldl' unstep 0 . reverse
827 where
828 unstep a b = a `shiftL` 8 .|. fromIntegral b
829
830
831 {-
832 -- This code is currently commented out.
833 -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for
834 -- discussion.
835
836 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
837 put_ bh (J# s# a#) = do
838 putByte bh 1
839 put_ bh (I# s#)
840 let sz# = sizeofByteArray# a# -- in *bytes*
841 put_ bh (I# sz#) -- in *bytes*
842 putByteArray bh a# sz#
843
844 get bh = do
845 b <- getByte bh
846 case b of
847 0 -> do (I# i#) <- get bh
848 return (S# i#)
849 _ -> do (I# s#) <- get bh
850 sz <- get bh
851 (BA a#) <- getByteArray bh sz
852 return (J# s# a#)
853
854 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
855 putByteArray bh a s# = loop 0#
856 where loop n#
857 | n# ==# s# = return ()
858 | otherwise = do
859 putByte bh (indexByteArray a n#)
860 loop (n# +# 1#)
861
862 getByteArray :: BinHandle -> Int -> IO ByteArray
863 getByteArray bh (I# sz) = do
864 (MBA arr) <- newByteArray sz
865 let loop n
866 | n ==# sz = return ()
867 | otherwise = do
868 w <- getByte bh
869 writeByteArray arr n w
870 loop (n +# 1#)
871 loop 0#
872 freezeByteArray arr
873 -}
874
875 {-
876 data ByteArray = BA ByteArray#
877 data MBA = MBA (MutableByteArray# RealWorld)
878
879 newByteArray :: Int# -> IO MBA
880 newByteArray sz = IO $ \s ->
881 case newByteArray# sz s of { (# s, arr #) ->
882 (# s, MBA arr #) }
883
884 freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
885 freezeByteArray arr = IO $ \s ->
886 case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
887 (# s, BA arr #) }
888
889 writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
890 writeByteArray arr i (W8# w) = IO $ \s ->
891 case writeWord8Array# arr i w s of { s ->
892 (# s, () #) }
893
894 indexByteArray :: ByteArray# -> Int# -> Word8
895 indexByteArray a# n# = W8# (indexWord8Array# a# n#)
896
897 -}
898 instance (Binary a) => Binary (Ratio a) where
899 put_ bh (a :% b) = do put_ bh a; put_ bh b
900 get bh = do a <- get bh; b <- get bh; return (a :% b)
901
902 -- Instance uses fixed-width encoding to allow inserting
903 -- Bin placeholders in the stream.
904 instance Binary (Bin a) where
905 put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32)
906 get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32)))
907
908
909 -- -----------------------------------------------------------------------------
910 -- Lazy reading/writing
911
912 lazyPut :: Binary a => BinHandle -> a -> IO ()
913 lazyPut bh a = do
914 -- output the obj with a ptr to skip over it:
915 pre_a <- tellBin bh
916 put_ bh pre_a -- save a slot for the ptr
917 put_ bh a -- dump the object
918 q <- tellBin bh -- q = ptr to after object
919 putAt bh pre_a q -- fill in slot before a with ptr to q
920 seekBin bh q -- finally carry on writing at q
921
922 lazyGet :: Binary a => BinHandle -> IO a
923 lazyGet bh = do
924 p <- get bh -- a BinPtr
925 p_a <- tellBin bh
926 a <- unsafeInterleaveIO $ do
927 -- NB: Use a fresh off_r variable in the child thread, for thread
928 -- safety.
929 off_r <- newFastMutInt 0
930 getAt bh { _off_r = off_r } p_a
931 seekBin bh p -- skip over the object for now
932 return a
933
934 -- -----------------------------------------------------------------------------
935 -- UserData
936 -- -----------------------------------------------------------------------------
937
938 -- | Information we keep around during interface file
939 -- serialization/deserialization. Namely we keep the functions for serializing
940 -- and deserializing 'Name's and 'FastString's. We do this because we actually
941 -- use serialization in two distinct settings,
942 --
943 -- * When serializing interface files themselves
944 --
945 -- * When computing the fingerprint of an IfaceDecl (which we computing by
946 -- hashing its Binary serialization)
947 --
948 -- These two settings have different needs while serializing Names:
949 --
950 -- * Names in interface files are serialized via a symbol table (see Note
951 -- [Symbol table representation of names] in "GHC.Iface.Binary").
952 --
953 -- * During fingerprinting a binding Name is serialized as the OccName and a
954 -- non-binding Name is serialized as the fingerprint of the thing they
955 -- represent. See Note [Fingerprinting IfaceDecls] for further discussion.
956 --
957 data UserData =
958 UserData {
959 -- for *deserialising* only:
960 ud_get_name :: BinHandle -> IO Name,
961 ud_get_fs :: BinHandle -> IO FastString,
962
963 -- for *serialising* only:
964 ud_put_nonbinding_name :: BinHandle -> Name -> IO (),
965 -- ^ serialize a non-binding 'Name' (e.g. a reference to another
966 -- binding).
967 ud_put_binding_name :: BinHandle -> Name -> IO (),
968 -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl)
969 ud_put_fs :: BinHandle -> FastString -> IO ()
970 }
971
972 newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's
973 -> (BinHandle -> IO FastString)
974 -> UserData
975 newReadState get_name get_fs
976 = UserData { ud_get_name = get_name,
977 ud_get_fs = get_fs,
978 ud_put_nonbinding_name = undef "put_nonbinding_name",
979 ud_put_binding_name = undef "put_binding_name",
980 ud_put_fs = undef "put_fs"
981 }
982
983 newWriteState :: (BinHandle -> Name -> IO ())
984 -- ^ how to serialize non-binding 'Name's
985 -> (BinHandle -> Name -> IO ())
986 -- ^ how to serialize binding 'Name's
987 -> (BinHandle -> FastString -> IO ())
988 -> UserData
989 newWriteState put_nonbinding_name put_binding_name put_fs
990 = UserData { ud_get_name = undef "get_name",
991 ud_get_fs = undef "get_fs",
992 ud_put_nonbinding_name = put_nonbinding_name,
993 ud_put_binding_name = put_binding_name,
994 ud_put_fs = put_fs
995 }
996
997 noUserData :: a
998 noUserData = undef "UserData"
999
1000 undef :: String -> a
1001 undef s = panic ("Binary.UserData: no " ++ s)
1002
1003 ---------------------------------------------------------
1004 -- The Dictionary
1005 ---------------------------------------------------------
1006
1007 type Dictionary = Array Int FastString -- The dictionary
1008 -- Should be 0-indexed
1009
1010 putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
1011 putDictionary bh sz dict = do
1012 put_ bh sz
1013 mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict)))
1014 -- It's OK to use nonDetEltsUFM here because the elements have indices
1015 -- that array uses to create order
1016
1017 getDictionary :: BinHandle -> IO Dictionary
1018 getDictionary bh = do
1019 sz <- get bh :: IO Int
1020 mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString)
1021 forM_ [0..(sz-1)] $ \i -> do
1022 fs <- getFS bh
1023 writeArray mut_arr i fs
1024 unsafeFreeze mut_arr
1025
1026 ---------------------------------------------------------
1027 -- The Symbol Table
1028 ---------------------------------------------------------
1029
1030 -- On disk, the symbol table is an array of IfExtName, when
1031 -- reading it in we turn it into a SymbolTable.
1032
1033 type SymbolTable = Array Int Name
1034
1035 ---------------------------------------------------------
1036 -- Reading and writing FastStrings
1037 ---------------------------------------------------------
1038
1039 putFS :: BinHandle -> FastString -> IO ()
1040 putFS bh fs = putBS bh $ bytesFS fs
1041
1042 getFS :: BinHandle -> IO FastString
1043 getFS bh = do
1044 l <- get bh :: IO Int
1045 getPrim bh l (\src -> pure $! mkFastStringBytes src l )
1046
1047 putBS :: BinHandle -> ByteString -> IO ()
1048 putBS bh bs =
1049 BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do
1050 put_ bh l
1051 putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l)
1052
1053 getBS :: BinHandle -> IO ByteString
1054 getBS bh = do
1055 l <- get bh :: IO Int
1056 BS.create l $ \dest -> do
1057 getPrim bh l (\src -> BS.memcpy dest src l)
1058
1059 instance Binary ByteString where
1060 put_ bh f = putBS bh f
1061 get bh = getBS bh
1062
1063 instance Binary FastString where
1064 put_ bh f =
1065 case getUserData bh of
1066 UserData { ud_put_fs = put_fs } -> put_fs bh f
1067
1068 get bh =
1069 case getUserData bh of
1070 UserData { ud_get_fs = get_fs } -> get_fs bh
1071
1072 deriving instance Binary NonDetFastString
1073 deriving instance Binary LexicalFastString
1074
1075 instance Binary Fingerprint where
1076 put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
1077 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
1078
1079 -- instance Binary FunctionOrData where
1080 -- put_ bh IsFunction = putByte bh 0
1081 -- put_ bh IsData = putByte bh 1
1082 -- get bh = do
1083 -- h <- getByte bh
1084 -- case h of
1085 -- 0 -> return IsFunction
1086 -- 1 -> return IsData
1087 -- _ -> panic "Binary FunctionOrData"
1088
1089 -- instance Binary TupleSort where
1090 -- put_ bh BoxedTuple = putByte bh 0
1091 -- put_ bh UnboxedTuple = putByte bh 1
1092 -- put_ bh ConstraintTuple = putByte bh 2
1093 -- get bh = do
1094 -- h <- getByte bh
1095 -- case h of
1096 -- 0 -> do return BoxedTuple
1097 -- 1 -> do return UnboxedTuple
1098 -- _ -> do return ConstraintTuple
1099
1100 -- instance Binary Activation where
1101 -- put_ bh NeverActive = do
1102 -- putByte bh 0
1103 -- put_ bh FinalActive = do
1104 -- putByte bh 1
1105 -- put_ bh AlwaysActive = do
1106 -- putByte bh 2
1107 -- put_ bh (ActiveBefore src aa) = do
1108 -- putByte bh 3
1109 -- put_ bh src
1110 -- put_ bh aa
1111 -- put_ bh (ActiveAfter src ab) = do
1112 -- putByte bh 4
1113 -- put_ bh src
1114 -- put_ bh ab
1115 -- get bh = do
1116 -- h <- getByte bh
1117 -- case h of
1118 -- 0 -> do return NeverActive
1119 -- 1 -> do return FinalActive
1120 -- 2 -> do return AlwaysActive
1121 -- 3 -> do src <- get bh
1122 -- aa <- get bh
1123 -- return (ActiveBefore src aa)
1124 -- _ -> do src <- get bh
1125 -- ab <- get bh
1126 -- return (ActiveAfter src ab)
1127
1128 -- instance Binary InlinePragma where
1129 -- put_ bh (InlinePragma s a b c d) = do
1130 -- put_ bh s
1131 -- put_ bh a
1132 -- put_ bh b
1133 -- put_ bh c
1134 -- put_ bh d
1135
1136 -- get bh = do
1137 -- s <- get bh
1138 -- a <- get bh
1139 -- b <- get bh
1140 -- c <- get bh
1141 -- d <- get bh
1142 -- return (InlinePragma s a b c d)
1143
1144 -- instance Binary RuleMatchInfo where
1145 -- put_ bh FunLike = putByte bh 0
1146 -- put_ bh ConLike = putByte bh 1
1147 -- get bh = do
1148 -- h <- getByte bh
1149 -- if h == 1 then return ConLike
1150 -- else return FunLike
1151
1152 -- instance Binary InlineSpec where
1153 -- put_ bh NoUserInlinePrag = putByte bh 0
1154 -- put_ bh Inline = putByte bh 1
1155 -- put_ bh Inlinable = putByte bh 2
1156 -- put_ bh NoInline = putByte bh 3
1157
1158 -- get bh = do h <- getByte bh
1159 -- case h of
1160 -- 0 -> return NoUserInlinePrag
1161 -- 1 -> return Inline
1162 -- 2 -> return Inlinable
1163 -- _ -> return NoInline
1164
1165 -- instance Binary RecFlag where
1166 -- put_ bh Recursive = do
1167 -- putByte bh 0
1168 -- put_ bh NonRecursive = do
1169 -- putByte bh 1
1170 -- get bh = do
1171 -- h <- getByte bh
1172 -- case h of
1173 -- 0 -> do return Recursive
1174 -- _ -> do return NonRecursive
1175
1176 -- instance Binary OverlapMode where
1177 -- put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s
1178 -- put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s
1179 -- put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s
1180 -- put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s
1181 -- put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
1182 -- get bh = do
1183 -- h <- getByte bh
1184 -- case h of
1185 -- 0 -> (get bh) >>= \s -> return $ NoOverlap s
1186 -- 1 -> (get bh) >>= \s -> return $ Overlaps s
1187 -- 2 -> (get bh) >>= \s -> return $ Incoherent s
1188 -- 3 -> (get bh) >>= \s -> return $ Overlapping s
1189 -- 4 -> (get bh) >>= \s -> return $ Overlappable s
1190 -- _ -> panic ("get OverlapMode" ++ show h)
1191
1192
1193 -- instance Binary OverlapFlag where
1194 -- put_ bh flag = do put_ bh (overlapMode flag)
1195 -- put_ bh (isSafeOverlap flag)
1196 -- get bh = do
1197 -- h <- get bh
1198 -- b <- get bh
1199 -- return OverlapFlag { overlapMode = h, isSafeOverlap = b }
1200
1201 -- instance Binary FixityDirection where
1202 -- put_ bh InfixL = do
1203 -- putByte bh 0
1204 -- put_ bh InfixR = do
1205 -- putByte bh 1
1206 -- put_ bh InfixN = do
1207 -- putByte bh 2
1208 -- get bh = do
1209 -- h <- getByte bh
1210 -- case h of
1211 -- 0 -> do return InfixL
1212 -- 1 -> do return InfixR
1213 -- _ -> do return InfixN
1214
1215 -- instance Binary Fixity where
1216 -- put_ bh (Fixity src aa ab) = do
1217 -- put_ bh src
1218 -- put_ bh aa
1219 -- put_ bh ab
1220 -- get bh = do
1221 -- src <- get bh
1222 -- aa <- get bh
1223 -- ab <- get bh
1224 -- return (Fixity src aa ab)
1225
1226 -- instance Binary WarningTxt where
1227 -- put_ bh (WarningTxt s w) = do
1228 -- putByte bh 0
1229 -- put_ bh s
1230 -- put_ bh w
1231 -- put_ bh (DeprecatedTxt s d) = do
1232 -- putByte bh 1
1233 -- put_ bh s
1234 -- put_ bh d
1235
1236 -- get bh = do
1237 -- h <- getByte bh
1238 -- case h of
1239 -- 0 -> do s <- get bh
1240 -- w <- get bh
1241 -- return (WarningTxt s w)
1242 -- _ -> do s <- get bh
1243 -- d <- get bh
1244 -- return (DeprecatedTxt s d)
1245
1246 -- instance Binary StringLiteral where
1247 -- put_ bh (StringLiteral st fs _) = do
1248 -- put_ bh st
1249 -- put_ bh fs
1250 -- get bh = do
1251 -- st <- get bh
1252 -- fs <- get bh
1253 -- return (StringLiteral st fs Nothing)
1254
1255 instance Binary a => Binary (Located a) where
1256 put_ bh (L l x) = do
1257 put_ bh l
1258 put_ bh x
1259
1260 get bh = do
1261 l <- get bh
1262 x <- get bh
1263 return (L l x)
1264
1265 instance Binary RealSrcSpan where
1266 put_ bh ss = do
1267 put_ bh (srcSpanFile ss)
1268 put_ bh (srcSpanStartLine ss)
1269 put_ bh (srcSpanStartCol ss)
1270 put_ bh (srcSpanEndLine ss)
1271 put_ bh (srcSpanEndCol ss)
1272
1273 get bh = do
1274 f <- get bh
1275 sl <- get bh
1276 sc <- get bh
1277 el <- get bh
1278 ec <- get bh
1279 return (mkRealSrcSpan (mkRealSrcLoc f sl sc)
1280 (mkRealSrcLoc f el ec))
1281
1282 instance Binary BufPos where
1283 put_ bh (BufPos i) = put_ bh i
1284 get bh = BufPos <$> get bh
1285
1286 instance Binary BufSpan where
1287 put_ bh (BufSpan start end) = do
1288 put_ bh start
1289 put_ bh end
1290 get bh = do
1291 start <- get bh
1292 end <- get bh
1293 return (BufSpan start end)
1294
1295 instance Binary UnhelpfulSpanReason where
1296 put_ bh r = case r of
1297 UnhelpfulNoLocationInfo -> putByte bh 0
1298 UnhelpfulWiredIn -> putByte bh 1
1299 UnhelpfulInteractive -> putByte bh 2
1300 UnhelpfulGenerated -> putByte bh 3
1301 UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs
1302
1303 get bh = do
1304 h <- getByte bh
1305 case h of
1306 0 -> return UnhelpfulNoLocationInfo
1307 1 -> return UnhelpfulWiredIn
1308 2 -> return UnhelpfulInteractive
1309 3 -> return UnhelpfulGenerated
1310 _ -> UnhelpfulOther <$> get bh
1311
1312 instance Binary SrcSpan where
1313 put_ bh (RealSrcSpan ss sb) = do
1314 putByte bh 0
1315 put_ bh ss
1316 put_ bh sb
1317
1318 put_ bh (UnhelpfulSpan s) = do
1319 putByte bh 1
1320 put_ bh s
1321
1322 get bh = do
1323 h <- getByte bh
1324 case h of
1325 0 -> do ss <- get bh
1326 sb <- get bh
1327 return (RealSrcSpan ss sb)
1328 _ -> do s <- get bh
1329 return (UnhelpfulSpan s)