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,
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)
| Choice (Parser a s r) (Parser a s r)
| Delay (Parser a s r) (s -> Parser a s r)
feed :: Monoid s => s -> Parser a s r -> Parser a 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 (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 p) = prepend r (feedEof p)
feedEof (Choice p1 p2) = feedEof p1 <||> feedEof p2
feedEof (Delay e _) = 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 f p) = (map applyToFst results', fmap (fmap infallible . applyToFst) rest)
where (results', rest) = results p
applyToFst (x, y) = (f x, y)
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 (resultPart (mappend r1) p1') (resultPart (mappend r2) p2'))
results p = ([], Just (mempty, p))
completeResults :: Parser a 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 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 f p) = (f mempty, infallible p)
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 f (ResultPart r p) = fmap f (prepend r p)
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 p1 <* p2 | isInfallible p2 = resultPart r (p1 <* p2)
p1 <* p2 = apply (<* p2) p1
instance Monoid s => Monad (Parser a s) where
return = Result mempty
Result t r >>= f = feed t (f r)
ResultPart r p >>= f = prepend r p >>= f
p >>= f = apply (>>= f) p
Result t _ >> p = feed t p
ResultPart _ p1 >> p2 = p1 >> p2
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 p1) p2 = resultPart r (appendIncremental p1 p2)
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 (ResultPart r p1) p2 = prepend r (append p1 p2)
append p1 p2 = apply (`append` p2) p1
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
instance (Monoid s, Monoid r) => Monoid (Parser a s r) where
mempty = return mempty
mappend = (><)
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 infallible p' else p'
where p' = Delay (feedEof p1 <<|> feedEof p2) (\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 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 (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 f (ResultPart r p) = resultPart (mappend $ f (r mempty)) (mapIncremental f p)
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 p') = resultPart r (lookAheadInto t p')
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 :: (r -> r) -> Parser a s r -> Parser a s r
resultPart _ Failure = Failure
resultPart f (Result t r) = Result t (f r)
resultPart f (ResultPart g p) = ResultPart (f . g) p
resultPart f p = ResultPart f p
infallible :: Parser a s r -> Parser a s r
infallible Failure = error "Internal contradiction"
infallible p | isInfallible p = p
| otherwise = ResultPart id p
isInfallible :: Parser a s r -> Bool
isInfallible Result{} = True
isInfallible ResultPart{} = True
isInfallible (Choice p _) = isInfallible p
isInfallible _ = False
prepend :: Monoid s => (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 p) = ResultPart (r1 . r2) p
prepend r (Choice p1 p2) = Choice (prepend r p1) (prepend r p2)
prepend r (Delay e f) = Delay (feedEof $ 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 (feedEof $ g e) (g . f)
apply f p = Delay (feedEof $ 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 f (ResultPart r p) = ResultPart r (f p)
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 = fst . takeWhiles
takeWhile1 :: (FactorialMonoid s, MonoidNull s) => (s -> Bool) -> Parser a s s
takeWhile1 = snd . takeWhiles
takeWhiles :: (FactorialMonoid s, MonoidNull s) => (s -> Bool) -> (Parser a s s, Parser a s s)
takeWhiles p = (while, while1)
where while = while1 <<|> return mempty
while1 = more f
f s | mnull s = while1
f s = let (prefix, suffix) = mspan p s
in if mnull prefix then Failure
else if mnull suffix then resultPart (mappend prefix) while
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 = infallible acceptAll'
where acceptAll' = Delay mempty (\s-> resultPart (mappend s) acceptAll')
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 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)
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 f p1 `andThen` p2 | isInfallible p2 = resultPart (\(r1, r2)-> (f r1, r2)) (p1 `andThen` p2)
p1 `andThen` p2 = apply (`andThen` p2) p1