module Text.ParserCombinators.Incremental (
Parser,
feed, feedEof, results, completeResults, resultPrefix,
failure, more, eof, anyToken, token, satisfy, acceptAll, string, takeWhile, takeWhile1,
count, skip, moptional, concatMany, concatSome, manyTill,
mapType, mapIncremental, (<||>), (<<|>), (><), lookAhead, notFollowedBy, and, andThen,
isInfallible, showWith
)
where
import Prelude hiding (and, takeWhile)
import Control.Applicative (Applicative (pure, (<*>), (*>), (<*)), Alternative ((<|>)))
import Control.Applicative.Monoid(MonoidApplicative(..), MonoidAlternative(..))
import Control.Monad (ap)
import Data.Monoid (Monoid, mempty, mappend, (<>))
import Data.Monoid.Cancellative (LeftCancellativeMonoid (mstripPrefix))
import Data.Monoid.Factorial (FactorialMonoid (splitPrimePrefix), mspan)
import Data.Monoid.Null (MonoidNull(mnull))
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 Failure = ([], Nothing)
results (Result t r) = ([(r, t)], Nothing)
results (ResultPart r e f) = ([], Just (r mempty, ResultPart id e f))
results (Choice p1 p2) | isInfallible p1 = (results1 ++ results2, combine rest1 rest2)
where (results1, rest1) = results p1
(results2, rest2) = results p2
combine Nothing rest = rest
combine rest Nothing = rest
combine (Just (r1, p1')) (Just (r2, p2')) = Just (mempty, Choice (prepend (r1 <>) p1') (prepend (r2 <>) p2'))
results p = ([], Just (mempty, 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 mnull 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
string :: (LeftCancellativeMonoid s, MonoidNull s) => s -> Parser a s s
string x | mnull x = mempty
string x = more (\y-> case (mstripPrefix x y, mstripPrefix 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) = mspan pred s
in if mnull 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 | mnull s = takeWhile1 pred
| otherwise = let (prefix, suffix) = mspan pred s
in if mnull prefix then Failure
else if mnull suffix then resultPart (mappend prefix) (takeWhile pred)
else Result suffix prefix
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