grammatical-parsers-0.7: src/Text/Grampa/Internal/LeftRecursive.hs
{-# LANGUAGE ConstraintKinds, CPP, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, InstanceSigs,
RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators,
UndecidableInstances #-}
-- | A context-free memoizing parser that can handle left-recursive grammars.
module Text.Grampa.Internal.LeftRecursive (Fixed(..), SeparatedParser(..),
autochain, asLeaf, liftPositive, liftPure, mapPrimitive,
parseSeparated, separated)
where
import Control.Applicative
import Control.Monad (Monad(..), MonadPlus(..), void)
#if MIN_VERSION_base(4,13,0)
import Control.Monad (MonadFail(fail))
#endif
import Control.Monad.Trans.State.Lazy (State, evalState)
import qualified Control.Monad.Trans.State.Lazy as State
import Data.Functor.Compose (Compose(..))
import Data.Kind (Type)
import Data.Maybe (isJust)
import Data.Semigroup (Semigroup(..))
import Data.Monoid (Monoid(mempty), All(..), Any(..))
import Data.Monoid.Null (MonoidNull(null))
import Data.Monoid.Factorial (FactorialMonoid)
import Data.Monoid.Textual (TextualMonoid)
import Data.Semigroup.Cancellative (LeftReductive)
import qualified Data.Monoid.Factorial as Factorial
import qualified Data.Monoid.Textual as Textual
import Data.String (fromString)
import Data.Type.Equality ((:~:)(Refl))
import Witherable (Filterable(mapMaybe))
import qualified Text.Parser.Char as Char
import Text.Parser.Char (CharParsing)
import Text.Parser.Combinators (Parsing(..))
import Text.Parser.LookAhead (LookAheadParsing(..))
import qualified Rank2
import Text.Grampa.Class (GrammarParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),
AmbiguousParsing(..), CommittedParsing(..), ConsumedInputParsing(..),
DeterministicParsing(..),
TailsParsing(parseTails, parseAllTails),
ParseResults, ParseFailure(..), FailureDescription(..), Pos)
import Text.Grampa.Internal (FallibleResults(..),
AmbiguousAlternative(ambiguousOr), AmbiguityDecidable(..), AmbiguityWitness(..),
ParserFlags (ParserFlags, nullable, dependsOn),
Dependencies (DynamicDependencies, StaticDependencies),
TraceableParsing(..))
import Text.Grampa.Internal.Storable (Storable1(reuse1), Storable11(reuse11, store11))
import Prelude hiding (cycle, null, span, take, takeWhile)
type ResultAppend p (g :: (Type -> Type) -> Type) s =
GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s)
-- | A transformer that adds left-recursive powers to a memoizing parser @p@ over grammar @g@
data Fixed p g s a =
-- | a fully general parser
Parser {
complete, direct, direct0, direct1, indirect :: p g s a,
choices :: ChoiceTree (Fixed p g s a),
isAmbiguous :: Maybe (AmbiguityWitness a),
cyclicDescendants :: g (Const (ParserFlags g)) -> ParserFlags g}
-- | a parser that doesn't start with a 'nonTerminal'
| DirectParser {
complete, direct0, direct1 :: p g s a}
-- | a parser that doesn't start with a 'nonTerminal' and always consumes some input
| PositiveDirectParser {
complete :: p g s a}
-- | Binary tree with two different choice nodes
data ChoiceTree a =
Leaf a
| SymmetricChoice (ChoiceTree a) (ChoiceTree a)
| LeftBiasedChoice (ChoiceTree a) (ChoiceTree a)
deriving Show
instance Functor ChoiceTree where
fmap f (Leaf a) = Leaf (f a)
fmap f (SymmetricChoice a b) = SymmetricChoice (fmap f a) (fmap f b)
fmap f (LeftBiasedChoice a b) = LeftBiasedChoice (fmap f a) (fmap f b)
instance Foldable ChoiceTree where
foldMap f (Leaf a) = f a
foldMap f (SymmetricChoice a b) = foldMap f a <> foldMap f b
foldMap f (LeftBiasedChoice a b) = foldMap f a <> foldMap f b
collapseChoices :: (Alternative p, DeterministicParsing p) => ChoiceTree (p a) -> p a
collapseChoices (SymmetricChoice p q) = collapseChoices p <|> collapseChoices q
collapseChoices (LeftBiasedChoice p q) = collapseChoices p <<|> collapseChoices q
collapseChoices (Leaf p) = p
-- | A type of parsers analyzed for their left-recursion class
data SeparatedParser p (g :: (Type -> Type) -> Type) s a =
-- | a parser that no left-recursive nonterminal depends on
FrontParser (p g s a)
-- | a left-recursive parser that may add to the set of parse results every time it's run
| CycleParser {
cycleParser :: p g s a,
backParser :: p g s a,
appendResultsArrow :: ResultAppend p g s a,
dependencies :: Dependencies g}
-- | a parser that doesn't start with any 'nonTerminal' so it can run first
| BackParser {
backParser :: p g s a}
newtype Union (g :: (Type -> Type) -> Type) = Union{getUnion :: g (Const Bool)}
--instance Rank2.Applicative g => Monoid (Union g) where
-- mempty = Union (Rank2.pure $ Const False)
instance (Rank2.Apply g, Rank2.Distributive g) => Semigroup (Union g) where
Union g1 <> Union g2 = Union (Rank2.liftA2 union g1 g2)
instance (Rank2.Apply g, Rank2.Distributive g) => Monoid (Union g) where
mempty = Union (Rank2.cotraverse (Const . getConst) (Const False))
mappend = (<>)
asLeaf :: Fixed p g s a -> Fixed p g s a
asLeaf p@Parser{} = p'
where p' = p{choices= Leaf p'}
asLeaf p = p
mapPrimitive :: forall p g s a b. AmbiguityDecidable b => (p g s a -> p g s b) -> Fixed p g s a -> Fixed p g s b
mapPrimitive f p@PositiveDirectParser{} = PositiveDirectParser{complete= f (complete p)}
mapPrimitive f p@DirectParser{} = DirectParser{complete= f (complete p),
direct0= f (direct0 p),
direct1= f (direct1 p)}
mapPrimitive f p@Parser{} = asLeaf Parser{
complete= f (complete p),
choices= undefined,
isAmbiguous= ambiguityWitness @b,
cyclicDescendants= cyclicDescendants p,
indirect= f (indirect p),
direct= f (direct p),
direct0= f (direct0 p),
direct1= f (direct1 p)}
general, general' :: (Rank2.Apply g, Alternative (p g s)) => Fixed p g s a -> Fixed p g s a
general p = Parser{
complete= complete p,
direct = direct p',
direct0= direct0 p',
direct1= direct1 p',
indirect= indirect p',
choices= choices p',
isAmbiguous= case p
of Parser{isAmbiguous= a} -> a
_ -> Nothing,
cyclicDescendants= cyclicDescendants p'}
where p' = general' p
general' p@PositiveDirectParser{} = asLeaf Parser{
complete= complete p,
direct = complete p,
direct0= empty,
direct1= complete p,
indirect= empty,
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= \cd-> ParserFlags False (StaticDependencies $ const (Const False) Rank2.<$> cd)}
general' p@DirectParser{} = asLeaf Parser{
complete= complete p,
direct = complete p,
direct0= direct0 p,
direct1= direct1 p,
indirect= empty,
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= \cd-> ParserFlags True (StaticDependencies $ const (Const False) Rank2.<$> cd)}
general' p@Parser{} = p
type LeftRecParsing p g s f = (Eq s, LeftReductive s, FactorialMonoid s, Alternative (p g s),
TailsParsing (p g s), GrammarConstraint (p g s) g, ParserGrammar (p g s) ~ g,
Functor (ResultFunctor (p g s)), s ~ ParserInput (p g s), FallibleResults f,
Storable1 (GrammarFunctor (p g s)) (ParserFlags g),
Storable1 (GrammarFunctor (p g s)) Bool,
AmbiguousAlternative (GrammarFunctor (p g s)))
-- | Parser transformer for left-recursive grammars.
--
-- @
-- 'parseComplete' :: ("Rank2".'Rank2.Apply' g, "Rank2".'Rank2.Traversable' g, 'FactorialMonoid' s) =>
-- g (LeftRecursive.'Parser' g s) -> s -> g ('Compose' ('ParseResults' s) [])
-- @
instance (Rank2.Apply g, GrammarFunctor (p g s) ~ f s, LeftRecParsing p g s f) => MultiParsing (Fixed p g s) where
type GrammarConstraint (Fixed p g s) g' = (GrammarConstraint (p g s) g', g ~ g',
Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)
type ResultFunctor (Fixed p g s) = ResultFunctor (p g s)
-- parsePrefix :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, Eq s, FactorialMonoid s) =>
-- g (Fixed p g s) -> s -> g (Compose (ResultFunctor (p g s)) ((,) s))
parsePrefix g input
| Just directs <- Rank2.traverse getDirect g' = parsePrefix directs input
| otherwise = Rank2.fmap (Compose . parsingResult @(p g s) input) (snd $ head $ parseSeparated g' input)
where g' = separated g
getDirect (FrontParser p) = Just p
getDirect (BackParser p) = Just p
getDirect CycleParser{} = Nothing
{-# INLINE parsePrefix #-}
-- parseComplete :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, Eq s, FactorialMonoid s) =>
-- g (Fixed p g s) -> s -> g (ResultFunctor (p g s))
parseComplete g input
| Just directs <- Rank2.traverse getDirect g' = parseComplete directs input
| otherwise = Rank2.fmap ((snd <$>) . parsingResult @(p g s) input)
$ snd $ head $ parseAllTails close $ parseSeparated g' input
where g' = separated g
getDirect (FrontParser p) = Just p
getDirect (BackParser p) = Just p
getDirect CycleParser{} = Nothing
close :: g (p g s)
close = Rank2.fmap (<* eof) selfReferring
{-# INLINE parseComplete #-}
-- | Parser transformer for left-recursive grammars.
instance (Rank2.Apply g, GrammarFunctor (p g s) ~ f s, LeftRecParsing p g s f) => GrammarParsing (Fixed p g s) where
type ParserGrammar (Fixed p g s) = g
type GrammarFunctor (Fixed p g s) = GrammarFunctor (p g s)
parsingResult :: s -> GrammarFunctor (p g s) a -> ResultFunctor (p g s) (s, a)
parsingResult s = parsingResult @(p g s) s
nonTerminal :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g) =>
(g (GrammarFunctor (p g s)) -> GrammarFunctor (p g s) a) -> Fixed p g s a
nonTerminal f = asLeaf Parser{
complete= ind,
direct= empty,
direct0= empty,
direct1= empty,
indirect= ind,
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= reuse1 . f . Rank2.fmap store11 . addSelf}
where ind = nonTerminal f
addSelf g = Rank2.liftA2 adjust bits g
adjust :: forall b. Const (g (Const Bool)) b -> Const (ParserFlags g) b -> Const (ParserFlags g) b
adjust (Const bit) (Const (ParserFlags n (StaticDependencies d))) =
Const ParserFlags{
nullable= n,
dependsOn= StaticDependencies (Rank2.liftA2 union bit d)}
adjust _ flags@(Const (ParserFlags _ DynamicDependencies)) = flags
{-# INLINE nonTerminal #-}
recursive = general
chainRecursive = chainWith chainRecursive
{-# INLINABLE chainRecursive #-}
chainLongestRecursive = chainWith chainLongestRecursive
{-# INLINABLE chainLongestRecursive #-}
chainWith :: (Rank2.Apply g, GrammarFunctor (p g s) ~ f, f ~ rl s, LeftRecParsing p g s rl)
=> ((f a -> g f -> g f) -> p g s a -> p g s a -> p g s a)
-> ((f a -> g f -> g f) -> Fixed p g s a -> Fixed p g s a -> Fixed p g s a)
chainWith f assign = chain
where chain base recurse@Parser{} = asLeaf Parser{
complete= f assign (complete base) (complete recurse),
direct= f assign (direct base) (complete recurse),
direct0= f assign (direct0 base) (complete recurse),
direct1= f assign (direct1 base) (complete recurse),
indirect= f assign (indirect base) (complete recurse),
choices= undefined,
isAmbiguous= isAmbiguous base <|> isAmbiguous recurse,
cyclicDescendants= \deps-> let ParserFlags pn pd = cyclicDescendants base deps
ParserFlags qn qd = cyclicDescendants recurse deps
qd' = case qd
of DynamicDependencies -> DynamicDependencies
StaticDependencies g -> StaticDependencies (clearOwnDep g)
in ParserFlags (pn && qn) (depUnion pd qd')}
chain base recurse = recurse <|> base
clearOwnDep = Rank2.fmap reuse11 . assign (store11 $ Const False) . Rank2.fmap store11
{-# INLINE chainWith #-}
bits :: forall (g :: (Type -> Type) -> Type). (Rank2.Distributive g, Rank2.Traversable g) => g (Const (g (Const Bool)))
bits = start `seq` Rank2.fmap oneBit start
where start = evalState (Rank2.traverse next (Rank2.distributeJoin Nothing)) 0
oneBit :: Const Int a -> Const (g (Const Bool)) a
next :: f a -> State Int (Const Int a)
oneBit (Const i) = Const (Rank2.fmap (Const . (i ==) . getConst) start)
next _ = do {i <- State.get; let {i' = succ i}; seq i' (State.put i'); return (Const i)}
instance Functor (p g s) => Functor (Fixed p g s) where
fmap f (PositiveDirectParser p) = PositiveDirectParser (fmap f p)
fmap f p@DirectParser{} = DirectParser{
complete= fmap f (complete p),
direct0= fmap f (direct0 p),
direct1= fmap f (direct1 p)}
fmap f p@Parser{} = p{
complete= fmap f (complete p),
direct= fmap f (direct p),
direct0= fmap f (direct0 p),
direct1= fmap f (direct1 p),
indirect= fmap f (indirect p),
choices= fmap f <$> choices p,
isAmbiguous= Nothing}
{-# INLINABLE fmap #-}
instance (Rank2.Apply g, Alternative (p g s)) => Applicative (Fixed p g s) where
pure a = DirectParser{complete= pure a,
direct0= pure a,
direct1= empty}
p@PositiveDirectParser{} <*> q = PositiveDirectParser{
complete= complete p <*> complete q}
p@DirectParser{} <*> q@PositiveDirectParser{} = PositiveDirectParser{
complete= complete p <*> complete q}
p@DirectParser{} <*> q@DirectParser{} = DirectParser{
complete= complete p <*> complete q,
direct0= direct0 p <*> direct0 q,
direct1= direct0 p <*> direct1 q <|> direct1 p <*> complete q}
p <*> q@Parser{} = asLeaf Parser{
complete= complete p' <*> complete q,
direct= direct0 p' <*> direct q <|> direct1 p' <*> complete q,
direct0= direct0 p' <*> direct0 q,
direct1= direct0 p' <*> direct1 q <|> direct1 p' <*> complete q,
indirect= direct0 p' <*> indirect q <|> indirect p' <*> complete q,
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= \deps-> let
pcd@(ParserFlags pn pd) = cyclicDescendants p' deps
ParserFlags qn qd = cyclicDescendants q deps
in if pn
then ParserFlags qn (depUnion pd qd)
else pcd}
where p'@Parser{} = general' p
p <*> q = asLeaf Parser{
complete= complete p' <*> complete q',
direct= direct p' <*> complete q',
direct0= direct0 p' <*> direct0 q',
direct1= direct0 p' <*> direct1 q' <|> direct1 p' <*> complete q',
indirect= indirect p' <*> complete q',
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= \deps-> let
pcd@(ParserFlags pn pd) = cyclicDescendants p' deps
ParserFlags qn qd = cyclicDescendants q' deps
in if pn
then ParserFlags qn (depUnion pd qd)
else pcd}
where p'@Parser{} = general' p
q'@Parser{} = general' q
{-# INLINABLE pure #-}
{-# INLINABLE (<*>) #-}
instance (Rank2.Apply g, Alternative (p g s)) => Alternative (Fixed p g s) where
empty = PositiveDirectParser{complete= empty}
p@PositiveDirectParser{} <|> q@PositiveDirectParser{} = PositiveDirectParser{complete= complete p <|> complete q}
p@PositiveDirectParser{} <|> q@DirectParser{} = DirectParser{
complete= complete p <|> complete q,
direct0 = direct0 q,
direct1= complete p <|> direct1 q}
p@DirectParser{} <|> q@PositiveDirectParser{} = DirectParser{
complete= complete p <|> complete q,
direct0 = direct0 p,
direct1= direct1 p <|> complete q}
p@DirectParser{} <|> q@DirectParser{} = DirectParser{
complete= complete p <|> complete q,
direct0 = direct0 p <|> direct0 q,
direct1= direct1 p <|> direct1 q}
p <|> q = Parser{complete= complete p' <|> complete q',
direct= direct p' <|> direct q',
direct0= direct0 p' <|> direct0 q',
direct1= direct1 p' <|> direct1 q',
indirect= indirect p' <|> indirect q',
choices= choices p' `SymmetricChoice` choices q',
isAmbiguous= Nothing,
cyclicDescendants= \deps-> let
ParserFlags pn pd = cyclicDescendants p' deps
ParserFlags qn qd = cyclicDescendants q' deps
in ParserFlags (pn || qn) (depUnion pd qd)}
where p'@Parser{} = general p
q'@Parser{} = general q
many (PositiveDirectParser p) = DirectParser{
complete= many p,
direct0= pure [],
direct1= some p}
many p@DirectParser{} = DirectParser{
complete= many (complete p),
direct0= pure [] <|> (:[]) <$> direct0 p,
direct1= (:) <$> direct1 p <*> many (complete p)}
many p@Parser{} = asLeaf Parser{
complete= mcp,
direct= d0 <|> d1,
direct0= d0,
direct1= d1,
indirect= (:) <$> indirect p <*> mcp,
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}
where d0 = pure [] <|> (:[]) <$> direct0 p
d1 = (:) <$> direct1 p <*> mcp
mcp = many (complete p)
some (PositiveDirectParser p) = PositiveDirectParser{complete= some p}
some p@DirectParser{} = DirectParser{
complete= some (complete p),
direct0= (:[]) <$> direct0 p,
direct1= (:) <$> direct1 p <*> many (complete p)}
some p@Parser{} = asLeaf Parser{
complete= some (complete p),
direct= d0 <|> d1,
direct0= d0,
direct1= d1,
indirect= (:) <$> indirect p <*> many (complete p),
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= cyclicDescendants p}
where d0 = (:[]) <$> direct0 p
d1= (:) <$> direct1 p <*> many (complete p)
{-# INLINABLE (<|>) #-}
{-# INLINABLE many #-}
{-# INLINABLE some #-}
instance Filterable (p g s) => Filterable (Fixed p g s) where
mapMaybe f (PositiveDirectParser p) = PositiveDirectParser (mapMaybe f p)
mapMaybe f p@DirectParser{} = DirectParser{
complete= mapMaybe f (complete p),
direct0= mapMaybe f (direct0 p),
direct1= mapMaybe f (direct1 p)}
mapMaybe f p@Parser{} = p{
complete= mapMaybe f (complete p),
direct= mapMaybe f (direct p),
direct0= mapMaybe f (direct0 p),
direct1= mapMaybe f (direct1 p),
indirect= mapMaybe f (indirect p),
choices= mapMaybe f <$> choices p,
isAmbiguous= Nothing}
{-# INLINABLE mapMaybe #-}
complement :: Const Bool x -> Const Bool x
complement (Const a) = Const (not a)
intersection :: Const Bool x -> Const Bool x -> Const Bool x
intersection (Const True) x = x
intersection (Const False) _ = Const False
union :: Const Bool x -> Const Bool x -> Const Bool x
union (Const False) x = x
union (Const True) _ = Const True
depUnion :: Rank2.Apply g => Dependencies g -> Dependencies g -> Dependencies g
depUnion (StaticDependencies d1) (StaticDependencies d2) = StaticDependencies (Rank2.liftA2 union d1 d2)
depUnion _ _ = DynamicDependencies
instance (Rank2.Apply g, Alternative (p g s), Monad (p g s)) => Monad (Fixed p g s) where
return = pure
(>>) = (*>)
PositiveDirectParser p >>= cont = PositiveDirectParser (p >>= complete . cont)
p@DirectParser{} >>= cont = asLeaf Parser{
complete= complete p >>= complete . cont,
direct= d0 <|> d1,
direct0= d0,
direct1= d1,
indirect= direct0 p >>= indirect . general' . cont,
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= const (ParserFlags True DynamicDependencies)}
where d0 = direct0 p >>= direct0 . general' . cont
d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont)
p >>= cont = asLeaf Parser{
complete= complete p >>= complete . cont,
direct= d0 <|> d1,
direct0= d0,
direct1= d1,
indirect= (indirect p >>= complete . cont) <|> (direct0 p >>= indirect . general' . cont),
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= \cd->
let pcd@(ParserFlags pn _) = cyclicDescendants p' cd
in if pn
then ParserFlags True DynamicDependencies
else pcd}
where d0 = direct0 p >>= direct0 . general' . cont
d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont)
p'@Parser{} = general' p
#if MIN_VERSION_base(4,13,0)
instance (Rank2.Apply g, Alternative (p g s), MonadFail (p g s)) => MonadFail (Fixed p g s) where
#endif
fail msg = PositiveDirectParser{complete= fail msg}
instance (Rank2.Apply g, MonadPlus (p g s)) => MonadPlus (Fixed p g s) where
mzero = empty
mplus = (<|>)
instance (Rank2.Apply g, Alternative (p g s), Semigroup x) => Semigroup (Fixed p g s x) where
(<>) = liftA2 (<>)
instance (Rank2.Apply g, Alternative (p g s), Monoid x) => Monoid (Fixed p g s x) where
mempty = pure mempty
mappend = (<>)
primitive :: p g s a -> p g s a -> p g s a -> Fixed p g s a
primitive d0 d1 d = DirectParser{complete= d,
direct0= d0,
direct1= d1}
{-# INLINE primitive #-}
-- | Lifts a primitive positive parser (/i.e./, one that always consumes some input) into a left-recursive one
liftPositive :: p g s a -> Fixed p g s a
liftPositive p = PositiveDirectParser{complete= p}
{-# INLINE liftPositive #-}
-- | Lifts a primitive pure parser (/i.e./, one that consumes no input) into a left-recursive one
liftPure :: Alternative (p g s) => p g s a -> Fixed p g s a
liftPure p = DirectParser{complete= p,
direct0= p,
direct1= empty}
{-# INLINE liftPure #-}
instance (Rank2.Apply g, Parsing (p g s), InputParsing (Fixed p g s)) => Parsing (Fixed p g s) where
eof = primitive eof empty eof
try (PositiveDirectParser p) = PositiveDirectParser (try p)
try p@DirectParser{} = DirectParser{
complete= try (complete p),
direct0= try (direct0 p),
direct1= try (direct1 p)}
try p@Parser{} = asLeaf p{
complete= try (complete p),
direct= try (direct p),
direct0= try (direct0 p),
direct1= try (direct1 p),
indirect= try (indirect p)}
PositiveDirectParser p <?> msg = PositiveDirectParser (p <?> msg)
p@DirectParser{} <?> msg = DirectParser{
complete= complete p <?> msg,
direct0= direct0 p <?> msg,
direct1= direct1 p <?> msg}
p@Parser{} <?> msg = asLeaf p{
complete= complete p <?> msg,
direct= direct p <?> msg,
direct0= direct0 p <?> msg,
direct1= direct1 p <?> msg,
indirect= indirect p <?> msg}
notFollowedBy p@PositiveDirectParser{} = DirectParser{
complete= notFollowedBy (complete p),
direct0= notFollowedBy (complete p),
direct1= empty}
notFollowedBy p@DirectParser{} = DirectParser{
complete= notFollowedBy (complete p),
direct0= notFollowedBy (complete p),
direct1= empty}
notFollowedBy p@Parser{} = asLeaf Parser{
complete= notFollowedBy (complete p),
direct= notFollowedBy (direct p),
direct0= notFollowedBy (direct p),
direct1= empty,
indirect= notFollowedBy (indirect p),
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}
unexpected msg = liftPositive (unexpected msg)
instance (Rank2.Apply g, InputParsing (Fixed p g s), DeterministicParsing (p g s)) =>
DeterministicParsing (Fixed p g s) where
p@DirectParser{} <<|> q@PositiveDirectParser{} = DirectParser{
complete= complete p <<|> complete q,
direct0 = direct0 p,
direct1= direct1 p <<|> complete q}
p@DirectParser{} <<|> q@DirectParser{} = DirectParser{
complete= complete p <<|> complete q,
direct0 = direct0 p <<|> direct0 q,
direct1= direct1 p <<|> direct1 q}
p <<|> q = Parser{complete= complete p' <<|> complete q',
direct= direct p' <<|> notFollowedBy (void $ complete p') *> direct q',
direct0= direct0 p' <<|> notFollowedBy (void $ complete p') *> direct0 q',
direct1= direct1 p' <<|> notFollowedBy (void $ complete p') *> direct1 q',
indirect= indirect p' <<|> notFollowedBy (void $ complete p') *> indirect q',
choices= choices p' `LeftBiasedChoice` choices q',
isAmbiguous= Nothing,
cyclicDescendants= \deps-> let
ParserFlags pn pd = cyclicDescendants p' deps
ParserFlags qn qd = cyclicDescendants q' deps
in ParserFlags (pn || qn) (depUnion pd qd)}
where p'@Parser{} = general p
q'@Parser{} = general q
takeSome p = (:) <$> p <*> takeMany p
takeMany (PositiveDirectParser p) = DirectParser{
complete = takeMany p,
direct0= [] <$ notFollowedBy (void p),
direct1= takeSome p}
takeMany p@DirectParser{} = DirectParser{
complete = takeMany (complete p),
direct0= (:[]) <$> direct0 p <<|> [] <$ notFollowedBy (void $ complete p),
direct1= (:) <$> direct1 p <*> takeMany (complete p)}
takeMany p@Parser{} = asLeaf Parser{
complete= mcp,
direct= d1 <<|> d0,
direct0= d0,
direct1= d1,
indirect= (:) <$> indirect p <*> mcp,
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}
where d0 = (:[]) <$> direct0 p <<|> [] <$ notFollowedBy (void $ direct p)
d1 = (:) <$> direct1 p <*> mcp
mcp = takeMany (complete p)
skipAll (PositiveDirectParser p) = DirectParser{
complete = skipAll p,
direct0= () <$ notFollowedBy (void p),
direct1= p *> skipAll p}
skipAll p@DirectParser{} = DirectParser{
complete = skipAll (complete p),
direct0= void (direct0 p) <<|> notFollowedBy (void $ complete p),
direct1= direct1 p *> skipAll (complete p)}
skipAll p@Parser{} = asLeaf Parser{
complete= mcp,
direct= d1 <<|> d0,
direct0= d0,
direct1= d1,
indirect= indirect p *> mcp,
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}
where d0 = () <$ direct0 p <<|> notFollowedBy (void $ direct p)
d1 = direct1 p *> mcp
mcp = skipAll (complete p)
instance (Rank2.Apply g, CommittedParsing (p g s), CommittedResults (p g s) ~ ParseResults s) =>
CommittedParsing (Fixed p g s) where
type CommittedResults (Fixed p g s) = ParseResults s
commit (PositiveDirectParser p) = PositiveDirectParser (commit p)
commit p@DirectParser{} = DirectParser{
complete = commit (complete p),
direct0= commit (direct0 p),
direct1= commit (direct1 p)}
commit p@Parser{} = asLeaf Parser{
complete= commit (complete p),
direct= commit (direct p),
direct0= commit (direct0 p),
direct1= commit (direct1 p),
indirect= commit (indirect p),
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= cyclicDescendants p}
admit :: Fixed p g s (CommittedResults (Fixed p g s) a) -> Fixed p g s a
admit (PositiveDirectParser p) = PositiveDirectParser (admit p)
admit p@DirectParser{} = DirectParser{
complete = admit (complete p),
direct0= admit (direct0 p),
direct1= admit (direct1 p)}
admit p@Parser{} = asLeaf Parser{
complete= admit (complete p),
direct= admit (direct p),
direct0= admit (direct0 p),
direct1= admit (direct1 p),
indirect= admit (indirect p),
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= cyclicDescendants p}
instance (Rank2.Apply g, LookAheadParsing (p g s), InputParsing (Fixed p g s)) => LookAheadParsing (Fixed p g s) where
lookAhead p@PositiveDirectParser{} = DirectParser{
complete= lookAhead (complete p),
direct0= lookAhead (complete p),
direct1= empty}
lookAhead p@DirectParser{} = DirectParser{
complete= lookAhead (complete p),
direct0= lookAhead (complete p),
direct1= empty}
lookAhead p@Parser{} = asLeaf Parser{
complete= lookAhead (complete p),
direct= lookAhead (direct p),
direct0= lookAhead (direct p),
direct1= empty,
isAmbiguous= isAmbiguous p,
indirect= lookAhead (indirect p),
choices= undefined,
cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}
instance (Rank2.Apply g, LeftReductive s, FactorialMonoid s, InputParsing (p g s), ParserInput (p g s) ~ s) =>
InputParsing (Fixed p g s) where
type ParserInput (Fixed p g s) = s
getInput = primitive getInput empty getInput
anyToken = liftPositive anyToken
satisfy predicate = liftPositive (satisfy predicate)
notSatisfy predicate = primitive (notSatisfy predicate) empty (notSatisfy predicate)
scan s0 f = primitive (mempty <$ notSatisfy test) (lookAhead (satisfy test) *> p) p
where p = scan s0 f
test = isJust . f s0
string s
| null s = primitive (string s) empty (string s)
| otherwise = liftPositive (string s)
take 0 = mempty
take n = liftPositive (take n)
takeWhile predicate = primitive (mempty <$ notSatisfy predicate)
(takeWhile1 predicate) (takeWhile predicate)
takeWhile1 predicate = liftPositive (takeWhile1 predicate)
{-# INLINABLE string #-}
instance (Rank2.Apply g, LeftReductive s, FactorialMonoid s, Show s,
TraceableParsing (p g s), ParserInput (p g s) ~ s) =>
TraceableParsing (Fixed p g s) where
traceInput description p@PositiveDirectParser{} = p{
complete= traceInput (\s-> "direct+ " <> description s) (complete p)}
traceInput description p@DirectParser{} = p{
complete= traceInput (\s-> "direct " <> description s) (complete p),
direct0= traceInput (\s-> "direct0 " <> description s) (direct0 p),
direct1= traceInput (\s-> "direct1 " <> description s) (direct1 p)}
traceInput description p@Parser{} = asLeaf p{
complete= traceBy "complete" (complete p),
direct= traceBy "direct" (direct p),
direct0= traceBy "direct0" (direct0 p),
direct1= traceBy "direct1" (direct1 p),
indirect= traceBy "indirect" (indirect p)}
where traceBy mode = traceInput (\s-> "(" <> mode <> ") " <> description s)
instance (Rank2.Apply g, LeftReductive s, FactorialMonoid s,
ConsumedInputParsing (p g s), ParserInput (p g s) ~ s) => ConsumedInputParsing (Fixed p g s) where
match (PositiveDirectParser p) = PositiveDirectParser (match p)
match p@DirectParser{} = DirectParser{
complete= match (complete p),
direct0 = match (direct0 p),
direct1 = match (direct1 p)}
match p@Parser{} = asLeaf Parser{
complete= match (complete p),
direct = match (direct p),
direct0 = match (direct0 p),
direct1 = match (direct1 p),
indirect= match (indirect p),
choices= undefined,
isAmbiguous= Nothing,
cyclicDescendants= cyclicDescendants p}
instance (Rank2.Apply g, Show s, TextualMonoid s, InputCharParsing (p g s), ParserInput (p g s) ~ s) =>
InputCharParsing (Fixed p g s) where
satisfyCharInput predicate = liftPositive (satisfyCharInput predicate)
notSatisfyChar predicate = primitive (notSatisfyChar predicate) empty (notSatisfyChar predicate)
scanChars s0 f = primitive (mempty <$ notSatisfyChar test) (lookAhead (Char.satisfy test) *> p) p
where p = scanChars s0 f
test = isJust . f s0
takeCharsWhile predicate = primitive (mempty <$ notSatisfyChar predicate)
(takeCharsWhile1 predicate) (takeCharsWhile predicate)
takeCharsWhile1 predicate = liftPositive (takeCharsWhile1 predicate)
instance (Rank2.Apply g, CharParsing (p g s), InputCharParsing (Fixed p g s), TextualMonoid s,
s ~ ParserInput (Fixed p g s), Show s) => CharParsing (Fixed p g s) where
satisfy predicate = liftPositive (Char.satisfy predicate)
string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)
text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t)
instance (AmbiguousParsing (p g s), Rank2.Apply g) => AmbiguousParsing (Fixed p g s) where
ambiguous (PositiveDirectParser p) = PositiveDirectParser (ambiguous p)
ambiguous p@DirectParser{} = DirectParser{complete= ambiguous (complete p),
direct0= ambiguous (direct0 p),
direct1= ambiguous (direct1 p)}
ambiguous p@Parser{} = asLeaf Parser{
complete= ambiguous (complete p),
direct= ambiguous (direct p),
direct0= ambiguous (direct0 p),
direct1= ambiguous (direct1 p),
indirect= ambiguous (indirect p),
choices= undefined,
isAmbiguous= Just (AmbiguityWitness Refl),
cyclicDescendants= cyclicDescendants p}
{-# INLINABLE ambiguous #-}
-- | Automatically apply 'chainRecursive' and 'chainLongestRecursive' to left-recursive grammar productions where
-- possible.
autochain :: forall p g s f rl (cb :: Type -> Type).
(cb ~ Const (g (Const Bool)), f ~ GrammarFunctor (p g s), f ~ rl s,
LeftRecParsing p g s rl, DeterministicParsing (p g s),
Rank2.Apply g, Rank2.Traversable g, Rank2.Distributive g, Rank2.Logistic g)
=> g (Fixed p g s) -> g (Fixed p g s)
autochain g = Rank2.liftA4 optimize Rank2.getters Rank2.setters candidates g
where candidates :: g (Const Bool)
optimize :: forall a. (Compose ((->) (g cb)) cb a)
-> (Rank2.Arrow (f Rank2.~> f) (Const (g f -> g f)) a)
-> Const Bool a
-> Fixed p g s a
-> Fixed p g s a
optimize getter setter (Const True) p@Parser{choices= cs} =
optimizeChoice (getCompose getter) (getConst . Rank2.apply setter . Rank2.Arrow . const) p cs
optimize _ _ _ p = p
optimizeChoice :: (g cb -> cb a)
-> (f a -> g f -> g f)
-- > (forall f. (f a -> f a) -> g f -> g f)
-- > (forall f. Rank2.Arrow f f a -> Const (g f -> g f) a)
-> Fixed p g s a
-> ChoiceTree (Fixed p g s a)
-> Fixed p g s a
splitSymmetric :: (g cb -> cb a) -> ChoiceTree (Fixed p g s a) -> ([Fixed p g s a], [Fixed p g s a])
isLeftRecursive :: (g cb -> cb a) -> ChoiceTree (Fixed p g s a) -> Bool
leftRecursiveParser :: (g cb -> cb a) -> Fixed p g s a -> Bool
optimizeChoice _ _ fallback Leaf{} = fallback
optimizeChoice get set fallback (LeftBiasedChoice p q)
| isLeftRecursive get q = fallback
| not (isLeftRecursive get p) = fallback
| LeftBiasedChoice p1 p2 <- p, not (isLeftRecursive get p2)
= optimizeChoice get set fallback $ LeftBiasedChoice p1 (LeftBiasedChoice p2 q)
| otherwise = chainLongestRecursive set (collapseChoices q) (collapseChoices p)
optimizeChoice get set fallback c@SymmetricChoice{}
| null base = fallback
| null recursives = fallback
| otherwise = chainRecursive set (foldr1 (<|>) base) (foldr1 (<|>) recursives)
where (base, recursives) = splitSymmetric get c
splitSymmetric get (SymmetricChoice p q) = splitSymmetric get p <> splitSymmetric get q
splitSymmetric get c
| isLeftRecursive get c = ([], [collapseChoices c])
| otherwise = ([collapseChoices c], [])
isLeftRecursive get = leftRecursiveParser get . collapseChoices
leftRecursiveParser get Parser{cyclicDescendants= cds} =
getAny $ Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection (getConst $ get bits) (deps bits)
where deps :: g cb -> g (Const Bool)
deps = getDependencies . dependsOn . cds
. Rank2.fmap (Const . ParserFlags False . StaticDependencies . getConst)
leftRecursiveParser _ _ = False
candidates = Rank2.liftA2 intersection (cyclicDependencies g) (complement Rank2.<$> cyclicDependencies g')
g' = Rank2.liftA2 noDirectLeftRecursion bits g
noDirectLeftRecursion (Const bit) p@Parser{cyclicDescendants= cd} = p{cyclicDescendants= excludeSelf . cd}
where excludeSelf (ParserFlags n DynamicDependencies) = ParserFlags n DynamicDependencies
excludeSelf (ParserFlags n (StaticDependencies deps)) =
ParserFlags n $ StaticDependencies $ Rank2.liftA2 intersection (complement Rank2.<$> bit) deps
noDirectLeftRecursion _ p = p
-- | Analyze the grammar's production interdependencies and produce a 'SeparatedParser' from each production's parser.
separated :: forall p g s. (Alternative (p g s), Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g,
AmbiguousAlternative (GrammarFunctor (p g s))) =>
g (Fixed p g s) -> g (SeparatedParser p g s)
separated g = Rank2.liftA4 reseparate circulars cycleFollowers descendants g
where descendants :: g (Const (Dependencies g))
cycleFollowers, circulars :: g (Const Bool)
appendResults :: forall a. Maybe (AmbiguityWitness a)
-> GrammarFunctor (p g s) a -> GrammarFunctor (p g s) a -> GrammarFunctor (p g s) a
leftRecursiveDeps :: forall a. Const Bool a -> Const (Dependencies g) a -> Const (g (Const Bool)) a
reseparate :: forall a. Const Bool a -> Const Bool a -> Const (Dependencies g) a -> Fixed p g s a
-> SeparatedParser p g s a
reseparate (Const circular) (Const follower) (Const d@(StaticDependencies deps)) p
| circular || leader && follower =
CycleParser (indirect p) (direct p) (Rank2.Arrow (Rank2.Arrow . appendResults (isAmbiguous p))) d
| follower = BackParser (complete p)
| otherwise = FrontParser (complete p)
where leader = getAny (Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection circulars deps)
reseparate _ _ (Const d@DynamicDependencies) p =
CycleParser (indirect p) (direct p) (Rank2.Arrow (Rank2.Arrow . appendResults (isAmbiguous p))) d
appendResults (Just (AmbiguityWitness Refl)) = ambiguousOr
appendResults Nothing = (<|>)
descendants = transitiveDescendants g
circulars = Rank2.liftA2 leftRecursive bits descendants
cycleFollowers = getUnion (Rank2.foldMap (Union . getConst) $
Rank2.liftA2 leftRecursiveDeps circulars descendants)
leftRecursiveDeps (Const True) (Const (StaticDependencies deps)) = Const deps
leftRecursiveDeps (Const False) (Const (StaticDependencies deps)) =
Const (Rank2.fmap (const $ Const False) deps)
leftRecursiveDeps _ (Const DynamicDependencies) = Const (Rank2.fmap (const $ Const True) g)
{-# INLINABLE separated #-}
getDependencies :: Rank2.Distributive g => Dependencies g -> g (Const Bool)
getDependencies (StaticDependencies deps) = deps
getDependencies DynamicDependencies = Rank2.cotraverse (const $ Const True) Nothing
cyclicDependencies :: (Alternative (p g s), Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)
=> g (Fixed p g s) -> g (Const Bool)
cyclicDependencies = Rank2.liftA2 leftRecursive bits . transitiveDescendants
leftRecursive :: forall g a. (Rank2.Apply g, Rank2.Foldable g)
=> Const (g (Const Bool)) a -> Const (Dependencies g) a -> Const Bool a
leftRecursive (Const bit) (Const (StaticDependencies deps)) =
Const (getAny $ Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection bit deps)
leftRecursive _ (Const DynamicDependencies) = Const True
transitiveDescendants :: (Alternative (p g s), Rank2.Apply g, Rank2.Traversable g)
=> g (Fixed p g s) -> g (Const (Dependencies g))
transitiveDescendants =
Rank2.fmap (Const . dependsOn . getConst) . fixDescendants . Rank2.fmap (Const . cyclicDescendants . general)
fixDescendants :: forall g. (Rank2.Apply g, Rank2.Traversable g)
=> g (Const (g (Const (ParserFlags g)) -> (ParserFlags g))) -> g (Const (ParserFlags g))
fixDescendants gf = go initial
where go :: g (Const (ParserFlags g)) -> g (Const (ParserFlags g))
go cd
| getAll (Rank2.foldMap (All . getConst) $ Rank2.liftA2 agree cd cd') = cd
| otherwise = go cd'
where cd' = Rank2.liftA2 flagUnion cd (Rank2.fmap (\(Const f)-> Const (f cd)) gf)
agree (Const (ParserFlags _xn (StaticDependencies xd))) (Const (ParserFlags _yn (StaticDependencies yd))) =
Const (getAll (Rank2.foldMap (All . getConst) (Rank2.liftA2 agree' xd yd)))
agree (Const (ParserFlags _xn DynamicDependencies)) (Const (ParserFlags _yn DynamicDependencies)) = Const True
agree _ _ = Const False
agree' (Const x) (Const y) = Const (x == y)
flagUnion (Const ParserFlags{dependsOn= old}) (Const (ParserFlags n new)) =
Const (ParserFlags n $ depUnion old new)
initial = Rank2.liftA2 (\_ (Const n)-> Const (ParserFlags n deps)) gf nullabilities
deps = StaticDependencies (const (Const False) Rank2.<$> gf)
nullabilities = fixNullabilities gf
{-# INLINABLE fixDescendants #-}
fixNullabilities :: forall g. (Rank2.Apply g, Rank2.Traversable g)
=> g (Const (g (Const (ParserFlags g)) -> (ParserFlags g))) -> g (Const Bool)
fixNullabilities gf = Const . nullable . getConst Rank2.<$> go initial
where go :: g (Const (ParserFlags g)) -> g (Const (ParserFlags g))
go cd
| getAll (Rank2.foldMap (All . getConst) $ Rank2.liftA2 agree cd cd') = cd
| otherwise = go cd'
where cd' = Rank2.fmap (\(Const f)-> Const (f cd)) gf
agree (Const flags1) (Const flags2) = Const (nullable flags1 == nullable flags2)
initial = const (Const (ParserFlags True (StaticDependencies $ const (Const False) Rank2.<$> gf))) Rank2.<$> gf
{-# INLINABLE fixNullabilities #-}
-- | Parse the given input using a context-free grammar 'separated' into left-recursive and other productions.
parseSeparated :: forall p g rl s. (Rank2.Apply g, Rank2.Foldable g, Eq s, FactorialMonoid s, LeftReductive s,
TailsParsing (p g s), GrammarConstraint (p g s) g,
GrammarFunctor (p g s) ~ rl s, FallibleResults rl,
s ~ ParserInput (p g s)) =>
g (SeparatedParser p g s) -> s -> [(s, g (GrammarFunctor (p g s)))]
parseSeparated parsers input = foldr parseTail [] (Factorial.tails input)
where parseTail s parsedTail = parsed
where parsed = (s,d''):parsedTail
d = Rank2.fmap (($ (s,d):parsedTail) . parseTails) directs
d' = fixRecursive s parsedTail d
d'' = Rank2.liftA2 f parsers d'
f :: forall a. SeparatedParser p g s a -> GrammarFunctor (p g s) a -> GrammarFunctor (p g s) a
f (FrontParser p) _ = parseTails p ((s,d''):parsedTail)
f _ result = result
fixRecursive :: s -> [(s, g (GrammarFunctor (p g s)))]
-> g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s))
whileAnyContinues :: (g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s)))
-> (g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s)))
-> g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s))
recurseTotal :: s -> g (GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s))
-> [(s, g (GrammarFunctor (p g s)))]
-> g (GrammarFunctor (p g s))
-> g (GrammarFunctor (p g s))
recurseMarginal :: s -> [(s, g (GrammarFunctor (p g s)))]
-> g (GrammarFunctor (p g s))
-> g (GrammarFunctor (p g s))
maybeDependencies :: g (Const (Maybe (Dependencies g)))
maybeDependency :: SeparatedParser p g s r -> Const (Maybe (Dependencies g)) r
appends :: g (ResultAppend p g s)
parserAppend :: SeparatedParser p g s r -> ResultAppend p g s r
directs = Rank2.fmap backParser parsers
indirects = Rank2.fmap (\p-> case p of {CycleParser{}-> cycleParser p; _ -> empty}) parsers
appends = Rank2.fmap parserAppend parsers
parserAppend p@CycleParser{} = appendResultsArrow p
parserAppend _ = Rank2.Arrow (Rank2.Arrow . const)
maybeDependencies = Rank2.fmap maybeDependency parsers
maybeDependency p@CycleParser{} = Const (Just $ dependencies p)
maybeDependency _ = Const Nothing
-- Fix the recursive knot on the head of the input, given its already-fixed tail and the initial record of
-- directly parsed results.
fixRecursive s parsedTail initial =
whileAnyContinues (recurseTotal s (appends Rank2.<*> initial) parsedTail)
(recurseMarginal s parsedTail)
initial initial
-- Loop accumulating the total parsing results from marginal results as long as there is any new marginal
-- result to expand a total one or a new failure expactation to augment an existing failure.
whileAnyContinues ft fm total marginal =
Rank2.liftA3 choiceWhile maybeDependencies total (whileAnyContinues ft fm (ft total) (fm marginal))
where choiceWhile :: Const (Maybe (Dependencies g)) x
-> GrammarFunctor (p g s) x -> GrammarFunctor (p g s) x
-> GrammarFunctor (p g s) x
choiceWhile (Const Nothing) t _ = t
choiceWhile (Const (Just (StaticDependencies deps))) t t'
| getAny (Rank2.foldMap (Any . getConst) (Rank2.liftA2 combine deps marginal)) = t'
| hasSuccess t = t
| otherwise =
failWith (failureOf $
if getAny (Rank2.foldMap (Any . getConst) $
Rank2.liftA2 (combineFailures $ failureOf t) deps marginal)
then t' else t)
where combine :: Const Bool x -> GrammarFunctor (p g s) x -> Const Bool x
combineFailures :: ParseFailure Pos s -> Const Bool x -> GrammarFunctor (p g s) x
-> Const Bool x
combine (Const False) _ = Const False
combine (Const True) results = Const (hasSuccess results)
combineFailures _ (Const False) _ = Const False
combineFailures (ParseFailure pos (FailureDescription expected inputs) errors) (Const True) rl =
Const (pos < pos'
|| pos == pos' && (any (`notElem` expected) expected'
|| any (`notElem` expected) expected')
|| any (`notElem` errors) errors')
where ParseFailure pos' (FailureDescription expected' inputs') errors' = failureOf rl
choiceWhile (Const (Just DynamicDependencies)) t t'
| getAny (Rank2.foldMap (Any . hasSuccess) marginal) = t'
| hasSuccess t = t
| ParseFailure _ (FailureDescription [] []) [] <- failureOf t = t'
| otherwise = t
-- Adds another round of indirect parsing results to the total results accumulated so far.
recurseTotal s initialAppends parsedTail total = Rank2.liftA2 reparse initialAppends indirects
where reparse :: (GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s)) a -> p g s a
-> GrammarFunctor (p g s) a
reparse append p = Rank2.apply append (parseTails p $ (s, total) : parsedTail)
-- Calculates the next round of indirect parsing results from the previous marginal round.
recurseMarginal s parsedTail marginal =
flip parseTails ((s, marginal) : parsedTail) Rank2.<$> indirects
{-# NOINLINE parseSeparated #-}