module Text.ParserCombinators.Incremental (
Parser,
feed, feedEof, results, completeResults, resultPrefix,
eof, anyToken, token, satisfy, acceptAll, string, takeWhile, takeWhile1,
count, skip, option, many0, many1, manyTill,
mapIncremental, (><), (<<|>), lookAhead, notFollowedBy, and, andThen,
showWith
)
where
import Prelude hiding (and, foldl, takeWhile)
import Control.Applicative (Applicative (pure, (<*>), (*>), (<*)), Alternative (empty, (<|>), some, many),
optional, liftA2)
import Control.Monad (Functor (fmap), Monad (return, (>>=), (>>)), MonadPlus (mzero, mplus), ap, liftM2)
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid, mempty, mappend)
import Data.Monoid.Cancellative (LeftCancellativeMonoid (mstripPrefix))
import Data.Monoid.Factorial (FactorialMonoid (splitPrimePrefix, mfoldr), mspan)
import Data.Monoid.Null (MonoidNull(mnull))
import Data.Foldable (Foldable, foldl, toList)
data Parser s r = Failure
| Result s r
| ResultPart (r -> r) (Parser s r)
| Choice (Parser s r) (Parser s r)
| CommitedLeftChoice (Parser s r) (Parser s r)
| More (s -> Parser s r)
| forall r'. Apply (Parser s r' -> Parser s r) (Parser s r')
| forall r'. ApplyInput (s -> Parser s r' -> Parser s r) (Parser s r')
feed :: Monoid s => s -> Parser s r -> Parser s r
feed _ Failure = Failure
feed s (Result t r) = Result (mappend t s) r
feed s (ResultPart r p) = resultPart r (feed s p)
feed s (Choice p1 p2) = feed s p1 <|> feed s p2
feed s (CommitedLeftChoice p1 p2) = feed s p1 <<|> feed s p2
feed s p@(More f) = f s
feed s (Apply f p) = f (feed s p)
feed s (ApplyInput f p) = f s (feed s p)
feedEof :: Monoid s => Parser s r -> Parser s r
feedEof Failure = Failure
feedEof p@Result{} = p
feedEof (ResultPart r p) = prepend r (feedEof p)
where prepend r (Result t r') = Result t (r r')
prepend r (Choice p1 p2) = prepend r p1 <|> prepend r p2
prepend r Failure = Failure
feedEof (Choice p1 p2) = feedEof p1 <|> feedEof p2
feedEof (CommitedLeftChoice p1 p2) = feedEof p1 <<|> feedEof p2
feedEof More{} = Failure
feedEof (Apply f p) = feedEof (f $ feedEof p)
feedEof (ApplyInput f p) = feedEof (f mempty $ feedEof p)
results :: Monoid r => Parser s r -> ([(r, s)], Maybe (r, Parser s r))
results Failure = ([], Nothing)
results (Result t r) = ([(r, t)], Nothing)
results (ResultPart f p) = (map prepend results', fmap prepend rest)
where (results', rest) = results p
prepend (x, y) = (f x, y)
results (Choice p1@Result{} p2) = (results1 ++ results2, combine rest1 rest2)
where (results1, rest1) = results p1
(results2, rest2) = results p2
combine Nothing rest2 = rest2
combine rest1 Nothing = rest1
combine (Just (r1, p1)) (Just (r2, p2)) =
Just (mempty, Choice (ResultPart (mappend r1) p1) (ResultPart (mappend r2) p2))
results p = ([], Just (mempty, p))
completeResults :: Parser s r -> [(r, s)]
completeResults (Result t r) = [(r, t)]
completeResults (ResultPart f p) = map (\(r, t)-> (f r, t)) (completeResults p)
completeResults (Choice p1@Result{} p2) = completeResults p1 ++ completeResults p2
completeResults _ = []
hasResult :: Parser s r -> Bool
hasResult Result{} = True
hasResult (ResultPart _ p) = hasResult p
hasResult (Choice Result{} _) = True
hasResult (CommitedLeftChoice _ p) = hasResult p
hasResult _ = False
resultPrefix :: Monoid r => Parser s r -> (r, Parser s r)
resultPrefix (Result t r) = (r, Result t mempty)
resultPrefix (ResultPart f p) = (f r, p')
where (r, p') = resultPrefix p
resultPrefix p = (mempty, p)
lookAhead :: Monoid s => Parser s r -> Parser s r
lookAhead p = lookAheadInto mempty p
notFollowedBy :: (Monoid s, Monoid r) => Parser s r' -> Parser s r
notFollowedBy = lookAheadNotInto mempty
lookAheadInto :: Monoid s => s -> Parser s r -> Parser s r
lookAheadInto t Failure = Failure
lookAheadInto t (Result _ r) = Result t r
lookAheadInto t (ResultPart r p) = resultPart r (lookAheadInto t p)
lookAheadInto t (More f) = More (\s-> lookAheadInto (mappend t s) (f s))
lookAheadInto t (Choice p1 p2) = lookAheadInto t p1 <|> lookAheadInto t p2
lookAheadInto t p = ApplyInput (\t' p'-> lookAheadInto (mappend t t') p') p
lookAheadNotInto :: (Monoid s, Monoid r) => s -> Parser s r' -> Parser s r
lookAheadNotInto t Failure = Result t mempty
lookAheadNotInto t (Result _ r) = Failure
lookAheadNotInto t (Choice (Result _ r) _) = Failure
lookAheadNotInto t (ResultPart r p) = lookAheadNotInto t p
lookAheadNotInto t p = ApplyInput (\t' p'-> lookAheadNotInto (mappend t t') p') p
resultPart :: (r -> r) -> Parser s r -> Parser s r
resultPart _ Failure = Failure
resultPart f (Result t r) = Result t (f r)
resultPart f (Choice (Result t r) p) = Choice (Result t (f r)) (resultPart f p)
resultPart f (ResultPart g p) = ResultPart (f . g) p
resultPart f p = ResultPart f p
instance Monoid s => Functor (Parser s) where
fmap f Failure = Failure
fmap f (Result t r) = Result t (f r)
fmap f (Choice p1 p2) = fmap f p1 <|> fmap f p2
fmap f (CommitedLeftChoice p1 p2) = fmap f p1 <<|> fmap f p2
fmap f (More g) = More (fmap f . g)
fmap f p = Apply (fmap f) p
instance Monoid s => Applicative (Parser s) where
pure = Result mempty
(<*>) = ap
(*>) = (>>)
Failure <* _ = Failure
Result t r <* p = feed t p *> pure r
ResultPart r p1 <* p2 = ResultPart r (p1 <* p2)
Choice p1a p1b <* p2 = (p1a <* p2) <|> (p1b <* p2)
More f <* p = More (\x-> f x <* p)
p1 <* p2 = Apply (<* p2) p1
instance Monoid s => Alternative (Parser s) where
empty = Failure
Failure <|> p = p
p <|> Failure = p
More f <|> More g = More (\x-> f x <|> g x)
p1@Result{} <|> p2 = Choice p1 p2
Choice p1a@Result{} p1b <|> p2 = Choice p1a (p1b <|> p2)
p1 <|> p2@Result{} = Choice p2 p1
p1 <|> Choice p2a@Result{} p2b = Choice p2a (p1 <|> p2b)
p1 <|> p2 = Choice p1 p2
instance Monoid s => Monad (Parser s) where
return = Result mempty
Failure >>= _ = Failure
Result t r >>= f = feed t (f r)
Choice p1 p2 >>= f = (p1 >>= f) <|> (p2 >>= f)
More f >>= g = More (\x-> f x >>= g)
p >>= f = Apply (>>= f) p
Failure >> _ = Failure
Result t _ >> p = feed t p
ResultPart r p1 >> p2 = p1 >> p2
Choice p1a p1b >> p2 = (p1a >> p2) <|> (p1b >> p2)
More f >> p = More (\x-> f x >> p)
p1 >> p2 = Apply (>> p2) p1
instance Monoid s => MonadPlus (Parser s) where
mzero = Failure
mplus = (<<|>)
instance (Monoid s, Monoid r) => Monoid (Parser s r) where
mempty = return mempty
mappend = (><)
showWith :: (Monoid s, Monoid r, Show s) => ((s -> Parser s r) -> String) -> (r -> String) -> Parser s r -> String
showWith sm sr Failure = "Failure"
showWith sm sr (Result t r) = "(Result (" ++ shows t ("++) " ++ sr r ++ ")")
showWith sm sr (ResultPart f p) = "(ResultPart (mappend " ++ sr (f mempty) ++ ") " ++ showWith sm sr p ++ ")"
showWith sm sr (Choice p1 p2) = "(Choice " ++ showWith sm sr p1 ++ " " ++ showWith sm sr p2 ++ ")"
showWith sm sr (CommitedLeftChoice p1 p2) =
"(CommitedLeftChoice " ++ showWith sm sr p1 ++ " " ++ showWith sm sr p2 ++ ")"
showWith sm sr (More f) = "(More $ " ++ sm f ++ ")"
showWith sm sr (Apply f p) = "Apply"
showWith sm sr (ApplyInput f p) = "ApplyInput"
mapIncremental :: (Monoid s, Monoid a, Monoid b) => (a -> b) -> Parser s a -> Parser s b
mapIncremental f Failure = Failure
mapIncremental f (Result t r) = Result t (f r)
mapIncremental f (ResultPart r p) = ResultPart (f (r mempty) `mappend`) (mapIncremental f p)
mapIncremental f (Choice p1 p2) = mapIncremental f p1 <|> mapIncremental f p2
mapIncremental f (CommitedLeftChoice p1 p2) = mapIncremental f p1 <<|> mapIncremental f p2
mapIncremental f (More g) = More (mapIncremental f . g)
mapIncremental f p = Apply (mapIncremental f) p
infixl 3 <<|>
(<<|>) :: Parser s r -> Parser s r -> Parser s r
Failure <<|> p = p
p <<|> Failure = p
p <<|> _ | hasResult p = p
More f <<|> More g = More (\x-> f x <<|> g x)
p1 <<|> p2 = CommitedLeftChoice p1 p2
infixl 5 ><
(><) :: (Monoid s, Monoid r) => Parser s r -> Parser s r -> Parser s r
Failure >< _ = Failure
Result t r >< p = resultPart (mappend r) (feed t p)
ResultPart r p1 >< p2 = resultPart r (p1 >< p2)
Choice p1a p1b >< p2 = (p1a >< p2) <|> (p1b >< p2)
More f >< p = More (\x-> f x >< p)
p1 >< p2 = Apply (>< p2) p1
eof :: (MonoidNull s, Monoid r) => Parser s r
eof = notFollowedBy nonEmptyInput
where nonEmptyInput = More $ \s-> if mnull s then nonEmptyInput else return s
anyToken :: FactorialMonoid s => Parser 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 s s
token x = satisfy (== x)
satisfy :: FactorialMonoid s => (s -> Bool) -> Parser s s
satisfy pred = p
where p = More f
f s = case splitPrimePrefix s
of Just (first, rest) -> if pred first then Result rest first else Failure
Nothing -> p
string :: (LeftCancellativeMonoid s, MonoidNull s) => s -> Parser 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 s s
takeWhile = fst . takeWhiles
takeWhile1 :: (FactorialMonoid s, MonoidNull s) => (s -> Bool) -> Parser s s
takeWhile1 = snd . takeWhiles
takeWhiles p = (takeWhile, takeWhile1)
where takeWhile = CommitedLeftChoice takeWhile1 (return mempty)
takeWhile1 = More f
f s | mnull s = takeWhile1
f s = let (prefix, suffix) = mspan p s
in if mnull prefix then Failure
else if mnull suffix then resultPart (mappend prefix) takeWhile
else Result suffix prefix
count :: (Monoid s, Monoid r) => Int -> Parser s r -> Parser s r
count n p | n > 0 = p >< count (pred n) p
| otherwise = mempty
option :: (Monoid s, Monoid r) => Parser s r -> Parser s r
option p = p <|> return mempty
skip :: (Monoid s, Monoid r) => Parser s r' -> Parser s r
skip p = p >> mempty
many0 :: (Monoid s, Monoid r) => Parser s r -> Parser s r
many0 = fst . manies
many1 :: (Monoid s, Monoid r) => Parser s r -> Parser s r
many1 = snd . manies
manies p = (many0, many1)
where many0 = CommitedLeftChoice many1 (return mempty)
many1 = More (\s-> feed s (p >< many0))
manyTill :: (Monoid s, Monoid r) => Parser s r -> Parser s r' -> Parser s r
manyTill next end = t
where t = skip end <<|> (next >< t)
acceptAll :: Monoid s => Parser s s
acceptAll = CommitedLeftChoice (More $ \s-> resultPart (mappend s) acceptAll) (return mempty)
and :: (Monoid s, Monoid r1, Monoid r2) => Parser s r1 -> Parser s r2 -> Parser 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 f p1 `and` p2 = fmap (\(r1, r2)-> (f r1, r2)) (p1 `and` p2)
p1 `and` ResultPart f p2 = fmap (\(r1, r2)-> (r1, f r2)) (p1 `and` p2)
Choice p1a p1b `and` p2 = (p1a `and` p2) <|> (p1b `and` p2)
p1 `and` Choice p2a p2b = (p1 `and` p2a) <|> (p1 `and` p2b)
More f `and` p = More (\x-> f x `and` feed x p)
p `and` More f = More (\x-> feed x p `and` f x)
p1 `and` p2 = (feedEof p1 `and` feedEof p2) <|> More (\x-> feed x p1 `and` feed x p2)
andThen :: (Monoid s, Monoid r1, Monoid r2) => Parser s r1 -> Parser s r2 -> Parser s (r1, r2)
Failure `andThen` _ = Failure
Result t r `andThen` p = resultPart (mappend (r, mempty)) (feed t (fmap ((,) mempty) p))
ResultPart f p1 `andThen` p2 = resultPart (\(r1, r2)-> (f r1, r2)) (p1 `andThen` p2)
Choice p1a p1b `andThen` p2 = (p1a `andThen` p2) <|> (p1b `andThen` p2)
More f `andThen` p = More (\x-> f x `andThen` p)
p1 `andThen` p2 = Apply (`andThen` p2) p1