{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UnboxedTuples #-}

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
#if MIN_VERSION_base(4,16,0)
#define HAS_TYPELITCHAR
#endif
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected

--
-- (c) The University of Glasgow 2002-2006
--
-- Binary I/O library, with special tweaks for GHC
--
-- Based on the nhc98 Binary library, which is copyright
-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
-- Under the terms of the license for that software, we must tell you
-- where you can obtain the original version of the Binary library, namely
--     http://www.cs.york.ac.uk/fp/nhc98/

module GHC.Utils.Binary
  ( {-type-}  Bin,
    {-class-} Binary(..),
    {-type-}  BinHandle,
    SymbolTable, Dictionary,

   BinData(..), dataHandle, handleData,

   openBinMem,
--   closeBin,

   seekBin,
   tellBin,
   castBin,
   withBinBuffer,

   writeBinMem,
   readBinMem,

   putAt, getAt,

   -- * For writing instances
   putByte,
   getByte,

   -- * Variable length encodings
   putULEB128,
   getULEB128,
   putSLEB128,
   getSLEB128,

   -- * Fixed length encoding
   FixedLengthEncoding(..),

   -- * Lazy Binary I/O
   lazyGet,
   lazyPut,

   -- * User data
   UserData(..), getUserData, setUserData,
   newReadState, newWriteState,
   putDictionary, getDictionary, putFS,
  ) where

#include "GhclibHsVersions.h"

import GHC.Prelude

import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
import GHC.Utils.Fingerprint
import GHC.Types.SrcLoc

import Control.DeepSeq
import Foreign hiding (shiftL, shiftR)
import Data.Array
import Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe   as BS
import Data.IORef
import Data.Char                ( ord, chr )
import Data.Time
import Data.List (unfoldr)
import Control.Monad            ( when, (<$!>), unless )
import System.IO as IO
import System.IO.Unsafe         ( unsafeInterleaveIO )
import System.IO.Error          ( mkIOError, eofErrorType )
import GHC.Real                 ( Ratio(..) )
#if MIN_VERSION_base(4,15,0)
import GHC.ForeignPtr           ( unsafeWithForeignPtr )
#endif

type BinArray = ForeignPtr Word8

#if !MIN_VERSION_base(4,15,0)
unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr = withForeignPtr
#endif

---------------------------------------------------------------
-- BinData
---------------------------------------------------------------

data BinData = BinData Int BinArray

instance NFData BinData where
  rnf :: BinData -> ()
rnf (BinData Int
sz BinArray
_) = forall a. NFData a => a -> ()
rnf Int
sz

instance Binary BinData where
  put_ :: BinHandle -> BinData -> IO ()
put_ BinHandle
bh (BinData Int
sz BinArray
dat) = do
    forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
sz
    BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
bh Int
sz forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dest ->
      forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr BinArray
dat forall a b. (a -> b) -> a -> b
$ \Ptr Word8
orig ->
        forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
dest Ptr Word8
orig Int
sz
  --
  get :: BinHandle -> IO BinData
get BinHandle
bh = do
    Int
sz <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    BinArray
dat <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
sz
    forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
bh Int
sz forall a b. (a -> b) -> a -> b
$ \Ptr Word8
orig ->
      forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr BinArray
dat forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dest ->
        forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
dest Ptr Word8
orig Int
sz
    forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> BinArray -> BinData
BinData Int
sz BinArray
dat)

dataHandle :: BinData -> IO BinHandle
dataHandle :: BinData -> IO BinHandle
dataHandle (BinData Int
size BinArray
bin) = do
  FastMutInt
ixr <- Int -> IO FastMutInt
newFastMutInt Int
0
  FastMutInt
szr <- Int -> IO FastMutInt
newFastMutInt Int
size
  IORef BinArray
binr <- forall a. a -> IO (IORef a)
newIORef BinArray
bin
  forall (m :: * -> *) a. Monad m => a -> m a
return (UserData -> FastMutInt -> FastMutInt -> IORef BinArray -> BinHandle
BinMem forall a. a
noUserData FastMutInt
ixr FastMutInt
szr IORef BinArray
binr)

handleData :: BinHandle -> IO BinData
handleData :: BinHandle -> IO BinData
handleData (BinMem UserData
_ FastMutInt
ixr FastMutInt
_ IORef BinArray
binr) = Int -> BinArray -> BinData
BinData forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastMutInt -> IO Int
readFastMutInt FastMutInt
ixr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IORef a -> IO a
readIORef IORef BinArray
binr

---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------

data BinHandle
  = BinMem {                     -- binary data stored in an unboxed array
     BinHandle -> UserData
bh_usr :: UserData,         -- sigh, need parameterized modules :-)
     BinHandle -> FastMutInt
_off_r :: !FastMutInt,      -- the current offset
     BinHandle -> FastMutInt
_sz_r  :: !FastMutInt,      -- size of the array (cached)
     BinHandle -> IORef BinArray
_arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
    }
        -- XXX: should really store a "high water mark" for dumping out
        -- the binary data to a file.

getUserData :: BinHandle -> UserData
getUserData :: BinHandle -> UserData
getUserData BinHandle
bh = BinHandle -> UserData
bh_usr BinHandle
bh

setUserData :: BinHandle -> UserData -> BinHandle
setUserData :: BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh UserData
us = BinHandle
bh { bh_usr :: UserData
bh_usr = UserData
us }

-- | Get access to the underlying buffer.
--
-- It is quite important that no references to the 'ByteString' leak out of the
-- continuation lest terrible things happen.
withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a
withBinBuffer :: forall a. BinHandle -> (ByteString -> IO a) -> IO a
withBinBuffer (BinMem UserData
_ FastMutInt
ix_r FastMutInt
_ IORef BinArray
arr_r) ByteString -> IO a
action = do
  BinArray
arr <- forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr BinArray
arr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
    CStringLen -> IO ByteString
BS.unsafePackCStringLen (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr, Int
ix) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO a
action


---------------------------------------------------------------
-- Bin
---------------------------------------------------------------

newtype Bin a = BinPtr Int
  deriving (Bin a -> Bin a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). Bin a -> Bin a -> Bool
/= :: Bin a -> Bin a -> Bool
$c/= :: forall k (a :: k). Bin a -> Bin a -> Bool
== :: Bin a -> Bin a -> Bool
$c== :: forall k (a :: k). Bin a -> Bin a -> Bool
Eq, Bin a -> Bin a -> Bool
Bin a -> Bin a -> Ordering
Bin a -> Bin a -> Bin a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall k (a :: k). Eq (Bin a)
forall k (a :: k). Bin a -> Bin a -> Bool
forall k (a :: k). Bin a -> Bin a -> Ordering
forall k (a :: k). Bin a -> Bin a -> Bin a
min :: Bin a -> Bin a -> Bin a
$cmin :: forall k (a :: k). Bin a -> Bin a -> Bin a
max :: Bin a -> Bin a -> Bin a
$cmax :: forall k (a :: k). Bin a -> Bin a -> Bin a
>= :: Bin a -> Bin a -> Bool
$c>= :: forall k (a :: k). Bin a -> Bin a -> Bool
> :: Bin a -> Bin a -> Bool
$c> :: forall k (a :: k). Bin a -> Bin a -> Bool
<= :: Bin a -> Bin a -> Bool
$c<= :: forall k (a :: k). Bin a -> Bin a -> Bool
< :: Bin a -> Bin a -> Bool
$c< :: forall k (a :: k). Bin a -> Bin a -> Bool
compare :: Bin a -> Bin a -> Ordering
$ccompare :: forall k (a :: k). Bin a -> Bin a -> Ordering
Ord, Int -> Bin a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> Bin a -> ShowS
forall k (a :: k). [Bin a] -> ShowS
forall k (a :: k). Bin a -> String
showList :: [Bin a] -> ShowS
$cshowList :: forall k (a :: k). [Bin a] -> ShowS
show :: Bin a -> String
$cshow :: forall k (a :: k). Bin a -> String
showsPrec :: Int -> Bin a -> ShowS
$cshowsPrec :: forall k (a :: k). Int -> Bin a -> ShowS
Show, Bin a
forall a. a -> a -> Bounded a
forall k (a :: k). Bin a
maxBound :: Bin a
$cmaxBound :: forall k (a :: k). Bin a
minBound :: Bin a
$cminBound :: forall k (a :: k). Bin a
Bounded)

castBin :: Bin a -> Bin b
castBin :: forall {k} {k} (a :: k) (b :: k). Bin a -> Bin b
castBin (BinPtr Int
i) = forall {k} (a :: k). Int -> Bin a
BinPtr Int
i

---------------------------------------------------------------
-- class Binary
---------------------------------------------------------------

-- | Do not rely on instance sizes for general types,
-- we use variable length encoding for many of them.
class Binary a where
    put_   :: BinHandle -> a -> IO ()
    put    :: BinHandle -> a -> IO (Bin a)
    get    :: BinHandle -> IO a

    -- define one of put_, put.  Use of put_ is recommended because it
    -- is more likely that tail-calls can kick in, and we rarely need the
    -- position return value.
    put_ BinHandle
bh a
a = do Bin a
_ <- forall a. Binary a => BinHandle -> a -> IO (Bin a)
put BinHandle
bh a
a; forall (m :: * -> *) a. Monad m => a -> m a
return ()
    put BinHandle
bh a
a  = do Bin a
p <- forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; forall (m :: * -> *) a. Monad m => a -> m a
return Bin a
p

putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()
putAt :: forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin a
p a
x = do forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin a
p; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
x; forall (m :: * -> *) a. Monad m => a -> m a
return ()

getAt  :: Binary a => BinHandle -> Bin a -> IO a
getAt :: forall a. Binary a => BinHandle -> Bin a -> IO a
getAt BinHandle
bh Bin a
p = do forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin a
p; forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

openBinMem :: Int -> IO BinHandle
openBinMem :: Int -> IO BinHandle
openBinMem Int
size
 | Int
size forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => String -> a
error String
"Data.Binary.openBinMem: size must be >= 0"
 | Bool
otherwise = do
   BinArray
arr <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
size
   IORef BinArray
arr_r <- forall a. a -> IO (IORef a)
newIORef BinArray
arr
   FastMutInt
ix_r <- Int -> IO FastMutInt
newFastMutInt Int
0
   FastMutInt
sz_r <- Int -> IO FastMutInt
newFastMutInt Int
size
   forall (m :: * -> *) a. Monad m => a -> m a
return (UserData -> FastMutInt -> FastMutInt -> IORef BinArray -> BinHandle
BinMem forall a. a
noUserData FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r)

tellBin :: BinHandle -> IO (Bin a)
tellBin :: forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin (BinMem UserData
_ FastMutInt
r FastMutInt
_ IORef BinArray
_) = do Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
r; forall (m :: * -> *) a. Monad m => a -> m a
return (forall {k} (a :: k). Int -> Bin a
BinPtr Int
ix)

seekBin :: BinHandle -> Bin a -> IO ()
seekBin :: forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin h :: BinHandle
h@(BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
_) (BinPtr !Int
p) = do
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  if (Int
p forall a. Ord a => a -> a -> Bool
>= Int
sz)
        then do BinHandle -> Int -> IO ()
expandBin BinHandle
h Int
p; FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
p
        else FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
p

writeBinMem :: BinHandle -> FilePath -> IO ()
writeBinMem :: BinHandle -> String -> IO ()
writeBinMem (BinMem UserData
_ FastMutInt
ix_r FastMutInt
_ IORef BinArray
arr_r) String
fn = do
  Handle
h <- String -> IOMode -> IO Handle
openBinaryFile String
fn IOMode
WriteMode
  BinArray
arr <- forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  Int
ix  <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr BinArray
arr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
h Ptr Word8
p Int
ix
  Handle -> IO ()
hClose Handle
h

readBinMem :: FilePath -> IO BinHandle
-- Return a BinHandle with a totally undefined State
readBinMem :: String -> IO BinHandle
readBinMem String
filename = do
  Handle
h <- String -> IOMode -> IO Handle
openBinaryFile String
filename IOMode
ReadMode
  Integer
filesize' <- Handle -> IO Integer
hFileSize Handle
h
  let filesize :: Int
filesize = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
filesize'
  BinArray
arr <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
filesize
  Int
count <- forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr BinArray
arr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h Ptr Word8
p Int
filesize
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count forall a. Eq a => a -> a -> Bool
/= Int
filesize) forall a b. (a -> b) -> a -> b
$
       forall a. HasCallStack => String -> a
error (String
"Binary.readBinMem: only read " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count forall a. [a] -> [a] -> [a]
++ String
" bytes")
  Handle -> IO ()
hClose Handle
h
  IORef BinArray
arr_r <- forall a. a -> IO (IORef a)
newIORef BinArray
arr
  FastMutInt
ix_r <- Int -> IO FastMutInt
newFastMutInt Int
0
  FastMutInt
sz_r <- Int -> IO FastMutInt
newFastMutInt Int
filesize
  forall (m :: * -> *) a. Monad m => a -> m a
return (UserData -> FastMutInt -> FastMutInt -> IORef BinArray -> BinHandle
BinMem forall a. a
noUserData FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r)

-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
expandBin :: BinHandle -> Int -> IO ()
expandBin (BinMem UserData
_ FastMutInt
_ FastMutInt
sz_r IORef BinArray
arr_r) !Int
off = do
   !Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
   let !sz' :: Int
sz' = Int -> Int
getSize Int
sz
   BinArray
arr <- forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
   BinArray
arr' <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
sz'
   forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr BinArray
arr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
old ->
     forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr BinArray
arr' forall a b. (a -> b) -> a -> b
$ \Ptr Word8
new ->
       forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
new Ptr Word8
old Int
sz
   FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
sz_r Int
sz'
   forall a. IORef a -> a -> IO ()
writeIORef IORef BinArray
arr_r BinArray
arr'
   where
    getSize :: Int -> Int
    getSize :: Int -> Int
getSize !Int
sz
      | Int
sz forall a. Ord a => a -> a -> Bool
> Int
off
      = Int
sz
      | Bool
otherwise
      = Int -> Int
getSize (Int
sz forall a. Num a => a -> a -> a
* Int
2)

-- -----------------------------------------------------------------------------
-- Low-level reading/writing of bytes

-- | Takes a size and action writing up to @size@ bytes.
--   After the action has run advance the index to the buffer
--   by size bytes.
putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim h :: BinHandle
h@(BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r) Int
size Ptr Word8 -> IO ()
f = do
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ix forall a. Num a => a -> a -> a
+ Int
size forall a. Ord a => a -> a -> Bool
> Int
sz) forall a b. (a -> b) -> a -> b
$
    BinHandle -> Int -> IO ()
expandBin BinHandle
h (Int
ix forall a. Num a => a -> a -> a
+ Int
size)
  BinArray
arr <- forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr BinArray
arr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
op -> Ptr Word8 -> IO ()
f (Ptr Word8
op forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ix)
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r (Int
ix forall a. Num a => a -> a -> a
+ Int
size)

-- -- | Similar to putPrim but advances the index by the actual number of
-- -- bytes written.
-- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO ()
-- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do
--   ix <- readFastMutInt ix_r
--   sz <- readFastMutInt sz_r
--   when (ix + size > sz) $
--     expandBin h (ix + size)
--   arr <- readIORef arr_r
--   written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)
--   writeFastMutInt ix_r (ix + written)

getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim :: forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim (BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r) Int
size Ptr Word8 -> IO a
f = do
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ix forall a. Num a => a -> a -> a
+ Int
size forall a. Ord a => a -> a -> Bool
> Int
sz) forall a b. (a -> b) -> a -> b
$
      forall a. IOError -> IO a
ioError (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
eofErrorType String
"Data.Binary.getPrim" forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
  BinArray
arr <- forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  a
w <- forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr BinArray
arr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> IO a
f (Ptr Word8
p forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ix)
    -- This is safe WRT #17760 as we we guarantee that the above line doesn't
    -- diverge
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r (Int
ix forall a. Num a => a -> a -> a
+ Int
size)
  forall (m :: * -> *) a. Monad m => a -> m a
return a
w

putWord8 :: BinHandle -> Word8 -> IO ()
putWord8 :: BinHandle -> Word8 -> IO ()
putWord8 BinHandle
h !Word8
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h Int
1 (\Ptr Word8
op -> forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
op Word8
w)

getWord8 :: BinHandle -> IO Word8
getWord8 :: BinHandle -> IO Word8
getWord8 BinHandle
h = forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h Int
1 forall a. Storable a => Ptr a -> IO a
peek

putWord16 :: BinHandle -> Word16 -> IO ()
putWord16 :: BinHandle -> Word16 -> IO ()
putWord16 BinHandle
h Word16
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h Int
2 (\Ptr Word8
op -> do
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w forall a. Bits a => a -> Int -> a
`shiftR` Int
8))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
1 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w forall a. Bits a => a -> a -> a
.&. Word16
0xFF))
  )

getWord16 :: BinHandle -> IO Word16
getWord16 :: BinHandle -> IO Word16
getWord16 BinHandle
h = forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h Int
2 (\Ptr Word8
op -> do
  Word16
w0 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
0
  Word16
w1 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
1
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Word16
w0 forall a. Bits a => a -> Int -> a
`shiftL` Int
8 forall a. Bits a => a -> a -> a
.|. Word16
w1
  )

putWord32 :: BinHandle -> Word32 -> IO ()
putWord32 :: BinHandle -> Word32 -> IO ()
putWord32 BinHandle
h Word32
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h Int
4 (\Ptr Word8
op -> do
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w forall a. Bits a => a -> Int -> a
`shiftR` Int
24))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
1 (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
w forall a. Bits a => a -> Int -> a
`shiftR` Int
16) forall a. Bits a => a -> a -> a
.&. Word32
0xFF))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
2 (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
w forall a. Bits a => a -> Int -> a
`shiftR` Int
8) forall a. Bits a => a -> a -> a
.&. Word32
0xFF))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
3 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w forall a. Bits a => a -> a -> a
.&. Word32
0xFF))
  )

getWord32 :: BinHandle -> IO Word32
getWord32 :: BinHandle -> IO Word32
getWord32 BinHandle
h = forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h Int
4 (\Ptr Word8
op -> do
  Word32
w0 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
0
  Word32
w1 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
1
  Word32
w2 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
2
  Word32
w3 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
3

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (Word32
w0 forall a. Bits a => a -> Int -> a
`shiftL` Int
24) forall a. Bits a => a -> a -> a
.|.
            (Word32
w1 forall a. Bits a => a -> Int -> a
`shiftL` Int
16) forall a. Bits a => a -> a -> a
.|.
            (Word32
w2 forall a. Bits a => a -> Int -> a
`shiftL` Int
8)  forall a. Bits a => a -> a -> a
.|.
            Word32
w3
  )

putWord64 :: BinHandle -> Word64 -> IO ()
putWord64 :: BinHandle -> Word64 -> IO ()
putWord64 BinHandle
h Word64
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h Int
8 (\Ptr Word8
op -> do
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
56))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
1 (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
48) forall a. Bits a => a -> a -> a
.&. Word64
0xFF))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
2 (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
40) forall a. Bits a => a -> a -> a
.&. Word64
0xFF))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
3 (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
32) forall a. Bits a => a -> a -> a
.&. Word64
0xFF))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
4 (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
24) forall a. Bits a => a -> a -> a
.&. Word64
0xFF))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
5 (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
16) forall a. Bits a => a -> a -> a
.&. Word64
0xFF))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
6 (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
8) forall a. Bits a => a -> a -> a
.&. Word64
0xFF))
  forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
op Int
7 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w forall a. Bits a => a -> a -> a
.&. Word64
0xFF))
  )

getWord64 :: BinHandle -> IO Word64
getWord64 :: BinHandle -> IO Word64
getWord64 BinHandle
h = forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h Int
8 (\Ptr Word8
op -> do
  Word64
w0 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
0
  Word64
w1 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
1
  Word64
w2 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
2
  Word64
w3 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
3
  Word64
w4 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
4
  Word64
w5 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
5
  Word64
w6 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
6
  Word64
w7 <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
op Int
7

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (Word64
w0 forall a. Bits a => a -> Int -> a
`shiftL` Int
56) forall a. Bits a => a -> a -> a
.|.
            (Word64
w1 forall a. Bits a => a -> Int -> a
`shiftL` Int
48) forall a. Bits a => a -> a -> a
.|.
            (Word64
w2 forall a. Bits a => a -> Int -> a
`shiftL` Int
40) forall a. Bits a => a -> a -> a
.|.
            (Word64
w3 forall a. Bits a => a -> Int -> a
`shiftL` Int
32) forall a. Bits a => a -> a -> a
.|.
            (Word64
w4 forall a. Bits a => a -> Int -> a
`shiftL` Int
24) forall a. Bits a => a -> a -> a
.|.
            (Word64
w5 forall a. Bits a => a -> Int -> a
`shiftL` Int
16) forall a. Bits a => a -> a -> a
.|.
            (Word64
w6 forall a. Bits a => a -> Int -> a
`shiftL` Int
8)  forall a. Bits a => a -> a -> a
.|.
            Word64
w7
  )

putByte :: BinHandle -> Word8 -> IO ()
putByte :: BinHandle -> Word8 -> IO ()
putByte BinHandle
bh !Word8
w = BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh Word8
w

getByte :: BinHandle -> IO Word8
getByte :: BinHandle -> IO Word8
getByte BinHandle
h = BinHandle -> IO Word8
getWord8 BinHandle
h

-- -----------------------------------------------------------------------------
-- Encode numbers in LEB128 encoding.
-- Requires one byte of space per 7 bits of data.
--
-- There are signed and unsigned variants.
-- Do NOT use the unsigned one for signed values, at worst it will
-- result in wrong results, at best it will lead to bad performance
-- when coercing negative values to an unsigned type.
--
-- We mark them as SPECIALIZE as it's extremely critical that they get specialized
-- to their specific types.
--
-- TODO: Each use of putByte performs a bounds check,
--       we should use putPrimMax here. However it's quite hard to return
--       the number of bytes written into putPrimMax without allocating an
--       Int for it, while the code below does not allocate at all.
--       So we eat the cost of the bounds check instead of increasing allocations
--       for now.

-- Unsigned numbers
{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-}
{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-}
{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-}
{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-}
{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-}
{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-}
{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-}
{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-}
putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()
putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()
putULEB128 BinHandle
bh a
w =
#if defined(DEBUG)
    (if w < 0 then panic "putULEB128: Signed number" else id) $
#endif
    a -> IO ()
go a
w
  where
    go :: a -> IO ()
    go :: a -> IO ()
go a
w
      | a
w forall a. Ord a => a -> a -> Bool
<= (a
127 :: a)
      = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w :: Word8)
      | Bool
otherwise = do
        -- bit 7 (8th bit) indicates more to come.
        let !byte :: Word8
byte = forall a. Bits a => a -> Int -> a
setBit (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w) Int
7 :: Word8
        BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
byte
        a -> IO ()
go (a
w forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
7)

{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-}
{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-}
{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-}
{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-}
{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-}
{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-}
{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-}
{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-}
getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a
getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a
getULEB128 BinHandle
bh =
    Int -> a -> IO a
go Int
0 a
0
  where
    go :: Int -> a -> IO a
    go :: Int -> a -> IO a
go Int
shift a
w = do
        Word8
b <- BinHandle -> IO Word8
getByte BinHandle
bh
        let !hasMore :: Bool
hasMore = forall a. Bits a => a -> Int -> Bool
testBit Word8
b Int
7
        let !val :: a
val = a
w forall a. Bits a => a -> a -> a
.|. ((forall a. Bits a => a -> Int -> a
clearBit (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b) Int
7) forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
shift) :: a
        if Bool
hasMore
            then do
                Int -> a -> IO a
go (Int
shiftforall a. Num a => a -> a -> a
+Int
7) a
val
            else
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! a
val

-- Signed numbers
{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-}
{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-}
{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-}
{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-}
{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-}
{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-}
{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-}
{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-}
putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()
putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()
putSLEB128 BinHandle
bh a
initial = a -> IO ()
go a
initial
  where
    go :: a -> IO ()
    go :: a -> IO ()
go a
val = do
        let !byte :: Word8
byte = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bits a => a -> Int -> a
clearBit a
val Int
7) :: Word8
        let !val' :: a
val' = a
val forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
7
        let !signBit :: Bool
signBit = forall a. Bits a => a -> Int -> Bool
testBit Word8
byte Int
6
        let !done :: Bool
done =
                -- Unsigned value, val' == 0 and last value can
                -- be discriminated from a negative number.
                ((a
val' forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
signBit) Bool -> Bool -> Bool
||
                -- Signed value,
                 (a
val' forall a. Eq a => a -> a -> Bool
== -a
1 Bool -> Bool -> Bool
&& Bool
signBit))

        let !byte' :: Word8
byte' = if Bool
done then Word8
byte else forall a. Bits a => a -> Int -> a
setBit Word8
byte Int
7
        BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
byte'

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done forall a b. (a -> b) -> a -> b
$ a -> IO ()
go a
val'

{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-}
{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-}
{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-}
{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-}
{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-}
{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-}
{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-}
{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-}
getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a
getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a
getSLEB128 BinHandle
bh = do
    (a
val,Int
shift,Bool
signed) <- Int -> a -> IO (a, Int, Bool)
go Int
0 a
0
    if Bool
signed Bool -> Bool -> Bool
&& (Int
shift forall a. Ord a => a -> a -> Bool
< forall b. FiniteBits b => b -> Int
finiteBitSize a
val )
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ((forall a. Bits a => a -> a
complement a
0 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
shift) forall a. Bits a => a -> a -> a
.|. a
val)
        else forall (m :: * -> *) a. Monad m => a -> m a
return a
val
    where
        go :: Int -> a -> IO (a,Int,Bool)
        go :: Int -> a -> IO (a, Int, Bool)
go Int
shift a
val = do
            Word8
byte <- BinHandle -> IO Word8
getByte BinHandle
bh
            let !byteVal :: a
byteVal = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bits a => a -> Int -> a
clearBit Word8
byte Int
7) :: a
            let !val' :: a
val' = a
val forall a. Bits a => a -> a -> a
.|. (a
byteVal forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
shift)
            let !more :: Bool
more = forall a. Bits a => a -> Int -> Bool
testBit Word8
byte Int
7
            let !shift' :: Int
shift' = Int
shiftforall a. Num a => a -> a -> a
+Int
7
            if Bool
more
                then Int -> a -> IO (a, Int, Bool)
go (Int
shift') a
val'
                else do
                    let !signed :: Bool
signed = forall a. Bits a => a -> Int -> Bool
testBit Word8
byte Int
6
                    forall (m :: * -> *) a. Monad m => a -> m a
return (a
val',Int
shift',Bool
signed)

-- -----------------------------------------------------------------------------
-- Fixed length encoding instances

-- Sometimes words are used to represent a certain bit pattern instead
-- of a number. Using FixedLengthEncoding we will write the pattern as
-- is to the interface file without the variable length encoding we usually
-- apply.

-- | Encode the argument in it's full length. This is different from many default
-- binary instances which make no guarantee about the actual encoding and
-- might do things use variable length encoding.
newtype FixedLengthEncoding a = FixedLengthEncoding { forall a. FixedLengthEncoding a -> a
unFixedLength :: a }

instance Binary (FixedLengthEncoding Word8) where
  put_ :: BinHandle -> FixedLengthEncoding Word8 -> IO ()
put_ BinHandle
h (FixedLengthEncoding Word8
x) = BinHandle -> Word8 -> IO ()
putByte BinHandle
h Word8
x
  get :: BinHandle -> IO (FixedLengthEncoding Word8)
get BinHandle
h = forall a. a -> FixedLengthEncoding a
FixedLengthEncoding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Word8
getByte BinHandle
h

instance Binary (FixedLengthEncoding Word16) where
  put_ :: BinHandle -> FixedLengthEncoding Word16 -> IO ()
put_ BinHandle
h (FixedLengthEncoding Word16
x) = BinHandle -> Word16 -> IO ()
putWord16 BinHandle
h Word16
x
  get :: BinHandle -> IO (FixedLengthEncoding Word16)
get BinHandle
h = forall a. a -> FixedLengthEncoding a
FixedLengthEncoding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Word16
getWord16 BinHandle
h

instance Binary (FixedLengthEncoding Word32) where
  put_ :: BinHandle -> FixedLengthEncoding Word32 -> IO ()
put_ BinHandle
h (FixedLengthEncoding Word32
x) = BinHandle -> Word32 -> IO ()
putWord32 BinHandle
h Word32
x
  get :: BinHandle -> IO (FixedLengthEncoding Word32)
get BinHandle
h = forall a. a -> FixedLengthEncoding a
FixedLengthEncoding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Word32
getWord32 BinHandle
h

instance Binary (FixedLengthEncoding Word64) where
  put_ :: BinHandle -> FixedLengthEncoding Word64 -> IO ()
put_ BinHandle
h (FixedLengthEncoding Word64
x) = BinHandle -> Word64 -> IO ()
putWord64 BinHandle
h Word64
x
  get :: BinHandle -> IO (FixedLengthEncoding Word64)
get BinHandle
h = forall a. a -> FixedLengthEncoding a
FixedLengthEncoding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Word64
getWord64 BinHandle
h

-- -----------------------------------------------------------------------------
-- Primitive Word writes

instance Binary Word8 where
  put_ :: BinHandle -> Word8 -> IO ()
put_ BinHandle
bh !Word8
w = BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh Word8
w
  get :: BinHandle -> IO Word8
get  = BinHandle -> IO Word8
getWord8

instance Binary Word16 where
  put_ :: BinHandle -> Word16 -> IO ()
put_ = forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()
putULEB128
  get :: BinHandle -> IO Word16
get  = forall a. (Integral a, FiniteBits a) => BinHandle -> IO a
getULEB128

instance Binary Word32 where
  put_ :: BinHandle -> Word32 -> IO ()
put_ = forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()
putULEB128
  get :: BinHandle -> IO Word32
get  = forall a. (Integral a, FiniteBits a) => BinHandle -> IO a
getULEB128

instance Binary Word64 where
  put_ :: BinHandle -> Word64 -> IO ()
put_ = forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO ()
putULEB128
  get :: BinHandle -> IO Word64
get = forall a. (Integral a, FiniteBits a) => BinHandle -> IO a
getULEB128

-- -----------------------------------------------------------------------------
-- Primitive Int writes

instance Binary Int8 where
  put_ :: BinHandle -> Int8 -> IO ()
put_ BinHandle
h Int8
w = forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
w :: Word8)
  get :: BinHandle -> IO Int8
get BinHandle
h    = do Word8
w <- forall a. Binary a => BinHandle -> IO a
get BinHandle
h; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w::Word8))

instance Binary Int16 where
  put_ :: BinHandle -> Int16 -> IO ()
put_ = forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()
putSLEB128
  get :: BinHandle -> IO Int16
get = forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a
getSLEB128

instance Binary Int32 where
  put_ :: BinHandle -> Int32 -> IO ()
put_ = forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()
putSLEB128
  get :: BinHandle -> IO Int32
get = forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a
getSLEB128

instance Binary Int64 where
  put_ :: BinHandle -> Int64 -> IO ()
put_ BinHandle
h Int64
w = forall a. (Integral a, Bits a) => BinHandle -> a -> IO ()
putSLEB128 BinHandle
h Int64
w
  get :: BinHandle -> IO Int64
get BinHandle
h    = forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a
getSLEB128 BinHandle
h

-- -----------------------------------------------------------------------------
-- Instances for standard types

instance Binary () where
    put_ :: BinHandle -> () -> IO ()
put_ BinHandle
_ () = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    get :: BinHandle -> IO ()
get  BinHandle
_    = forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance Binary Bool where
    put_ :: BinHandle -> Bool -> IO ()
put_ BinHandle
bh Bool
b = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum Bool
b))
    get :: BinHandle -> IO Bool
get  BinHandle
bh   = do Word8
x <- BinHandle -> IO Word8
getWord8 BinHandle
bh; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall a. Enum a => Int -> a
toEnum (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x))

instance Binary Char where
    put_ :: BinHandle -> Char -> IO ()
put_  BinHandle
bh Char
c = forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) :: Word32)
    get :: BinHandle -> IO Char
get  BinHandle
bh   = do Word32
x <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
x :: Word32)))

instance Binary Int where
    put_ :: BinHandle -> Int -> IO ()
put_ BinHandle
bh Int
i = forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i :: Int64)
    get :: BinHandle -> IO Int
get  BinHandle
bh = do
        Int64
x <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
x :: Int64))

instance Binary a => Binary [a] where
    put_ :: BinHandle -> [a] -> IO ()
put_ BinHandle
bh [a]
l = do
        let len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l
        forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
len
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh) [a]
l
    get :: BinHandle -> IO [a]
get BinHandle
bh = do
        Int
len <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int -- Int is variable length encoded so only
                                -- one byte for small lists.
        let loop :: Int -> IO [a]
loop Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
            loop Int
n = do a
a <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; [a]
as <- Int -> IO [a]
loop (Int
nforall a. Num a => a -> a -> a
-Int
1); forall (m :: * -> *) a. Monad m => a -> m a
return (a
aforall a. a -> [a] -> [a]
:[a]
as)
        Int -> IO [a]
loop Int
len

instance (Ix a, Binary a, Binary b) => Binary (Array a b) where
    put_ :: BinHandle -> Array a b -> IO ()
put_ BinHandle
bh Array a b
arr = do
        forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> (i, i)
bounds Array a b
arr
        forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> [e]
elems Array a b
arr
    get :: BinHandle -> IO (Array a b)
get BinHandle
bh = do
        (a, a)
bounds <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        [b]
xs <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (a, a)
bounds [b]
xs

instance (Binary a, Binary b) => Binary (a,b) where
    put_ :: BinHandle -> (a, b) -> IO ()
put_ BinHandle
bh (a
a,b
b) = do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b
    get :: BinHandle -> IO (a, b)
get BinHandle
bh        = do a
a <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                       b
b <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                       forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b)

instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
    put_ :: BinHandle -> (a, b, c) -> IO ()
put_ BinHandle
bh (a
a,b
b,c
c) = do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh c
c
    get :: BinHandle -> IO (a, b, c)
get BinHandle
bh          = do a
a <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                         b
b <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                         c
c <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                         forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c)

instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
    put_ :: BinHandle -> (a, b, c, d) -> IO ()
put_ BinHandle
bh (a
a,b
b,c
c,d
d) = do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh c
c; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh d
d
    get :: BinHandle -> IO (a, b, c, d)
get BinHandle
bh            = do a
a <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                           b
b <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                           c
c <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                           d
d <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                           forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d)

instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where
    put_ :: BinHandle -> (a, b, c, d, e) -> IO ()
put_ BinHandle
bh (a
a,b
b,c
c,d
d, e
e) = do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh c
c; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh d
d; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh e
e;
    get :: BinHandle -> IO (a, b, c, d, e)
get BinHandle
bh               = do a
a <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                              b
b <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                              c
c <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                              d
d <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                              e
e <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                              forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e)

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where
    put_ :: BinHandle -> (a, b, c, d, e, f) -> IO ()
put_ BinHandle
bh (a
a,b
b,c
c,d
d, e
e, f
f) = do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh c
c; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh d
d; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh e
e; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh f
f;
    get :: BinHandle -> IO (a, b, c, d, e, f)
get BinHandle
bh                  = do a
a <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 b
b <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 c
c <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 d
d <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 e
e <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 f
f <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
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
    put_ :: BinHandle -> (a, b, c, d, e, f, g) -> IO ()
put_ BinHandle
bh (a
a,b
b,c
c,d
d,e
e,f
f,g
g) = do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh c
c; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh d
d; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh e
e; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh f
f; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh g
g
    get :: BinHandle -> IO (a, b, c, d, e, f, g)
get BinHandle
bh                  = do a
a <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 b
b <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 c
c <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 d
d <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 e
e <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 f
f <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 g
g <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                 forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b,c
c,d
d,e
e,f
f,g
g)

instance Binary a => Binary (Maybe a) where
    put_ :: BinHandle -> Maybe a -> IO ()
put_ BinHandle
bh Maybe a
Nothing  = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
    put_ BinHandle
bh (Just a
a) = do BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a
    get :: BinHandle -> IO (Maybe a)
get BinHandle
bh           = do Word8
h <- BinHandle -> IO Word8
getWord8 BinHandle
bh
                          case Word8
h of
                            Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                            Word8
_ -> do a
x <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)

instance (Binary a, Binary b) => Binary (Either a b) where
    put_ :: BinHandle -> Either a b -> IO ()
put_ BinHandle
bh (Left  a
a) = do BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a
    put_ BinHandle
bh (Right b
b) = do BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh b
b
    get :: BinHandle -> IO (Either a b)
get BinHandle
bh            = do Word8
h <- BinHandle -> IO Word8
getWord8 BinHandle
bh
                           case Word8
h of
                             Word8
0 -> do a
a <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left a
a)
                             Word8
_ -> do b
b <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right b
b)

instance Binary UTCTime where
    put_ :: BinHandle -> UTCTime -> IO ()
put_ BinHandle
bh UTCTime
u = do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (UTCTime -> Day
utctDay UTCTime
u)
                   forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (UTCTime -> DiffTime
utctDayTime UTCTime
u)
    get :: BinHandle -> IO UTCTime
get BinHandle
bh = do Day
day <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                DiffTime
dayTime <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ UTCTime { utctDay :: Day
utctDay = Day
day, utctDayTime :: DiffTime
utctDayTime = DiffTime
dayTime }

instance Binary Day where
    put_ :: BinHandle -> Day -> IO ()
put_ BinHandle
bh Day
d = forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Day -> Integer
toModifiedJulianDay Day
d)
    get :: BinHandle -> IO Day
get BinHandle
bh = do Integer
i <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModifiedJulianDay { toModifiedJulianDay :: Integer
toModifiedJulianDay = Integer
i }

instance Binary DiffTime where
    put_ :: BinHandle -> DiffTime -> IO ()
put_ BinHandle
bh DiffTime
dt = forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall a. Real a => a -> Rational
toRational DiffTime
dt)
    get :: BinHandle -> IO DiffTime
get BinHandle
bh = do Rational
r <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational Rational
r

{-
Finally - a reasonable portable Integer instance.

We used to encode values in the Int32 range as such,
falling back to a string of all things. In either case
we stored a tag byte to discriminate between the two cases.

This made some sense as it's highly portable but also not very
efficient.

However GHC stores a surprisingly large number off large Integer
values. In the examples looked at between 25% and 50% of Integers
serialized were outside of the Int32 range.

Consider a valie like `2724268014499746065`, some sort of hash
actually generated by GHC.
In the old scheme this was encoded as a list of 19 chars. This
gave a size of 77 Bytes, one for the length of the list and 76
since we encode chars as Word32 as well.

We can easily do better. The new plan is:

* Start with a tag byte
  * 0 => Int64 (LEB128 encoded)
  * 1 => Negative large interger
  * 2 => Positive large integer
* Followed by the value:
  * Int64 is encoded as usual
  * Large integers are encoded as a list of bytes (Word8).
    We use Data.Bits which defines a bit order independent of the representation.
    Values are stored LSB first.

This means our example value `2724268014499746065` is now only 10 bytes large.
* One byte tag
* One byte for the length of the [Word8] list.
* 8 bytes for the actual date.

The new scheme also does not depend in any way on
architecture specific details.

We still use this scheme even with LEB128 available,
as it has less overhead for truly large numbers. (> maxBound :: Int64)

The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal
-}

instance Binary Integer where
    put_ :: BinHandle -> Integer -> IO ()
put_ BinHandle
bh Integer
i
      | Integer
i forall a. Ord a => a -> a -> Bool
>= Integer
lo64 Bool -> Bool -> Bool
&& Integer
i forall a. Ord a => a -> a -> Bool
<= Integer
hi64 = do
          BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh Word8
0
          forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Int64)
      | Bool
otherwise = do
          if Integer
i forall a. Ord a => a -> a -> Bool
< Integer
0
            then BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh Word8
1
            else BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh Word8
2
          forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Integer -> [Word8]
unroll forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
abs Integer
i)
      where
        lo64 :: Integer
lo64 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
minBound :: Int64)
        hi64 :: Integer
hi64 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int64)
    get :: BinHandle -> IO Integer
get BinHandle
bh = do
      Word8
int_kind <- BinHandle -> IO Word8
getWord8 BinHandle
bh
      case Word8
int_kind of
        Word8
0 -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int64)
        -- Large integer
        Word8
1 -> forall a. Num a => a -> a
negate forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> IO Integer
getInt
        Word8
2 -> IO Integer
getInt
        Word8
_ -> forall a. String -> a
panic String
"Binary Integer - Invalid byte"
        where
          getInt :: IO Integer
          getInt :: IO Integer
getInt = [Word8] -> Integer
roll forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO [Word8])

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

roll :: [Word8] -> Integer
roll :: [Word8] -> Integer
roll   = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a} {a}. (Bits a, Integral a, Num a) => a -> a -> a
unstep Integer
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  where
    unstep :: a -> a -> a
unstep a
a a
b = a
a forall a. Bits a => a -> Int -> a
`shiftL` Int
8 forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b


    {-
    -- This code is currently commented out.
    -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for
    -- discussion.

    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
    put_ bh (J# s# a#) = do
        putByte bh 1
        put_ bh (I# s#)
        let sz# = sizeofByteArray# a#  -- in *bytes*
        put_ bh (I# sz#)  -- in *bytes*
        putByteArray bh a# sz#

    get bh = do
        b <- getByte bh
        case b of
          0 -> do (I# i#) <- get bh
                  return (S# i#)
          _ -> do (I# s#) <- get bh
                  sz <- get bh
                  (BA a#) <- getByteArray bh sz
                  return (J# s# a#)

putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
putByteArray bh a s# = loop 0#
  where loop n#
           | n# ==# s# = return ()
           | otherwise = do
                putByte bh (indexByteArray a n#)
                loop (n# +# 1#)

getByteArray :: BinHandle -> Int -> IO ByteArray
getByteArray bh (I# sz) = do
  (MBA arr) <- newByteArray sz
  let loop n
           | n ==# sz = return ()
           | otherwise = do
                w <- getByte bh
                writeByteArray arr n w
                loop (n +# 1#)
  loop 0#
  freezeByteArray arr
    -}

{-
data ByteArray = BA ByteArray#
data MBA = MBA (MutableByteArray# RealWorld)

newByteArray :: Int# -> IO MBA
newByteArray sz = IO $ \s ->
  case newByteArray# 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 #) }

writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
writeByteArray arr i (W8# w) = IO $ \s ->
  case writeWord8Array# arr i w s of { s ->
  (# s, () #) }

indexByteArray :: ByteArray# -> Int# -> Word8
indexByteArray a# n# = W8# (indexWord8Array# a# n#)

-}
instance (Binary a) => Binary (Ratio a) where
    put_ :: BinHandle -> Ratio a -> IO ()
put_ BinHandle
bh (a
a :% a
b) = do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
b
    get :: BinHandle -> IO (Ratio a)
get BinHandle
bh = do a
a <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; a
b <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; forall (m :: * -> *) a. Monad m => a -> m a
return (a
a forall a. a -> a -> Ratio a
:% a
b)

-- Instance uses fixed-width encoding to allow inserting
-- Bin placeholders in the stream.
instance Binary (Bin a) where
  put_ :: BinHandle -> Bin a -> IO ()
put_ BinHandle
bh (BinPtr Int
i) = BinHandle -> Word32 -> IO ()
putWord32 BinHandle
bh (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i :: Word32)
  get :: BinHandle -> IO (Bin a)
get BinHandle
bh = do Word32
i <- BinHandle -> IO Word32
getWord32 BinHandle
bh; forall (m :: * -> *) a. Monad m => a -> m a
return (forall {k} (a :: k). Int -> Bin a
BinPtr (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
i :: Word32)))


-- -----------------------------------------------------------------------------
-- Lazy reading/writing

lazyPut :: Binary a => BinHandle -> a -> IO ()
lazyPut :: forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh a
a = do
    -- output the obj with a ptr to skip over it:
    Bin (Bin Any)
pre_a <- forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
pre_a       -- save a slot for the ptr
    forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a           -- dump the object
    Bin Any
q <- forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh     -- q = ptr to after object
    forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
pre_a Bin Any
q    -- fill in slot before a with ptr to q
    forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
q        -- finally carry on writing at q

lazyGet :: Binary a => BinHandle -> IO a
lazyGet :: forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh = do
    Bin Any
p <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh -- a BinPtr
    Bin a
p_a <- forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    a
a <- forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
        -- NB: Use a fresh off_r variable in the child thread, for thread
        -- safety.
        FastMutInt
off_r <- Int -> IO FastMutInt
newFastMutInt Int
0
        forall a. Binary a => BinHandle -> Bin a -> IO a
getAt BinHandle
bh { _off_r :: FastMutInt
_off_r = FastMutInt
off_r } Bin a
p_a
    forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
p -- skip over the object for now
    forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- -----------------------------------------------------------------------------
-- UserData
-- -----------------------------------------------------------------------------

-- | Information we keep around during interface file
-- serialization/deserialization. Namely we keep the functions for serializing
-- and deserializing 'Name's and 'FastString's. We do this because we actually
-- use serialization in two distinct settings,
--
-- * When serializing interface files themselves
--
-- * When computing the fingerprint of an IfaceDecl (which we computing by
--   hashing its Binary serialization)
--
-- These two settings have different needs while serializing Names:
--
-- * Names in interface files are serialized via a symbol table (see Note
--   [Symbol table representation of names] in "GHC.Iface.Binary").
--
-- * During fingerprinting a binding Name is serialized as the OccName and a
--   non-binding Name is serialized as the fingerprint of the thing they
--   represent. See Note [Fingerprinting IfaceDecls] for further discussion.
--
data UserData =
   UserData {
        -- for *deserialising* only:
        UserData -> BinHandle -> IO Name
ud_get_name :: BinHandle -> IO Name,
        UserData -> BinHandle -> IO FastString
ud_get_fs   :: BinHandle -> IO FastString,

        -- for *serialising* only:
        UserData -> BinHandle -> Name -> IO ()
ud_put_nonbinding_name :: BinHandle -> Name -> IO (),
        -- ^ serialize a non-binding 'Name' (e.g. a reference to another
        -- binding).
        UserData -> BinHandle -> Name -> IO ()
ud_put_binding_name :: BinHandle -> Name -> IO (),
        -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl)
        UserData -> BinHandle -> FastString -> IO ()
ud_put_fs   :: BinHandle -> FastString -> IO ()
   }

newReadState :: (BinHandle -> IO Name)   -- ^ how to deserialize 'Name's
             -> (BinHandle -> IO FastString)
             -> UserData
newReadState :: (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState BinHandle -> IO Name
get_name BinHandle -> IO FastString
get_fs
  = UserData { ud_get_name :: BinHandle -> IO Name
ud_get_name = BinHandle -> IO Name
get_name,
               ud_get_fs :: BinHandle -> IO FastString
ud_get_fs   = BinHandle -> IO FastString
get_fs,
               ud_put_nonbinding_name :: BinHandle -> Name -> IO ()
ud_put_nonbinding_name = forall a. String -> a
undef String
"put_nonbinding_name",
               ud_put_binding_name :: BinHandle -> Name -> IO ()
ud_put_binding_name    = forall a. String -> a
undef String
"put_binding_name",
               ud_put_fs :: BinHandle -> FastString -> IO ()
ud_put_fs   = forall a. String -> a
undef String
"put_fs"
             }

newWriteState :: (BinHandle -> Name -> IO ())
                 -- ^ how to serialize non-binding 'Name's
              -> (BinHandle -> Name -> IO ())
                 -- ^ how to serialize binding 'Name's
              -> (BinHandle -> FastString -> IO ())
              -> UserData
newWriteState :: (BinHandle -> Name -> IO ())
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> FastString -> IO ())
-> UserData
newWriteState BinHandle -> Name -> IO ()
put_nonbinding_name BinHandle -> Name -> IO ()
put_binding_name BinHandle -> FastString -> IO ()
put_fs
  = UserData { ud_get_name :: BinHandle -> IO Name
ud_get_name = forall a. String -> a
undef String
"get_name",
               ud_get_fs :: BinHandle -> IO FastString
ud_get_fs   = forall a. String -> a
undef String
"get_fs",
               ud_put_nonbinding_name :: BinHandle -> Name -> IO ()
ud_put_nonbinding_name = BinHandle -> Name -> IO ()
put_nonbinding_name,
               ud_put_binding_name :: BinHandle -> Name -> IO ()
ud_put_binding_name    = BinHandle -> Name -> IO ()
put_binding_name,
               ud_put_fs :: BinHandle -> FastString -> IO ()
ud_put_fs   = BinHandle -> FastString -> IO ()
put_fs
             }

noUserData :: a
noUserData :: forall a. a
noUserData = forall a. String -> a
undef String
"UserData"

undef :: String -> a
undef :: forall a. String -> a
undef String
s = forall a. String -> a
panic (String
"Binary.UserData: no " forall a. [a] -> [a] -> [a]
++ String
s)

---------------------------------------------------------
-- The Dictionary
---------------------------------------------------------

type Dictionary = Array Int FastString -- The dictionary
                                       -- Should be 0-indexed

putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
putDictionary :: BinHandle -> Int -> UniqFM FastString (Int, FastString) -> IO ()
putDictionary BinHandle
bh Int
sz UniqFM FastString (Int, FastString)
dict = do
  forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
sz
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> FastString -> IO ()
putFS BinHandle
bh) (forall i e. Array i e -> [e]
elems (forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,Int
szforall a. Num a => a -> a -> a
-Int
1) (forall key elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM FastString (Int, FastString)
dict)))
    -- It's OK to use nonDetEltsUFM here because the elements have indices
    -- that array uses to create order

getDictionary :: BinHandle -> IO Dictionary
getDictionary :: BinHandle -> IO Dictionary
getDictionary BinHandle
bh = do
  Int
sz <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
  [FastString]
elems <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a. Int -> [a] -> [a]
take Int
sz (forall a. a -> [a]
repeat (BinHandle -> IO FastString
getFS BinHandle
bh)))
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,Int
szforall a. Num a => a -> a -> a
-Int
1) [FastString]
elems)

---------------------------------------------------------
-- The Symbol Table
---------------------------------------------------------

-- On disk, the symbol table is an array of IfExtName, when
-- reading it in we turn it into a SymbolTable.

type SymbolTable = Array Int Name

---------------------------------------------------------
-- Reading and writing FastStrings
---------------------------------------------------------

putFS :: BinHandle -> FastString -> IO ()
putFS :: BinHandle -> FastString -> IO ()
putFS BinHandle
bh FastString
fs = BinHandle -> ByteString -> IO ()
putBS BinHandle
bh forall a b. (a -> b) -> a -> b
$ FastString -> ByteString
bytesFS FastString
fs

getFS :: BinHandle -> IO FastString
getFS :: BinHandle -> IO FastString
getFS BinHandle
bh = do
  Int
l  <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
  forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
bh Int
l (\Ptr Word8
src -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Ptr Word8 -> Int -> FastString
mkFastStringBytes Ptr Word8
src Int
l )

putBS :: BinHandle -> ByteString -> IO ()
putBS :: BinHandle -> ByteString -> IO ()
putBS BinHandle
bh ByteString
bs =
  forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr, Int
l) -> do
    forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
l
    BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
bh Int
l (\Ptr Word8
op -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
BS.memcpy Ptr Word8
op (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr) Int
l)

getBS :: BinHandle -> IO ByteString
getBS :: BinHandle -> IO ByteString
getBS BinHandle
bh = do
  Int
l <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
  Int -> (Ptr Word8 -> IO ()) -> IO ByteString
BS.create Int
l forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dest -> do
    forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
bh Int
l (\Ptr Word8
src -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
BS.memcpy Ptr Word8
dest Ptr Word8
src Int
l)

instance Binary ByteString where
  put_ :: BinHandle -> ByteString -> IO ()
put_ BinHandle
bh ByteString
f = BinHandle -> ByteString -> IO ()
putBS BinHandle
bh ByteString
f
  get :: BinHandle -> IO ByteString
get BinHandle
bh = BinHandle -> IO ByteString
getBS BinHandle
bh

instance Binary FastString where
  put_ :: BinHandle -> FastString -> IO ()
put_ BinHandle
bh FastString
f =
    case BinHandle -> UserData
getUserData BinHandle
bh of
        UserData { ud_put_fs :: UserData -> BinHandle -> FastString -> IO ()
ud_put_fs = BinHandle -> FastString -> IO ()
put_fs } -> BinHandle -> FastString -> IO ()
put_fs BinHandle
bh FastString
f

  get :: BinHandle -> IO FastString
get BinHandle
bh =
    case BinHandle -> UserData
getUserData BinHandle
bh of
        UserData { ud_get_fs :: UserData -> BinHandle -> IO FastString
ud_get_fs = BinHandle -> IO FastString
get_fs } -> BinHandle -> IO FastString
get_fs BinHandle
bh

deriving instance Binary NonDetFastString
deriving instance Binary LexicalFastString

instance Binary Fingerprint where
  put_ :: BinHandle -> Fingerprint -> IO ()
put_ BinHandle
h (Fingerprint Word64
w1 Word64
w2) = do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
h Word64
w1; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
h Word64
w2
  get :: BinHandle -> IO Fingerprint
get  BinHandle
h = do Word64
w1 <- forall a. Binary a => BinHandle -> IO a
get BinHandle
h; Word64
w2 <- forall a. Binary a => BinHandle -> IO a
get BinHandle
h; forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Word64 -> Fingerprint
Fingerprint Word64
w1 Word64
w2)

-- instance Binary FunctionOrData where
--     put_ bh IsFunction = putByte bh 0
--     put_ bh IsData     = putByte bh 1
--     get bh = do
--         h <- getByte bh
--         case h of
--           0 -> return IsFunction
--           1 -> return IsData
--           _ -> panic "Binary FunctionOrData"

-- instance Binary TupleSort where
--     put_ bh BoxedTuple      = putByte bh 0
--     put_ bh UnboxedTuple    = putByte bh 1
--     put_ bh ConstraintTuple = putByte bh 2
--     get bh = do
--       h <- getByte bh
--       case h of
--         0 -> do return BoxedTuple
--         1 -> do return UnboxedTuple
--         _ -> do return ConstraintTuple

-- instance Binary Activation where
--     put_ bh NeverActive = do
--             putByte bh 0
--     put_ bh FinalActive = do
--             putByte bh 1
--     put_ bh AlwaysActive = do
--             putByte bh 2
--     put_ bh (ActiveBefore src aa) = do
--             putByte bh 3
--             put_ bh src
--             put_ bh aa
--     put_ bh (ActiveAfter src ab) = do
--             putByte bh 4
--             put_ bh src
--             put_ bh ab
--     get bh = do
--             h <- getByte bh
--             case h of
--               0 -> do return NeverActive
--               1 -> do return FinalActive
--               2 -> do return AlwaysActive
--               3 -> do src <- get bh
--                       aa <- get bh
--                       return (ActiveBefore src aa)
--               _ -> do src <- get bh
--                       ab <- get bh
--                       return (ActiveAfter src ab)

-- instance Binary InlinePragma where
--     put_ bh (InlinePragma s a b c d) = do
--             put_ bh s
--             put_ bh a
--             put_ bh b
--             put_ bh c
--             put_ bh d

--     get bh = do
--            s <- get bh
--            a <- get bh
--            b <- get bh
--            c <- get bh
--            d <- get bh
--            return (InlinePragma s a b c d)

-- instance Binary RuleMatchInfo where
--     put_ bh FunLike = putByte bh 0
--     put_ bh ConLike = putByte bh 1
--     get bh = do
--             h <- getByte bh
--             if h == 1 then return ConLike
--                       else return FunLike

-- instance Binary InlineSpec where
--     put_ bh NoUserInlinePrag = putByte bh 0
--     put_ bh Inline           = putByte bh 1
--     put_ bh Inlinable        = putByte bh 2
--     put_ bh NoInline         = putByte bh 3

--     get bh = do h <- getByte bh
--                 case h of
--                   0 -> return NoUserInlinePrag
--                   1 -> return Inline
--                   2 -> return Inlinable
--                   _ -> return NoInline

-- instance Binary RecFlag where
--     put_ bh Recursive = do
--             putByte bh 0
--     put_ bh NonRecursive = do
--             putByte bh 1
--     get bh = do
--             h <- getByte bh
--             case h of
--               0 -> do return Recursive
--               _ -> do return NonRecursive

-- instance Binary OverlapMode where
--     put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s
--     put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s
--     put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s
--     put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s
--     put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
--     get bh = do
--         h <- getByte bh
--         case h of
--             0 -> (get bh) >>= \s -> return $ NoOverlap s
--             1 -> (get bh) >>= \s -> return $ Overlaps s
--             2 -> (get bh) >>= \s -> return $ Incoherent s
--             3 -> (get bh) >>= \s -> return $ Overlapping s
--             4 -> (get bh) >>= \s -> return $ Overlappable s
--             _ -> panic ("get OverlapMode" ++ show h)


-- instance Binary OverlapFlag where
--     put_ bh flag = do put_ bh (overlapMode flag)
--                       put_ bh (isSafeOverlap flag)
--     get bh = do
--         h <- get bh
--         b <- get bh
--         return OverlapFlag { overlapMode = h, isSafeOverlap = b }

-- instance Binary FixityDirection where
--     put_ bh InfixL = do
--             putByte bh 0
--     put_ bh InfixR = do
--             putByte bh 1
--     put_ bh InfixN = do
--             putByte bh 2
--     get bh = do
--             h <- getByte bh
--             case h of
--               0 -> do return InfixL
--               1 -> do return InfixR
--               _ -> do return InfixN

-- instance Binary Fixity where
--     put_ bh (Fixity src aa ab) = do
--             put_ bh src
--             put_ bh aa
--             put_ bh ab
--     get bh = do
--           src <- get bh
--           aa <- get bh
--           ab <- get bh
--           return (Fixity src aa ab)

-- instance Binary WarningTxt where
--     put_ bh (WarningTxt s w) = do
--             putByte bh 0
--             put_ bh s
--             put_ bh w
--     put_ bh (DeprecatedTxt s d) = do
--             putByte bh 1
--             put_ bh s
--             put_ bh d

--     get bh = do
--             h <- getByte bh
--             case h of
--               0 -> do s <- get bh
--                       w <- get bh
--                       return (WarningTxt s w)
--               _ -> do s <- get bh
--                       d <- get bh
--                       return (DeprecatedTxt s d)

-- instance Binary StringLiteral where
--   put_ bh (StringLiteral st fs _) = do
--             put_ bh st
--             put_ bh fs
--   get bh = do
--             st <- get bh
--             fs <- get bh
--             return (StringLiteral st fs Nothing)

instance Binary a => Binary (Located a) where
    put_ :: BinHandle -> Located a -> IO ()
put_ BinHandle
bh (L SrcSpan
l a
x) = do
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SrcSpan
l
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
x

    get :: BinHandle -> IO (Located a)
get BinHandle
bh = do
            SrcSpan
l <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            a
x <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpan
l a
x)

instance Binary RealSrcSpan where
  put_ :: BinHandle -> RealSrcSpan -> IO ()
put_ BinHandle
bh RealSrcSpan
ss = do
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
ss)
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
ss)
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
ss)
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
ss)
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
ss)

  get :: BinHandle -> IO RealSrcSpan
get BinHandle
bh = do
            FastString
f <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Int
sl <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Int
sc <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Int
el <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            Int
ec <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
            forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
f Int
sl Int
sc)
                                  (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
f Int
el Int
ec))

instance Binary UnhelpfulSpanReason where
  put_ :: BinHandle -> UnhelpfulSpanReason -> IO ()
put_ BinHandle
bh UnhelpfulSpanReason
r = case UnhelpfulSpanReason
r of
    UnhelpfulSpanReason
UnhelpfulNoLocationInfo -> BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
    UnhelpfulSpanReason
UnhelpfulWiredIn        -> BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
    UnhelpfulSpanReason
UnhelpfulInteractive    -> BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2
    UnhelpfulSpanReason
UnhelpfulGenerated      -> BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
3
    UnhelpfulOther FastString
fs       -> BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
4 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh FastString
fs

  get :: BinHandle -> IO UnhelpfulSpanReason
get BinHandle
bh = do
    Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
    case Word8
h of
      Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return UnhelpfulSpanReason
UnhelpfulNoLocationInfo
      Word8
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return UnhelpfulSpanReason
UnhelpfulWiredIn
      Word8
2 -> forall (m :: * -> *) a. Monad m => a -> m a
return UnhelpfulSpanReason
UnhelpfulInteractive
      Word8
3 -> forall (m :: * -> *) a. Monad m => a -> m a
return UnhelpfulSpanReason
UnhelpfulGenerated
      Word8
_ -> FastString -> UnhelpfulSpanReason
UnhelpfulOther forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

instance Binary SrcSpan where
  put_ :: BinHandle -> SrcSpan -> IO ()
put_ BinHandle
bh (RealSrcSpan RealSrcSpan
ss Maybe BufSpan
_sb) = do
          BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
          -- BufSpan doesn't ever get serialised because the positions depend
          -- on build location.
          forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh RealSrcSpan
ss

  put_ BinHandle
bh (UnhelpfulSpan UnhelpfulSpanReason
s) = do
          BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
          forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh UnhelpfulSpanReason
s

  get :: BinHandle -> IO SrcSpan
get BinHandle
bh = do
          Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
          case Word8
h of
            Word8
0 -> do RealSrcSpan
ss <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                    forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
ss forall a. Maybe a
Nothing)
            Word8
_ -> do UnhelpfulSpanReason
s <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                    forall (m :: * -> *) a. Monad m => a -> m a
return (UnhelpfulSpanReason -> SrcSpan
UnhelpfulSpan UnhelpfulSpanReason
s)