module Text.ParserCombinators.Incremental (
Parser,
feed, feedEof, inspect, results, completeResults, resultPrefix,
failure, more, eof, anyToken, token, satisfy, acceptAll, string, takeWhile, takeWhile1,
satisfyChar, takeCharsWhile, takeCharsWhile1,
count, skip, moptional, concatMany, concatSome, manyTill,
mapType, mapIncremental, (<||>), (<<|>), (><), lookAhead, notFollowedBy, and, andThen,
isInfallible, showWith
)
where
import Prelude hiding (and, null, span, takeWhile)
import Control.Applicative (Applicative (pure, (<*>), (*>), (<*)), Alternative ((<|>)))
import Control.Applicative.Monoid(MonoidApplicative(..), MonoidAlternative(..))
import Control.Monad (ap)
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid, mempty, mappend, (<>))
import Data.Monoid.Cancellative (LeftReductiveMonoid (stripPrefix))
import Data.Monoid.Factorial (FactorialMonoid (splitPrimePrefix), span)
import Data.Monoid.Null (MonoidNull(null))
import Data.Monoid.Textual (TextualMonoid)
import qualified Data.Monoid.Textual as Textual
data Parser a s r = Failure
| Result s r
| ResultPart (r -> r) (Parser a s r) (s -> Parser a s r)
| Delay (Parser a s r) (s -> Parser a s r)
| Choice (Parser a s r) (Parser a s r)
feed :: Monoid s => s -> Parser a s r -> Parser a s r
feed s Failure = s `seq` Failure
feed s (Result t r) = Result (mappend t s) r
feed s (ResultPart r _ f) = resultPart r (f s)
feed s (Choice p1 p2) = feed s p1 <||> feed s p2
feed s (Delay _ f) = f s
feedEof :: Monoid s => Parser a s r -> Parser a s r
feedEof Failure = Failure
feedEof p@Result{} = p
feedEof (ResultPart r e _) = prepend r (feedEof e)
feedEof (Choice p1 p2) = feedEof p1 <||> feedEof p2
feedEof (Delay e _) = feedEof e
results :: Monoid r => Parser a s r -> ([(r, s)], Maybe (r, Parser a s r))
results = fmap (fmap (\(mf, p)-> (fromMaybe id mf mempty, p))) . inspect
inspect :: Parser a s r -> ([(r, s)], Maybe (Maybe (r -> r), Parser a s r))
inspect Failure = ([], Nothing)
inspect (Result t r) = ([(r, t)], Nothing)
inspect (ResultPart r e f) = ([], Just (Just r, ResultPart id e f))
inspect (Choice p1 p2) | isInfallible p1 = (results1 ++ results2, combine rest1 rest2)
where (results1, rest1) = inspect p1
(results2, rest2) = inspect p2
combine Nothing rest = rest
combine rest Nothing = rest
combine (Just (r1, p1')) (Just (r2, p2')) =
Just (Just id, Choice (prepend (fromMaybe id r1) p1') (prepend (fromMaybe id r2) p2'))
inspect p = ([], Just (Nothing, p))
completeResults :: Parser a s r -> [(r, s)]
completeResults (Result t r) = [(r, t)]
completeResults (ResultPart r e f) = map (\(r', t)-> (r r', t)) (completeResults e)
completeResults (Choice p1 p2) | isInfallible p1 = completeResults p1 ++ completeResults p2
completeResults _ = []
resultPrefix :: Monoid r => Parser a s r -> (r, Parser a s r)
resultPrefix (Result t r) = (r, Result t mempty)
resultPrefix (ResultPart r e f) = (r mempty, ResultPart id e f)
resultPrefix p = (mempty, p)
failure :: Parser a s r
failure = Failure
instance Monoid s => Functor (Parser a s) where
fmap f (Result t r) = Result t (f r)
fmap g (ResultPart r e f) = ResultPart id (fmap g $ prepend r $ feedEof e) (fmap g . prepend r . f)
fmap f p = apply (fmap f) p
instance Monoid s => Applicative (Parser a s) where
pure = Result mempty
(<*>) = ap
(*>) = (>>)
Result t r <* p = feed t p *> pure r
ResultPart r e f <* p | isInfallible p = ResultPart r (e <* p) ((<* p) . f)
p1 <* p2 = apply (<* p2) p1
instance Monoid s => Monad (Parser a s) where
return = Result mempty
Result t r >>= f = feed t (f r)
p >>= f = apply (>>= f) p
Result t _ >> p = feed t p
ResultPart _ e f >> p | isInfallible p = ResultPart id (e >> p) ((>> p) . f)
| otherwise = Delay (e >> p) ((>> p) . f)
p1 >> p2 = apply (>> p2) p1
instance Monoid s => MonoidApplicative (Parser a s) where
_ >< Failure = Failure
p1 >< p2 | isInfallible p2 = appendIncremental p1 p2
| otherwise = append p1 p2
appendIncremental :: (Monoid s, Monoid r) => Parser a s r -> Parser a s r -> Parser a s r
appendIncremental (Result t r) p = resultPart (mappend r) (feed t p)
appendIncremental (ResultPart r e f) p2 = ResultPart r (appendIncremental e p2) (flip appendIncremental p2 . f)
appendIncremental p1 p2 = apply (`appendIncremental` p2) p1
append :: (Monoid s, Monoid r) => Parser a s r -> Parser a s r -> Parser a s r
append (Result t r) p2 = prepend (mappend r) (feed t p2)
append p1 p2 = apply (`append` p2) p1
instance (Monoid s, Monoid r) => Monoid (Parser a s r) where
mempty = return mempty
mappend = (><)
instance (Alternative (Parser a s), Monoid s) => MonoidAlternative (Parser a s) where
moptional p = p <|> mempty
concatMany = fst . manies
concatSome = snd . manies
manies :: (Alternative (Parser a s), Monoid s, Monoid r) => Parser a s r -> (Parser a s r, Parser a s r)
manies p = (many, some)
where many = some <|> mempty
some = appendIncremental p many
infixl 3 <||>
infixl 3 <<|>
(<||>) :: Parser a s r -> Parser a s r -> Parser a s r
Delay e1 f1 <||> Delay e2 f2 = Delay (e1 <||> e2) (\s-> f1 s <||> f2 s)
Failure <||> p = p
p <||> Failure = p
p1@Result{} <||> p2 = Choice p1 p2
p1@ResultPart{} <||> p2 = Choice p1 p2
Choice p1a p1b <||> p2 | isInfallible p1a = Choice p1a (p1b <||> p2)
p1 <||> p2@Result{} = Choice p2 p1
p1 <||> p2@ResultPart{} = Choice p2 p1
p1 <||> Choice p2a p2b | isInfallible p2a = Choice p2a (p1 <||> p2b)
p1 <||> p2 = Choice p1 p2
(<<|>) :: Monoid s => Parser a s r -> Parser a s r -> Parser a s r
Failure <<|> p = p
p <<|> _ | isInfallible p = p
p <<|> Failure = p
p1 <<|> p2 = if isInfallible p2 then ResultPart id e f else Delay e f
where e = feedEof p1 <<|> feedEof p2
f s = feed s p1 <<|> feed s p2
showWith :: (Monoid s, Monoid r, Show s) => ((s -> Parser a s r) -> String) -> (r -> String) -> Parser a s r -> String
showWith _ _ Failure = "Failure"
showWith _ sr (Result t r) = "(Result " ++ shows t (" " ++ sr r ++ ")")
showWith sm sr (ResultPart r e f) =
"(ResultPart (mappend " ++ sr (r mempty) ++ ") " ++ showWith sm sr e ++ " " ++ sm f ++ ")"
showWith sm sr (Choice p1 p2) = "(Choice " ++ showWith sm sr p1 ++ " " ++ showWith sm sr p2 ++ ")"
showWith sm sr (Delay e f) = "(Delay " ++ showWith sm sr e ++ " " ++ sm f ++ ")"
mapIncremental :: (Monoid s, Monoid a, Monoid b) => (a -> b) -> Parser p s a -> Parser p s b
mapIncremental f (Result t r) = Result t (f r)
mapIncremental g (ResultPart r e f) =
ResultPart (mappend $ g $ r mempty) (mapIncremental g e) (mapIncremental g . f)
mapIncremental f p = apply (mapIncremental f) p
lookAhead :: Monoid s => Parser a s r -> Parser a s r
lookAhead p = lookAheadInto mempty p
where lookAheadInto :: Monoid s => s -> Parser a s r -> Parser a s r
lookAheadInto _ Failure = Failure
lookAheadInto t (Result _ r) = Result t r
lookAheadInto t (ResultPart r e f) = ResultPart r (lookAheadInto t e) (\s-> lookAheadInto (mappend t s) (f s))
lookAheadInto t (Choice p1 p2) = lookAheadInto t p1 <||> lookAheadInto t p2
lookAheadInto t (Delay e f) = Delay (lookAheadInto t e) (\s-> lookAheadInto (mappend t s) (f s))
notFollowedBy :: (Monoid s, Monoid r) => Parser a s r' -> Parser a s r
notFollowedBy = lookAheadNotInto mempty
where lookAheadNotInto :: (Monoid s, Monoid r) => s -> Parser a s r' -> Parser a s r
lookAheadNotInto t Failure = Result t mempty
lookAheadNotInto t (Delay e f) = Delay (lookAheadNotInto t e) (\s-> lookAheadNotInto (mappend t s) (f s))
lookAheadNotInto t p | isInfallible p = Failure
| otherwise = Delay (lookAheadNotInto t $ feedEof p)
(\s-> lookAheadNotInto (mappend t s) (feed s p))
resultPart :: Monoid s => (r -> r) -> Parser a s r -> Parser a s r
resultPart _ Failure = error "Internal contradiction"
resultPart f (Result t r) = Result t (f r)
resultPart r1 (ResultPart r2 e f) = ResultPart (r1 . r2) e f
resultPart r p = ResultPart r (feedEof p) (flip feed p)
isInfallible :: Parser a s r -> Bool
isInfallible Result{} = True
isInfallible ResultPart{} = True
isInfallible (Choice p _) = isInfallible p
isInfallible _ = False
prepend :: (r -> r) -> Parser a s r -> Parser a s r
prepend _ Failure = Failure
prepend r1 (Result t r2) = Result t (r1 r2)
prepend r1 (ResultPart r2 e f) = ResultPart (r1 . r2) e f
prepend r (Choice p1 p2) = Choice (prepend r p1) (prepend r p2)
prepend r (Delay e f) = Delay (prepend r e) (prepend r . f)
apply :: Monoid s => (Parser a s r -> Parser a s r') -> Parser a s r -> Parser a s r'
apply _ Failure = Failure
apply f (Choice p1 p2) = f p1 <||> f p2
apply g (Delay e f) = Delay (g e) (g . f)
apply f p = Delay (f $ feedEof p) (\s-> f $ feed s p)
mapType :: (Parser a s r -> Parser b s r) -> Parser a s r -> Parser b s r
mapType _ Failure = Failure
mapType _ (Result s r) = Result s r
mapType g (ResultPart r e f) = ResultPart r (g e) (g . f)
mapType f (Choice p1 p2) = Choice (f p1) (f p2)
mapType g (Delay e f) = Delay (g e) (g . f)
more :: (s -> Parser a s r) -> Parser a s r
more = Delay Failure
eof :: (MonoidNull s, Monoid r) => Parser a s r
eof = Delay mempty (\s-> if null s then eof else Failure)
anyToken :: FactorialMonoid s => Parser a s s
anyToken = more f
where f s = case splitPrimePrefix s
of Just (first, rest) -> Result rest first
Nothing -> anyToken
token :: (Eq s, FactorialMonoid s) => s -> Parser a s s
token x = satisfy (== x)
satisfy :: FactorialMonoid s => (s -> Bool) -> Parser a s s
satisfy predicate = p
where p = more f
f s = case splitPrimePrefix s
of Just (first, rest) -> if predicate first then Result rest first else Failure
Nothing -> p
satisfyChar :: TextualMonoid s => (Char -> Bool) -> Parser a s s
satisfyChar predicate = p
where p = more f
f s = case splitPrimePrefix s
of Just (first, rest) -> case Textual.characterPrefix first
of Just c -> if predicate c then Result rest first else Failure
Nothing -> if null rest then p else Failure
Nothing -> p
string :: (LeftReductiveMonoid s, MonoidNull s) => s -> Parser a s s
string x | null x = mempty
string x = more (\y-> case (stripPrefix x y, stripPrefix y x)
of (Just y', _) -> Result y' x
(Nothing, Nothing) -> Failure
(Nothing, Just x') -> string x' >> return x)
takeWhile :: (FactorialMonoid s, MonoidNull s) => (s -> Bool) -> Parser a s s
takeWhile pred = while
where while = ResultPart id (return mempty) f
f s = let (prefix, suffix) = span pred s
in if null suffix then resultPart (mappend prefix) while
else Result suffix prefix
takeWhile1 :: (FactorialMonoid s, MonoidNull s) => (s -> Bool) -> Parser a s s
takeWhile1 pred = more f
where f s | null s = takeWhile1 pred
| otherwise = let (prefix, suffix) = span pred s
in if null prefix then Failure
else if null suffix then resultPart (mappend prefix) (takeWhile pred)
else Result suffix prefix
takeCharsWhile :: (TextualMonoid s, MonoidNull s) => (Char -> Bool) -> Parser a s s
takeCharsWhile pred = while
where while = ResultPart id (return mempty) f
f s = let (prefix, suffix) = Textual.span (const False) pred s
in if null suffix then resultPart (mappend prefix) while
else let (prefix', suffix') = Textual.span (const True) (const False) suffix
in if null prefix' then Result suffix prefix
else resultPart (mappend prefix . mappend prefix') (f suffix')
takeCharsWhile1 :: (TextualMonoid s, MonoidNull s) => (Char -> Bool) -> Parser a s s
takeCharsWhile1 pred = more f
where f s | null s = takeCharsWhile1 pred
| otherwise = let (prefix, suffix) = Textual.span (const False) pred s
(prefix', suffix') = Textual.span (const True) (const False) suffix
in if null prefix
then if null prefix' then Failure
else prepend (mappend prefix') (f suffix')
else if null suffix then resultPart (mappend prefix) (takeCharsWhile pred)
else if null prefix' then Result suffix prefix
else resultPart (mappend prefix . mappend prefix')
(feed suffix' $ takeCharsWhile pred)
count :: (Monoid s, Monoid r) => Int -> Parser a s r -> Parser a s r
count n p | n > 0 = p >< count (pred n) p
| otherwise = mempty
skip :: (Monoid s, Monoid r) => Parser a s r' -> Parser a s r
skip p = p *> mempty
manyTill :: (Alternative (Parser a s), Monoid s, Monoid r) => Parser a s r -> Parser a s r' -> Parser a s r
manyTill next end = t
where t = skip end <|> mappend next t
acceptAll :: Monoid s => Parser a s s
acceptAll = ResultPart id mempty f
where f s = ResultPart (mappend s) mempty f
and :: (Monoid s, Monoid r1, Monoid r2) => Parser a s r1 -> Parser a s r2 -> Parser a s (r1, r2)
Failure `and` _ = Failure
_ `and` Failure = Failure
p `and` Result _ r = fmap (\x-> (x, r)) (feedEof p)
Result _ r `and` p = fmap (\x-> (r, x)) (feedEof p)
ResultPart r e f `and` p | isInfallible p =
ResultPart (\(r1, r2)-> (r r1, r2)) (e `and` feedEof p) (\s-> f s `and` feed s p)
p `and` ResultPart r e f | isInfallible p =
ResultPart (\(r1, r2)-> (r1, r r2)) (feedEof p `and` e) (\s-> feed s p `and` f s)
Choice p1a p1b `and` p2 = (p1a `and` p2) <||> (p1b `and` p2)
p1 `and` Choice p2a p2b = (p1 `and` p2a) <||> (p1 `and` p2b)
p1 `and` p2 = Delay (feedEof p1 `and` feedEof p2) (\s-> feed s p1 `and` feed s p2)
andThen :: (Monoid s, Monoid r1, Monoid r2) => Parser a s r1 -> Parser a s r2 -> Parser a s (r1, r2)
Result t r `andThen` p | isInfallible p = resultPart (mappend (r, mempty)) (feed t (fmap ((,) mempty) p))
ResultPart r e f `andThen` p | isInfallible p = ResultPart (\(r1, r2)-> (r r1, r2)) (e `andThen` p) ((`andThen` p) . f)
p1 `andThen` p2 = apply (`andThen` p2) p1