module Database.VCache.VGet
( VGet
, getVRef, getPVar
, getVSpace
, getWord8
, getWord16le, getWord16be
, getWord32le, getWord32be
, getWord64le, getWord64be
, getStorable
, getVarNat, getVarInt
, getByteString, getByteStringLazy
, getc
, withBytes
, isolate
, label
, lookAhead, lookAheadM, lookAheadE
, isEmpty
) where
import Control.Applicative
import Data.Bits
import Data.Char
import Data.Word
import Foreign.Ptr
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Alloc (mallocBytes,finalizerFree)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.ForeignPtr (newForeignPtr)
import qualified Data.List as L
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.Alloc
import Database.VCache.VGetAux
isolate :: Int -> Int -> VGet a -> VGet a
isolate nBytes nRefs op = VGet $ \ s ->
let pF = vget_target s `plusPtr` nBytes in
if (pF > vget_limit s) then return (VGetE "isolate: not enough data") else
case takeExact nRefs (vget_children s) of
Nothing -> return (VGetE "isolate: not enough children")
Just (cs,cs') ->
let s_isolated = s { vget_children = cs
, vget_limit = pF
}
in
let s_postIsolate = s { vget_children = cs'
, vget_target = pF
}
in
_vget op s_isolated >>= \ r_isolated -> case r_isolated of
VGetE emsg -> return (VGetE emsg)
VGetR r s' ->
let bDone = vgetStateEmpty s' in
if bDone then return (VGetR r s_postIsolate) else
return (VGetE "isolate: did not parse all input")
takeExact :: Int -> [a] -> Maybe ([a],[a])
takeExact = takeExact' []
takeExact' :: [a] -> Int -> [a] -> Maybe ([a],[a])
takeExact' l 0 r = Just (L.reverse l, r)
takeExact' l n (r:rs) = takeExact' (r:l) (n1) rs
takeExact' _ _ _ = Nothing
getVRef :: (VCacheable a) => VGet (VRef a)
getVRef = VGet $ \ s ->
case (vget_children s) of
(c:cs) | isVRefAddr c -> do
let s' = s { vget_children = cs }
vref <- addr2vref (vget_space s) c
return (VGetR vref s')
_ -> return (VGetE "getVRef")
getPVar :: (VCacheable a) => VGet (PVar a)
getPVar = VGet $ \ s ->
case (vget_children s) of
(c:cs) | isPVarAddr c -> do
let s' = s { vget_children = cs }
pvar <- addr2pvar (vget_space s) c
return (VGetR pvar s')
_ -> return (VGetE "getPVar")
getVSpace :: VGet VSpace
getVSpace = VGet $ \ s -> return (VGetR (vget_space s) s)
getWord16le, getWord16be :: VGet Word16
getWord32le, getWord32be :: VGet Word32
getWord64le, getWord64be :: VGet Word64
getWord16le = consuming 2 $ VGet $ \ s -> do
let p = vget_target s
b0 <- peekByte p
b1 <- peekByte (p `plusPtr` 1)
let r = (fromIntegral b1 `shiftL` 8) .|.
(fromIntegral b0 )
let s' = s { vget_target = p `plusPtr` 2 }
return (VGetR r s')
getWord32le = consuming 4 $ VGet $ \ s -> do
let p = vget_target s
b0 <- peekByte p
b1 <- peekByte (p `plusPtr` 1)
b2 <- peekByte (p `plusPtr` 2)
b3 <- peekByte (p `plusPtr` 3)
let r = (fromIntegral b3 `shiftL` 24) .|.
(fromIntegral b2 `shiftL` 16) .|.
(fromIntegral b1 `shiftL` 8) .|.
(fromIntegral b0 )
let s' = s { vget_target = p `plusPtr` 4 }
return (VGetR r s')
getWord64le = consuming 8 $ VGet $ \ s -> do
let p = vget_target s
b0 <- peekByte p
b1 <- peekByte (p `plusPtr` 1)
b2 <- peekByte (p `plusPtr` 2)
b3 <- peekByte (p `plusPtr` 3)
b4 <- peekByte (p `plusPtr` 4)
b5 <- peekByte (p `plusPtr` 5)
b6 <- peekByte (p `plusPtr` 6)
b7 <- peekByte (p `plusPtr` 7)
let r = (fromIntegral b7 `shiftL` 56) .|.
(fromIntegral b6 `shiftL` 48) .|.
(fromIntegral b5 `shiftL` 40) .|.
(fromIntegral b4 `shiftL` 32) .|.
(fromIntegral b3 `shiftL` 24) .|.
(fromIntegral b2 `shiftL` 16) .|.
(fromIntegral b1 `shiftL` 8) .|.
(fromIntegral b0 )
let s' = s { vget_target = p `plusPtr` 8 }
return (VGetR r s')
getWord16be = consuming 2 $ VGet $ \ s -> do
let p = vget_target s
b0 <- peekByte p
b1 <- peekByte (p `plusPtr` 1)
let r = (fromIntegral b0 `shiftL` 8) .|.
(fromIntegral b1 )
let s' = s { vget_target = p `plusPtr` 2 }
return (VGetR r s')
getWord32be = consuming 4 $ VGet $ \ s -> do
let p = vget_target s
b0 <- peekByte p
b1 <- peekByte (p `plusPtr` 1)
b2 <- peekByte (p `plusPtr` 2)
b3 <- peekByte (p `plusPtr` 3)
let r = (fromIntegral b0 `shiftL` 24) .|.
(fromIntegral b1 `shiftL` 16) .|.
(fromIntegral b2 `shiftL` 8) .|.
(fromIntegral b3 )
let s' = s { vget_target = p `plusPtr` 4 }
return (VGetR r s')
getWord64be = consuming 8 $ VGet $ \ s -> do
let p = vget_target s
b0 <- peekByte p
b1 <- peekByte (p `plusPtr` 1)
b2 <- peekByte (p `plusPtr` 2)
b3 <- peekByte (p `plusPtr` 3)
b4 <- peekByte (p `plusPtr` 4)
b5 <- peekByte (p `plusPtr` 5)
b6 <- peekByte (p `plusPtr` 6)
b7 <- peekByte (p `plusPtr` 7)
let r = (fromIntegral b0 `shiftL` 56) .|.
(fromIntegral b1 `shiftL` 48) .|.
(fromIntegral b2 `shiftL` 40) .|.
(fromIntegral b3 `shiftL` 32) .|.
(fromIntegral b4 `shiftL` 24) .|.
(fromIntegral b5 `shiftL` 16) .|.
(fromIntegral b6 `shiftL` 8) .|.
(fromIntegral b7 )
let s' = s { vget_target = p `plusPtr` 8 }
return (VGetR r s')
getStorable :: (Storable a) => VGet a
getStorable = _getStorable undefined
_getStorable :: (Storable a) => a -> VGet a
_getStorable _dummy = withBytes (sizeOf _dummy) (peekAligned . castPtr)
getByteString :: Int -> VGet BS.ByteString
getByteString n | (n > 0) = _getByteString n
| otherwise = return (BS.empty)
_getByteString :: Int -> VGet BS.ByteString
_getByteString n = withBytes n $ \ pSrc -> do
pDst <- mallocBytes n
copyBytes pDst pSrc n
fp <- newForeignPtr finalizerFree pDst
return $! BSI.fromForeignPtr fp 0 n
getByteStringLazy :: Int -> VGet LBS.ByteString
getByteStringLazy n = LBS.fromStrict <$> getByteString n
withBytes :: Int -> (Ptr Word8 -> IO a) -> VGet a
withBytes n action = consuming n $ VGet $ \ s -> do
let pTgt = vget_target s
let s' = s { vget_target = pTgt `plusPtr` n }
a <- action pTgt
return (VGetR a s')
getc :: VGet Char
getc =
_c0 >>= \ b0 ->
if (b0 < 0x80) then return $! chr b0 else
if (b0 < 0xe0) then _getc2 (b0 `xor` 0xc0) else
if (b0 < 0xf0) then _getc3 (b0 `xor` 0xe0) else
_getc4 (b0 `xor` 0xf0)
_getc2, _getc3, _getc4 :: Int -> VGet Char
_getc2 b0 =
_cc >>= \ b1 ->
return $! chr ((b0 `shiftL` 6) .|. b1)
_getc3 b0 =
_cc >>= \ b1 ->
_cc >>= \ b2 ->
return $! chr ((b0 `shiftL` 12) .|. (b1 `shiftL` 6) .|. b2)
_getc4 b0 =
_cc >>= \ b1 ->
_cc >>= \ b2 ->
_cc >>= \ b3 ->
return $! chr ((b0 `shiftL` 18) .|. (b1 `shiftL` 12) .|. (b2 `shiftL` 6) .|. b3)
_c0,_cc :: VGet Int
_c0 = fromIntegral <$> getWord8
_cc = (fromIntegral . xor 0x80) <$> getWord8
label :: ShowS -> VGet a -> VGet a
label sf op = VGet $ \ s ->
_vget op s >>= \ r ->
return $
case r of
VGetE emsg -> VGetE (sf emsg)
ok@(VGetR _ _) -> ok
lookAhead :: VGet a -> VGet a
lookAhead op = VGet $ \ s ->
_vget op s >>= \ result ->
return $
case result of
VGetR r _ -> VGetR r s
other -> other
lookAheadM :: VGet (Maybe a) -> VGet (Maybe a)
lookAheadM op = VGet $ \ s ->
_vget op s >>= \ result ->
return $
case result of
VGetR Nothing _ -> VGetR Nothing s
other -> other
lookAheadE :: VGet (Either a b) -> VGet (Either a b)
lookAheadE op = VGet $ \ s ->
_vget op s >>= \ result ->
return $
case result of
VGetR l@(Left _) _ -> VGetR l s
other -> other