grammatical-parsers 0.1 → 0.2

raw patch · 13 files changed

+1093/−499 lines, 13 filesdep ~grammatical-parsersdep ~rank2classesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: grammatical-parsers, rank2classes

API changes (from Hackage documentation)

Files

• README.md +1/−1
• examples/Arithmetic.hs +2/−5
• examples/Comparisons.hs +2/−2
• grammatical-parsers.cabal +8/−7
• src/Text/Grampa.hs +1/−3
• src/Text/Grampa/Class.hs +15/−9
• src/Text/Grampa/ContextFree/LeftRecursive.hs +551/−351
• src/Text/Grampa/ContextFree/Memoizing.hs +128/−72
• src/Text/Grampa/ContextFree/Parallel.hs +52/−33
• src/Text/Grampa/Internal.hs +37/−0
• src/Text/Grampa/PEG/Backtrack.hs +51/−9
• src/Text/Grampa/PEG/Backtrack/Length.hs +202/−0
• src/Text/Grampa/PEG/Packrat.hs +43/−7

@@ -1,7 +1,7 @@ Grammatical Parsers =================== -Behold, yet another parser combinator library in Haskell.+Behold, yet another parser combinator library in Haskell. Except this one is capable of working with grammars rather than mere parsers. A more in-depth description is available in the [paper](../Grampa.lhs.pdf) from Haskell Symposium 2017, what follows is a short tutorial.  You can apply the usual [Applicative](http://hackage.haskell.org/package/base/docs/Control-Applicative.html#t:Applicative),

@@ -67,12 +67,9 @@ instance Rank2.Applicative (Arithmetic e) where    pure f = Arithmetic f f f f f +instance Rank2.DistributiveTraversable (Arithmetic e)+ instance Rank2.Distributive (Arithmetic e) where-   distributeM f = Arithmetic{expr= f >>= expr,-                              sum= f >>= sum,-                              product= f >>= product,-                              factor= f >>= factor,-                              primary= f >>= primary}    distributeWith w f = Arithmetic{expr= w (expr <$> f),                                    sum= w (sum <$> f),                                    product= w (product <$> f),

@@ -48,9 +48,9 @@ instance Rank2.Applicative (Comparisons c e) where    pure f = Comparisons f f +instance Rank2.DistributiveTraversable (Comparisons c e)+ instance Rank2.Distributive (Comparisons c e) where-   distributeM f = Comparisons{test= f >>= test,-                               term= f >>= term}    distributeWith w f = Comparisons{test= w (test <$> f),                                     term= w (term <$> f)} 

@@ -1,5 +1,5 @@ name:                grammatical-parsers-version:             0.1+version:             0.2 synopsis:            parsers that can combine into grammars description:   /Gram/matical-/pa/rsers, or Grampa for short, is a library of parser types whose values are meant to be assigned@@ -27,16 +27,16 @@                        Text.Grampa.PEG.Backtrack, Text.Grampa.PEG.Packrat,                        Text.Grampa.ContextFree.Parallel, Text.Grampa.ContextFree.Memoizing,                        Text.Grampa.ContextFree.LeftRecursive-  other-modules:       Text.Grampa.Class+  other-modules:       Text.Grampa.Class, Text.Grampa.Internal, Text.Grampa.PEG.Backtrack.Length   default-language:    Haskell2010   -- other-modules:   ghc-options:         -Wall   build-depends:       base >=4.7 && <5,-                       rank2classes < 1.0,                        containers >= 0.4 && < 0.6,                        transformers >= 0.5 && < 0.6,                        monoid-subclasses >=0.4 && <0.5,-                       parsers < 0.13+                       parsers < 0.13,+                       rank2classes < 1.0   -- hs-source-dirs:         default-language:    Haskell2010 @@ -46,7 +46,8 @@   other-modules:       Arithmetic, Boolean, Combined, Comparisons, Conditionals, Lambda, Utilities   default-language:    Haskell2010   build-depends:       base >=4.7 && <5, containers >= 0.5.7.0 && < 0.6,-                       rank2classes < 1.0, grammatical-parsers == 0.1,+                       parsers < 0.13,+                       rank2classes < 1.0, grammatical-parsers,                        monoid-subclasses >=0.4 && <0.5  test-suite           quicktests@@ -54,7 +55,7 @@   hs-source-dirs:    test, examples   x-uses-tf:         true   build-depends:     base >=4.7 && < 5, monoid-subclasses < 0.5, parsers < 0.13,-                     rank2classes < 1.0, grammatical-parsers == 0.1,+                     rank2classes < 1.0, grammatical-parsers,                      QuickCheck >= 2 && < 3, checkers >= 0.4.6 && < 0.5, testing-feat < 0.5,                      tasty >= 0.7, tasty-quickcheck >= 0.7   main-is:           Test.hs@@ -73,7 +74,7 @@   type:              exitcode-stdio-1.0   hs-source-dirs:    test, examples   ghc-options:       -O2 -Wall -rtsopts -main-is Benchmark.main-  Build-Depends:     base >=4.7 && < 5, rank2classes < 1.0, grammatical-parsers == 0.1, monoid-subclasses >=0.4 && <0.5,+  Build-Depends:     base >=4.7 && < 5, rank2classes < 1.0, grammatical-parsers, monoid-subclasses >=0.4 && <0.5,                      criterion >= 1.0, deepseq >= 1.1, containers >= 0.5.7.0 && < 0.6, text >= 1.1   main-is:           Benchmark.hs   other-modules:     Arithmetic

@@ -18,7 +18,6 @@ import Text.Parser.Combinators (Parsing((<?>), notFollowedBy, skipMany, skipSome, unexpected)) import Text.Parser.LookAhead (LookAheadParsing(lookAhead)) -import Data.Functor.Compose (Compose(..)) import qualified Rank2 import Text.Grampa.Class (MultiParsing(..), GrammarParsing(..), MonoidParsing(..), ParseResults, ParseFailure(..)) @@ -34,6 +33,5 @@    = g (p g' s) -> g (p g' s)  -- | Apply the given 'parse' function to the given grammar-free parser and its input.-simply :: (Rank2.Only r (p (Rank2.Only r) s) -> s -> Rank2.Only r f)-            -> p (Rank2.Only r) s r -> s -> f r+simply :: (Rank2.Only r (p (Rank2.Only r) s) -> s -> Rank2.Only r f) -> p (Rank2.Only r) s r -> s -> f r simply parseGrammar p input = Rank2.fromOnly (parseGrammar (Rank2.Only p) input)

@@ -10,7 +10,6 @@ import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid) import GHC.Exts (Constraint)-import Text.Parser.Combinators (Parsing)  import qualified Rank2 @@ -33,8 +32,7 @@    type GrammarConstraint m (g :: (* -> *) -> *) :: Constraint    type GrammarConstraint m g = Rank2.Functor g    -- | Given a rank-2 record of parsers and input, produce a record of parses of the complete input.-   parseComplete :: (GrammarConstraint m g, FactorialMonoid s) =>-                    g (m g s) -> s -> g (ResultFunctor m)+   parseComplete :: (GrammarConstraint m g, FactorialMonoid s) => g (m g s) -> s -> g (ResultFunctor m)    -- | Given a rank-2 record of parsers and input, produce a record of prefix parses paired with the remaining input    -- suffix.    parsePrefix :: (GrammarConstraint m g, FactorialMonoid s) =>@@ -44,11 +42,11 @@ class MultiParsing m => GrammarParsing m where    type GrammarFunctor m :: ((* -> *) -> *) -> * -> * -> *    -- | Used to reference a grammar production, only necessary from outside the grammar itself-   nonTerminal :: (g (GrammarFunctor m g s) -> GrammarFunctor m g s a) -> m g s a+   nonTerminal :: GrammarConstraint m g => (g (GrammarFunctor m g s) -> GrammarFunctor m g s a) -> m g s a    -- | Construct a grammar whose every production refers to itself.-   selfReferring :: Rank2.Distributive g => g (m g s)+   selfReferring :: (GrammarConstraint m g, Rank2.Distributive g) => g (m g s)    -- | Convert a self-referring grammar function to a grammar.-   fixGrammar :: forall g s. Rank2.Distributive g => (g (m g s) -> g (m g s)) -> g (m g s)+   fixGrammar :: forall g s. (GrammarConstraint m g, Rank2.Distributive g) => (g (m g s) -> g (m g s)) -> g (m g s)    -- | Mark a parser that relies on primitive recursion to prevent an infinite loop in 'fixGrammar'.    recursive :: m g s a -> m g s a @@ -61,7 +59,7 @@    -- | A parser that fails on any input and succeeds at its end.    endOfInput :: FactorialMonoid s => m s ()    -- | Always sucessful parser that returns the remaining input without consuming it.-   getInput :: MonoidNull s => m s s+   getInput :: FactorialMonoid s => m s s     -- | A parser that accepts any single input atom.    anyToken :: FactorialMonoid s => m s s@@ -69,9 +67,17 @@    token :: (Eq s, FactorialMonoid s) => s -> m s s    -- | A parser that accepts an input atom only if it satisfies the given predicate.    satisfy :: FactorialMonoid s => (s -> Bool) -> m s s-   -- | Specialization of 'satisfy' on 'TextualMonoid' inputs, accepting an input character only if it satisfies the-   -- given predicate.+   -- | Specialization of 'satisfy' on 'TextualMonoid' inputs, accepting and returning an input character only if it+   -- satisfies the given predicate.    satisfyChar :: TextualMonoid s => (Char -> Bool) -> m s Char+   -- | Specialization of 'satisfy' on 'TextualMonoid' inputs, accepting an input character only if it satisfies the+   -- given predicate, and returning the input atom that represents the character. A faster version of @singleton <$>+   -- satisfyChar p@ and of @satisfy (fromMaybe False p . characterPrefix)@.+   satisfyCharInput :: TextualMonoid s => (Char -> Bool) -> m s s+   -- | A parser that succeeds exactly when satisfy doesn't, equivalent to @notFollowedBy . satisfy@+   notSatisfy :: FactorialMonoid s => (s -> Bool) -> m s ()+   -- | A parser that succeeds exactly when satisfyChar doesn't, equivalent to @notFollowedBy . satisfyChar@+   notSatisfyChar :: TextualMonoid s => (Char -> Bool) -> m s ()     -- | A stateful scanner. The predicate modifies a state argument, and each transformed state is passed to successive    -- invocations of the predicate on each token of the input until one returns 'Nothing' or the input ends.

@@ -1,23 +1,17 @@-{-# LANGUAGE FlexibleContexts, GADTs, InstanceSigs, GeneralizedNewtypeDeriving,-             RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, InstanceSigs,+             RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} {-# OPTIONS -fno-full-laziness #-}-module Text.Grampa.ContextFree.LeftRecursive (Parser)+module Text.Grampa.ContextFree.LeftRecursive (Fixed, Parser, SeparatedParser(..), longest, peg, terminalPEG, +                                              parseSeparated, separated, (<<|>)) where  import Control.Applicative-import Control.Arrow((&&&)) import Control.Monad (Monad(..), MonadPlus(..)) import Control.Monad.Trans.State.Lazy (State, evalState, get, put)  import Data.Char (isSpace)-import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.IntMap (IntMap)-import Data.IntSet (IntSet)-import Data.Maybe (isJust, maybe)--import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet+import Data.Maybe (isJust)  import Data.Monoid (Monoid(mempty), All(..), Any(..), (<>)) import Data.Monoid.Null (MonoidNull(null))@@ -35,42 +29,87 @@  import qualified Rank2 import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults)+import Text.Grampa.Internal (BinTree(EmptyTree)) import Text.Grampa.ContextFree.Memoizing (ResultList(..), fromResultList) import qualified Text.Grampa.ContextFree.Memoizing as Memoizing+import qualified Text.Grampa.PEG.Backtrack.Length as Backtrack -import Prelude hiding (null, showsPrec, span, takeWhile)+import Prelude hiding (cycle, null, span, takeWhile) -data Parser g s a where-   NonTerminal   :: (g (Parser g s) -> Parser g s a) -> Parser g s a-   Primitive     :: String -> Maybe (Memoizing.Parser g s a) -> Maybe (Memoizing.Parser g s a)-                 -> Memoizing.Parser g s a -> Parser g s a-   Recursive     :: Parser g s a -> Parser g s a-   Map           :: (a -> b) -> Parser g s a -> Parser g s b-   Ap            :: Parser g s (a -> b) -> Parser g s a -> Parser g s b-   Pure          :: a -> Parser g s a-   Empty         :: Parser g s a-   Bind          :: Parser g s a -> (a -> Parser g s b) -> Parser g s b-   Choice        :: Parser g s a -> Parser g s a -> Parser g s a-   Try           :: Parser g s a -> Parser g s a-   Describe      :: Parser g s a -> String -> Parser g s a-   NotFollowedBy :: Show a => Parser g s a -> Parser g s ()-   Lookahead     :: Parser g s a -> Parser g s a-   Many          :: Parser g s a -> Parser g s [a]-   Some          :: Parser g s a -> Parser g s [a]-   ConcatMany    :: Monoid a => Parser g s a -> Parser g s a-   ResultsWrap   :: ResultList g s a -> Parser g s a-   Index         :: Int -> Parser g s a+type Parser = Fixed Memoizing.Parser --- | Parser of general context-free grammars, including left recursion. O(n³) performance.+data Fixed p g s a =+   Parser {+      complete, direct, direct0, direct1, indirect :: p g s a,+      cyclicDescendants :: Rank2.Apply g => g (Const (ParserFlags g)) -> ParserFlags g}+   | DirectParser {+      complete, direct0, direct1 :: p g s a}+   | PositiveDirectParser {+      complete :: p g s a}++data SeparatedParser p g s a = FrontParser (p g s a)+                             | CycleParser {+                                  cycleParser  :: p g s a,+                                  backParser   :: p g s a,+                                  dependencies :: g (Const Bool)}+                             | BackParser {+                                  backParser :: p g s a}++data ParserFlags g = ParserFlags {+   nullable :: Bool,+   dependsOn :: g (Const Bool)}++deriving instance Show (g (Const Bool)) => Show (ParserFlags g)++data ParserFunctor g s a = ParserResultsFunctor {parserResults :: ResultList g s a}+                         | ParserFlagsFunctor {parserFlags :: ParserFlags g}++newtype Union (g :: (* -> *) -> *) = 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) => Monoid (Union g) where+   mempty = Union (Rank2.distributeWith (Const . getConst) (Const False))+   mappend (Union g1) (Union g2) = Union (Rank2.liftA2 union g1 g2)++general, general' :: 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',+   cyclicDescendants= cyclicDescendants p'}+   where p' = general' p++general' p@PositiveDirectParser{} = Parser{+   complete= complete p,+   direct = complete p,+   direct0= empty,+   direct1= complete p,+   indirect= empty,+   cyclicDescendants= \cd-> ParserFlags False (const (Const False) Rank2.<$> cd)}+general' p@DirectParser{} = Parser{+   complete= complete p,+   direct = complete p,+   direct0= direct0 p,+   direct1= direct1 p,+   indirect= empty,+   cyclicDescendants= \cd-> ParserFlags True (const (Const False) Rank2.<$> cd)}+general' p@Parser{} = p++-- | Parser of general context-free grammars, including left recursion. -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Apply' g, "Rank2".'Rank2.Traversable' g, 'FactorialMonoid' s) =>---                  g (LeftRecursive.'Parser' g s) -> s -> g ('Compose' 'ParseResults' [])+--                  g (LeftRecursive.'Fixed g s) -> s -> g ('Compose' 'ParseResults' []) -- @-instance MultiParsing Parser where-   type GrammarConstraint Parser g = (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)-   type ResultFunctor Parser = Compose ParseResults []-   parsePrefix :: (Rank2.Apply g, Rank2.Traversable g, FactorialMonoid s) =>+instance MultiParsing (Fixed Memoizing.Parser) where+   type GrammarConstraint (Fixed Memoizing.Parser) g = (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)+   type ResultFunctor (Fixed Memoizing.Parser) = Compose ParseResults []+   parsePrefix :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, FactorialMonoid s) =>                   g (Parser g s) -> s -> g (Compose (Compose ParseResults []) ((,) s))    parsePrefix g input = Rank2.fmap (Compose . Compose . fromResultList input)                                     (snd $ head $ parseRecursive g input)@@ -80,369 +119,530 @@                                       (snd $ head $ Memoizing.reparseTails close $ parseRecursive g input)       where close = Rank2.fmap (<* endOfInput) selfReferring -instance GrammarParsing Parser where-   type GrammarFunctor Parser = Parser-   nonTerminal = NonTerminal-   recursive = Recursive+instance GrammarParsing (Fixed Memoizing.Parser) where+   type GrammarFunctor (Fixed Memoizing.Parser) = ParserFunctor+   nonTerminal :: forall g s a. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)+                  => (g (ParserFunctor g s) -> ParserFunctor g s a) -> Parser g s a+   nonTerminal f = Parser{+      complete= ind,+      direct= empty,+      direct0= empty,+      direct1= empty,+      indirect= ind,+      cyclicDescendants= parserFlags . f . Rank2.fmap (ParserFlagsFunctor . getConst) . addSelf}+      where ind = nonTerminal (parserResults . f . Rank2.fmap ParserResultsFunctor)+            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 d)) =+               Const ParserFlags{+                  nullable= n, +                  dependsOn= Rank2.liftA2 union bit d}+   {-# INLINE nonTerminal #-}+   recursive = general -instance (Rank2.Distributive g, Rank2.Traversable g) => Show (Parser g s a) where-   show (NonTerminal accessor) = "nt" ++ show i-      where Index i = accessor orderedSelfReferring-   show (Primitive name _ _ _) = name-   show Recursive{} = "recursive"-   show (Map _ ast) = "(f <$> " ++ shows ast ")"-   show (Ap f p) = "(" ++ show f ++ " <*> " ++ shows p ")"-   show (Pure _) = "pure x"-   show Empty = "empty"-   show (Bind ast _) = "(" ++ show ast ++ " >>= " ++ ")"-   show (Choice l r) = "(" ++ show l ++ " <|> " ++ shows r ")"-   show (Try ast) = "(try " ++ shows ast ")"-   show (Describe ast msg) = "(" ++ shows ast (" <?> " ++ shows msg ")")-   show (NotFollowedBy ast) = "(notFollowedBy " ++ shows ast ")"-   show (Lookahead ast) = "(lookAhead " ++ shows ast ")"-   show (Many ast) = "(many " ++ shows ast ")"-   show (Some ast) = "(some " ++ shows ast ")"-   show (ConcatMany ast) = "(concatMany " ++ shows ast ")"-   show Index{} = error "Index should be temporary only"-   show ResultsWrap{} = error "ResultsWrap should be temporary only"+bits :: forall (g :: (* -> *) -> *). (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 <- get; let {i' = succ i}; seq i' (put i'); return (Const i)} -instance (Rank2.Distributive g, Rank2.Traversable g) => Show1 (Parser g s) where-   liftShowsPrec _showsPrec _showList _prec (NonTerminal accessor) _rest = "nt" ++ show i-      where Index i = accessor orderedSelfReferring-   liftShowsPrec _showsPrec _showL _prec (Primitive name _ _ _) rest = name ++ rest-   liftShowsPrec _showsPrec _showL _prec Recursive{} rest = "recursive" ++ rest-   liftShowsPrec _showsPrec _showL _prec (Map _ ast) rest = "(f <$> " ++ shows ast (")" ++ rest)-   liftShowsPrec _showsPrec _showL _prec (Ap f p) rest = "(" ++ show f ++ " <*> " ++ shows p (")" ++ rest)-   liftShowsPrec  showsPrec _showL  prec (Pure x) rest = "pure " ++ showsPrec prec x rest-   liftShowsPrec _showsPrec _showL _prec Empty _rest = "empty"-   liftShowsPrec _showsPrec _showL _prec (Bind ast _) rest = "(" ++ shows ast (" >>= " ++ ")" ++ rest)-   liftShowsPrec _showsPrec _showL _prec (Choice l r) rest = "(" ++ show l ++ " <|> " ++ shows r (")" ++ rest)-   liftShowsPrec _showsPrec _showL _prec (Try ast) rest = "(try " ++ shows ast (")" ++ rest)-   liftShowsPrec _showsPrec _showL _prec (Describe ast msg) rest = "(" ++ shows ast (" <?> " ++ shows msg (")" ++ rest))-   liftShowsPrec _showsPrec _showL _prec (NotFollowedBy ast) rest = "(notFollowedBy " ++ shows ast (")" ++ rest)-   liftShowsPrec _showsPrec _showL _prec (Lookahead ast) rest = "(lookAhead " ++ shows ast (")" ++ rest)-   liftShowsPrec _showsPrec _showL _prec (Many ast) rest = "(many " ++ shows ast (")" ++ rest)-   liftShowsPrec _showsPrec _showL _prec (Some ast) rest = "(some " ++ shows ast (")" ++ rest)-   liftShowsPrec _showsPrec _showL _prec (ConcatMany ast) rest = "(concatMany " ++ shows ast (")" ++ rest)-   liftShowsPrec _showsPrec _showL _prec Index{} _rest = error "Index should be temporary only"-   liftShowsPrec _showsPrec _showL _prec ResultsWrap{} _rest = error "ResultsWrap should be temporary only"+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)}+   {-# INLINABLE fmap #-} -instance Functor (Parser g s) where-   fmap _ Empty = Empty-   fmap f ast = Map f ast+instance 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{} = 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,+      cyclicDescendants= \deps-> let+           pcd@(ParserFlags pn pd) = cyclicDescendants p' deps+           ParserFlags qn qd = cyclicDescendants q deps+        in if pn+           then ParserFlags qn (Rank2.liftA2 union pd qd)+           else pcd}+      where p'@Parser{} = general' p+   p <*> q = 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',+      cyclicDescendants= \deps-> let+           pcd@(ParserFlags pn pd) = cyclicDescendants p' deps+           ParserFlags qn qd = cyclicDescendants q' deps+        in if pn+           then ParserFlags qn (Rank2.liftA2 union pd qd)+           else pcd}+      where p'@Parser{} = general' p+            q'@Parser{} = general' q+   {-# INLINABLE pure #-}+   {-# INLINABLE (<*>) #-} -instance Applicative (Parser g s) where-   pure = Pure-   Empty <*> _ = Empty-   _ <*> Empty = Empty-   p <*> q = Ap p q+instance 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',+                    cyclicDescendants= \deps-> let+                         ParserFlags pn pd = cyclicDescendants p' deps+                         ParserFlags qn qd = cyclicDescendants q' deps+                      in ParserFlags (pn || qn) (Rank2.liftA2 union 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{} = Parser{+      complete= mcp,+      direct= d0 <|> d1,+      direct0= d0,+      direct1= d1,+      indirect= (:) <$> indirect p <*> mcp,+      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{} = Parser{+      complete= some (complete p),+      direct= d0 <|> d1,+      direct0= d0,+      direct1= d1,+      indirect= (:) <$> indirect p <*> many (complete p),+      cyclicDescendants= cyclicDescendants p}+      where d0 = (:[]) <$> direct0 p+            d1= (:) <$> direct1 p <*> many (complete p)+   {-# INLINABLE (<|>) #-}+   {-# INLINABLE many #-}+   {-# INLINABLE some #-} -instance Alternative (Parser g s) where-   empty = Empty-   Empty <|> ast = ast-   ast <|> Empty = ast-   p <|> q = Choice p q-   many Empty = pure []-   many ast = Many ast-   some Empty = Empty-   some ast = Some ast+infixl 3 <<|>+(<<|>) :: Parser g s a -> Parser g s a -> Parser g s a+p@DirectParser{} <<|> q@PositiveDirectParser{} = DirectParser{+   complete= complete p Memoizing.<<|> complete q,+   direct0 = direct0 p,+   direct1= direct1 p Memoizing.<<|> complete q}+p@DirectParser{} <<|> q@DirectParser{} = DirectParser{+   complete= complete p Memoizing.<<|> complete q,+   direct0 = direct0 p Memoizing.<<|> direct0 q,+   direct1= direct1 p Memoizing.<<|> direct1 q}+p <<|> q = Parser{complete= complete p' Memoizing.<<|> complete q',+                 direct= direct p' Memoizing.<<|> direct q',+                 direct0= direct0 p' Memoizing.<<|> direct0 q',+                 direct1= direct1 p' Memoizing.<<|> direct1 q',+                 indirect= indirect p' Memoizing.<<|> indirect q',+                 cyclicDescendants= \deps-> let+                         ParserFlags pn pd = cyclicDescendants p' deps+                         ParserFlags qn qd = cyclicDescendants q' deps+                      in ParserFlags (pn || qn) (Rank2.liftA2 union pd qd)}+   where p'@Parser{} = general p+         q'@Parser{} = general q -instance Monad (Parser g s) where+union :: Const Bool x -> Const Bool x -> Const Bool x+union (Const False) d = d+union (Const True) _ = Const True++instance (Alternative (p g s), Monad (p g s)) => Monad (Fixed p g s) where    return = pure    (>>) = (*>)-   Empty >>= _ = Empty-   ast >>= cont = Bind ast cont+   PositiveDirectParser p >>= cont = PositiveDirectParser (p >>= complete . cont)+   p@DirectParser{} >>= cont = Parser{+      complete= complete p >>= complete . cont,+      direct= d0 <|> d1,+      direct0= d0,+      direct1= d1,+      indirect= direct0 p >>= indirect . general' . cont,+      cyclicDescendants= \cd-> (ParserFlags True $ Rank2.fmap (const $ Const True) cd)}+      where d0 = direct0 p >>= direct0 . general' . cont+            d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont)+   p >>= cont = Parser{+      complete= complete p >>= complete . cont,+      direct= d0 <|> d1,+      direct0= d0,+      direct1= d1,+      indirect= (indirect p >>= complete . cont) <|> (direct0 p >>= indirect . general' . cont),+      cyclicDescendants= \cd-> (ParserFlags True $ Rank2.fmap (const $ Const True) cd)}+      where d0 = direct0 p >>= direct0 . general' . cont+            d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont) -instance MonadPlus (Parser g s) where+instance MonadPlus (p g s) => MonadPlus (Fixed p g s) where    mzero = empty    mplus = (<|>) -instance Monoid x => Monoid (Parser g s x) where+instance (Alternative (p g s), Monoid x) => Monoid (Fixed p g s x) where    mempty = pure mempty    mappend = liftA2 mappend -instance MonoidNull s => Parsing (Parser g s) where-   eof = Primitive "eof" (Just eof) Nothing eof-   try Empty = Empty-   try ast = Try ast-   Empty <?> _ = Empty-   ast <?> msg = Describe ast msg-   notFollowedBy = NotFollowedBy-   unexpected msg = Primitive "unexpected" Nothing (Just $ unexpected msg) (unexpected msg)-   skipMany = ConcatMany . (() <$)+primitive :: String -> p g s a -> p g s a -> p g s a -> Fixed p g s a+primitive _name d0 d1 d = DirectParser{complete= d,+                                       direct0= d0,+                                       direct1= d1} -instance MonoidNull s => LookAheadParsing (Parser g s) where-   lookAhead = Lookahead+positivePrimitive :: String -> p g s a -> Fixed p g s a+positivePrimitive _name p = PositiveDirectParser{complete= p} -instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where-   satisfy = satisfyChar-   string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)-   text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t)+instance (LookAheadParsing (p g s), MonoidParsing (Fixed p g)) => Parsing (Fixed p g s) where+   eof = primitive "eof" 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{} = 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 = 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{} = Parser{+      complete= notFollowedBy (complete p),+      direct= notFollowedBy (direct p),+      direct0= notFollowedBy (direct p),+      direct1= empty,+      indirect= notFollowedBy (indirect p),+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}+   unexpected msg = positivePrimitive "unexpected" (unexpected msg)+   skipMany p = concatMany (() <$ p) -instance (Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = () <$ takeCharsWhile1 isSpace+instance (LookAheadParsing (p g s), MonoidParsing (Fixed p g)) => 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{} = Parser{+      complete= lookAhead (complete p),+      direct= lookAhead (direct p),+      direct0= lookAhead (direct p),+      direct1= empty,+      indirect= lookAhead (indirect p),+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}} -instance MonoidParsing (Parser g) where-   endOfInput = Primitive "endOfInput" (Just endOfInput) Nothing endOfInput-   getInput = Primitive "getInput" (Just $ eof *> getInput) (Just $ notFollowedBy eof *> getInput) getInput-   anyToken = Primitive "anyToken" Nothing (Just anyToken) anyToken-   token x = Primitive "token" Nothing (Just $ token x) (token x)-   satisfy predicate = Primitive "satisfy" Nothing (Just $ satisfy predicate) (satisfy predicate)-   satisfyChar predicate = Primitive "satisfyChar" Nothing (Just $ satisfyChar predicate) (satisfyChar predicate)-   scan s0 f = Primitive "scan" (Just $ mempty <$ notFollowedBy (() <$ p1)) (Just $ lookAhead p1 *> p) p+instance MonoidParsing (Fixed Memoizing.Parser g) where+   endOfInput = primitive "endOfInput" endOfInput empty endOfInput+   getInput = primitive "getInput" (endOfInput *> getInput) (notFollowedBy endOfInput *> getInput) getInput+   anyToken = positivePrimitive "anyToken" anyToken+   token x = positivePrimitive "token" (token x)+   satisfy predicate = positivePrimitive "satisfy" (satisfy predicate)+   satisfyChar predicate = positivePrimitive "satisfyChar" (satisfyChar predicate)+   satisfyCharInput predicate = positivePrimitive "satisfyCharInput" (satisfyCharInput predicate)+   notSatisfy predicate = primitive "notSatisfy" (notSatisfy predicate) empty (notSatisfy predicate)+   notSatisfyChar predicate = primitive "notSatisfyChar" (notSatisfyChar predicate) empty (notSatisfyChar predicate)+   scan s0 f = primitive "scan" (mempty <$ notSatisfy test) (lookAhead (satisfy test) *> p) p       where p = scan s0 f-            p1 = satisfy (isJust . f s0)-   scanChars s0 f = Primitive "scanChars" (Just $ mempty <$ notFollowedBy p1) (Just $ lookAhead p1 *> p) p+            test = isJust . f s0+   scanChars s0 f = primitive "scanChars" (mempty <$ notSatisfyChar test) (lookAhead (satisfyChar test) *> p) p       where p = scanChars s0 f-            p1 = satisfyChar (isJust . f s0)+            test = isJust . f s0    string s-      | null s = Primitive ("(string " ++ shows s ")") (Just $ string s) Nothing (string s)-      | otherwise = Primitive ("(string " ++ shows s ")") Nothing (Just $ string s) (string s)-   takeWhile predicate = Primitive "takeWhile" (Just $ mempty <$ notFollowedBy (() <$ satisfy predicate))-                                               (Just $ takeWhile1 predicate) (takeWhile predicate)-   takeWhile1 predicate = Primitive "takeWhile1" Nothing (Just $ takeWhile1 predicate) (takeWhile1 predicate)-   takeCharsWhile predicate = Primitive "takeCharsWhile" (Just $ mempty <$ notFollowedBy (satisfyChar predicate))-                                                         (Just $ takeCharsWhile1 predicate) (takeCharsWhile predicate)-   takeCharsWhile1 predicate = Primitive "takeCharsWhile1" Nothing (Just $ takeCharsWhile1 predicate)-                                                           (takeCharsWhile1 predicate)-   whiteSpace = Primitive "whiteSpace" (Just $ notFollowedBy whiteSpace) (Just whiteSpace) whiteSpace-   concatMany = ConcatMany--toParser :: (Rank2.Functor g, FactorialMonoid s) => Parser g s a -> Memoizing.Parser g s a-toParser (NonTerminal accessor) = nonTerminal (unwrap . accessor . Rank2.fmap ResultsWrap)-   where unwrap (ResultsWrap x) = x-         unwrap _ = error "should have been wrapped"-toParser (Primitive _ _ _ p) = p-toParser (Recursive ast) = toParser ast-toParser (Map f ast) = f <$> toParser ast-toParser (Ap f a) = toParser f <*> toParser a-toParser (Pure x) = pure x-toParser Empty = empty-toParser (Bind ast cont) = toParser ast >>= toParser . cont-toParser (Choice l r) = toParser l <|> toParser r-toParser (Try ast) = try (toParser ast)-toParser (Describe ast msg) = toParser ast <?> msg-toParser (NotFollowedBy ast) = notFollowedBy (toParser ast)-toParser (Lookahead ast) = lookAhead (toParser ast)-toParser (Many ast) = many (toParser ast)-toParser (Some ast) = some (toParser ast)-toParser (ConcatMany ast) = concatMany (toParser ast)-toParser Index{} = error "Index should be temporary only"-toParser ResultsWrap{} = error "ResultsWrap should be temporary only"--splitDirect :: (Rank2.Functor g, FactorialMonoid s) => Parser g s a -> (Parser g s a, Parser g s a)-splitDirect ast@NonTerminal{} = (empty, ast)-splitDirect ast@Primitive{} = (ast, empty)-splitDirect (Recursive ast) = both Recursive (splitDirect ast)-splitDirect (Map f ast) = both (f <$>) (splitDirect ast)-splitDirect (Ap f a)-   | Empty <- an = (fd <*> a, fn <*> a)-   | otherwise = (fd0 <*> ad <|> fd1 <*> a, fd0 <*> an <|> fn <*> a)-   where (fd, fn) = splitDirect f-         (ad, an) = splitDirect a-         (fd0, fd1) = splitNullable fd-splitDirect ast@Pure{} = (ast, empty)-splitDirect Empty = (Empty, Empty)-splitDirect (Bind ast cont) = (d0cd <|> (d1 >>= cont), d0cn <|> (n >>= cont))-   where (d, n) = splitDirect ast-         (d0, d1) = splitNullable d-         (d0cd, d0cn) = splitDirect (d0 >>= cont)-splitDirect (Choice l r) = (ld <|> rd, ln <|> rn)-   where (ld, ln) = splitDirect l-         (rd, rn) = splitDirect r-splitDirect (Try ast) = both try (splitDirect ast)-splitDirect (Describe ast msg) = both (<?> msg) (splitDirect ast)-splitDirect (NotFollowedBy ast) = both notFollowedBy (splitDirect ast)-splitDirect (Lookahead ast) = both lookAhead (splitDirect ast)-splitDirect ast@(Many ast1) = (pure [] <|> (:) <$> d <*> ast, (:) <$> n <*> ast)-   where (d, n) = splitDirect ast1-splitDirect (Some ast) = ((:) <$> d <*> ast', (:) <$> n <*> ast')-   where (d, n) = splitDirect ast-         ast' = Many ast-splitDirect ast@(ConcatMany ast1) = (pure mempty <|> (<>) <$> d <*> ast, (<>) <$> n <*> ast)-   where (d, n) = splitDirect ast1-splitDirect Index{} = error "Index should be temporary only"-splitDirect ResultsWrap{} = error "ResultsWrap should be temporary only"--splitNullable :: MonoidNull s => Parser g s a -> (Parser g s a, Parser g s a)-splitNullable ast@NonTerminal{} = (ast, empty)-splitNullable (Primitive name p0 p1 _) = (maybe empty (\p-> Primitive name (Just p) Nothing p) p0,-                                          maybe empty (\p-> Primitive name Nothing (Just p) p) p1)-splitNullable (Recursive ast) = both Recursive (splitNullable ast)-splitNullable (Map f ast) = both (f <$>) (splitNullable ast)-splitNullable (Ap f a)-   | Empty <- f0 = (empty, f <*> a)-   | Empty <- a0 = (empty, f <*> a)-   | otherwise = (f0 <*> a0, f1 <*> a <|> f <*> a1)-   where (f0, f1) = splitNullable f-         (a0, a1) = splitNullable a-splitNullable ast@Pure{} = (ast, empty)-splitNullable Empty = (empty, empty)-splitNullable (Bind ast cont) = (fst c0, snd c0 <|> (ast1 >>= cont))-   where (ast0, ast1) = splitNullable ast-         c0 = splitNullable (ast0 >>= cont)-splitNullable (Choice l r) = (l0 <|> r0, l1 <|> r1)-   where (l0, l1) = splitNullable l-         (r0, r1) = splitNullable r-splitNullable (Try ast) = both try (splitNullable ast)-splitNullable (Describe ast msg) = both (<?> msg) (splitNullable ast)-splitNullable ast@NotFollowedBy{} = (ast, empty)-splitNullable ast@Lookahead{} = (ast, empty)-splitNullable (Many ast) = (pure [] <|> (:[]) <$> ast0, (:) <$> ast1 <*> many ast)-   where (ast0, ast1) = splitNullable ast-splitNullable (Some ast) = ((:[]) <$> ast0, (:) <$> ast1 <*> many ast)-   where (ast0, ast1) = splitNullable ast-splitNullable (ConcatMany ast) = (pure mempty <|> ast0, (<>) <$> ast1 <*> concatMany ast)-   where (ast0, ast1) = splitNullable ast-splitNullable (ResultsWrap _) = error "ResultsWrap should be temporary only"-splitNullable (Index _) = error "Index should be temporary only"+      | null s = primitive ("(string " ++ shows s ")") (string s) empty (string s)+      | otherwise = positivePrimitive ("(string " ++ shows s ")") (string s)+   takeWhile predicate = primitive "takeWhile" (mempty <$ notSatisfy predicate)+                                               (takeWhile1 predicate) (takeWhile predicate)+   takeWhile1 predicate = positivePrimitive "takeWhile1" (takeWhile1 predicate)+   takeCharsWhile predicate = primitive "takeCharsWhile" (mempty <$ notSatisfyChar predicate)+                                                         (takeCharsWhile1 predicate) (takeCharsWhile predicate)+   takeCharsWhile1 predicate = positivePrimitive "takeCharsWhile1" (takeCharsWhile1 predicate)+   whiteSpace = primitive "whiteSpace" (notSatisfyChar isSpace) (satisfyChar isSpace *> whiteSpace) whiteSpace+   concatMany p@PositiveDirectParser{} = DirectParser{+      complete= cmp,+      direct0= d0,+      direct1= d1}+      where d0 = pure mempty+            d1 = (<>) <$> complete p <*> cmp+            cmp = concatMany (complete p)+   concatMany p@DirectParser{} = DirectParser{+      complete= cmp,+      direct0= d0,+      direct1= d1}+      where d0 = pure mempty <|> direct0 p+            d1 = (<>) <$> direct1 p <*> cmp+            cmp = concatMany (complete p)+   concatMany p@Parser{} = Parser{+      complete= cmp,+      direct= d0 <|> d1,+      direct0= d0,+      direct1= d1,+      indirect= (<>) <$> indirect p <*> cmp,+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}+      where d0 = pure mempty <|> direct0 p+            d1 = (<>) <$> direct1 p <*> cmp+            cmp = concatMany (complete p)+   {-# INLINABLE string #-} -both :: (a -> b) -> (a, a) -> (b, b)-both f (x, y) = (f x, f y)+instance MonoidParsing (Fixed Backtrack.Parser g) where+   endOfInput = primitive "endOfInput" endOfInput empty endOfInput+   getInput = primitive "getInput" (endOfInput *> getInput) (notFollowedBy endOfInput *> getInput) getInput+   anyToken = positivePrimitive "anyToken" anyToken+   token x = positivePrimitive "token" (token x)+   satisfy predicate = positivePrimitive "satisfy" (satisfy predicate)+   satisfyChar predicate = positivePrimitive "satisfyChar" (satisfyChar predicate)+   satisfyCharInput predicate = positivePrimitive "satisfyCharInput" (satisfyCharInput predicate)+   notSatisfy predicate = primitive "notSatisfy" (notSatisfy predicate) empty (notSatisfy predicate)+   notSatisfyChar predicate = primitive "notSatisfyChar" (notSatisfyChar predicate) empty (notSatisfyChar predicate)+   scan s0 f = primitive "scan" (mempty <$ notSatisfy test) (lookAhead (satisfy test) *> p) p+      where p = scan s0 f+            test = isJust . f s0+   scanChars s0 f = primitive "scanChars" (mempty <$ notSatisfyChar test) (lookAhead (satisfyChar test) *> p) p+      where p = scanChars s0 f+            test = isJust . f s0+   string s+      | null s = primitive ("(string " ++ shows s ")") (string s) empty (string s)+      | otherwise = positivePrimitive ("(string " ++ shows s ")") (string s)+   takeWhile predicate = primitive "takeWhile" (mempty <$ notSatisfy predicate)+                                               (takeWhile1 predicate) (takeWhile predicate)+   takeWhile1 predicate = positivePrimitive "takeWhile1" (takeWhile1 predicate)+   takeCharsWhile predicate = primitive "takeCharsWhile" (mempty <$ notSatisfyChar predicate)+                                                         (takeCharsWhile1 predicate) (takeCharsWhile predicate)+   takeCharsWhile1 predicate = positivePrimitive "takeCharsWhile1" (takeCharsWhile1 predicate)+   whiteSpace = primitive "whiteSpace" (notSatisfyChar isSpace) (satisfyChar isSpace *> whiteSpace) whiteSpace+   concatMany p@PositiveDirectParser{} = DirectParser{+      complete= cmp,+      direct0= d0,+      direct1= d1}+      where d0 = pure mempty+            d1 = (<>) <$> complete p <*> cmp+            cmp = concatMany (complete p)+   concatMany p@DirectParser{} = DirectParser{+      complete= cmp,+      direct0= d0,+      direct1= d1}+      where d0 = pure mempty `Backtrack.alt` direct0 p+            d1 = (<>) <$> direct1 p <*> cmp+            cmp = concatMany (complete p)+   concatMany p@Parser{} = Parser{+      complete= cmp,+      direct= d0 `Backtrack.alt` d1,+      direct0= d0,+      direct1= d1,+      indirect= (<>) <$> indirect p <*> cmp,+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}+      where d0 = pure mempty `Backtrack.alt` direct0 p+            d1 = (<>) <$> direct1 p <*> cmp+            cmp = concatMany (complete p)+   {-# INLINABLE string #-} -leftDescendants :: forall g s. (Rank2.Apply g, Rank2.Traversable g) => g (Parser g s) -> g (Const (Bool, g (Const Bool)))-leftDescendants g = evalState (Rank2.traverse (const replaceFromList) g) $ map (setToBools <$>) $-                    IntMap.elems $ calcLeftSets $ IntMap.fromList $ zip [0..] $ Rank2.foldMap successorSet g-   where replaceFromList :: State [x] (Const x y)-         replaceFromList = do next:rest <- get-                              put rest-                              return (Const next)-         setToBools :: IntSet -> g (Const Bool)-         setToBools = Rank2.traverse isElem enumeration-         isElem :: Parser g s a -> IntSet -> Const Bool a-         isElem (Index i) set = Const (IntSet.member i set)-         successorSet :: Parser g s a -> [IntSet]-         successorSet a = [leftRecursiveOn a]-         enumeration = ordered g-         universe = Rank2.foldMap (\(Index i)-> IntSet.singleton i) enumeration-         g0 = fixNullable g-         leftRecursiveOn :: Parser g s a -> IntSet-         leftRecursiveOn (NonTerminal accessor) = IntSet.singleton i-            where Index i = accessor enumeration-         leftRecursiveOn Primitive{} = mempty-         leftRecursiveOn (Recursive ast) = leftRecursiveOn ast-         leftRecursiveOn (Map _ ast) = leftRecursiveOn ast-         leftRecursiveOn (Ap f p) = leftRecursiveOn f <> if nullable g0 f then leftRecursiveOn p else mempty-         leftRecursiveOn Pure{} = mempty-         leftRecursiveOn Empty = mempty-         leftRecursiveOn (Bind ast _cont) = if nullable g0 ast then universe else leftRecursiveOn ast-         leftRecursiveOn (Choice l r) = leftRecursiveOn l <> leftRecursiveOn r-         leftRecursiveOn (Try ast) = leftRecursiveOn ast-         leftRecursiveOn (Describe ast _) = leftRecursiveOn ast-         leftRecursiveOn (NotFollowedBy ast) = leftRecursiveOn ast-         leftRecursiveOn (Lookahead ast) = leftRecursiveOn ast-         leftRecursiveOn (Many ast) = leftRecursiveOn ast-         leftRecursiveOn (Some ast) = leftRecursiveOn ast-         leftRecursiveOn (ConcatMany ast) = leftRecursiveOn ast+instance (LookAheadParsing (p g s), MonoidParsing (Fixed p g), Show s, TextualMonoid s) =>+         CharParsing (Fixed p g s) where+   satisfy = satisfyChar+   string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)+   char = satisfyChar . (==)+   notChar = satisfyChar . (/=)+   anyChar = satisfyChar (const True)+   text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -nullable :: Rank2.Functor g => g (Const Bool) -> Parser g s a -> Bool-nullable gn (NonTerminal accessor) = n == 1-   where Index n = accessor (Rank2.fmap (\(Const z)-> Index $ if z then 1 else 0) gn)-nullable _  (Primitive _name z _ _) = isJust z-nullable gn (Recursive ast) = nullable gn ast-nullable gn (Map _ ast) = nullable gn ast-nullable gn (Ap f p) = nullable gn f && nullable gn p-nullable _  Pure{} = True-nullable _  Empty = False-nullable gn (Bind ast _cont) = nullable gn ast-nullable gn (Choice l r) = nullable gn l || nullable gn r-nullable gn (Try ast) = nullable gn ast-nullable gn (Describe ast _) = nullable gn ast-nullable _  NotFollowedBy{} = True-nullable _  Lookahead{} = True-nullable _  Many{} = True-nullable gn (Some ast) = nullable gn ast-nullable _  ConcatMany{} = True+instance (LookAheadParsing (p g s), TokenParsing (p g s), MonoidParsing (Fixed p g), Show s, TextualMonoid s) => +         TokenParsing (Fixed p g s) where+   someSpace = positivePrimitive "someSpace" someSpace -fixNullable :: (Rank2.Apply g, Rank2.Foldable g) => g (Parser g s) -> g (Const Bool)-fixNullable g = go (Rank2.fmap (const $ Const True) g)-   where go gn-            | getAll (Rank2.foldMap (All . getConst) $ Rank2.liftA2 agree gn gn') = gn-            | otherwise = go gn'-            where gn' = Rank2.fmap (Const . nullable gn) g-         agree x y = Const (x == y)+-- | Turns a context-free parser into a backtracking PEG parser that consumes the longest possible prefix of the list+-- of input tails, opposite of 'peg'+longest :: FactorialMonoid s => Fixed Memoizing.Parser g s a -> Fixed Backtrack.Parser g [(s, g (ResultList g s))] a+longest (PositiveDirectParser p) = PositiveDirectParser (Memoizing.longest p)+longest p@DirectParser{} = DirectParser{complete= Memoizing.longest (complete p),+                                        direct0=  Memoizing.longest (direct0 p),+                                        direct1=  Memoizing.longest (direct1 p)}+longest p@Parser{} = Parser{complete= Memoizing.longest (complete p),+                            direct=  Memoizing.longest (direct p),+                            direct0=  Memoizing.longest (direct0 p),+                            direct1=  Memoizing.longest (direct1 p),+                            indirect=  Memoizing.longest (indirect p),+                            cyclicDescendants= cyclicDescendants p} -orderedSelfReferring :: (Rank2.Distributive g, Rank2.Traversable g) => g (Parser g s)-orderedSelfReferring = ordered (Rank2.distributeWith NonTerminal id)+-- | Turns a backtracking PEG parser of the list of input tails into a context-free parser, opposite of 'longest'+peg :: Fixed Backtrack.Parser g [(s, g (ResultList g s))] a -> Fixed Memoizing.Parser g s a+peg (PositiveDirectParser p) = PositiveDirectParser (Memoizing.peg p)+peg p@DirectParser{} = DirectParser{complete= Memoizing.peg (complete p),+                                        direct0=  Memoizing.peg (direct0 p),+                                        direct1=  Memoizing.peg (direct1 p)}+peg p@Parser{} = Parser{complete= Memoizing.peg (complete p),+                        direct=  Memoizing.peg (direct p),+                        direct0=  Memoizing.peg (direct0 p),+                        direct1=  Memoizing.peg (direct1 p),+                        indirect=  Memoizing.peg (indirect p),+                        cyclicDescendants= cyclicDescendants p} -ordered :: Rank2.Traversable g => g (Parser g s) -> g (Parser g s)-ordered g = evalState (Rank2.traverse (const increment) g) 0-   where increment :: State Int (Parser g s a)-         increment = do {n <- get; put (n+1); return (Index n)}+-- | Turns a backtracking PEG parser into a context-free parser+terminalPEG :: Monoid s => Fixed Backtrack.Parser g s a -> Fixed Memoizing.Parser g s a+terminalPEG (PositiveDirectParser p) = PositiveDirectParser (Memoizing.terminalPEG p)+terminalPEG p@DirectParser{} = DirectParser{complete= Memoizing.terminalPEG (complete p),+                                            direct0=  Memoizing.terminalPEG (direct0 p),+                                            direct1=  Memoizing.terminalPEG (direct1 p)}+terminalPEG p@Parser{} = Parser{complete= Memoizing.terminalPEG (complete p),+                                direct=  Memoizing.terminalPEG (direct p),+                                direct0=  Memoizing.terminalPEG (direct0 p),+                                direct1=  Memoizing.terminalPEG (direct1 p),+                                indirect=  Memoizing.terminalPEG (indirect p),+                                cyclicDescendants= cyclicDescendants p} -data AdvanceFront = AdvanceFront{visited       :: IntSet,-                                 cyclic        :: Bool,-                                 front         :: IntSet}-                  deriving Show+parseRecursive :: forall g s. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, FactorialMonoid s) =>+                  g (Parser g s) -> s -> [(s, g (ResultList g s))]+parseRecursive = parseSeparated . separated -calcLeftSets :: IntMap IntSet -> IntMap (Bool, IntSet)-calcLeftSets successors = (cyclic &&& visited) <$> expandPaths initialDepths-   where expandPaths :: IntMap AdvanceFront -> IntMap AdvanceFront-         expandPaths paths-            | all (IntSet.null . front) paths' = paths'-            | otherwise = expandPaths paths'-            where paths' = expandReachables <$> paths-                  expandReachables :: AdvanceFront -> AdvanceFront-                  expandReachables x = -                     AdvanceFront{visited= visited x <> front x,-                                  cyclic= cyclic x || not (IntSet.null $ IntSet.intersection (front x) (visited x)),-                                  front= IntSet.foldr' addSuccessors mempty (IntSet.difference (front x) (visited x))}-         addSuccessors :: Int -> IntSet -> IntSet-         addSuccessors node set = set <> successors IntMap.! node-         initialDepths = IntMap.mapWithKey setToFront successors-         setToFront root set = AdvanceFront{visited= mempty,-                                            cyclic= IntSet.member root set,-                                            front= set}+separated :: forall g s. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g) =>+             g (Parser g s) -> g (SeparatedParser Memoizing.Parser g s)+separated g = Rank2.liftA4 reseparate circulars cycleFollowers descendants g+   where descendants :: g (Const (g (Const Bool)))+         cycleFollowers, circulars :: g (Const Bool)+         cyclicDescendantses :: g (Const (ParserFlags g))+         leftRecursive :: forall a. Const (g (Const Bool)) a -> Const (ParserFlags g) a -> Const Bool a+         leftRecursiveDeps :: forall a. Const Bool a -> Const (ParserFlags g) a -> Const (g (Const Bool)) a+         reseparate :: forall a. Const Bool a -> Const Bool a -> Const (g (Const Bool)) a -> Parser g s a+                    -> SeparatedParser Memoizing.Parser g s a+         reseparate (Const circular) (Const follower) (Const deps) p+            | circular || leader && follower = CycleParser (indirect p) (direct p) deps+            | follower = BackParser (complete p)+            | otherwise = FrontParser (complete p)+            where leader = getAny (Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection circulars deps)+         descendants = Rank2.fmap (Const . dependsOn . getConst) cyclicDescendantses+         cyclicDescendantses = fixDescendants (Rank2.fmap (Const . cyclicDescendants . general) g)+         circulars = Rank2.liftA2 leftRecursive bits cyclicDescendantses+         cycleFollowers = getUnion (Rank2.foldMap (Union . getConst) $+                                    Rank2.liftA2 leftRecursiveDeps circulars cyclicDescendantses)+         leftRecursive (Const bit) (Const flags) =+            Const (getAny $ Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection bit $ dependsOn flags)+         leftRecursiveDeps (Const True) (Const flags) = Const (dependsOn flags)+         leftRecursiveDeps (Const False) (Const flags) = Const (Rank2.fmap (const $ Const False) (dependsOn flags))+         intersection (Const a) (Const b) = Const (a && b) -newtype Couple f a = Couple{unCouple :: (f a, f a)} deriving Show+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 depsUnion cd (Rank2.fmap (\(Const f)-> Const (f cd)) gf)+         agree (Const (ParserFlags _xn xd)) (Const (ParserFlags _yn yd)) =+            Const (getAll (Rank2.foldMap (All . getConst) (Rank2.liftA2 agree' xd yd)))+         agree' (Const x) (Const y) = Const (x == y)+         depsUnion (Const ParserFlags{dependsOn= old}) (Const (ParserFlags n new)) = +            Const (ParserFlags n $ Rank2.liftA2 union old new)+         initial = Rank2.liftA2 (\_ (Const n)-> Const (ParserFlags n (const (Const False) Rank2.<$> gf))) gf nullabilities+         nullabilities = fixNullabilities gf -parseRecursive :: forall g s. (Rank2.Apply g, Rank2.Traversable g, FactorialMonoid s) =>-                  g (Parser g s) -> s -> [(s, g (ResultList g s))]-parseRecursive ast = parseSeparated descendants (Rank2.fmap toParser indirect) (Rank2.fmap toParser direct)-   where directRecursive = Rank2.fmap (Couple . splitDirect) ast-         cyclicDescendants = leftDescendants ast-         cyclic = Rank2.fmap (mapConst fst) cyclicDescendants-         descendants = Rank2.liftA3 cond cyclic (Rank2.fmap (mapConst snd) cyclicDescendants) noDescendants-         direct = Rank2.liftA3 cond cyclic (Rank2.fmap (fst . unCouple) directRecursive) ast-         indirect = Rank2.liftA3 cond cyclic (Rank2.fmap (snd . unCouple) directRecursive) emptyGrammar-         emptyGrammar :: g (Parser g s)-         emptyGrammar = Rank2.fmap (const empty) ast-         noDescendants = Rank2.fmap (const $ Const $ Rank2.fmap (const $ Const False) ast) ast-         cond (Const False) _t f = f-         cond (Const True) t _f = t-         mapConst f (Const c) = Const (f c)+fixNullabilities :: forall g. (Rank2.Apply g, Rank2.Traversable g)+                    => g (Const (g (Const (ParserFlags g)) -> (ParserFlags g))) -> g (Const Bool)+fixNullabilities gf = Rank2.fmap (Const . nullable . getConst) (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 (const (Const False) Rank2.<$> gf))) Rank2.<$> gf  -- | Parse the given input using a context-free grammar separated into two parts: the first specifying all the -- left-recursive productions, the second all others. The first function argument specifies the left-recursive -- dependencies among the grammar productions. parseSeparated :: forall g s. (Rank2.Apply g, Rank2.Foldable g, FactorialMonoid s) =>-                  g (Const (g (Const Bool))) -> g (Memoizing.Parser g s) -> g (Memoizing.Parser g s) -> s-               -> [(s, g (ResultList g s))]-parseSeparated dependencies indirect direct input = foldr parseTail [] (Factorial.tails input)+                  g (SeparatedParser Memoizing.Parser g s) -> s -> [(s, g (ResultList 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) . Memoizing.applyParser) direct+            where parsed = (s,d''):parsedTail+                  d      = Rank2.fmap (($ (s,d):parsedTail) . Memoizing.applyParser) directs                   d'     = fixRecursive s parsedTail d-+                  d''    = Rank2.liftA2 f parsers d'+                  f :: forall a. SeparatedParser Memoizing.Parser g s a -> ResultList g s a -> ResultList g s a+                  f (FrontParser p) _ = Memoizing.applyParser p ((s,d''):parsedTail)+                  f _ result = result          fixRecursive :: s -> [(s, g (ResultList g s))] -> g (ResultList g s) -> g (ResultList g s)          whileAnyContinues :: g (ResultList g s) -> g (ResultList g s) -> g (ResultList g s)          recurseOnce :: s -> [(s, g (ResultList g s))] -> g (ResultList g s) -> g (ResultList g s)+         maybeDependencies :: g (Const (Maybe (g (Const Bool)))) +         directs = Rank2.fmap backParser parsers+         indirects = Rank2.fmap (\p-> case p of {CycleParser{}-> cycleParser p; _ -> empty}) parsers+         maybeDependencies = Rank2.fmap (Const . maybeDependency) parsers+         maybeDependency p@CycleParser{} = Just (dependencies p)+         maybeDependency _ = Nothing+                                                                             fixRecursive s parsedTail initial =             foldr1 whileAnyContinues (iterate (recurseOnce s parsedTail) initial) -         whileAnyContinues g1 g2 = Rank2.liftA3 choiceWhile dependencies g1 g2-            where choiceWhile :: Const (g (Const Bool)) x -> ResultList g i x -> ResultList g i x -> ResultList g i x+         whileAnyContinues g1 g2 = Rank2.liftA3 choiceWhile maybeDependencies g1 g2+            where choiceWhile :: Const (Maybe (g (Const Bool))) x -> ResultList g i x -> ResultList g i x +                                 -> ResultList g i x                   combine :: Const Bool x -> ResultList g i x -> Const Bool x-                  choiceWhile (Const deps) r1 r2+                  choiceWhile (Const Nothing) r1 _ = r1+                  choiceWhile (Const (Just deps)) r1 r2                      | getAny (Rank2.foldMap (Any . getConst) (Rank2.liftA2 combine deps g1)) = r1 <> r2                      | otherwise = r1                   combine (Const False) _ = Const False-                  combine (Const True) (ResultList [] _) = Const False+                  combine (Const True) (ResultList EmptyTree _) = Const False                   combine (Const True) _ = Const True -         recurseOnce s parsedTail initial = Rank2.fmap (($ parsed) . Memoizing.applyParser) indirect+         recurseOnce s parsedTail initial = Rank2.fmap (($ parsed) . Memoizing.applyParser) indirects             where parsed = (s, initial):parsedTail

@@ -1,14 +1,17 @@ {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,              RankNTypes, ScopedTypeVariables, TypeFamilies #-}-module Text.Grampa.ContextFree.Memoizing (FailureInfo(..), ResultList(..), Parser(..), fromResultList, reparseTails)+module Text.Grampa.ContextFree.Memoizing (FailureInfo(..), ResultList(..), Parser(..), BinTree(..), (<<|>),+                                          fromResultList, reparseTails, longest, peg, terminalPEG) where  import Control.Applicative import Control.Monad (Monad(..), MonadPlus(..)) import Data.Char (isSpace)+import Data.Function (on)+import Data.Foldable (toList) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.List (genericLength, nub)+import Data.List (genericLength, maximumBy, nub) import Data.Monoid (Monoid(mappend, mempty), (<>)) import Data.Monoid.Cancellative (LeftReductiveMonoid (isPrefixOf)) import Data.Monoid.Null (MonoidNull(null))@@ -17,7 +20,6 @@ import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Data.String (fromString)-import Data.Word (Word64)  import qualified Text.Parser.Char import Text.Parser.Char (CharParsing)@@ -28,69 +30,74 @@ import qualified Rank2  import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Internal (BinTree(..), FailureInfo(..))+import qualified Text.Grampa.PEG.Backtrack.Length as Backtrack  import Prelude hiding (iterate, length, null, showList, span, takeWhile)  -- | Parser for a context-free grammar with packrat-like sharing of parse results. It does not support left-recursive -- grammars. newtype Parser g s r = Parser{applyParser :: [(s, g (ResultList g s))] -> ResultList g s r}-            -data ResultList g s r = ResultList ![ResultInfo g s r] {-# UNPACK #-} !FailureInfo-data ResultInfo g s r = ResultInfo ![(s, g (ResultList g s))] !r-data FailureInfo = FailureInfo !Int Word64 [String] deriving (Eq, Show) +data ResultList g s r = ResultList !(BinTree (ResultInfo g s r)) {-# UNPACK #-} !FailureInfo+data ResultInfo g s r = ResultInfo !Int ![(s, g (ResultList g s))] !r+ instance (Show s, Show r) => Show (ResultList g s r) where    show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")")  instance Show1 (ResultList g s) where-   liftShowsPrec _sp showList _prec (ResultList l f) rest = "ResultList " ++ showList (simplify <$> l) (shows f rest)-      where simplify (ResultInfo _ r) = r+   liftShowsPrec _sp showList _prec (ResultList l f) rest = "ResultList " ++ showList (simplify <$> toList l) (shows f rest)+      where simplify (ResultInfo _ _ r) = r  instance (Show s, Show r) => Show (ResultInfo g s r) where-   show (ResultInfo t r) = "(ResultInfo @" ++ show (fst $ head t) ++ " " ++ shows r ")"+   show (ResultInfo l _ r) = "(ResultInfo @" ++ show l ++ " " ++ shows r ")"  instance Functor (ResultInfo g s) where-   fmap f (ResultInfo t r) = ResultInfo t (f r)+   fmap f (ResultInfo l t r) = ResultInfo l t (f r)  instance Functor (ResultList g s) where    fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure  instance Monoid (ResultList g s r) where-   mempty = ResultList [] mempty+   mempty = ResultList mempty mempty    ResultList rl1 f1 `mappend` ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2) -instance Monoid FailureInfo where-   mempty = FailureInfo 0 maxBound []-   f1@(FailureInfo s1 pos1 exp1) `mappend` f2@(FailureInfo s2 pos2 exp2)-      | s1 < s2 = f2-      | s1 > s2 = f1-      | otherwise = FailureInfo s1 pos' exp'-      where (pos', exp') | pos1 < pos2 = (pos1, exp1)-                         | pos1 > pos2 = (pos2, exp2)-                         | otherwise = (pos1, exp1 <> exp2)- instance Functor (Parser g i) where    fmap f (Parser p) = Parser (fmap f . p)+   {-# INLINABLE fmap #-}  instance Applicative (Parser g i) where-   pure a = Parser (\rest-> ResultList [ResultInfo rest a] mempty)+   pure a = Parser (\rest-> ResultList (Leaf $ ResultInfo 0 rest a) mempty)    Parser p <*> Parser q = Parser r where       r rest = case p rest-               of ResultList results failure -> ResultList [] failure <> foldMap continue results-      continue (ResultInfo rest' f) = f <$> q rest'-+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results+      continue (ResultInfo l rest' f) = continue' l f (q rest')+      continue' l f (ResultList rs failure) = ResultList (adjust l f <$> rs) failure+      adjust l f (ResultInfo l' rest' a) = ResultInfo (l+l') rest' (f a)+   {-# INLINABLE pure #-}+   {-# INLINABLE (<*>) #-}  instance Alternative (Parser g i) where-   empty = Parser (\rest-> ResultList [] $ FailureInfo 0 (genericLength rest) ["empty"])+   empty = Parser (\rest-> ResultList mempty $ FailureInfo 0 (genericLength rest) ["empty"])    Parser p <|> Parser q = Parser r where       r rest = p rest <> q rest+   {-# INLINABLE (<|>) #-} +infixl 3 <<|>+(<<|>) :: Parser g s a -> Parser g s a -> Parser g s a+Parser p <<|> Parser q = Parser r where+   r rest = case p rest+            of rl@(ResultList EmptyTree _failure) -> rl <> q rest+               rl -> rl+ instance Monad (Parser g i) where    return = pure    Parser p >>= f = Parser q where       q rest = case p rest-               of ResultList results failure -> ResultList [] failure <> foldMap continue results-      continue (ResultInfo rest' a) = applyParser (f a) rest'+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results+      continue (ResultInfo l rest' a) = continue' l (applyParser (f a) rest')+      continue' l (ResultList rs failure) = ResultList (adjust l <$> rs) failure+      adjust l (ResultInfo l' rest' a) = ResultInfo (l+l') rest' a  instance MonadPlus (Parser g s) where    mzero = empty@@ -104,9 +111,11 @@    type GrammarFunctor Parser = ResultList    nonTerminal f = Parser p where       p ((_, d) : _) = f d-      p _ = ResultList [] (FailureInfo 1 0 ["NonTerminal at endOfInput"])+      p _ = ResultList mempty (FailureInfo 1 0 ["NonTerminal at endOfInput"])+   {-# INLINE nonTerminal #-} --- | Memoizing parser guarantees O(n²) performance, but provides no left recursion support.+-- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions, but provides no left+-- recursion support. -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>@@ -136,60 +145,80 @@ instance MonoidParsing (Parser g) where    endOfInput = eof    getInput = Parser p-      where p rest@((s, _):_) = ResultList [ResultInfo [last rest] s] mempty-            p [] = ResultList [ResultInfo [] mempty] mempty+      where p rest@((s, _):_) = ResultList (Leaf $ ResultInfo (length rest) [last rest] s) mempty+            p [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty    anyToken = Parser p       where p rest@((s, _):t) = case splitPrimePrefix s-                                of Just (first, _) -> ResultList [ResultInfo t first] mempty-                                   _ -> ResultList [] (FailureInfo 1 (genericLength rest) ["anyToken"])-            p [] = ResultList [] (FailureInfo 1 0 ["anyToken"])+                                of Just (first, _) -> ResultList (Leaf $ ResultInfo 1 t first) mempty+                                   _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["anyToken"])+            p [] = ResultList mempty (FailureInfo 1 0 ["anyToken"])    satisfy predicate = Parser p       where p rest@((s, _):t) =                case splitPrimePrefix s-               of Just (first, _) | predicate first -> ResultList [ResultInfo t first] mempty-                  _ -> ResultList [] (FailureInfo 1 (genericLength rest) ["satisfy"])-            p [] = ResultList [] (FailureInfo 1 0 ["satisfy"])+               of Just (first, _) | predicate first -> ResultList (Leaf $ ResultInfo 1 t first) mempty+                  _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfy"])+            p [] = ResultList mempty (FailureInfo 1 0 ["satisfy"])    satisfyChar predicate = Parser p       where p rest@((s, _):t) =-               case Textual.splitCharacterPrefix s-               of Just (first, _) | predicate first -> ResultList [ResultInfo t first] mempty-                  _ -> ResultList [] (FailureInfo 1 (genericLength rest) ["satisfyChar"])-            p [] = ResultList [] (FailureInfo 1 0 ["satisfyChar"])+               case Textual.characterPrefix s+               of Just first | predicate first -> ResultList (Leaf $ ResultInfo 1 t first) mempty+                  _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfyChar"])+            p [] = ResultList mempty (FailureInfo 1 0 ["satisfyChar"])+   satisfyCharInput predicate = Parser p+      where p rest@((s, _):t) =+               case Textual.characterPrefix s+               of Just first | predicate first -> ResultList (Leaf $ ResultInfo 1 t $ Factorial.primePrefix s) mempty+                  _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfyCharInput"])+            p [] = ResultList mempty (FailureInfo 1 0 ["satisfyCharInput"])    scan s0 f = Parser (p s0)-      where p s rest@((i, _) : _) = ResultList [ResultInfo (drop (Factorial.length prefix) rest) prefix] mempty+      where p s rest@((i, _) : _) = ResultList (Leaf $ ResultInfo l (drop l rest) prefix) mempty                where (prefix, _, _) = Factorial.spanMaybe' s f i-            p _ [] = ResultList [ResultInfo [] mempty] mempty+                     l = Factorial.length prefix+            p _ [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty    scanChars s0 f = Parser (p s0)-      where p s rest@((i, _) : _) = ResultList [ResultInfo (drop (Factorial.length prefix) rest) prefix] mempty+      where p s rest@((i, _) : _) = ResultList (Leaf $ ResultInfo l (drop l rest) prefix) mempty                where (prefix, _, _) = Textual.spanMaybe_' s f i-            p _ [] = ResultList [ResultInfo [] mempty] mempty+                     l = Factorial.length prefix+            p _ [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty    takeWhile predicate = Parser p       where p rest@((s, _) : _)-               | x <- Factorial.takeWhile predicate s =-                    ResultList [ResultInfo (drop (Factorial.length x) rest) x] mempty-            p [] = ResultList [ResultInfo [] mempty] mempty+               | x <- Factorial.takeWhile predicate s, l <- Factorial.length x =+                    ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty+            p [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty    takeWhile1 predicate = Parser p       where p rest@((s, _) : _)-               | x <- Factorial.takeWhile predicate s, not (null x) =-                    ResultList [ResultInfo (drop (Factorial.length x) rest) x] mempty-            p rest = ResultList [] (FailureInfo 1 (genericLength rest) ["takeWhile1"])+               | x <- Factorial.takeWhile predicate s, l <- Factorial.length x, l > 0 =+                    ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty+            p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["takeWhile1"])    takeCharsWhile predicate = Parser p       where p rest@((s, _) : _)-               | x <- Textual.takeWhile_ False predicate s =-                    ResultList [ResultInfo (drop (Factorial.length x) rest) x] mempty-            p [] = ResultList [ResultInfo [] mempty] mempty+               | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x =+                    ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty+            p [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty    takeCharsWhile1 predicate = Parser p       where p rest@((s, _) : _)-               | x <- Textual.takeWhile_ False predicate s, not (null x) =-                    ResultList [ResultInfo (drop (Factorial.length x) rest) x] mempty-            p rest = ResultList [] (FailureInfo 1 (genericLength rest) ["takeCharsWhile1"])+               | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x, l > 0 =+                    ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty+            p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["takeCharsWhile1"])    string s = Parser p where       p rest@((s', _) : _)-         | s `isPrefixOf` s' = ResultList [ResultInfo (Factorial.drop (Factorial.length s) rest) s] mempty-      p rest = ResultList [] (FailureInfo 1 (genericLength rest) ["string " ++ show s])+         | s `isPrefixOf` s' = ResultList (Leaf $ ResultInfo l (Factorial.drop l rest) s) mempty+      p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["string " ++ show s])+      l = Factorial.length s    whiteSpace = () <$ takeCharsWhile isSpace    concatMany p = go       where go = mempty <|> (<>) <$> p <*> go+   notSatisfy predicate = Parser p+      where p rest@((s, _):_)+               | Just (first, _) <- splitPrimePrefix s, +                 predicate first = ResultList mempty (FailureInfo 1 (genericLength rest) ["notSatisfy"])+            p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty+   notSatisfyChar predicate = Parser p+      where p rest@((s, _):_)+               | Just first <- Textual.characterPrefix s, +                 predicate first = ResultList mempty (FailureInfo 1 (genericLength rest) ["notSatisfyChar"])+            p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty+   {-# INLINABLE string #-}  instance MonoidNull s => Parsing (Parser g s) where    try (Parser p) = Parser (weakenResults . p)@@ -197,21 +226,21 @@    Parser p <?> msg  = Parser (strengthenResults . p)       where strengthenResults (ResultList rl (FailureInfo s pos _msgs)) = ResultList rl (FailureInfo (succ s) pos [msg])    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))-      where rewind t (ResultList [] _) = ResultList [ResultInfo t ()] mempty-            rewind t ResultList{} = ResultList [] (FailureInfo 1 (genericLength t) ["notFollowedBy"])+      where rewind t (ResultList EmptyTree _) = ResultList (Leaf $ ResultInfo 0 t ()) mempty+            rewind t ResultList{} = ResultList mempty (FailureInfo 1 (genericLength t) ["notFollowedBy"])    skipMany p = go       where go = pure () <|> p *> go-   unexpected msg = Parser (\t-> ResultList [] $ FailureInfo 0 (genericLength t) [msg])+   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo 0 (genericLength t) [msg])    eof = Parser f       where f rest@((s, _):_)-               | null s = ResultList [ResultInfo rest ()] mempty-               | otherwise = ResultList [] (FailureInfo 1 (genericLength rest) ["endOfInput"])-            f [] = ResultList [ResultInfo [] ()] mempty+               | null s = ResultList (Leaf $ ResultInfo 0 rest ()) mempty+               | otherwise = ResultList mempty (FailureInfo 1 (genericLength rest) ["endOfInput"])+            f [] = ResultList (Leaf $ ResultInfo 0 [] ()) mempty  instance MonoidNull s => LookAheadParsing (Parser g s) where    lookAhead (Parser p) = Parser (\input-> rewind input (p input))       where rewind t (ResultList rl failure) = ResultList (rewindInput t <$> rl) failure-            rewindInput t (ResultInfo _ r) = ResultInfo t r+            rewindInput t (ResultInfo _ _ r) = ResultInfo 0 t r  instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where    satisfy = satisfyChar@@ -225,8 +254,35 @@    someSpace = () <$ takeCharsWhile1 isSpace  fromResultList :: FactorialMonoid s => s -> ResultList g s r -> ParseResults [(s, r)]-fromResultList s (ResultList [] (FailureInfo _ pos msgs)) =+fromResultList s (ResultList EmptyTree (FailureInfo _ pos msgs)) =    Left (ParseFailure (length s - fromIntegral pos + 1) (nub msgs))-fromResultList _ (ResultList rl _failure) = Right (f <$> rl)-   where f (ResultInfo ((s, _):_) r) = (s, r)-         f (ResultInfo [] r) = (mempty, r)+fromResultList _ (ResultList rl _failure) = Right (f <$> toList rl)+   where f (ResultInfo _ ((s, _):_) r) = (s, r)+         f (ResultInfo _ [] r) = (mempty, r)++-- | Turns a context-free parser into a backtracking PEG parser that consumes the longest possible prefix of the list+-- of input tails, opposite of 'peg'+longest :: FactorialMonoid s => Parser g s a -> Backtrack.Parser g [(s, g (ResultList g s))] a+longest p = Backtrack.Parser q where+   q rest = case applyParser p rest+            of ResultList EmptyTree failure -> Backtrack.NoParse failure+               ResultList rs _ -> parsed (maximumBy (compare `on` resultLength) rs)+   resultLength (ResultInfo l _ _) = l+   parsed (ResultInfo l s r) = Backtrack.Parsed l r s++-- | Turns a backtracking PEG parser of the list of input tails into a context-free parser, opposite of 'longest'+peg :: Backtrack.Parser g [(s, g (ResultList g s))] a -> Parser g s a+peg p = Parser q where+   q rest = case Backtrack.applyParser p rest+            of Backtrack.Parsed l result suffix -> ResultList (Leaf $ ResultInfo l suffix result) mempty+               Backtrack.NoParse failure -> ResultList mempty failure++-- | Turns a backtracking PEG parser into a context-free parser+terminalPEG :: Monoid s => Backtrack.Parser g s a -> Parser g s a+terminalPEG p = Parser q where+   q [] = case Backtrack.applyParser p mempty+            of Backtrack.Parsed l result _ -> ResultList (Leaf $ ResultInfo l [] result) mempty+               Backtrack.NoParse failure -> ResultList mempty failure+   q rest@((s, _):_) = case Backtrack.applyParser p s+                       of Backtrack.Parsed l result _ -> ResultList (Leaf $ ResultInfo l (drop l rest) result) mempty+                          Backtrack.NoParse failure -> ResultList mempty failure

@@ -6,6 +6,7 @@ import Control.Applicative import Control.Monad (Monad(..), MonadPlus(..)) import Data.Char (isSpace)+import Data.Foldable (toList) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (nub)@@ -27,7 +28,8 @@  import qualified Rank2 -import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..), completeParser)+import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Internal (BinTree(..))  import Prelude hiding (iterate, null, showList, span, takeWhile) @@ -35,7 +37,7 @@ -- support. newtype Parser (g :: (* -> *) -> *) s r = Parser{applyParser :: s -> ResultList s r} -data ResultList s r = ResultList ![ResultInfo s r] {-# UNPACK #-} !FailureInfo+data ResultList s r = ResultList !(BinTree (ResultInfo s r)) {-# UNPACK #-} !FailureInfo data ResultInfo s r = ResultInfo !s !r data FailureInfo = FailureInfo !Int Int [String] deriving (Eq, Show) @@ -43,7 +45,7 @@    show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")")  instance Show1 (ResultList s) where-   liftShowsPrec _sp showList _prec (ResultList l f) rest = "ResultList " ++ showList (simplify <$> l) (shows f rest)+   liftShowsPrec _sp showList _prec (ResultList l f) rest = "ResultList " ++ showList (simplify <$> toList l) (shows f rest)       where simplify (ResultInfo _ r) = r  instance (Show s, Show r) => Show (ResultInfo s r) where@@ -56,7 +58,7 @@    fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure  instance Monoid (ResultList s r) where-   mempty = ResultList [] mempty+   mempty = ResultList mempty mempty    ResultList rl1 f1 `mappend` ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2)  instance Monoid FailureInfo where@@ -73,15 +75,15 @@    fmap f (Parser p) = Parser (fmap f . p)  instance Applicative (Parser g s) where-   pure a = Parser (\rest-> ResultList [ResultInfo rest a] mempty)+   pure a = Parser (\rest-> ResultList (Leaf $ ResultInfo rest a) mempty)    Parser p <*> Parser q = Parser r where       r rest = case p rest-               of ResultList results failure -> ResultList [] failure <> foldMap continue results+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results       continue (ResultInfo rest' f) = f <$> q rest'   instance FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\s-> ResultList [] $ FailureInfo 0 (Factorial.length s) ["empty"])+   empty = Parser (\s-> ResultList mempty $ FailureInfo 0 (Factorial.length s) ["empty"])    Parser p <|> Parser q = Parser r where       r rest = p rest <> q rest @@ -89,7 +91,7 @@    return = pure    Parser p >>= f = Parser q where       q rest = case p rest-               of ResultList results failure -> ResultList [] failure <> foldMap continue results+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results       continue (ResultInfo rest' a) = applyParser (f a) rest'  instance FactorialMonoid s => MonadPlus (Parser g s) where@@ -117,49 +119,65 @@  instance MonoidParsing (Parser g) where    endOfInput = Parser f-      where f s | null s = ResultList [ResultInfo s ()] mempty-                | otherwise = ResultList [] (FailureInfo 1 (Factorial.length s) ["endOfInput"])+      where f s | null s = ResultList (Leaf $ ResultInfo s ()) mempty+                | otherwise = ResultList mempty (FailureInfo 1 (Factorial.length s) ["endOfInput"])    getInput = Parser p-      where p s = ResultList [ResultInfo mempty s] mempty+      where p s = ResultList (Leaf $ ResultInfo mempty s) mempty    anyToken = Parser p       where p s = case Factorial.splitPrimePrefix s-                  of Just (first, rest) -> ResultList [ResultInfo rest first] mempty-                     _ -> ResultList [] (FailureInfo 1 (Factorial.length s) ["anyToken"])+                  of Just (first, rest) -> ResultList (Leaf $ ResultInfo rest first) mempty+                     _ -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["anyToken"])    satisfy predicate = Parser p       where p s = case Factorial.splitPrimePrefix s-                  of Just (first, rest) | predicate first -> ResultList [ResultInfo rest first] mempty-                     _ -> ResultList [] (FailureInfo 1 (Factorial.length s) ["satisfy"])+                  of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) mempty+                     _ -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["satisfy"])    satisfyChar predicate = Parser p       where p s =                case Textual.splitCharacterPrefix s-               of Just (first, rest) | predicate first -> ResultList [ResultInfo rest first] mempty-                  _ -> ResultList [] (FailureInfo 1 (Factorial.length s) ["satisfyChar"])+               of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) mempty+                  _ -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["satisfyChar"])+   satisfyCharInput predicate = Parser p+      where p s =+               case Textual.splitCharacterPrefix s+               of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest $ Factorial.primePrefix s) mempty+                  _ -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["satisfyChar"])+   notSatisfy predicate = Parser p+      where p s = case Factorial.splitPrimePrefix s+                  of Just (first, _) +                        | predicate first -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["notSatisfy"])+                     _ -> ResultList (Leaf $ ResultInfo s ()) mempty+   notSatisfyChar predicate = Parser p+      where p s = case Textual.characterPrefix s+                  of Just first +                        | predicate first -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["notSatisfyChar"])+                     _ -> ResultList (Leaf $ ResultInfo s ()) mempty    scan s0 f = Parser (p s0)-      where p s i = ResultList [ResultInfo suffix prefix] mempty+      where p s i = ResultList (Leaf $ ResultInfo suffix prefix) mempty                where (prefix, suffix, _) = Factorial.spanMaybe' s f i    scanChars s0 f = Parser (p s0)-      where p s i = ResultList [ResultInfo suffix prefix] mempty+      where p s i = ResultList (Leaf $ ResultInfo suffix prefix) mempty                where (prefix, suffix, _) = Textual.spanMaybe_' s f i    takeWhile predicate = Parser p-      where p s | (prefix, suffix) <- Factorial.span predicate s = ResultList [ResultInfo suffix prefix] mempty+      where p s | (prefix, suffix) <- Factorial.span predicate s = ResultList (Leaf $ ResultInfo suffix prefix) mempty    takeWhile1 predicate = Parser p       where p s | (prefix, suffix) <- Factorial.span predicate s =                 if Null.null prefix-               then ResultList [] (FailureInfo 1 (Factorial.length s) ["takeWhile1"])-               else ResultList [ResultInfo suffix prefix] mempty+               then ResultList mempty (FailureInfo 1 (Factorial.length s) ["takeWhile1"])+               else ResultList (Leaf $ ResultInfo suffix prefix) mempty    takeCharsWhile predicate = Parser p-      where p s | (prefix, suffix) <- Textual.span_ False predicate s = ResultList [ResultInfo suffix prefix] mempty+      where p s | (prefix, suffix) <- Textual.span_ False predicate s = +               ResultList (Leaf $ ResultInfo suffix prefix) mempty    takeCharsWhile1 predicate = Parser p       where p s | (prefix, suffix) <- Textual.span_ False predicate s =                if null prefix-               then ResultList [] (FailureInfo 1 (Factorial.length s) ["takeCharsWhile1"])-               else ResultList [ResultInfo suffix prefix] mempty+               then ResultList mempty (FailureInfo 1 (Factorial.length s) ["takeCharsWhile1"])+               else ResultList (Leaf $ ResultInfo suffix prefix) mempty    string s = Parser p where-      p s' | Just suffix <- Cancellative.stripPrefix s s' = ResultList [ResultInfo suffix s] mempty-           | otherwise = ResultList [] (FailureInfo 1 (Factorial.length s') ["string " ++ show s])+      p s' | Just suffix <- Cancellative.stripPrefix s s' = ResultList (Leaf $ ResultInfo suffix s) mempty+           | otherwise = ResultList mempty (FailureInfo 1 (Factorial.length s') ["string " ++ show s])    whiteSpace = () <$ takeCharsWhile isSpace    concatMany (Parser p) = Parser q-      where q s = ResultList [] failure <> foldMap continue rs+      where q s = ResultList mempty failure <> foldMap continue rs                where ResultList rs failure = p s             continue (ResultInfo suffix prefix) = (prefix <>) <$> q suffix @@ -169,11 +187,11 @@    Parser p <?> msg  = Parser (strengthenResults . p)       where strengthenResults (ResultList rl (FailureInfo s pos _msgs)) = ResultList rl (FailureInfo (succ s) pos [msg])    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))-      where rewind t (ResultList [] _) = ResultList [ResultInfo t ()] mempty-            rewind t ResultList{} = ResultList [] (FailureInfo 1 (Factorial.length t) ["notFollowedBy"])+      where rewind t (ResultList EmptyTree _) = ResultList (Leaf $ ResultInfo t ()) mempty+            rewind t ResultList{} = ResultList mempty (FailureInfo 1 (Factorial.length t) ["notFollowedBy"])    skipMany p = go       where go = pure () <|> p *> go-   unexpected msg = Parser (\t-> ResultList [] $ FailureInfo 0 (Factorial.length t) [msg])+   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo 0 (Factorial.length t) [msg])    eof = endOfInput  instance FactorialMonoid s => LookAheadParsing (Parser g s) where@@ -193,6 +211,7 @@    someSpace = () <$ takeCharsWhile1 isSpace  fromResultList :: FactorialMonoid s => s -> ResultList s r -> ParseResults [(s, r)]-fromResultList s (ResultList [] (FailureInfo _ pos msgs)) = Left (ParseFailure (Factorial.length s - pos) (nub msgs))-fromResultList _ (ResultList rl _failure) = Right (f <$> rl)+fromResultList s (ResultList EmptyTree (FailureInfo _ pos msgs)) = +   Left (ParseFailure (Factorial.length s - pos) (nub msgs))+fromResultList _ (ResultList rl _failure) = Right (f <$> toList rl)    where f (ResultInfo s r) = (s, r)

@@ -0,0 +1,37 @@+module Text.Grampa.Internal (BinTree(..), FailureInfo(..)) where++import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Word (Word64)++data FailureInfo = FailureInfo !Int Word64 [String] deriving (Eq, Show)++data BinTree a = Fork !(BinTree a) !(BinTree a)+               | Leaf !a+               | EmptyTree+               deriving (Show)++instance Monoid FailureInfo where+   mempty = FailureInfo 0 maxBound []+   f1@(FailureInfo s1 pos1 exp1) `mappend` f2@(FailureInfo s2 pos2 exp2)+      | s1 < s2 = f2+      | s1 > s2 = f1+      | otherwise = FailureInfo s1 pos' exp'+      where (pos', exp') | pos1 < pos2 = (pos1, exp1)+                         | pos1 > pos2 = (pos2, exp2)+                         | otherwise = (pos1, exp1 <> exp2)++instance Functor BinTree where+   fmap f (Fork left right) = Fork (fmap f left) (fmap f right)+   fmap f (Leaf a) = Leaf (f a)+   fmap _ EmptyTree = EmptyTree++instance Foldable BinTree where+   foldMap f (Fork left right) = foldMap f left <> foldMap f right+   foldMap f (Leaf a) = f a+   foldMap _ EmptyTree = mempty++instance Monoid (BinTree a) where+   mempty = EmptyTree+   mappend EmptyTree t = t+   mappend t EmptyTree = t+   mappend l r = Fork l r

@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} -- | Backtracking parser for Parsing Expression Grammars-module Text.Grampa.PEG.Backtrack (Parser) where+module Text.Grampa.PEG.Backtrack (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2) import Control.Monad (Monad(..), MonadPlus(..))@@ -11,7 +11,7 @@ import Data.List (nub) import Data.Monoid (Monoid(mappend, mempty), (<>)) import Data.Monoid.Factorial(FactorialMonoid)-import Data.Word (Word64)+import Data.String (fromString)  import qualified Data.Monoid.Cancellative as Cancellative import qualified Data.Monoid.Factorial as Factorial@@ -20,13 +20,17 @@  import qualified Rank2 +import qualified Text.Parser.Char+import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..))+import Text.Parser.LookAhead (LookAheadParsing(..))+import Text.Parser.Token (TokenParsing(someSpace)) import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Internal (FailureInfo(..)) -data Result (g :: (* -> *) -> *) s v = Parsed{ parsedPrefix :: v, -                                              _parsedSuffix :: s}+data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,+                                              parsedSuffix :: !s}                                      | NoParse FailureInfo-data FailureInfo = FailureInfo !Int Word64 [String] deriving (Eq, Show)  -- | Parser type for Parsing Expression Grammars that uses a backtracking algorithm, fast for grammars in LL(1) class -- but with potentially exponential performance for longer ambiguous prefixes.@@ -42,6 +46,7 @@     instance Functor (Parser g s) where    fmap f (Parser p) = Parser (fmap f . p)+   {-# INLINABLE fmap #-}  instance Applicative (Parser g s) where    pure a = Parser (Parsed a)@@ -49,10 +54,15 @@       r rest = case p rest                of Parsed f rest' -> f <$> q rest'                   NoParse failure -> NoParse failure+   {-# INLINABLE (<*>) #-}  instance Factorial.FactorialMonoid s => Alternative (Parser g s) where    empty = Parser (\rest-> NoParse $ FailureInfo 0 (fromIntegral $ Factorial.length rest) ["empty"])-   Parser p <|> Parser q = Parser r where+   (<|>) = alt++-- | A named and unconstrained version of the '<|>' operator+alt :: Parser g s a -> Parser g s a -> Parser g s a+Parser p `alt` Parser q = Parser r where       r rest = case p rest                of x@Parsed{} -> x                   NoParse{} -> q rest@@ -81,11 +91,27 @@       where rewind t Parsed{} = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length t) ["notFollowedBy"])             rewind t NoParse{} = Parsed () t +instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where+   lookAhead (Parser p) = Parser (\input-> rewind input (p input))+      where rewind t (Parsed r _) = Parsed r t+            rewind _ r@NoParse{} = r++instance (Show s, Textual.TextualMonoid s) => CharParsing (Parser g s) where+   satisfy = satisfyChar+   string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)+   char = satisfyChar . (==)+   notChar = satisfyChar . (/=)+   anyChar = satisfyChar (const True)+   text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t)++instance (Show s, Textual.TextualMonoid s) => TokenParsing (Parser g s) where+   someSpace = () <$ takeCharsWhile1 isSpace+ instance MonoidParsing (Parser g) where    endOfInput = Parser p-      where p rest = if Null.null rest-                     then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])-                     else Parsed () rest+      where p rest+               | Null.null rest = Parsed () rest+               | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])    getInput = Parser p       where p rest = Parsed rest mempty    anyToken = Parser p@@ -102,6 +128,21 @@                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> Parsed first suffix                   _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+   satisfyCharInput predicate = Parser p+      where p rest =+               case Textual.splitCharacterPrefix rest+               of Just (first, suffix) | predicate first -> Parsed (Factorial.primePrefix rest) suffix+                  _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+   notSatisfy predicate = Parser p+      where p s = case Factorial.splitPrimePrefix s+                  of Just (first, _) +                        | predicate first -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfy"])+                     _ -> Parsed () s+   notSatisfyChar predicate = Parser p+      where p s = case Textual.characterPrefix s+                  of Just first | predicate first +                                  -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfyChar"])+                     _ -> Parsed () s    scan s0 f = Parser (p s0)       where p s rest = Parsed prefix suffix                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest@@ -131,6 +172,7 @@                      of Parsed prefix suffix -> let Parsed prefix' suffix' = q suffix                                                 in Parsed (prefix <> prefix') suffix'                         NoParse{} -> Parsed mempty rest+   {-# INLINABLE string #-}  -- | Backtracking PEG parser --

@@ -0,0 +1,202 @@+{-# LANGUAGE TypeFamilies #-}+-- | Backtracking parser for Parsing Expression Grammars, tracking the consumed input length+module Text.Grampa.PEG.Backtrack.Length (Parser(..), Result(..), alt) where++import Control.Applicative (Applicative(..), Alternative(..), liftA2)+import Control.Monad (Monad(..), MonadPlus(..))++import Data.Char (isSpace)+import Data.Functor.Classes (Show1(..))+import Data.Functor.Compose (Compose(..))+import Data.List (nub)+import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Monoid.Factorial(FactorialMonoid)+import Data.String (fromString)++import qualified Data.Monoid.Cancellative as Cancellative+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Null as Null+import qualified Data.Monoid.Textual as Textual++import qualified Rank2++import qualified Text.Parser.Char+import Text.Parser.Char (CharParsing)+import Text.Parser.Combinators (Parsing(..))+import Text.Parser.LookAhead (LookAheadParsing(..))+import Text.Parser.Token (TokenParsing(someSpace))+import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Internal (FailureInfo(..))++data Result (g :: (* -> *) -> *) s v = Parsed{parsedLength :: !Int,+                                              parsedResult :: !v,+                                              parsedSuffix :: !s}+                                     | NoParse FailureInfo++-- | Parser type for Parsing Expression Grammars that uses a backtracking algorithm, fast for grammars in LL(1) class+-- but with potentially exponential performance for longer ambiguous prefixes.+newtype Parser g s r = Parser{applyParser :: s -> Result g s r}++instance Show1 (Result g s) where+   liftShowsPrec showsPrecSub _showList prec Parsed{parsedResult= r} rest = "Parsed " ++ showsPrecSub prec r rest+   liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest++instance Functor (Result g s) where+   fmap f (Parsed l a rest) = Parsed l (f a) rest+   fmap _ (NoParse failure) = NoParse failure+   +instance Functor (Parser g s) where+   fmap f (Parser p) = Parser (fmap f . p)+   {-# INLINABLE fmap #-}++instance Applicative (Parser g s) where+   pure a = Parser (Parsed 0 a)+   Parser p <*> Parser q = Parser r where+      r rest = case p rest+               of Parsed l f rest' -> case q rest'+                                      of Parsed l' a rest'' -> Parsed (l+l') (f a) rest''+                                         NoParse failure -> NoParse failure+                  NoParse failure -> NoParse failure+   {-# INLINABLE (<*>) #-}++instance Factorial.FactorialMonoid s => Alternative (Parser g s) where+   empty = Parser (\rest-> NoParse $ FailureInfo 0 (fromIntegral $ Factorial.length rest) ["empty"])+   (<|>) = alt++-- | A named and unconstrained version of the '<|>' operator+alt :: Parser g s a -> Parser g s a -> Parser g s a+Parser p `alt` Parser q = Parser r where+      r rest = case p rest+               of x@Parsed{} -> x+                  NoParse{} -> q rest++instance Monad (Parser g s) where+   return = pure+   Parser p >>= f = Parser r where+      r rest = case p rest+               of Parsed l a rest' -> case applyParser (f a) rest'+                                      of Parsed l' b rest'' -> Parsed (l+l') b rest''+                                         NoParse failure -> NoParse failure+                  NoParse failure -> NoParse failure++instance Factorial.FactorialMonoid s => MonadPlus (Parser g s) where+   mzero = empty+   mplus = (<|>)++instance Monoid x => Monoid (Parser g s x) where+   mempty = pure mempty+   mappend = liftA2 mappend++instance Factorial.FactorialMonoid s => Parsing (Parser g s) where+   try = id+   (<?>) = const+   eof = endOfInput+   unexpected msg = Parser (\t-> NoParse $ FailureInfo 0 (fromIntegral $ Factorial.length t) [msg])+   notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))+      where rewind t Parsed{} = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length t) ["notFollowedBy"])+            rewind t NoParse{} = Parsed 0 () t++instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where+   lookAhead (Parser p) = Parser (\input-> rewind input (p input))+      where rewind t (Parsed _ r _) = Parsed 0 r t+            rewind _ r@NoParse{} = r++instance (Show s, Textual.TextualMonoid s) => CharParsing (Parser g s) where+   satisfy = satisfyChar+   string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)+   char = satisfyChar . (==)+   notChar = satisfyChar . (/=)+   anyChar = satisfyChar (const True)+   text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t)++instance (Show s, Textual.TextualMonoid s) => TokenParsing (Parser g s) where+   someSpace = () <$ takeCharsWhile1 isSpace++instance MonoidParsing (Parser g) where+   endOfInput = Parser p+      where p rest+               | Null.null rest = Parsed 0 () rest+               | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])+   getInput = Parser p+      where p rest = Parsed (Factorial.length rest) rest mempty+   anyToken = Parser p+      where p rest = case Factorial.splitPrimePrefix rest+                     of Just (first, suffix) -> Parsed 1 first suffix+                        _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["anyToken"])+   satisfy predicate = Parser p+      where p rest =+               case Factorial.splitPrimePrefix rest+               of Just (first, suffix) | predicate first -> Parsed 1 first suffix+                  _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfy"])+   satisfyChar predicate = Parser p+      where p rest =+               case Textual.splitCharacterPrefix rest+               of Just (first, suffix) | predicate first -> Parsed 1 first suffix+                  _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+   satisfyCharInput predicate = Parser p+      where p rest =+               case Textual.splitCharacterPrefix rest+               of Just (first, suffix) | predicate first -> Parsed 1 (Factorial.primePrefix rest) suffix+                  _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+   notSatisfy predicate = Parser p+      where p s = case Factorial.splitPrimePrefix s+                  of Just (first, _) +                        | predicate first -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfy"])+                     _ -> Parsed 0 () s+   notSatisfyChar predicate = Parser p+      where p s = case Textual.characterPrefix s+                  of Just first | predicate first +                                  -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfyChar"])+                     _ -> Parsed 0 () s+   scan s0 f = Parser (p s0)+      where p s rest = Parsed (Factorial.length prefix) prefix suffix+               where (prefix, suffix, _) = Factorial.spanMaybe' s f rest+   scanChars s0 f = Parser (p s0)+      where p s rest = Parsed (Factorial.length prefix) prefix suffix+               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest+   takeWhile predicate = Parser p+      where p rest | (prefix, suffix) <- Factorial.span predicate rest =+               Parsed (Factorial.length prefix) prefix suffix+   takeWhile1 predicate = Parser p+      where p rest | (prefix, suffix) <- Factorial.span predicate rest =+                        if Null.null prefix+                        then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeWhile1"])+                        else Parsed (Factorial.length prefix) prefix suffix+   takeCharsWhile predicate = Parser p+      where p rest | (prefix, suffix) <- Textual.span_ False predicate rest = +               Parsed (Factorial.length prefix) prefix suffix+   takeCharsWhile1 predicate = Parser p+      where p rest | (prefix, suffix) <- Textual.span_ False predicate rest =+                     if Null.null prefix+                     then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"])+                     else Parsed (Factorial.length prefix) prefix suffix+   string s = Parser p where+      p s' | Just suffix <- Cancellative.stripPrefix s s' = Parsed l s suffix+           | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])+      l = Factorial.length s+   whiteSpace = () <$ takeCharsWhile isSpace+   concatMany (Parser p) = Parser q+      where q rest = case p rest+                     of Parsed l prefix suffix -> let Parsed l' prefix' suffix' = q suffix+                                                  in Parsed (l+l') (prefix <> prefix') suffix'+                        NoParse{} -> Parsed 0 mempty rest+   {-# INLINABLE string #-}++-- | Backtracking PEG parser+--+-- @+-- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>+--                  g (Backtrack.'Parser' g s) -> s -> g 'ParseResults'+-- @+instance MultiParsing Parser where+   type ResultFunctor Parser = ParseResults+   {-# NOINLINE parsePrefix #-}+   -- | Returns an input prefix parse paired with the remaining input suffix.+   parsePrefix g input = Rank2.fmap (Compose . fromResult input . (`applyParser` input)) g+   parseComplete g input = Rank2.fmap ((snd <$>) . fromResult input . (`applyParser` input))+                                      (Rank2.fmap (<* endOfInput) g)++fromResult :: FactorialMonoid s => s -> Result g s r -> ParseResults (s, r)+fromResult s (NoParse (FailureInfo _ pos msgs)) =+   Left (ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs))+fromResult _ (Parsed _ prefix suffix) = Right (suffix, prefix)

@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} -- | Packrat parser-module Text.Grampa.PEG.Packrat (Parser) where+module Text.Grampa.PEG.Packrat (Parser(..), Result(..)) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2) import Control.Monad (Monad(..), MonadPlus(..))@@ -11,7 +11,7 @@ import Data.List (genericLength, nub) import Data.Monoid (Monoid(mappend, mempty), (<>)) import Data.Monoid.Factorial(FactorialMonoid)-import Data.Word (Word64)+import Data.String (fromString)  import qualified Data.Monoid.Cancellative as Cancellative import qualified Data.Monoid.Factorial as Factorial@@ -20,14 +20,18 @@  import qualified Rank2 +import qualified Text.Parser.Char+import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..))+import Text.Parser.LookAhead (LookAheadParsing(..))+import Text.Parser.Token (TokenParsing(someSpace)) import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Internal (FailureInfo(..)) import qualified Text.Grampa.PEG.Backtrack as Backtrack (Parser) -data Result g s v = Parsed{parsedPrefix :: v, -                           parsedSuffix :: [(s, g (Result g s))]}+data Result g s v = Parsed{parsedPrefix :: !v, +                           parsedSuffix :: ![(s, g (Result g s))]}                   | NoParse FailureInfo-data FailureInfo = FailureInfo !Int Word64 [String] deriving (Eq, Show)  -- | Parser type for Parsing Expression Grammars that uses an improved packrat algorithm, with O(1) performance bounds -- but with worse constants and more memory consumption than 'Backtrack.Parser'. The 'parse' function returns an input@@ -83,6 +87,22 @@       where rewind t Parsed{} = NoParse (FailureInfo 1 (genericLength t) ["notFollowedBy"])             rewind t NoParse{} = Parsed () t +instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where+   lookAhead (Parser p) = Parser (\input-> rewind input (p input))+      where rewind t (Parsed r _) = Parsed r t+            rewind _ r@NoParse{} = r++instance (Show s, Textual.TextualMonoid s) => CharParsing (Parser g s) where+   satisfy = satisfyChar+   string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)+   char = satisfyChar . (==)+   notChar = satisfyChar . (/=)+   anyChar = satisfyChar (const True)+   text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t)++instance (Show s, Textual.TextualMonoid s) => TokenParsing (Parser g s) where+   someSpace = () <$ takeCharsWhile1 isSpace+ instance GrammarParsing Parser where    type GrammarFunctor Parser = Result    nonTerminal f = Parser p where@@ -110,10 +130,26 @@             p [] = NoParse (FailureInfo 1 0 ["satisfy"])    satisfyChar predicate = Parser p       where p rest@((s, _):t) =-               case Textual.splitCharacterPrefix s-               of Just (first, _) | predicate first -> Parsed first t+               case Textual.characterPrefix s+               of Just first | predicate first -> Parsed first t                   _ -> NoParse (FailureInfo 1 (genericLength rest) ["satisfyChar"])             p [] = NoParse (FailureInfo 1 0 ["satisfyChar"])+   satisfyCharInput predicate = Parser p+      where p rest@((s, _):t) =+               case Textual.characterPrefix s+               of Just first | predicate first -> Parsed (Factorial.primePrefix s) t+                  _ -> NoParse (FailureInfo 1 (genericLength rest) ["satisfyChar"])+            p [] = NoParse (FailureInfo 1 0 ["satisfyChar"])+   notSatisfy predicate = Parser p+      where p rest@((s, _):_)+               | Just (first, _) <- Factorial.splitPrimePrefix s, +                 predicate first = NoParse (FailureInfo 1 (genericLength rest) ["notSatisfy"])+            p rest = Parsed () rest+   notSatisfyChar predicate = Parser p+      where p rest@((s, _):_)+               | Just first <- Textual.characterPrefix s, +                 predicate first = NoParse (FailureInfo 1 (genericLength rest) ["notSatisfyChar"])+            p rest = Parsed () rest    scan s0 f = Parser (p s0)       where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)                where (prefix, _, _) = Factorial.spanMaybe' s f i