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

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

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

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

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

   openBinMem,
--   closeBin,

   seekBin,
   tellBin,
   castBin,
   withBinBuffer,

   foldGet,

   writeBinMem,
   readBinMem,
   readBinMemN,

   putAt, getAt,
   forwardPut, forwardPut_, forwardGet,

   -- * For writing instances
   putByte,
   getByte,

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

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

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

   -- * User data
   UserData(..), getUserData, setUserData,
   newReadState, newWriteState, noUserData,

   -- * String table ("dictionary")
   putDictionary, getDictionary, putFS,
   FSTable, initFSTable, getDictFastString, putDictFastString,

   -- * Newtype wrappers
   BinSpan(..), BinSrcSpan(..), BinLocated(..)
  ) where

import GHC.Prelude

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

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

import Control.DeepSeq
import Foreign hiding (shiftL, shiftR, void)
import Data.Array
import Data.Array.IO
import Data.Array.Unsafe
import Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe   as BS
import Data.IORef
import Data.Char                ( ord, chr )
import Data.List.NonEmpty       ( NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Set                 ( Set )
import qualified Data.Set as Set
import Data.Time
import Data.List (unfoldr)
import Control.Monad            ( when, (<$!>), unless, forM_, void )
import System.IO as IO
import System.IO.Unsafe         ( unsafeInterleaveIO )
import System.IO.Error          ( mkIOError, eofErrorType )
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

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_ :: BinHandle -> BinData -> IO ()
put_ BinHandle
bh (BinData Int
sz BinArray
dat) = do
    BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
sz
    BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
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 :: BinHandle -> IO BinData
get BinHandle
bh = do
    Int
sz <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    BinArray
dat <- Int -> IO BinArray
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
sz
    BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
bh Int
sz ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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
    BinData -> IO BinData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> BinArray -> BinData
BinData Int
sz BinArray
dat)

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

handleData :: BinHandle -> IO BinData
handleData :: BinHandle -> IO BinData
handleData (BinMem UserData
_ FastMutInt
ixr FastMutInt
_ IORef BinArray
binr) = Int -> BinArray -> BinData
BinData (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

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

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

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

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

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

unsafeUnpackBinBuffer :: ByteString -> IO BinHandle
unsafeUnpackBinBuffer :: ByteString -> IO BinHandle
unsafeUnpackBinBuffer (BS.BS BinArray
arr Int
len) = do
  IORef BinArray
arr_r <- BinArray -> IO (IORef BinArray)
forall a. a -> IO (IORef a)
newIORef BinArray
arr
  FastMutInt
ix_r <- Int -> IO FastMutInt
newFastMutInt Int
0
  FastMutInt
sz_r <- Int -> IO FastMutInt
newFastMutInt Int
len
  BinHandle -> IO BinHandle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UserData -> FastMutInt -> FastMutInt -> IORef BinArray -> BinHandle
BinMem UserData
noUserData FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r)

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

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

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

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

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

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

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

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

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

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

-- | SeekBin but without calling expandBin
seekBinNoExpand :: BinHandle -> Bin a -> IO ()
seekBinNoExpand :: forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBinNoExpand (BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
_) (BinPtr !Int
p) = do
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  if (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz)
        then String -> IO ()
forall a. HasCallStack => String -> a
panic String
"seekBinNoExpand: seek out of range"
        else FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
p

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

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

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

readBinMem_ :: Int -> Handle -> IO BinHandle
readBinMem_ :: Int -> Handle -> IO BinHandle
readBinMem_ Int
filesize Handle
h = do
  BinArray
arr <- Int -> IO BinArray
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
filesize
  Int
count <- BinArray -> (Ptr Word8 -> IO Int) -> IO Int
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr BinArray
arr ((Ptr Word8 -> IO Int) -> IO Int)
-> (Ptr Word8 -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
filesize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       String -> IO ()
forall a. HasCallStack => String -> a
error (String
"Binary.readBinMem: only read " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes")
  IORef BinArray
arr_r <- BinArray -> IO (IORef BinArray)
forall a. a -> IO (IORef a)
newIORef BinArray
arr
  FastMutInt
ix_r <- Int -> IO FastMutInt
newFastMutInt Int
0
  FastMutInt
sz_r <- Int -> IO FastMutInt
newFastMutInt Int
filesize
  BinHandle -> IO BinHandle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UserData -> FastMutInt -> FastMutInt -> IORef BinArray -> BinHandle
BinMem UserData
noUserData FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r)

-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
expandBin :: BinHandle -> Int -> IO ()
expandBin (BinMem UserData
_ FastMutInt
_ FastMutInt
sz_r IORef BinArray
arr_r) !Int
off = do
   !Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
   let !sz' :: Int
sz' = Int -> Int
getSize Int
sz
   BinArray
arr <- IORef BinArray -> IO BinArray
forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
   BinArray
arr' <- Int -> IO BinArray
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
sz'
   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
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
   FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
sz_r Int
sz'
   IORef BinArray -> BinArray -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef BinArray
arr_r BinArray
arr'
   where
    getSize :: Int -> Int
    getSize :: Int -> Int
getSize !Int
sz
      | Int
sz 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
  -> BinHandle
  -> b -- initial accumulator
  -> (Word -> a -> b -> IO b)
  -> IO b
foldGet :: forall a b.
Binary a =>
Word -> BinHandle -> b -> (Word -> a -> b -> IO b) -> IO b
foldGet Word
n BinHandle
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
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
          b
b' <- Word -> a -> b -> IO b
f Word
i a
a b
b
          Word -> b -> IO b
go (Word
iWord -> Word -> Word
forall a. Num a => a -> a -> a
+Word
1) b
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 :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim h :: BinHandle
h@(BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r) Int
size Ptr Word8 -> IO ()
f = do
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
sz) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    BinHandle -> Int -> IO ()
expandBin BinHandle
h (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size)
  BinArray
arr <- IORef BinArray -> IO BinArray
forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  BinArray -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr BinArray
arr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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)
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size)

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

getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim :: forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim (BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r) Int
size Ptr Word8 -> IO a
f = do
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
sz) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IOError -> IO ()
forall a. IOError -> IO a
ioError (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
eofErrorType String
"Data.Binary.getPrim" Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
  BinArray
arr <- IORef BinArray -> IO BinArray
forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  a
w <- BinArray -> (Ptr Word8 -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr BinArray
arr ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \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
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size)
  a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
w

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

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

putWord16 :: BinHandle -> Word16 -> IO ()
putWord16 :: BinHandle -> Word16 -> IO ()
putWord16 BinHandle
h Word16
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h Int
2 (\Ptr Word8
op -> do
  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 :: BinHandle -> IO Word16
getWord16 :: BinHandle -> IO Word16
getWord16 BinHandle
h = BinHandle -> Int -> (Ptr Word8 -> IO Word16) -> IO Word16
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h Int
2 (\Ptr Word8
op -> do
  Word16
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
  Word16
w1 <- 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
1
  Word16 -> IO Word16
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> IO Word16) -> Word16 -> IO Word16
forall a b. (a -> b) -> a -> b
$! Word16
w0 Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
w1
  )

putWord32 :: BinHandle -> Word32 -> IO ()
putWord32 :: BinHandle -> Word32 -> IO ()
putWord32 BinHandle
h Word32
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h Int
4 (\Ptr Word8
op -> do
  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 :: BinHandle -> IO Word32
getWord32 :: BinHandle -> IO Word32
getWord32 BinHandle
h = BinHandle -> Int -> (Ptr Word8 -> IO Word32) -> IO Word32
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h Int
4 (\Ptr Word8
op -> do
  Word32
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
  Word32
w1 <- 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
1
  Word32
w2 <- 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
2
  Word32
w3 <- 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
3

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

putWord64 :: BinHandle -> Word64 -> IO ()
putWord64 :: BinHandle -> Word64 -> IO ()
putWord64 BinHandle
h Word64
w = BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
h Int
8 (\Ptr Word8
op -> do
  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 :: BinHandle -> IO Word64
getWord64 :: BinHandle -> IO Word64
getWord64 BinHandle
h = BinHandle -> Int -> (Ptr Word8 -> IO Word64) -> IO Word64
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
h Int
8 (\Ptr Word8
op -> do
  Word64
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
  Word64
w1 <- 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
1
  Word64
w2 <- 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
2
  Word64
w3 <- 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
3
  Word64
w4 <- 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
4
  Word64
w5 <- 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
5
  Word64
w6 <- 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
6
  Word64
w7 <- 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
7

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

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

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

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

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

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

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

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

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

-- | Encode the argument in it's full length. This is different from many default
-- binary instances which make no guarantee about the actual encoding and
-- might do things use variable length encoding.
newtype FixedLengthEncoding a
  = FixedLengthEncoding { forall a. FixedLengthEncoding a -> a
unFixedLength :: a }
  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_ :: BinHandle -> FixedLengthEncoding Word8 -> IO ()
put_ BinHandle
h (FixedLengthEncoding Word8
x) = BinHandle -> Word8 -> IO ()
putByte BinHandle
h Word8
x
  get :: BinHandle -> IO (FixedLengthEncoding Word8)
get BinHandle
h = 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
<$> BinHandle -> IO Word8
getByte BinHandle
h

instance Binary (FixedLengthEncoding Word16) where
  put_ :: BinHandle -> FixedLengthEncoding Word16 -> IO ()
put_ BinHandle
h (FixedLengthEncoding Word16
x) = BinHandle -> Word16 -> IO ()
putWord16 BinHandle
h Word16
x
  get :: BinHandle -> IO (FixedLengthEncoding Word16)
get BinHandle
h = 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
<$> BinHandle -> IO Word16
getWord16 BinHandle
h

instance Binary (FixedLengthEncoding Word32) where
  put_ :: BinHandle -> FixedLengthEncoding Word32 -> IO ()
put_ BinHandle
h (FixedLengthEncoding Word32
x) = BinHandle -> Word32 -> IO ()
putWord32 BinHandle
h Word32
x
  get :: BinHandle -> IO (FixedLengthEncoding Word32)
get BinHandle
h = 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
<$> BinHandle -> IO Word32
getWord32 BinHandle
h

instance Binary (FixedLengthEncoding Word64) where
  put_ :: BinHandle -> FixedLengthEncoding Word64 -> IO ()
put_ BinHandle
h (FixedLengthEncoding Word64
x) = BinHandle -> Word64 -> IO ()
putWord64 BinHandle
h Word64
x
  get :: BinHandle -> IO (FixedLengthEncoding Word64)
get BinHandle
h = 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
<$> BinHandle -> IO Word64
getWord64 BinHandle
h

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

instance Binary a => Binary [a] where
    put_ :: BinHandle -> [a] -> IO ()
put_ BinHandle
bh [a]
l = do
        let len :: Int
len = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l
        BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
len
        (a -> IO ()) -> [a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh) [a]
l
    get :: BinHandle -> IO [a]
get BinHandle
bh = do
        Int
len <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int -- Int is variable length encoded so only
                                -- one byte for small lists.
        let loop :: Int -> IO [a]
loop Int
0 = [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            loop Int
n = do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; [a]
as <- Int -> IO [a]
loop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1); [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as)
        Int -> IO [a]
loop Int
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_ :: BinHandle -> Set a -> IO ()
put_ BinHandle
bh Set a
s = BinHandle -> [a] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
s)
  get :: BinHandle -> IO (Set a)
get BinHandle
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
<$> BinHandle -> IO [a]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

instance Binary a => Binary (NonEmpty a) where
    put_ :: BinHandle -> NonEmpty a -> IO ()
put_ BinHandle
bh = BinHandle -> [a] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
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 :: BinHandle -> IO (NonEmpty a)
get BinHandle
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
<$> BinHandle -> IO [a]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

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

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

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

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

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

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

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

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

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

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

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

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

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

{-
Finally - a reasonable portable Integer instance.

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

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

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

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

We can easily do better. The new plan is:

* Start with a tag byte
  * 0 => Int64 (LEB128 encoded)
  * 1 => Negative large 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_ :: BinHandle -> Integer -> IO ()
put_ BinHandle
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
          BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh Word8
0
          BinHandle -> Int64 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
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 BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh Word8
1
            else BinHandle -> Word8 -> IO ()
putWord8 BinHandle
bh Word8
2
          BinHandle -> [Word8] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
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 :: BinHandle -> IO Integer
get BinHandle
bh = do
      Word8
int_kind <- BinHandle -> IO Word8
getWord8 BinHandle
bh
      case Word8
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
<$!> (BinHandle -> IO Int64
forall a. Binary a => BinHandle -> IO a
get BinHandle
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
<$!> (BinHandle -> IO [Word8]
forall a. Binary a => BinHandle -> IO a
get BinHandle
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_ :: BinHandle -> Ratio a -> IO ()
put_ BinHandle
bh (a
a :% a
b) = do BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
b
    get :: BinHandle -> IO (Ratio a)
get BinHandle
bh = do a
a <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; a
b <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; Ratio a -> IO (Ratio a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a a -> a -> Ratio a
forall a. a -> a -> Ratio a
:% a
b)

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


-- -----------------------------------------------------------------------------
-- 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 :: BinHandle -> (b -> IO a) -> IO b -> IO (a,b)
forwardPut :: forall b a. BinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forwardPut BinHandle
bh b -> IO a
put_A IO b
put_B = do
  -- write placeholder pointer to A
  Bin (Bin Any)
pre_a <- BinHandle -> IO (Bin (Bin Any))
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
  BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
pre_a

  -- write B
  b
r_b <- IO b
put_B

  -- update A's pointer
  Bin Any
a <- BinHandle -> IO (Bin Any)
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
  BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
pre_a Bin Any
a
  BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBinNoExpand BinHandle
bh Bin Any
a

  -- write A
  a
r_a <- b -> IO a
put_A b
r_b
  (a, b) -> IO (a, b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
r_a,b
r_b)

forwardPut_ :: BinHandle -> (b -> IO a) -> IO b -> IO ()
forwardPut_ :: forall b a. BinHandle -> (b -> IO a) -> IO b -> IO ()
forwardPut_ BinHandle
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
$ BinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forall b a. BinHandle -> (b -> IO a) -> IO b -> IO (a, b)
forwardPut BinHandle
bh b -> IO a
put_A IO b
put_B

-- | Read a value stored using a forward reference
forwardGet :: BinHandle -> IO a -> IO a
forwardGet :: forall a. BinHandle -> IO a -> IO a
forwardGet BinHandle
bh IO a
get_A = do
    -- read forward reference
    Bin Any
p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh -- a BinPtr
    -- store current position
    Bin Any
p_a <- BinHandle -> IO (Bin Any)
forall {k} (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    -- go read the forward value, then seek back
    BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBinNoExpand BinHandle
bh Bin Any
p
    a
r <- IO a
get_A
    BinHandle -> Bin Any -> IO ()
forall {k} (a :: k). BinHandle -> Bin a -> IO ()
seekBinNoExpand BinHandle
bh Bin Any
p_a
    a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r

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

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

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

-- | Deserialize a value serialized by 'lazyPutMaybe'.
lazyGetMaybe :: Binary a => BinHandle -> IO (Maybe a)
lazyGetMaybe :: forall a. Binary a => BinHandle -> IO (Maybe a)
lazyGetMaybe BinHandle
bh = do
  Word8
h <- BinHandle -> IO Word8
getWord8 BinHandle
bh
  case Word8
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
<$> BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh

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

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

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

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

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

noUserData :: UserData
noUserData :: UserData
noUserData = UserData
  { ud_get_name :: BinHandle -> IO Name
ud_get_name            = String -> BinHandle -> IO Name
forall a. String -> a
undef String
"get_name"
  , ud_get_fs :: BinHandle -> IO FastString
ud_get_fs              = String -> BinHandle -> IO FastString
forall a. String -> a
undef String
"get_fs"
  , ud_put_nonbinding_name :: BinHandle -> Name -> IO ()
ud_put_nonbinding_name = String -> BinHandle -> Name -> IO ()
forall a. String -> a
undef String
"put_nonbinding_name"
  , ud_put_binding_name :: BinHandle -> Name -> IO ()
ud_put_binding_name    = String -> BinHandle -> Name -> IO ()
forall a. String -> a
undef String
"put_binding_name"
  , ud_put_fs :: BinHandle -> FastString -> IO ()
ud_put_fs              = String -> BinHandle -> FastString -> IO ()
forall a. String -> a
undef String
"put_fs"
  }

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

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

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

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

getDictionary :: BinHandle -> IO Dictionary
getDictionary :: BinHandle -> IO (Array Int FastString)
getDictionary BinHandle
bh = do
  Int
sz <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
  IOArray Int FastString
mut_arr <- (Int, Int) -> IO (IOArray Int FastString)
forall i. Ix i => (i, i) -> IO (IOArray i FastString)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
0, Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) :: IO (IOArray Int FastString)
  [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..(Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
    FastString
fs <- BinHandle -> IO FastString
getFS BinHandle
bh
    IOArray Int FastString -> Int -> FastString -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Int FastString
mut_arr Int
i FastString
fs
  IOArray Int FastString -> IO (Array Int FastString)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
unsafeFreeze IOArray Int FastString
mut_arr

getDictFastString :: Dictionary -> BinHandle -> IO FastString
getDictFastString :: Array Int FastString -> BinHandle -> IO FastString
getDictFastString Array Int FastString
dict BinHandle
bh = do
    Word32
j <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    FastString -> IO FastString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> IO FastString) -> FastString -> IO FastString
forall a b. (a -> b) -> a -> b
$! (Array Int FastString
dict Array Int FastString -> Int -> FastString
forall i e. Ix i => Array i e -> i -> e
! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
j :: Word32))


initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int)
initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int)
initFSTable BinHandle
bh = do
  FastMutInt
dict_next_ref <- Int -> IO FastMutInt
newFastMutInt Int
0
  IORef (UniqFM FastString (Int, FastString))
dict_map_ref <- UniqFM FastString (Int, FastString)
-> IO (IORef (UniqFM FastString (Int, FastString)))
forall a. a -> IO (IORef a)
newIORef UniqFM FastString (Int, FastString)
forall key elt. UniqFM key elt
emptyUFM
  let bin_dict :: FSTable
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 :: IO Int
put_dict = do
        Int
fs_count <- FastMutInt -> IO Int
readFastMutInt FastMutInt
dict_next_ref
        UniqFM FastString (Int, FastString)
dict_map  <- IORef (UniqFM FastString (Int, FastString))
-> IO (UniqFM FastString (Int, FastString))
forall a. IORef a -> IO a
readIORef IORef (UniqFM FastString (Int, FastString))
dict_map_ref
        BinHandle -> Int -> UniqFM FastString (Int, FastString) -> IO ()
putDictionary BinHandle
bh Int
fs_count UniqFM FastString (Int, FastString)
dict_map
        Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
fs_count

  -- BinHandle with FastString writing support
  let ud :: UserData
ud = BinHandle -> UserData
getUserData BinHandle
bh
  let ud_fs :: UserData
ud_fs = UserData
ud { ud_put_fs = putDictFastString bin_dict }
  let bh_fs :: BinHandle
bh_fs = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh UserData
ud_fs

  (BinHandle, FSTable, IO Int) -> IO (BinHandle, FSTable, IO Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinHandle
bh_fs,FSTable
bin_dict,IO Int
put_dict)

putDictFastString :: FSTable -> BinHandle -> FastString -> IO ()
putDictFastString :: FSTable -> BinHandle -> FastString -> IO ()
putDictFastString FSTable
dict BinHandle
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
>>= BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
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
    UniqFM FastString (Int, FastString)
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 :: Unique
uniq = FastString -> Unique
forall a. Uniquable a => a -> Unique
getUnique FastString
f
    case UniqFM FastString (Int, FastString)
-> Unique -> Maybe (Int, FastString)
forall key elt. UniqFM key elt -> Unique -> Maybe elt
lookupUFM_Directly UniqFM FastString (Int, FastString)
out Unique
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
           Int
j <- FastMutInt -> IO Int
readFastMutInt FastMutInt
j_r
           FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
j_r (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
           IORef (UniqFM FastString (Int, FastString))
-> UniqFM FastString (Int, FastString) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM FastString (Int, FastString))
out_r (UniqFM FastString (Int, FastString) -> IO ())
-> UniqFM FastString (Int, FastString) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM FastString (Int, FastString)
-> Unique
-> (Int, FastString)
-> UniqFM FastString (Int, FastString)
forall key elt. UniqFM key elt -> Unique -> elt -> UniqFM key elt
addToUFM_Directly UniqFM FastString (Int, FastString)
out Unique
uniq (Int
j, FastString
f)
           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)

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

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

type SymbolTable = Array Int Name

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

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

getFS :: BinHandle -> IO FastString
getFS :: BinHandle -> IO FastString
getFS BinHandle
bh = do
  Int
l  <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
  BinHandle -> Int -> (Ptr Word8 -> IO FastString) -> IO FastString
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
bh Int
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 )

putBS :: BinHandle -> ByteString -> IO ()
putBS :: BinHandle -> ByteString -> IO ()
putBS BinHandle
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
    BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
l
    BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
putPrim BinHandle
bh Int
l (\Ptr Word8
op -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
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 :: BinHandle -> IO ByteString
getBS :: BinHandle -> IO ByteString
getBS BinHandle
bh = do
  Int
l <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
  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
    BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO ()
forall a. BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a
getPrim BinHandle
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_ :: BinHandle -> ByteString -> IO ()
put_ BinHandle
bh ByteString
f = BinHandle -> ByteString -> IO ()
putBS BinHandle
bh ByteString
f
  get :: BinHandle -> IO ByteString
get BinHandle
bh = BinHandle -> IO ByteString
getBS BinHandle
bh

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

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

deriving instance Binary NonDetFastString
deriving instance Binary LexicalFastString

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

  get :: BinHandle -> IO UnhelpfulSpanReason
get BinHandle
bh = do
    Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
    case Word8
h of
      Word8
0 -> 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
<$> BinHandle -> IO FastString
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

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

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

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

  get :: BinHandle -> IO BinSrcSpan
get BinHandle
bh = do
          Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
          case Word8
h of
            Word8
0 -> do BinSpan RealSrcSpan
ss <- BinHandle -> IO BinSpan
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                    BinSrcSpan -> IO BinSrcSpan
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinSrcSpan -> IO BinSrcSpan) -> BinSrcSpan -> IO BinSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpan -> BinSrcSpan
BinSrcSpan (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
ss Maybe BufSpan
forall a. Maybe a
Strict.Nothing)
            Word8
_ -> do UnhelpfulSpanReason
s <- BinHandle -> IO UnhelpfulSpanReason
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                    BinSrcSpan -> IO BinSrcSpan
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinSrcSpan -> IO BinSrcSpan) -> BinSrcSpan -> IO BinSrcSpan
forall a b. (a -> b) -> a -> b
$ SrcSpan -> BinSrcSpan
BinSrcSpan (UnhelpfulSpanReason -> SrcSpan
UnhelpfulSpan UnhelpfulSpanReason
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_ :: BinHandle -> IntMap v -> IO ()
put_ BinHandle
bh IntMap v
m = BinHandle -> [(Int, v)] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (IntMap v -> [(Int, v)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList IntMap v
m)
  get :: BinHandle -> IO (IntMap v)
get BinHandle
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
<$> BinHandle -> IO [(Int, v)]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh