{-# LANGUAGE CPP, ScopedTypeVariables #-}
module Binary
( Bin,
Binary(..),
BinHandle,
openBinIO, openBinIO_,
openBinMem,
seekBin,
tellBin,
castBin,
writeBinMem,
readBinMem,
isEOFBin,
putByte,
getByte,
putSharedString,
getSharedString,
lazyGet,
lazyPut,
#if __GLASGOW_HASKELL__<610
ByteArray(..),
getByteArray,
putByteArray,
#endif
getBinFileWithDict,
putBinFileWithDict,
) 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
import System.CPUTime (getCPUTime)
import Numeric (showFFloat)
#define SIZEOF_HSINT SIZEOF_VOID_P
type BinArray = IOUArray Int Word8
data BinHandle
= BinMem {
BinHandle -> UserData
bh_usr :: UserData,
BinHandle -> FastMutInt
off_r :: !FastMutInt,
BinHandle -> FastMutInt
sz_r :: !FastMutInt,
BinHandle -> IORef BinArray
arr_r :: !(IORef BinArray)
}
| BinIO {
bh_usr :: UserData,
off_r :: !FastMutInt,
BinHandle -> Handle
hdl :: !IO.Handle
}
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 }
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 a where
put_ :: BinHandle -> a -> IO ()
put :: BinHandle -> a -> IO (Bin a)
get :: BinHandle -> IO a
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
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)
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 ()
{-# INLINE expandBin #-}
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
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))
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))
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
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
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))
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))
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 ()
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))
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)))
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
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_ :: 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)
list <- getMany len
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#
put_ bh (I# sz#)
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)
lazyPut :: Binary a => BinHandle -> a -> IO ()
lazyPut :: forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh a
a = do
pre_a <- BinHandle -> IO (Bin (Bin Any))
forall a. BinHandle -> IO (Bin a)
tellBin BinHandle
bh
put_ bh pre_a
put_ bh a
q <- tellBin bh
putAt bh pre_a q
seekBin bh 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
p_a <- tellBin bh
a <- unsafeInterleaveIO (getAt bh p_a)
seekBin bh p
return a
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
magic <- get bh
when (magic /= binaryInterfaceMagic) $
error "magic number mismatch: old/corrupt interface file?"
dict_p <- Binary.get bh
data_p <- tellBin bh
seekBin bh dict_p
dict <- getDictionary bh
seekBin bh data_p
let bh' = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh (Dictionary -> UserData
initReadState Dictionary
dict)
get bh'
putBinFileWithDict :: Binary a => FilePath -> a -> IO ()
putBinFileWithDict :: forall a. Binary a => String -> a -> IO ()
putBinFileWithDict String
file_path a
the_thing = do
bh <- Int -> IO BinHandle
openBinMem Int
initBinMemSize
put_ bh binaryInterfaceMagic
dict_p_p <- tellBin bh
put_ bh dict_p_p
usr_state <- newWriteState
put_ (setUserData bh usr_state) the_thing
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
putAt bh dict_p_p dict_p
seekBin bh dict_p
putDictionary bh j (constructDictionary j fm)
writeBinMem bh file_path
data UserData =
UserData {
UserData -> Dictionary
ud_dict :: Dictionary,
UserData -> IORef Int
ud_next :: IORef Int,
#if __GLASGOW_HASKELL__>=602
# if __GLASGOW_HASKELL__>=707
UserData -> IOHashTable HashTable String Int
ud_map :: BasicHashTable String Int
# else
ud_map :: HashTable String Int
# 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)
type Dictionary = Array Int String
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)
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)
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"