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, defaultMany, defaultSome
)
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 t s r = Failure String
| Result s r
| ResultPart (r -> r) (Parser t s r) (s -> Parser t s r)
| Delay (Parser t s r) (s -> Parser t s r)
| Choice (Parser t s r) (Parser t s r)
feed :: Monoid s => s -> Parser t s r -> Parser t s r
feed s p@Failure{} = s `seq` p
feed s (Result s' r) = Result (mappend s' 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 t s r -> Parser t s r
feedEof p@Failure{} = p
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 t s r -> ([(r, s)], Maybe (r, Parser t s r))
results = fmap (fmap (\(mf, p)-> (fromMaybe id mf mempty, p))) . inspect
inspect :: Parser t s r -> ([(r, s)], Maybe (Maybe (r -> r), Parser t s r))
inspect Failure{} = ([], Nothing)
inspect (Result s r) = ([(r, s)], 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 t s r -> [(r, s)]
completeResults (Result s r) = [(r, s)]
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 t s r -> (r, Parser t s r)
resultPrefix (Result s r) = (r, Result s mempty)
resultPrefix (ResultPart r e f) = (r mempty, ResultPart id e f)
resultPrefix p = (mempty, p)
failure :: Parser t s r
failure = Failure "failure"
infix 0 <?>
(<?>) :: Monoid s => Parser t s r -> String -> Parser t s r
Failure{} <?> msg = Failure msg
p@Result{} <?> _ = p
p@ResultPart{} <?> _ = p
p <?> msg = apply (<?> msg) p
instance Monoid s => Functor (Parser t s) where
fmap f (Result s r) = Result s (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 t s) where
pure = Result mempty
Result s r <*> p = r <$> feed s p
p1 <*> p2 = apply (<*> p2) p1
Result s _ *> p = feed s p
ResultPart _ e f *> p | isInfallible p = ResultPart id (e *> p) ((*> p) . f)
| otherwise = Delay (e *> p) ((*> p) . f)
p1 *> p2 = apply (*> p2) p1
Result s r <* p = feed s 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 t s) where
return = pure
Result s r >>= f = feed s (f r)
p >>= f = apply (>>= f) p
(>>) = (*>)
instance Monoid s => MonoidApplicative (Parser t s) where
Result s r +<*> p = resultPart r (feed s p)
p1 +<*> p2 = apply (+<*> p2) p1
_ >< p@Failure{} = p
p1 >< p2 | isInfallible p2 = appendIncremental p1 p2
| otherwise = append p1 p2
appendIncremental :: (Monoid s, Monoid r) => Parser t s r -> Parser t s r -> Parser t s r
appendIncremental (Result s r) p = resultPart (mappend r) (feed s 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 t s r -> Parser t s r -> Parser t s r
append (Result s r) p2 = prepend (mappend r) (feed s p2)
append p1 p2 = apply (`append` p2) p1
instance (Monoid s, Monoid r) => Monoid (Parser t s r) where
mempty = return mempty
mappend = (><)
instance (Alternative (Parser t s), Monoid s) => MonoidAlternative (Parser t s) where
moptional p = p <|> mempty
concatMany = fst . manies
concatSome = snd . manies
manies :: (Alternative (Parser t s), Monoid s, Monoid r) => Parser t s r -> (Parser t s r, Parser t s r)
manies p = (many, some)
where many = resultPart id (some <|> mempty)
some = appendIncremental p many
infixl 3 <||>
infixl 3 <<|>
(<||>) :: Parser t s r -> Parser t s r -> Parser t 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 t s r -> Parser t s r -> Parser t 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
defaultMany :: (Monoid s, Alternative (Parser t s)) => Parser t s r -> Parser t s [r]
defaultMany = fst . defaultManySome
defaultSome :: (Monoid s, Alternative (Parser t s)) => Parser t s r -> Parser t s [r]
defaultSome = snd . defaultManySome
defaultManySome :: (Monoid s, Alternative (Parser t s)) => Parser t s r -> (Parser t s [r], Parser t s [r])
defaultManySome p = (many, some)
where many = resultPart id (some <|> pure [])
some = (:) <$> p +<*> many
showWith :: (Monoid s, Monoid r, Show s) => ((s -> Parser t s r) -> String) -> (r -> String) -> Parser t s r -> String
showWith _ _ (Failure s) = "Failure " ++ show s
showWith _ sr (Result s r) = "(Result " ++ shows s (" " ++ 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 s r) = Result s (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 t s r -> Parser t s r
lookAhead p = lookAheadInto mempty p
where lookAheadInto :: Monoid s => s -> Parser t s r -> Parser t s r
lookAheadInto _ p@Failure{} = p
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 t s r' -> Parser t s r
notFollowedBy = lookAheadNotInto mempty
where lookAheadNotInto :: (Monoid s, Monoid r) => s -> Parser t s r' -> Parser t 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 "notFollowedBy"
| otherwise = Delay (lookAheadNotInto t $ feedEof p)
(\s-> lookAheadNotInto (mappend t s) (feed s p))
resultPart :: Monoid s => (r -> r) -> Parser t s r -> Parser t s r
resultPart _ Failure{} = error "Internal contradiction"
resultPart f (Result s r) = Result s (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 t s r -> Bool
isInfallible Result{} = True
isInfallible ResultPart{} = True
isInfallible (Choice p _) = isInfallible p
isInfallible _ = False
prepend :: (r -> r) -> Parser t s r -> Parser t s r
prepend _ p@Failure{} = p
prepend r1 (Result s r2) = Result s (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 t s r -> Parser t s r') -> Parser t s r -> Parser t s r'
apply _ (Failure s) = Failure s
apply f (Choice p1 p2) = f p1 <||> f p2
apply g (Delay e f) = Delay (g e) (g . f)
apply g (ResultPart r e f) = Delay (g $ prepend r e) (g . prepend r . f)
apply f p = Delay (f $ feedEof p) (\s-> f $ feed s p)
mapType :: (Parser t s r -> Parser b s r) -> Parser t s r -> Parser b s r
mapType _ (Failure s) = Failure s
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 t s r) -> Parser t s r
more = Delay (Failure "more")
eof :: (MonoidNull s, Monoid r) => Parser t s r
eof = Delay mempty (\s-> if null s then eof else Failure "eof")
anyToken :: FactorialMonoid s => Parser t 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 t s s
token x = satisfy (== x)
satisfy :: FactorialMonoid s => (s -> Bool) -> Parser t 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 "satisfy"
Nothing -> p
satisfyChar :: TextualMonoid s => (Char -> Bool) -> Parser t 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 "satisfyChar"
Nothing -> if null rest then p else Failure "satisfyChar"
Nothing -> p
string :: (LeftReductiveMonoid s, MonoidNull s) => s -> Parser t 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 "string"
(Nothing, Just x') -> string x' >> return x)
takeWhile :: (FactorialMonoid s, MonoidNull s) => (s -> Bool) -> Parser t 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 t 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 "takeWhile1"
else if null suffix then resultPart (mappend prefix) (takeWhile pred)
else Result suffix prefix
takeCharsWhile :: (TextualMonoid s, MonoidNull s) => (Char -> Bool) -> Parser t 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 t 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 "takeCharsWhile1"
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 t s r -> Parser t s r
count n p | n > 0 = p >< count (pred n) p
| otherwise = mempty
skip :: (Monoid s, Monoid r) => Parser t s r' -> Parser t s r
skip p = p *> mempty
manyTill :: (Monoid s, Monoid r) => Parser t s r -> Parser t s r' -> Parser t s r
manyTill next end = if isInfallible next then t1 else t2
where t1 = skip end <<|> appendIncremental next t1
t2 = skip end <<|> append next t2
acceptAll :: Monoid s => Parser t s s
acceptAll = ResultPart id mempty f
where f s = ResultPart (mappend s) mempty f
and :: (Monoid s, Monoid r1, Monoid r2) => Parser t s r1 -> Parser t s r2 -> Parser t s (r1, r2)
Failure s `and` _ = Failure s
_ `and` Failure s = Failure s
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 t s r1 -> Parser t s r2 -> Parser t s (r1, r2)
Result s r `andThen` p | isInfallible p = resultPart (mappend (r, mempty)) (feed s (mapIncremental ((,) 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