{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UnboxedTuples #-}

{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
-- 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, RelBin(..), getRelBin,
    {-class-} Binary(..),
    {-type-}  ReadBinHandle, WriteBinHandle,
    SymbolTable, Dictionary,

   BinData(..), dataHandle, handleData,
   unsafeUnpackBinBuffer,

   openBinMem,
--   closeBin,

   seekBinWriter,
   seekBinReader,
   seekBinReaderRel,
   tellBinReader,
   tellBinWriter,
   castBin,
   withBinBuffer,
   freezeWriteHandle,
   shrinkBinBuffer,
   thawReadHandle,

   foldGet, foldGet',

   writeBinMem,
   readBinMem,
   readBinMemN,

   putAt, getAt,
   putAtRel,
   forwardPut, forwardPut_, forwardGet,
   forwardPutRel, forwardPutRel_, forwardGetRel,

   -- * For writing instances
   putByte,
   getByte,
   putByteString,
   getByteString,

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

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

   -- * Lazy Binary I/O
   lazyGet,
   lazyPut,
   lazyGet',
   lazyPut',
   lazyGetMaybe,
   lazyPutMaybe,

   -- * User data
   ReaderUserData, getReaderUserData, setReaderUserData, noReaderUserData,
   WriterUserData, getWriterUserData, setWriterUserData, noWriterUserData,
   mkWriterUserData, mkReaderUserData,
   newReadState, newWriteState,
   addReaderToUserData, addWriterToUserData,
   findUserDataReader, findUserDataWriter,
   -- * Binary Readers & Writers
   BinaryReader(..), BinaryWriter(..),
   mkWriter, mkReader,
   SomeBinaryReader, SomeBinaryWriter,
   mkSomeBinaryReader, mkSomeBinaryWriter,
   -- * Tables
   ReaderTable(..),
   WriterTable(..),
   -- * String table ("dictionary")
   initFastStringReaderTable, initFastStringWriterTable,
   putDictionary, getDictionary, putFS,
   FSTable(..), getDictFastString, putDictFastString,
   -- * Generic deduplication table
   GenericSymbolTable(..),
   initGenericSymbolTable,
   getGenericSymtab, putGenericSymTab,
   getGenericSymbolTable, putGenericSymbolTable,
   -- * Newtype wrappers
   BinSpan(..), BinSrcSpan(..), BinLocated(..),
   -- * Newtypes for types that have canonically more than one valid encoding
   BindingName(..),
   simpleBindingNameWriter,
   simpleBindingNameReader,
   FullBinData(..), freezeBinHandle, thawBinHandle, putFullBinData,
   BinArray,
  ) where

import GHC.Prelude

import Language.Haskell.Syntax.Module.Name (ModuleName(..))

import {-# SOURCE #-} GHC.Types.Name (Name)
import GHC.Data.FastString
import GHC.Data.TrieMap
import GHC.Utils.Panic.Plain
import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
import GHC.Utils.Fingerprint
import GHC.Types.SrcLoc
import GHC.Types.Unique
import qualified GHC.Data.Strict as Strict
import GHC.Utils.Outputable( JoinPointHood(..) )

import Control.DeepSeq
import Control.Monad            ( when, (<$!>), unless, forM_, void )
import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
import Data.Array
import Data.Array.IO
import Data.Array.Unsafe
import Data.ByteString (ByteString, copy)
import Data.Coerce
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe   as BS
import Data.IORef
import Data.Char                ( ord, chr )
import Data.List.NonEmpty       ( NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy
import Data.Set                 ( Set )
import qualified Data.Set as Set
import Data.Time
import Data.List (unfoldr)
import System.IO as IO
import System.IO.Unsafe         ( unsafeInterleaveIO )
import System.IO.Error          ( mkIOError, eofErrorType )
import Type.Reflection          ( Typeable, SomeTypeRep(..) )
import qualified Type.Reflection as Refl
import GHC.Real                 ( Ratio(..) )
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
#if MIN_VERSION_base(4,15,0)
import GHC.ForeignPtr           ( unsafeWithForeignPtr )
#endif

import Unsafe.Coerce (unsafeCoerce)

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
_) = Int -> ()
forall a. NFData a => a -> ()
rnf Int
sz

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

dataHandle :: BinData -> IO ReadBinHandle
dataHandle :: BinData -> IO ReadBinHandle
dataHandle (BinData Int
size BinArray
bin) = do
  ixr <- Int -> IO FastMutInt
newFastMutInt Int
0
  return (ReadBinMem noReaderUserData ixr size bin)

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

---------------------------------------------------------------
-- FullBinData
---------------------------------------------------------------

-- | 'FullBinData' stores a slice to a 'BinArray'.
--
-- It requires less memory than 'ReadBinHandle', and can be constructed from
-- a 'ReadBinHandle' via 'freezeBinHandle' and turned back into a
-- 'ReadBinHandle' using 'thawBinHandle'.
-- Additionally, the byte array slice can be put into a 'WriteBinHandle' without extra
-- conversions via 'putFullBinData'.
data FullBinData = FullBinData
  { FullBinData -> ReaderUserData
fbd_readerUserData :: ReaderUserData
  -- ^ 'ReaderUserData' that can be used to resume reading.
  , FullBinData -> Int
fbd_off_s :: {-# UNPACK #-} !Int
  -- ^ start offset
  , FullBinData -> Int
fbd_off_e :: {-# UNPACK #-} !Int
  -- ^ end offset
  , FullBinData -> Int
fbd_size :: {-# UNPACK #-} !Int
  -- ^ total buffer size
  , FullBinData -> BinArray
fbd_buffer :: {-# UNPACK #-} !BinArray
  }

-- Equality and Ord assume that two distinct buffers are different, even if they compare the same things.
instance Eq FullBinData where
  (FullBinData ReaderUserData
_ Int
b Int
c Int
d BinArray
e) == :: FullBinData -> FullBinData -> Bool
== (FullBinData ReaderUserData
_ Int
b1 Int
c1 Int
d1 BinArray
e1) = Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b1 Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c1 Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
d1 Bool -> Bool -> Bool
&& BinArray
e BinArray -> BinArray -> Bool
forall a. Eq a => a -> a -> Bool
== BinArray
e1

instance Ord FullBinData where
  compare :: FullBinData -> FullBinData -> Ordering
compare (FullBinData ReaderUserData
_ Int
b Int
c Int
d BinArray
e) (FullBinData ReaderUserData
_ Int
b1 Int
c1 Int
d1 BinArray
e1) =
    Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
b Int
b1 Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
c Int
c1 Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
d Int
d1 Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` BinArray -> BinArray -> Ordering
forall a. Ord a => a -> a -> Ordering
compare BinArray
e BinArray
e1

-- | Write the 'FullBinData' slice into the 'WriteBinHandle'.
putFullBinData :: WriteBinHandle -> FullBinData -> IO ()
putFullBinData :: WriteBinHandle -> FullBinData -> IO ()
putFullBinData WriteBinHandle
bh (FullBinData ReaderUserData
_ Int
o1 Int
o2 Int
_sz BinArray
ba) = do
  let sz :: Int
sz = Int
o2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
o1
  WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim WriteBinHandle
bh Int
sz ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dest ->
    BinArray -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr (BinArray
ba BinArray -> Int -> BinArray
forall a b. ForeignPtr a -> Int -> ForeignPtr b
`plusForeignPtr` Int
o1) ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
orig ->
    Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
dest Ptr Word8
orig Int
sz

-- | Freeze a 'ReadBinHandle' and a start index into a 'FullBinData'.
--
-- 'FullBinData' stores a slice starting from the 'Bin a' location to the current
-- offset of the 'ReadBinHandle'.
freezeBinHandle :: ReadBinHandle -> Bin a -> IO FullBinData
freezeBinHandle :: forall {k} (a :: k). ReadBinHandle -> Bin a -> IO FullBinData
freezeBinHandle (ReadBinMem ReaderUserData
user_data FastMutInt
ixr Int
sz BinArray
binr) (BinPtr Int
start) = do
  ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ixr
  pure (FullBinData user_data start ix sz binr)

-- | Turn the 'FullBinData' into a 'ReadBinHandle', setting the 'ReadBinHandle'
-- offset to the start of the 'FullBinData' and restore the 'ReaderUserData' that was
-- obtained from 'freezeBinHandle'.
thawBinHandle :: FullBinData -> IO ReadBinHandle
thawBinHandle :: FullBinData -> IO ReadBinHandle
thawBinHandle (FullBinData ReaderUserData
user_data Int
ix Int
_end Int
sz BinArray
ba) = do
  ixr <- Int -> IO FastMutInt
newFastMutInt Int
ix
  return $ ReadBinMem user_data ixr sz ba

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

-- | A write-only handle that can be used to serialise binary data into a buffer.
--
-- The buffer is an unboxed binary array.
data WriteBinHandle
  = WriteBinMem {
     WriteBinHandle -> WriterUserData
wbm_userData :: WriterUserData,
     -- ^ User data for writing binary outputs.
     -- Allows users to overwrite certain 'Binary' instances.
     -- This is helpful when a non-canonical 'Binary' instance is required,
     -- such as in the case of 'Name'.
     WriteBinHandle -> FastMutInt
wbm_off_r    :: !FastMutInt,      -- ^ the current offset
     WriteBinHandle -> FastMutInt
wbm_sz_r     :: !FastMutInt,      -- ^ size of the array (cached)
     WriteBinHandle -> IORef BinArray
wbm_arr_r    :: !(IORef BinArray) -- ^ the array (bounds: (0,size-1))
    }

-- | A read-only handle that can be used to deserialise binary data from a buffer.
--
-- The buffer is an unboxed binary array.
data ReadBinHandle
  = ReadBinMem {
     ReadBinHandle -> ReaderUserData
rbm_userData :: ReaderUserData,
     -- ^ User data for reading binary inputs.
     -- Allows users to overwrite certain 'Binary' instances.
     -- This is helpful when a non-canonical 'Binary' instance is required,
     -- such as in the case of 'Name'.
     ReadBinHandle -> FastMutInt
rbm_off_r    :: !FastMutInt,     -- ^ the current offset
     ReadBinHandle -> Int
rbm_sz_r     :: !Int,            -- ^ size of the array (cached)
     ReadBinHandle -> BinArray
rbm_arr_r    :: !BinArray        -- ^ the array (bounds: (0,size-1))
    }

getReaderUserData :: ReadBinHandle -> ReaderUserData
getReaderUserData :: ReadBinHandle -> ReaderUserData
getReaderUserData ReadBinHandle
bh = ReadBinHandle -> ReaderUserData
rbm_userData ReadBinHandle
bh

getWriterUserData :: WriteBinHandle -> WriterUserData
getWriterUserData :: WriteBinHandle -> WriterUserData
getWriterUserData WriteBinHandle
bh = WriteBinHandle -> WriterUserData
wbm_userData WriteBinHandle
bh

setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle
setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle
setWriterUserData WriteBinHandle
bh WriterUserData
us = WriteBinHandle
bh { wbm_userData = us }

setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle
setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle
setReaderUserData ReadBinHandle
bh ReaderUserData
us = ReadBinHandle
bh { rbm_userData = us }

-- | Add 'SomeBinaryReader' as a known binary decoder.
-- If a 'BinaryReader' for the associated type already exists in 'ReaderUserData',
-- it is overwritten.
addReaderToUserData :: forall a. Typeable a => BinaryReader a -> ReadBinHandle -> ReadBinHandle
addReaderToUserData :: forall a.
Typeable a =>
BinaryReader a -> ReadBinHandle -> ReadBinHandle
addReaderToUserData BinaryReader a
reader ReadBinHandle
bh = ReadBinHandle
bh
  { rbm_userData = (rbm_userData bh)
      { ud_reader_data =
          let
            typRep = forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Refl.typeRep @a
          in
            Map.insert (SomeTypeRep typRep) (SomeBinaryReader typRep reader) (ud_reader_data (rbm_userData bh))
      }
  }

-- | Add 'SomeBinaryWriter' as a known binary encoder.
-- If a 'BinaryWriter' for the associated type already exists in 'WriterUserData',
-- it is overwritten.
addWriterToUserData :: forall a . Typeable a => BinaryWriter a -> WriteBinHandle -> WriteBinHandle
addWriterToUserData :: forall a.
Typeable a =>
BinaryWriter a -> WriteBinHandle -> WriteBinHandle
addWriterToUserData BinaryWriter a
writer WriteBinHandle
bh = WriteBinHandle
bh
  { wbm_userData = (wbm_userData bh)
      { ud_writer_data =
          let
            typRep = forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Refl.typeRep @a
          in
            Map.insert (SomeTypeRep typRep) (SomeBinaryWriter typRep writer) (ud_writer_data (wbm_userData bh))
      }
  }

-- | Get access to the underlying buffer.
withBinBuffer :: WriteBinHandle -> (ByteString -> IO a) -> IO a
withBinBuffer :: forall a. WriteBinHandle -> (ByteString -> IO a) -> IO a
withBinBuffer (WriteBinMem WriterUserData
_ FastMutInt
ix_r FastMutInt
_ IORef BinArray
arr_r) ByteString -> IO a
action = do
  ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  arr <- readIORef arr_r
  action $ BS.fromForeignPtr arr 0 ix

unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle
unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle
unsafeUnpackBinBuffer (BS.BS BinArray
arr Int
len) = do
  ix_r <- Int -> IO FastMutInt
newFastMutInt Int
0
  return (ReadBinMem noReaderUserData ix_r len arr)

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

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

-- | Like a 'Bin' but is used to store relative offset pointers.
-- Relative offset pointers store a relative location, but also contain an
-- anchor that allow to obtain the absolute offset.
data RelBin a = RelBin
  { forall {k} (a :: k). RelBin a -> Bin a
relBin_anchor :: {-# UNPACK #-} !(Bin a)
  -- ^ Absolute position from where we read 'relBin_offset'.
  , forall {k} (a :: k). RelBin a -> RelBinPtr a
relBin_offset :: {-# UNPACK #-} !(RelBinPtr a)
  -- ^ Relative offset to 'relBin_anchor'.
  -- The absolute position of the 'RelBin' is @relBin_anchor + relBin_offset@
  }
  deriving (RelBin a -> RelBin a -> Bool
(RelBin a -> RelBin a -> Bool)
-> (RelBin a -> RelBin a -> Bool) -> Eq (RelBin a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). RelBin a -> RelBin a -> Bool
$c== :: forall k (a :: k). RelBin a -> RelBin a -> Bool
== :: RelBin a -> RelBin a -> Bool
$c/= :: forall k (a :: k). RelBin a -> RelBin a -> Bool
/= :: RelBin a -> RelBin a -> Bool
Eq, Eq (RelBin a)
Eq (RelBin a) =>
(RelBin a -> RelBin a -> Ordering)
-> (RelBin a -> RelBin a -> Bool)
-> (RelBin a -> RelBin a -> Bool)
-> (RelBin a -> RelBin a -> Bool)
-> (RelBin a -> RelBin a -> Bool)
-> (RelBin a -> RelBin a -> RelBin a)
-> (RelBin a -> RelBin a -> RelBin a)
-> Ord (RelBin a)
RelBin a -> RelBin a -> Bool
RelBin a -> RelBin a -> Ordering
RelBin a -> RelBin a -> RelBin 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 (RelBin a)
forall k (a :: k). RelBin a -> RelBin a -> Bool
forall k (a :: k). RelBin a -> RelBin a -> Ordering
forall k (a :: k). RelBin a -> RelBin a -> RelBin a
$ccompare :: forall k (a :: k). RelBin a -> RelBin a -> Ordering
compare :: RelBin a -> RelBin a -> Ordering
$c< :: forall k (a :: k). RelBin a -> RelBin a -> Bool
< :: RelBin a -> RelBin a -> Bool
$c<= :: forall k (a :: k). RelBin a -> RelBin a -> Bool
<= :: RelBin a -> RelBin a -> Bool
$c> :: forall k (a :: k). RelBin a -> RelBin a -> Bool
> :: RelBin a -> RelBin a -> Bool
$c>= :: forall k (a :: k). RelBin a -> RelBin a -> Bool
>= :: RelBin a -> RelBin a -> Bool
$cmax :: forall k (a :: k). RelBin a -> RelBin a -> RelBin a
max :: RelBin a -> RelBin a -> RelBin a
$cmin :: forall k (a :: k). RelBin a -> RelBin a -> RelBin a
min :: RelBin a -> RelBin a -> RelBin a
Ord, Int -> RelBin a -> ShowS
[RelBin a] -> ShowS
RelBin a -> String
(Int -> RelBin a -> ShowS)
-> (RelBin a -> String) -> ([RelBin a] -> ShowS) -> Show (RelBin a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> RelBin a -> ShowS
forall k (a :: k). [RelBin a] -> ShowS
forall k (a :: k). RelBin a -> String
$cshowsPrec :: forall k (a :: k). Int -> RelBin a -> ShowS
showsPrec :: Int -> RelBin a -> ShowS
$cshow :: forall k (a :: k). RelBin a -> String
show :: RelBin a -> String
$cshowList :: forall k (a :: k). [RelBin a] -> ShowS
showList :: [RelBin a] -> ShowS
Show, RelBin a
RelBin a -> RelBin a -> Bounded (RelBin a)
forall a. a -> a -> Bounded a
forall k (a :: k). RelBin a
$cminBound :: forall k (a :: k). RelBin a
minBound :: RelBin a
$cmaxBound :: forall k (a :: k). RelBin a
maxBound :: RelBin a
Bounded)

-- | A 'RelBinPtr' is like a 'Bin', but contains a relative offset pointer
-- instead of an absolute offset.
newtype RelBinPtr a = RelBinPtr (Bin a)
  deriving (RelBinPtr a -> RelBinPtr a -> Bool
(RelBinPtr a -> RelBinPtr a -> Bool)
-> (RelBinPtr a -> RelBinPtr a -> Bool) -> Eq (RelBinPtr a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). RelBinPtr a -> RelBinPtr a -> Bool
$c== :: forall k (a :: k). RelBinPtr a -> RelBinPtr a -> Bool
== :: RelBinPtr a -> RelBinPtr a -> Bool
$c/= :: forall k (a :: k). RelBinPtr a -> RelBinPtr a -> Bool
/= :: RelBinPtr a -> RelBinPtr a -> Bool
Eq, Eq (RelBinPtr a)
Eq (RelBinPtr a) =>
(RelBinPtr a -> RelBinPtr a -> Ordering)
-> (RelBinPtr a -> RelBinPtr a -> Bool)
-> (RelBinPtr a -> RelBinPtr a -> Bool)
-> (RelBinPtr a -> RelBinPtr a -> Bool)
-> (RelBinPtr a -> RelBinPtr a -> Bool)
-> (RelBinPtr a -> RelBinPtr a -> RelBinPtr a)
-> (RelBinPtr a -> RelBinPtr a -> RelBinPtr a)
-> Ord (RelBinPtr a)
RelBinPtr a -> RelBinPtr a -> Bool
RelBinPtr a -> RelBinPtr a -> Ordering
RelBinPtr a -> RelBinPtr a -> RelBinPtr 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 (RelBinPtr a)
forall k (a :: k). RelBinPtr a -> RelBinPtr a -> Bool
forall k (a :: k). RelBinPtr a -> RelBinPtr a -> Ordering
forall k (a :: k). RelBinPtr a -> RelBinPtr a -> RelBinPtr a
$ccompare :: forall k (a :: k). RelBinPtr a -> RelBinPtr a -> Ordering
compare :: RelBinPtr a -> RelBinPtr a -> Ordering
$c< :: forall k (a :: k). RelBinPtr a -> RelBinPtr a -> Bool
< :: RelBinPtr a -> RelBinPtr a -> Bool
$c<= :: forall k (a :: k). RelBinPtr a -> RelBinPtr a -> Bool
<= :: RelBinPtr a -> RelBinPtr a -> Bool
$c> :: forall k (a :: k). RelBinPtr a -> RelBinPtr a -> Bool
> :: RelBinPtr a -> RelBinPtr a -> Bool
$c>= :: forall k (a :: k). RelBinPtr a -> RelBinPtr a -> Bool
>= :: RelBinPtr a -> RelBinPtr a -> Bool
$cmax :: forall k (a :: k). RelBinPtr a -> RelBinPtr a -> RelBinPtr a
max :: RelBinPtr a -> RelBinPtr a -> RelBinPtr a
$cmin :: forall k (a :: k). RelBinPtr a -> RelBinPtr a -> RelBinPtr a
min :: RelBinPtr a -> RelBinPtr a -> RelBinPtr a
Ord, Int -> RelBinPtr a -> ShowS
[RelBinPtr a] -> ShowS
RelBinPtr a -> String
(Int -> RelBinPtr a -> ShowS)
-> (RelBinPtr a -> String)
-> ([RelBinPtr a] -> ShowS)
-> Show (RelBinPtr a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> RelBinPtr a -> ShowS
forall k (a :: k). [RelBinPtr a] -> ShowS
forall k (a :: k). RelBinPtr a -> String
$cshowsPrec :: forall k (a :: k). Int -> RelBinPtr a -> ShowS
showsPrec :: Int -> RelBinPtr a -> ShowS
$cshow :: forall k (a :: k). RelBinPtr a -> String
show :: RelBinPtr a -> String
$cshowList :: forall k (a :: k). [RelBinPtr a] -> ShowS
showList :: [RelBinPtr a] -> ShowS
Show, RelBinPtr a
RelBinPtr a -> RelBinPtr a -> Bounded (RelBinPtr a)
forall a. a -> a -> Bounded a
forall k (a :: k). RelBinPtr a
$cminBound :: forall k (a :: k). RelBinPtr a
minBound :: RelBinPtr a
$cmaxBound :: forall k (a :: k). RelBinPtr a
maxBound :: RelBinPtr a
Bounded)

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

-- | Read a relative offset location and wrap it in 'RelBin'.
--
-- The resulting 'RelBin' can be translated into an absolute offset location using
-- 'makeAbsoluteBin'
getRelBin :: ReadBinHandle -> IO (RelBin a)
getRelBin :: forall {k} (a :: k). ReadBinHandle -> IO (RelBin a)
getRelBin ReadBinHandle
bh = do
  start <- ReadBinHandle -> IO (Bin a)
forall {k} (a :: k). ReadBinHandle -> IO (Bin a)
tellBinReader ReadBinHandle
bh
  off <- get bh
  pure $ RelBin start off

makeAbsoluteBin ::  RelBin a -> Bin a
makeAbsoluteBin :: forall {k} (a :: k). RelBin a -> Bin a
makeAbsoluteBin (RelBin (BinPtr !Int
start) (RelBinPtr (BinPtr !Int
offset))) =
  Int -> Bin a
forall {k} (a :: k). Int -> Bin a
BinPtr (Int -> Bin a) -> Int -> Bin a
forall a b. (a -> b) -> a -> b
$ Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset

makeRelativeBin :: RelBin a -> RelBinPtr a
makeRelativeBin :: forall {k} (a :: k). RelBin a -> RelBinPtr a
makeRelativeBin (RelBin Bin a
_ RelBinPtr a
offset) = RelBinPtr a
offset

toRelBin :: Bin (RelBinPtr a) -> Bin a -> RelBin a
toRelBin :: forall {k} (a :: k). Bin (RelBinPtr a) -> Bin a -> RelBin a
toRelBin (BinPtr !Int
start) (BinPtr !Int
goal) =
  Bin a -> RelBinPtr a -> RelBin a
forall {k} (a :: k). Bin a -> RelBinPtr a -> RelBin a
RelBin (Int -> Bin a
forall {k} (a :: k). Int -> Bin a
BinPtr Int
start) (Bin a -> RelBinPtr a
forall {k} (a :: k). Bin a -> RelBinPtr a
RelBinPtr (Bin a -> RelBinPtr a) -> Bin a -> RelBinPtr a
forall a b. (a -> b) -> a -> b
$ Int -> Bin a
forall {k} (a :: k). Int -> Bin a
BinPtr (Int -> Bin a) -> Int -> Bin a
forall a b. (a -> b) -> a -> b
$ Int
goal Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start)

---------------------------------------------------------------
-- 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_   :: WriteBinHandle -> a -> IO ()
    put    :: WriteBinHandle -> a -> IO (Bin a)
    get    :: ReadBinHandle -> 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_ WriteBinHandle
bh a
a = do _ <- WriteBinHandle -> a -> IO (Bin a)
forall a. Binary a => WriteBinHandle -> a -> IO (Bin a)
put WriteBinHandle
bh a
a; return ()
    put WriteBinHandle
bh a
a  = do p <- WriteBinHandle -> IO (Bin a)
forall {k} (a :: k). WriteBinHandle -> IO (Bin a)
tellBinWriter WriteBinHandle
bh; put_ bh a; return p

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

putAtRel :: WriteBinHandle -> Bin (RelBinPtr a) -> Bin a -> IO ()
putAtRel :: forall {k} (a :: k).
WriteBinHandle -> Bin (RelBinPtr a) -> Bin a -> IO ()
putAtRel WriteBinHandle
bh Bin (RelBinPtr a)
from Bin a
to = WriteBinHandle -> Bin (RelBinPtr a) -> RelBinPtr a -> IO ()
forall a. Binary a => WriteBinHandle -> Bin a -> a -> IO ()
putAt WriteBinHandle
bh Bin (RelBinPtr a)
from (RelBin a -> RelBinPtr a
forall {k} (a :: k). RelBin a -> RelBinPtr a
makeRelativeBin (RelBin a -> RelBinPtr a) -> RelBin a -> RelBinPtr a
forall a b. (a -> b) -> a -> b
$ Bin (RelBinPtr a) -> Bin a -> RelBin a
forall {k} (a :: k). Bin (RelBinPtr a) -> Bin a -> RelBin a
toRelBin Bin (RelBinPtr a)
from Bin a
to)

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

openBinMem :: Int -> IO WriteBinHandle
openBinMem :: Int -> IO WriteBinHandle
openBinMem Int
size
 | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = String -> IO WriteBinHandle
forall a. HasCallStack => String -> a
error String
"GHC.Utils.Binary.openBinMem: size must be >= 0"
 | Bool
otherwise = do
   arr <- Int -> IO BinArray
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
size
   arr_r <- newIORef arr
   ix_r <- newFastMutInt 0
   sz_r <- newFastMutInt size
   return WriteBinMem
    { wbm_userData = noWriterUserData
    , wbm_off_r = ix_r
    , wbm_sz_r = sz_r
    , wbm_arr_r = arr_r
    }

-- | Freeze the given 'WriteBinHandle' and turn it into an equivalent 'ReadBinHandle'.
--
-- The current offset of the 'WriteBinHandle' is maintained in the new 'ReadBinHandle'.
freezeWriteHandle :: WriteBinHandle -> IO ReadBinHandle
freezeWriteHandle :: WriteBinHandle -> IO ReadBinHandle
freezeWriteHandle WriteBinHandle
wbm = do
  rbm_off_r <- Int -> IO FastMutInt
newFastMutInt (Int -> IO FastMutInt) -> IO Int -> IO FastMutInt
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FastMutInt -> IO Int
readFastMutInt (WriteBinHandle -> FastMutInt
wbm_off_r WriteBinHandle
wbm)
  rbm_sz_r <- readFastMutInt (wbm_sz_r wbm)
  rbm_arr_r <- readIORef (wbm_arr_r wbm)
  pure $ ReadBinMem
    { rbm_userData = noReaderUserData
    , rbm_off_r = rbm_off_r
    , rbm_sz_r = rbm_sz_r
    , rbm_arr_r = rbm_arr_r
    }

-- | Copy the BinBuffer to a new BinBuffer which is exactly the right size.
-- This performs a copy of the underlying buffer.
-- The buffer may be truncated if the offset is not at the end of the written
-- output.
--
-- UserData is also discarded during the copy
-- You should just use this when translating a Put handle into a Get handle.
shrinkBinBuffer :: WriteBinHandle -> IO ReadBinHandle
shrinkBinBuffer :: WriteBinHandle -> IO ReadBinHandle
shrinkBinBuffer WriteBinHandle
bh = WriteBinHandle
-> (ByteString -> IO ReadBinHandle) -> IO ReadBinHandle
forall a. WriteBinHandle -> (ByteString -> IO a) -> IO a
withBinBuffer WriteBinHandle
bh ((ByteString -> IO ReadBinHandle) -> IO ReadBinHandle)
-> (ByteString -> IO ReadBinHandle) -> IO ReadBinHandle
forall a b. (a -> b) -> a -> b
$ \ByteString
bs -> do
  ByteString -> IO ReadBinHandle
unsafeUnpackBinBuffer (ByteString -> ByteString
copy ByteString
bs)

thawReadHandle :: ReadBinHandle -> IO WriteBinHandle
thawReadHandle :: ReadBinHandle -> IO WriteBinHandle
thawReadHandle ReadBinHandle
rbm = do
  wbm_off_r <- Int -> IO FastMutInt
newFastMutInt (Int -> IO FastMutInt) -> IO Int -> IO FastMutInt
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FastMutInt -> IO Int
readFastMutInt (ReadBinHandle -> FastMutInt
rbm_off_r ReadBinHandle
rbm)
  wbm_sz_r <- newFastMutInt (rbm_sz_r rbm)
  wbm_arr_r <- newIORef (rbm_arr_r rbm)
  pure $ WriteBinMem
    { wbm_userData = noWriterUserData
    , wbm_off_r = wbm_off_r
    , wbm_sz_r = wbm_sz_r
    , wbm_arr_r = wbm_arr_r
    }

tellBinWriter :: WriteBinHandle -> IO (Bin a)
tellBinWriter :: forall {k} (a :: k). WriteBinHandle -> IO (Bin a)
tellBinWriter (WriteBinMem WriterUserData
_ FastMutInt
r FastMutInt
_ IORef BinArray
_) = do ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
r; return (BinPtr ix)

tellBinReader :: ReadBinHandle -> IO (Bin a)
tellBinReader :: forall {k} (a :: k). ReadBinHandle -> IO (Bin a)
tellBinReader (ReadBinMem ReaderUserData
_ FastMutInt
r Int
_ BinArray
_) = do ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
r; return (BinPtr ix)

seekBinWriter :: WriteBinHandle -> Bin a -> IO ()
seekBinWriter :: forall {k} (a :: k). WriteBinHandle -> Bin a -> IO ()
seekBinWriter h :: WriteBinHandle
h@(WriteBinMem WriterUserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
_) (BinPtr !Int
p) = do
  sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  if (p > sz)
        then do expandBin h p; writeFastMutInt ix_r p
        else writeFastMutInt ix_r p

-- | 'seekBinNoExpandWriter' moves the index pointer to the location pointed to
-- by 'Bin a'.
-- This operation may 'panic', if the pointer location is out of bounds of the
-- buffer of 'BinHandle'.
seekBinNoExpandWriter :: WriteBinHandle -> Bin a -> IO ()
seekBinNoExpandWriter :: forall {k} (a :: k). WriteBinHandle -> Bin a -> IO ()
seekBinNoExpandWriter (WriteBinMem WriterUserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
_) (BinPtr !Int
p) = do
  sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  if (p > sz)
        then panic "seekBinNoExpandWriter: seek out of range"
        else writeFastMutInt ix_r p

-- | SeekBin but without calling expandBin
seekBinReader :: ReadBinHandle -> Bin a -> IO ()
seekBinReader :: forall {k} (a :: k). ReadBinHandle -> Bin a -> IO ()
seekBinReader (ReadBinMem ReaderUserData
_ FastMutInt
ix_r Int
sz_r BinArray
_) (BinPtr !Int
p) = do
  if (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
sz_r)
        then String -> IO ()
forall a. HasCallStack => String -> a
panic String
"seekBinReader: seek out of range"
        else FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
p

seekBinReaderRel :: ReadBinHandle -> RelBin a -> IO ()
seekBinReaderRel :: forall {k} (a :: k). ReadBinHandle -> RelBin a -> IO ()
seekBinReaderRel (ReadBinMem ReaderUserData
_ FastMutInt
ix_r Int
sz_r BinArray
_) RelBin a
relBin = do
  let (BinPtr !Int
p) = RelBin a -> Bin a
forall {k} (a :: k). RelBin a -> Bin a
makeAbsoluteBin RelBin a
relBin
  if (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
sz_r)
        then String -> IO ()
forall a. HasCallStack => String -> a
panic String
"seekBinReaderRel: seek out of range"
        else FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
p

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

readBinMem :: FilePath -> IO ReadBinHandle
readBinMem :: String -> IO ReadBinHandle
readBinMem String
filename = do
  String
-> IOMode -> (Handle -> IO ReadBinHandle) -> IO ReadBinHandle
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
filename IOMode
ReadMode ((Handle -> IO ReadBinHandle) -> IO ReadBinHandle)
-> (Handle -> IO ReadBinHandle) -> IO ReadBinHandle
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    filesize' <- Handle -> IO Integer
hFileSize Handle
h
    let filesize = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
filesize'
    readBinMem_ filesize h

readBinMemN :: Int -> FilePath -> IO (Maybe ReadBinHandle)
readBinMemN :: Int -> String -> IO (Maybe ReadBinHandle)
readBinMemN Int
size String
filename = do
  String
-> IOMode
-> (Handle -> IO (Maybe ReadBinHandle))
-> IO (Maybe ReadBinHandle)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
filename IOMode
ReadMode ((Handle -> IO (Maybe ReadBinHandle)) -> IO (Maybe ReadBinHandle))
-> (Handle -> IO (Maybe ReadBinHandle)) -> IO (Maybe ReadBinHandle)
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    filesize' <- Handle -> IO Integer
hFileSize Handle
h
    let filesize = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
filesize'
    if filesize < size
      then pure Nothing
      else Just <$> readBinMem_ size h

readBinMem_ :: Int -> Handle -> IO ReadBinHandle
readBinMem_ :: Int -> Handle -> IO ReadBinHandle
readBinMem_ Int
filesize Handle
h = do
  arr <- Int -> IO BinArray
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
filesize
  count <- unsafeWithForeignPtr arr $ \Ptr Word8
p -> Handle -> Ptr Word8 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h Ptr Word8
p Int
filesize
  when (count /= filesize) $
       error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
  ix_r <- newFastMutInt 0
  return ReadBinMem
    { rbm_userData = noReaderUserData
    , rbm_off_r = ix_r
    , rbm_sz_r = filesize
    , rbm_arr_r = arr
    }

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

foldGet
  :: Binary a
  => Word -- n elements
  -> ReadBinHandle
  -> b -- initial accumulator
  -> (Word -> a -> b -> IO b)
  -> IO b
foldGet :: forall a b.
Binary a =>
Word -> ReadBinHandle -> b -> (Word -> a -> b -> IO b) -> IO b
foldGet Word
n ReadBinHandle
bh b
init_b Word -> a -> b -> IO b
f = Word -> b -> IO b
go Word
0 b
init_b
  where
    go :: Word -> b -> IO b
go Word
i b
b
      | Word
i Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
n    = b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
      | Bool
otherwise = do
          a <- ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
          b' <- f i a b
          go (i+1) b'

foldGet'
  :: Binary a
  => Word -- n elements
  -> ReadBinHandle
  -> b -- initial accumulator
  -> (Word -> a -> b -> IO b)
  -> IO b
{-# INLINE foldGet' #-}
foldGet' :: forall a b.
Binary a =>
Word -> ReadBinHandle -> b -> (Word -> a -> b -> IO b) -> IO b
foldGet' Word
n ReadBinHandle
bh b
init_b Word -> a -> b -> IO b
f = Word -> b -> IO b
go Word
0 b
init_b
  where
    go :: Word -> b -> IO b
go Word
i !b
b
      | Word
i Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
n    = b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
      | Bool
otherwise = do
          !a  <- ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
          b'  <- f i a b
          go (i+1) b'


-- -----------------------------------------------------------------------------
-- 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 :: WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim :: WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim h :: WriteBinHandle
h@(WriteBinMem WriterUserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r) Int
size Ptr Word8 -> IO ()
f = do
  ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  sz <- readFastMutInt sz_r
  when (ix + size > sz) $
    expandBin h (ix + size)
  arr <- readIORef arr_r
  unsafeWithForeignPtr arr $ \Ptr Word8
op -> Ptr Word8 -> IO ()
f (Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ix)
  writeFastMutInt ix_r (ix + 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 :: ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim :: forall a. ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim (ReadBinMem ReaderUserData
_ FastMutInt
ix_r Int
sz_r BinArray
arr_r) Int
size Ptr Word8 -> IO a
f = do
  ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  when (ix + size > sz_r) $
      ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing)
  w <- unsafeWithForeignPtr arr_r $ \Ptr Word8
p -> Ptr Word8 -> IO a
f (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
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
  writeFastMutInt ix_r (ix + size)
  return w

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

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

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

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

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

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

  return $! (w0 `shiftL` 24) .|.
            (w1 `shiftL` 16) .|.
            (w2 `shiftL` 8)  .|.
            w3
  )

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

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

  return $! (w0 `shiftL` 56) .|.
            (w1 `shiftL` 48) .|.
            (w2 `shiftL` 40) .|.
            (w3 `shiftL` 32) .|.
            (w4 `shiftL` 24) .|.
            (w5 `shiftL` 16) .|.
            (w6 `shiftL` 8)  .|.
            w7
  )

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

getByte :: ReadBinHandle -> IO Word8
getByte :: ReadBinHandle -> IO Word8
getByte ReadBinHandle
h = ReadBinHandle -> IO Word8
getWord8 ReadBinHandle
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 :: WriteBinHandle -> Word -> IO () #-}
{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word64 -> IO () #-}
{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word32 -> IO () #-}
{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word16 -> IO () #-}
{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int -> IO () #-}
{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int64 -> IO () #-}
{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int32 -> IO () #-}
{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int16 -> IO () #-}
putULEB128 :: forall a. (Integral a, FiniteBits a) => WriteBinHandle -> a -> IO ()
putULEB128 :: forall a.
(Integral a, FiniteBits a) =>
WriteBinHandle -> a -> IO ()
putULEB128 WriteBinHandle
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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= (a
127 :: a)
      = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh (a -> Word8
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 = Word8 -> Int -> Word8
forall a. (Num a, Bits a) => a -> Int -> a
setBit (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
w) Int
7 :: Word8
        WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
byte
        a -> IO ()
go (a
w a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
7)

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

-- Signed numbers
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word64 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word32 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word16 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-}
{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-}
putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO ()
putSLEB128 WriteBinHandle
bh a
initial = a -> IO ()
go a
initial
  where
    go :: a -> IO ()
    go :: a -> IO ()
go a
val = do
        let !byte :: Word8
byte = a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int -> a
forall a. (Num a, Bits a) => a -> Int -> a
clearBit a
val Int
7) :: Word8
        let !val' :: a
val' = a
val a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
7
        let !signBit :: Bool
signBit = Word8 -> Int -> Bool
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' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
signBit) Bool -> Bool -> Bool
||
                -- Signed value,
                 (a
val' a -> a -> Bool
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 Word8 -> Int -> Word8
forall a. (Num a, Bits a) => a -> Int -> a
setBit Word8
byte Int
7
        WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
byte'

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

{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word #-}
{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word64 #-}
{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word32 #-}
{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word16 #-}
{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int #-}
{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int64 #-}
{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int32 #-}
{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int16 #-}
getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => ReadBinHandle -> IO a
getSLEB128 :: forall a.
(Show a, Integral a, FiniteBits a) =>
ReadBinHandle -> IO a
getSLEB128 ReadBinHandle
bh = do
    (val,shift,signed) <- Int -> a -> IO (a, Int, Bool)
go Int
0 a
0
    if signed && (shift < finiteBitSize val )
        then return $! ((complement 0 `unsafeShiftL` shift) .|. val)
        else return val
    where
        go :: Int -> a -> IO (a,Int,Bool)
        go :: Int -> a -> IO (a, Int, Bool)
go Int
shift a
val = do
            byte <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
            let !byteVal = Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int -> Word8
forall a. (Num a, Bits a) => a -> Int -> a
clearBit Word8
byte Int
7) :: a
            let !val' = a
val a -> a -> a
forall a. Bits a => a -> a -> a
.|. (a
byteVal a -> Int -> a
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
shift)
            let !more = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
byte Int
7
            let !shift' = Int
shiftInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
7
            if more
                then go (shift') val'
                else do
                    let !signed = Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
byte Int
6
                    return (val',shift',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 its full length. This is different from many default
-- binary instances which make no guarantee about the actual encoding and
-- might do things using variable length encoding.
newtype FixedLengthEncoding a
  = FixedLengthEncoding { forall a. FixedLengthEncoding a -> a
unFixedLength :: a }
  deriving (FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
(FixedLengthEncoding a -> FixedLengthEncoding a -> Bool)
-> (FixedLengthEncoding a -> FixedLengthEncoding a -> Bool)
-> Eq (FixedLengthEncoding a)
forall a.
Eq a =>
FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
== :: FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
$c/= :: forall a.
Eq a =>
FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
/= :: FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
Eq,Eq (FixedLengthEncoding a)
Eq (FixedLengthEncoding a) =>
(FixedLengthEncoding a -> FixedLengthEncoding a -> Ordering)
-> (FixedLengthEncoding a -> FixedLengthEncoding a -> Bool)
-> (FixedLengthEncoding a -> FixedLengthEncoding a -> Bool)
-> (FixedLengthEncoding a -> FixedLengthEncoding a -> Bool)
-> (FixedLengthEncoding a -> FixedLengthEncoding a -> Bool)
-> (FixedLengthEncoding a
    -> FixedLengthEncoding a -> FixedLengthEncoding a)
-> (FixedLengthEncoding a
    -> FixedLengthEncoding a -> FixedLengthEncoding a)
-> Ord (FixedLengthEncoding a)
FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
FixedLengthEncoding a -> FixedLengthEncoding a -> Ordering
FixedLengthEncoding a
-> FixedLengthEncoding a -> FixedLengthEncoding 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 a. Ord a => Eq (FixedLengthEncoding a)
forall a.
Ord a =>
FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
forall a.
Ord a =>
FixedLengthEncoding a -> FixedLengthEncoding a -> Ordering
forall a.
Ord a =>
FixedLengthEncoding a
-> FixedLengthEncoding a -> FixedLengthEncoding a
$ccompare :: forall a.
Ord a =>
FixedLengthEncoding a -> FixedLengthEncoding a -> Ordering
compare :: FixedLengthEncoding a -> FixedLengthEncoding a -> Ordering
$c< :: forall a.
Ord a =>
FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
< :: FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
$c<= :: forall a.
Ord a =>
FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
<= :: FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
$c> :: forall a.
Ord a =>
FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
> :: FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
$c>= :: forall a.
Ord a =>
FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
>= :: FixedLengthEncoding a -> FixedLengthEncoding a -> Bool
$cmax :: forall a.
Ord a =>
FixedLengthEncoding a
-> FixedLengthEncoding a -> FixedLengthEncoding a
max :: FixedLengthEncoding a
-> FixedLengthEncoding a -> FixedLengthEncoding a
$cmin :: forall a.
Ord a =>
FixedLengthEncoding a
-> FixedLengthEncoding a -> FixedLengthEncoding a
min :: FixedLengthEncoding a
-> FixedLengthEncoding a -> FixedLengthEncoding a
Ord,Int -> FixedLengthEncoding a -> ShowS
[FixedLengthEncoding a] -> ShowS
FixedLengthEncoding a -> String
(Int -> FixedLengthEncoding a -> ShowS)
-> (FixedLengthEncoding a -> String)
-> ([FixedLengthEncoding a] -> ShowS)
-> Show (FixedLengthEncoding a)
forall a. Show a => Int -> FixedLengthEncoding a -> ShowS
forall a. Show a => [FixedLengthEncoding a] -> ShowS
forall a. Show a => FixedLengthEncoding a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> FixedLengthEncoding a -> ShowS
showsPrec :: Int -> FixedLengthEncoding a -> ShowS
$cshow :: forall a. Show a => FixedLengthEncoding a -> String
show :: FixedLengthEncoding a -> String
$cshowList :: forall a. Show a => [FixedLengthEncoding a] -> ShowS
showList :: [FixedLengthEncoding a] -> ShowS
Show)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | This instance doesn't rely on the determinism of the keys' 'Ord' instance,
-- so it works e.g. for 'Name's too.
instance (Binary a, Ord a) => Binary (Set a) where
  put_ :: WriteBinHandle -> Set a -> IO ()
put_ WriteBinHandle
bh Set a
s = WriteBinHandle -> [a] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
s)
  get :: ReadBinHandle -> IO (Set a)
get ReadBinHandle
bh = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> Set a) -> IO [a] -> IO (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO [a]
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh

instance Binary a => Binary (NonEmpty a) where
    put_ :: WriteBinHandle -> NonEmpty a -> IO ()
put_ WriteBinHandle
bh = WriteBinHandle -> [a] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh ([a] -> IO ()) -> (NonEmpty a -> [a]) -> NonEmpty a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NonEmpty.toList
    get :: ReadBinHandle -> IO (NonEmpty a)
get ReadBinHandle
bh = [a] -> NonEmpty a
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList ([a] -> NonEmpty a) -> IO [a] -> IO (NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO [a]
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh

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

instance (Binary a, Binary b) => Binary (a,b) where
    put_ :: WriteBinHandle -> (a, b) -> IO ()
put_ WriteBinHandle
bh (a
a,b
b) = do WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh a
a; WriteBinHandle -> b -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh b
b
    get :: ReadBinHandle -> IO (a, b)
get ReadBinHandle
bh        = do a <- ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
                       b <- get bh
                       return (a,b)

instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
    put_ :: WriteBinHandle -> (a, b, c) -> IO ()
put_ WriteBinHandle
bh (a
a,b
b,c
c) = do WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh a
a; WriteBinHandle -> b -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh b
b; WriteBinHandle -> c -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh c
c
    get :: ReadBinHandle -> IO (a, b, c)
get ReadBinHandle
bh          = do a <- ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
                         b <- get bh
                         c <- get bh
                         return (a,b,c)

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

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

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where
    put_ :: WriteBinHandle -> (a, b, c, d, e, f) -> IO ()
put_ WriteBinHandle
bh (a
a,b
b,c
c,d
d, e
e, f
f) = do WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh a
a; WriteBinHandle -> b -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh b
b; WriteBinHandle -> c -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh c
c; WriteBinHandle -> d -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh d
d; WriteBinHandle -> e -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh e
e; WriteBinHandle -> f -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh f
f;
    get :: ReadBinHandle -> IO (a, b, c, d, e, f)
get ReadBinHandle
bh                  = do a <- ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
                                 b <- get bh
                                 c <- get bh
                                 d <- get bh
                                 e <- get bh
                                 f <- get bh
                                 return (a,b,c,d,e,f)

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where
    put_ :: WriteBinHandle -> (a, b, c, d, e, f, g) -> IO ()
put_ WriteBinHandle
bh (a
a,b
b,c
c,d
d,e
e,f
f,g
g) = do WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh a
a; WriteBinHandle -> b -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh b
b; WriteBinHandle -> c -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh c
c; WriteBinHandle -> d -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh d
d; WriteBinHandle -> e -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh e
e; WriteBinHandle -> f -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh f
f; WriteBinHandle -> g -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh g
g
    get :: ReadBinHandle -> IO (a, b, c, d, e, f, g)
get ReadBinHandle
bh                  = do a <- ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
                                 b <- get bh
                                 c <- get bh
                                 d <- get bh
                                 e <- get bh
                                 f <- get bh
                                 g <- get bh
                                 return (a,b,c,d,e,f,g)

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

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

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

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

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

instance Binary DiffTime where
    put_ :: WriteBinHandle -> DiffTime -> IO ()
put_ WriteBinHandle
bh DiffTime
dt = WriteBinHandle -> Rational -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
dt)
    get :: ReadBinHandle -> IO DiffTime
get ReadBinHandle
bh = do r <- ReadBinHandle -> IO Rational
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
                return $ fromRational r

instance Binary JoinPointHood where
    put_ :: WriteBinHandle -> JoinPointHood -> IO ()
put_ WriteBinHandle
bh JoinPointHood
NotJoinPoint = WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
0
    put_ WriteBinHandle
bh (JoinPoint Int
ar) = do
        WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
1
        WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Int
ar
    get :: ReadBinHandle -> IO JoinPointHood
get ReadBinHandle
bh = do
        h <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
        case h of
            Word8
0 -> JoinPointHood -> IO JoinPointHood
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JoinPointHood
NotJoinPoint
            Word8
_ -> do { ar <- ReadBinHandle -> IO Int
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh; return (JoinPoint ar) }

{-
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 of large Integer
values. In the examples looked at between 25% and 50% of Integers
serialized were outside of the Int32 range.

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

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

roll :: [Word8] -> Integer
roll :: [Word8] -> Integer
roll   = (Integer -> Word8 -> Integer) -> Integer -> [Word8] -> Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Integer -> Word8 -> Integer
forall {a} {a}. (Bits a, Integral a, Num a) => a -> a -> a
unstep Integer
0 ([Word8] -> Integer) -> ([Word8] -> [Word8]) -> [Word8] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [Word8]
forall a. [a] -> [a]
reverse
  where
    unstep :: a -> a -> a
unstep a
a a
b = a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 a -> a -> a
forall a. Bits a => a -> 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_ :: WriteBinHandle -> Ratio a -> IO ()
put_ WriteBinHandle
bh (a
a :% a
b) = do WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh a
a; WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh a
b
    get :: ReadBinHandle -> IO (Ratio a)
get ReadBinHandle
bh = do a <- ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh; b <- get bh; return (a :% b)

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

-- Instance uses fixed-width encoding to allow inserting
-- Bin placeholders in the stream.
instance Binary (RelBinPtr a) where
  put_ :: WriteBinHandle -> RelBinPtr a -> IO ()
put_ WriteBinHandle
bh (RelBinPtr Bin a
i) = WriteBinHandle -> Bin a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Bin a
i
  get :: ReadBinHandle -> IO (RelBinPtr a)
get ReadBinHandle
bh = Bin a -> RelBinPtr a
forall {k} (a :: k). Bin a -> RelBinPtr a
RelBinPtr (Bin a -> RelBinPtr a) -> IO (Bin a) -> IO (RelBinPtr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO (Bin a)
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh

-- -----------------------------------------------------------------------------
-- Forward reading/writing

-- | @'forwardPut' put_A put_B@ outputs A after B but allows A to be read before B
-- by using a forward reference.
forwardPut :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)
forwardPut :: forall b a. WriteBinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forwardPut WriteBinHandle
bh b -> IO a
put_A IO b
put_B = do
  -- write placeholder pointer to A
  pre_a <- WriteBinHandle -> IO (Bin (Bin (ZonkAny 5)))
forall {k} (a :: k). WriteBinHandle -> IO (Bin a)
tellBinWriter WriteBinHandle
bh
  put_ bh pre_a

  -- write B
  r_b <- put_B

  -- update A's pointer
  a <- tellBinWriter bh
  putAt bh pre_a a
  seekBinNoExpandWriter bh a

  -- write A
  r_a <- put_A r_b
  pure (r_a,r_b)

forwardPut_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO ()
forwardPut_ :: forall b a. WriteBinHandle -> (b -> IO a) -> IO b -> IO ()
forwardPut_ WriteBinHandle
bh b -> IO a
put_A IO b
put_B = IO (a, b) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (a, b) -> IO ()) -> IO (a, b) -> IO ()
forall a b. (a -> b) -> a -> b
$ WriteBinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forall b a. WriteBinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forwardPut WriteBinHandle
bh b -> IO a
put_A IO b
put_B

-- | Read a value stored using a forward reference
--
-- The forward reference is expected to be an absolute offset.
forwardGet :: ReadBinHandle -> IO a -> IO a
forwardGet :: forall a. ReadBinHandle -> IO a -> IO a
forwardGet ReadBinHandle
bh IO a
get_A = do
    -- read forward reference
    p <- ReadBinHandle -> IO (Bin (ZonkAny 1))
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh -- a BinPtr
    -- store current position
    p_a <- tellBinReader bh
    -- go read the forward value, then seek back
    seekBinReader bh p
    r <- get_A
    seekBinReader bh p_a
    pure r

-- | @'forwardPutRel' put_A put_B@ outputs A after B but allows A to be read before B
-- by using a forward reference.
--
-- This forward reference is a relative offset that allows us to skip over the
-- result of 'put_A'.
forwardPutRel :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b)
forwardPutRel :: forall b a. WriteBinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forwardPutRel WriteBinHandle
bh b -> IO a
put_A IO b
put_B = do
  -- write placeholder pointer to A
  pre_a <- WriteBinHandle -> IO (Bin (RelBinPtr (ZonkAny 7)))
forall {k} (a :: k). WriteBinHandle -> IO (Bin a)
tellBinWriter WriteBinHandle
bh
  put_ bh pre_a

  -- write B
  r_b <- put_B

  -- update A's pointer
  a <- tellBinWriter bh
  putAtRel bh pre_a a
  seekBinNoExpandWriter bh a

  -- write A
  r_a <- put_A r_b
  pure (r_a,r_b)

-- | Like 'forwardGetRel', but discard the result.
forwardPutRel_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO ()
forwardPutRel_ :: forall b a. WriteBinHandle -> (b -> IO a) -> IO b -> IO ()
forwardPutRel_ WriteBinHandle
bh b -> IO a
put_A IO b
put_B = IO (a, b) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (a, b) -> IO ()) -> IO (a, b) -> IO ()
forall a b. (a -> b) -> a -> b
$ WriteBinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forall b a. WriteBinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forwardPutRel WriteBinHandle
bh b -> IO a
put_A IO b
put_B

-- | Read a value stored using a forward reference.
--
-- The forward reference is expected to be a relative offset.
forwardGetRel :: ReadBinHandle -> IO a -> IO a
forwardGetRel :: forall a. ReadBinHandle -> IO a -> IO a
forwardGetRel ReadBinHandle
bh IO a
get_A = do
    -- read forward reference
    p <- ReadBinHandle -> IO (RelBin (ZonkAny 11))
forall {k} (a :: k). ReadBinHandle -> IO (RelBin a)
getRelBin ReadBinHandle
bh
    -- store current position
    p_a <- tellBinReader bh
    -- go read the forward value, then seek back
    seekBinReader bh $ makeAbsoluteBin p
    r <- get_A
    seekBinReader bh p_a
    pure r

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

lazyPut :: Binary a => WriteBinHandle -> a -> IO ()
lazyPut :: forall a. Binary a => WriteBinHandle -> a -> IO ()
lazyPut = (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO ()
forall a.
(WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO ()
lazyPut' WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_

lazyGet :: Binary a => ReadBinHandle -> IO a
lazyGet :: forall a. Binary a => ReadBinHandle -> IO a
lazyGet = (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a
forall a. (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a
lazyGet' ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
get

lazyPut' :: (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO ()
lazyPut' :: forall a.
(WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO ()
lazyPut' WriteBinHandle -> a -> IO ()
f WriteBinHandle
bh a
a = do
    -- output the obj with a ptr to skip over it:
    pre_a <- WriteBinHandle -> IO (Bin (RelBinPtr (ZonkAny 9)))
forall {k} (a :: k). WriteBinHandle -> IO (Bin a)
tellBinWriter WriteBinHandle
bh
    put_ bh pre_a       -- save a slot for the ptr
    f bh a           -- dump the object
    q <- tellBinWriter bh     -- q = ptr to after object
    putAtRel bh pre_a q    -- fill in slot before a with ptr to q
    seekBinWriter bh q        -- finally carry on writing at q

lazyGet' :: (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a
lazyGet' :: forall a. (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a
lazyGet' ReadBinHandle -> IO a
f ReadBinHandle
bh = do
    p <- ReadBinHandle -> IO (RelBin (ZonkAny 15))
forall {k} (a :: k). ReadBinHandle -> IO (RelBin a)
getRelBin ReadBinHandle
bh -- a BinPtr
    p_a <- tellBinReader bh
    a <- unsafeInterleaveIO $ do
        -- NB: Use a fresh rbm_off_r variable in the child thread, for thread
        -- safety.
        off_r <- newFastMutInt 0
        let bh' = ReadBinHandle
bh { rbm_off_r = off_r }
        seekBinReader bh' p_a
        f bh'
    seekBinReader bh (makeAbsoluteBin p) -- skip over the object for now
    return a

-- | Serialize the constructor strictly but lazily serialize a value inside a
-- 'Just'.
--
-- This way we can check for the presence of a value without deserializing the
-- value itself.
lazyPutMaybe :: Binary a => WriteBinHandle -> Maybe a -> IO ()
lazyPutMaybe :: forall a. Binary a => WriteBinHandle -> Maybe a -> IO ()
lazyPutMaybe WriteBinHandle
bh Maybe a
Nothing  = WriteBinHandle -> Word8 -> IO ()
putWord8 WriteBinHandle
bh Word8
0
lazyPutMaybe WriteBinHandle
bh (Just a
x) = do
  WriteBinHandle -> Word8 -> IO ()
putWord8 WriteBinHandle
bh Word8
1
  WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
lazyPut WriteBinHandle
bh a
x

-- | Deserialize a value serialized by 'lazyPutMaybe'.
lazyGetMaybe :: Binary a => ReadBinHandle -> IO (Maybe a)
lazyGetMaybe :: forall a. Binary a => ReadBinHandle -> IO (Maybe a)
lazyGetMaybe ReadBinHandle
bh = do
  h <- ReadBinHandle -> IO Word8
getWord8 ReadBinHandle
bh
  case h of
    Word8
0 -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Word8
_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO a
forall a. Binary a => ReadBinHandle -> IO a
lazyGet ReadBinHandle
bh

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

-- Note [Binary 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.
--

-- | Newtype to serialise binding names differently to non-binding 'Name'.
-- See Note [Binary UserData]
newtype BindingName = BindingName { BindingName -> Name
getBindingName :: Name }
  deriving ( BindingName -> BindingName -> Bool
(BindingName -> BindingName -> Bool)
-> (BindingName -> BindingName -> Bool) -> Eq BindingName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BindingName -> BindingName -> Bool
== :: BindingName -> BindingName -> Bool
$c/= :: BindingName -> BindingName -> Bool
/= :: BindingName -> BindingName -> Bool
Eq )

simpleBindingNameWriter :: BinaryWriter Name -> BinaryWriter BindingName
simpleBindingNameWriter :: BinaryWriter Name -> BinaryWriter BindingName
simpleBindingNameWriter = BinaryWriter Name -> BinaryWriter BindingName
forall a b. Coercible a b => a -> b
coerce

simpleBindingNameReader :: BinaryReader Name -> BinaryReader BindingName
simpleBindingNameReader :: BinaryReader Name -> BinaryReader BindingName
simpleBindingNameReader = BinaryReader Name -> BinaryReader BindingName
forall a b. Coercible a b => a -> b
coerce

-- | Existential for 'BinaryWriter' with a type witness.
data SomeBinaryWriter = forall a . SomeBinaryWriter (Refl.TypeRep a) (BinaryWriter a)

-- | Existential for 'BinaryReader' with a type witness.
data SomeBinaryReader = forall a . SomeBinaryReader (Refl.TypeRep a) (BinaryReader a)

-- | UserData required to serialise symbols for interface files.
--
-- See Note [Binary UserData]
data WriterUserData =
   WriterUserData {
      WriterUserData -> Map SomeTypeRep SomeBinaryWriter
ud_writer_data :: Map SomeTypeRep SomeBinaryWriter
      -- ^ A mapping from a type witness to the 'Writer' for the associated type.
      -- This is a 'Map' because microbenchmarks indicated this is more efficient
      -- than other representations for less than ten elements.
      --
      -- Considered representations:
      --
      -- * [(TypeRep, SomeBinaryWriter)]
      -- * bytehash (on hackage)
      -- * Map TypeRep SomeBinaryWriter
   }

-- | UserData required to deserialise symbols for interface files.
--
-- See Note [Binary UserData]
data ReaderUserData =
   ReaderUserData {
      ReaderUserData -> Map SomeTypeRep SomeBinaryReader
ud_reader_data :: Map SomeTypeRep SomeBinaryReader
      -- ^ A mapping from a type witness to the 'Reader' for the associated type.
      -- This is a 'Map' because microbenchmarks indicated this is more efficient
      -- than other representations for less than ten elements.
      --
      -- Considered representations:
      --
      -- * [(TypeRep, SomeBinaryReader)]
      -- * bytehash (on hackage)
      -- * Map TypeRep SomeBinaryReader
   }

mkWriterUserData :: [SomeBinaryWriter] -> WriterUserData
mkWriterUserData :: [SomeBinaryWriter] -> WriterUserData
mkWriterUserData [SomeBinaryWriter]
caches = WriterUserData
noWriterUserData
  { ud_writer_data = Map.fromList $ map (\cache :: SomeBinaryWriter
cache@(SomeBinaryWriter TypeRep a
typRep BinaryWriter a
_) -> (TypeRep a -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
typRep, SomeBinaryWriter
cache)) caches
  }

mkReaderUserData :: [SomeBinaryReader] -> ReaderUserData
mkReaderUserData :: [SomeBinaryReader] -> ReaderUserData
mkReaderUserData [SomeBinaryReader]
caches = ReaderUserData
noReaderUserData
  { ud_reader_data = Map.fromList $ map (\cache :: SomeBinaryReader
cache@(SomeBinaryReader TypeRep a
typRep BinaryReader a
_) -> (TypeRep a -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
typRep, SomeBinaryReader
cache)) caches
  }

mkSomeBinaryWriter :: forall a . Refl.Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter :: forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter BinaryWriter a
cb = TypeRep a -> BinaryWriter a -> SomeBinaryWriter
forall a. TypeRep a -> BinaryWriter a -> SomeBinaryWriter
SomeBinaryWriter (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Refl.typeRep @a) BinaryWriter a
cb

mkSomeBinaryReader :: forall a . Refl.Typeable a => BinaryReader a -> SomeBinaryReader
mkSomeBinaryReader :: forall a. Typeable a => BinaryReader a -> SomeBinaryReader
mkSomeBinaryReader BinaryReader a
cb = TypeRep a -> BinaryReader a -> SomeBinaryReader
forall a. TypeRep a -> BinaryReader a -> SomeBinaryReader
SomeBinaryReader (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Refl.typeRep @a) BinaryReader a
cb

newtype BinaryReader s = BinaryReader
  { forall s. BinaryReader s -> ReadBinHandle -> IO s
getEntry :: ReadBinHandle -> IO s
  } deriving ((forall a b. (a -> b) -> BinaryReader a -> BinaryReader b)
-> (forall a b. a -> BinaryReader b -> BinaryReader a)
-> Functor BinaryReader
forall a b. a -> BinaryReader b -> BinaryReader a
forall a b. (a -> b) -> BinaryReader a -> BinaryReader b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> BinaryReader a -> BinaryReader b
fmap :: forall a b. (a -> b) -> BinaryReader a -> BinaryReader b
$c<$ :: forall a b. a -> BinaryReader b -> BinaryReader a
<$ :: forall a b. a -> BinaryReader b -> BinaryReader a
Functor)

newtype BinaryWriter s = BinaryWriter
  { forall s. BinaryWriter s -> WriteBinHandle -> s -> IO ()
putEntry :: WriteBinHandle -> s -> IO ()
  }

mkWriter :: (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter :: forall s. (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter WriteBinHandle -> s -> IO ()
f = BinaryWriter
  { putEntry :: WriteBinHandle -> s -> IO ()
putEntry = WriteBinHandle -> s -> IO ()
f
  }

mkReader :: (ReadBinHandle -> IO s) -> BinaryReader s
mkReader :: forall s. (ReadBinHandle -> IO s) -> BinaryReader s
mkReader ReadBinHandle -> IO s
f = BinaryReader
  { getEntry :: ReadBinHandle -> IO s
getEntry = ReadBinHandle -> IO s
f
  }

-- | Find the 'BinaryReader' for the 'Binary' instance for the type identified by 'Proxy a'.
--
-- If no 'BinaryReader' has been configured before, this function will panic.
findUserDataReader :: forall a . Refl.Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a
findUserDataReader :: forall a. Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a
findUserDataReader Proxy a
query ReadBinHandle
bh =
  case SomeTypeRep
-> Map SomeTypeRep SomeBinaryReader -> Maybe SomeBinaryReader
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Proxy a -> SomeTypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
Refl.someTypeRep Proxy a
query) (ReaderUserData -> Map SomeTypeRep SomeBinaryReader
ud_reader_data (ReaderUserData -> Map SomeTypeRep SomeBinaryReader)
-> ReaderUserData -> Map SomeTypeRep SomeBinaryReader
forall a b. (a -> b) -> a -> b
$ ReadBinHandle -> ReaderUserData
getReaderUserData ReadBinHandle
bh) of
    Maybe SomeBinaryReader
Nothing -> String -> BinaryReader a
forall a. HasCallStack => String -> a
panic (String -> BinaryReader a) -> String -> BinaryReader a
forall a b. (a -> b) -> a -> b
$ String
"Failed to find BinaryReader for the key: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeTypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> SomeTypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
Refl.someTypeRep Proxy a
query)
    Just (SomeBinaryReader TypeRep a
_ (BinaryReader a
reader :: BinaryReader x)) ->
      forall a b. a -> b
unsafeCoerce @(BinaryReader x) @(BinaryReader a) BinaryReader a
reader
      -- This 'unsafeCoerce' could be written safely like this:
      --
      -- @
      --   Just (SomeBinaryReader _ (reader :: BinaryReader x)) ->
      --     case testEquality (typeRep @a) tyRep of
      --       Just Refl -> coerce @(BinaryReader x) @(BinaryReader a) reader
      --       Nothing -> panic $ "Invariant violated"
      -- @
      --
      -- But it comes at a slight performance cost and this function is used in
      -- binary serialisation hot loops, thus, we prefer the small performance boost over
      -- the additional type safety.

-- | Find the 'BinaryWriter' for the 'Binary' instance for the type identified by 'Proxy a'.
--
-- If no 'BinaryWriter' has been configured before, this function will panic.
findUserDataWriter :: forall a . Refl.Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a
findUserDataWriter :: forall a. Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a
findUserDataWriter Proxy a
query WriteBinHandle
bh =
  case SomeTypeRep
-> Map SomeTypeRep SomeBinaryWriter -> Maybe SomeBinaryWriter
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Proxy a -> SomeTypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
Refl.someTypeRep Proxy a
query) (WriterUserData -> Map SomeTypeRep SomeBinaryWriter
ud_writer_data (WriterUserData -> Map SomeTypeRep SomeBinaryWriter)
-> WriterUserData -> Map SomeTypeRep SomeBinaryWriter
forall a b. (a -> b) -> a -> b
$ WriteBinHandle -> WriterUserData
getWriterUserData WriteBinHandle
bh) of
    Maybe SomeBinaryWriter
Nothing -> String -> BinaryWriter a
forall a. HasCallStack => String -> a
panic (String -> BinaryWriter a) -> String -> BinaryWriter a
forall a b. (a -> b) -> a -> b
$ String
"Failed to find BinaryWriter for the key: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeTypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> SomeTypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
Refl.someTypeRep Proxy a
query)
    Just (SomeBinaryWriter TypeRep a
_ (BinaryWriter a
writer :: BinaryWriter x)) ->
      forall a b. a -> b
unsafeCoerce @(BinaryWriter x) @(BinaryWriter a) BinaryWriter a
writer
      -- This 'unsafeCoerce' could be written safely like this:
      --
      -- @
      --   Just (SomeBinaryWriter tyRep (writer :: BinaryWriter x)) ->
      --     case testEquality (typeRep @a) tyRep of
      --       Just Refl -> coerce @(BinaryWriter x) @(BinaryWriter a) writer
      --       Nothing -> panic $ "Invariant violated"
      -- @
      --
      -- But it comes at a slight performance cost and this function is used in
      -- binary serialisation hot loops, thus, we prefer the small performance boost over
      -- the additional type safety.


noReaderUserData :: ReaderUserData
noReaderUserData :: ReaderUserData
noReaderUserData = ReaderUserData
  { ud_reader_data :: Map SomeTypeRep SomeBinaryReader
ud_reader_data = Map SomeTypeRep SomeBinaryReader
forall k a. Map k a
Map.empty
  }

noWriterUserData :: WriterUserData
noWriterUserData :: WriterUserData
noWriterUserData = WriterUserData
  { ud_writer_data :: Map SomeTypeRep SomeBinaryWriter
ud_writer_data = Map SomeTypeRep SomeBinaryWriter
forall k a. Map k a
Map.empty
  }

newReadState :: (ReadBinHandle -> IO Name)   -- ^ how to deserialize 'Name's
             -> (ReadBinHandle -> IO FastString)
             -> ReaderUserData
newReadState :: (ReadBinHandle -> IO Name)
-> (ReadBinHandle -> IO FastString) -> ReaderUserData
newReadState ReadBinHandle -> IO Name
get_name ReadBinHandle -> IO FastString
get_fs =
  [SomeBinaryReader] -> ReaderUserData
mkReaderUserData
    [ BinaryReader Name -> SomeBinaryReader
forall a. Typeable a => BinaryReader a -> SomeBinaryReader
mkSomeBinaryReader (BinaryReader Name -> SomeBinaryReader)
-> BinaryReader Name -> SomeBinaryReader
forall a b. (a -> b) -> a -> b
$ (ReadBinHandle -> IO Name) -> BinaryReader Name
forall s. (ReadBinHandle -> IO s) -> BinaryReader s
mkReader ReadBinHandle -> IO Name
get_name
    , BinaryReader BindingName -> SomeBinaryReader
forall a. Typeable a => BinaryReader a -> SomeBinaryReader
mkSomeBinaryReader (BinaryReader BindingName -> SomeBinaryReader)
-> BinaryReader BindingName -> SomeBinaryReader
forall a b. (a -> b) -> a -> b
$ forall s. (ReadBinHandle -> IO s) -> BinaryReader s
mkReader @BindingName ((ReadBinHandle -> IO Name) -> ReadBinHandle -> IO BindingName
forall a b. Coercible a b => a -> b
coerce ReadBinHandle -> IO Name
get_name)
    , BinaryReader FastString -> SomeBinaryReader
forall a. Typeable a => BinaryReader a -> SomeBinaryReader
mkSomeBinaryReader (BinaryReader FastString -> SomeBinaryReader)
-> BinaryReader FastString -> SomeBinaryReader
forall a b. (a -> b) -> a -> b
$ (ReadBinHandle -> IO FastString) -> BinaryReader FastString
forall s. (ReadBinHandle -> IO s) -> BinaryReader s
mkReader ReadBinHandle -> IO FastString
get_fs
    ]

newWriteState :: (WriteBinHandle -> Name -> IO ())
                 -- ^ how to serialize non-binding 'Name's
              -> (WriteBinHandle -> Name -> IO ())
                 -- ^ how to serialize binding 'Name's
              -> (WriteBinHandle -> FastString -> IO ())
              -> WriterUserData
newWriteState :: (WriteBinHandle -> Name -> IO ())
-> (WriteBinHandle -> Name -> IO ())
-> (WriteBinHandle -> FastString -> IO ())
-> WriterUserData
newWriteState WriteBinHandle -> Name -> IO ()
put_non_binding_name WriteBinHandle -> Name -> IO ()
put_binding_name WriteBinHandle -> FastString -> IO ()
put_fs =
  [SomeBinaryWriter] -> WriterUserData
mkWriterUserData
    [ BinaryWriter BindingName -> SomeBinaryWriter
forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter (BinaryWriter BindingName -> SomeBinaryWriter)
-> BinaryWriter BindingName -> SomeBinaryWriter
forall a b. (a -> b) -> a -> b
$ (WriteBinHandle -> BindingName -> IO ())
-> BinaryWriter BindingName
forall s. (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter (\WriteBinHandle
bh BindingName
name -> WriteBinHandle -> Name -> IO ()
put_binding_name WriteBinHandle
bh (BindingName -> Name
getBindingName BindingName
name))
    , BinaryWriter Name -> SomeBinaryWriter
forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter (BinaryWriter Name -> SomeBinaryWriter)
-> BinaryWriter Name -> SomeBinaryWriter
forall a b. (a -> b) -> a -> b
$ (WriteBinHandle -> Name -> IO ()) -> BinaryWriter Name
forall s. (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter WriteBinHandle -> Name -> IO ()
put_non_binding_name
    , BinaryWriter FastString -> SomeBinaryWriter
forall a. Typeable a => BinaryWriter a -> SomeBinaryWriter
mkSomeBinaryWriter (BinaryWriter FastString -> SomeBinaryWriter)
-> BinaryWriter FastString -> SomeBinaryWriter
forall a b. (a -> b) -> a -> b
$ (WriteBinHandle -> FastString -> IO ()) -> BinaryWriter FastString
forall s. (WriteBinHandle -> s -> IO ()) -> BinaryWriter s
mkWriter WriteBinHandle -> FastString -> IO ()
put_fs
    ]

-- ----------------------------------------------------------------------------
-- Types for lookup and deduplication tables.
-- ----------------------------------------------------------------------------

-- | A 'ReaderTable' describes how to deserialise a table from disk,
-- and how to create a 'BinaryReader' that looks up values in the deduplication table.
data ReaderTable a = ReaderTable
  { forall a. ReaderTable a -> ReadBinHandle -> IO (SymbolTable a)
getTable :: ReadBinHandle -> IO (SymbolTable a)
  -- ^ Deserialise a list of elements into a 'SymbolTable'.
  , forall a. ReaderTable a -> SymbolTable a -> BinaryReader a
mkReaderFromTable :: SymbolTable a -> BinaryReader a
  -- ^ Given the table from 'getTable', create a 'BinaryReader'
  -- that reads values only from the 'SymbolTable'.
  }

-- | A 'WriterTable' is an interface any deduplication table can implement to
-- describe how the table can be written to disk.
newtype WriterTable = WriterTable
  { WriterTable -> WriteBinHandle -> IO Int
putTable :: WriteBinHandle -> IO Int
  -- ^ Serialise a table to disk. Returns the number of written elements.
  }

-- ----------------------------------------------------------------------------
-- Common data structures for constructing and maintaining lookup tables for
-- binary serialisation and deserialisation.
-- ----------------------------------------------------------------------------

-- | The 'GenericSymbolTable' stores a mapping from already seen elements to an index.
-- If an element wasn't seen before, it is added to the mapping together with a fresh
-- index.
--
-- 'GenericSymbolTable' is a variant of a 'BinSymbolTable' that is polymorphic in the table implementation.
-- As such it can be used with any container that implements the 'TrieMap' type class.
--
-- While 'GenericSymbolTable' is similar to the 'BinSymbolTable', it supports storing tree-like
-- structures such as 'Type' and 'IfaceType' more efficiently.
--
data GenericSymbolTable m = GenericSymbolTable
  { forall (m :: * -> *). GenericSymbolTable m -> FastMutInt
gen_symtab_next :: !FastMutInt
  -- ^ The next index to use.
  , forall (m :: * -> *). GenericSymbolTable m -> IORef (m Int)
gen_symtab_map  :: !(IORef (m Int))
  -- ^ Given a symbol, find the symbol and return its index.
  , forall (m :: * -> *). GenericSymbolTable m -> IORef [Key m]
gen_symtab_to_write :: !(IORef [Key m])
  -- ^ Reversed list of values to write into the buffer.
  -- This is an optimisation, as it allows us to write out quickly all
  -- newly discovered values that are discovered when serialising 'Key m'
  -- to disk.
  }

-- | Initialise a 'GenericSymbolTable', initialising the index to '0'.
initGenericSymbolTable :: TrieMap m => IO (GenericSymbolTable m)
initGenericSymbolTable :: forall (m :: * -> *). TrieMap m => IO (GenericSymbolTable m)
initGenericSymbolTable = do
  symtab_next <- Int -> IO FastMutInt
newFastMutInt Int
0
  symtab_map <- newIORef emptyTM
  symtab_todo <- newIORef []
  pure $ GenericSymbolTable
        { gen_symtab_next = symtab_next
        , gen_symtab_map  = symtab_map
        , gen_symtab_to_write = symtab_todo
        }

-- | Serialise the 'GenericSymbolTable' to disk.
--
-- Since 'GenericSymbolTable' stores tree-like structures, such as 'IfaceType',
-- serialising an element can add new elements to the mapping.
-- Thus, 'putGenericSymbolTable' first serialises all values, and then checks whether any
-- new elements have been discovered. If so, repeat the loop.
putGenericSymbolTable :: forall m. (TrieMap m) => GenericSymbolTable m -> (WriteBinHandle -> Key m -> IO ()) -> WriteBinHandle -> IO Int
{-# INLINE putGenericSymbolTable #-}
putGenericSymbolTable :: forall (m :: * -> *).
TrieMap m =>
GenericSymbolTable m
-> (WriteBinHandle -> Key m -> IO ()) -> WriteBinHandle -> IO Int
putGenericSymbolTable GenericSymbolTable m
gen_sym_tab WriteBinHandle -> Key m -> IO ()
serialiser WriteBinHandle
bh = do
  WriteBinHandle -> IO Int
putGenericSymbolTable WriteBinHandle
bh
  where
    symtab_next :: FastMutInt
symtab_next = GenericSymbolTable m -> FastMutInt
forall (m :: * -> *). GenericSymbolTable m -> FastMutInt
gen_symtab_next GenericSymbolTable m
gen_sym_tab
    symtab_to_write :: IORef [Key m]
symtab_to_write = GenericSymbolTable m -> IORef [Key m]
forall (m :: * -> *). GenericSymbolTable m -> IORef [Key m]
gen_symtab_to_write GenericSymbolTable m
gen_sym_tab
    putGenericSymbolTable :: WriteBinHandle -> IO Int
    putGenericSymbolTable :: WriteBinHandle -> IO Int
putGenericSymbolTable WriteBinHandle
bh  = do
      let loop :: IO Int
loop = do
            vs <- IORef [Key m] -> ([Key m] -> ([Key m], [Key m])) -> IO [Key m]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Key m]
symtab_to_write (\[Key m]
a -> ([], [Key m]
a))
            case vs of
              [] -> FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
              [Key m]
todo -> do
                (Key m -> IO ()) -> [Key m] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Key m
n -> WriteBinHandle -> Key m -> IO ()
serialiser WriteBinHandle
bh Key m
n) ([Key m] -> [Key m]
forall a. [a] -> [a]
reverse [Key m]
todo)
                IO Int
loop
      ((), Int) -> Int
forall a b. (a, b) -> b
snd (((), Int) -> Int) -> IO ((), Int) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (WriteBinHandle -> (Int -> IO ()) -> IO Int -> IO ((), Int)
forall b a. WriteBinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forwardPutRel WriteBinHandle
bh (IO () -> Int -> IO ()
forall a b. a -> b -> a
const (IO () -> Int -> IO ()) -> IO () -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh) (IO Int -> IO ((), Int)) -> IO Int -> IO ((), Int)
forall a b. (a -> b) -> a -> b
$
          IO Int
loop)

-- | Read the elements of a 'GenericSymbolTable' from disk into a 'SymbolTable'.
getGenericSymbolTable :: forall a . (ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a)
getGenericSymbolTable :: forall a.
(ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a)
getGenericSymbolTable ReadBinHandle -> IO a
deserialiser ReadBinHandle
bh = do
  sz <- ReadBinHandle -> IO Int -> IO Int
forall a. ReadBinHandle -> IO a -> IO a
forwardGetRel ReadBinHandle
bh (ReadBinHandle -> IO Int
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh) :: IO Int
  mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)
  forM_ [0..(sz-1)] $ \Int
i -> do
    f <- ReadBinHandle -> IO a
deserialiser ReadBinHandle
bh
    writeArray mut_arr i f
  unsafeFreeze mut_arr

-- | Write an element 'Key m' to the given 'WriteBinHandle'.
--
-- If the element was seen before, we simply write the index of that element to the
-- 'WriteBinHandle'. If we haven't seen it before, we add the element to
-- the 'GenericSymbolTable', increment the index, and return this new index.
putGenericSymTab :: (TrieMap m) => GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()
{-# INLINE putGenericSymTab #-}
putGenericSymTab :: forall (m :: * -> *).
TrieMap m =>
GenericSymbolTable m -> WriteBinHandle -> Key m -> IO ()
putGenericSymTab GenericSymbolTable{
               gen_symtab_map :: forall (m :: * -> *). GenericSymbolTable m -> IORef (m Int)
gen_symtab_map = IORef (m Int)
symtab_map_ref,
               gen_symtab_next :: forall (m :: * -> *). GenericSymbolTable m -> FastMutInt
gen_symtab_next = FastMutInt
symtab_next,
               gen_symtab_to_write :: forall (m :: * -> *). GenericSymbolTable m -> IORef [Key m]
gen_symtab_to_write = IORef [Key m]
symtab_todo }
        WriteBinHandle
bh Key m
val = do
  symtab_map <- IORef (m Int) -> IO (m Int)
forall a. IORef a -> IO a
readIORef IORef (m Int)
symtab_map_ref
  case lookupTM val symtab_map of
    Just Int
off -> WriteBinHandle -> Word32 -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
    Maybe Int
Nothing -> do
      off <- FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
      writeFastMutInt symtab_next (off+1)
      writeIORef symtab_map_ref
          $! insertTM val off symtab_map
      atomicModifyIORef symtab_todo (\[Key m]
todo -> (Key m
val Key m -> [Key m] -> [Key m]
forall a. a -> [a] -> [a]
: [Key m]
todo, ()))
      put_ bh (fromIntegral off :: Word32)

-- | Read a value from a 'SymbolTable'.
getGenericSymtab :: Binary a => SymbolTable a -> ReadBinHandle -> IO a
getGenericSymtab :: forall a. Binary a => SymbolTable a -> ReadBinHandle -> IO a
getGenericSymtab SymbolTable a
symtab ReadBinHandle
bh = do
  i :: Word32 <- ReadBinHandle -> IO Word32
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
  return $! symtab ! fromIntegral i

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

-- | A 'SymbolTable' of 'FastString's.
type Dictionary = SymbolTable FastString

initFastStringReaderTable :: IO (ReaderTable FastString)
initFastStringReaderTable :: IO (ReaderTable FastString)
initFastStringReaderTable = do
  ReaderTable FastString -> IO (ReaderTable FastString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReaderTable FastString -> IO (ReaderTable FastString))
-> ReaderTable FastString -> IO (ReaderTable FastString)
forall a b. (a -> b) -> a -> b
$
    ReaderTable
      { getTable :: ReadBinHandle -> IO (SymbolTable FastString)
getTable = ReadBinHandle -> IO (SymbolTable FastString)
getDictionary
      , mkReaderFromTable :: SymbolTable FastString -> BinaryReader FastString
mkReaderFromTable = \SymbolTable FastString
tbl -> (ReadBinHandle -> IO FastString) -> BinaryReader FastString
forall s. (ReadBinHandle -> IO s) -> BinaryReader s
mkReader (SymbolTable FastString -> ReadBinHandle -> IO FastString
getDictFastString SymbolTable FastString
tbl)
      }

initFastStringWriterTable :: IO (WriterTable, BinaryWriter FastString)
initFastStringWriterTable :: IO (WriterTable, BinaryWriter FastString)
initFastStringWriterTable = do
  dict_next_ref <- Int -> IO FastMutInt
newFastMutInt Int
0
  dict_map_ref <- newIORef emptyUFM
  let bin_dict =
        FSTable
          { fs_tab_next :: FastMutInt
fs_tab_next = FastMutInt
dict_next_ref
          , fs_tab_map :: IORef (UniqFM FastString (Int, FastString))
fs_tab_map = IORef (UniqFM FastString (Int, FastString))
dict_map_ref
          }
  let put_dict WriteBinHandle
bh = do
        fs_count <- FastMutInt -> IO Int
readFastMutInt FastMutInt
dict_next_ref
        dict_map <- readIORef dict_map_ref
        putDictionary bh fs_count dict_map
        pure fs_count

  return
    ( WriterTable
        { putTable = put_dict
        }
    , mkWriter $ putDictFastString bin_dict
    )

putDictionary :: WriteBinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO ()
putDictionary :: WriteBinHandle
-> Int -> UniqFM FastString (Int, FastString) -> IO ()
putDictionary WriteBinHandle
bh Int
sz UniqFM FastString (Int, FastString)
dict = do
  WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh Int
sz
  (FastString -> IO ()) -> [FastString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (WriteBinHandle -> FastString -> IO ()
putFS WriteBinHandle
bh) (SymbolTable FastString -> [FastString]
forall i e. Array i e -> [e]
elems ((Int, Int) -> [(Int, FastString)] -> SymbolTable FastString
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (UniqFM FastString (Int, FastString) -> [(Int, FastString)]
forall {k} (key :: k) 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 :: ReadBinHandle -> IO Dictionary
getDictionary :: ReadBinHandle -> IO (SymbolTable FastString)
getDictionary ReadBinHandle
bh = do
  sz <- ReadBinHandle -> IO Int
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh :: IO Int
  mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString)
  forM_ [0..(sz-1)] $ \Int
i -> do
    fs <- ReadBinHandle -> IO FastString
getFS ReadBinHandle
bh
    writeArray mut_arr i fs
  unsafeFreeze mut_arr

getDictFastString :: Dictionary -> ReadBinHandle -> IO FastString
getDictFastString :: SymbolTable FastString -> ReadBinHandle -> IO FastString
getDictFastString SymbolTable FastString
dict ReadBinHandle
bh = do
    j <- ReadBinHandle -> IO Word32
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
    return $! (dict ! fromIntegral (j :: Word32))

putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO ()
putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO ()
putDictFastString FSTable
dict WriteBinHandle
bh FastString
fs = FSTable -> FastString -> IO Word32
allocateFastString FSTable
dict FastString
fs IO Word32 -> (Word32 -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriteBinHandle -> Word32 -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh

allocateFastString :: FSTable -> FastString -> IO Word32
allocateFastString :: FSTable -> FastString -> IO Word32
allocateFastString FSTable { fs_tab_next :: FSTable -> FastMutInt
fs_tab_next = FastMutInt
j_r
                           , fs_tab_map :: FSTable -> IORef (UniqFM FastString (Int, FastString))
fs_tab_map  = IORef (UniqFM FastString (Int, FastString))
out_r
                           } FastString
f = do
    out <- IORef (UniqFM FastString (Int, FastString))
-> IO (UniqFM FastString (Int, FastString))
forall a. IORef a -> IO a
readIORef IORef (UniqFM FastString (Int, FastString))
out_r
    let !uniq = FastString -> Unique
forall a. Uniquable a => a -> Unique
getUnique FastString
f
    case lookupUFM_Directly out uniq of
        Just (Int
j, FastString
_)  -> Word32 -> IO Word32
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j :: Word32)
        Maybe (Int, FastString)
Nothing -> do
           j <- FastMutInt -> IO Int
readFastMutInt FastMutInt
j_r
           writeFastMutInt j_r (j + 1)
           writeIORef out_r $! addToUFM_Directly out uniq (j, f)
           return (fromIntegral j :: Word32)

-- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to
-- avoid a collision and copy to avoid a dependency.
data FSTable = FSTable { FSTable -> FastMutInt
fs_tab_next :: !FastMutInt -- The next index to use
                       , FSTable -> IORef (UniqFM FastString (Int, FastString))
fs_tab_map  :: !(IORef (UniqFM FastString (Int,FastString)))
                                -- indexed by FastString
  }


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

-- | Symbols that are read from disk.
-- The 'SymbolTable' index starts on '0'.
type SymbolTable a = Array Int a

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

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

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

-- | Put a ByteString without its length (can't be read back without knowing the
-- length!)
putByteString :: WriteBinHandle -> ByteString -> IO ()
putByteString :: WriteBinHandle -> ByteString -> IO ()
putByteString WriteBinHandle
bh ByteString
bs =
  ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr, Int
l) -> do
    WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim WriteBinHandle
bh Int
l (\Ptr Word8
op -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
op (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr) Int
l)

-- | Get a ByteString whose length is known
getByteString :: ReadBinHandle -> Int -> IO ByteString
getByteString :: ReadBinHandle -> Int -> IO ByteString
getByteString ReadBinHandle
bh Int
l =
  Int -> (Ptr Word8 -> IO ()) -> IO ByteString
BS.create Int
l ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dest -> do
    ReadBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
forall a. ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim ReadBinHandle
bh Int
l (\Ptr Word8
src -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
dest Ptr Word8
src Int
l)

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

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

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

instance Binary FastString where
  put_ :: WriteBinHandle -> FastString -> IO ()
put_ WriteBinHandle
bh FastString
f =
    case Proxy FastString -> WriteBinHandle -> BinaryWriter FastString
forall a. Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a
findUserDataWriter (Proxy FastString
forall {k} (t :: k). Proxy t
Proxy :: Proxy FastString) WriteBinHandle
bh of
      BinaryWriter FastString
tbl -> BinaryWriter FastString -> WriteBinHandle -> FastString -> IO ()
forall s. BinaryWriter s -> WriteBinHandle -> s -> IO ()
putEntry BinaryWriter FastString
tbl WriteBinHandle
bh FastString
f

  get :: ReadBinHandle -> IO FastString
get ReadBinHandle
bh =
    case Proxy FastString -> ReadBinHandle -> BinaryReader FastString
forall a. Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a
findUserDataReader (Proxy FastString
forall {k} (t :: k). Proxy t
Proxy :: Proxy FastString) ReadBinHandle
bh of
      BinaryReader FastString
tbl -> BinaryReader FastString -> ReadBinHandle -> IO FastString
forall s. BinaryReader s -> ReadBinHandle -> IO s
getEntry BinaryReader FastString
tbl ReadBinHandle
bh

deriving instance Binary NonDetFastString
deriving instance Binary LexicalFastString

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

instance Binary ModuleName where
  put_ :: WriteBinHandle -> ModuleName -> IO ()
put_ WriteBinHandle
bh (ModuleName FastString
fs) = WriteBinHandle -> FastString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh FastString
fs
  get :: ReadBinHandle -> IO ModuleName
get ReadBinHandle
bh = do fs <- ReadBinHandle -> IO FastString
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh; return (ModuleName fs)

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

newtype BinLocated a = BinLocated { forall a. BinLocated a -> Located a
unBinLocated :: Located a }

instance Binary a => Binary (BinLocated a) where
    put_ :: WriteBinHandle -> BinLocated a -> IO ()
put_ WriteBinHandle
bh (BinLocated (L SrcSpan
l a
x)) = do
            WriteBinHandle -> BinSrcSpan -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (BinSrcSpan -> IO ()) -> BinSrcSpan -> IO ()
forall a b. (a -> b) -> a -> b
$ SrcSpan -> BinSrcSpan
BinSrcSpan SrcSpan
l
            WriteBinHandle -> a -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh a
x

    get :: ReadBinHandle -> IO (BinLocated a)
get ReadBinHandle
bh = do
            l <- BinSrcSpan -> SrcSpan
unBinSrcSpan (BinSrcSpan -> SrcSpan) -> IO BinSrcSpan -> IO SrcSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO BinSrcSpan
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
            x <- get bh
            return $ BinLocated (L l x)

newtype BinSpan = BinSpan { BinSpan -> RealSrcSpan
unBinSpan :: RealSrcSpan }

-- See Note [Source Location Wrappers]
instance Binary BinSpan where
  put_ :: WriteBinHandle -> BinSpan -> IO ()
put_ WriteBinHandle
bh (BinSpan RealSrcSpan
ss) = do
            WriteBinHandle -> FastString -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
ss)
            WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
ss)
            WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
ss)
            WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
ss)
            WriteBinHandle -> Int -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
ss)

  get :: ReadBinHandle -> IO BinSpan
get ReadBinHandle
bh = do
            f <- ReadBinHandle -> IO FastString
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
            sl <- get bh
            sc <- get bh
            el <- get bh
            ec <- get bh
            return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc)
                                            (mkRealSrcLoc f el ec))

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

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

newtype BinSrcSpan = BinSrcSpan { BinSrcSpan -> SrcSpan
unBinSrcSpan :: SrcSpan }

-- See Note [Source Location Wrappers]
instance Binary BinSrcSpan where
  put_ :: WriteBinHandle -> BinSrcSpan -> IO ()
put_ WriteBinHandle
bh (BinSrcSpan (RealSrcSpan RealSrcSpan
ss Maybe BufSpan
_sb)) = do
          WriteBinHandle -> Word8 -> IO ()
putByte WriteBinHandle
bh Word8
0
          -- BufSpan doesn't ever get serialised because the positions depend
          -- on build location.
          WriteBinHandle -> BinSpan -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (BinSpan -> IO ()) -> BinSpan -> IO ()
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> BinSpan
BinSpan RealSrcSpan
ss

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

  get :: ReadBinHandle -> IO BinSrcSpan
get ReadBinHandle
bh = do
          h <- ReadBinHandle -> IO Word8
getByte ReadBinHandle
bh
          case h of
            Word8
0 -> do BinSpan ss <- ReadBinHandle -> IO BinSpan
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
                    return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing)
            Word8
_ -> do s <- ReadBinHandle -> IO UnhelpfulSpanReason
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh
                    return $ BinSrcSpan (UnhelpfulSpan s)


{-
Note [Source Location Wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Source locations are banned from interface files, to
prevent filepaths affecting interface hashes.

Unfortunately, we can't remove all binary instances,
as they're used to serialise .hie files, and we don't
want to break binary compatibility.

To this end, the Bin[Src]Span newtypes wrappers were
introduced to prevent accidentally serialising a
source location as part of a larger structure.
-}

--------------------------------------------------------------------------------
-- Instances for the containers package
--------------------------------------------------------------------------------

instance (Binary v) => Binary (IntMap v) where
  put_ :: WriteBinHandle -> IntMap v -> IO ()
put_ WriteBinHandle
bh IntMap v
m = WriteBinHandle -> [(Int, v)] -> IO ()
forall a. Binary a => WriteBinHandle -> a -> IO ()
put_ WriteBinHandle
bh (IntMap v -> [(Int, v)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap v
m)
  get :: ReadBinHandle -> IO (IntMap v)
get ReadBinHandle
bh = [(Int, v)] -> IntMap v
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, v)] -> IntMap v) -> IO [(Int, v)] -> IO (IntMap v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadBinHandle -> IO [(Int, v)]
forall a. Binary a => ReadBinHandle -> IO a
get ReadBinHandle
bh