module Database.VCache.VPut
( VPut
, putVRef, putPVar
, putWord8
, putWord16le, putWord16be
, putWord32le, putWord32be
, putWord64le, putWord64be
, putStorable
, putVarNat, putVarInt
, reserve, reserving, unsafePutWord8
, putByteString, putByteStringLazy
, putc
) where
import Data.Bits
import Data.Char
import Data.Word
import Foreign.Ptr (plusPtr,castPtr)
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Utils (copyBytes)
import Foreign.ForeignPtr (withForeignPtr)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BSI
import qualified Data.ByteString.Lazy as LBS
import Database.VCache.Types
import Database.VCache.Aligned
import Database.VCache.VPutAux
putVRef :: VRef a -> VPut ()
putVRef ref = VPut $ \ s ->
if (vput_space s == vref_space ref) then _putVRef s ref else
fail $ "putVRef argument is not from destination VCache"
_putVRef :: VPutS -> VRef a -> IO (VPutR ())
_putVRef s ref =
let cs = vput_children s in
let c = PutChild (Right ref) in
let s' = s { vput_children = (c:cs) } in
return (VPutR () s')
putPVar :: PVar a -> VPut ()
putPVar pvar = VPut $ \ s ->
if (vput_space s == pvar_space pvar) then _putPVar s pvar else
fail $ "putPVar argument is not from destination VCache"
_putPVar :: VPutS -> PVar a -> IO (VPutR ())
_putPVar s pvar =
let cs = vput_children s in
let c = PutChild (Left pvar) in
let s' = s { vput_children = (c:cs) } in
return (VPutR () s')
putWord16le, putWord16be :: Word16 -> VPut ()
putWord32le, putWord32be :: Word32 -> VPut ()
putWord64le, putWord64be :: Word64 -> VPut ()
putWord16le w = reserving 2 $ VPut $ \ s -> do
let p = vput_target s
let s' = s { vput_target = (p `plusPtr` 2) }
poke (p ) (fromIntegral (w ) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (w `shiftR` 8) :: Word8)
return (VPutR () s')
putWord32le w = reserving 4 $ VPut $ \ s -> do
let p = vput_target s
let s' = s { vput_target = (p `plusPtr` 4) }
poke (p ) (fromIntegral (w ) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (w `shiftR` 8) :: Word8)
poke (p `plusPtr` 2) (fromIntegral (w `shiftR` 16) :: Word8)
poke (p `plusPtr` 3) (fromIntegral (w `shiftR` 24) :: Word8)
return (VPutR () s')
putWord64le w = reserving 8 $ VPut $ \ s -> do
let p = vput_target s
let s' = s { vput_target = (p `plusPtr` 8) }
poke (p ) (fromIntegral (w ) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (w `shiftR` 8) :: Word8)
poke (p `plusPtr` 2) (fromIntegral (w `shiftR` 16) :: Word8)
poke (p `plusPtr` 3) (fromIntegral (w `shiftR` 24) :: Word8)
poke (p `plusPtr` 4) (fromIntegral (w `shiftR` 32) :: Word8)
poke (p `plusPtr` 5) (fromIntegral (w `shiftR` 40) :: Word8)
poke (p `plusPtr` 6) (fromIntegral (w `shiftR` 48) :: Word8)
poke (p `plusPtr` 7) (fromIntegral (w `shiftR` 56) :: Word8)
return (VPutR () s')
putWord16be w = reserving 2 $ VPut $ \ s -> do
let p = vput_target s
let s' = s { vput_target = (p `plusPtr` 2) }
poke (p ) (fromIntegral (w `shiftR` 8) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (w ) :: Word8)
return (VPutR () s')
putWord32be w = reserving 4 $ VPut $ \ s -> do
let p = vput_target s
let s' = s { vput_target = (p `plusPtr` 4) }
poke (p ) (fromIntegral (w `shiftR` 24) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (w `shiftR` 16) :: Word8)
poke (p `plusPtr` 2) (fromIntegral (w `shiftR` 8) :: Word8)
poke (p `plusPtr` 3) (fromIntegral (w ) :: Word8)
return (VPutR () s')
putWord64be w = reserving 8 $ VPut $ \ s -> do
let p = vput_target s
let s' = s { vput_target = (p `plusPtr` 8) }
poke (p ) (fromIntegral (w `shiftR` 56) :: Word8)
poke (p `plusPtr` 1) (fromIntegral (w `shiftR` 48) :: Word8)
poke (p `plusPtr` 2) (fromIntegral (w `shiftR` 40) :: Word8)
poke (p `plusPtr` 3) (fromIntegral (w `shiftR` 32) :: Word8)
poke (p `plusPtr` 4) (fromIntegral (w `shiftR` 24) :: Word8)
poke (p `plusPtr` 5) (fromIntegral (w `shiftR` 16) :: Word8)
poke (p `plusPtr` 6) (fromIntegral (w `shiftR` 8) :: Word8)
poke (p `plusPtr` 7) (fromIntegral (w ) :: Word8)
return (VPutR () s')
putStorable :: (Storable a) => a -> VPut ()
putStorable a =
let n = sizeOf a in
reserving n $ VPut $ \ s -> do
let pTgt = vput_target s
let s' = s { vput_target = (pTgt `plusPtr` n) }
pokeAligned (castPtr pTgt) a
return (VPutR () s')
putByteString :: BS.ByteString -> VPut ()
putByteString s = reserving (BS.length s) (_putByteString s)
putByteStringLazy :: LBS.ByteString -> VPut ()
putByteStringLazy s = reserving (fromIntegral $ LBS.length s) (mapM_ _putByteString (LBS.toChunks s))
_putByteString :: BS.ByteString -> VPut ()
_putByteString (BSI.PS fpSrc p_off p_len) =
VPut $ \ s -> withForeignPtr fpSrc $ \ pSrc -> do
let pDst = vput_target s
copyBytes pDst (pSrc `plusPtr` p_off) p_len
let s' = s { vput_target = (pDst `plusPtr` p_len) }
return (VPutR () s')
putc :: Char -> VPut ()
putc a | c <= 0x7f = putWord8 (fromIntegral c)
| c <= 0x7ff = reserving 2 $ VPut $ \ s -> do
let p = vput_target s
let s' = s { vput_target = (p `plusPtr` 2) }
poke (p ) (0xc0 .|. y)
poke (p `plusPtr` 1) (0x80 .|. z)
return (VPutR () s')
| c <= 0xffff = reserving 3 $ VPut $ \ s -> do
let p = vput_target s
let s' = s { vput_target = (p `plusPtr` 3) }
poke (p ) (0xe0 .|. x)
poke (p `plusPtr` 1) (0x80 .|. y)
poke (p `plusPtr` 2) (0x80 .|. z)
return (VPutR () s')
| c <= 0x10ffff = reserving 4 $ VPut $ \ s -> do
let p = vput_target s
let s' = s { vput_target = (p `plusPtr` 4) }
poke (p ) (0xf0 .|. w)
poke (p `plusPtr` 1) (0x80 .|. x)
poke (p `plusPtr` 2) (0x80 .|. y)
poke (p `plusPtr` 3) (0x80 .|. z)
return (VPutR () s')
| otherwise = fail "not a valid character"
where
c = ord a
z, y, x, w :: Word8
z = fromIntegral (c .&. 0x3f)
y = fromIntegral (shiftR c 6 .&. 0x3f)
x = fromIntegral (shiftR c 12 .&. 0x3f)
w = fromIntegral (shiftR c 18 .&. 0x7)