grammatical-parsers 0.5.1 → 0.5.2

raw patch · 19 files changed

+385/−148 lines, 19 filesdep +witherabledep −witherable-classPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: witherable

Dependencies removed: witherable-class

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• grammatical-parsers.cabal +3/−2
• src/Text/Grampa.hs +4/−3
• src/Text/Grampa/Class.hs +3/−2
• src/Text/Grampa/ContextFree/Continued.hs +12/−2
• src/Text/Grampa/ContextFree/Continued/Measured.hs +12/−2
• src/Text/Grampa/ContextFree/LeftRecursive.hs +122/−90
• src/Text/Grampa/ContextFree/LeftRecursive/Transformer.hs +1/−9
• src/Text/Grampa/ContextFree/Memoizing.hs +14/−4
• src/Text/Grampa/ContextFree/Parallel.hs +10/−2
• src/Text/Grampa/ContextFree/SortedMemoizing.hs +21/−5
• src/Text/Grampa/ContextFree/SortedMemoizing/Transformer.hs +27/−7
• src/Text/Grampa/Internal.hs +22/−4
• src/Text/Grampa/PEG/Backtrack.hs +10/−2
• src/Text/Grampa/PEG/Backtrack/Measured.hs +10/−2
• src/Text/Grampa/PEG/Continued.hs +12/−2
• src/Text/Grampa/PEG/Continued/Measured.hs +12/−3
• src/Text/Grampa/PEG/Packrat.hs +13/−2
• test/Test.hs +67/−5

@@ -1,3 +1,13 @@+Version 0.5.2+---------------+* Switched from the deprecated `witherable-class` package to `witherable`+* Deprecated the `ContextFree.Memoizing` module+* Fixed and tested the `<<|>` instance of the `LeftRecursive` parser+* Fixed and tested a with left-recursive monadic empty match+* Fixed an infinite loop in the expected set closure calculation+* Improved documentation+* Added the `TraceableParsing` class for easier debugging, not exposed+ Version 0.5.1 --------------- * Fixed the `skipAll` implementation for the `SortedMemoizing.Transformer` parser

@@ -1,5 +1,5 @@ name:                grammatical-parsers-version:             0.5.1+version:             0.5.2 synopsis:            parsers that 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@@ -50,7 +50,7 @@                        parsers < 0.13,                        input-parsers < 0.3,                        attoparsec >= 0.13 && < 0.14,-                       witherable-class < 0.1,+                       witherable == 0.4.*,                        rank2classes >= 1.0.2 && < 1.5  executable             arithmetic@@ -79,6 +79,7 @@   x-uses-tf:         true   build-depends:     base >=4.9 && < 5, containers >= 0.5.7.0 && < 0.7,                      monoid-subclasses < 1.2, parsers < 0.13,+                     witherable == 0.4.*,                      rank2classes >= 1.0.2 && < 1.5, grammatical-parsers,                      QuickCheck >= 2 && < 3, checkers >= 0.4.6 && < 0.6, size-based < 0.2,                      testing-feat >= 1.1 && < 1.2,

@@ -1,5 +1,5 @@--- | Collection of parsing algorithms with a common interface, operating on grammars represented as records with rank-2--- field types.+-- | A collection of parsing algorithms with a common interface, operating on grammars represented as records with+-- rank-2 field types. {-# LANGUAGE FlexibleContexts, KindSignatures, OverloadedStrings, RankNTypes, ScopedTypeVariables #-} module Text.Grampa (    -- * Parsing methods@@ -46,7 +46,8 @@                     (s  :: *)    = g (p g' s) -> g (p g' s) --- | Apply the given 'parse' function to the given grammar-free parser and its input.+-- | Apply the given parsing function (typically `parseComplete` or `parsePrefix`) to the given grammar-agnostic+-- 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 parseGrammar p input = Rank2.fromOnly (parseGrammar (Rank2.Only p) input) 

@@ -35,8 +35,9 @@  -- | A 'ParseFailure' contains the offset of the parse failure and the list of things expected at that offset. data ParseFailure s = ParseFailure Int [Expected s] deriving (Eq, Functor, Show)-data Expected s = Expected String-                | ExpectedInput s++data Expected s = Expected String -- ^ a readable description of the expected input+                | ExpectedInput s -- ^ a literal piece of expected input                 deriving (Functor, Eq, Ord, Read, Show)  -- | An 'Ambiguous' parse result, produced by the 'ambiguous' combinator, contains a 'NonEmpty' list of

@@ -13,7 +13,8 @@ import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Debug.Trace (trace)+import Witherable (Filterable(mapMaybe))  import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null@@ -28,7 +29,7 @@ import Text.Parser.LookAhead (LookAheadParsing(..)) import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),                           ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..))+import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,                                               parsedSuffix :: !s}@@ -206,6 +207,15 @@          | Just suffix <- Cancellative.stripPrefix s s' = success s suffix failure          | otherwise = failure (FailureInfo (Factorial.length s') [ExpectedInput s])    {-# INLINABLE string #-}++instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where+   traceInput :: forall a. (s -> String) -> Parser g s a -> Parser g s a+   traceInput description (Parser p) = Parser q+      where q :: forall x. s -> (a -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+            q rest success failure = traceWith "Parsing " (p rest success' failure')+               where traceWith prefix = trace (prefix <> description rest)+                     failure' f = traceWith "Failed " (failure f)+                     success' r suffix failure'' = traceWith "Parsed " (success r suffix failure'')  instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p

@@ -13,7 +13,8 @@ import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Debug.Trace (trace)+import Witherable (Filterable(mapMaybe))  import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null@@ -28,7 +29,7 @@ import Text.Parser.LookAhead (LookAheadParsing(..)) import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),                           MultiParsing(..), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..))+import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,                                               parsedSuffix :: !s}@@ -214,6 +215,15 @@       where q :: forall x. s -> ((s, a) -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             q rest success failure = p rest success' failure                where success' r !len suffix failure' = success (Factorial.take len rest, r) len suffix failure'++instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where+   traceInput :: forall a. (s -> String) -> Parser g s a -> Parser g s a+   traceInput description (Parser p) = Parser q+      where q :: forall x. s -> (a -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+            q rest success failure = traceWith "Parsing " (p rest success' failure')+               where traceWith prefix = trace (prefix <> description rest)+                     failure' f = traceWith "Failed " (failure f)+                     success' r !len suffix failure'' = traceWith "Parsed " (success r len suffix failure'')  instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p

@@ -1,8 +1,8 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, InstanceSigs,+{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, InstanceSigs,              RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators,              UndecidableInstances #-} {-# OPTIONS -fno-full-laziness #-}-module Text.Grampa.ContextFree.LeftRecursive (Fixed, Parser, SeparatedParser(..), FallibleWithExpectations(..),+module Text.Grampa.ContextFree.LeftRecursive (Fixed, Parser, SeparatedParser(..),                                               longest, peg, terminalPEG,                                               liftPositive, liftPure, mapPrimitive,                                               parseSeparated, separated)@@ -25,7 +25,7 @@ import qualified Data.Monoid.Textual as Textual import Data.String (fromString) import Data.Type.Equality ((:~:)(Refl))-import Data.Witherable.Class (Filterable(mapMaybe))+import Witherable (Filterable(mapMaybe))  import qualified Text.Parser.Char as Char import Text.Parser.Char (CharParsing)@@ -34,11 +34,11 @@  import qualified Rank2 import Text.Grampa.Class (GrammarParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),-                          AmbiguousParsing(..), Ambiguous(..),-                          ConsumedInputParsing(..), DeterministicParsing(..),-                          TailsParsing(parseTails, parseAllTails), Expected(..))-import Text.Grampa.Internal (ResultList(..), FailureInfo(..),-                             AmbiguousAlternative(ambiguousOr), AmbiguityDecidable(..), AmbiguityWitness(..))+                          AmbiguousParsing(..), ConsumedInputParsing(..), DeterministicParsing(..),+                          TailsParsing(parseTails, parseAllTails))+import Text.Grampa.Internal (ResultList(..), FailureInfo(..), FallibleResults(..),+                             AmbiguousAlternative(ambiguousOr), AmbiguityDecidable(..), AmbiguityWitness(..),+                             TraceableParsing(..)) import qualified Text.Grampa.ContextFree.SortedMemoizing as Memoizing import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack @@ -64,16 +64,21 @@                                                      cycleParser  :: p g s a,                                                      backParser   :: p g s a,                                                      appendResultsArrow :: ResultAppend p g s a,-                                                     dependencies :: g (Const Bool)}+                                                     dependencies :: Dependencies g}                                                 | BackParser {                                                      backParser :: p g s a}  data ParserFlags g = ParserFlags {    nullable :: Bool,-   dependsOn :: g (Const Bool)}+   dependsOn :: Dependencies g} -deriving instance Show (g (Const Bool)) => Show (ParserFlags g)+deriving instance Show (Dependencies g) => Show (ParserFlags g) +data Dependencies g = DynamicDependencies+                    | StaticDependencies (g (Const Bool))++deriving instance Show (g (Const Bool)) => Show (Dependencies g)+ data ParserFunctor p g s a = ParserResultsFunctor {parserResults :: GrammarFunctor (p g s) a}                            | ParserFlagsFunctor {parserFlags :: ParserFlags g} @@ -123,7 +128,7 @@    direct1= complete p,    indirect= empty,    isAmbiguous= Nothing,-   cyclicDescendants= \cd-> ParserFlags False (const (Const False) Rank2.<$> cd)}+   cyclicDescendants= \cd-> ParserFlags False (StaticDependencies $ const (Const False) Rank2.<$> cd)} general' p@DirectParser{} = Parser{    complete= complete p,    direct = complete p,@@ -131,21 +136,21 @@    direct1= direct1 p,    indirect= empty,    isAmbiguous= Nothing,-   cyclicDescendants= \cd-> ParserFlags True (const (Const False) Rank2.<$> cd)}+   cyclicDescendants= \cd-> ParserFlags True (StaticDependencies $ const (Const False) Rank2.<$> cd)} general' p@Parser{} = p --- | Parser of general context-free grammars, including left recursion.+type LeftRecParsing p g s f = (Eq s, LeftReductive s, FactorialMonoid s, Alternative (p g s),+                               TailsParsing (p g s), GrammarConstraint (p g s) g, ParserGrammar (p g s) ~ g,+                               Functor (ResultFunctor (p g s)), s ~ ParserInput (p g s), FallibleResults f,+                               AmbiguousAlternative (GrammarFunctor (p g s)))++-- | Parser transformer for left-recursive grammars. -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Apply' g, "Rank2".'Rank2.Traversable' g, 'FactorialMonoid' s) =>---                  g (LeftRecursive.'Fixed g s) -> s -> g ('Compose' ('ParseResults' s) [])+--                  g (LeftRecursive.'Parser' g s) -> s -> g ('Compose' ('ParseResults' s) []) -- @-instance (Eq s, LeftReductive s, FactorialMonoid s, Alternative (p g s),-          TailsParsing (p g s), GrammarConstraint (p g s) g, ParserGrammar (p g s) ~ g,-          Functor (ResultFunctor (p g s)),-          s ~ ParserInput (p g s), GrammarFunctor (p g s) ~ rl s, FallibleWithExpectations rl,-          AmbiguousAlternative (GrammarFunctor (p g s))) =>-         MultiParsing (Fixed p g s) where+instance (GrammarFunctor (p g s) ~ f s, LeftRecParsing p g s f) => MultiParsing (Fixed p g s) where    type GrammarConstraint (Fixed p g s) g' = (GrammarConstraint (p g s) g', g ~ g',                                               Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)    type ResultFunctor (Fixed p g s) = ResultFunctor (p g s)@@ -163,12 +168,8 @@       where g' = separated g    {-# INLINE parseComplete #-} -instance (Eq s, LeftReductive s, FactorialMonoid s, Alternative (p g s),-          TailsParsing (p g s), GrammarConstraint (p g s) g, ParserGrammar (p g s) ~ g,-          Functor (ResultFunctor (p g s)),-          s ~ ParserInput (p g s), GrammarFunctor (p g s) ~ rl s, FallibleWithExpectations rl,-          AmbiguousAlternative (GrammarFunctor (p g s))) =>-         GrammarParsing (Fixed p g s) where+-- | Parser transformer for left-recursive grammars.+instance (GrammarFunctor (p g s) ~ f s, LeftRecParsing p g s f) => GrammarParsing (Fixed p g s) where    type ParserGrammar (Fixed p g s) = g    type GrammarFunctor (Fixed p g s) = ParserFunctor p g s    parsingResult :: s -> ParserFunctor p g s a -> ResultFunctor (p g s) (s, a)@@ -186,10 +187,11 @@       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)) =+            adjust (Const bit) (Const (ParserFlags n (StaticDependencies d))) =                Const ParserFlags{                   nullable= n, -                  dependsOn= Rank2.liftA2 union bit d}+                  dependsOn= StaticDependencies (Rank2.liftA2 union bit d)}+            adjust _ flags@(Const (ParserFlags _ DynamicDependencies)) = flags    {-# INLINE nonTerminal #-}    recursive = general @@ -239,7 +241,7 @@            pcd@(ParserFlags pn pd) = cyclicDescendants p' deps            ParserFlags qn qd = cyclicDescendants q deps         in if pn-           then ParserFlags qn (Rank2.liftA2 union pd qd)+           then ParserFlags qn (depUnion pd qd)            else pcd}       where p'@Parser{} = general' p    p <*> q = Parser{@@ -253,7 +255,7 @@            pcd@(ParserFlags pn pd) = cyclicDescendants p' deps            ParserFlags qn qd = cyclicDescendants q' deps         in if pn-           then ParserFlags qn (Rank2.liftA2 union pd qd)+           then ParserFlags qn (depUnion pd qd)            else pcd}       where p'@Parser{} = general' p             q'@Parser{} = general' q@@ -284,7 +286,7 @@                     cyclicDescendants= \deps-> let                          ParserFlags pn pd = cyclicDescendants p' deps                          ParserFlags qn qd = cyclicDescendants q' deps-                      in ParserFlags (pn || qn) (Rank2.liftA2 union pd qd)}+                      in ParserFlags (pn || qn) (depUnion pd qd)}       where p'@Parser{} = general p             q'@Parser{} = general q    many (PositiveDirectParser p) = DirectParser{@@ -344,6 +346,10 @@ union (Const False) d = d union (Const True) _ = Const True +depUnion :: Rank2.Apply g => Dependencies g -> Dependencies g -> Dependencies g+depUnion (StaticDependencies d1) (StaticDependencies d2) = StaticDependencies (Rank2.liftA2 union d1 d2)+depUnion _ _ = DynamicDependencies+ instance (Alternative (p g s), Monad (p g s)) => Monad (Fixed p g s) where    return = pure    (>>) = (*>)@@ -355,7 +361,7 @@       direct1= d1,       indirect= direct0 p >>= indirect . general' . cont,       isAmbiguous= Nothing,-      cyclicDescendants= \cd-> (ParserFlags True $ Rank2.fmap (const $ Const True) cd)}+      cyclicDescendants= const (ParserFlags True DynamicDependencies)}       where d0 = direct0 p >>= direct0 . general' . cont             d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont)    p >>= cont = Parser{@@ -368,7 +374,7 @@       cyclicDescendants= \cd->          let pcd@(ParserFlags pn _) = cyclicDescendants p' cd          in if pn-            then ParserFlags True (Rank2.fmap (const $ Const True) cd)+            then ParserFlags True DynamicDependencies             else pcd}       where d0 = direct0 p >>= direct0 . general' . cont             d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont)@@ -458,15 +464,15 @@       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',-                    isAmbiguous= Nothing,-                    cyclicDescendants= \deps-> let-                            ParserFlags pn pd = cyclicDescendants p' deps-                            ParserFlags qn qd = cyclicDescendants q' deps-                         in ParserFlags (pn || qn) (Rank2.liftA2 union pd qd)}+                     direct= direct p' <<|> notFollowedBy (void $ complete p') *> direct q',+                     direct0= direct0 p' <<|> notFollowedBy (void $ complete p') *> direct0 q',+                     direct1= direct1 p' <<|> notFollowedBy (void $ complete p') *> direct1 q',+                     indirect= indirect p' <<|> notFollowedBy (void $ complete p') *> indirect q',+                     isAmbiguous= Nothing,+                     cyclicDescendants= \deps-> let+                           ParserFlags pn pd = cyclicDescendants p' deps+                           ParserFlags qn qd = cyclicDescendants q' deps+                        in ParserFlags (pn || qn) (depUnion pd qd)}       where p'@Parser{} = general p             q'@Parser{} = general q    takeSome p = (:) <$> p <*> takeMany p@@ -545,8 +551,25 @@    takeWhile predicate = primitive (mempty <$ notSatisfy predicate)                                                (takeWhile1 predicate) (takeWhile predicate)    takeWhile1 predicate = liftPositive (takeWhile1 predicate)+    {-# INLINABLE string #-} +instance (LeftReductive s, FactorialMonoid s, Show s, TraceableParsing (p g s), ParserInput (p g s) ~ s) =>+         TraceableParsing (Fixed p g s) where+   traceInput description p@PositiveDirectParser{} = p{+      complete= traceInput (\s-> "direct+ " <> description s) (complete p)}+   traceInput description p@DirectParser{} = p{+      complete= traceInput (\s-> "direct " <> description s) (complete p),+      direct0= traceInput (\s-> "direct0 " <> description s) (direct0 p),+      direct1= traceInput (\s-> "direct1 " <> description s) (direct1 p)}+   traceInput description p@Parser{} = p{+      complete= traceBy "complete" (complete p),+      direct= traceBy "direct" (direct p),+      direct0= traceBy "direct0" (direct0 p),+      direct1= traceBy "direct1" (direct1 p),+      indirect= traceBy "indirect" (indirect p)}+      where traceBy mode = traceInput (\s-> "(" <> mode <> ") " <> description s)+ instance (LeftReductive s, FactorialMonoid s,           ConsumedInputParsing (p g s), ParserInput (p g s) ~ s) => ConsumedInputParsing (Fixed p g s) where    match (PositiveDirectParser p) = PositiveDirectParser (match p)@@ -640,7 +663,7 @@ parseRecursive :: forall p g s rl. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g,                                     Eq s, FactorialMonoid s, LeftReductive s, Alternative (p g s),                                     TailsParsing (p g s), GrammarConstraint (p g s) g,-                                    s ~ ParserInput (p g s), GrammarFunctor (p g s) ~ rl s, FallibleWithExpectations rl,+                                    s ~ ParserInput (p g s), GrammarFunctor (p g s) ~ rl s, FallibleResults rl,                                     AmbiguousAlternative (GrammarFunctor (p g s))) =>                   g (Fixed p g s) -> s -> [(s, g (GrammarFunctor (p g s)))] parseRecursive = parseSeparated . separated@@ -650,21 +673,23 @@                             AmbiguousAlternative (GrammarFunctor (p g s))) =>              g (Fixed p g s) -> g (SeparatedParser p g s) separated g = Rank2.liftA4 reseparate circulars cycleFollowers descendants g-   where descendants :: g (Const (g (Const Bool)))+   where descendants :: g (Const (Dependencies g))          cycleFollowers, circulars :: g (Const Bool)          cyclicDescendantses :: g (Const (ParserFlags g))          appendResults :: forall a. Maybe (AmbiguityWitness a)                        -> GrammarFunctor (p g s) a -> GrammarFunctor (p g s) a -> GrammarFunctor (p g s) a          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 -> Fixed p g s a+         reseparate :: forall a. Const Bool a -> Const Bool a -> Const (Dependencies g) a -> Fixed p g s a                     -> SeparatedParser p g s a-         reseparate (Const circular) (Const follower) (Const deps) p+         reseparate (Const circular) (Const follower) (Const d@(StaticDependencies deps)) p             | circular || leader && follower =-              CycleParser (indirect p) (direct p) (Rank2.Arrow (Rank2.Arrow . appendResults (isAmbiguous p))) deps+              CycleParser (indirect p) (direct p) (Rank2.Arrow (Rank2.Arrow . appendResults (isAmbiguous p))) d             | follower = BackParser (complete p)             | otherwise = FrontParser (complete p)             where leader = getAny (Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection circulars deps)+         reseparate _ _ (Const d@DynamicDependencies) p =+              CycleParser (indirect p) (direct p) (Rank2.Arrow (Rank2.Arrow . appendResults (isAmbiguous p))) d          appendResults (Just (AmbiguityWitness Refl)) = ambiguousOr          appendResults Nothing = (<|>)          descendants = Rank2.fmap (Const . dependsOn . getConst) cyclicDescendantses@@ -672,10 +697,14 @@          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))+         leftRecursive (Const bit) (Const ParserFlags{dependsOn= StaticDependencies deps}) =+            Const (getAny $ Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection bit deps)+         leftRecursive _ (Const ParserFlags{dependsOn= DynamicDependencies}) = Const True+         leftRecursiveDeps (Const True) (Const ParserFlags{dependsOn= StaticDependencies deps}) = Const deps+         leftRecursiveDeps (Const False) (Const ParserFlags{dependsOn= StaticDependencies deps}) =+            Const (Rank2.fmap (const $ Const False) deps)+         leftRecursiveDeps _ (Const ParserFlags{dependsOn= DynamicDependencies}) =+            Const (Rank2.fmap (const $ Const True) g)          intersection (Const a) (Const b) = Const (a && b) {-# INLINABLE separated #-} @@ -686,26 +715,29 @@          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)) =+            where cd' = Rank2.liftA2 flagUnion cd (Rank2.fmap (\(Const f)-> Const (f cd)) gf)+         agree (Const (ParserFlags _xn (StaticDependencies xd))) (Const (ParserFlags _yn (StaticDependencies yd))) =             Const (getAll (Rank2.foldMap (All . getConst) (Rank2.liftA2 agree' xd yd)))+         agree (Const (ParserFlags _xn DynamicDependencies)) (Const (ParserFlags _yn DynamicDependencies)) = Const True+         agree _ _ = Const False          agree' (Const x) (Const y) = Const (x == y)-         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+         flagUnion (Const ParserFlags{dependsOn= old}) (Const (ParserFlags n new)) = +            Const (ParserFlags n $ depUnion old new)+         initial = Rank2.liftA2 (\_ (Const n)-> Const (ParserFlags n deps)) gf nullabilities+         deps = StaticDependencies (const (Const False) Rank2.<$> gf)+         StaticDependencies nullabilities = fixNullabilities gf {-# INLINABLE fixDescendants #-}  fixNullabilities :: forall g. (Rank2.Apply g, Rank2.Traversable g)-                    => g (Const (g (Const (ParserFlags g)) -> (ParserFlags g))) -> g (Const Bool)-fixNullabilities gf = Rank2.fmap (Const . nullable . getConst) (go initial)+                    => g (Const (g (Const (ParserFlags g)) -> (ParserFlags g))) -> Dependencies g+fixNullabilities gf = StaticDependencies (Const . nullable . getConst Rank2.<$> go initial)    where go :: g (Const (ParserFlags g)) -> g (Const (ParserFlags g))          go cd             | getAll (Rank2.foldMap (All . getConst) $ Rank2.liftA2 agree cd cd') = cd             | otherwise = go cd'             where cd' = Rank2.fmap (\(Const f)-> Const (f cd)) gf          agree (Const flags1) (Const flags2) = Const (nullable flags1 == nullable flags2)-         initial = const (Const (ParserFlags True (const (Const False) Rank2.<$> gf))) Rank2.<$> gf+         initial = const (Const (ParserFlags True (StaticDependencies $ const (Const False) Rank2.<$> gf))) Rank2.<$> gf {-# INLINABLE fixNullabilities #-}  -- | Parse the given input using a context-free grammar separated into two parts: the first specifying all the@@ -713,7 +745,7 @@ -- dependencies among the grammar productions. parseSeparated :: forall p g rl s. (Rank2.Apply g, Rank2.Foldable g, Eq s, FactorialMonoid s, LeftReductive s,                                     TailsParsing (p g s), GrammarConstraint (p g s) g,-                                    GrammarFunctor (p g s) ~ rl s, FallibleWithExpectations rl,+                                    GrammarFunctor (p g s) ~ rl s, FallibleResults rl,                                     s ~ ParserInput (p g s)) =>                   g (SeparatedParser p g s) -> s -> [(s, g (GrammarFunctor (p g s)))] parseSeparated parsers input = foldr parseTail [] (Factorial.tails input)@@ -725,18 +757,20 @@                   f :: forall a. SeparatedParser p g s a -> GrammarFunctor (p g s) a -> GrammarFunctor (p g s) a                   f (FrontParser p) _ = parseTails p ((s,d''):parsedTail)                   f _ result = result-         fixRecursive :: s -> [(s, g (GrammarFunctor (p g s)))] -> g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s))+         fixRecursive :: s -> [(s, g (GrammarFunctor (p g s)))]+                      -> g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s))          whileAnyContinues :: (g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s)))                            -> (g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s)))                            -> g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s))-         recurseTotal :: s -> g (GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s)) -> [(s, g (GrammarFunctor (p g s)))]+         recurseTotal :: s -> g (GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s))+                      -> [(s, g (GrammarFunctor (p g s)))]                       -> g (GrammarFunctor (p g s))                       -> g (GrammarFunctor (p g s))          recurseMarginal :: s -> [(s, g (GrammarFunctor (p g s)))]                       -> g (GrammarFunctor (p g s))                       -> g (GrammarFunctor (p g s))-         maybeDependencies :: g (Const (Maybe (g (Const Bool))))-         maybeDependency :: SeparatedParser p g s r -> Const (Maybe (g (Const Bool))) r+         maybeDependencies :: g (Const (Maybe (Dependencies g)))+         maybeDependency :: SeparatedParser p g s r -> Const (Maybe (Dependencies g)) r          appends :: g (ResultAppend p g s)          parserAppend :: SeparatedParser p g s r -> ResultAppend p g s r @@ -749,50 +783,48 @@          maybeDependency p@CycleParser{} = Const (Just $ dependencies p)          maybeDependency _ = Const Nothing +         -- Fix the recursive knot on the head of the input, given its already-fixed tail and the initial record of+         -- directly parsed results.          fixRecursive s parsedTail initial =             whileAnyContinues (recurseTotal s (appends Rank2.<*> initial) parsedTail)                               (recurseMarginal s parsedTail)                               initial initial +         -- Loop accumulating the total parsing results from marginal results as long as there is any new marginal+         -- result to expand a total one or a new failure expactation to augment an existing failure.          whileAnyContinues ft fm total marginal =             Rank2.liftA3 choiceWhile maybeDependencies total (whileAnyContinues ft fm (ft total) (fm marginal))-            where choiceWhile :: Const (Maybe (g (Const Bool))) x+            where choiceWhile :: Const (Maybe (Dependencies g)) x                               -> GrammarFunctor (p g s) x -> GrammarFunctor (p g s) x                               -> GrammarFunctor (p g s) x                   choiceWhile (Const Nothing) t _ = t-                  choiceWhile (Const (Just deps)) t t'+                  choiceWhile (Const (Just (StaticDependencies deps))) t t'                      | getAny (Rank2.foldMap (Any . getConst) (Rank2.liftA2 combine deps marginal)) = t'                      | hasSuccess t = t                      | otherwise =-                        let expected = expectations t-                            FailureInfo pos expected' =-                               failureOf (if getAny (Rank2.foldMap (Any . getConst) $-                                                     Rank2.liftA2 (combineFailures expected) deps marginal)-                                          then t' else t)-                        in failWith (FailureInfo pos expected')+                        failWith (failureOf $+                                  if getAny (Rank2.foldMap (Any . getConst) $+                                             Rank2.liftA2 (combineFailures $ failureOf t) deps marginal)+                                  then t' else t)                      where combine :: Const Bool x -> GrammarFunctor (p g s) x -> Const Bool x-                           combineFailures :: [Expected s] -> Const Bool x -> GrammarFunctor (p g s) x -> Const Bool x+                           combineFailures :: FailureInfo s -> Const Bool x -> GrammarFunctor (p g s) x -> Const Bool x                            combine (Const False) _ = Const False                            combine (Const True) results = Const (hasSuccess results)                            combineFailures _ (Const False) _ = Const False-                           combineFailures expected (Const True) rl = Const (any (`notElem` expected) $ expectations rl)+                           combineFailures (FailureInfo pos expected) (Const True) rl =+                              Const (pos > pos' || pos == pos' && any (`notElem` expected) expected')+                              where FailureInfo pos' expected' = failureOf rl+                  choiceWhile (Const (Just DynamicDependencies)) t t'+                     | getAny (Rank2.foldMap (Any . hasSuccess) marginal) = t'+                     | FailureInfo _ [] <- failureOf t = t'+                     | otherwise = t +         -- Adds another round of indirect parsing results to the total results accumulated so far.          recurseTotal s initialAppends parsedTail total = Rank2.liftA2 reparse initialAppends indirects-            where reparse :: (GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s)) a -> p g s a -> GrammarFunctor (p g s) a+            where reparse :: (GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s)) a -> p g s a+                          -> GrammarFunctor (p g s) a                   reparse append p = Rank2.apply append (parseTails p $ (s, total) : parsedTail)+         -- Calculates the next round of indirect parsing results from the previous marginal round.          recurseMarginal s parsedTail marginal =             flip parseTails ((s, marginal) : parsedTail) Rank2.<$> indirects {-# NOINLINE parseSeparated #-}--class FallibleWithExpectations f where-   hasSuccess   :: f s a -> Bool-   failureOf    :: f s a -> FailureInfo s-   failWith     :: FailureInfo s -> f s a-   expectations :: f s a -> [Expected s]--instance FallibleWithExpectations (ResultList g) where-   hasSuccess (ResultList [] _) = False-   hasSuccess _ = True-   failureOf (ResultList _ failure) = failure-   failWith = ResultList []-   expectations (ResultList _ (FailureInfo _ expected)) = expected

@@ -4,10 +4,9 @@                                                           parseSeparated, separated) where -import Text.Grampa.ContextFree.LeftRecursive (Fixed, SeparatedParser(..), FallibleWithExpectations(..),+import Text.Grampa.ContextFree.LeftRecursive (Fixed, SeparatedParser(..),                                               liftPositive, liftPure, mapPrimitive, parseSeparated, separated) import qualified Text.Grampa.ContextFree.SortedMemoizing.Transformer as Transformer-import Text.Grampa.ContextFree.SortedMemoizing.Transformer (ResultListT(ResultList), FailureInfo(FailureInfo)) import Text.Grampa.Internal (AmbiguityDecidable)  type ParserT m = Fixed (Transformer.ParserT m)@@ -23,10 +22,3 @@ -- | Transform the computation carried by the parser. tmap :: AmbiguityDecidable b => (m a -> m b) -> ParserT m g s a -> ParserT m g s b tmap = mapPrimitive . Transformer.tmap--instance FallibleWithExpectations (ResultListT m g) where-   hasSuccess (ResultList [] _) = False-   hasSuccess _ = True-   failureOf (ResultList _ failure) = failure-   failWith = ResultList []-   expectations (ResultList _ (FailureInfo _ expected)) = expected

@@ -1,7 +1,9 @@ {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,              RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}-module Text.Grampa.ContextFree.Memoizing (FailureInfo(..), ResultList(..), Parser(..), BinTree(..),-                                          fromResultList, reparseTails, longest, peg, terminalPEG)+module Text.Grampa.ContextFree.Memoizing+       {-# DEPRECATED "Use Text.Grampa.ContextFree.SortedMemoizing instead" #-}+       (FailureInfo(..), ResultList(..), Parser(..), BinTree(..),+        fromResultList, reparseTails, longest, peg, terminalPEG) where  import Control.Applicative@@ -20,7 +22,8 @@ import Data.Semigroup (Semigroup((<>))) import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Debug.Trace (trace)+import Witherable (Filterable(mapMaybe))  import qualified Text.Parser.Char import Text.Parser.Char (CharParsing)@@ -32,7 +35,7 @@ import Text.Grampa.Class (GrammarParsing(..), MultiParsing(..),                           DeterministicParsing(..), InputParsing(..), InputCharParsing(..),                           TailsParsing(parseTails), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (BinTree(..), FailureInfo(..))+import Text.Grampa.Internal (BinTree(..), FailureInfo(..), TraceableParsing(..)) import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack  import Prelude hiding (iterate, length, null, showList, span, takeWhile)@@ -214,6 +217,13 @@                  predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfy"])             p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty    {-# INLINABLE string #-}++instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where+   traceInput description (Parser p) = Parser q+      where q rest@((s, _):_) = case traceWith "Parsing " (p rest)+                                of rl@(ResultList EmptyTree _) -> traceWith "Failed " rl+                                   rl -> traceWith "Parsed " rl+               where traceWith prefix = trace (prefix <> description s)  instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p

@@ -19,7 +19,8 @@ import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Debug.Trace (trace)+import Witherable (Filterable(mapMaybe))  import qualified Text.Parser.Char import Text.Parser.Char (CharParsing)@@ -30,7 +31,7 @@  import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),                           ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (BinTree(..), FailureInfo(..), noFailure)+import Text.Grampa.Internal (BinTree(..), FailureInfo(..), noFailure, TraceableParsing(..))  import Prelude hiding (iterate, null, showList, span, takeWhile) @@ -164,6 +165,13 @@    string s = Parser p where       p s' | Just suffix <- Cancellative.stripPrefix s s' = ResultList (Leaf $ ResultInfo suffix s) noFailure            | otherwise = ResultList mempty (FailureInfo (Factorial.length s') [ExpectedInput s])++instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where+   traceInput description (Parser p) = Parser q+      where q s = case traceWith "Parsing " (p s)+                  of rl@(ResultList EmptyTree _) -> traceWith "Failed " rl+                     rl -> traceWith "Parsed " rl+               where traceWith prefix = trace (prefix <> description s)  instance TextualMonoid s => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p

@@ -19,7 +19,8 @@ import Data.Semigroup (Semigroup((<>))) import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Debug.Trace (trace)+import Witherable (Filterable(mapMaybe))  import qualified Text.Parser.Char import Text.Parser.Char (CharParsing)@@ -32,7 +33,7 @@                           AmbiguousParsing(..), Ambiguous(Ambiguous),                           ConsumedInputParsing(..), DeterministicParsing(..),                           TailsParsing(parseTails, parseAllTails), ParseResults, Expected(..))-import Text.Grampa.Internal (FailureInfo(..), ResultList(..), ResultsOfLength(..), fromResultList)+import Text.Grampa.Internal (FailureInfo(..), ResultList(..), ResultsOfLength(..), fromResultList, TraceableParsing(..)) import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack  import Prelude hiding (iterate, length, null, showList, span, takeWhile)@@ -91,21 +92,28 @@    mempty = pure mempty    mappend = liftA2 mappend +-- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions. Can be wrapped with+-- 'Text.Grampa.ContextFree.LeftRecursive.Fixed' to provide left recursion support. instance (Eq s, LeftReductive s, FactorialMonoid s) => GrammarParsing (Parser g s) where    type ParserGrammar (Parser g s) = g    type GrammarFunctor (Parser g s) = ResultList g s    parsingResult s = Compose . fromResultList s    nonTerminal :: (Rank2.Functor g, ParserInput (Parser g s) ~ s) => (g (ResultList g s) -> ResultList g s a) -> Parser g s a    nonTerminal f = Parser p where-      p ((_, d) : _) = f d+      p input@((_, d) : _) = ResultList rs' failure+         where ResultList rs failure = f d+               rs' = sync <$> rs+               -- in left-recursive grammars the stored input remainder may be wrong, so revert to the complete input+               sync (ResultsOfLength 0 _remainder r) = ResultsOfLength 0 input r+               sync rol = rol       p _ = ResultList mempty (FailureInfo 0 [Expected "NonTerminal at endOfInput"])    {-# INLINE nonTerminal #-}  instance (Eq s, LeftReductive s, FactorialMonoid s) => TailsParsing (Parser g s) where    parseTails = applyParser --- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions, but provides no left--- recursion support.+-- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions. Can be wrapped with+-- 'Text.Grampa.ContextFree.LeftRecursive.Fixed' to provide left recursion support. -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>@@ -176,6 +184,14 @@                  predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfy"])             p rest = ResultList [ResultsOfLength 0 rest (():|[])] mempty    {-# INLINABLE string #-}++instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where+   traceInput description (Parser p) = Parser q+      where q rest@((s, _):_) = case traceWith "Parsing " (p rest)+                                of rl@(ResultList [] _) -> traceWith "Failed " rl+                                   rl -> traceWith "Parsed " rl+               where traceWith prefix = trace (prefix <> description s)+            q [] = p []  instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p

@@ -21,7 +21,8 @@ import qualified Data.Monoid.Textual as Textual import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Witherable (Filterable(mapMaybe))+import Debug.Trace (trace)  import qualified Text.Parser.Char import Text.Parser.Char (CharParsing)@@ -34,7 +35,7 @@                           ConsumedInputParsing(..), DeterministicParsing(..),                           AmbiguousParsing(..), Ambiguous(Ambiguous),                           TailsParsing(..), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..), AmbiguousAlternative(..))+import Text.Grampa.Internal (FailureInfo(..), FallibleResults(..), AmbiguousAlternative(..), TraceableParsing(..)) import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack  import Prelude hiding (iterate, length, null, showList, span, takeWhile)@@ -135,8 +136,8 @@    mempty = pure mempty    mappend = liftA2 mappend --- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions, but provides no left--- recursion support.+-- | Memoizing parser that carries an applicative computation. Can be wrapped with+-- 'Text.Grampa.ContextFree.LeftRecursive.Fixed' to provide left recursion support. -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>@@ -154,14 +155,20 @@                               (snd $ head $ parseAllTails close $ parseGrammarTails g input)       where close = Rank2.fmap (<* eof) g -instance (Applicative m, Eq s, LeftReductive s, FactorialMonoid s, Rank2.Functor g) =>-         GrammarParsing (ParserT m g s) where+-- | Memoizing parser that carries an applicative computation. Can be wrapped with+-- 'Text.Grampa.ContextFree.LeftRecursive.Fixed' to provide left recursion support.+instance (Applicative m, Eq s, LeftReductive s, FactorialMonoid s) => GrammarParsing (ParserT m g s) where    type ParserGrammar (ParserT m g s) = g    type GrammarFunctor (ParserT m g s) = ResultListT m g s    parsingResult s = Compose . Compose . fmap (fmap sequenceA) . fromResultList s    nonTerminal :: (ParserInput (ParserT m g s) ~ s) => (g (ResultListT m g s) -> ResultListT m g s a) -> ParserT m g s a    nonTerminal f = Parser p where-      p ((_, d) : _) = f d+      p input@((_, d) : _) = ResultList rs' failure+         where ResultList rs failure = f d+               rs' = sync <$> rs+               -- in left-recursive grammars the stored input remainder may be wrong, so revert to the complete input+               sync (ResultsOfLengthT (ROL 0 _remainder r)) = ResultsOfLengthT (ROL 0 input r)+               sync rs = rs       p _ = ResultList mempty (FailureInfo 0 [Expected "NonTerminal at endOfInput"])    {-# INLINE nonTerminal #-} @@ -224,6 +231,13 @@             p rest = singleResult 0 rest ()    {-# INLINABLE string #-} +instance InputParsing (ParserT m g s)  => TraceableParsing (ParserT m g s) where+   traceInput description (Parser p) = Parser q+      where q rest@((s, _):_) = case traceWith "Parsing " (p rest)+                                of rl@(ResultList [] _) -> traceWith "Failed " rl+                                   rl -> traceWith "Parsed " rl+               where traceWith prefix = trace (prefix <> description s)+ instance (Applicative m, Show s, TextualMonoid s) => InputCharParsing (ParserT m g s) where    satisfyCharInput predicate = Parser p       where p rest@((s, _):t) =@@ -434,3 +448,9 @@ instance Monoid (ResultListT m g s r) where    mempty = ResultList mempty mempty    mappend = (<>)++instance FallibleResults (ResultListT m g) where+   hasSuccess (ResultList [] _) = False+   hasSuccess _ = True+   failureOf (ResultList _ failure) = failure+   failWith = ResultList []

@@ -1,7 +1,8 @@-{-# LANGUAGE FlexibleInstances, GADTs, RankNTypes, TypeOperators #-}+{-# LANGUAGE ConstrainedClassMethods, FlexibleContexts, FlexibleInstances, GADTs, RankNTypes, TypeOperators #-} -module Text.Grampa.Internal (BinTree(..), FailureInfo(..), ResultList(..), ResultsOfLength(..),+module Text.Grampa.Internal (BinTree(..), FailureInfo(..), ResultList(..), ResultsOfLength(..), FallibleResults(..),                              AmbiguousAlternative(..), AmbiguityDecidable(..), AmbiguityWitness(..),+                             TraceableParsing(..),                              fromResultList, noFailure) where  import Control.Applicative (Applicative(..), Alternative(..))@@ -12,11 +13,11 @@ import Data.Monoid (Monoid(mappend, mempty)) import Data.Semigroup (Semigroup((<>))) import Data.Type.Equality ((:~:)(Refl))-import Data.Witherable.Class (Filterable(mapMaybe))+import Witherable (Filterable(mapMaybe))  import Data.Monoid.Factorial (FactorialMonoid, length) -import Text.Grampa.Class (Ambiguous(..), Expected(..), ParseFailure(..), ParseResults)+import Text.Grampa.Class (Ambiguous(..), Expected(..), ParseFailure(..), ParseResults, InputParsing(..))  import Prelude hiding (length, showList) @@ -154,3 +155,20 @@ instance Monoid (BinTree a) where    mempty = EmptyTree    mappend = (<>)++class FallibleResults f where+   hasSuccess   :: f s a -> Bool+   failureOf    :: f s a -> FailureInfo s+   failWith     :: FailureInfo s -> f s a++instance FallibleResults (ResultList g) where+   hasSuccess (ResultList [] _) = False+   hasSuccess _ = True+   failureOf (ResultList _ failure) = failure+   failWith = ResultList []++class InputParsing m => TraceableParsing m where+   traceInput :: (ParserInput m -> String) -> m a -> m a+   traceAs :: Show (ParserInput m) => String -> m a -> m a+   traceAs description = traceInput (\input-> description <> " @ " <> show input)+

@@ -13,7 +13,8 @@ import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Debug.Trace (trace)+import Witherable (Filterable(mapMaybe))  import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null@@ -28,7 +29,7 @@ import Text.Parser.LookAhead (LookAheadParsing(..)) import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),                           ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..))+import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,                                               parsedSuffix :: !s}@@ -176,6 +177,13 @@       p s' | Just suffix <- Cancellative.stripPrefix s s' = Parsed s suffix            | otherwise = NoParse (FailureInfo (Factorial.length s') [ExpectedInput s])    {-# INLINABLE string #-}++instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where+   traceInput description (Parser p) = Parser q+      where q s = case traceWith "Parsing " (p s)+                  of r@Parsed{} -> traceWith "Parsed " r+                     r@NoParse{} -> traceWith "Failed " r+               where traceWith prefix = trace (prefix <> description s)  instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p

@@ -13,7 +13,8 @@ import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Debug.Trace (trace)+import Witherable (Filterable(mapMaybe))  import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null@@ -28,7 +29,7 @@ import Text.Parser.LookAhead (LookAheadParsing(..)) import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),                           MultiParsing(..), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..))+import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedLength :: !Int,                                               parsedResult :: !v,@@ -189,6 +190,13 @@       where q rest = case p rest                      of Parsed l prefix suffix -> Parsed l (Factorial.take l rest, prefix) suffix                         NoParse failure -> NoParse failure++instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where+   traceInput description (Parser p) = Parser q+      where q s = case traceWith "Parsing " (p s)+                  of r@Parsed{} -> traceWith "Parsed " r+                     r@NoParse{} -> traceWith "Failed " r+               where traceWith prefix = trace (prefix <> description s)  instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p

@@ -14,7 +14,8 @@ import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Debug.Trace (trace)+import Witherable (Filterable(mapMaybe))  import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null@@ -28,7 +29,7 @@ import Text.Parser.LookAhead (LookAheadParsing(..)) import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),                           ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..))+import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,                                               parsedSuffix :: !s}@@ -199,6 +200,15 @@          | Just suffix <- stripPrefix s s' = success s suffix          | otherwise = failure (FailureInfo (Factorial.length s') [ExpectedInput s])    {-# INLINABLE string #-}++instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where+   traceInput :: forall a. (s -> String) -> Parser g s a -> Parser g s a+   traceInput description (Parser p) = Parser q+      where q :: forall x. s -> (a -> s -> x) -> (FailureInfo s -> x) -> x+            q rest success failure = traceWith "Parsing " (p rest success' failure')+               where traceWith prefix = trace (prefix <> description rest)+                     failure' f = traceWith "Failed " (failure f)+                     success' r suffix = traceWith "Parsed " (success r suffix)  instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p

@@ -5,7 +5,6 @@ import Control.Applicative (Applicative(..), Alternative(..), liftA2) import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..)) -import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (nub) import Data.Semigroup (Semigroup(..))@@ -13,7 +12,8 @@ import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Debug.Trace (trace)+import Witherable (Filterable(mapMaybe))  import Data.Semigroup.Cancellative (LeftReductive(stripPrefix)) import qualified Data.Monoid.Factorial as Factorial@@ -28,7 +28,7 @@ import Text.Parser.LookAhead (LookAheadParsing(..)) import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),                           MultiParsing(..), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..))+import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..)) import Text.Grampa.PEG.Continued (Result(..))  -- | Parser type for Parsing Expression Grammars that uses a continuation-passing algorithm and keeps track of the@@ -198,6 +198,15 @@       where q :: forall x. s -> ((s, a) -> Int -> s -> x) -> (FailureInfo s -> x) -> x             q rest success failure = p rest success' failure                where success' r !len suffix = success (Factorial.take len rest, r) len suffix++instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where+   traceInput :: forall a. (s -> String) -> Parser g s a -> Parser g s a+   traceInput description (Parser p) = Parser q+      where q :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo s -> x) -> x+            q rest success failure = traceWith "Parsing " (p rest success' failure')+               where traceWith prefix = trace (prefix <> description rest)+                     failure' f = traceWith "Failed " (failure f)+                     success' r !len suffix = traceWith "Parsed " (success r len suffix)  instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p

@@ -14,7 +14,8 @@ import Data.Semigroup (Semigroup(..)) import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString)-import Data.Witherable.Class (Filterable(mapMaybe))+import Debug.Trace (trace)+import Witherable (Filterable(mapMaybe))  import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null@@ -29,7 +30,7 @@ import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..),                           GrammarParsing(..), MultiParsing(..),                           TailsParsing(parseTails), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..))+import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))  data Result g s v = Parsed{parsedPrefix :: !v,                             parsedSuffix :: ![(s, g (Result g s))]}@@ -136,6 +137,7 @@    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) +-- | Packrat parser instance (Eq s, LeftReductive s, FactorialMonoid s) => GrammarParsing (Parser g s) where    type ParserGrammar (Parser g s) = g    type GrammarFunctor (Parser g s) = Result g s@@ -190,6 +192,15 @@       p rest@((s', _) : _)          | s `isPrefixOf` s' = Parsed s (Factorial.drop (Factorial.length s) rest)       p rest = NoParse (FailureInfo (genericLength rest) [ExpectedInput s])++instance (InputParsing (Parser g s), Monoid s)  => TraceableParsing (Parser g s) where+   traceInput description (Parser p) = Parser q+      where q rest = case traceWith "Parsing " (p rest)+                  of r@Parsed{} -> traceWith "Parsed " r+                     r@NoParse{} -> traceWith "Failed " r+               where traceWith prefix = trace (prefix <> description (case rest+                                                                      of ((s, _):_) -> s+                                                                         [] -> mempty))  instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p

@@ -18,7 +18,7 @@ import Data.Word (Word8, Word64)  import Data.Functor.Compose (Compose(..))-import Text.Parser.Combinators (choice, eof, sepBy1, skipMany)+import Text.Parser.Combinators (choice, eof, sepBy, sepBy1, skipMany) import qualified Text.Parser.Char as Char import Text.Parser.Token (whiteSpace) @@ -32,17 +32,19 @@ import Test.QuickCheck.Checkers (Binop, EqProp(..), TestBatch, unbatch) import Test.QuickCheck.Classes (functor, monad, monoid, applicative, alternative,                                 monadFunctor, monadApplicative, monadOr, monadPlus)+import Witherable (filter)  import qualified Rank2 import qualified Rank2.TH import Text.Grampa hiding (symbol) import qualified Text.Grampa.ContextFree.Parallel as Parallel+import qualified Text.Grampa.ContextFree.SortedMemoizing as Memoizing import qualified Text.Grampa.ContextFree.LeftRecursive as LeftRecursive  import qualified Test.Ambiguous import qualified Test.Examples -import Prelude hiding (null, takeWhile)+import Prelude hiding (filter, null, takeWhile)  data Recursive f = Recursive{start :: f String,                              rec :: f [String],@@ -61,6 +63,24 @@    one = string "(" *> start <* string ")",    next= string "]"} +filteredGrammar Recursive{..} = Recursive{+   start= concat <$> rec,+   rec= filter (not . null) (many one),+   one = string "1",+   next= string "2" <|> (next >>= error "next")}++monadicGrammar Recursive{..} = Recursive{+   start= concat <$> rec,+   rec= many one >>= \x-> if null x then fail "empty" else return x,+   one = string "1",+   next= string "2" <|> (next >>= error "next")}++nullRecursiveGrammar Recursive{..} = Recursive{+   start= rec >>= \a-> (concat a <>) <$> next,+   rec= many one,+   one = string "1",+   next= string "2" <|> (next >>= \n-> (n <>) <$> string "3" )}+ nameListGrammar :: Recursive (LeftRecursive.Parser Recursive String) nameListGrammar = fixGrammar nameListGrammarBuilder nameListGrammarBuilder g@Recursive{..} = Recursive{@@ -84,16 +104,58 @@  type Parser = Parallel.Parser -simpleParse :: (Eq s, FactorialMonoid s, LeftReductive s) => Parallel.Parser (Rank2.Only r) s r -> s -> ParseResults s [(s, r)]+simpleParse :: (Eq s, FactorialMonoid s, LeftReductive s) =>+               Parallel.Parser (Rank2.Only r) s r -> s -> ParseResults s [(s, r)] simpleParse p input = getCompose . getCompose $ simply parsePrefix p input +memoizingParse :: (Eq s, FactorialMonoid s, LeftReductive s) =>+                  Memoizing.Parser (Rank2.Only r) s r -> s -> ParseResults s [(s, r)]+memoizingParse p input = getCompose . getCompose $ simply parsePrefix p input++leftRecursiveParse :: (Eq s, FactorialMonoid s, LeftReductive s) =>+                      LeftRecursive.Parser (Rank2.Only r) s r -> s -> ParseResults s [(s, r)]+leftRecursiveParse p input = getCompose . getCompose $ simply parsePrefix p input++languagePragma :: (DeterministicParsing p, Monad p, InputCharParsing p, ParserInput p ~ String) => p [String]+languagePragma = do spaceChars+                    lang <- isLanguagePragma+                            <$> takeOptional (string "{-#" *> spaceChars *> takeCharsWhile isLetter <* spaceChars)+                    if lang+                       then extension `sepBy` (string "," *> spaceChars) <* string "#-}" <* spaceChars+                       else comment *> languagePragma <<|> pure []+   where spaceChars = takeCharsWhile isSpace+         isLanguagePragma (Just pragmaName) = pragmaName == "LANGUAGE"+         isLanguagePragma Nothing = False+         extension = takeCharsWhile isLetter <* spaceChars+         comment = string "--" <* takeCharsWhile (/= '\n') <|> blockComment+         blockComment = string "{-"+                        *> skipMany (blockComment+                                     <<|> notFollowedBy (string "-}") *> anyToken *> takeCharsWhile  (/= '-'))+                        *> string "-}"+ tests = testGroup "Grampa" [-           let g = fixGrammar recursiveManyGrammar :: Recursive (LeftRecursive.Parser Recursive String)+           let g, gf, gm, gn :: Recursive (LeftRecursive.Parser Recursive String)+               g = fixGrammar recursiveManyGrammar+               gf = fixGrammar filteredGrammar+               gm = fixGrammar monadicGrammar+               gn = fixGrammar nullRecursiveGrammar            in testGroup "recursive"               [testProperty "minimal" $ start (parseComplete g "()") == Compose (Right [""]),                testProperty "bracketed" $ start (parseComplete g "[()]") == Compose (Right [""]),                testProperty "name list" $-                 start (parseComplete nameListGrammar "foo, bar") == Compose (Right ["foo bar"])],+                 start (parseComplete nameListGrammar "foo, bar") == Compose (Right ["foo bar"]),+               testProperty "filtered" $+                 start (parseComplete gf "") === Compose (Left (ParseFailure 0 [ExpectedInput "1"])),+               testProperty "monadic" $+                 start (parseComplete gm "") === Compose (Left (ParseFailure 0 [Expected "empty"])),+               testProperty "null monadic" $+                 start (parseComplete gn "23") === Compose (Right ["23"])+              ],+           testGroup "languagePragma"+             [testProperty "Parallel" $ simpleParse languagePragma "{-# LANGUAGE Foo #-}" === Right [("", ["Foo"])],+              testProperty "Memoizing" $ memoizingParse languagePragma "{-# LANGUAGE Foo #-}" === Right [("", ["Foo"])],+              testProperty "LeftRecursive" $+              leftRecursiveParse languagePragma "{-# LANGUAGE Foo #-}" === Right [("", ["Foo"])]],            testGroup "arithmetic"              [testProperty "arithmetic"   $ \tree-> Test.Examples.parseArithmetical (show tree) === Right tree,               testProperty "boolean"      $ \tree-> Test.Examples.parseBoolean (show tree) === Right tree,