module Darcs.Patch.ReadMonads (ParserM, Darcs.Patch.ReadMonads.take,
parse, parseStrictly, char, int,
option, choice, skipSpace, skipWhile, string,
lexChar, lexString, lexEof, takeTillChar,
myLex', anyChar, endOfInput, takeTill,
checkConsumes,
linesStartingWith, linesStartingWithEndingWith) where
import ByteStringUtils ( dropSpace, breakSpace, breakFirstPS,
readIntPS, breakLastPS )
import qualified Data.ByteString as B (null, drop, length, tail, empty,
ByteString)
import qualified Data.ByteString.Char8 as BC ( uncons, dropWhile, break
, splitAt, length, head )
import Control.Applicative ( Alternative(..), Applicative(..), (<$>) )
import Control.Monad ( MonadPlus(..) )
lexChar :: ParserM m => Char -> m ()
lexChar c = do
skipSpace
char c
return ()
lexString :: ParserM m => B.ByteString -> m ()
lexString str = work
$ \s -> case myLex s of
Just (xs :*: ys) | xs == str -> Just (() :*: ys)
_ -> Nothing
string :: ParserM m => B.ByteString -> m ()
string str = work
$ \s -> case BC.splitAt (BC.length str) s of
(h, t) | h == str -> Just (() :*: t)
_ -> Nothing
lexEof :: ParserM m => m ()
lexEof = work
$ \s -> if B.null (dropSpace s)
then Just (() :*: B.empty)
else Nothing
myLex :: B.ByteString -> Maybe (ParserState B.ByteString)
myLex s = let s' = dropSpace s
in if B.null s'
then Nothing
else Just $ stuple $ breakSpace s'
myLex' :: ParserM m => m B.ByteString
myLex' = work myLex
anyChar :: ParserM m => m Char
anyChar = work $ \s -> stuple <$> BC.uncons s
endOfInput :: ParserM m => m ()
endOfInput = work $ \s -> if B.null s
then Just (() :*: s)
else Nothing
char :: ParserM m => Char -> m ()
char c = work $ \s ->
case BC.uncons s of
Just (c', s') | c == c' -> Just (() :*: s')
_ -> Nothing
int :: ParserM m => m Int
int = work $ \s -> stuple <$> readIntPS s
skipSpace :: ParserM m => m ()
skipSpace = alterInput dropSpace
skipWhile :: ParserM m => (Char -> Bool) -> m ()
skipWhile p = alterInput (BC.dropWhile p)
takeTill :: ParserM m => (Char -> Bool) -> m B.ByteString
takeTill p = work $ \s -> Just $ stuple (BC.break p s)
takeTillChar :: ParserM m => Char -> m B.ByteString
takeTillChar c = work $ \s -> Just $ stuple (BC.break (==c) s)
take :: ParserM m => Int -> m B.ByteString
take n = work $ \s -> if B.length s >= n
then Just $ stuple $ BC.splitAt n s
else Nothing
linesStartingWith :: ParserM m => Char -> m [B.ByteString]
linesStartingWith c = work $ linesStartingWith' c
linesStartingWith' :: Char -> B.ByteString -> Maybe (ParserState [B.ByteString])
linesStartingWith' c thes =
Just (lsw [] thes)
where lsw acc s | B.null s || BC.head s /= c = (reverse acc :*: s)
lsw acc s = let s' = B.tail s
in case breakFirstPS '\n' s' of
Just (l, r) -> lsw (l:acc) r
Nothing -> (reverse (s':acc) :*: B.empty)
linesStartingWithEndingWith :: ParserM m => Char -> Char -> m [B.ByteString]
linesStartingWithEndingWith st en = work $ linesStartingWithEndingWith' st en
linesStartingWithEndingWith' :: Char -> Char -> B.ByteString
-> Maybe (ParserState [B.ByteString])
linesStartingWithEndingWith' st en s = lswew s
where
lswew x | B.null x = Nothing
lswew x =
if BC.head x == en
then Just ([] :*: B.tail x)
else if BC.head x /= st
then Nothing
else case BC.break ((==) '\n') $ B.tail x of
(l,r) -> case lswew $ B.tail r of
Just (ls :*: r') -> Just ((l:ls) :*: r')
Nothing ->
case breakLastPS en l of
Just (l2,_) ->
Just ([l2] :*: B.drop (B.length l2+2) x)
Nothing -> Nothing
alterInput :: ParserM m
=> (B.ByteString -> B.ByteString) -> m ()
alterInput f = work (\s -> Just (() :*: f s))
option :: Alternative f => a -> f a -> f a
option x p = p <|> pure x
choice :: Alternative f => [f a] -> f a
choice = foldr (<|>) empty
checkConsumes :: ParserM m => m a -> m a
checkConsumes parser = do
x <- B.length <$> peekInput
res <- parser
x' <- B.length <$> peekInput
if x' < x then return res else mzero
class (Functor m, Applicative m, Alternative m, Monad m, MonadPlus m) => ParserM m where
work :: (B.ByteString -> Maybe (ParserState a)) -> m a
maybeWork :: (B.ByteString -> Maybe (ParserState a)) -> m (Maybe a)
peekInput :: m B.ByteString
parse :: m a -> B.ByteString -> Maybe (a, B.ByteString)
parseStrictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString)
parseStrictly (SM f) s = case f s of
Just (a :*: r) -> Just (a, r)
_ -> Nothing
data ParserState a = !a :*: !B.ByteString
stuple :: (a, B.ByteString) -> ParserState a
stuple (a, b) = a :*: b
newtype SM a = SM (B.ByteString -> Maybe (ParserState a))
bindSM :: SM a -> (a -> SM b) -> SM b
bindSM (SM m) k = SM $ \s -> case m s of
Nothing -> Nothing
Just (x :*: s') ->
case k x of
SM y -> y s'
returnSM :: a -> SM a
returnSM x = SM (\s -> Just (x :*: s))
failSM :: String -> SM a
failSM _ = SM (\_ -> Nothing)
instance Monad SM where
(>>=) = bindSM
return = returnSM
fail = failSM
instance ParserM SM where
work f = SM f
maybeWork f = SM $ \s -> case f s of
Just (x :*: s') -> Just (Just x :*: s')
Nothing -> Just (Nothing :*: s)
peekInput = SM $ \s -> Just (s :*: s)
parse = parseStrictly
instance MonadPlus SM where
mzero = failSM ""
mplus (SM a) (SM b) = SM $ \s ->
case a s of
Nothing -> b s
r -> r
instance Functor SM where
fmap f m = m `bindSM` (returnSM . f)
instance Applicative SM where
pure = returnSM
a <*> b =
a `bindSM` \c ->
b `bindSM` \d ->
returnSM (c d)
instance Alternative SM where
empty = failSM ""
(<|>) = mplus