{-# LANGUAGE CPP, ScopedTypeVariables #-}
--
-- (c) The University of Glasgow 2002
--
-- 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 Binary
  ( {-type-}  Bin,
    {-class-} Binary(..),
    {-type-}  BinHandle,

   openBinIO, openBinIO_,
   openBinMem,
--   closeBin,

   seekBin,
   tellBin,
   castBin,

   writeBinMem,
   readBinMem,

   isEOFBin,

   -- for writing instances:
   putByte,
   getByte,
   putSharedString,
   getSharedString,

   -- lazy Bin I/O
   lazyGet,
   lazyPut,

#if __GLASGOW_HASKELL__<610
   -- GHC only:
   ByteArray(..),
   getByteArray,
   putByteArray,
#endif

   getBinFileWithDict,  -- :: Binary a => FilePath -> IO a
   putBinFileWithDict,  -- :: Binary a => FilePath -> ModuleName -> a -> IO ()

  ) where

#if __GLASGOW_HASKELL__>=604
#include "ghcconfig.h"
#else
#include "config.h"
#endif

import FastMutInt

import Map (Map)
import qualified Map as Map
#if __GLASGOW_HASKELL__>=602
# if __GLASGOW_HASKELL__>=707
import Data.HashTable.Class as HashTable
              (HashTable)
import Data.HashTable.IO as HashTable
              (BasicHashTable, toList, new, insert, lookup)
# else
import Data.HashTable as HashTable
# endif
#endif
import Data.Array.IO
import Data.Array
import Data.Bits
import Data.Int
import Data.Word
import Data.IORef
import Data.Char                ( ord, chr )
import Data.Array.Base          ( unsafeRead, unsafeWrite )
import Control.Monad            ( when, liftM )
import System.IO as IO
import System.IO.Unsafe         ( unsafeInterleaveIO )
import System.IO.Error          ( mkIOError, eofErrorType )
import GHC.Real                 ( Ratio(..) )
import GHC.Exts
# if __GLASGOW_HASKELL__>=612
import GHC.IO     (IO(IO))
#else
import GHC.IOBase (IO(IO))
#endif
import GHC.Word                 ( Word8(..) )
# if __GLASGOW_HASKELL__<602
import GHC.Handle               ( hSetBinaryMode )
# endif
-- for debug
import System.CPUTime           (getCPUTime)
import Numeric                  (showFFloat)

#define SIZEOF_HSINT SIZEOF_VOID_P

type BinArray = IOUArray Int Word8

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

  | BinIO {             -- binary data stored in a file
     bh_usr :: UserData,
     off_r :: !FastMutInt,              -- the current offset (cached)
     BinHandle -> Handle
hdl   :: !IO.Handle                -- the file handle (must be seekable)
   }
        -- cache the file ptr in BinIO; using hTell is too expensive
        -- to call repeatedly.  If anyone else is modifying this Handle
        -- at the same time, we'll be screwed.

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 }


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

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

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

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 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 p <- BinHandle -> IO (Bin a)
forall a. BinHandle -> IO (Bin a)
tellBin BinHandle
bh; put_ bh a; return 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 a. BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin a
p; BinHandle -> a -> IO (Bin a)
forall a. Binary a => BinHandle -> a -> IO (Bin a)
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 a. BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin a
p; BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

openBinIO_ :: IO.Handle -> IO BinHandle
openBinIO_ :: Handle -> IO BinHandle
openBinIO_ Handle
h = Handle -> IO BinHandle
openBinIO Handle
h

openBinIO :: IO.Handle -> IO BinHandle
openBinIO :: Handle -> IO BinHandle
openBinIO Handle
h = do
  r <- IO FastMutInt
newFastMutInt
  writeFastMutInt r 0
  return (BinIO noUserData r h)

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
"Data.Binary.openBinMem: size must be >= 0"
 | Bool
otherwise = do
   arr <- (Int, Int) -> IO BinArray
forall i. Ix i => (i, i) -> IO (IOUArray i Word8)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
0,Int
sizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
   arr_r <- newIORef arr
   ix_r <- newFastMutInt
   writeFastMutInt ix_r 0
   sz_r <- newFastMutInt
   writeFastMutInt sz_r size
   return (BinMem noUserData ix_r sz_r arr_r)

tellBin :: BinHandle -> IO (Bin a)
tellBin :: forall a. BinHandle -> IO (Bin a)
tellBin (BinIO  UserData
_ FastMutInt
r Handle
_)   = do ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
r; return (BinPtr ix)
tellBin (BinMem UserData
_ FastMutInt
r FastMutInt
_ IORef BinArray
_) = do ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
r; return (BinPtr ix)

seekBin :: BinHandle -> Bin a -> IO ()
seekBin :: forall a. BinHandle -> Bin a -> IO ()
seekBin (BinIO UserData
_ FastMutInt
ix_r Handle
h) (BinPtr Int
p) = do
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
p
  Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p)
seekBin h :: BinHandle
h@(BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
a) (BinPtr Int
p) = do
  sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  if (p >= sz)
        then do expandBin h p; writeFastMutInt ix_r p
        else writeFastMutInt ix_r p

isEOFBin :: BinHandle -> IO Bool
isEOFBin :: BinHandle -> IO Bool
isEOFBin (BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
a) = do
  ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  sz <- readFastMutInt sz_r
  return (ix >= sz)
isEOFBin (BinIO UserData
_ FastMutInt
ix_r Handle
h) = Handle -> IO Bool
hIsEOF Handle
h

writeBinMem :: BinHandle -> FilePath -> IO ()
writeBinMem :: BinHandle -> String -> IO ()
writeBinMem (BinIO UserData
_ FastMutInt
_ Handle
_) String
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"Data.Binary.writeBinMem: not a memory handle"
writeBinMem (BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r) String
fn = do
  h <- String -> IOMode -> IO Handle
openFile String
fn IOMode
WriteMode
  hSetBinaryMode h True
  arr <- readIORef arr_r
  ix  <- readFastMutInt ix_r
  hPutArray h arr ix
  hClose h

readBinMem :: FilePath -> IO BinHandle
-- Return a BinHandle with a totally undefined State
readBinMem :: String -> IO BinHandle
readBinMem String
filename = do
  h <- String -> IOMode -> IO Handle
openFile String
filename IOMode
ReadMode
  hSetBinaryMode h True
  filesize' <- hFileSize h
  let filesize = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
filesize'
  arr <- newArray_ (0,filesize-1)
  count <- hGetArray h arr filesize
  when (count /= filesize)
        (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
  hClose h
  arr_r <- newIORef arr
  ix_r <- newFastMutInt
  writeFastMutInt ix_r 0
  sz_r <- newFastMutInt
  writeFastMutInt sz_r filesize
  return (BinMem noUserData ix_r sz_r 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
ix_r FastMutInt
sz_r IORef BinArray
arr_r) Int
off = do
   sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
   let sz' = [Int] -> Int
forall a. HasCallStack => [a] -> a
head ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
off) ((Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Int
sz))
   arr <- readIORef arr_r
   arr' <- newArray_ (0,sz'-1)
   sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
             | i <- [ 0 .. sz-1 ] ]
   writeFastMutInt sz_r sz'
   writeIORef arr_r arr'
#ifdef DEBUG
   hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
#endif
   return ()
expandBin (BinIO UserData
_ FastMutInt
_ Handle
_) Int
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- no need to expand a file, we'll assume they expand by themselves.
{-# INLINE expandBin #-}

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

putWord8 :: BinHandle -> Word8 -> IO ()
putWord8 :: BinHandle -> Word8 -> IO ()
putWord8 h :: BinHandle
h@(BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r) Word8
w = do
    ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
    sz <- readFastMutInt sz_r
        -- double the size of the array if it overflows
    if (ix >= sz)
        then do expandBin h ix
                putWord8 h w
        else do arr <- readIORef arr_r
                unsafeWrite arr ix w
                writeFastMutInt ix_r (ix+1)
                return ()
putWord8 (BinIO UserData
_ FastMutInt
ix_r Handle
h) Word8
w = do
    ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
    hPutChar h (chr (fromIntegral w))   -- XXX not really correct
    writeFastMutInt ix_r (ix+1)
    return ()

getWord8 :: BinHandle -> IO Word8
getWord8 :: BinHandle -> IO Word8
getWord8 (BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r) = do
    ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
    sz <- readFastMutInt sz_r
    when (ix >= sz)  $
        ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
    arr <- readIORef arr_r
    w <- unsafeRead arr ix
    writeFastMutInt ix_r (ix+1)
    return w
getWord8 (BinIO UserData
_ FastMutInt
ix_r Handle
h) = do
    ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
    c <- hGetChar h
    writeFastMutInt ix_r (ix+1)
    return $! (fromIntegral (ord c))    -- XXX not really correct

putByte :: BinHandle -> Word8 -> IO ()
putByte :: BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
w = BinHandle -> Word8 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Word8
w

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

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

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

instance Binary Word16 where
  put_ :: BinHandle -> Word16 -> IO ()
put_ BinHandle
h Word16
w = do -- XXX too slow.. inline putWord8?
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
  get :: BinHandle -> IO Word16
get BinHandle
h = do
    w1 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    w2 <- getWord8 h
    return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)


instance Binary Word32 where
  put_ :: BinHandle -> Word32 -> IO ()
put_ BinHandle
h Word32
w = do
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
  get :: BinHandle -> IO Word32
get BinHandle
h = do
    w1 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    w2 <- getWord8 h
    w3 <- getWord8 h
    w4 <- getWord8 h
    return $! ((fromIntegral w1 `shiftL` 24) .|.
               (fromIntegral w2 `shiftL` 16) .|.
               (fromIntegral w3 `shiftL`  8) .|.
               (fromIntegral w4))


instance Binary Word64 where
  put_ :: BinHandle -> Word64 -> IO ()
put_ BinHandle
h Word64
w = do
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (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))
  get :: BinHandle -> IO Word64
get BinHandle
h = do
    w1 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    w2 <- getWord8 h
    w3 <- getWord8 h
    w4 <- getWord8 h
    w5 <- getWord8 h
    w6 <- getWord8 h
    w7 <- getWord8 h
    w8 <- getWord8 h
    return $! ((fromIntegral w1 `shiftL` 56) .|.
               (fromIntegral w2 `shiftL` 48) .|.
               (fromIntegral w3 `shiftL` 40) .|.
               (fromIntegral w4 `shiftL` 32) .|.
               (fromIntegral w5 `shiftL` 24) .|.
               (fromIntegral w6 `shiftL` 16) .|.
               (fromIntegral w7 `shiftL`  8) .|.
               (fromIntegral w8))

-- -----------------------------------------------------------------------------
-- 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 w <- BinHandle -> IO Word8
forall a. Binary a => BinHandle -> IO a
get BinHandle
h; return $! (fromIntegral (w::Word8))

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

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

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

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

instance Binary () where
    put_ :: BinHandle -> () -> IO ()
put_ BinHandle
bh () = () -> 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 ()
--    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)

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 x <- BinHandle -> IO Word8
getWord8 BinHandle
bh; return $! (toEnum (fromIntegral x))
--    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)

instance Binary Char where
    put_ :: BinHandle -> Char -> IO ()
put_  BinHandle
bh Char
c = BinHandle -> Word8 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) :: Word8)
    get :: BinHandle -> IO Char
get  BinHandle
bh   = do x <- BinHandle -> IO Word8
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; return $! (chr (fromIntegral (x :: Word8)))
--    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)

instance Binary Int where
#if SIZEOF_HSINT == 4
    put_ bh i = put_ bh (fromIntegral i :: Int32)
    get  bh = do
        x <- get bh
        return $! (fromIntegral (x :: Int32))
#elif SIZEOF_HSINT == 8
    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
        x <- BinHandle -> IO Int64
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        return $! (fromIntegral (x :: Int64))
#else
#error "unsupported sizeof(HsInt)"
#endif
--    getF bh   = getBitsF bh 32

instance Binary a => Binary [a] where
    put_ :: BinHandle -> [a] -> IO ()
put_ BinHandle
bh [a]
list = do BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
list)
                      (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]
list
    get :: BinHandle -> IO [a]
get BinHandle
bh = do len <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                let getMany :: Int -> IO [a]
                    getMany Int
0 = [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                    getMany Int
n = do x <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                   xs <- getMany (n-1)
                                   return (x:xs)
                getMany len

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 <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                       b <- get bh
                       return (a,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 <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                         b <- get bh
                         c <- get bh
                         return (a,b,c)

instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
    put_ :: 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 <- BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                         b <- get bh
                         c <- get bh
                         d <- get bh
                         return (a,b,c,d)

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

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

instance (Binary key, Ord key, Binary elem) => Binary (Map key elem) where
--    put_ bh fm = put_ bh (Map.toList fm)
--    get bh = do list <- get bh
--                return (Map.fromList list)

    put_ :: BinHandle -> Map key elem -> IO ()
put_ BinHandle
bh Map key elem
fm = do let list :: [(key, elem)]
list = Map key elem -> [(key, elem)]
forall k a. Map k a -> [(k, a)]
Map.toList Map key elem
fm
                    BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh ([(key, elem)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(key, elem)]
list)
                    ((key, elem) -> IO ()) -> [(key, elem)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(key
key, elem
val) -> do BinHandle -> key -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh key
key
                                             BinHandle -> elem -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh elem
val) [(key, elem)]
list
    get :: BinHandle -> IO (Map key elem)
get BinHandle
bh = do len <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                let getMany :: Int -> IO [(key,elem)]
                    getMany Int
0 = [(key, elem)] -> IO [(key, elem)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                    getMany Int
n = do key <- BinHandle -> IO key
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                   val <- lazyGet bh
                                   xs <- getMany (n-1)
                                   return ((key,val):xs)
--                printElapsedTime "before get Map"
                list <- getMany len
--                printElapsedTime "after get Map"
                return (Map.fromList list)

#ifdef __GLASGOW_HASKELL__
#if __GLASGOW_HASKELL__<610
instance Binary Integer where
    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
    put_ bh (J# s# a#) = do
        p <- 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 ()

#if __GLASGOW_HASKELL__ < 503
writeByteArray arr i w8 = IO $ \s ->
  case word8ToWord w8 of { W# w# ->
  case writeCharArray# arr i (chr# (word2Int# w#)) s  of { s ->
  (# s , () #) }}
#else
writeByteArray arr i (W8# w) = IO $ \s ->
  case writeWord8Array# arr i w s of { s ->
  (# s, () #) }
#endif

#if __GLASGOW_HASKELL__ < 503
indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
#else
indexByteArray a# n# = W8# (indexWord8Array# a# n#)
#endif

instance (Integral a, Binary a) => Binary (Ratio a) where
    put_ bh (a :% b) = do put_ bh a; put_ bh b
    get bh = do a <- get bh; b <- get bh; return (a :% b)

#else

instance Binary Integer where
    put_ :: BinHandle -> Integer -> IO ()
put_ BinHandle
h Integer
n = do
      BinHandle -> Int8 -> IO (Bin Int8)
forall a. Binary a => BinHandle -> a -> IO (Bin a)
put BinHandle
h ((Integer -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int8) -> Integer -> Int8
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => a -> a
signum Integer
n) :: Int8)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let n' :: Integer
n' = Integer -> Integer
forall a. Num a => a -> a
abs Integer
n
            nBytes :: Int
nBytes = Integer -> Int
forall {p}. (Ord p, Bits p, Num p) => p -> Int
byteSize Integer
n'
        BinHandle -> Word64 -> IO (Bin Word64)
forall a. Binary a => BinHandle -> a -> IO (Bin a)
put BinHandle
h (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nBytes :: Word64)
        (Word8 -> IO ()) -> [Word8] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> Word8 -> IO ()
putByte BinHandle
h) [ Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Integer
n' Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8)) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0xff)
                          | Int
b <- [ Int
nBytesInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, Int
nBytesInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2 .. Int
0 ] ]
      where byteSize :: p -> Int
byteSize p
n =
                let f :: Int -> Int
f Int
b = if (p
1 p -> Int -> p
forall a. Bits a => a -> Int -> a
`shiftL` (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8)) p -> p -> Bool
forall a. Ord a => a -> a -> Bool
> p
n
                             then Int
b
                             else Int -> Int
f (Int
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                in Int -> Int
f Int
0
    get :: BinHandle -> IO Integer
get BinHandle
h = do
      sign :: Int8 <- BinHandle -> IO Int8
forall a. Binary a => BinHandle -> IO a
get BinHandle
h
      if sign == 0
         then return 0
         else do
           nBytes :: Word64 <- get h
           n <- accumBytes nBytes 0
           return $ fromIntegral sign * n
      where accumBytes :: t -> t -> IO t
accumBytes t
nBytes t
acc | t
nBytes t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 = t -> IO t
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return t
acc
                                  | Bool
otherwise = do
                b <- BinHandle -> IO Word8
getByte BinHandle
h
                accumBytes (nBytes - 1) ((acc `shiftL` 8) .|. fromIntegral b)
#endif

#endif

instance Binary (Bin a) where
  put_ :: BinHandle -> Bin a -> IO ()
put_ BinHandle
bh (BinPtr Int
i) = BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
i
  get :: BinHandle -> IO (Bin a)
get BinHandle
bh = do i <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; return (BinPtr i)

-- -----------------------------------------------------------------------------
-- 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:
    pre_a <- BinHandle -> IO (Bin (Bin Any))
forall a. BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    put_ bh pre_a       -- save a slot for the ptr
    put_ bh a           -- dump the object
    q <- tellBin bh     -- q = ptr to after object
    putAt bh pre_a q    -- fill in slot before a with ptr to q
    seekBin bh 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
    p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh         -- a BinPtr
    p_a <- tellBin bh
    a <- unsafeInterleaveIO (getAt bh p_a)
    seekBin bh p -- skip over the object for now
    return a

-- --------------------------------------------------------------
--      Main wrappers: getBinFileWithDict, putBinFileWithDict
--
--      This layer is built on top of the stuff above,
--      and should not know anything about BinHandles
-- --------------------------------------------------------------

initBinMemSize :: Int
initBinMemSize       = (Int
1024Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1024) :: Int
binaryInterfaceMagic :: Word32
binaryInterfaceMagic = Word32
0x1face :: Word32

getBinFileWithDict :: Binary a => FilePath -> IO a
getBinFileWithDict :: forall a. Binary a => String -> IO a
getBinFileWithDict String
file_path = do
  bh <- String -> IO BinHandle
Binary.readBinMem String
file_path

        -- Read the magic number to check that this really is a GHC .hi file
        -- (This magic number does not change when we change
        --  GHC interface file format)
  magic <- get bh
  when (magic /= binaryInterfaceMagic) $
        error "magic number mismatch: old/corrupt interface file?"

        -- Read the dictionary
        -- The next word in the file is a pointer to where the dictionary is
        -- (probably at the end of the file)
  dict_p <- Binary.get bh       -- Get the dictionary ptr
  data_p <- tellBin bh          -- Remember where we are now
  seekBin bh dict_p
  dict <- getDictionary bh
  seekBin bh data_p             -- Back to where we were before

        -- Initialise the user-data field of bh
  let bh' = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh (Dictionary -> UserData
initReadState Dictionary
dict)
        
        -- At last, get the thing
  get bh'

putBinFileWithDict :: Binary a => FilePath -> a -> IO ()
putBinFileWithDict :: forall a. Binary a => String -> a -> IO ()
putBinFileWithDict String
file_path a
the_thing = do
--  hnd <- openBinaryFile file_path WriteMode
--  bh <- openBinIO hnd
  bh <- Int -> IO BinHandle
openBinMem Int
initBinMemSize
  put_ bh binaryInterfaceMagic

        -- Remember where the dictionary pointer will go
  dict_p_p <- tellBin bh
  put_ bh dict_p_p      -- Placeholder for ptr to dictionary

        -- Make some initial state
  usr_state <- newWriteState

        -- Put the main thing,
  put_ (setUserData bh usr_state) the_thing

        -- Get the final-state
  j <- readIORef  (ud_next usr_state)
#if __GLASGOW_HASKELL__>=602
  fm <- HashTable.toList (ud_map  usr_state)
#else
  fm <- liftM Map.toList $ readIORef (ud_map  usr_state)
#endif
  dict_p <- tellBin bh  -- This is where the dictionary will start

        -- Write the dictionary pointer at the fornt of the file
  putAt bh dict_p_p dict_p      -- Fill in the placeholder
  seekBin bh dict_p             -- Seek back to the end of the file

        -- Write the dictionary itself
  putDictionary bh j (constructDictionary j fm)

        -- And send the result to the file
  writeBinMem bh file_path
--  hClose hnd

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

data UserData =
   UserData {   -- This field is used only when reading
              UserData -> Dictionary
ud_dict :: Dictionary,

                -- The next two fields are only used when writing
              UserData -> IORef Int
ud_next :: IORef Int,     -- The next index to use
#if __GLASGOW_HASKELL__>=602
# if __GLASGOW_HASKELL__>=707
              UserData -> IOHashTable HashTable String Int
ud_map  :: BasicHashTable String Int -- The index of each string
# else
              ud_map  :: HashTable String Int -- The index of each string
# endif
#else
              ud_map  :: IORef (Map String Int)
#endif
        }

noUserData :: a
noUserData = String -> a
forall a. HasCallStack => String -> a
error String
"Binary.UserData: no user data"

initReadState :: Dictionary -> UserData
initReadState :: Dictionary -> UserData
initReadState Dictionary
dict = UserData{ ud_dict :: Dictionary
ud_dict = Dictionary
dict,
                               ud_next :: IORef Int
ud_next = String -> IORef Int
forall {a}. String -> a
undef String
"next",
                               ud_map :: IOHashTable HashTable String Int
ud_map  = String -> HashTable RealWorld String Int
forall {a}. String -> a
undef String
"map" }

newWriteState :: IO UserData
newWriteState :: IO UserData
newWriteState = do
  j_r <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
#if __GLASGOW_HASKELL__>=602
# if __GLASGOW_HASKELL__>=707
  out_r <- HashTable.new
# else
  out_r <- HashTable.new (==) HashTable.hashString
# endif
#else
  out_r <- newIORef Map.empty
#endif
  return (UserData { ud_dict = error "dict",
                     ud_next = j_r,
                     ud_map  = out_r })


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

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

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

putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
putDictionary BinHandle
bh Int
sz Dictionary
dict = do
  BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
sz
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> String -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh) (Dictionary -> [String]
forall i e. Array i e -> [e]
elems Dictionary
dict)

getDictionary :: BinHandle -> IO Dictionary
getDictionary :: BinHandle -> IO Dictionary
getDictionary BinHandle
bh = do
  sz <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
  elems <- sequence (take sz (repeat (get bh)))
  return (listArray (0,sz-1) elems)

constructDictionary :: Int -> [(String,Int)] -> Dictionary
constructDictionary :: Int -> [(String, Int)] -> Dictionary
constructDictionary Int
j [(String, Int)]
fm = (Int, Int) -> [(Int, String)] -> Dictionary
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (((String, Int) -> (Int, String))
-> [(String, Int)] -> [(Int, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
x,Int
y) -> (Int
y,String
x)) [(String, Int)]
fm)

---------------------------------------------------------
--              Reading and writing memoised Strings
---------------------------------------------------------

putSharedString :: BinHandle -> String -> IO ()
putSharedString :: BinHandle -> String -> IO ()
putSharedString BinHandle
bh String
str =
  case BinHandle -> UserData
getUserData BinHandle
bh of
    UserData { ud_next :: UserData -> IORef Int
ud_next = IORef Int
j_r, ud_map :: UserData -> IOHashTable HashTable String Int
ud_map = IOHashTable HashTable String Int
out_r, ud_dict :: UserData -> Dictionary
ud_dict = Dictionary
dict} -> do
#if __GLASGOW_HASKELL__>=602
      entry <- IOHashTable HashTable String Int -> String -> IO (Maybe Int)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
HashTable.lookup IOHashTable HashTable String Int
out_r String
str
#else
      fm <- readIORef out_r
      let entry = Map.lookup str fm
#endif
      case entry of
        Just Int
j  -> BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
j
        Maybe Int
Nothing -> do
                     j <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
j_r
                     put_ bh j
                     writeIORef j_r (j+1)
#if __GLASGOW_HASKELL__>=602
                     HashTable.insert out_r str j
#else
                     modifyIORef out_r (\fm -> Map.insert str j fm)
#endif

getSharedString :: BinHandle -> IO String
getSharedString :: BinHandle -> IO String
getSharedString BinHandle
bh = do
        j <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        return $! (ud_dict (getUserData bh) ! j)

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

putFS bh (FastString id l ba) = do
  put_ bh (I# l)
  putByteArray bh ba l
putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)
        -- Note: the length of the FastString is *not* the same as
        -- the size of the ByteArray: the latter is rounded up to a
        -- multiple of the word size.

{- -- possible faster version, not quite there yet:
getFS bh@BinMem{} = do
  (I# l) <- get bh
  arr <- readIORef (arr_r bh)
  off <- readFastMutInt (off_r bh)
  return $! (mkFastSubStringBA# arr off l)
-}
getFS bh = do
  (I# l) <- get bh
  (BA ba) <- getByteArray bh (I# l)
  return $! (mkFastSubStringBA# ba 0# l)

instance Binary FastString where
  put_ bh f@(FastString id l ba) =
    case getUserData bh of {
        UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do
    out <- readIORef out_r
    let uniq = getUnique f
    case lookupUFM out uniq of
        Just (j,f)  -> put_ bh j
        Nothing -> do
           j <- readIORef j_r
           put_ bh j
           writeIORef j_r (j+1)
           writeIORef out_r (addToUFM out uniq (j,f))
    }
  put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))

  get bh = do
        j <- get bh
        return $! (ud_dict (getUserData bh) ! j)
-}

printElapsedTime :: String -> IO ()
printElapsedTime :: String -> IO ()
printElapsedTime String
msg = do
  time <- IO Integer
getCPUTime
  hPutStr stderr $ "elapsed time: " ++ Numeric.showFFloat (Just 2) ((fromIntegral time) / 10^12) " (" ++ msg ++ ")\n"