module Darcs.Patch.ReadMonads (ParserM, work, maybe_work, alter_input,
parse_strictly, parse_lazily,
peek_input,
lex_char, lex_string, lex_strings, lex_eof,
my_lex) where
import ByteStringUtils ( dropSpace, breakSpace )
import qualified Data.ByteString as B (null, empty, ByteString)
import qualified Data.ByteString.Char8 as BC (unpack, pack)
lex_char :: ParserM m => Char -> m ()
lex_char c = lex_string [c]
lex_string :: ParserM m => String -> m ()
lex_string str = work
$ \s -> case my_lex s of
Just (xs, ys) | xs == BC.pack str -> Just ((), ys)
_ -> Nothing
lex_eof :: ParserM m => m ()
lex_eof = work
$ \s -> if B.null (dropSpace s)
then Just ((), B.empty)
else Nothing
lex_strings :: ParserM m => [String] -> m String
lex_strings str =
work $ \s ->
case my_lex s of
Just (xs, ys) | xs' `elem` str -> Just (xs', ys)
where xs' = BC.unpack xs
_ -> Nothing
my_lex :: B.ByteString -> Maybe (B.ByteString, B.ByteString)
my_lex s = let s' = dropSpace s
in if B.null s'
then Nothing
else Just $ breakSpace s'
alter_input :: ParserM m
=> (B.ByteString -> B.ByteString) -> m ()
alter_input f = work (\s -> Just ((), f s))
class Monad m => ParserM m where
work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m a
maybe_work :: (B.ByteString -> Maybe (a, B.ByteString)) -> m (Maybe a)
peek_input :: m B.ByteString
parse_strictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString)
parse_strictly (SM f) s = f s
newtype SM a = SM (B.ByteString -> Maybe (a, B.ByteString))
instance Monad SM where
SM m >>= k = SM $ \s -> case m s of
Nothing -> Nothing
Just (x, s') ->
case k x of
SM y -> y s'
return x = SM (\s -> Just (x,s))
fail _ = SM (\_ -> Nothing)
instance ParserM SM where
work f = SM f
maybe_work f = SM $ \s -> case f s of
Just (x, s') -> Just (Just x, s')
Nothing -> Just (Nothing, s)
peek_input = SM $ \s -> Just (s, s)
parse_lazily :: LM a -> B.ByteString -> (a, B.ByteString)
parse_lazily (LM f) s = f s
newtype LM a = LM (B.ByteString -> (a, B.ByteString))
instance Monad LM where
LM m >>= k = LM $ \s -> let (x, s') = m s
LM y = k x
in y s'
return x = LM (\s -> (x,s))
fail s = error s
instance ParserM LM where
work f = LM $ \s -> case f s of
Nothing -> error "parser error"
Just x -> x
maybe_work f = LM $ \s -> case f s of
Nothing -> (Nothing, s)
Just (x, s') -> (Just x, s')
peek_input = LM $ \s -> (s, s)