{-# 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 :: UserData
bh_usr = UserData
us }


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

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

castBin :: Bin a -> Bin b
castBin :: forall a b. Bin a -> Bin b
castBin (BinPtr Int
i) = 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 forall a. Binary a => BinHandle -> a -> IO (Bin a)
put BinHandle
bh a
a; forall (m :: * -> *) a. Monad m => a -> m a
return ()
    put BinHandle
bh a
a  = do Bin a
p <- forall a. BinHandle -> IO (Bin a)
tellBin BinHandle
bh; forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a; forall (m :: * -> *) a. Monad m => a -> m a
return Bin a
p

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

getAt  :: Binary a => BinHandle -> Bin a -> IO a
getAt :: forall a. Binary a => BinHandle -> Bin a -> IO a
getAt BinHandle
bh Bin a
p = do forall a. BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin a
p; 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
  FastMutInt
r <- IO FastMutInt
newFastMutInt
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
r Int
0
  forall (m :: * -> *) a. Monad m => a -> m a
return (UserData -> FastMutInt -> Handle -> BinHandle
BinIO forall {a}. a
noUserData FastMutInt
r Handle
h)

openBinMem :: Int -> IO BinHandle
openBinMem :: Int -> IO BinHandle
openBinMem Int
size
 | Int
size forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. HasCallStack => String -> a
error String
"Data.Binary.openBinMem: size must be >= 0"
 | Bool
otherwise = do
   BinArray
arr <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
0,Int
sizeforall a. Num a => a -> a -> a
-Int
1)
   IORef BinArray
arr_r <- forall a. a -> IO (IORef a)
newIORef BinArray
arr
   FastMutInt
ix_r <- IO FastMutInt
newFastMutInt
   FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
0
   FastMutInt
sz_r <- IO FastMutInt
newFastMutInt
   FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
sz_r Int
size
   forall (m :: * -> *) a. Monad m => a -> m a
return (UserData -> FastMutInt -> FastMutInt -> IORef BinArray -> BinHandle
BinMem forall {a}. a
noUserData FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r)

tellBin :: BinHandle -> IO (Bin a)
tellBin :: forall a. BinHandle -> IO (Bin a)
tellBin (BinIO  UserData
_ FastMutInt
r Handle
_)   = do Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
r; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Int -> Bin a
BinPtr Int
ix)
tellBin (BinMem UserData
_ FastMutInt
r FastMutInt
_ IORef BinArray
_) = do Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
r; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Int -> Bin a
BinPtr Int
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 (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
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  if (Int
p forall a. Ord a => a -> a -> Bool
>= Int
sz)
        then do BinHandle -> Int -> IO ()
expandBin BinHandle
h Int
p; FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
p
        else FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
p

isEOFBin :: BinHandle -> IO Bool
isEOFBin :: BinHandle -> IO Bool
isEOFBin (BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
a) = do
  Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
  forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ix forall a. Ord a => a -> a -> Bool
>= Int
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
_ = 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
  Handle
h <- String -> IOMode -> IO Handle
openFile String
fn IOMode
WriteMode
  Handle -> Bool -> IO ()
hSetBinaryMode Handle
h Bool
True
  BinArray
arr <- forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
  Int
ix  <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
  Handle -> BinArray -> Int -> IO ()
hPutArray Handle
h BinArray
arr Int
ix
  Handle -> IO ()
hClose Handle
h

readBinMem :: FilePath -> IO BinHandle
-- Return a BinHandle with a totally undefined State
readBinMem :: String -> IO BinHandle
readBinMem String
filename = do
  Handle
h <- String -> IOMode -> IO Handle
openFile String
filename IOMode
ReadMode
  Handle -> Bool -> IO ()
hSetBinaryMode Handle
h Bool
True
  Integer
filesize' <- Handle -> IO Integer
hFileSize Handle
h
  let filesize :: Int
filesize = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
filesize'
  BinArray
arr <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
0,Int
filesizeforall a. Num a => a -> a -> a
-Int
1)
  Int
count <- Handle -> BinArray -> Int -> IO Int
hGetArray Handle
h BinArray
arr Int
filesize
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count forall a. Eq a => a -> a -> Bool
/= Int
filesize)
        (forall a. HasCallStack => String -> a
error (String
"Binary.readBinMem: only read " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count forall a. [a] -> [a] -> [a]
++ String
" bytes"))
  Handle -> IO ()
hClose Handle
h
  IORef BinArray
arr_r <- forall a. a -> IO (IORef a)
newIORef BinArray
arr
  FastMutInt
ix_r <- IO FastMutInt
newFastMutInt
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r Int
0
  FastMutInt
sz_r <- IO FastMutInt
newFastMutInt
  FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
sz_r Int
filesize
  forall (m :: * -> *) a. Monad m => a -> m a
return (UserData -> FastMutInt -> FastMutInt -> IORef BinArray -> BinHandle
BinMem forall {a}. a
noUserData FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r)

-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
expandBin :: BinHandle -> Int -> IO ()
expandBin (BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r) Int
off = do
   Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
   let sz' :: Int
sz' = forall a. [a] -> a
head (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Ord a => a -> a -> Bool
<= Int
off) (forall a. (a -> a) -> a -> [a]
iterate (forall a. Num a => a -> a -> a
* Int
2) Int
sz))
   BinArray
arr <- forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
   BinArray
arr' <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
0,Int
sz'forall a. Num a => a -> a -> a
-Int
1)
   forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead BinArray
arr Int
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite BinArray
arr' Int
i
             | Int
i <- [ Int
0 .. Int
szforall a. Num a => a -> a -> a
-Int
1 ] ]
   FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
sz_r Int
sz'
   forall a. IORef a -> a -> IO ()
writeIORef IORef BinArray
arr_r BinArray
arr'
#ifdef DEBUG
   hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
#endif
   forall (m :: * -> *) a. Monad m => a -> m a
return ()
expandBin (BinIO UserData
_ FastMutInt
_ Handle
_) Int
_ = 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
    Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
    Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
        -- double the size of the array if it overflows
    if (Int
ix forall a. Ord a => a -> a -> Bool
>= Int
sz)
        then do BinHandle -> Int -> IO ()
expandBin BinHandle
h Int
ix
                BinHandle -> Word8 -> IO ()
putWord8 BinHandle
h Word8
w
        else do BinArray
arr <- forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
                forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> e -> m ()
unsafeWrite BinArray
arr Int
ix Word8
w
                FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r (Int
ixforall a. Num a => a -> a -> a
+Int
1)
                forall (m :: * -> *) a. Monad m => a -> m a
return ()
putWord8 (BinIO UserData
_ FastMutInt
ix_r Handle
h) Word8
w = do
    Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
    Handle -> Char -> IO ()
hPutChar Handle
h (Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w))   -- XXX not really correct
    FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r (Int
ixforall a. Num a => a -> a -> a
+Int
1)
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

getWord8 :: BinHandle -> IO Word8
getWord8 :: BinHandle -> IO Word8
getWord8 (BinMem UserData
_ FastMutInt
ix_r FastMutInt
sz_r IORef BinArray
arr_r) = do
    Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
    Int
sz <- FastMutInt -> IO Int
readFastMutInt FastMutInt
sz_r
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
ix forall a. Ord a => a -> a -> Bool
>= Int
sz)  forall a b. (a -> b) -> a -> b
$
        forall a. IOError -> IO a
ioError (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
eofErrorType String
"Data.Binary.getWord8" forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
    BinArray
arr <- forall a. IORef a -> IO a
readIORef IORef BinArray
arr_r
    Word8
w <- forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> Int -> m e
unsafeRead BinArray
arr Int
ix
    FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r (Int
ixforall a. Num a => a -> a -> a
+Int
1)
    forall (m :: * -> *) a. Monad m => a -> m a
return Word8
w
getWord8 (BinIO UserData
_ FastMutInt
ix_r Handle
h) = do
    Int
ix <- FastMutInt -> IO Int
readFastMutInt FastMutInt
ix_r
    Char
c <- Handle -> IO Char
hGetChar Handle
h
    FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
ix_r (Int
ixforall a. Num a => a -> a -> a
+Int
1)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c))    -- XXX not really correct

putByte :: BinHandle -> Word8 -> IO ()
putByte :: BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
w = 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

-- -----------------------------------------------------------------------------
-- Primitve 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w forall a. Bits a => a -> Int -> a
`shiftR` Int
8))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
w forall a. Bits a => a -> a -> a
.&. Word16
0xff))
  get :: BinHandle -> IO Word16
get BinHandle
h = do
    Word8
w1 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w2 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w1 forall a. Bits a => a -> Int -> a
`shiftL` Int
8) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w2)


instance Binary Word32 where
  put_ :: BinHandle -> Word32 -> IO ()
put_ BinHandle
h Word32
w = do
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w forall a. Bits a => a -> Int -> a
`shiftR` Int
24))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
w forall a. Bits a => a -> Int -> a
`shiftR` Int
16) forall a. Bits a => a -> a -> a
.&. Word32
0xff))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
w forall a. Bits a => a -> Int -> a
`shiftR` Int
8)  forall a. Bits a => a -> a -> a
.&. Word32
0xff))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w forall a. Bits a => a -> a -> a
.&. Word32
0xff))
  get :: BinHandle -> IO Word32
get BinHandle
h = do
    Word8
w1 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w2 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w3 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w4 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w1 forall a. Bits a => a -> Int -> a
`shiftL` Int
24) forall a. Bits a => a -> a -> a
.|.
               (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w2 forall a. Bits a => a -> Int -> a
`shiftL` Int
16) forall a. Bits a => a -> a -> a
.|.
               (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w3 forall a. Bits a => a -> Int -> a
`shiftL`  Int
8) forall a. Bits a => a -> a -> a
.|.
               (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w4))


instance Binary Word64 where
  put_ :: BinHandle -> Word64 -> IO ()
put_ BinHandle
h Word64
w = do
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
56))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
48) forall a. Bits a => a -> a -> a
.&. Word64
0xff))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
40) forall a. Bits a => a -> a -> a
.&. Word64
0xff))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
32) forall a. Bits a => a -> a -> a
.&. Word64
0xff))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
24) forall a. Bits a => a -> a -> a
.&. Word64
0xff))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR` Int
16) forall a. Bits a => a -> a -> a
.&. Word64
0xff))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word64
w forall a. Bits a => a -> Int -> a
`shiftR`  Int
8) forall a. Bits a => a -> a -> a
.&. Word64
0xff))
    BinHandle -> Word8 -> IO ()
putByte BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
w forall a. Bits a => a -> a -> a
.&. Word64
0xff))
  get :: BinHandle -> IO Word64
get BinHandle
h = do
    Word8
w1 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w2 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w3 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w4 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w5 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w6 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w7 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    Word8
w8 <- BinHandle -> IO Word8
getWord8 BinHandle
h
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w1 forall a. Bits a => a -> Int -> a
`shiftL` Int
56) forall a. Bits a => a -> a -> a
.|.
               (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w2 forall a. Bits a => a -> Int -> a
`shiftL` Int
48) forall a. Bits a => a -> a -> a
.|.
               (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w3 forall a. Bits a => a -> Int -> a
`shiftL` Int
40) forall a. Bits a => a -> a -> a
.|.
               (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w4 forall a. Bits a => a -> Int -> a
`shiftL` Int
32) forall a. Bits a => a -> a -> a
.|.
               (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w5 forall a. Bits a => a -> Int -> a
`shiftL` Int
24) forall a. Bits a => a -> a -> a
.|.
               (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w6 forall a. Bits a => a -> Int -> a
`shiftL` Int
16) forall a. Bits a => a -> a -> a
.|.
               (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w7 forall a. Bits a => a -> Int -> a
`shiftL`  Int
8) forall a. Bits a => a -> a -> a
.|.
               (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w8))

-- -----------------------------------------------------------------------------
-- Primitve Int writes

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

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

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

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

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

instance Binary () where
    put_ :: BinHandle -> () -> IO ()
put_ BinHandle
bh () = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    get :: BinHandle -> IO ()
get  BinHandle
_     = 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum Bool
b))
    get :: BinHandle -> IO Bool
get  BinHandle
bh   = do Word8
x <- BinHandle -> IO Word8
getWord8 BinHandle
bh; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall a. Enum a => Int -> a
toEnum (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x))
--    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 = forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) :: Word8)
    get :: BinHandle -> IO Char
get  BinHandle
bh   = do Word8
x <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
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 = forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i :: Int64)
    get :: BinHandle -> IO Int
get  BinHandle
bh = do
        Int64
x <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
x :: Int64))
#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 forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
list)
                      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh) [a]
list
    get :: BinHandle -> IO [a]
get BinHandle
bh = do Int
len <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                let getMany :: Int -> IO [a]
                    getMany :: Int -> IO [a]
getMany Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
                    getMany Int
n = do a
x <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                   [a]
xs <- Int -> IO [a]
getMany (Int
nforall a. Num a => a -> a -> a
-Int
1)
                                   forall (m :: * -> *) a. Monad m => a -> m a
return (a
xforall a. a -> [a] -> [a]
:[a]
xs)
                Int -> IO [a]
getMany Int
len

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

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

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

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

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

instance (Binary a, Binary i, Ix i) => Binary (Array i a) where
  put_ :: BinHandle -> Array i a -> IO ()
put_ BinHandle
bh Array i a
arr = do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall i e. Array i e -> (i, i)
Data.Array.bounds Array i a
arr)
                   forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall i e. Array i e -> [e]
Data.Array.elems Array i a
arr)
  get :: BinHandle -> IO (Array i a)
get BinHandle
bh = do (i, i)
bounds <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
              [a]
elems <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (i, i)
bounds [a]
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 = forall k a. Map k a -> [(k, a)]
Map.toList Map key elem
fm
                    forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(key, elem)]
list)
                    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(key
key, elem
val) -> do forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh key
key
                                             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 Int
len <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                let getMany :: Int -> IO [(key,elem)]
                    getMany :: Int -> IO [(key, elem)]
getMany Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
                    getMany Int
n = do key
key <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                                   elem
val <- forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh
                                   [(key, elem)]
xs <- Int -> IO [(key, elem)]
getMany (Int
nforall a. Num a => a -> a -> a
-Int
1)
                                   forall (m :: * -> *) a. Monad m => a -> m a
return ((key
key,elem
val)forall a. a -> [a] -> [a]
:[(key, elem)]
xs)
--                printElapsedTime "before get Map"
                [(key, elem)]
list <- Int -> IO [(key, elem)]
getMany Int
len
--                printElapsedTime "after get Map"
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(key, elem)]
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
      forall a. Binary a => BinHandle -> a -> IO (Bin a)
put BinHandle
h ((forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
signum Integer
n) :: Int8)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
n forall a. Eq a => a -> a -> Bool
/= Integer
0) forall a b. (a -> b) -> a -> b
$ do
        let n' :: Integer
n' = forall a. Num a => a -> a
abs Integer
n
            nBytes :: Int
nBytes = forall {p}. (Ord p, Bits p, Num p) => p -> Int
byteSize Integer
n'
        forall a. Binary a => BinHandle -> a -> IO (Bin a)
put BinHandle
h (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nBytes :: Word64)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BinHandle -> Word8 -> IO ()
putByte BinHandle
h) [ forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Integer
n' forall a. Bits a => a -> Int -> a
`shiftR` (Int
b forall a. Num a => a -> a -> a
* Int
8)) forall a. Bits a => a -> a -> a
.&. Integer
0xff)
                          | Int
b <- [ Int
nBytesforall a. Num a => a -> a -> a
-Int
1, Int
nBytesforall 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 forall a. Bits a => a -> Int -> a
`shiftL` (Int
b forall a. Num a => a -> a -> a
* Int
8)) forall a. Ord a => a -> a -> Bool
> p
n
                             then Int
b
                             else Int -> Int
f (Int
b forall a. Num a => a -> a -> a
+ Int
1)
                in Int -> Int
f Int
0
    get :: BinHandle -> IO Integer
get BinHandle
h = do
      Int8
sign :: Int8 <- forall a. Binary a => BinHandle -> IO a
get BinHandle
h
      if Int8
sign forall a. Eq a => a -> a -> Bool
== Int8
0
         then forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
         else do
           Word64
nBytes :: Word64 <- forall a. Binary a => BinHandle -> IO a
get BinHandle
h
           Integer
n <- forall {t} {t}. (Bits t, Num t, Num t, Eq t) => t -> t -> IO t
accumBytes Word64
nBytes Integer
0
           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
sign forall a. Num a => a -> a -> a
* Integer
n
      where accumBytes :: t -> t -> IO t
accumBytes t
nBytes t
acc | t
nBytes forall a. Eq a => a -> a -> Bool
== t
0 = forall (m :: * -> *) a. Monad m => a -> m a
return t
acc
                                  | Bool
otherwise = do
                Word8
b <- BinHandle -> IO Word8
getByte BinHandle
h
                t -> t -> IO t
accumBytes (t
nBytes forall a. Num a => a -> a -> a
- t
1) ((t
acc forall a. Bits a => a -> Int -> a
`shiftL` Int
8) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b)
#endif

#endif

instance Binary (Bin a) where
  put_ :: BinHandle -> Bin a -> IO ()
put_ BinHandle
bh (BinPtr Int
i) = forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
i
  get :: BinHandle -> IO (Bin a)
get BinHandle
bh = do Int
i <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Int -> Bin a
BinPtr Int
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:
    Bin (Bin Any)
pre_a <- forall a. BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
pre_a       -- save a slot for the ptr
    forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
a           -- dump the object
    Bin Any
q <- forall a. BinHandle -> IO (Bin a)
tellBin BinHandle
bh     -- q = ptr to after object
    forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
pre_a Bin Any
q    -- fill in slot before a with ptr to q
    forall a. BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
q        -- finally carry on writing at q

lazyGet :: Binary a => BinHandle -> IO a
lazyGet :: forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh = do
    Bin Any
p <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh         -- a BinPtr
    Bin a
p_a <- forall a. BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    a
a <- forall a. IO a -> IO a
unsafeInterleaveIO (forall a. Binary a => BinHandle -> Bin a -> IO a
getAt BinHandle
bh Bin a
p_a)
    forall a. BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
p -- skip over the object for now
    forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- --------------------------------------------------------------
--      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
1024forall 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
  BinHandle
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)
  Word32
magic <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
magic forall a. Eq a => a -> a -> Bool
/= Word32
binaryInterfaceMagic) forall a b. (a -> b) -> a -> b
$
        forall a. HasCallStack => String -> a
error String
"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)
  Bin Any
dict_p <- forall a. Binary a => BinHandle -> IO a
Binary.get BinHandle
bh       -- Get the dictionary ptr
  Bin Any
data_p <- forall a. BinHandle -> IO (Bin a)
tellBin BinHandle
bh          -- Remember where we are now
  forall a. BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
dict_p
  Dictionary
dict <- BinHandle -> IO Dictionary
getDictionary BinHandle
bh
  forall a. BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
data_p             -- Back to where we were before

        -- Initialise the user-data field of bh
  let bh' :: BinHandle
bh' = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh (Dictionary -> UserData
initReadState Dictionary
dict)
        
        -- At last, get the thing
  forall a. Binary a => BinHandle -> IO a
get BinHandle
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
  BinHandle
bh <- Int -> IO BinHandle
openBinMem Int
initBinMemSize
  forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Word32
binaryInterfaceMagic

        -- Remember where the dictionary pointer will go
  Bin (Bin Any)
dict_p_p <- forall a. BinHandle -> IO (Bin a)
tellBin BinHandle
bh
  forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
dict_p_p      -- Placeholder for ptr to dictionary

        -- Make some intial state
  UserData
usr_state <- IO UserData
newWriteState

        -- Put the main thing,
  forall a. Binary a => BinHandle -> a -> IO ()
put_ (BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh UserData
usr_state) a
the_thing

        -- Get the final-state
  Int
j <- forall a. IORef a -> IO a
readIORef  (UserData -> IORef Int
ud_next UserData
usr_state)
#if __GLASGOW_HASKELL__>=602
  [(String, Int)]
fm <- forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> IO [(k, v)]
HashTable.toList (UserData -> BasicHashTable String Int
ud_map  UserData
usr_state)
#else
  fm <- liftM Map.toList $ readIORef (ud_map  usr_state)
#endif
  Bin Any
dict_p <- forall a. BinHandle -> IO (Bin a)
tellBin BinHandle
bh  -- This is where the dictionary will start

        -- Write the dictionary pointer at the fornt of the file
  forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
dict_p_p Bin Any
dict_p      -- Fill in the placeholder
  forall a. BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
dict_p             -- Seek back to the end of the file

        -- Write the dictionary itself
  BinHandle -> Int -> Dictionary -> IO ()
putDictionary BinHandle
bh Int
j (Int -> [(String, Int)] -> Dictionary
constructDictionary Int
j [(String, Int)]
fm)

        -- And send the result to the file
  BinHandle -> String -> IO ()
writeBinMem BinHandle
bh String
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 -> BasicHashTable 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 = 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 = forall {a}. String -> a
undef String
"next",
                               ud_map :: BasicHashTable String Int
ud_map  = forall {a}. String -> a
undef String
"map" }

newWriteState :: IO UserData
newWriteState :: IO UserData
newWriteState = do
  IORef Int
j_r <- forall a. a -> IO (IORef a)
newIORef Int
0
#if __GLASGOW_HASKELL__>=602
# if __GLASGOW_HASKELL__>=707
  HashTable RealWorld String Int
out_r <- forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
HashTable.new
# else
  out_r <- HashTable.new (==) HashTable.hashString
# endif
#else
  out_r <- newIORef Map.empty
#endif
  forall (m :: * -> *) a. Monad m => a -> m a
return (UserData { ud_dict :: Dictionary
ud_dict = forall a. HasCallStack => String -> a
error String
"dict",
                     ud_next :: IORef Int
ud_next = IORef Int
j_r,
                     ud_map :: BasicHashTable String Int
ud_map  = HashTable RealWorld String Int
out_r })


undef :: String -> a
undef String
s = forall a. HasCallStack => String -> a
error (String
"Binary.UserData: no " 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
  forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
sz
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh) (forall i e. Array i e -> [e]
elems Dictionary
dict)

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

constructDictionary :: Int -> [(String,Int)] -> Dictionary
constructDictionary :: Int -> [(String, Int)] -> Dictionary
constructDictionary Int
j [(String, Int)]
fm = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Int
0,Int
jforall a. Num a => a -> a -> a
-Int
1) (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 -> BasicHashTable String Int
ud_map = BasicHashTable String Int
out_r, ud_dict :: UserData -> Dictionary
ud_dict = Dictionary
dict} -> do
#if __GLASGOW_HASKELL__>=602
      Maybe Int
entry <- forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
HashTable.lookup BasicHashTable String Int
out_r String
str
#else
      fm <- readIORef out_r
      let entry = Map.lookup str fm
#endif
      case Maybe Int
entry of
        Just Int
j  -> forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
j
        Maybe Int
Nothing -> do
                     Int
j <- forall a. IORef a -> IO a
readIORef IORef Int
j_r
                     forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
j
                     forall a. IORef a -> a -> IO ()
writeIORef IORef Int
j_r (Int
jforall a. Num a => a -> a -> a
+Int
1)
#if __GLASGOW_HASKELL__>=602
                     forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
HashTable.insert BasicHashTable String Int
out_r String
str Int
j
#else
                     modifyIORef out_r (\fm -> Map.insert str j fm)
#endif

getSharedString :: BinHandle -> IO String
getSharedString :: BinHandle -> IO String
getSharedString BinHandle
bh = do
        Int
j <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (UserData -> Dictionary
ud_dict (BinHandle -> UserData
getUserData BinHandle
bh) forall i e. Ix i => Array i e -> i -> e
! Int
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
  Integer
time <- IO Integer
getCPUTime
  Handle -> String -> IO ()
hPutStr Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"elapsed time: " forall a. [a] -> [a] -> [a]
++ forall a. RealFloat a => Maybe Int -> a -> ShowS
Numeric.showFFloat (forall a. a -> Maybe a
Just Int
2) ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
time) forall a. Fractional a => a -> a -> a
/ Double
10forall a b. (Num a, Integral b) => a -> b -> a
^Integer
12) String
" (" forall a. [a] -> [a] -> [a]
++ String
msg forall a. [a] -> [a] -> [a]
++ String
")\n"