module Database.VCache.VPutAux
( reserving, reserve
, unsafePutWord8
, putWord8
, putVarNat
, putVarInt
, putVarNatR
) where
import Control.Applicative
import Data.Bits
import Data.Word
import Data.IORef
import Foreign.Storable
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Database.VCache.Types
reserving :: Int -> VPut a -> VPut a
reserving n op = reserve n >> op
reserve :: Int -> VPut ()
reserve n = VPut $ \ s ->
let avail = vput_limit s `minusPtr` vput_target s in
if (avail >= n) then return (VPutR () s)
else VPutR () <$> grow n s
grow :: Int -> VPutS -> IO VPutS
grow n s =
readIORef (vput_buffer s) >>= \ pBuff ->
let currSize = vput_limit s `minusPtr` pBuff in
let bytesUsed = vput_target s `minusPtr` pBuff in
let bytesNeeded = (2 * currSize) + n + 1000 in
reallocBytes pBuff bytesNeeded >>= \ pBuff' ->
writeIORef (vput_buffer s) pBuff' >>
let target' = pBuff' `plusPtr` bytesUsed in
let limit' = pBuff' `plusPtr` bytesNeeded in
return $ s
{ vput_target = target'
, vput_limit = limit'
}
unsafePutWord8 :: Word8 -> VPut ()
unsafePutWord8 w8 = VPut $ \ s ->
let pTgt = vput_target s in
let s' = s { vput_target = (pTgt `plusPtr` 1) } in
poke pTgt w8 >>
return (VPutR () s')
putWord8 :: Word8 -> VPut ()
putWord8 w8 = reserving 1 $ unsafePutWord8 w8
putVarNat :: Integer -> VPut ()
putVarNat n | (n < 0) = fail $ "putVarNat with " ++ show n
| otherwise = _putVarNat q >> putWord8 bLo
where q = n `shiftR` 7
bLo = 0x7f .&. fromIntegral n
_putVarNat :: Integer -> VPut ()
_putVarNat 0 = return ()
_putVarNat n = _putVarNat q >> putWord8 b where
q = n `shiftR` 7
b = 0x80 .|. (0x7f .&. fromIntegral n)
putVarInt :: Integer -> VPut ()
putVarInt = putVarNat . zigZag
zigZag :: Integer -> Integer
zigZag n | (n < 0) = (negate n * 2) 1
| otherwise = (n * 2)
putVarNatR :: Int -> VPut ()
putVarNatR n | (n < 0) = fail $ "putVarNatR with " ++ show n
| otherwise = putWord8 bLo >> _putVarNatR q
where bLo = 0x7f .&. fromIntegral n
q = n `shiftR` 7
_putVarNatR :: Int -> VPut ()
_putVarNatR 0 = return ()
_putVarNatR n = putWord8 b >> _putVarNatR q where
b = 0x80 .|. (0x7f .&. fromIntegral n)
q = n `shiftR` 7