module Data.Binary.Get.Internal (
Get
, runCont
, Decoder(..)
, runGetIncremental
, readN
, readNWith
, skip
, bytesRead
, get
, put
, demandInput
, ensureN
, remaining
, getBytes
, isEmpty
, lookAhead
, lookAheadM
, lookAheadE
, getByteString
) where
import Foreign
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Unsafe as B
import Control.Applicative
import Control.Monad
#if __GLASGOW_HASKELL__ < 704 && !defined(__HADDOCK__)
import GHC.Base
#endif
data Decoder a = Fail !B.ByteString String
| Partial (Maybe B.ByteString -> Decoder a)
| Done !B.ByteString a
| BytesRead !Int64 (Int64 -> Decoder a)
newtype Get a = C { runCont :: forall r.
B.ByteString ->
Success a r ->
Decoder r }
type Success a r = B.ByteString -> a -> Decoder r
instance Monad Get where
return = returnG
(>>=) = bindG
fail = failG
returnG :: a -> Get a
returnG a = C $ \s ks -> ks s a
bindG :: Get a -> (a -> Get b) -> Get b
bindG (C c) f = C $ \i ks -> c i (\i' a -> (runCont (f a)) i' ks)
failG :: String -> Get a
failG str = C $ \i _ks -> Fail i str
apG :: Get (a -> b) -> Get a -> Get b
apG d e = do
b <- d
a <- e
return (b a)
fmapG :: (a -> b) -> Get a -> Get b
fmapG f m = C $ \i ks -> runCont m i (\i' a -> ks i' (f a))
instance Applicative Get where
pure = returnG
(<*>) = apG
instance MonadPlus Get where
mzero = empty
mplus = (<|>)
instance Functor Get where
fmap = fmapG
instance Functor Decoder where
fmap f (Done s a) = Done s (f a)
fmap f (Partial k) = Partial (fmap f . k)
fmap _ (Fail s msg) = Fail s msg
fmap f (BytesRead b k) = BytesRead b (fmap f . k)
instance (Show a) => Show (Decoder a) where
show (Fail _ msg) = "Fail: " ++ msg
show (Partial _) = "Partial _"
show (Done _ a) = "Done: " ++ show a
show (BytesRead _ _) = "BytesRead"
runGetIncremental :: Get a -> Decoder a
runGetIncremental g = noMeansNo $
runCont g B.empty (\i a -> Done i a)
noMeansNo :: Decoder a -> Decoder a
noMeansNo r0 = go r0
where
go r =
case r of
Partial k -> Partial $ \ms ->
case ms of
Just _ -> go (k ms)
Nothing -> neverAgain (k ms)
BytesRead n k -> BytesRead n (go . k)
Done _ _ -> r
Fail _ _ -> r
neverAgain r =
case r of
Partial k -> neverAgain (k Nothing)
BytesRead n k -> BytesRead n (neverAgain . k)
Fail _ _ -> r
Done _ _ -> r
prompt :: B.ByteString -> Decoder a -> (B.ByteString -> Decoder a) -> Decoder a
prompt inp kf ks =
let loop =
Partial $ \sm ->
case sm of
Just s | B.null s -> loop
| otherwise -> ks (inp `B.append` s)
Nothing -> kf
in loop
bytesRead :: Get Int64
bytesRead = C $ \inp k -> BytesRead (fromIntegral $ B.length inp) (k inp)
demandInput :: Get ()
demandInput = C $ \inp ks ->
prompt inp (Fail inp "demandInput: not enough bytes") (\inp' -> ks inp' ())
skip :: Int -> Get ()
skip n = readN n (const ())
isEmpty :: Get Bool
isEmpty = C $ \inp ks ->
if B.null inp
then prompt inp (ks inp True) (\inp' -> ks inp' False)
else ks inp False
getBytes :: Int -> Get B.ByteString
getBytes = getByteString
instance Alternative Get where
empty = C $ \inp _ks -> Fail inp "Data.Binary.Get(Alternative).empty"
(<|>) f g = do
(decoder, bs) <- runAndKeepTrack f
case decoder of
Done inp x -> C $ \_ ks -> ks inp x
Fail _ _ -> pushBack bs >> g
_ -> error "Binary: impossible"
some p = (:) <$> p <*> many p
many p = do
v <- (Just <$> p) <|> pure Nothing
case v of
Nothing -> pure []
Just x -> (:) x <$> many p
runAndKeepTrack :: Get a -> Get (Decoder a, [B.ByteString])
runAndKeepTrack g = C $ \inp ks ->
let r0 = runCont g inp (\inp' a -> Done inp' a)
go !acc r = case r of
Done inp' a -> ks inp (Done inp' a, reverse acc)
Partial k -> Partial $ \minp -> go (maybe acc (:acc) minp) (k minp)
Fail inp' s -> ks inp (Fail inp' s, reverse acc)
BytesRead unused k -> BytesRead unused (go acc . k)
in go [] r0
pushBack :: [B.ByteString] -> Get ()
pushBack [] = C $ \ inp ks -> ks inp ()
pushBack bs = C $ \ inp ks -> ks (B.concat (inp : bs)) ()
lookAhead :: Get a -> Get a
lookAhead g = do
(decoder, bs) <- runAndKeepTrack g
case decoder of
Done _ a -> pushBack bs >> return a
Fail inp s -> C $ \_ _ -> Fail inp s
_ -> error "Binary: impossible"
lookAheadM :: Get (Maybe a) -> Get (Maybe a)
lookAheadM g = do
let g' = maybe (Left ()) Right <$> g
either (const Nothing) Just <$> lookAheadE g'
lookAheadE :: Get (Either a b) -> Get (Either a b)
lookAheadE g = do
(decoder, bs) <- runAndKeepTrack g
case decoder of
Done _ (Left x) -> pushBack bs >> return (Left x)
Done inp (Right x) -> C $ \_ ks -> ks inp (Right x)
Fail inp s -> C $ \_ _ -> Fail inp s
_ -> error "Binary: impossible"
remaining :: Get Int64
remaining = C $ \ inp ks ->
let loop acc = Partial $ \ minp ->
case minp of
Nothing -> let all_inp = B.concat (inp : (reverse acc))
in ks all_inp (fromIntegral $ B.length all_inp)
Just inp' -> loop (inp':acc)
in loop []
getByteString :: Int -> Get B.ByteString
getByteString n | n > 0 = readN n (B.unsafeTake n)
| otherwise = return B.empty
get :: Get B.ByteString
get = C $ \inp ks -> ks inp inp
put :: B.ByteString -> Get ()
put s = C $ \_inp ks -> ks s ()
readN :: Int -> (B.ByteString -> a) -> Get a
readN !n f = ensureN n >> unsafeReadN n f
ensureN :: Int -> Get ()
ensureN !n0 = C $ \inp ks -> do
if B.length inp >= n0
then ks inp ()
else runCont (go n0) inp ks
where
go n = C $ \inp ks -> do
if B.length inp >= n
then ks inp ()
else runCont (demandInput >> go n) inp ks
unsafeReadN :: Int -> (B.ByteString -> a) -> Get a
unsafeReadN !n f = C $ \inp ks -> do
ks (B.unsafeDrop n inp) $! f inp
readNWith :: Int -> (Ptr a -> IO a) -> Get a
readNWith n f = do
readN n $ \s -> B.inlinePerformIO $ B.unsafeUseAsCString s (f . castPtr)