grammatical-parsers 0.5.2 → 0.6

raw patch · 24 files changed

+1344/−913 lines, 24 filesdep −size-baseddep −testing-featdep ~attoparsecPVP ok

version bump matches the API change (PVP)

Dependencies removed: size-based, testing-feat

Dependency ranges changed: attoparsec

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• README.md +3/−3
• examples/BooleanTransformations.hs +1/−0
• grammatical-parsers.cabal +5/−5
• src/Text/Grampa.hs +65/−32
• src/Text/Grampa/Class.hs +66/−15
• src/Text/Grampa/Combinators.hs +9/−5
• src/Text/Grampa/ContextFree/Continued.hs +96/−70
• src/Text/Grampa/ContextFree/Continued/Measured.hs +96/−75
• src/Text/Grampa/ContextFree/LeftRecursive.hs +87/−36
• src/Text/Grampa/ContextFree/LeftRecursive/Transformer.hs +3/−1
• src/Text/Grampa/ContextFree/Memoizing.hs +79/−65
• src/Text/Grampa/ContextFree/Parallel.hs +79/−52
• src/Text/Grampa/ContextFree/SortedMemoizing.hs +96/−64
• src/Text/Grampa/ContextFree/SortedMemoizing/Transformer.hs +109/−85
• src/Text/Grampa/Internal.hs +22/−37
• src/Text/Grampa/PEG/Backtrack.hs +58/−36
• src/Text/Grampa/PEG/Backtrack/Measured.hs +63/−37
• src/Text/Grampa/PEG/Continued.hs +101/−73
• src/Text/Grampa/PEG/Continued/Measured.hs +91/−70
• src/Text/Grampa/PEG/Packrat.hs +62/−42
• test/README.lhs +3/−3
• test/Test.hs +96/−75
• test/Test/Examples.hs +38/−32

@@ -1,3 +1,19 @@+Version 0.6+---------------+* Updated code to compile with GHC 9.2.2+* Added type `GrammarOverlay` and function `overlay`+* Added the `someNonEmpty` combinator+* Added the `CommittedParsing` class+* The failure messages are now sorted+* `<?>` preserves the erroneous messages+* Fixed the `parsingResult` in Packrat+* Fixed the use of `maxBound` on `Down` which flipped meaning in `base`+* Turned `ParseFailure` into a record to work around an old Haddock bug+* Unified the `FailureInfo` type with `ParseFailure`+* Parameterized `ParseFailure` with a position type+* Eliminated the `size-based` and `testing-feat` dependencies+* Hid the `Text.Grampa.ContextFree.Memoizing` module+ Version 0.5.2 --------------- * Switched from the deprecated `witherable-class` package to `witherable`

@@ -89,9 +89,9 @@ -- >>> parseComplete grammar "1+2*3" -- Arithmetic{ --   sum=Compose (Right [7]),---   product=Compose (Left (ParseFailure 1 [Expected "end of input"])),---   factor=Compose (Left (ParseFailure 1 [Expected "end of input"])),---   number=Compose (Left (ParseFailure 1 [Expected "end of input"]))}+--   product=Compose (Left (ParseFailure {failurePosition = Down 4, expectedAlternatives = [StaticDescription "end of input"], errorAlternatives = []})),+--   factor=Compose (Left (ParseFailure {failurePosition = Down 4, expectedAlternatives = [StaticDescription "end of input"], errorAlternatives = []})),+--   number=Compose (Left (ParseFailure {failurePosition = Down 4, expectedAlternatives = [StaticDescription "end of input"], errorAlternatives = []}))} -- >>> parsePrefix grammar "1+2*3 apples" -- Arithmetic{ --   sum=Compose (Compose (Right [("+2*3 apples",1),("*3 apples",3),(" apples",7)])),

@@ -10,6 +10,7 @@ import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import Data.Maybe (mapMaybe)+import Data.Semigroup ((<>)) import System.Environment (getArgs) import Text.Parser.Token (TokenParsing(..), symbol) import qualified Text.Grampa

@@ -1,5 +1,5 @@ name:                grammatical-parsers-version:             0.5.2+version:             0.6 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@@ -16,6 +16,7 @@ category:            Text, Parsing build-type:          Custom cabal-version:       >=1.10+tested-with:         GHC==9.2.2, GHC==9.0.2, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2 extra-source-files:  README.md, CHANGELOG.md source-repository head   type:              git@@ -32,7 +33,6 @@                        Text.Grampa.Combinators,                        Text.Grampa.PEG.Backtrack, Text.Grampa.PEG.Packrat,                        Text.Grampa.ContextFree.Continued, Text.Grampa.ContextFree.Parallel,-                       Text.Grampa.ContextFree.Memoizing,                        Text.Grampa.ContextFree.SortedMemoizing,                        Text.Grampa.ContextFree.SortedMemoizing.Transformer,                        Text.Grampa.ContextFree.LeftRecursive,@@ -40,6 +40,7 @@   other-modules:       Text.Grampa.Class, Text.Grampa.Internal,                        Text.Grampa.PEG.Backtrack.Measured,                        Text.Grampa.PEG.Continued, Text.Grampa.PEG.Continued.Measured,+                       Text.Grampa.ContextFree.Memoizing,                        Text.Grampa.ContextFree.Continued.Measured   default-language:    Haskell2010   ghc-options:         -Wall@@ -49,7 +50,7 @@                        monoid-subclasses >=1.0 && <1.2,                        parsers < 0.13,                        input-parsers < 0.3,-                       attoparsec >= 0.13 && < 0.14,+                       attoparsec >= 0.13 && < 0.15,                        witherable == 0.4.*,                        rank2classes >= 1.0.2 && < 1.5 @@ -81,8 +82,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,+                     QuickCheck >= 2 && < 3, checkers >= 0.4.6 && < 0.6,                      tasty >= 0.7, tasty-quickcheck >= 0.7   main-is:           Test.hs   other-modules:     Test.Ambiguous, Test.Examples,

@@ -1,24 +1,33 @@ -- | 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 #-}+{-# LANGUAGE FlexibleContexts, KindSignatures, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeFamilies #-} module Text.Grampa (-   -- * Parsing methods+   -- * Applying parsers    failureDescription, simply,    -- * Types-   Grammar, GrammarBuilder, ParseResults, ParseFailure(..), Expected(..), Ambiguous(..), Position,-   -- * Parser combinators and primitives-   DeterministicParsing(..), AmbiguousParsing(..),-   InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),-   MultiParsing(..), GrammarParsing(..),-   TokenParsing(..), LexicalParsing(..),+   Grammar, GrammarBuilder, GrammarOverlay, ParseResults, ParseFailure(..), FailureDescription(..), Ambiguous(..), Pos,+   -- * Classes+   -- ** Parsing+   DeterministicParsing(..), AmbiguousParsing(..), CommittedParsing(..), TraceableParsing(..),+   LexicalParsing(..),+   -- ** Grammars+   MultiParsing(..), GrammarParsing(..), overlay,+   -- ** From the [input-parsers](http://hackage.haskell.org/package/input-parsers) library+   InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..), Position(..),+   -- ** From the [parsers](http://hackage.haskell.org/package/parsers) library    module Text.Parser.Char,    module Text.Parser.Combinators,    module Text.Parser.LookAhead,+   TokenParsing(..),+   -- * Other combinators    module Text.Grampa.Combinators) where -import Data.List (intersperse, nub, sort)-import Data.Monoid ((<>))+import Data.List (intersperse)+import Data.Kind (Type)+import Data.Monoid ((<>), Endo (Endo, appEndo))+import Data.Monoid.Factorial (drop)+import Data.Monoid.Null (null) import Data.Monoid.Textual (TextualMonoid) import Data.String (IsString(fromString)) import Text.Parser.Char (CharParsing(char, notChar, anyChar))@@ -32,38 +41,62 @@ import qualified Rank2 import Text.Grampa.Class (MultiParsing(..), GrammarParsing(..),                           InputParsing(..), InputCharParsing(..),-                          ConsumedInputParsing(..), DeterministicParsing(..), LexicalParsing(..),-                          AmbiguousParsing(..), Ambiguous(..), ParseResults, ParseFailure(..), Expected(..))+                          ConsumedInputParsing(..), LexicalParsing(..),+                          CommittedParsing(..), DeterministicParsing(..),+                          AmbiguousParsing(..), Ambiguous(..),+                          ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (TraceableParsing(..)) --- | A type synonym for a fixed grammar record type @g@ with a given parser type @p@ on input streams of type @s@-type Grammar (g  :: (* -> *) -> *) p s = g (p g s)+import Prelude hiding (drop, null) --- | A type synonym for an endomorphic function on a grammar record type @g@, whose parsers of type @p@ build grammars--- of type @g'@, parsing input streams of type @s@-type GrammarBuilder (g  :: (* -> *) -> *)-                    (g' :: (* -> *) -> *)-                    (p  :: ((* -> *) -> *) -> * -> * -> *)-                    (s  :: *)+-- | Fixed grammar record type @g@ with a given parser type @p@ on input streams of type @s@+type Grammar (g  :: (Type -> Type) -> Type) p s = g (p g s)++-- | A @GrammarBuilder g g' p s@ is an endomorphic function on a grammar @g@, whose parsers of type @p@ build grammars+-- of type @g'@, parsing input streams of type @s@. The first grammar @g@ may be a building block for the final+-- grammar @g'@.+type GrammarBuilder (g  :: (Type -> Type) -> Type)+                    (g' :: (Type -> Type) -> Type)+                    (p  :: ((Type -> Type) -> Type) -> Type -> Type -> Type)+                    (s  :: Type)    = g (p g' s) -> g (p g' s) +-- | A grammar overlay is a function that takes a final grammar @self@ and the parent grammar @super@ and builds a new+-- grammar from them. Use 'overlay' to apply a colection of overlays on top of a base grammar.+type GrammarOverlay (g  :: (Type -> Type) -> Type)+                    (m  :: Type -> Type)+   = g m -> g m -> g m++-- | Layers a sequence of 'GrammarOverlay' on top of a base 'GrammarBuilder' to produce a new grammar.+overlay :: (GrammarParsing m, g ~ ParserGrammar m, GrammarConstraint m g, Rank2.Distributive g, Foldable f)+        => (g m -> g m) -> f (GrammarOverlay g m) -> g m+overlay base layers = appEndo (foldMap (Endo . ($ self)) layers) (base self)+   where self = selfReferring+ -- | Apply the given parsing function (typically `parseComplete` or `parsePrefix`) to the given grammar-agnostic--- parser and its input.+-- parser and its input. A typical invocation might be+--+-- > getCompose $ simply parsePrefix myParser myInput 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)  -- | Given the textual parse input, the parse failure on the input, and the number of lines preceding the failure to -- show, produce a human-readable failure description.-failureDescription :: forall s. (Ord s, TextualMonoid s) => s -> ParseFailure s -> Int -> s-failureDescription input (ParseFailure pos expected) contextLineCount =-   Position.context input (Position.fromStart pos) contextLineCount-   <> "expected " <> oxfordComma (fromExpected <$> nub (sort expected))-   where oxfordComma :: [s] -> s-         oxfordComma [] = ""-         oxfordComma [x] = x-         oxfordComma [x, y] = x <> " or " <> y-         oxfordComma (x:y:rest) = mconcat (intersperse ", " (x : y : onLast ("or " <>) rest))+failureDescription :: forall s pos. (Ord s, TextualMonoid s, Position pos) => s -> ParseFailure pos s -> Int -> s+failureDescription input (ParseFailure pos expected erroneous) contextLineCount =+   Position.context input pos contextLineCount+   <> mconcat+      (intersperse ", but " $ filter (not . null)+       [onNonEmpty ("expected " <>) $ oxfordComma " or " (fromDescription <$> expected),+        oxfordComma " and " (fromDescription <$> erroneous)])+   where oxfordComma :: s -> [s] -> s+         oxfordComma _ [] = ""+         oxfordComma _ [x] = x+         oxfordComma conjunction [x, y] = x <> conjunction <> y+         oxfordComma conjunction (x:y:rest) = mconcat (intersperse ", " (x : y : onLast (drop 1 conjunction <>) rest))+         onNonEmpty f x = if null x then x else f x          onLast _ [] = []          onLast f [x] = [f x]          onLast f (x:xs) = x : onLast f xs-         fromExpected (Expected s) = fromString s-         fromExpected (ExpectedInput s) = "string \"" <> s <> "\""+         fromDescription (StaticDescription s) = fromString s+         fromDescription (LiteralDescription s) = "string \"" <> s <> "\""

@@ -1,16 +1,19 @@ {-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor,-             FlexibleContexts, FlexibleInstances, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeApplications,-             TypeFamilies, TypeSynonymInstances, UndecidableInstances #-}+             FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, OverloadedStrings,+             RankNTypes, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeSynonymInstances,+             UndecidableInstances #-}+-- | The core classes supported by all the parsers in this library. module Text.Grampa.Class (MultiParsing(..), GrammarParsing(..),                           AmbiguousParsing(..), DeterministicParsing(..), InputParsing(..), InputCharParsing(..),-                          ConsumedInputParsing(..), LexicalParsing(..), TailsParsing(..),-                          ParseResults, ParseFailure(..), Expected(..),+                          CommittedParsing(..), ConsumedInputParsing(..), LexicalParsing(..), TailsParsing(..),+                          ParseResults, ParseFailure(..), FailureDescription(..), Pos,                           Ambiguous(..), completeParser) where  import Control.Applicative (Alternative(empty), liftA2) import Data.Char (isAlphaNum, isLetter, isSpace) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))+import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Data (Data) import Data.Typeable (Typeable)@@ -20,6 +23,7 @@ import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid) import Data.Semigroup (Semigroup((<>)))+import Data.Ord (Down(Down)) import Text.Parser.Combinators (Parsing((<?>))) import Text.Parser.Token (TokenParsing) import Text.Parser.Deterministic (DeterministicParsing(..))@@ -31,15 +35,40 @@  import Prelude hiding (takeWhile) -type ParseResults s = Either (ParseFailure s)+type ParseResults s = Either (ParseFailure Pos s)  -- | 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 ParseFailure pos s =+   ParseFailure {failurePosition :: pos,+                 expectedAlternatives :: [FailureDescription s],  -- ^ expected input alternatives+                 errorAlternatives ::    [FailureDescription s]   -- ^ erroneous input descriptions+                }+   deriving (Eq, Functor, Show) -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)+-- | A position in the input is represented as the length of its remainder.+type Pos = Down Int +-- | An expected or erroneous input can be described using 'String' or using the input type+data FailureDescription s = StaticDescription String   -- ^ a readable description of the expected input+                          | LiteralDescription s       -- ^ a literal piece of expected input+                            deriving (Functor, Eq, Ord, Read, Show)++instance (Ord pos, Ord s) => Semigroup (ParseFailure pos s) where+   ParseFailure pos1 exp1 err1 <> ParseFailure pos2 exp2 err2 = ParseFailure pos' exp' err'+      where (pos', exp', err') | pos1 > pos2 = (pos1, exp1, err1)+                               | pos1 < pos2 = (pos2, exp2, err2)+                               | otherwise = (pos1, merge exp1 exp2, merge err1 err2)+            merge [] xs = xs+            merge xs [] = xs+            merge xs@(x:xs') ys@(y:ys')+               | x < y = x : merge xs' ys+               | x > y = y : merge xs ys'+               | otherwise = x : merge xs' ys'++instance Ord s => Monoid (ParseFailure Pos s) where+   mempty = ParseFailure (Down maxBound) [] []+   mappend = (<>)+ -- | An 'Ambiguous' parse result, produced by the 'ambiguous' combinator, contains a 'NonEmpty' list of -- alternative results. newtype Ambiguous a = Ambiguous{getAmbiguous :: NonEmpty a} deriving (Data, Eq, Ord, Show, Typeable)@@ -71,20 +100,20 @@  instance Monoid a => Monoid (Ambiguous a) where    mempty = Ambiguous (mempty :| [])-   Ambiguous xs `mappend` Ambiguous ys = Ambiguous (liftA2 mappend xs ys)+   mappend = (<>)  completeParser :: MonoidNull s => Compose (ParseResults s) (Compose [] ((,) s)) r -> Compose (ParseResults s) [] r completeParser (Compose (Left failure)) = Compose (Left failure) completeParser (Compose (Right (Compose results))) =    case filter (Null.null . fst) results-   of [] -> Compose (Left $ ParseFailure 0 [Expected "complete parse"])+   of [] -> Compose (Left $ ParseFailure 0 [StaticDescription "a complete parse"] [])       completeResults -> Compose (Right $ snd <$> completeResults)  -- | Choose one of the instances of this class to parse with. class InputParsing m => MultiParsing m where    -- | Some parser types produce a single result, others a list of results.-   type ResultFunctor m :: * -> *-   type GrammarConstraint m (g :: (* -> *) -> *) :: Constraint+   type ResultFunctor m :: Type -> Type+   type GrammarConstraint m (g :: (Type -> Type) -> Type) :: 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 :: (ParserInput m ~ s, GrammarConstraint m g, Eq s, FactorialMonoid s) =>@@ -97,9 +126,9 @@ -- | Parsers that belong to this class can memoize the parse results to avoid exponential performance complexity. class MultiParsing m => GrammarParsing m where    -- | The record of grammar productions associated with the parser-   type ParserGrammar m :: (* -> *) -> *+   type ParserGrammar m :: (Type -> Type) -> Type    -- | For internal use by 'notTerminal'-   type GrammarFunctor m :: * -> *+   type GrammarFunctor m :: Type -> Type    -- | Converts the intermediate to final parsing result.    parsingResult :: ParserInput m -> GrammarFunctor m a -> ResultFunctor m (ParserInput m, a)    -- | Used to reference a grammar production, only necessary from outside the grammar itself@@ -131,6 +160,28 @@    -- | Collect all alternative parses of the same length into a 'NonEmpty' list of results.    ambiguous :: m a -> m (Ambiguous a) +-- | Parsers that can temporarily package and delay failure, in a way dual to Parsec's @try@ combinator. Where Parsec+-- would require something like+--+-- > alternatives  =  try intro1 *> expected1+-- >              <|> try intro2 *> expected2+-- >              <|> fallback+--+-- you can instead say+--+-- > alternatives = admit  $  intro1 *> commit expected1+-- >                      <|> intro2 *> commit expected2+-- >                      <|> commit fallback+--+-- A parsing failure inside an @intro@ parser leaves the other alternatives open, a failure inside an @expected@+-- parser bubbles up and out of the whole @admit@ block.+class Alternative m => CommittedParsing m where+   type CommittedResults m :: Type -> Type+   -- | Commits the argument parser to success.+   commit :: m a -> m (CommittedResults m a)+   -- | Admits a possible defeat of the argument parser.+   admit :: m (CommittedResults m a) -> m a+   -- | If a grammar is 'Lexical', its parsers can instantiate the 'TokenParsing' class. class (DeterministicParsing m, InputCharParsing m, TokenParsing m) => LexicalParsing m where    -- | Always succeeds, consuming all white space and comments

@@ -1,12 +1,12 @@ {-# LANGUAGE TypeFamilies #-}--module Text.Grampa.Combinators (moptional, concatMany, concatSome,+-- | A collection of useful parsing combinators not found in dependent libraries.+module Text.Grampa.Combinators (moptional, concatMany, concatSome, someNonEmpty,                                 flag, count, upto,                                 delimiter, operator, keyword) where  import Control.Applicative(Applicative(..), Alternative(..))-import Data.List.NonEmpty (fromList)-import Data.Monoid (Monoid)+import Data.List.NonEmpty (NonEmpty((:|)), fromList)+import Data.Monoid (Monoid, (<>)) import Data.Monoid.Factorial (FactorialMonoid) import Data.Semigroup (Semigroup(sconcat)) import Data.Semigroup.Cancellative (LeftReductive)@@ -24,7 +24,11 @@  -- | One or more argument occurrences like 'some', with concatenated monoidal results. concatSome :: (Alternative p, Semigroup a) => p a -> p a-concatSome p = sconcat . fromList <$> some p+concatSome p = sconcat <$> someNonEmpty p++-- | One or more argument occurrences like 'some', returned in a 'NonEmpty' list.+someNonEmpty :: Alternative p => p a -> p (NonEmpty a)+someNonEmpty p = (:|) <$> p <*> many p  -- | Returns 'True' if the argument parser succeeds and 'False' otherwise. flag :: Alternative p => p a -> p Bool

@@ -1,13 +1,16 @@-{-# LANGUAGE InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE CPP, FlexibleContexts, InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} -- | Continuation-passing parser for context-free grammars module Text.Grampa.ContextFree.Continued (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2)-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..))+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif  import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.List (nub)+import Data.Kind (Type) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid)@@ -27,18 +30,21 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),-                          ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))+import Text.Parser.Input.Position (fromEnd)+import Text.Grampa.Class (CommittedParsing(..), DeterministicParsing(..),+                          InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (expected, TraceableParsing(..)) -data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,-                                              parsedSuffix :: !s}-                                     | NoParse (FailureInfo s)+data Result (g :: (Type -> Type) -> Type) s v =+     Parsed{parsedPrefix :: !v,+            parsedSuffix :: !s}+   | NoParse (ParseFailure Pos s)  -- | Parser type for context-free grammars that uses a continuation-passing algorithm, fast for grammars in LL(1) -- class but with potentially exponential performance for longer ambiguous prefixes.-newtype Parser (g :: (* -> *) -> *) s r =-   Parser{applyParser :: forall x. s -> (r -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x}+newtype Parser (g :: (Type -> Type) -> Type) s r =+   Parser{applyParser :: forall x. s -> (r -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x}  instance Show s => Show1 (Result g s) where    liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest@@ -56,46 +62,53 @@    pure a = Parser (\input success failure-> success a input failure)    (<*>) :: forall a b. Parser g s (a -> b) -> Parser g s a -> Parser g s b    Parser p <*> Parser q = Parser r where-      r :: forall x. s -> (b -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      r :: forall x. s -> (b -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x       r rest success failure = p rest (\f rest'-> q rest' (success . f)) failure    {-# INLINABLE (<*>) #-} -instance Factorial.FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected "empty"])+instance (Factorial.FactorialMonoid s, Ord s) => Alternative (Parser g s) where+   empty = Parser (\rest _ failure-> failure $ ParseFailure (fromEnd $ Factorial.length rest) [] [])    (<|>) = alt  -- | A named and unconstrained version of the '<|>' operator-alt :: forall g s a. Parser g s a -> Parser g s a -> Parser g s a+alt :: forall g s a. Ord s => Parser g s a -> Parser g s a -> Parser g s a Parser p `alt` Parser q = Parser r where-   r :: forall x. s -> (a -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+   r :: forall x. s -> (a -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x    r rest success failure = p rest success' failure'       where success' a rest' _ = success a rest' failure'             failure' f1 = q rest success (\f2 -> failure (f1 <> f2))  instance Factorial.FactorialMonoid s => Filterable (Result g s) where    mapMaybe f (Parsed a rest) =-      maybe (NoParse $ FailureInfo (Factorial.length rest) [Expected "filter"]) (`Parsed` rest) (f a)+      maybe (NoParse $ expected (fromEnd $ Factorial.length rest) "filter") (`Parsed` rest) (f a)    mapMaybe _ (NoParse failure) = NoParse failure     instance Factorial.FactorialMonoid s => Filterable (Parser g s) where    mapMaybe :: forall a b. (a -> Maybe b) -> Parser g s a -> Parser g s b    mapMaybe f (Parser p) = Parser q where-      q :: forall x. s -> (b -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      q :: forall x. s -> (b -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x       q rest success failure = p rest (maybe filterFailure success . f) failure-         where filterFailure _ _ = failure (FailureInfo (Factorial.length rest) [Expected "filter"])+         where filterFailure _ _ = failure (expected (fromEnd $ Factorial.length rest) "filter")    {-# INLINABLE mapMaybe #-} +#if MIN_VERSION_base(4,13,0) instance Monad (Parser g s) where+#else+instance Factorial.FactorialMonoid s => Monad (Parser g s) where+#endif    return = pure    (>>=) :: forall a b. Parser g s a -> (a -> Parser g s b) -> Parser g s b    Parser p >>= f = Parser r where-      r :: forall x. s -> (b -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      r :: forall x. s -> (b -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x       r rest success failure = p rest (\a rest'-> applyParser (f a) rest' success) failure +#if MIN_VERSION_base(4,13,0) instance Factorial.FactorialMonoid s => MonadFail (Parser g s) where-   fail msg = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected msg])+#endif+   fail msg = Parser (\rest _ failure->+                       failure $ ParseFailure (fromEnd $ Factorial.length rest) [] [StaticDescription msg]) -instance Factorial.FactorialMonoid s => MonadPlus (Parser g s) where+instance (Factorial.FactorialMonoid s, Ord s) => MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) @@ -104,61 +117,77 @@  instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>) -instance Factorial.FactorialMonoid s => Parsing (Parser g s) where+instance (Factorial.FactorialMonoid s, Ord s) => Parsing (Parser g s) where    try :: forall a. Parser g s a -> Parser g s a    try (Parser p) = Parser q-      where q :: forall x. s -> (a -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (a -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success (failure . rewindFailure)-               where rewindFailure (FailureInfo _pos _msgs) = FailureInfo (Factorial.length input) []+               where rewindFailure ParseFailure{} = ParseFailure (fromEnd $ Factorial.length input) [] []    (<?>) :: forall a. Parser g s a -> String -> Parser g s a    Parser p <?> msg  = Parser q-      where q :: forall x. s -> (a -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (a -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success (failure . replaceFailure)-               where replaceFailure (FailureInfo pos msgs) =-                        FailureInfo pos (if pos == Factorial.length input then [Expected msg] else msgs)+               where replaceFailure (ParseFailure pos msgs erroneous) =+                        ParseFailure pos (if pos == fromEnd (Factorial.length input) then [StaticDescription msg]+                                          else msgs) erroneous     eof = Parser p       where p rest success failure                | Null.null rest = success () rest failure-               | otherwise = failure (FailureInfo (Factorial.length rest) [Expected "end of input"])-   unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (Factorial.length t) [Expected msg])+               | otherwise = failure (expected (fromEnd $ Factorial.length rest) "end of input")+   unexpected msg = Parser (\t _ failure ->+                             failure $ ParseFailure (fromEnd $ Factorial.length t) [] [StaticDescription msg])    notFollowedBy (Parser p) = Parser q-      where q :: forall x. s -> (() -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (() -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success' failure'-               where success' _ _ _ = failure (FailureInfo (Factorial.length input) [Expected "notFollowedBy"])+               where success' _ _ _ = failure (expected (fromEnd $ Factorial.length input) "notFollowedBy")                      failure' _ = success () input failure -instance FactorialMonoid s => DeterministicParsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => DeterministicParsing (Parser g s) where    (<<|>) :: forall a. Parser g s a -> Parser g s a -> Parser g s a    Parser p <<|> Parser q = Parser r where-      r :: forall x. s -> (a -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      r :: forall x. s -> (a -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x       r rest success failure = p rest success' failure'          where success' a rest' _ = success a rest' failure                failure' f1 = q rest success (\f2 -> failure (f1 <> f2))    takeSome p = (:) <$> p <*> takeMany p    takeMany p = takeSome p <<|> pure [] -instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => CommittedParsing (Parser g s) where+   type CommittedResults (Parser g s) = ParseResults s+   commit :: forall a. Parser g s a -> Parser g s (ParseResults s a)+   commit (Parser p) = Parser q+      where q :: forall x. s -> (ParseResults s a -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x+            q input success failure = p input (success . Right) failure'+               where failure' f = success (Left f) input failure+   admit :: forall a. Parser g s (ParseResults s a) -> Parser g s a+   admit (Parser p) = Parser q+      where q :: forall x. s -> (a -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x+            q input success failure = p input success' failure+               where success' (Left f) _rest = const (failure f)+                     success' (Right a) rest = success a rest++instance (FactorialMonoid s, Ord s) => LookAheadParsing (Parser g s) where    lookAhead :: forall a. Parser g s a -> Parser g s a    lookAhead (Parser p) = Parser q-      where q :: forall x. s -> (a -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (a -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success' failure'                where success' a _ = success a input                      failure' f = failure f -instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where+instance (Ord s, Show s, TextualMonoid s) => CharParsing (Parser g s) where    satisfy predicate = Parser p-      where p :: forall x. s -> (Char -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (Char -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> success first suffix failure-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "Char.satisfy"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s) => InputParsing (Parser g s) where+instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s, Ord s) => InputParsing (Parser g s) where    type ParserInput (Parser g s) = s    getInput = Parser p       where p rest success failure = success rest rest failure@@ -166,84 +195,84 @@       where p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) -> success first suffix failure-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "anyToken"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "anyToken")    satisfy predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) | predicate first -> success first suffix failure-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfy"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "satisfy")    notSatisfy predicate = Parser p-      where p :: forall x. s -> (() -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (() -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, _)-                     | predicate first -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfy"])+                     | predicate first -> failure (expected (fromEnd $ Factorial.length rest) "notSatisfy")                   _ -> success () rest failure    scan :: forall state. state -> (state -> s -> Maybe state) -> Parser g s s    scan s0 f = Parser (p s0)-      where p :: forall x. state -> s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. state -> s -> (s -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p s rest success failure = success prefix suffix failure                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest    take n = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure               | (prefix, suffix) <- Factorial.splitAt n rest,                 Factorial.length prefix == n = success prefix suffix failure-              | otherwise = failure (FailureInfo (Factorial.length rest) [Expected $ "take " ++ show n])+              | otherwise = failure (expected (fromEnd $ Factorial.length rest) $ "take " ++ show n)    takeWhile predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure | (prefix, suffix) <- Factorial.span predicate rest = success prefix suffix failure    takeWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure                | (prefix, suffix) <- Factorial.span predicate rest =                     if Null.null prefix-                    then failure (FailureInfo (Factorial.length rest) [Expected "takeWhile1"])+                    then failure (expected (fromEnd $ Factorial.length rest) "takeWhile1")                     else success prefix suffix failure    string s = Parser p where-      p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      p :: forall x. s -> (s -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x       p s' success failure          | Just suffix <- Cancellative.stripPrefix s s' = success s suffix failure-         | otherwise = failure (FailureInfo (Factorial.length s') [ExpectedInput s])+         | otherwise = failure (ParseFailure (fromEnd $ Factorial.length s') [LiteralDescription 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+      where q :: forall x. s -> (a -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos 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+instance (Ord s, Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> success (Factorial.primePrefix rest) suffix failure-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfyChar"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "satisfyChar")    notSatisfyChar predicate = Parser p-      where p :: forall x. s -> (() -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (() -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.characterPrefix rest                of Just first | predicate first-                               -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfyChar"])+                               -> failure (expected (fromEnd $ Factorial.length rest) "notSatisfyChar")                   _ -> success () rest failure    scanChars :: forall state. state -> (state -> Char -> Maybe state) -> Parser g s s    scanChars s0 f = Parser (p s0)-      where p :: forall x. state -> s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. state -> s -> (s -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p s rest success failure = success prefix suffix failure                where (prefix, suffix, _) = Textual.spanMaybe_' s f rest    takeCharsWhile predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure                | (prefix, suffix) <- Textual.span_ False predicate rest = success prefix suffix failure    takeCharsWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure-               | Null.null prefix = failure (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])+               | Null.null prefix = failure (expected (fromEnd $ Factorial.length rest) "takeCharsWhile1")                | otherwise = success prefix suffix failure                where (prefix, suffix) = Textual.span_ False predicate rest @@ -253,12 +282,9 @@ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) => --                  g (Continued.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s) => MultiParsing (Parser g s) where+instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s, Ord s) => MultiParsing (Parser g s) where    type ResultFunctor (Parser g s) = ParseResults s    -- | Returns an input prefix parse paired with the remaining input suffix.-   parsePrefix g input = Rank2.fmap (Compose . (\p-> applyParser p input (\a rest _-> Right (rest, a)) (Left . fromFailure input))) g-   parseComplete g input = Rank2.fmap (\p-> applyParser p input (const . const . Right) (Left . fromFailure input))+   parsePrefix g input = Rank2.fmap (Compose . (\p-> applyParser p input (\a rest _-> Right (rest, a)) Left)) g+   parseComplete g input = Rank2.fmap (\p-> applyParser p input (const . const . Right) Left)                                       (Rank2.fmap (<* eof) g)--fromFailure :: (Eq s, FactorialMonoid s) => s -> FailureInfo s -> ParseFailure s-fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - pos + 1) (nub msgs)

@@ -1,13 +1,16 @@-{-# LANGUAGE BangPatterns, InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE CPP, BangPatterns, FlexibleContexts, InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} -- | Continuation-passing parser for context-free grammars that keeps track of the parsed prefix length module Text.Grampa.ContextFree.Continued.Measured (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2)-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..))+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif  import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.List (nub)+import Data.Kind (Type) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid)@@ -27,18 +30,21 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),-                          MultiParsing(..), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))+import Text.Parser.Input.Position (fromEnd)+import Text.Grampa.Class (CommittedParsing(..), DeterministicParsing(..),+                          InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),+                          MultiParsing(..), ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (expected, erroneous, TraceableParsing(..)) -data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,-                                              parsedSuffix :: !s}-                                     | NoParse (FailureInfo s)+data Result (g :: (Type -> Type) -> Type) s v =+     Parsed{parsedPrefix :: !v,+            parsedSuffix :: !s}+   | NoParse (ParseFailure Pos s)  -- | Parser type for context-free grammars that uses a continuation-passing algorithm, fast for grammars in LL(1) -- class but with potentially exponential performance for longer ambiguous prefixes.-newtype Parser (g :: (* -> *) -> *) s r =-   Parser{applyParser :: forall x. s -> (r -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x}+newtype Parser (g :: (Type -> Type) -> Type) s r =+   Parser{applyParser :: forall x. s -> (r -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x}  instance Show s => Show1 (Result g s) where    liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest@@ -56,18 +62,18 @@    pure a = Parser (\input success failure-> success a 0 input failure)    (<*>) :: forall a b. Parser g s (a -> b) -> Parser g s a -> Parser g s b    Parser p <*> Parser q = Parser r where-      r :: forall x. s -> (b -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      r :: forall x. s -> (b -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x       r rest success failure = p rest (\f len rest'-> q rest' (\a len'-> success (f a) $! len + len')) failure    {-# INLINABLE (<*>) #-} -instance Factorial.FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected "empty"])+instance (Factorial.FactorialMonoid s, Ord s) => Alternative (Parser g s) where+   empty = Parser (\rest _ failure-> failure $ ParseFailure (fromEnd $ Factorial.length rest) [] [])    (<|>) = alt  -- | A named and unconstrained version of the '<|>' operator-alt :: forall g s a. Parser g s a -> Parser g s a -> Parser g s a+alt :: forall g s a. Ord s => Parser g s a -> Parser g s a -> Parser g s a Parser p `alt` Parser q = Parser r where-   r :: forall x. s -> (a -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+   r :: forall x. s -> (a -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x    r rest success failure = p rest success' failure'       where success' a len rest' _ = success a len rest' failure'             failure' f1 = q rest success (\f2 -> failure (f1 <> f2))@@ -75,24 +81,30 @@ instance Factorial.FactorialMonoid s => Filterable (Parser g s) where    mapMaybe :: forall a b. (a -> Maybe b) -> Parser g s a -> Parser g s b    mapMaybe f (Parser p) = Parser q where-      q :: forall x. s -> (b -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      q :: forall x. s -> (b -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x       q rest success failure = p rest (maybe filterFailure success . f) failure-         where filterFailure _ _ _ = failure (FailureInfo (Factorial.length rest) [Expected "filter"])+         where filterFailure _ _ _ = failure (expected (fromEnd $ Factorial.length rest) "filter")    {-# INLINABLE mapMaybe #-} +#if MIN_VERSION_base(4,13,0) instance Monad (Parser g s) where+#else+instance Factorial.FactorialMonoid s => Monad (Parser g s) where+#endif    return = pure    (>>=) :: forall a b. Parser g s a -> (a -> Parser g s b) -> Parser g s b    Parser p >>= f = Parser r where-      r :: forall x. s -> (b -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      r :: forall x. s -> (b -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x       r rest success failure = p rest                                  (\a len rest'-> applyParser (f a) rest' $ \b len'-> success b $! len + len')                                  failure +#if MIN_VERSION_base(4,13,0) instance Factorial.FactorialMonoid s => MonadFail (Parser g s) where-   fail msg = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected msg])+#endif+   fail msg = Parser (\rest _ failure-> failure $ erroneous (fromEnd $ Factorial.length rest) msg) -instance Factorial.FactorialMonoid s => MonadPlus (Parser g s) where+instance (Factorial.FactorialMonoid s, Ord s) => MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) @@ -101,60 +113,76 @@  instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>) -instance Factorial.FactorialMonoid s => Parsing (Parser g s) where+instance (Factorial.FactorialMonoid s, Ord s) => Parsing (Parser g s) where    try :: forall a. Parser g s a -> Parser g s a    try (Parser p) = Parser q-      where q :: forall x. s -> (a -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (a -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success (failure . rewindFailure)-               where rewindFailure (FailureInfo _pos _msgs) = FailureInfo (Factorial.length input) []+               where rewindFailure ParseFailure{} = ParseFailure (fromEnd $ Factorial.length input) [] []    (<?>) :: forall a. Parser g s a -> String -> Parser g s a    Parser p <?> msg  = Parser q-      where q :: forall x. s -> (a -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (a -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success (failure . replaceFailure)-               where replaceFailure (FailureInfo pos msgs) =-                        FailureInfo pos (if pos == Factorial.length input then [Expected msg] else msgs)+               where replaceFailure (ParseFailure pos msgs erroneous') =+                        ParseFailure pos (if pos == fromEnd (Factorial.length input) then [StaticDescription msg]+                                          else msgs) erroneous'    eof = Parser p       where p rest success failure                | Null.null rest = success () 0 rest failure-               | otherwise = failure (FailureInfo (Factorial.length rest) [Expected "end of input"])-   unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (Factorial.length t) [Expected msg])+               | otherwise = failure (expected (fromEnd $ Factorial.length rest) "end of input")+   unexpected msg = Parser (\t _ failure -> failure $ erroneous (fromEnd $ Factorial.length t) msg)    notFollowedBy (Parser p) = Parser q-      where q :: forall x. s -> (() -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (() -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success' failure'-               where success' _ _ _ _ = failure (FailureInfo (Factorial.length input) [Expected "notFollowedBy"])+               where success' _ _ _ _ = failure (expected (fromEnd $ Factorial.length input) "notFollowedBy")                      failure' _ = success () 0 input failure -instance Factorial.FactorialMonoid s => DeterministicParsing (Parser g s) where+instance (Factorial.FactorialMonoid s, Ord s) => DeterministicParsing (Parser g s) where    (<<|>) :: forall a. Parser g s a -> Parser g s a -> Parser g s a    Parser p <<|> Parser q = Parser r where-      r :: forall x. s -> (a -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      r :: forall x. s -> (a -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x       r rest success failure = p rest success' failure'          where success' a len rest' _ = success a len rest' failure                failure' f1 = q rest success (\f2 -> failure (f1 <> f2))    takeSome p = (:) <$> p <*> takeMany p    takeMany p = takeSome p <<|> pure [] -instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => CommittedParsing (Parser g s) where+   type CommittedResults (Parser g s) = ParseResults s+   commit :: forall a. Parser g s a -> Parser g s (ParseResults s a)+   commit (Parser p) = Parser q+      where q :: forall x. s -> (ParseResults s a -> Int -> s -> (ParseFailure Pos s -> x) -> x)+              -> (ParseFailure Pos s -> x) -> x+            q input success failure = p input (success . Right) failure'+               where failure' f = success (Left f) 0 input failure+   admit :: forall a. Parser g s (ParseResults s a) -> Parser g s a+   admit (Parser p) = Parser q+      where q :: forall x. s -> (a -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x+            q input success failure = p input success' failure+               where success' (Left f) _len _rest = const (failure f)+                     success' (Right a) len rest = success a len rest++instance (Factorial.FactorialMonoid s, Ord s) => LookAheadParsing (Parser g s) where    lookAhead :: forall a. Parser g s a -> Parser g s a    lookAhead (Parser p) = Parser q-      where q :: forall x. s -> (a -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (a -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success' failure'                where success' a _ _ = success a 0 input                      failure' f = failure f -instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where+instance (Show s, Ord s, TextualMonoid s) => CharParsing (Parser g s) where    satisfy predicate = Parser p-      where p :: forall x. s -> (Char -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (Char -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> success first 1 suffix failure-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "Char.satisfy"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s) => InputParsing (Parser g s) where+instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s, Ord s) => InputParsing (Parser g s) where    type ParserInput (Parser g s) = s    getInput = Parser p       where p rest success failure = success rest 0 rest failure@@ -162,98 +190,98 @@       where p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) -> success first 1 suffix failure-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "anyToken"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "anyToken")    satisfy predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) | predicate first -> success first 1 suffix failure-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfy"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "satisfy")    notSatisfy predicate = Parser p-      where p :: forall x. s -> (() -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (() -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, _)-                     | predicate first -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfy"])+                     | predicate first -> failure (expected (fromEnd $ Factorial.length rest) "notSatisfy")                   _ -> success () 0 rest failure    scan :: forall state. state -> (state -> s -> Maybe state) -> Parser g s s    scan s0 f = Parser (p s0)-      where p :: forall x. state -> s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. state -> s -> (s -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p s rest success failure = success prefix len suffix failure                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest                      !len = Factorial.length prefix    take n = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure                | (prefix, suffix) <- Factorial.splitAt n rest,                  len <- Factorial.length prefix, len == n = success prefix len suffix failure-               | otherwise = failure (FailureInfo (Factorial.length rest) [Expected $ "take " ++ show n])+               | otherwise = failure (expected (fromEnd $ Factorial.length rest) $ "take " ++ show n)    takeWhile predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure                 | (prefix, suffix) <- Factorial.span predicate rest,                   !len <- Factorial.length prefix =                      success prefix len suffix failure    takeWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure                | (prefix, suffix) <- Factorial.span predicate rest,                   !len <- Factorial.length prefix =                     if len == 0-                    then failure (FailureInfo (Factorial.length rest) [Expected "takeWhile1"])+                    then failure (expected (fromEnd $ Factorial.length rest) "takeWhile1")                     else success prefix len suffix failure    string s = Parser p where-      p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      p :: forall x. s -> (s -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x       p s' success failure          | Just suffix <- Cancellative.stripPrefix s s', !len <- Factorial.length s = success s len suffix failure-         | otherwise = failure (FailureInfo (Factorial.length s') [ExpectedInput s])+         | otherwise = failure (ParseFailure (fromEnd $ Factorial.length s') [LiteralDescription s] [])    {-# INLINABLE string #-} -instance (Cancellative.LeftReductive s, FactorialMonoid s) => ConsumedInputParsing (Parser g s) where+instance (Cancellative.LeftReductive s, FactorialMonoid s, Ord s) => ConsumedInputParsing (Parser g s) where    match :: forall a. Parser g s a -> Parser g s (s, a)    match (Parser p) = Parser q-      where q :: forall x. s -> ((s, a) -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> ((s, a) -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos 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+      where q :: forall x. s -> (a -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos 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+instance (Ord s, Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> success (Factorial.primePrefix rest) 1 suffix failure-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfyChar"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "satisfyChar")    notSatisfyChar predicate = Parser p-      where p :: forall x. s -> (() -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (() -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.characterPrefix rest                of Just first | predicate first-                               -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfyChar"])+                               -> failure (expected (fromEnd $ Factorial.length rest) "notSatisfyChar")                   _ -> success () 0 rest failure    scanChars :: forall state. state -> (state -> Char -> Maybe state) -> Parser g s s    scanChars s0 f = Parser (p s0)-      where p :: forall x. state -> s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. state -> s -> (s -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p s rest success failure = success prefix len suffix failure                where (prefix, suffix, _) = Textual.spanMaybe_' s f rest                      !len = Factorial.length prefix    takeCharsWhile predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure                | (prefix, suffix) <- Textual.span_ False predicate rest,                   !len <- Factorial.length prefix = success prefix len suffix failure    takeCharsWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (ParseFailure Pos s -> x) -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure-               | Null.null prefix = failure (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])+               | Null.null prefix = failure (expected (fromEnd $ Factorial.length rest) "takeCharsWhile1")                | otherwise = len `seq` success prefix len suffix failure                where (prefix, suffix) = Textual.span_ False predicate rest                      len = Factorial.length prefix@@ -264,17 +292,10 @@ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) => --                  g (Continued.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s) => MultiParsing (Parser g s) where+instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s, Ord s) => MultiParsing (Parser g s) where    type ResultFunctor (Parser g s) = ParseResults s    -- | Returns an input prefix parse paired with the remaining input suffix.-   parsePrefix g input = Rank2.fmap (Compose . (\p-> applyParser p input-                                                                 (\a _ rest _-> Right (rest, a))-                                                                 (Left . fromFailure input))) +   parsePrefix g input = Rank2.fmap (Compose . (\p-> applyParser p input (\a _ rest _-> Right (rest, a)) Left))                                      g-   parseComplete g input = Rank2.fmap (\p-> applyParser p input-                                                        (const . const . const . Right)-                                                        (Left . fromFailure input))+   parseComplete g input = Rank2.fmap (\p-> applyParser p input (const . const . const . Right) Left)                                       (Rank2.fmap (<* eof) g)--fromFailure :: (Eq s, FactorialMonoid s) => s -> FailureInfo s -> ParseFailure s-fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - pos + 1) (nub msgs)

@@ -1,7 +1,8 @@-{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, InstanceSigs,+{-# LANGUAGE ConstraintKinds, CPP, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, InstanceSigs,              RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators,              UndecidableInstances #-} {-# OPTIONS -fno-full-laziness #-}+-- | A context-free memoizing parser that can handle left-recursive grammars. module Text.Grampa.ContextFree.LeftRecursive (Fixed, Parser, SeparatedParser(..),                                               longest, peg, terminalPEG,                                               liftPositive, liftPure, mapPrimitive,@@ -9,10 +10,14 @@ where  import Control.Applicative-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..), void)+import Control.Monad (Monad(..), MonadPlus(..), void)+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif import Control.Monad.Trans.State.Lazy (State, evalState, get, put)  import Data.Functor.Compose (Compose(..))+import Data.Kind (Type) import Data.Maybe (isJust)  import Data.Semigroup (Semigroup(..))@@ -34,9 +39,10 @@  import qualified Rank2 import Text.Grampa.Class (GrammarParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),-                          AmbiguousParsing(..), ConsumedInputParsing(..), DeterministicParsing(..),-                          TailsParsing(parseTails, parseAllTails))-import Text.Grampa.Internal (ResultList(..), FailureInfo(..), FallibleResults(..),+                          AmbiguousParsing(..), CommittedParsing(..), ConsumedInputParsing(..),+                          DeterministicParsing(..),+                          TailsParsing(parseTails, parseAllTails), ParseResults, ParseFailure(..), Pos)+import Text.Grampa.Internal (ResultList(..), FallibleResults(..),                              AmbiguousAlternative(ambiguousOr), AmbiguityDecidable(..), AmbiguityWitness(..),                              TraceableParsing(..)) import qualified Text.Grampa.ContextFree.SortedMemoizing as Memoizing@@ -44,29 +50,39 @@  import Prelude hiding (cycle, null, span, take, takeWhile) +-- | A parser for left-recursive grammars type Parser = Fixed Memoizing.Parser -type ResultAppend p (g :: (* -> *) -> *) s =+type ResultAppend p (g :: (Type -> Type) -> Type) s =    GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s) +-- | A transformer that adds left-recursive powers to a memoizing parser @p@ over grammar @g@ data Fixed p g s a =+   -- | a fully general parser    Parser {       complete, direct, direct0, direct1, indirect :: p g s a,       isAmbiguous :: Maybe (AmbiguityWitness a),       cyclicDescendants :: Rank2.Apply g => g (Const (ParserFlags g)) -> ParserFlags g}+   -- | a parser that doesn't start with a 'nonTerminal'    | DirectParser {       complete, direct0, direct1 :: p g s a}+   -- | a parser that doesn't start with a 'nonTerminal' and always consumes some input    | PositiveDirectParser {       complete :: p g s a} -data SeparatedParser p (g :: (* -> *) -> *) s a = FrontParser (p g s a)-                                                | CycleParser {-                                                     cycleParser  :: p g s a,-                                                     backParser   :: p g s a,-                                                     appendResultsArrow :: ResultAppend p g s a,-                                                     dependencies :: Dependencies g}-                                                | BackParser {-                                                     backParser :: p g s a}+-- | A type of parsers analyzed for their left-recursion class+data SeparatedParser p (g :: (Type -> Type) -> Type) s a =+   -- | a parser that doesn't start with any 'nonTerminal' so it can run first+   FrontParser (p g s a)+   -- | a left-recursive parser that may add to the set of parse results every time it's run+   | CycleParser {+        cycleParser  :: p g s a,+        backParser   :: p g s a,+        appendResultsArrow :: ResultAppend p g s a,+        dependencies :: Dependencies g}+   -- | a parser that depends on other non-terminals but is not left-recursive+   | BackParser {+        backParser :: p g s a}  data ParserFlags g = ParserFlags {    nullable :: Bool,@@ -82,7 +98,7 @@ data ParserFunctor p g s a = ParserResultsFunctor {parserResults :: GrammarFunctor (p g s) a}                            | ParserFlagsFunctor {parserFlags :: ParserFlags g} -newtype Union (g :: (* -> *) -> *) = Union{getUnion :: g (Const Bool)}+newtype Union (g :: (Type -> Type) -> Type) = Union{getUnion :: g (Const Bool)}  --instance Rank2.Applicative g => Monoid (Union g) where --   mempty = Union (Rank2.pure $ Const False)@@ -92,7 +108,7 @@  instance (Rank2.Apply g, Rank2.Distributive g) => Monoid (Union g) where    mempty = Union (Rank2.cotraverse (Const . getConst) (Const False))-   mappend (Union g1) (Union g2) = Union (Rank2.liftA2 union g1 g2)+   mappend = (<>)  mapPrimitive :: forall p g s a b. AmbiguityDecidable b => (p g s a -> p g s b) -> Fixed p g s a -> Fixed p g s b mapPrimitive f p@PositiveDirectParser{} = PositiveDirectParser{complete= f (complete p)}@@ -154,13 +170,13 @@    type GrammarConstraint (Fixed p g s) g' = (GrammarConstraint (p g s) g', g ~ g',                                               Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)    type ResultFunctor (Fixed p g s) = ResultFunctor (p g s)-   parsePrefix :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, Eq s, FactorialMonoid s) =>-                  g (Fixed p g s) -> s -> g (Compose (ResultFunctor (p g s)) ((,) s))+   -- parsePrefix :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, Eq s, FactorialMonoid s) =>+   --                g (Fixed p g s) -> s -> g (Compose (ResultFunctor (p g s)) ((,) s))    parsePrefix g input = Rank2.fmap (Compose . parsingResult @(p g s) input)                                     (snd $ head $ parseRecursive g input)    {-# INLINE parsePrefix #-}-   parseComplete :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, Eq s, FactorialMonoid s) =>-                    g (Fixed p g s) -> s -> g (ResultFunctor (p g s))+   -- parseComplete :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, Eq s, FactorialMonoid s) =>+   --                  g (Fixed p g s) -> s -> g (ResultFunctor (p g s))    parseComplete g = \input-> let close :: g (p g s)                                   close = Rank2.fmap (<* eof) selfReferring                               in Rank2.fmap ((snd <$>) . parsingResult @(p g s) input)@@ -195,7 +211,7 @@    {-# INLINE nonTerminal #-}    recursive = general -bits :: forall (g :: (* -> *) -> *). (Rank2.Distributive g, Rank2.Traversable g) => g (Const (g (Const Bool)))+bits :: forall (g :: (Type -> Type) -> Type). (Rank2.Distributive g, Rank2.Traversable g) => g (Const (g (Const Bool))) bits = start `seq` Rank2.fmap oneBit start    where start = evalState (Rank2.traverse next (Rank2.distributeJoin Nothing)) 0          oneBit :: Const Int a -> Const (g (Const Bool)) a@@ -380,7 +396,9 @@             d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont)             p'@Parser{} = general' p +#if MIN_VERSION_base(4,13,0) instance (Alternative (p g s), MonadFail (p g s)) => MonadFail (Fixed p g s) where+#endif    fail msg = PositiveDirectParser{complete= fail msg}  instance MonadPlus (p g s) => MonadPlus (Fixed p g s) where@@ -392,7 +410,7 @@  instance (Alternative (p g s), Monoid x) => Monoid (Fixed p g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>)  primitive :: p g s a -> p g s a -> p g s a -> Fixed p g s a primitive d0 d1 d = DirectParser{complete= d,@@ -515,6 +533,36 @@             d1 = direct1 p *> mcp             mcp = skipAll (complete p) +instance (CommittedParsing (p g s), CommittedResults (p g s) ~ ParseResults s) => CommittedParsing (Fixed p g s) where+   type CommittedResults (Fixed p g s) = ParseResults s+   commit (PositiveDirectParser p) = PositiveDirectParser (commit p)+   commit p@DirectParser{} = DirectParser{+      complete = commit (complete p),+      direct0= commit (direct0 p),+      direct1= commit (direct1 p)}+   commit p@Parser{} = Parser{+      complete= commit (complete p),+      direct= commit (direct p),+      direct0= commit (direct0 p),+      direct1= commit (direct1 p),+      indirect= commit (indirect p),+      isAmbiguous= Nothing,+      cyclicDescendants= cyclicDescendants p}+   admit :: Fixed p g s (CommittedResults (Fixed p g s) a) -> Fixed p g s a+   admit (PositiveDirectParser p) = PositiveDirectParser (admit p)+   admit p@DirectParser{} = DirectParser{+      complete = admit (complete p),+      direct0= admit (direct0 p),+      direct1= admit (direct1 p)}+   admit p@Parser{} = Parser{+      complete= admit (complete p),+      direct= admit (direct p),+      direct0= admit (direct0 p),+      direct1= admit (direct1 p),+      indirect= admit (indirect p),+      isAmbiguous= Nothing,+      cyclicDescendants= cyclicDescendants p}+ instance (LookAheadParsing (p g s), InputParsing (Fixed p g s)) => LookAheadParsing (Fixed p g s) where    lookAhead p@PositiveDirectParser{} = DirectParser{       complete= lookAhead (complete p),@@ -633,7 +681,7 @@                             cyclicDescendants= cyclicDescendants p}  -- | 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 :: Ord s => 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),@@ -647,7 +695,7 @@                         cyclicDescendants= cyclicDescendants p}  -- | 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 :: (Monoid s, Ord 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),@@ -669,6 +717,7 @@ parseRecursive = parseSeparated . separated {-# INLINE parseRecursive #-} +-- | Analyze the grammar's production interdependencies and produce a 'SeparatedParser' from each production's parser. separated :: forall p g s. (Alternative (p g s), Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g,                             AmbiguousAlternative (GrammarFunctor (p g s))) =>              g (Fixed p g s) -> g (SeparatedParser p g s)@@ -693,7 +742,7 @@          appendResults (Just (AmbiguityWitness Refl)) = ambiguousOr          appendResults Nothing = (<|>)          descendants = Rank2.fmap (Const . dependsOn . getConst) cyclicDescendantses-         cyclicDescendantses = fixDescendants (Rank2.fmap (Const . cyclicDescendants . general) g)+         cyclicDescendantses = fixDescendants (Rank2.fmap (\p-> Const $ cyclicDescendants $ general p) g)          circulars = Rank2.liftA2 leftRecursive bits cyclicDescendantses          cycleFollowers = getUnion (Rank2.foldMap (Union . getConst) $                                     Rank2.liftA2 leftRecursiveDeps circulars cyclicDescendantses)@@ -725,12 +774,12 @@             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+         nullabilities = fixNullabilities gf {-# INLINABLE fixDescendants #-}  fixNullabilities :: forall g. (Rank2.Apply g, Rank2.Traversable g)-                    => g (Const (g (Const (ParserFlags g)) -> (ParserFlags g))) -> Dependencies g-fixNullabilities gf = StaticDependencies (Const . nullable . getConst Rank2.<$> go initial)+                    => g (Const (g (Const (ParserFlags g)) -> (ParserFlags g))) -> g (Const Bool)+fixNullabilities gf = Const . nullable . getConst Rank2.<$> go initial    where go :: g (Const (ParserFlags g)) -> g (Const (ParserFlags g))          go cd             | getAll (Rank2.foldMap (All . getConst) $ Rank2.liftA2 agree cd cd') = cd@@ -740,9 +789,7 @@          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--- left-recursive productions, the second all others. The first function argument specifies the left-recursive--- dependencies among the grammar productions.+-- | Parse the given input using a context-free grammar 'separated' into left-recursive and other productions. parseSeparated :: forall p g rl s. (Rank2.Apply g, Rank2.Foldable g, Eq s, FactorialMonoid s, LeftReductive s,                                     TailsParsing (p g s), GrammarConstraint (p g s) g,                                     GrammarFunctor (p g s) ~ rl s, FallibleResults rl,@@ -807,16 +854,20 @@                                              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 :: FailureInfo s -> Const Bool x -> GrammarFunctor (p g s) x -> Const Bool x+                           combineFailures :: ParseFailure Pos s -> Const Bool x -> GrammarFunctor (p g s) x+                                           -> Const Bool x                            combine (Const False) _ = Const False                            combine (Const True) results = Const (hasSuccess results)                            combineFailures _ (Const False) _ = Const False-                           combineFailures (FailureInfo pos expected) (Const True) rl =-                              Const (pos > pos' || pos == pos' && any (`notElem` expected) expected')-                              where FailureInfo pos' expected' = failureOf rl+                           combineFailures (ParseFailure pos expected erroneous) (Const True) rl =+                              Const (pos < pos'+                                     || pos == pos' && (any (`notElem` expected) expected'+                                                        || any (`notElem` erroneous) erroneous'))+                              where ParseFailure pos' expected' erroneous' = failureOf rl                   choiceWhile (Const (Just DynamicDependencies)) t t'                      | getAny (Rank2.foldMap (Any . hasSuccess) marginal) = t'-                     | FailureInfo _ [] <- failureOf t = t'+                     | hasSuccess t = t+                     | ParseFailure _ [] [] <- failureOf t = t'                      | otherwise = t           -- Adds another round of indirect parsing results to the total results accumulated so far.

@@ -1,4 +1,6 @@ {-# Language GADTs #-}+-- | A context-free parser that can handle left-recursive grammars and carry a+-- monadic computation with each parsing result. module Text.Grampa.ContextFree.LeftRecursive.Transformer (ParserT, SeparatedParser(..), AmbiguityDecidable,                                                           lift, liftPositive, tbind, tmap,                                                           parseSeparated, separated)@@ -12,7 +14,7 @@ type ParserT m = Fixed (Transformer.ParserT m)  -- | Lift a parse-free computation into the parser.-lift :: Applicative m => m a -> ParserT m g s a+lift :: (Applicative m, Ord s) => m a -> ParserT m g s a lift = liftPure . Transformer.lift  -- | Transform the computation carried by the parser using the monadic bind ('>>=').

@@ -1,24 +1,29 @@-{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,+{-# LANGUAGE CPP, FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,              RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+-- | A context-free parser with packrat-like memoization of parse results. module Text.Grampa.ContextFree.Memoizing        {-# DEPRECATED "Use Text.Grampa.ContextFree.SortedMemoizing instead" #-}-       (FailureInfo(..), ResultList(..), Parser(..), BinTree(..),-        fromResultList, reparseTails, longest, peg, terminalPEG)+       (ResultList(..), Parser(..), BinTree(..),+        reparseTails, longest, peg, terminalPEG) where  import Control.Applicative-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..))+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif import Data.Function (on) import Data.Foldable (toList) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.List (genericLength, maximumBy, nub)+import Data.List (maximumBy) import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Null (MonoidNull(null)) import Data.Monoid.Factorial (FactorialMonoid, length, splitPrimePrefix) import Data.Monoid.Textual (TextualMonoid) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual+import Data.Ord (Down(Down)) import Data.Semigroup (Semigroup((<>))) import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString)@@ -34,8 +39,8 @@  import Text.Grampa.Class (GrammarParsing(..), MultiParsing(..),                           DeterministicParsing(..), InputParsing(..), InputCharParsing(..),-                          TailsParsing(parseTails), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (BinTree(..), FailureInfo(..), TraceableParsing(..))+                          TailsParsing(parseTails), ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (BinTree(..), TraceableParsing(..), expected, erroneous) import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack  import Prelude hiding (iterate, length, null, showList, span, takeWhile)@@ -44,7 +49,7 @@ -- grammars. newtype Parser g s r = Parser{applyParser :: [(s, g (ResultList g s))] -> ResultList g s r} -data ResultList g s r = ResultList !(BinTree (ResultInfo g s r)) {-# UNPACK #-} !(FailureInfo s)+data ResultList g s r = ResultList !(BinTree (ResultInfo g s r)) {-# UNPACK #-} !(ParseFailure Pos s) data ResultInfo g s r = ResultInfo !Int ![(s, g (ResultList g s))] !r  instance (Show s, Show r) => Show (ResultList g s r) where@@ -72,10 +77,10 @@ instance Filterable (ResultList g s) where    mapMaybe f (ResultList l failure) = ResultList (mapMaybe (traverse f) l) failure -instance Semigroup (ResultList g s r) where+instance Ord s => Semigroup (ResultList g s r) where    ResultList rl1 f1 <> ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2) -instance Monoid (ResultList g s r) where+instance Ord s => Monoid (ResultList g s r) where    mempty = ResultList mempty mempty    mappend = (<>) @@ -83,7 +88,7 @@    fmap f (Parser p) = Parser (fmap f . p)    {-# INLINABLE fmap #-} -instance Applicative (Parser g i) where+instance Ord s => Applicative (Parser g s) where    pure a = Parser (\rest-> ResultList (Leaf $ ResultInfo 0 rest a) mempty)    Parser p <*> Parser q = Parser r where       r rest = case p rest@@ -94,8 +99,8 @@    {-# INLINABLE pure #-}    {-# INLINABLE (<*>) #-} -instance Alternative (Parser g i) where-   empty = Parser (\rest-> ResultList mempty $ FailureInfo (genericLength rest) [Expected "empty"])+instance Ord s => Alternative (Parser g s) where+   empty = Parser (\rest-> ResultList mempty $ ParseFailure (Down $ length rest) [] [])    Parser p <|> Parser q = Parser r where       r rest = p rest <> q rest    {-# INLINABLE (<|>) #-}@@ -104,7 +109,7 @@    mapMaybe f (Parser p) = Parser (mapMaybe f . p)    {-# INLINABLE mapMaybe #-} -instance Monad (Parser g i) where+instance Ord s => Monad (Parser g s) where    return = pure    Parser p >>= f = Parser q where       q rest = case p rest@@ -113,31 +118,33 @@       continue' l (ResultList rs failure) = ResultList (adjust l <$> rs) failure       adjust l (ResultInfo l' rest' a) = ResultInfo (l+l') rest' a -instance MonadFail (Parser g s) where+#if MIN_VERSION_base(4,13,0)+instance Ord s => MonadFail (Parser g s) where+#endif    fail msg = Parser p-      where p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected msg])+      where p rest = ResultList mempty (erroneous (Down $ length rest) msg) -instance MonadPlus (Parser g s) where+instance Ord s => MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) -instance Semigroup x => Semigroup (Parser g s x) where+instance (Semigroup x, Ord s) => Semigroup (Parser g s x) where    (<>) = liftA2 (<>) -instance Monoid x => Monoid (Parser g s x) where+instance (Monoid x, Ord s) => Monoid (Parser g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>) -instance (Eq s, LeftReductive s, FactorialMonoid s) => GrammarParsing (Parser g s) where+instance (Ord 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+   parsingResult _ = Compose . fromResultList    nonTerminal f = Parser p where       p ((_, d) : _) = f d-      p _ = ResultList mempty (FailureInfo 0 [Expected "NonTerminal at endOfInput"])+      p _ = ResultList mempty (expected 0 "NonTerminal at endOfInput")    {-# INLINE nonTerminal #-} -instance (Eq s, LeftReductive s, FactorialMonoid s) => TailsParsing (Parser g s) where+instance (Ord 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@@ -147,14 +154,14 @@ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) => --                  g (Memoizing.'Parser' g s) -> s -> g ('Compose' ('ParseResults' s) []) -- @-instance (LeftReductive s, FactorialMonoid s) => MultiParsing (Parser g s) where+instance (LeftReductive s, FactorialMonoid s, Ord s) => MultiParsing (Parser g s) where    type GrammarConstraint (Parser g s) g' = (g ~ g', Rank2.Functor g)    type ResultFunctor (Parser g s) = Compose (ParseResults s) []    -- | Returns the list of all possible input prefix parses paired with the remaining input suffix.-   parsePrefix g input = Rank2.fmap (Compose . Compose . fromResultList input) (snd $ head $ parseGrammarTails g input)-   parseComplete :: (Rank2.Functor g, Eq s, FactorialMonoid s) =>-                    g (Parser g s) -> s -> g (Compose (ParseResults s) [])-   parseComplete g input = Rank2.fmap ((snd <$>) . Compose . fromResultList input)+   parsePrefix g input = Rank2.fmap (Compose . Compose . fromResultList) (snd $ head $ parseGrammarTails g input)+   -- parseComplete :: (Rank2.Functor g, Eq s, FactorialMonoid s) =>+   --                  g (Parser g s) -> s -> g (Compose (ParseResults s) [])+   parseComplete g input = Rank2.fmap ((snd <$>) . Compose . fromResultList)                               (snd $ head $ reparseTails close $ parseGrammarTails g input)       where close = Rank2.fmap (<* eof) g @@ -169,7 +176,7 @@ reparseTails final parsed@((s, _):_) = (s, gd):parsed    where gd = Rank2.fmap (`applyParser` parsed) final -instance (LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+instance (LeftReductive s, FactorialMonoid s, Ord s) => InputParsing (Parser g s) where    type ParserInput (Parser g s) = s    getInput = Parser p       where p rest@((s, _):_) = ResultList (Leaf $ ResultInfo 0 rest s) mempty@@ -177,14 +184,14 @@    anyToken = Parser p       where p rest@((s, _):t) = case splitPrimePrefix s                                 of Just (first, _) -> ResultList (Leaf $ ResultInfo 1 t first) mempty-                                   _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "anyToken"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "anyToken"])+                                   _ -> ResultList mempty (expected (Down $ length rest) "anyToken")+            p [] = ResultList mempty (expected 0 "anyToken")    satisfy predicate = Parser p       where p rest@((s, _):t) =                case splitPrimePrefix s                of Just (first, _) | predicate first -> ResultList (Leaf $ ResultInfo 1 t first) mempty-                  _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "satisfy"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "satisfy"])+                  _ -> ResultList mempty (expected (Down $ length rest) "satisfy")+            p [] = ResultList mempty (expected 0 "satisfy")    scan s0 f = Parser (p s0)       where p s rest@((i, _) : _) = ResultList (Leaf $ ResultInfo l (drop l rest) prefix) mempty                where (prefix, _, _) = Factorial.spanMaybe' s f i@@ -195,7 +202,7 @@       where p rest@((s, _) : _)                | x <- Factorial.take n s, l <- Factorial.length x, l == n =                     ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty-            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected $ "take " ++ show n])+            p rest = ResultList mempty (expected (Down $ length rest) $ "take " ++ show n)    takeWhile predicate = Parser p       where p rest@((s, _) : _)                | x <- Factorial.takeWhile predicate s, l <- Factorial.length x =@@ -205,16 +212,16 @@       where p rest@((s, _) : _)                | 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 (genericLength rest) [Expected "takeWhile1"])+            p rest = ResultList mempty (expected (Down $ length rest) "takeWhile1")    string s = Parser p where       p rest@((s', _) : _)          | s `isPrefixOf` s' = ResultList (Leaf $ ResultInfo l (Factorial.drop l rest) s) mempty-      p rest = ResultList mempty (FailureInfo (genericLength rest) [ExpectedInput s])+      p rest = ResultList mempty (ParseFailure (Down $ length rest) [LiteralDescription s] [])       l = Factorial.length s    notSatisfy predicate = Parser p       where p rest@((s, _):_)                | Just (first, _) <- splitPrimePrefix s, -                 predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfy"])+                 predicate first = ResultList mempty (expected (Down $ length rest) "notSatisfy")             p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty    {-# INLINABLE string #-} @@ -224,14 +231,15 @@                                 of rl@(ResultList EmptyTree _) -> 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+instance (Ord s, Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    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 (genericLength rest) [Expected "satisfyCharInput"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "satisfyCharInput"])+                  _ -> ResultList mempty (expected (Down $ length rest) "satisfyCharInput")+            p [] = ResultList mempty (expected 0 "satisfyCharInput")    scanChars s0 f = Parser (p s0)       where p s rest@((i, _) : _) = ResultList (Leaf $ ResultInfo l (drop l rest) prefix) mempty                where (prefix, _, _) = Textual.spanMaybe_' s f i@@ -246,36 +254,38 @@       where p rest@((s, _) : _)                | 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 (genericLength rest) [Expected "takeCharsWhile1"])+            p rest = ResultList mempty (expected (Down $ length rest) "takeCharsWhile1")    notSatisfyChar predicate = Parser p       where p rest@((s, _):_)                | Just first <- Textual.characterPrefix s, -                 predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfyChar"])+                 predicate first = ResultList mempty (expected (Down $ length rest) "notSatisfyChar")             p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty -instance MonoidNull s => Parsing (Parser g s) where+instance (MonoidNull s, Ord s) => Parsing (Parser g s) where    try (Parser p) = Parser q       where q rest = rewindFailure (p rest)-               where rewindFailure (ResultList rl (FailureInfo _pos _msgs)) =-                        ResultList rl (FailureInfo (genericLength rest) [])+               where rewindFailure (ResultList rl _) = ResultList rl (ParseFailure (Down $ length rest) [] [])    Parser p <?> msg  = Parser q       where q rest = replaceFailure (p rest)-               where replaceFailure (ResultList EmptyTree (FailureInfo pos msgs)) =-                        ResultList EmptyTree (FailureInfo pos $ if pos == genericLength rest then [Expected msg] else msgs)+               where replaceFailure (ResultList EmptyTree (ParseFailure pos msgs erroneous')) =+                        ResultList EmptyTree (ParseFailure pos+                                                 (if pos == Down (length rest) then [StaticDescription msg]+                                                  else msgs)+                                                 erroneous')                      replaceFailure rl = rl    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))       where rewind t (ResultList EmptyTree _) = ResultList (Leaf $ ResultInfo 0 t ()) mempty-            rewind t ResultList{} = ResultList mempty (FailureInfo (genericLength t) [Expected "notFollowedBy"])+            rewind t ResultList{} = ResultList mempty (expected (Down $ length t) "notFollowedBy")    skipMany p = go       where go = pure () <|> p *> go-   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (genericLength t) [Expected msg])+   unexpected msg = Parser (\t-> ResultList mempty $ expected (Down $ length t) msg)    eof = Parser f       where f rest@((s, _):_)                | null s = ResultList (Leaf $ ResultInfo 0 rest ()) mempty-               | otherwise = ResultList mempty (FailureInfo (genericLength rest) [Expected "endOfInput"])+               | otherwise = ResultList mempty (expected (Down $ length rest) "endOfInput")             f [] = ResultList (Leaf $ ResultInfo 0 [] ()) mempty -instance MonoidNull s => DeterministicParsing (Parser g s) where+instance (MonoidNull s, Ord s) => DeterministicParsing (Parser g s) where    Parser p <<|> Parser q = Parser r where       r rest = case p rest                of rl@(ResultList EmptyTree _failure) -> rl <> q rest@@ -292,24 +302,25 @@                       ResultList rl _failure -> foldMap continue rl          where continue (ResultInfo len' rest' _) = q (len + len') rest' -instance MonoidNull s => LookAheadParsing (Parser g s) where+instance (MonoidNull s, Ord 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 0 t r -instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where+instance (Ord s, Show s, TextualMonoid s) => CharParsing (Parser g s) where    satisfy predicate = Parser p       where p rest@((s, _):t) =                case Textual.characterPrefix s                of Just first | predicate first -> ResultList (Leaf $ ResultInfo 1 t first) mempty-                  _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "Char.satisfy"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "Char.satisfy"])+                  _ -> ResultList mempty (expected (Down $ length rest) "Char.satisfy")+            p [] = ResultList mempty (expected 0 "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -fromResultList :: (Eq s, FactorialMonoid s) => s -> ResultList g s r -> ParseResults s [(s, r)]-fromResultList s (ResultList EmptyTree (FailureInfo pos msgs)) = Left (ParseFailure (length s - pos + 1) (nub msgs))-fromResultList _ (ResultList rl _failure) = Right (f <$> toList rl)+fromResultList :: FactorialMonoid s => ResultList g s r -> ParseResults s [(s, r)]+fromResultList (ResultList EmptyTree (ParseFailure pos positive negative)) =+   Left (ParseFailure (pos - 1) positive negative)+fromResultList (ResultList rl _failure) = Right (f <$> toList rl)    where f (ResultInfo _ ((s, _):_) r) = (s, r)          f (ResultInfo _ [] r) = (mempty, r) @@ -318,22 +329,25 @@ longest :: 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 (FailureInfo pos expected) -> Backtrack.NoParse (FailureInfo pos $ map message expected)+            of ResultList EmptyTree (ParseFailure pos positive negative)+                  -> Backtrack.NoParse (ParseFailure pos (map message positive) (map message negative))                ResultList rs _ -> parsed (maximumBy (compare `on` resultLength) rs)    resultLength (ResultInfo l _ _) = l    parsed (ResultInfo l s r) = Backtrack.Parsed l r s-   message (Expected msg) = Expected msg-   message (ExpectedInput s) = ExpectedInput [(s, error "longest")]+   message (StaticDescription msg) = StaticDescription msg+   message (LiteralDescription s) = LiteralDescription [(s, error "longest")]  -- | 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 :: Ord s => 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 (FailureInfo pos expected) -> ResultList mempty (FailureInfo pos ((fst . head <$>) <$> expected))+               Backtrack.NoParse (ParseFailure pos positive negative)+                  -> ResultList mempty (ParseFailure pos (original <$> positive) (original <$> negative))+      where original = (fst . head <$>)  -- | Turns a backtracking PEG parser into a context-free parser-terminalPEG :: Monoid s => Backtrack.Parser g s a -> Parser g s a+terminalPEG :: (Monoid s, Ord 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

@@ -1,14 +1,18 @@-{-# LANGUAGE FlexibleContexts, InstanceSigs, GeneralizedNewtypeDeriving,+{-# LANGUAGE CPP, FlexibleContexts, InstanceSigs, GeneralizedNewtypeDeriving,              RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}-module Text.Grampa.ContextFree.Parallel (FailureInfo(..), ResultList(..), Parser, fromResultList)+-- | A context-free, non-memoizing parser that handles all alternatives in parallel.+module Text.Grampa.ContextFree.Parallel (ResultList(..), Parser) where  import Control.Applicative-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..))+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif import Data.Foldable (toList) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.List (nub)+import Data.Kind (Type) import Data.Semigroup (Semigroup(..)) import qualified Data.Semigroup.Cancellative as Cancellative import Data.Monoid (Monoid(mappend, mempty))@@ -26,20 +30,22 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))+import Text.Parser.Input.Position (fromEnd)  import qualified Rank2 -import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),-                          ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (BinTree(..), FailureInfo(..), noFailure, TraceableParsing(..))+import Text.Grampa.Class (CommittedParsing(..), DeterministicParsing(..),+                          InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (BinTree(..), expected, noFailure, TraceableParsing(..))  import Prelude hiding (iterate, null, showList, span, takeWhile)  -- | Parser type for context-free grammars using a parallel parsing algorithm with no result sharing nor left recursion -- support.-newtype Parser (g :: (* -> *) -> *) s r = Parser{applyParser :: s -> ResultList s r}+newtype Parser (g :: (Type -> Type) -> Type) s r = Parser{applyParser :: s -> ResultList s r} -data ResultList s r = ResultList !(BinTree (ResultInfo s r)) {-# UNPACK #-} !(FailureInfo s)+data ResultList s r = ResultList !(BinTree (ResultInfo s r)) {-# UNPACK #-} !(ParseFailure Pos s) data ResultInfo s r = ResultInfo !s !r  instance (Show s, Show r) => Show (ResultList s r) where@@ -67,17 +73,17 @@ instance Functor (ResultList s) where    fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure -instance Semigroup (ResultList s r) where+instance Ord s => Semigroup (ResultList s r) where    ResultList rl1 f1 <> ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2) -instance Monoid (ResultList s r) where+instance Ord s => Monoid (ResultList s r) where    mempty = ResultList mempty noFailure    mappend = (<>)  instance Functor (Parser g s) where    fmap f (Parser p) = Parser (fmap f . p) -instance Applicative (Parser g s) where+instance Ord s => Applicative (Parser g s) where    pure a = Parser (\rest-> ResultList (Leaf $ ResultInfo rest a) noFailure)    Parser p <*> Parser q = Parser r where       r rest = case p rest@@ -85,34 +91,40 @@       continue (ResultInfo rest' f) = f <$> q rest'  -instance FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\s-> ResultList mempty $ FailureInfo (Factorial.length s) [Expected "empty"])+instance (FactorialMonoid s, Ord s) => Alternative (Parser g s) where+   empty = Parser (\s-> ResultList mempty $ ParseFailure (fromEnd $ Factorial.length s) [] [])    Parser p <|> Parser q = Parser r where       r rest = p rest <> q rest  instance FactorialMonoid s => Filterable (Parser g s) where    mapMaybe f (Parser p) = Parser (mapMaybe f . p) -instance Monad (Parser g s) where+#if MIN_VERSION_base(4,13,0)+instance Ord s => Monad (Parser g s) where+#else+instance (Factorial.FactorialMonoid s, Ord s) => Monad (Parser g s) where+#endif    return = pure    Parser p >>= f = Parser q where       q rest = case p rest                of ResultList results failure -> ResultList mempty failure <> foldMap continue results       continue (ResultInfo rest' a) = applyParser (f a) rest' -instance FactorialMonoid s => MonadFail (Parser g s) where-   fail msg = Parser (\s-> ResultList mempty $ FailureInfo (Factorial.length s) [Expected msg])+#if MIN_VERSION_base(4,13,0)+instance (FactorialMonoid s, Ord s) => MonadFail (Parser g s) where+#endif+   fail msg = Parser (\s-> ResultList mempty $ ParseFailure (fromEnd $ Factorial.length s) [] [StaticDescription msg]) -instance FactorialMonoid s => MonadPlus (Parser g s) where+instance (FactorialMonoid s, Ord s) => MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) -instance Semigroup x => Semigroup (Parser g s x) where+instance (Ord s, Semigroup x) => Semigroup (Parser g s x) where    (<>) = liftA2 (<>) -instance Monoid x => Monoid (Parser g s x) where+instance (Monoid x, Ord s) => Monoid (Parser g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>)  -- | Parallel parser produces a list of all possible parses. --@@ -120,31 +132,31 @@ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, Eq s, 'FactorialMonoid' s) => --                  g (Parallel.'Parser' g s) -> s -> g ('Compose' ('ParseResults' s) []) -- @-instance (Cancellative.LeftReductive s, FactorialMonoid s) => MultiParsing (Parser g s) where+instance (Cancellative.LeftReductive s, FactorialMonoid s, Ord s) => MultiParsing (Parser g s) where    type ResultFunctor (Parser g s) = Compose (ParseResults s) []    -- | Returns the list of all possible input prefix parses paired with the remaining input suffix.-   parsePrefix g input = Rank2.fmap (Compose . Compose . fromResultList input . (`applyParser` input)) g+   parsePrefix g input = Rank2.fmap (Compose . Compose . fromResultList . (`applyParser` input)) g    -- | Returns the list of all possible parses of complete input.    parseComplete :: (Rank2.Functor g', Eq s, FactorialMonoid s) =>                     g' (Parser g s) -> s -> g' (Compose (ParseResults s) [])    parseComplete g input = Rank2.fmap ((snd <$>) . getCompose) (parsePrefix (Rank2.fmap (<* eof) g) input) -instance (Cancellative.LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+instance (Cancellative.LeftReductive s, FactorialMonoid s, Ord s) => InputParsing (Parser g s) where    type ParserInput (Parser g s) = s    getInput = Parser p       where p s = ResultList (Leaf $ ResultInfo s s) noFailure    anyToken = Parser p       where p s = case Factorial.splitPrimePrefix s                   of Just (first, rest) -> ResultList (Leaf $ ResultInfo rest first) noFailure-                     _ -> ResultList mempty (FailureInfo (Factorial.length s) [Expected "anyToken"])+                     _ -> ResultList mempty (expected (fromEnd $ Factorial.length s) "anyToken")    satisfy predicate = Parser p       where p s = case Factorial.splitPrimePrefix s                   of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) noFailure-                     _ -> ResultList mempty (FailureInfo (Factorial.length s) [Expected "satisfy"])+                     _ -> ResultList mempty (expected (fromEnd $ Factorial.length s) "satisfy")    notSatisfy predicate = Parser p       where p s = case Factorial.splitPrimePrefix s                   of Just (first, _) -                        | predicate first -> ResultList mempty (FailureInfo (Factorial.length s) [Expected "notSatisfy"])+                        | predicate first -> ResultList mempty (expected (fromEnd $ Factorial.length s) "notSatisfy")                      _ -> ResultList (Leaf $ ResultInfo s ()) noFailure    scan s0 f = Parser (p s0)       where p s i = ResultList (Leaf $ ResultInfo suffix prefix) noFailure@@ -153,18 +165,18 @@       where p s               | (prefix, suffix) <- Factorial.splitAt n s,                 Factorial.length prefix == n = ResultList (Leaf $ ResultInfo suffix prefix) noFailure-              | otherwise = ResultList mempty (FailureInfo (Factorial.length s) [Expected $ "take " ++ show n])+              | otherwise = ResultList mempty (expected (fromEnd $ Factorial.length s) $ "take " ++ show n)    takeWhile predicate = Parser p       where p s = ResultList (Leaf $ ResultInfo suffix prefix) noFailure               where (prefix, suffix) = Factorial.span predicate s    takeWhile1 predicate = Parser p       where p s | (prefix, suffix) <- Factorial.span predicate s =                 if Null.null prefix-               then ResultList mempty (FailureInfo (Factorial.length s) [Expected "takeWhile1"])+               then ResultList mempty (expected (fromEnd $ Factorial.length s) "takeWhile1")                else ResultList (Leaf $ ResultInfo suffix prefix) noFailure    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])+           | otherwise = ResultList mempty (ParseFailure (fromEnd $ Factorial.length s') [LiteralDescription s] [])  instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where    traceInput description (Parser p) = Parser q@@ -173,17 +185,17 @@                      rl -> traceWith "Parsed " rl                where traceWith prefix = trace (prefix <> description s) -instance TextualMonoid s => InputCharParsing (Parser g s) where+instance (Ord s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p       where p s =                case Textual.splitCharacterPrefix s                of Just (first, rest)                      | predicate first -> ResultList (Leaf $ ResultInfo rest $ Factorial.primePrefix s) noFailure-                  _ -> ResultList mempty (FailureInfo (Factorial.length s) [Expected "satisfyCharInput"])+                  _ -> ResultList mempty (expected (fromEnd $ Factorial.length s) "satisfyCharInput")    notSatisfyChar predicate = Parser p       where p s = case Textual.characterPrefix s-                  of Just first -                        | predicate first -> ResultList mempty (FailureInfo (Factorial.length s) [Expected "notSatisfyChar"])+                  of Just first | predicate first+                        -> ResultList mempty (expected (fromEnd $ Factorial.length s) "notSatisfyChar")                      _ -> ResultList (Leaf $ ResultInfo s ()) noFailure    scanChars s0 f = Parser (p s0)       where p s i = ResultList (Leaf $ ResultInfo suffix prefix) noFailure@@ -194,31 +206,34 @@    takeCharsWhile1 predicate = Parser p       where p s | (prefix, suffix) <- Textual.span_ False predicate s =                if null prefix-               then ResultList mempty (FailureInfo (Factorial.length s) [Expected "takeCharsWhile1"])+               then ResultList mempty (expected (fromEnd $ Factorial.length s) "takeCharsWhile1")                else ResultList (Leaf $ ResultInfo suffix prefix) noFailure -instance FactorialMonoid s => Parsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => Parsing (Parser g s) where    try (Parser p) = Parser q       where q rest = rewindFailure (p rest)-               where rewindFailure (ResultList rl (FailureInfo _pos _msgs)) =-                        ResultList rl (FailureInfo (Factorial.length rest) [])+               where rewindFailure (ResultList rl _) =+                        ResultList rl (ParseFailure (fromEnd $ Factorial.length rest) [] [])    Parser p <?> msg  = Parser q       where q rest = replaceFailure (p rest)-               where replaceFailure (ResultList EmptyTree (FailureInfo pos msgs)) =-                        ResultList EmptyTree (FailureInfo pos $-                                              if pos == Factorial.length rest then [Expected msg] else msgs)+               where replaceFailure (ResultList EmptyTree (ParseFailure pos msgs erroneous)) =+                        ResultList EmptyTree (ParseFailure pos+                                                           (if pos == fromEnd (Factorial.length rest)+                                                            then [StaticDescription msg] else msgs)+                                                           erroneous)                      replaceFailure rl = rl    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))       where rewind t (ResultList EmptyTree _) = ResultList (Leaf $ ResultInfo t ()) noFailure-            rewind t ResultList{} = ResultList mempty (FailureInfo (Factorial.length t) [Expected "notFollowedBy"])+            rewind t ResultList{} = ResultList mempty (expected (fromEnd $ Factorial.length t) "notFollowedBy")    skipMany p = go       where go = pure () <|> try p *> go-   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (Factorial.length t) [Expected msg])+   unexpected msg = Parser (\t-> ResultList mempty+                                 $ ParseFailure (fromEnd $ Factorial.length t) [] [StaticDescription msg])    eof = Parser f       where f s | null s = ResultList (Leaf $ ResultInfo s ()) noFailure-                | otherwise = ResultList mempty (FailureInfo (Factorial.length s) [Expected "end of input"])+                | otherwise = ResultList mempty (expected (fromEnd $ Factorial.length s) "end of input") -instance FactorialMonoid s => DeterministicParsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => DeterministicParsing (Parser g s) where    Parser p <<|> Parser q = Parser r where       r rest = case p rest                of rl@(ResultList EmptyTree _failure) -> rl <> q rest@@ -235,22 +250,34 @@                   ResultList rl _failure -> foldMap continue rl          where continue (ResultInfo rest' _) = q rest' -instance FactorialMonoid s => LookAheadParsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => CommittedParsing (Parser g s) where+   type CommittedResults (Parser g s) = ParseResults s+   commit (Parser p) = Parser q+      where q rest = case p rest+                     of ResultList EmptyTree failure -> ResultList (Leaf $ ResultInfo rest $ Left failure) mempty+                        ResultList rl failure -> ResultList (fmap Right <$> rl) failure+   admit (Parser p) = Parser q+      where q rest = case p rest+                     of ResultList EmptyTree failure -> ResultList EmptyTree failure+                        ResultList rl failure -> foldMap expose rl <> ResultList EmptyTree failure+            expose (ResultInfo _ (Left failure)) = ResultList EmptyTree failure+            expose (ResultInfo rest (Right r)) = ResultList (Leaf $ ResultInfo rest r) mempty++instance (FactorialMonoid s, Ord 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 -instance TextualMonoid s => CharParsing (Parser g s) where+instance (TextualMonoid s, Ord s) => CharParsing (Parser g s) where    satisfy predicate = Parser p       where p s =                case Textual.splitCharacterPrefix s                of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) noFailure-                  _ -> ResultList mempty (FailureInfo (Factorial.length s) [Expected "Char.satisfy"])+                  _ -> ResultList mempty (expected (fromEnd $ Factorial.length s) "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -fromResultList :: (Eq s, FactorialMonoid s) => s -> ResultList s r -> ParseResults s [(s, r)]-fromResultList s (ResultList EmptyTree (FailureInfo pos msgs)) = -   Left (ParseFailure (Factorial.length s - pos) (nub msgs))-fromResultList _ (ResultList rl _failure) = Right (f <$> toList rl)+fromResultList :: (Eq s, FactorialMonoid s) => ResultList s r -> ParseResults s [(s, r)]+fromResultList (ResultList EmptyTree failure) = Left failure+fromResultList (ResultList rl _failure) = Right (f <$> toList rl)    where f (ResultInfo s r) = (s, r)

@@ -1,21 +1,26 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,+{-# LANGUAGE BangPatterns, CPP, FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,              RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+-- | A context-free memoizing parser that handles all alternatives in parallel. module Text.Grampa.ContextFree.SortedMemoizing -       (FailureInfo(..), ResultList(..), Parser(..),+       (ParseFailure(..), ResultList(..), Parser(..),         longest, peg, terminalPEG) where  import Control.Applicative-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..))+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif+import Data.Either (partitionEithers) import Data.Functor.Compose (Compose(..))-import Data.List (genericLength)-import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty, toList) import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Null (MonoidNull(null)) import Data.Monoid.Factorial (FactorialMonoid, splitPrimePrefix) import Data.Monoid.Textual (TextualMonoid) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual+import Data.Ord (Down(Down)) import Data.Semigroup (Semigroup((<>))) import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString)@@ -30,13 +35,14 @@ import qualified Rank2  import Text.Grampa.Class (GrammarParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),-                          AmbiguousParsing(..), Ambiguous(Ambiguous),+                          AmbiguousParsing(..), Ambiguous(Ambiguous), CommittedParsing(..),                           ConsumedInputParsing(..), DeterministicParsing(..),-                          TailsParsing(parseTails, parseAllTails), ParseResults, Expected(..))-import Text.Grampa.Internal (FailureInfo(..), ResultList(..), ResultsOfLength(..), fromResultList, TraceableParsing(..))+                          TailsParsing(parseTails, parseAllTails), ParseResults, ParseFailure(..),+                          FailureDescription(..))+import Text.Grampa.Internal (ResultList(..), ResultsOfLength(..), TraceableParsing(..), expected, erroneous) import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack -import Prelude hiding (iterate, length, null, showList, span, takeWhile)+import Prelude hiding (iterate, null, showList, span, takeWhile)  -- | Parser for a context-free grammar with packrat-like sharing of parse results. It does not support left-recursive -- grammars.@@ -46,7 +52,7 @@    fmap f (Parser p) = Parser (fmap f . p)    {-# INLINE fmap #-} -instance Applicative (Parser g i) where+instance Ord s => Applicative (Parser g s) where    pure a = Parser (\rest-> ResultList [ResultsOfLength 0 rest (a:|[])] mempty)    Parser p <*> Parser q = Parser r where       r rest = case p rest@@ -57,17 +63,17 @@    {-# INLINABLE pure #-}    {-# INLINABLE (<*>) #-} -instance Alternative (Parser g i) where-   empty = Parser (\rest-> ResultList mempty $ FailureInfo (genericLength rest) [])+instance Ord s => Alternative (Parser g s) where+   empty = Parser (\rest-> ResultList mempty $ ParseFailure (Down $ length rest) [] [])    Parser p <|> Parser q = Parser r where       r rest = p rest <> q rest    {-# INLINE (<|>) #-}    {-# INLINABLE empty #-} -instance Filterable (Parser g i) where+instance Filterable (Parser g s) where   mapMaybe f (Parser p) = Parser (mapMaybe f . p) -instance Monad (Parser g i) where+instance Ord s => Monad (Parser g s) where    return = pure    (>>) = (*>)    Parser p >>= f = Parser q where@@ -77,27 +83,29 @@       continue' l (ResultList rs failure) = ResultList (adjust l <$> rs) failure       adjust l (ResultsOfLength l' rest' rs) = ResultsOfLength (l+l') rest' rs -instance MonadFail (Parser g s) where+#if MIN_VERSION_base(4,13,0)+instance Ord s => MonadFail (Parser g s) where+#endif    fail msg = Parser p-      where p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected msg])+      where p rest = ResultList mempty (erroneous (Down $ length rest) msg) -instance MonadPlus (Parser g s) where+instance Ord s => MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) -instance Semigroup x => Semigroup (Parser g s x) where+instance (Semigroup x, Ord s) => Semigroup (Parser g s x) where    (<>) = liftA2 (<>) -instance Monoid x => Monoid (Parser g s x) where+instance (Monoid x, Ord s) => Monoid (Parser g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   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+instance (Ord 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+   parsingResult _ = Compose . fromResultList    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 input@((_, d) : _) = ResultList rs' failure@@ -106,10 +114,10 @@                -- 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"])+      p _ = ResultList mempty (expected 0 "NonTerminal at endOfInput")    {-# INLINE nonTerminal #-} -instance (Eq s, LeftReductive s, FactorialMonoid s) => TailsParsing (Parser g s) where+instance (Ord s, LeftReductive s, FactorialMonoid s) => TailsParsing (Parser g s) where    parseTails = applyParser  -- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions. Can be wrapped with@@ -119,24 +127,31 @@ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) => --                  g (Memoizing.'Parser' g s) -> s -> g ('Compose' ('ParseResults' s) []) -- @-instance (LeftReductive s, FactorialMonoid s) => MultiParsing (Parser g s) where+instance (LeftReductive s, FactorialMonoid s, Ord s) => MultiParsing (Parser g s) where    type GrammarConstraint (Parser g s) g' = (g ~ g', Rank2.Functor g)    type ResultFunctor (Parser g s) = Compose (ParseResults s) []    -- | Returns the list of all possible input prefix parses paired with the remaining input suffix.-   parsePrefix g input = Rank2.fmap (Compose . Compose . fromResultList input) (snd $ head $ parseGrammarTails g input)-   parseComplete :: (ParserInput (Parser g s) ~ s, Rank2.Functor g, Eq s, FactorialMonoid s) =>-                    g (Parser g s) -> s -> g (Compose (ParseResults s) [])-   parseComplete g input = Rank2.fmap ((snd <$>) . Compose . fromResultList input)+   parsePrefix g input = Rank2.fmap (Compose . Compose . fromResultList) (snd $ head $ parseGrammarTails g input)+   -- parseComplete :: (ParserInput (Parser g s) ~ s, Rank2.Functor g, Eq s, FactorialMonoid s) =>+   --                  g (Parser g s) -> s -> g (Compose (ParseResults s) [])+   parseComplete g input = Rank2.fmap ((snd <$>) . Compose . fromResultList)                               (snd $ head $ parseAllTails close $ parseGrammarTails g input)       where close = Rank2.fmap (<* eof) g +fromResultList :: FactorialMonoid s => ResultList g s r -> ParseResults s [(s, r)]+fromResultList (ResultList [] (ParseFailure pos expected' erroneous')) =+   Left (ParseFailure (pos - 1) expected' erroneous')+fromResultList (ResultList rl _failure) = Right (foldMap f rl)+   where f (ResultsOfLength _ ((s, _):_) r) = (,) s <$> toList r+         f (ResultsOfLength _ [] r) = (,) mempty <$> toList r+ parseGrammarTails :: (Rank2.Functor g, FactorialMonoid s) => g (Parser g s) -> s -> [(s, g (ResultList g s))] parseGrammarTails g input = foldr parseTail [] (Factorial.tails input)    where parseTail s parsedTail = parsed             where parsed = (s,d):parsedTail                   d      = Rank2.fmap (($ parsed) . applyParser) g -instance (LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+instance (LeftReductive s, FactorialMonoid s, Ord s) => InputParsing (Parser g s) where    type ParserInput (Parser g s) = s    getInput = Parser p       where p rest@((s, _):_) = ResultList [ResultsOfLength 0 rest (s:|[])] mempty@@ -144,14 +159,14 @@    anyToken = Parser p       where p rest@((s, _):t) = case splitPrimePrefix s                                 of Just (first, _) -> ResultList [ResultsOfLength 1 t (first:|[])] mempty-                                   _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "anyToken"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "anyToken"])+                                   _ -> ResultList mempty (expected (Down $ length rest) "anyToken")+            p [] = ResultList mempty (expected 0 "anyToken")    satisfy predicate = Parser p       where p rest@((s, _):t) =                case splitPrimePrefix s                of Just (first, _) | predicate first -> ResultList [ResultsOfLength 1 t (first:|[])] mempty-                  _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "satisfy"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "satisfy"])+                  _ -> ResultList mempty (expected (Down $ length rest) "satisfy")+            p [] = ResultList mempty (expected 0 "satisfy")    scan s0 f = Parser (p s0)       where p s rest@((i, _) : _) = ResultList [ResultsOfLength l (drop l rest) (prefix:|[])] mempty                where (prefix, _, _) = Factorial.spanMaybe' s f i@@ -162,7 +177,7 @@       where p rest@((s, _) : _)                | x <- Factorial.take n s, l <- Factorial.length x, l == n =                     ResultList [ResultsOfLength l (drop l rest) (x:|[])] mempty-            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected $ "take " ++ show n])+            p rest = ResultList mempty (expected (Down $ length rest) $ "take " ++ show n)    takeWhile predicate = Parser p       where p rest@((s, _) : _)                | x <- Factorial.takeWhile predicate s, l <- Factorial.length x =@@ -172,16 +187,16 @@       where p rest@((s, _) : _)                | x <- Factorial.takeWhile predicate s, l <- Factorial.length x, l > 0 =                     ResultList [ResultsOfLength l (drop l rest) (x:|[])] mempty-            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected "takeWhile1"])+            p rest = ResultList mempty (expected (Down $ length rest) "takeWhile1")    string s = Parser p where       p rest@((s', _) : _)          | s `isPrefixOf` s' = ResultList [ResultsOfLength l (Factorial.drop l rest) (s:|[])] mempty-      p rest = ResultList mempty (FailureInfo (genericLength rest) [ExpectedInput s])+      p rest = ResultList mempty (ParseFailure (Down $ length rest) [LiteralDescription s] [])       l = Factorial.length s    notSatisfy predicate = Parser p       where p rest@((s, _):_)                | Just (first, _) <- splitPrimePrefix s, -                 predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfy"])+                 predicate first = ResultList mempty (expected (Down $ length rest) "notSatisfy")             p rest = ResultList [ResultsOfLength 0 rest (():|[])] mempty    {-# INLINABLE string #-} @@ -193,13 +208,13 @@                where traceWith prefix = trace (prefix <> description s)             q [] = p [] -instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where+instance (Ord s, Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p       where p rest@((s, _):t) =                case Textual.characterPrefix s                of Just first | predicate first -> ResultList [ResultsOfLength 1 t (Factorial.primePrefix s:|[])] mempty-                  _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "satisfyCharInput"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "satisfyCharInput"])+                  _ -> ResultList mempty (expected (Down $ length rest) "satisfyCharInput")+            p [] = ResultList mempty (expected 0 "satisfyCharInput")    scanChars s0 f = Parser (p s0)       where p s rest@((i, _) : _) = ResultList [ResultsOfLength l (drop l rest) (prefix:|[])] mempty                where (prefix, _, _) = Textual.spanMaybe_' s f i@@ -214,43 +229,43 @@       where p rest@((s, _) : _)                | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x, l > 0 =                     ResultList [ResultsOfLength l (drop l rest) (x:|[])] mempty-            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected "takeCharsWhile1"])+            p rest = ResultList mempty (expected (Down $ length rest) "takeCharsWhile1")    notSatisfyChar predicate = Parser p       where p rest@((s, _):_)                | Just first <- Textual.characterPrefix s, -                 predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfyChar"])+                 predicate first = ResultList mempty (expected (Down $ length rest) "notSatisfyChar")             p rest = ResultList [ResultsOfLength 0 rest (():|[])] mempty -instance (LeftReductive s, FactorialMonoid s) => ConsumedInputParsing (Parser g s) where+instance (LeftReductive s, FactorialMonoid s, Ord s) => ConsumedInputParsing (Parser g s) where    match (Parser p) = Parser q       where q [] = addConsumed mempty (p [])             q rest@((s, _) : _) = addConsumed s (p rest)             addConsumed input (ResultList rl failure) = ResultList (add1 <$> rl) failure                where add1 (ResultsOfLength l t rs) = ResultsOfLength l t ((,) (Factorial.take l input) <$> rs) -instance MonoidNull s => Parsing (Parser g s) where+instance (MonoidNull s, Ord s) => Parsing (Parser g s) where    try (Parser p) = Parser q       where q rest = rewindFailure (p rest)-               where rewindFailure (ResultList rl (FailureInfo _pos _msgs)) =-                        ResultList rl (FailureInfo (genericLength rest) [])+               where rewindFailure (ResultList rl _) = ResultList rl (ParseFailure (Down $ length rest) [] [])    Parser p <?> msg  = Parser q       where q rest = replaceFailure (p rest)-               where replaceFailure (ResultList [] (FailureInfo pos msgs)) =-                        ResultList [] (FailureInfo pos $ if pos == genericLength rest then [Expected msg] else msgs)+               where replaceFailure (ResultList [] (ParseFailure pos msgs erroneous')) =+                        ResultList [] (ParseFailure pos (if pos == Down (length rest) then [StaticDescription msg]+                                                         else msgs) erroneous')                      replaceFailure rl = rl    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))       where rewind t (ResultList [] _) = ResultList [ResultsOfLength 0 t (():|[])] mempty-            rewind t ResultList{} = ResultList mempty (FailureInfo (genericLength t) [Expected "notFollowedBy"])+            rewind t ResultList{} = ResultList mempty (expected (Down $ length t) "notFollowedBy")    skipMany p = go       where go = pure () <|> try p *> go-   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (genericLength t) [Expected msg])+   unexpected msg = Parser (\t-> ResultList mempty $ expected (Down $ length t) msg)    eof = Parser f       where f rest@((s, _):_)                | null s = ResultList [ResultsOfLength 0 rest (():|[])] mempty-               | otherwise = ResultList mempty (FailureInfo (genericLength rest) [Expected "end of input"])+               | otherwise = ResultList mempty (expected (Down $ length rest) "end of input")             f [] = ResultList [ResultsOfLength 0 [] (():|[])] mempty -instance MonoidNull s => DeterministicParsing (Parser g s) where+instance (MonoidNull s, Ord s) => DeterministicParsing (Parser g s) where    Parser p <<|> Parser q = Parser r where       r rest = case p rest                of rl@(ResultList [] _failure) -> rl <> q rest@@ -267,47 +282,64 @@                        ResultList rl _failure -> foldMap continue rl          where continue (ResultsOfLength len' rest' _) = q (len + len') rest' -instance MonoidNull s => LookAheadParsing (Parser g s) where+instance (MonoidNull s, Ord s) => LookAheadParsing (Parser g s) where    lookAhead (Parser p) = Parser (\input-> rewind input (p input))       where rewind _ rl@(ResultList [] _) = rl             rewind t (ResultList rl failure) = ResultList [ResultsOfLength 0 t $ foldr1 (<>) (results <$> rl)] failure             results (ResultsOfLength _ _ r) = r -instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where+instance (Ord s, Show s, TextualMonoid s) => CharParsing (Parser g s) where    satisfy predicate = Parser p       where p rest@((s, _):t) =                case Textual.characterPrefix s                of Just first | predicate first -> ResultList [ResultsOfLength 1 t (first:|[])] mempty-                  _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "Char.satisfy"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "Char.satisfy"])+                  _ -> ResultList mempty (expected (Down $ length rest) "Char.satisfy")+            p [] = ResultList mempty (expected 0 "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance AmbiguousParsing (Parser g s) where+instance Ord s => AmbiguousParsing (Parser g s) where    ambiguous (Parser p) = Parser q       where q rest | ResultList rs failure <- p rest = ResultList (groupByLength <$> rs) failure             groupByLength (ResultsOfLength l rest rs) = ResultsOfLength l rest (Ambiguous rs :| []) +instance Ord s => CommittedParsing (Parser g s) where+   type CommittedResults (Parser g s) = ParseResults s+   commit (Parser p) = Parser q+      where q rest = case p rest+                     of ResultList [] failure -> ResultList [ResultsOfLength 0 rest (Left failure:|[])] mempty+                        ResultList rl failure -> ResultList (fmap Right <$> rl) failure+   admit (Parser p) = Parser q+      where q rest = case p rest+                     of ResultList [] failure -> ResultList [] failure+                        ResultList rl failure -> foldMap expose rl <> ResultList [] failure+            expose (ResultsOfLength len t rs) = case nonEmpty successes of+               Nothing -> ResultList [] (mconcat failures)+               Just successes' -> ResultList [ResultsOfLength len t successes'] (mconcat failures)+               where (failures, successes) = partitionEithers (toList rs)+         -- | 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 :: 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 [] (FailureInfo pos expected) -> Backtrack.NoParse (FailureInfo pos $ map message expected)+            of ResultList [] (ParseFailure pos positive negative)+                  -> Backtrack.NoParse (ParseFailure pos (map message positive) (map message negative))                ResultList rs _ -> parsed (last rs)    parsed (ResultsOfLength l s (r:|_)) = Backtrack.Parsed l r s-   message (Expected msg) = Expected msg-   message (ExpectedInput s) = ExpectedInput [(s, error "longest")]+   message (StaticDescription msg) = StaticDescription msg+   message (LiteralDescription s) = LiteralDescription [(s, error "longest")]  -- | 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 :: Ord s => 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 [ResultsOfLength l suffix (result:|[])] mempty-               Backtrack.NoParse (FailureInfo pos expected) -> ResultList mempty (FailureInfo pos ((fst . head <$>) <$> expected))+               Backtrack.NoParse (ParseFailure pos positive negative)+                 -> ResultList mempty (ParseFailure pos ((fst . head <$>) <$> positive) ((fst . head <$>) <$> negative))  -- | Turns a backtracking PEG parser into a context-free parser-terminalPEG :: Monoid s => Backtrack.Parser g s a -> Parser g s a+terminalPEG :: Monoid s => Ord 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 [ResultsOfLength l [] (result:|[])] mempty

@@ -1,24 +1,30 @@-{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, InstanceSigs,+{-# LANGUAGE BangPatterns, CPP, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, InstanceSigs,              RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}-module Text.Grampa.ContextFree.SortedMemoizing.Transformer-       (FailureInfo(..), ResultListT(..), ParserT(..), (<<|>),-        tbind, lift, tmap, longest, peg, terminalPEG)+-- | A context-free memoizing parser that handles all alternatives in parallel+-- and carries a monadic computation with each parsing result.+module Text.Grampa.ContextFree.SortedMemoizing.Transformer (ResultListT(..), ParserT(..), (<<|>),+                                                            tbind, lift, tmap, longest, peg, terminalPEG) where  import Control.Applicative-import Control.Monad (MonadFail(fail), MonadPlus(..), join, void)+import Control.Monad (MonadPlus(..), join, void)+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif import qualified Control.Monad.Trans.Class as Trans (lift) import Control.Monad.Trans.State.Strict (StateT, evalStateT)+import Data.Either (partitionEithers) import Data.Function (on) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..))-import Data.List (genericLength, nub) import Data.List.NonEmpty (NonEmpty((:|)), groupBy, nonEmpty, fromList, toList) import Data.Monoid.Null (MonoidNull(null)) import Data.Monoid.Factorial (FactorialMonoid, splitPrimePrefix) import Data.Monoid.Textual (TextualMonoid) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual+import Data.Ord (Down(Down))+import Data.Semigroup (Semigroup((<>))) import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString) import Witherable (Filterable(mapMaybe))@@ -32,13 +38,13 @@ import qualified Rank2  import Text.Grampa.Class (GrammarParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),-                          ConsumedInputParsing(..), DeterministicParsing(..),+                          ConsumedInputParsing(..), CommittedParsing(..), DeterministicParsing(..),                           AmbiguousParsing(..), Ambiguous(Ambiguous),-                          TailsParsing(..), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..), FallibleResults(..), AmbiguousAlternative(..), TraceableParsing(..))+                          TailsParsing(..), ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (expected, FallibleResults(..), AmbiguousAlternative(..), TraceableParsing(..)) import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack -import Prelude hiding (iterate, length, null, showList, span, takeWhile)+import Prelude hiding (iterate, null, showList, span, takeWhile)  -- | Parser for a context-free grammar with packrat-like sharing that carries a monadic computation as part of the -- parse result.@@ -47,16 +53,16 @@ newtype ResultsOfLengthT m g s r = ResultsOfLengthT{getResultsOfLength :: ResultsOfLength m g s (m r)} data ResultsOfLength m g s a = ROL !Int ![(s, g (ResultListT m g s))] !(NonEmpty a) data ResultListT m g s r = ResultList{resultSuccesses :: ![ResultsOfLengthT m g s r],-                                      resultFailures  :: !(FailureInfo s)}+                                      resultFailures  :: !(ParseFailure Pos s)} -singleResult :: Applicative m => Int -> [(s, g (ResultListT m g s))] -> r -> ResultListT m g s r+singleResult :: (Applicative m, Ord s) => Int -> [(s, g (ResultListT m g s))] -> r -> ResultListT m g s r singleResult len rest a = ResultList [ResultsOfLengthT $ ROL len rest (pure a:|[])] mempty  instance Functor m => Functor (ParserT m g s) where    fmap f (Parser p) = Parser (fmap f . p)    {-# INLINE fmap #-} -instance Applicative m => Applicative (ParserT m g s) where+instance (Applicative m, Ord s) => Applicative (ParserT m g s) where    pure a = Parser (\rest-> singleResult 0 rest a)    Parser p <*> Parser q = Parser r where       r rest = case p rest@@ -67,8 +73,8 @@    {-# INLINABLE pure #-}    {-# INLINABLE (<*>) #-} -instance Applicative m => Alternative (ParserT m g s) where-   empty = Parser (\rest-> ResultList mempty $ FailureInfo (genericLength rest) [])+instance (Applicative m, Ord s) => Alternative (ParserT m g s) where+   empty = Parser (\rest-> ResultList mempty $ ParseFailure (Down $ length rest) [] [])    Parser p <|> Parser q = Parser r where       r rest = p rest <> q rest    {-# INLINE (<|>) #-}@@ -81,7 +87,7 @@ instance {-# overlaps #-} (Monad m, Traversable m, Monoid state) => Filterable (ParserT (StateT state m) g s) where   mapMaybe f (Parser p) = Parser (mapMaybe f . p) -instance (Monad m, Traversable m) => Monad (ParserT m g s) where+instance (Monad m, Traversable m, Ord s) => Monad (ParserT m g s) where    return = pure    (>>) = (*>)    Parser p >>= f = Parser q where@@ -97,16 +103,18 @@       rejoinResults m = ResultList (fmap rejoinResultsOfLengthT $ sequence $ resultSuccesses <$> m) (foldMap resultFailures m)       rejoinResultsOfLengthT m = ResultsOfLengthT (join <$> traverse getResultsOfLength m) -instance (Monad m, Traversable m) => MonadFail (ParserT m g s) where+#if MIN_VERSION_base(4,13,0)+instance (Monad m, Traversable m, Ord s) => MonadFail (ParserT m g s) where+#endif    fail msg = Parser p-      where p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected msg])+      where p rest = ResultList mempty (ParseFailure (Down $ length rest) [] [StaticDescription msg]) -instance (Foldable m, Monad m, Traversable m) => MonadPlus (ParserT m g s) where+instance (Foldable m, Monad m, Traversable m, Ord s) => MonadPlus (ParserT m g s) where    mzero = empty    mplus = (<|>)  -- | Lift a parse-free computation into the parser.-lift :: m a -> ParserT m g s a+lift :: Ord s => m a -> ParserT m g s a lift m = Parser (\rest-> ResultList [ResultsOfLengthT $ ROL 0 rest (m:|[])] mempty)  -- | Transform the computation carried by the parser using the monadic bind ('>>=').@@ -129,12 +137,12 @@ mapResults :: (m a -> m b) -> ResultsOfLengthT m g s a -> ResultsOfLengthT m g s b mapResults f (ResultsOfLengthT rol) = ResultsOfLengthT (f <$> rol) -instance (Applicative m, Semigroup x) => Semigroup (ParserT m g s x) where+instance (Applicative m, Semigroup x, Ord s) => Semigroup (ParserT m g s x) where    (<>) = liftA2 (<>) -instance (Applicative m, Monoid x) => Monoid (ParserT m g s x) where+instance (Applicative m, Monoid x, Ord s) => Monoid (ParserT m g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>)  -- | Memoizing parser that carries an applicative computation. Can be wrapped with -- 'Text.Grampa.ContextFree.LeftRecursive.Fixed' to provide left recursion support.@@ -143,24 +151,24 @@ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) => --                  g (Memoizing.'Parser' g s) -> s -> g ('Compose' ('ParseResults' s) []) -- @-instance (Applicative m, LeftReductive s, FactorialMonoid s) => MultiParsing (ParserT m g s) where+instance (Applicative m, LeftReductive s, FactorialMonoid s, Ord s) => MultiParsing (ParserT m g s) where    type GrammarConstraint (ParserT m g s) g' = (g ~ g', Rank2.Functor g)    type ResultFunctor (ParserT m g s) = Compose (Compose (ParseResults s) []) m    -- | Returns the list of all possible input prefix parses paired with the remaining input suffix.-   parsePrefix g input = Rank2.fmap (Compose . Compose . Compose . fmap (fmap sequenceA) . fromResultList input)+   parsePrefix g input = Rank2.fmap (Compose . Compose . Compose . fmap (fmap sequenceA) . fromResultList)                                     (snd $ head $ parseGrammarTails g input)-   parseComplete :: (ParserInput (ParserT m g s) ~ s, Rank2.Functor g, Eq s, FactorialMonoid s) =>-                    g (ParserT m g s) -> s -> g (Compose (Compose (ParseResults s) []) m)-   parseComplete g input = Rank2.fmap (Compose . fmap snd . Compose . fromResultList input)+   -- parseComplete :: (ParserInput (ParserT m g s) ~ s, Rank2.Functor g, Eq s, FactorialMonoid s) =>+   --                  g (ParserT m g s) -> s -> g (Compose (Compose (ParseResults s) []) m)+   parseComplete g input = Rank2.fmap (Compose . fmap snd . Compose . fromResultList)                               (snd $ head $ parseAllTails close $ parseGrammarTails g input)       where close = Rank2.fmap (<* eof) g  -- | 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+instance (Applicative m, Ord 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+   parsingResult _ = Compose . Compose . fmap (fmap sequenceA) . fromResultList    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 input@((_, d) : _) = ResultList rs' failure@@ -168,11 +176,11 @@                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"])+               sync rols = rols+      p _ = ResultList mempty (expected 0 "NonTerminal at endOfInput")    {-# INLINE nonTerminal #-} -instance (Applicative m, Eq s, LeftReductive s, FactorialMonoid s, Rank2.Functor g) =>+instance (Applicative m, Ord s, LeftReductive s, FactorialMonoid s, Rank2.Functor g) =>          TailsParsing (ParserT m g s) where    parseTails = applyParser @@ -182,7 +190,7 @@             where parsed = (s,d):parsedTail                   d      = Rank2.fmap (($ parsed) . applyParser) g -instance (Applicative m, LeftReductive s, FactorialMonoid s) => InputParsing (ParserT m g s) where+instance (Applicative m, LeftReductive s, FactorialMonoid s, Ord s) => InputParsing (ParserT m g s) where    type ParserInput (ParserT m g s) = s    getInput = Parser p       where p rest@((s, _):_) = singleResult 0 rest s@@ -190,14 +198,14 @@    anyToken = Parser p       where p rest@((s, _):t) = case splitPrimePrefix s                                 of Just (first, _) -> singleResult 1 t first-                                   _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "anyToken"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "anyToken"])+                                   _ -> ResultList mempty (expected (Down $ length rest) "anyToken")+            p [] = ResultList mempty (expected 0 "anyToken")    satisfy predicate = Parser p       where p rest@((s, _):t) =                case splitPrimePrefix s                of Just (first, _) | predicate first -> singleResult 1 t first-                  _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "satisfy"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "satisfy"])+                  _ -> ResultList mempty (expected (Down $ length rest) "satisfy")+            p [] = ResultList mempty (expected 0 "satisfy")    scan s0 f = Parser (p s0)       where p s rest@((i, _) : _) = singleResult l (drop l rest) prefix                where (prefix, _, _) = Factorial.spanMaybe' s f i@@ -213,39 +221,39 @@       where p rest@((s, _) : _)                | x <- Factorial.take n s, l <- Factorial.length x, l == n =                     singleResult l (drop l rest) x-            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected $ "take " ++ show n])+            p rest = ResultList mempty (expected (Down $ length rest) $ "take " ++ show n)    takeWhile1 predicate = Parser p       where p rest@((s, _) : _)                | x <- Factorial.takeWhile predicate s, l <- Factorial.length x, l > 0 =                     singleResult l (drop l rest) x-            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected "takeWhile1"])+            p rest = ResultList mempty (expected (Down $ length rest) "takeWhile1")    string s = Parser p where       p rest@((s', _) : _)          | s `isPrefixOf` s' = singleResult l (drop l rest) s-      p rest = ResultList mempty (FailureInfo (genericLength rest) [ExpectedInput s])+      p rest = ResultList mempty (ParseFailure (Down $ length rest) [LiteralDescription s] [])       l = Factorial.length s    notSatisfy predicate = Parser p       where p rest@((s, _):_)                | Just (first, _) <- splitPrimePrefix s, -                 predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfy"])+                 predicate first = ResultList mempty (expected (Down $ length rest) "notSatisfy")             p rest = singleResult 0 rest ()    {-# INLINABLE string #-} -instance InputParsing (ParserT m g s)  => TraceableParsing (ParserT m g s) where+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)+      where q rest = case traceWith "Parsing " (p rest)+                     of rl@(ResultList [] _) -> traceWith "Failed " rl+                        rl -> traceWith "Parsed " rl+               where traceWith prefix = trace (prefix <> case rest of ((s, _):_) -> description s; [] -> "EOF") -instance (Applicative m, Show s, TextualMonoid s) => InputCharParsing (ParserT m g s) where+instance (Applicative m, Ord s, Show s, TextualMonoid s) => InputCharParsing (ParserT m g s) where    satisfyCharInput predicate = Parser p       where p rest@((s, _):t) =                case Textual.characterPrefix s                of Just first                      | predicate first -> singleResult 1 t (Factorial.primePrefix s)-                  _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "satisfyCharInput"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "satisfyCharInput"])+                  _ -> ResultList mempty (expected (Down $ length rest) "satisfyCharInput")+            p [] = ResultList mempty (expected 0 "satisfyCharInput")    scanChars s0 f = Parser (p s0)       where p s rest@((i, _) : _) = singleResult l (drop l rest) prefix                where (prefix, _, _) = Textual.spanMaybe_' s f i@@ -260,14 +268,14 @@       where p rest@((s, _) : _)                | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x, l > 0 =                     singleResult l (drop l rest) x-            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected "takeCharsWhile1"])+            p rest = ResultList mempty (expected (Down $ length rest) "takeCharsWhile1")    notSatisfyChar predicate = Parser p       where p rest@((s, _):_)                | Just first <- Textual.characterPrefix s, -                 predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfyChar"])+                 predicate first = ResultList mempty (expected (Down $ length rest) "notSatisfyChar")             p rest = singleResult 0 rest () -instance (Applicative m, LeftReductive s, FactorialMonoid s) => ConsumedInputParsing (ParserT m g s) where+instance (Applicative m, LeftReductive s, FactorialMonoid s, Ord s) => ConsumedInputParsing (ParserT m g s) where    match (Parser p) = Parser q       where q [] = addConsumed mempty (p [])             q rest@((s, _) : _) = addConsumed s (p rest)@@ -275,29 +283,29 @@                where add1 (ResultsOfLengthT (ROL l t rs)) =                         ResultsOfLengthT (ROL l t $ ((,) (Factorial.take l input) <$>) <$> rs) -instance (Applicative m, MonoidNull s) => Parsing (ParserT m g s) where+instance (Applicative m, MonoidNull s, Ord s) => Parsing (ParserT m g s) where    try (Parser p) = Parser q       where q rest = rewindFailure (p rest)-               where rewindFailure (ResultList rl (FailureInfo _pos _msgs)) =-                        ResultList rl (FailureInfo (genericLength rest) [])+               where rewindFailure (ResultList rl _) = ResultList rl (ParseFailure (Down $ length rest) [] [])    Parser p <?> msg  = Parser q       where q rest = replaceFailure (p rest)-               where replaceFailure (ResultList [] (FailureInfo pos msgs)) =-                        ResultList [] (FailureInfo pos $ if pos == genericLength rest then [Expected msg] else msgs)+               where replaceFailure (ResultList [] (ParseFailure pos msgs erroneous)) =+                        ResultList [] (ParseFailure pos (if pos == Down (length rest) then [StaticDescription msg]+                                                         else msgs) erroneous)                      replaceFailure rl = rl    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))       where rewind t (ResultList [] _) = singleResult 0 t ()-            rewind t ResultList{} = ResultList mempty (FailureInfo (genericLength t) [Expected "notFollowedBy"])+            rewind t ResultList{} = ResultList mempty (expected (Down $ length t) "notFollowedBy")    skipMany p = go       where go = pure () <|> try p *> go-   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (genericLength t) [Expected msg])+   unexpected msg = Parser (\t-> ResultList mempty $ expected (Down $ length t) msg)    eof = Parser f       where f rest@((s, _):_)                | null s = singleResult 0 rest ()-               | otherwise = ResultList mempty (FailureInfo (genericLength rest) [Expected "end of input"])+               | otherwise = ResultList mempty (expected (Down $ length rest) "end of input")             f [] = singleResult 0 [] () -instance (Applicative m, MonoidNull s) => DeterministicParsing (ParserT m g s) where+instance (Applicative m, MonoidNull s, Ord s) => DeterministicParsing (ParserT m g s) where    Parser p <<|> Parser q = Parser r where       r rest = case p rest                of rl@(ResultList [] _failure) -> rl <> q rest@@ -317,24 +325,40 @@          where continue (ResultsOfLengthT (ROL len' rest' results)) =                   foldMap (\r-> q (len + len') (effects <* r) rest') results -instance (Applicative m, MonoidNull s) => LookAheadParsing (ParserT m g s) where+instance (Applicative m, Traversable m, Ord s) => CommittedParsing (ParserT m g s) where+   type CommittedResults (ParserT m g s) = ParseResults s+   commit (Parser p) = Parser q+      where q rest = case p rest+                     of ResultList [] failure -> ResultList [ResultsOfLengthT+                                                             $ ROL 0 rest (pure (Left failure) :| [])] mempty+                        ResultList rl failure -> ResultList (mapResults (fmap Right) <$> rl) failure+   admit (Parser p) = Parser q+      where q rest = case p rest+                     of ResultList [] failure -> ResultList [] failure+                        ResultList rl failure -> foldMap expose rl <> ResultList [] failure+            expose (ResultsOfLengthT (ROL len t rs)) = case nonEmpty successes of+               Nothing -> ResultList [] (mconcat failures)+               Just successes' -> ResultList [ResultsOfLengthT $ ROL len t successes'] (mconcat failures)+               where (failures, successes) = partitionEithers (sequenceA <$> toList rs)++instance (Applicative m, MonoidNull s, Ord s) => LookAheadParsing (ParserT m g s) where    lookAhead (Parser p) = Parser (\input-> rewind input (p input))       where rewind _ rl@(ResultList [] _) = rl             rewind t (ResultList rl failure) =                ResultList [ResultsOfLengthT $ ROL 0 t $ foldr1 (<>) (results <$> rl)] failure             results (ResultsOfLengthT (ROL _ _ r)) = r -instance (Applicative m, Show s, TextualMonoid s) => CharParsing (ParserT m g s) where+instance (Applicative m, Ord s, Show s, TextualMonoid s) => CharParsing (ParserT m g s) where    satisfy predicate = Parser p       where p rest@((s, _):t) =                case Textual.characterPrefix s                of Just first | predicate first -> singleResult 1 t first-                  _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "Char.satisfy"])-            p [] = ResultList mempty (FailureInfo 0 [Expected "Char.satisfy"])+                  _ -> ResultList mempty (expected (Down $ length rest) "Char.satisfy")+            p [] = ResultList mempty (expected 0 "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Applicative m, Eq (m ())) => AmbiguousParsing (ParserT m g s) where+instance (Applicative m, Eq (m ()), Ord s) => AmbiguousParsing (ParserT m g s) where    ambiguous (Parser p) = Parser q       where q rest | ResultList rs failure <- p rest = ResultList (groupByLength <$> rs) failure             groupByLength :: ResultsOfLengthT m g s r -> ResultsOfLengthT m g s (Ambiguous r)@@ -346,22 +370,23 @@ longest :: ParserT Identity g s a -> Backtrack.Parser g [(s, g (ResultListT Identity g s))] a longest p = Backtrack.Parser q where    q rest = case applyParser p rest-            of ResultList [] (FailureInfo pos expected) -> Backtrack.NoParse (FailureInfo pos $ map message expected)+            of ResultList [] (ParseFailure pos positive negative)+                  -> Backtrack.NoParse (ParseFailure pos (map message positive) (map message negative))                ResultList rs _ -> parsed (last rs)    parsed (ResultsOfLengthT (ROL l s (Identity r:|_))) = Backtrack.Parsed l r s-   message (Expected msg) = Expected msg-   message (ExpectedInput s) = ExpectedInput [(s, error "longest")]+   message (StaticDescription msg) = StaticDescription msg+   message (LiteralDescription s) = LiteralDescription [(s, error "longest")]  -- | Turns a backtracking PEG parser of the list of input tails into a context-free parser, opposite of 'longest'-peg :: Applicative m => Backtrack.Parser g [(s, g (ResultListT m g s))] a -> ParserT m g s a+peg :: (Applicative m, Ord s) => Backtrack.Parser g [(s, g (ResultListT m g s))] a -> ParserT m g s a peg p = Parser q where    q rest = case Backtrack.applyParser p rest             of Backtrack.Parsed l result suffix -> singleResult l suffix result-               Backtrack.NoParse (FailureInfo pos expected) ->-                  ResultList mempty (FailureInfo pos ((fst . head <$>) <$> expected))+               Backtrack.NoParse (ParseFailure pos positive negative) ->+                  ResultList mempty (ParseFailure pos ((fst . head <$>) <$> positive) ((fst . head <$>) <$> negative))  -- | Turns a backtracking PEG parser into a context-free parser-terminalPEG :: (Applicative m, Monoid s) => Backtrack.Parser g s a -> ParserT m g s a+terminalPEG :: (Applicative m, Monoid s, Ord s) => Backtrack.Parser g s a -> ParserT m g s a terminalPEG p = Parser q where    q [] = case Backtrack.applyParser p mempty             of Backtrack.Parsed l result _ -> singleResult l [] result@@ -370,10 +395,9 @@                        of Backtrack.Parsed l result _ -> singleResult l (drop l rest) result                           Backtrack.NoParse failure -> ResultList mempty failure -fromResultList :: (Functor m, Eq s, FactorialMonoid s) => s -> ResultListT m g s r -> ParseResults s [(s, m r)]-fromResultList s (ResultList [] (FailureInfo pos msgs)) =-   Left (ParseFailure (Factorial.length s - pos + 1) (nub msgs))-fromResultList _ (ResultList rl _failure) = Right (foldMap f rl)+fromResultList :: (Functor m, Eq s, FactorialMonoid s) => ResultListT m g s r -> ParseResults s [(s, m r)]+fromResultList (ResultList [] (ParseFailure pos positive negative)) = Left (ParseFailure (pos - 1) positive negative)+fromResultList (ResultList rl _failure) = Right (foldMap f rl)    where f (ResultsOfLengthT (ROL _ ((s, _):_) r)) = (,) s <$> toList r          f (ResultsOfLengthT (ROL _ [] r)) = (,) mempty <$> toList r {-# INLINABLE fromResultList #-}@@ -390,25 +414,25 @@    fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure    {-# INLINE fmap #-} -instance Applicative m => Applicative (ResultsOfLength m g s) where+instance (Applicative m, Ord s) => Applicative (ResultsOfLength m g s) where    pure = ROL 0 mempty . pure    ROL l1 _ fs <*> ROL l2 t2 xs = ROL (l1 + l2) t2 (fs <*> xs)    {-# INLINE pure #-}    {-# INLINE (<*>) #-} -instance Applicative m => Applicative (ResultsOfLengthT m g s) where+instance (Applicative m, Ord s) => Applicative (ResultsOfLengthT m g s) where    pure = ResultsOfLengthT . pure . pure    ResultsOfLengthT rol1 <*> ResultsOfLengthT rol2 = ResultsOfLengthT (liftA2 (<*>) rol1 rol2) -instance Applicative m => Applicative (ResultListT m g s) where+instance (Applicative m, Ord s) => Applicative (ResultListT m g s) where    pure a = ResultList [pure a] mempty    ResultList rl1 f1 <*> ResultList rl2 f2 = ResultList ((<*>) <$> rl1 <*> rl2) (f1 <> f2) -instance Applicative m => Alternative (ResultListT m g s) where+instance (Applicative m, Ord s) => Alternative (ResultListT m g s) where    empty = ResultList mempty mempty    (<|>) = (<>) -instance Applicative m => AmbiguousAlternative (ResultListT m g s) where+instance (Applicative m, Ord s) => AmbiguousAlternative (ResultListT m g s) where    ambiguousOr (ResultList rl1 f1) (ResultList rl2 f2) = ResultList (merge rl1 rl2) (f1 <> f2)       where merge [] rl = rl             merge rl [] = rl@@ -435,7 +459,7 @@             traverseWithMonoid :: StateT state m a -> Maybe (StateT state m b)             traverseWithMonoid m = Trans.lift <$> traverse f (evalStateT m mempty) -instance Semigroup (ResultListT m g s r) where+instance Ord s => Semigroup (ResultListT m g s r) where    ResultList rl1 f1 <> ResultList rl2 f2 = ResultList (merge rl1 rl2) (f1 <> f2)       where merge [] rl = rl             merge rl [] = rl@@ -445,7 +469,7 @@                | l1 > l2 = rol2 : merge rl1' rest2                | otherwise = ResultsOfLengthT (ROL l1 s1 (r1 <> r2)) : merge rest1 rest2 -instance Monoid (ResultListT m g s r) where+instance Ord s => Monoid (ResultListT m g s r) where    mempty = ResultList mempty mempty    mappend = (<>) 

@@ -1,31 +1,28 @@-{-# LANGUAGE ConstrainedClassMethods, FlexibleContexts, FlexibleInstances, GADTs, RankNTypes, TypeOperators #-}+{-# LANGUAGE ConstrainedClassMethods, FlexibleContexts, FlexibleInstances, GADTs,+             RankNTypes, TypeOperators #-} -module Text.Grampa.Internal (BinTree(..), FailureInfo(..), ResultList(..), ResultsOfLength(..), FallibleResults(..),+module Text.Grampa.Internal (BinTree(..), ResultList(..), ResultsOfLength(..), FallibleResults(..),                              AmbiguousAlternative(..), AmbiguityDecidable(..), AmbiguityWitness(..),                              TraceableParsing(..),-                             fromResultList, noFailure) where+                             noFailure, expected, erroneous) where  import Control.Applicative (Applicative(..), Alternative(..)) import Data.Foldable (toList) import Data.Functor.Classes (Show1(..)) import Data.List.NonEmpty (NonEmpty, nonEmpty)-import Data.List (nub) import Data.Monoid (Monoid(mappend, mempty))+import Data.Ord (Down(Down)) import Data.Semigroup (Semigroup((<>))) import Data.Type.Equality ((:~:)(Refl)) import Witherable (Filterable(mapMaybe)) -import Data.Monoid.Factorial (FactorialMonoid, length)--import Text.Grampa.Class (Ambiguous(..), Expected(..), ParseFailure(..), ParseResults, InputParsing(..))+import Text.Grampa.Class (Ambiguous(..), FailureDescription(..), ParseFailure(..), InputParsing(..), Pos)  import Prelude hiding (length, showList) -data FailureInfo s = FailureInfo Int [Expected s] deriving (Eq, Show)- data ResultsOfLength g s r = ResultsOfLength !Int ![(s, g (ResultList g s))] !(NonEmpty r) -data ResultList g s r = ResultList ![ResultsOfLength g s r] !(FailureInfo s)+data ResultList g s r = ResultList ![ResultsOfLength g s r] !(ParseFailure Pos s)  data BinTree a = Fork !(BinTree a) !(BinTree a)                | Leaf !a@@ -44,26 +41,14 @@ instance AmbiguityDecidable (Ambiguous a) where    ambiguityWitness = Just (AmbiguityWitness Refl) -fromResultList :: (Eq s, FactorialMonoid s) => s -> ResultList g s r -> ParseResults s [(s, r)]-fromResultList s (ResultList [] (FailureInfo pos msgs)) =-   Left (ParseFailure (length s - pos + 1) (nub msgs))-fromResultList _ (ResultList rl _failure) = Right (foldMap f rl)-   where f (ResultsOfLength _ ((s, _):_) r) = (,) s <$> toList r-         f (ResultsOfLength _ [] r) = (,) mempty <$> toList r-{-# INLINABLE fromResultList #-}--noFailure :: FailureInfo s-noFailure = FailureInfo maxBound []+noFailure :: ParseFailure Pos s+noFailure = ParseFailure (Down maxBound) [] [] -instance Semigroup (FailureInfo s) where-   FailureInfo pos1 exp1 <> FailureInfo pos2 exp2 = FailureInfo pos' exp'-      where (pos', exp') | pos1 < pos2 = (pos1, exp1)-                         | pos1 > pos2 = (pos2, exp2)-                         | otherwise = (pos1, exp1 <> exp2)+expected :: Pos -> String -> ParseFailure Pos s+expected pos msg = ParseFailure pos [StaticDescription msg] [] -instance Monoid (FailureInfo s) where-   mempty = FailureInfo maxBound []-   mappend = (<>)+erroneous :: Pos -> String -> ParseFailure Pos s+erroneous pos msg = ParseFailure pos [] [StaticDescription msg]  instance (Show s, Show r) => Show (ResultList g s r) where    show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")")@@ -84,24 +69,24 @@    fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure    {-# INLINE fmap #-} -instance Applicative (ResultsOfLength g s) where+instance Ord s => Applicative (ResultsOfLength g s) where    pure = ResultsOfLength 0 mempty . pure    ResultsOfLength l1 _ fs <*> ResultsOfLength l2 t2 xs = ResultsOfLength (l1 + l2) t2 (fs <*> xs) -instance Applicative (ResultList g s) where+instance Ord s => Applicative (ResultList g s) where    pure a = ResultList [pure a] mempty    ResultList rl1 f1 <*> ResultList rl2 f2 = ResultList ((<*>) <$> rl1 <*> rl2) (f1 <> f2) -instance Alternative (ResultList g s) where+instance Ord s => Alternative (ResultList g s) where    empty = ResultList mempty mempty    (<|>) = (<>)  instance Filterable (ResultList g s) where-   mapMaybe f (ResultList l failure) = ResultList (mapMaybe maybeROL l) failure+   mapMaybe f (ResultList rols failure) = ResultList (mapMaybe maybeROL rols) failure       where maybeROL (ResultsOfLength l t rs) = ResultsOfLength l t <$> nonEmpty (mapMaybe f $ toList rs)    {-# INLINE mapMaybe #-} -instance Semigroup (ResultList g s r) where+instance Ord s => Semigroup (ResultList g s r) where    ResultList rl1 f1 <> ResultList rl2 f2 = ResultList (merge rl1 rl2) (f1 <> f2)       where merge [] rl = rl             merge rl [] = rl@@ -110,7 +95,7 @@                | l1 > l2 = rol2 : merge rl1' rest2                | otherwise = ResultsOfLength l1 s1 (r1 <> r2) : merge rest1 rest2 -instance AmbiguousAlternative (ResultList g s) where+instance Ord s => AmbiguousAlternative (ResultList g s) where    ambiguousOr (ResultList rl1 f1) (ResultList rl2 f2) = ResultList (merge rl1 rl2) (f1 <> f2)       where merge [] rl = rl             merge rl [] = rl@@ -123,7 +108,7 @@ class Alternative f => AmbiguousAlternative f where    ambiguousOr :: f (Ambiguous a) -> f (Ambiguous a) -> f (Ambiguous a) -instance Monoid (ResultList g s r) where+instance Ord s => Monoid (ResultList g s r) where    mempty = ResultList mempty mempty    mappend = (<>) @@ -158,8 +143,8 @@  class FallibleResults f where    hasSuccess   :: f s a -> Bool-   failureOf    :: f s a -> FailureInfo s-   failWith     :: FailureInfo s -> f s a+   failureOf    :: f s a -> ParseFailure Pos s+   failWith     :: ParseFailure Pos s -> f s a  instance FallibleResults (ResultList g) where    hasSuccess (ResultList [] _) = False

@@ -1,13 +1,16 @@-{-# LANGUAGE TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies, UndecidableInstances #-} -- | Backtracking parser for Parsing Expression Grammars module Text.Grampa.PEG.Backtrack (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2)-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..))+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif  import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.List (nub)+import Data.Kind (Type) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid)@@ -27,13 +30,16 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),-                          ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))+import Text.Parser.Input.Position (fromEnd)+import Text.Grampa.Class (CommittedParsing(..), DeterministicParsing(..),+                          InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (expected, TraceableParsing(..)) -data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,-                                              parsedSuffix :: !s}-                                     | NoParse (FailureInfo s)+data Result (g :: (Type -> Type) -> Type) s v =+     Parsed{parsedPrefix :: !v,+            parsedSuffix :: !s}+   | NoParse (ParseFailure Pos s)  -- | 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.@@ -49,7 +55,7 @@  instance Factorial.FactorialMonoid s => Filterable (Result g s) where    mapMaybe f (Parsed a rest) =-      maybe (NoParse $ FailureInfo (Factorial.length rest) [Expected "filter"]) (`Parsed` rest) (f a)+      maybe (NoParse $ expected (fromEnd $ Factorial.length rest) "filter") (`Parsed` rest) (f a)    mapMaybe _ (NoParse failure) = NoParse failure     instance Functor (Parser g s) where@@ -65,7 +71,7 @@    {-# INLINABLE (<*>) #-}  instance Factorial.FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\rest-> NoParse $ FailureInfo (Factorial.length rest) [Expected "empty"])+   empty = Parser (\rest-> NoParse $ ParseFailure (fromEnd $ Factorial.length rest) [] [])    (<|>) = alt  -- | A named and unconstrained version of the '<|>' operator@@ -86,8 +92,10 @@                of Parsed a rest' -> applyParser (f a) rest'                   NoParse failure -> NoParse failure +#if MIN_VERSION_base(4,13,0) instance Factorial.FactorialMonoid s => MonadFail (Parser g s) where-   fail msg = Parser (\rest-> NoParse $ FailureInfo (Factorial.length rest) [Expected msg])+   fail msg = Parser (\rest-> NoParse $ ParseFailure (fromEnd $ Factorial.length rest) [] [StaticDescription msg])+#endif  instance Factorial.FactorialMonoid s => MonadPlus (Parser g s) where    mzero = empty@@ -98,28 +106,43 @@  instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>)  instance Factorial.FactorialMonoid s => Parsing (Parser g s) where    try (Parser p) = Parser q       where q rest = rewindFailure (p rest)-               where rewindFailure (NoParse (FailureInfo _pos _msgs)) =-                        NoParse (FailureInfo (Factorial.length rest) [])+               where rewindFailure NoParse{} = NoParse (ParseFailure (fromEnd $ Factorial.length rest) [] [])                      rewindFailure parsed = parsed    Parser p <?> msg  = Parser q       where q rest = replaceFailure (p rest)-               where replaceFailure (NoParse (FailureInfo pos msgs)) =-                        NoParse (FailureInfo pos $ if pos == Factorial.length rest then [Expected msg] else msgs)+               where replaceFailure (NoParse (ParseFailure pos msgs _)) =+                        NoParse (ParseFailure pos+                                              (if pos == fromEnd (Factorial.length rest) then [StaticDescription msg]+                                               else msgs)+                                              [])                      replaceFailure parsed = parsed    eof = Parser p       where p rest                | Null.null rest = Parsed () rest-               | otherwise = NoParse (FailureInfo (Factorial.length rest) [Expected "end of input"])-   unexpected msg = Parser (\t-> NoParse $ FailureInfo (Factorial.length t) [Expected msg])+               | otherwise = NoParse (ParseFailure (fromEnd $ Factorial.length rest)+                                                   [StaticDescription "end of input"] [])+   unexpected msg = Parser (\t-> NoParse $ ParseFailure (fromEnd $ Factorial.length t) [] [StaticDescription msg])    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))-      where rewind t Parsed{} = NoParse (FailureInfo (Factorial.length t) [Expected "notFollowedBy"])+      where rewind t Parsed{} = NoParse (expected (fromEnd $ Factorial.length t) "notFollowedBy")             rewind t NoParse{} = Parsed () t +instance FactorialMonoid s => CommittedParsing (Parser g s) where+   type CommittedResults (Parser g s) = ParseResults s+   commit (Parser p) = Parser q+      where q rest = case p rest+                     of NoParse failure -> Parsed (Left failure) rest+                        Parsed a rest' -> Parsed (Right a) rest'+   admit (Parser p) = Parser q+      where q rest = case p rest+                     of NoParse failure -> NoParse failure+                        Parsed (Left failure) _ -> NoParse failure+                        Parsed (Right a) rest' -> Parsed a rest'+ -- | Every PEG parser is deterministic all the time. instance FactorialMonoid s => DeterministicParsing (Parser g s) where    (<<|>) = alt@@ -137,7 +160,7 @@       where p rest =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> Parsed first suffix-                  _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "Char.satisfy"])+                  _ -> NoParse (expected (fromEnd $ Factorial.length rest) "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) @@ -148,16 +171,16 @@    anyToken = Parser p       where p rest = case Factorial.splitPrimePrefix rest                      of Just (first, suffix) -> Parsed first suffix-                        _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "anyToken"])+                        _ -> NoParse (expected (fromEnd $ Factorial.length rest) "anyToken")    satisfy predicate = Parser p       where p rest =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) | predicate first -> Parsed first suffix-                  _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "satisfy"])+                  _ -> NoParse (expected (fromEnd $ Factorial.length rest) "satisfy")    notSatisfy predicate = Parser p       where p s = case Factorial.splitPrimePrefix s                   of Just (first, _) -                        | predicate first -> NoParse (FailureInfo (Factorial.length s) [Expected "notSatisfy"])+                        | predicate first -> NoParse (expected (fromEnd $ Factorial.length s) "notSatisfy")                      _ -> Parsed () s    scan s0 f = Parser (p s0)       where p s rest = Parsed prefix suffix@@ -165,17 +188,17 @@    take n = Parser p       where p rest               | (prefix, suffix) <- Factorial.splitAt n rest, Factorial.length prefix == n = Parsed prefix suffix-              | otherwise = NoParse (FailureInfo (Factorial.length rest) [Expected $ "take " ++ show n])+              | otherwise = NoParse (expected (fromEnd $ Factorial.length rest) $ "take " ++ show n)    takeWhile predicate = Parser p       where p rest | (prefix, suffix) <- Factorial.span predicate rest = Parsed prefix suffix    takeWhile1 predicate = Parser p       where p rest | (prefix, suffix) <- Factorial.span predicate rest =                         if Null.null prefix-                        then NoParse (FailureInfo (Factorial.length rest) [Expected "takeWhile1"])+                        then NoParse (expected (fromEnd $ Factorial.length rest) "takeWhile1")                         else Parsed prefix suffix    string s = Parser p where       p s' | Just suffix <- Cancellative.stripPrefix s s' = Parsed s suffix-           | otherwise = NoParse (FailureInfo (Factorial.length s') [ExpectedInput s])+           | otherwise = NoParse (ParseFailure (fromEnd $ Factorial.length s') [LiteralDescription s] [])    {-# INLINABLE string #-}  instance InputParsing (Parser g s)  => TraceableParsing (Parser g s) where@@ -190,11 +213,11 @@       where p rest =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> Parsed (Factorial.primePrefix rest) suffix-                  _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "satisfyCharInput"])+                  _ -> NoParse (expected (fromEnd $ Factorial.length rest) "satisfyCharInput")    notSatisfyChar predicate = Parser p       where p s = case Textual.characterPrefix s                   of Just first | predicate first -                                  -> NoParse (FailureInfo (Factorial.length s) [Expected "notSatisfyChar"])+                                  -> NoParse (expected (fromEnd $ Factorial.length s) "notSatisfyChar")                      _ -> Parsed () s    scanChars s0 f = Parser (p s0)       where p s rest = Parsed prefix suffix@@ -204,7 +227,7 @@    takeCharsWhile1 predicate = Parser p       where p rest | (prefix, suffix) <- Textual.span_ False predicate rest =                      if Null.null prefix-                     then NoParse (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])+                     then NoParse (expected (fromEnd $ Factorial.length rest) "takeCharsWhile1")                      else Parsed prefix suffix  -- | Backtracking PEG parser@@ -217,11 +240,10 @@    type ResultFunctor (Parser g s) = ParseResults s    {-# 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))+   parsePrefix g input = Rank2.fmap (Compose . fromResult . (`applyParser` input)) g+   parseComplete g input = Rank2.fmap ((snd <$>) . fromResult . (`applyParser` input))                                       (Rank2.fmap (<* eof) g) -fromResult :: (Eq s, FactorialMonoid s) => s -> Result g s r -> ParseResults s (s, r)-fromResult s (NoParse (FailureInfo pos msgs)) =-   Left (ParseFailure (Factorial.length s - pos + 1) (nub msgs))-fromResult _ (Parsed prefix suffix) = Right (suffix, prefix)+fromResult :: (Eq s, FactorialMonoid s) => Result g s r -> ParseResults s (s, r)+fromResult (NoParse failure) = Left failure+fromResult (Parsed prefix suffix) = Right (suffix, prefix)

@@ -1,13 +1,16 @@-{-# LANGUAGE TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies, UndecidableInstances #-} -- | Backtracking parser for Parsing Expression Grammars, tracking the consumed input length module Text.Grampa.PEG.Backtrack.Measured (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2)-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..))+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif  import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.List (nub)+import Data.Kind (Type) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid)@@ -27,14 +30,17 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),-                          MultiParsing(..), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))+import Text.Parser.Input.Position (fromEnd)+import Text.Grampa.Class (CommittedParsing(..), DeterministicParsing(..),+                          InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),+                          MultiParsing(..), ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (expected, TraceableParsing(..)) -data Result (g :: (* -> *) -> *) s v = Parsed{parsedLength :: !Int,-                                              parsedResult :: !v,-                                              parsedSuffix :: !s}-                                     | NoParse (FailureInfo s)+data Result (g :: (Type -> Type) -> Type) s v =+     Parsed{parsedLength :: !Int,+             parsedResult :: !v,+             parsedSuffix :: !s}+   | NoParse (ParseFailure Pos s)  -- | 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.@@ -50,7 +56,7 @@  instance Factorial.FactorialMonoid s => Filterable (Result g s) where    mapMaybe f (Parsed l a rest) =-      maybe (NoParse $ FailureInfo (Factorial.length rest) [Expected "filter"]) (\b-> Parsed l b rest) (f a)+      maybe (NoParse $ expected (fromEnd $ Factorial.length rest) "filter") (\b-> Parsed l b rest) (f a)    mapMaybe _ (NoParse failure) = NoParse failure     instance Functor (Parser g s) where@@ -68,7 +74,7 @@    {-# INLINABLE (<*>) #-}  instance FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\rest-> NoParse $ FailureInfo (Factorial.length rest) [Expected "empty"])+   empty = Parser (\rest-> NoParse $ ParseFailure (fromEnd $ Factorial.length rest) [] [])    (<|>) = alt  -- | A named and unconstrained version of the '<|>' operator@@ -82,7 +88,11 @@    mapMaybe f (Parser p) = Parser (mapMaybe f . p)    {-# INLINABLE mapMaybe #-} +#if MIN_VERSION_base(4,13,0) instance Monad (Parser g s) where+#else+instance Factorial.FactorialMonoid s => Monad (Parser g s) where+#endif    return = pure    Parser p >>= f = Parser r where       r rest = case p rest@@ -91,8 +101,10 @@                                          NoParse failure -> NoParse failure                   NoParse failure -> NoParse failure +#if MIN_VERSION_base(4,13,0) instance FactorialMonoid s => MonadFail (Parser g s) where-   fail msg = Parser (\rest-> NoParse $ FailureInfo (Factorial.length rest) [Expected msg])+#endif+   fail msg = Parser (\rest-> NoParse $ ParseFailure (fromEnd $ Factorial.length rest) [] [StaticDescription msg])  instance FactorialMonoid s => MonadPlus (Parser g s) where    mzero = empty@@ -103,28 +115,43 @@  instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>)  instance FactorialMonoid s => Parsing (Parser g s) where    try (Parser p) = Parser q       where q rest = rewindFailure (p rest)-               where rewindFailure (NoParse (FailureInfo _pos _msgs)) =-                        NoParse (FailureInfo (Factorial.length rest) [])+               where rewindFailure NoParse{} = NoParse (ParseFailure (fromEnd $ Factorial.length rest) [] [])                      rewindFailure parsed = parsed    Parser p <?> msg  = Parser q       where q rest = replaceFailure (p rest)-               where replaceFailure (NoParse (FailureInfo pos msgs)) =-                        NoParse (FailureInfo pos $ if pos == Factorial.length rest then [Expected msg] else msgs)+               where replaceFailure (NoParse (ParseFailure pos msgs erroneous)) =+                        NoParse (ParseFailure pos+                                    (if pos == fromEnd (Factorial.length rest) then [StaticDescription msg] else msgs)+                                    erroneous)                      replaceFailure parsed = parsed    eof = Parser p       where p rest                | Null.null rest = Parsed 0 () rest-               | otherwise = NoParse (FailureInfo (Factorial.length rest) [Expected "end of input"])-   unexpected msg = Parser (\t-> NoParse $ FailureInfo (Factorial.length t) [Expected msg])+               | otherwise = NoParse (ParseFailure (fromEnd $ Factorial.length rest)+                                                   [StaticDescription "end of input"] [])+   unexpected msg = Parser (\t-> NoParse $ ParseFailure (fromEnd $ Factorial.length t) [] [StaticDescription msg])    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))-      where rewind t Parsed{} = NoParse (FailureInfo (Factorial.length t) [Expected "notFollowedBy"])+      where rewind t Parsed{} = NoParse (ParseFailure (fromEnd $ Factorial.length t)+                                                      [StaticDescription "notFollowedBy"] [])             rewind t NoParse{} = Parsed 0 () t +instance FactorialMonoid s => CommittedParsing (Parser g s) where+   type CommittedResults (Parser g s) = ParseResults s+   commit (Parser p) = Parser q+      where q rest = case p rest+                     of NoParse failure -> Parsed 0 (Left failure) rest+                        Parsed len a rest' -> Parsed len (Right a) rest'+   admit (Parser p) = Parser q+      where q rest = case p rest+                     of NoParse failure -> NoParse failure+                        Parsed _ (Left failure) _ -> NoParse failure+                        Parsed len (Right a) rest' -> Parsed len a rest'+ -- | Every PEG parser is deterministic all the time. instance FactorialMonoid s => DeterministicParsing (Parser g s) where    (<<|>) = alt@@ -142,7 +169,7 @@       where p rest =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> Parsed 1 first suffix-                  _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "Char.satisfy"])+                  _ -> NoParse (expected (fromEnd $ Factorial.length rest) "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) @@ -153,16 +180,16 @@    anyToken = Parser p       where p rest = case Factorial.splitPrimePrefix rest                      of Just (first, suffix) -> Parsed 1 first suffix-                        _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "anyToken"])+                        _ -> NoParse (expected (fromEnd $ 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 (Factorial.length rest) [Expected "satisfy"])+                  _ -> NoParse (expected (fromEnd $ Factorial.length rest) "satisfy")    notSatisfy predicate = Parser p       where p s = case Factorial.splitPrimePrefix s                   of Just (first, _) -                        | predicate first -> NoParse (FailureInfo (Factorial.length s) [Expected "notSatisfy"])+                        | predicate first -> NoParse (expected (fromEnd $ Factorial.length s) "notSatisfy")                      _ -> Parsed 0 () s    scan s0 f = Parser (p s0)       where p s rest = Parsed (Factorial.length prefix) prefix suffix@@ -170,18 +197,18 @@    take n = Parser p       where p rest               | (prefix, suffix) <- Factorial.splitAt n rest, Factorial.length prefix == n = Parsed n prefix suffix-              | otherwise = NoParse (FailureInfo (Factorial.length rest) [Expected $ "take " ++ show n])+              | otherwise = NoParse (expected (fromEnd $ Factorial.length rest) $ "take " ++ show n)    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 (Factorial.length rest) [Expected "takeWhile1"])+                        then NoParse (expected (fromEnd $ Factorial.length rest) "takeWhile1")                         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 (Factorial.length s') [ExpectedInput s])+           | otherwise = NoParse (ParseFailure (fromEnd $ Factorial.length s') [LiteralDescription s] [])       l = Factorial.length s    {-# INLINABLE string #-} @@ -203,11 +230,11 @@       where p rest =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> Parsed 1 (Factorial.primePrefix rest) suffix-                  _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "satisfyChar"])+                  _ -> NoParse (expected (fromEnd $ Factorial.length rest) "satisfyChar")    notSatisfyChar predicate = Parser p       where p s = case Textual.characterPrefix s                   of Just first | predicate first -                                  -> NoParse (FailureInfo (Factorial.length s) [Expected "notSatisfyChar"])+                                  -> NoParse (expected (fromEnd $ Factorial.length s) "notSatisfyChar")                      _ -> Parsed 0 () s    scanChars s0 f = Parser (p s0)       where p s rest = Parsed (Factorial.length prefix) prefix suffix@@ -218,7 +245,7 @@    takeCharsWhile1 predicate = Parser p       where p rest | (prefix, suffix) <- Textual.span_ False predicate rest =                      if Null.null prefix-                     then NoParse (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])+                     then NoParse (expected (fromEnd $ Factorial.length rest) "takeCharsWhile1")                      else Parsed (Factorial.length prefix) prefix suffix  -- | Backtracking PEG parser@@ -231,11 +258,10 @@    type ResultFunctor (Parser g s) = ParseResults s    {-# 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))+   parsePrefix g input = Rank2.fmap (Compose . fromResult . (`applyParser` input)) g+   parseComplete g input = Rank2.fmap ((snd <$>) . fromResult . (`applyParser` input))                                       (Rank2.fmap (<* eof) g) -fromResult :: (Eq s, FactorialMonoid s) => s -> Result g s r -> ParseResults s (s, r)-fromResult s (NoParse (FailureInfo pos msgs)) =-   Left (ParseFailure (Factorial.length s - pos + 1) (nub msgs))-fromResult _ (Parsed _ prefix suffix) = Right (suffix, prefix)+fromResult :: (Eq s, FactorialMonoid s) => Result g s r -> ParseResults s (s, r)+fromResult (NoParse failure) = Left failure+fromResult (Parsed _ prefix suffix) = Right (suffix, prefix)

@@ -1,13 +1,16 @@-{-# LANGUAGE InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE CPP, FlexibleContexts, InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} -- | Continuation-passing parser for Parsing Expression Grammars module Text.Grampa.PEG.Continued (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2)-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..))+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif  import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.List (nub)+import Data.Kind (Type) import Data.Semigroup (Semigroup((<>))) import Data.Semigroup.Cancellative (LeftReductive(stripPrefix)) import Data.Monoid (Monoid(mappend, mempty))@@ -27,18 +30,20 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),-                          ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))+import Text.Parser.Input.Position (fromEnd)+import Text.Grampa.Class (CommittedParsing(..), DeterministicParsing(..),+                          InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (expected, TraceableParsing(..)) -data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,+data Result (g :: (Type -> Type) -> Type) s v = Parsed{parsedPrefix :: !v,                                               parsedSuffix :: !s}-                                     | NoParse (FailureInfo s)+                                     | NoParse (ParseFailure Pos s)  -- | Parser type for Parsing Expression Grammars that uses a continuation-passing algorithm, fast for grammars in -- LL(1) class but with potentially exponential performance for longer ambiguous prefixes.-newtype Parser (g :: (* -> *) -> *) s r =-   Parser{applyParser :: forall x. s -> (r -> s -> x) -> (FailureInfo s -> x) -> x}+newtype Parser (g :: (Type -> Type) -> Type) s r =+   Parser{applyParser :: forall x. s -> (r -> s -> x) -> (ParseFailure Pos s -> x) -> x}  instance Show s => Show1 (Result g s) where    liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest@@ -50,7 +55,8 @@  instance Factorial.FactorialMonoid s => Filterable (Result g s) where    mapMaybe f (Parsed a rest) =-      maybe (NoParse $ FailureInfo (Factorial.length rest) [Expected "filter"]) (`Parsed` rest) (f a)+      maybe (NoParse $ ParseFailure (fromEnd $ Factorial.length rest) [StaticDescription "filter"] [])+            (`Parsed` rest) (f a)    mapMaybe _ (NoParse failure) = NoParse failure     instance Functor (Parser g s) where@@ -61,98 +67,123 @@    pure a = Parser (\input success _-> success a input)    (<*>) :: forall a b. Parser g s (a -> b) -> Parser g s a -> Parser g s b    Parser p <*> Parser q = Parser r where-      r :: forall x. s -> (b -> s -> x) -> (FailureInfo s -> x) -> x+      r :: forall x. s -> (b -> s -> x) -> (ParseFailure Pos s -> x) -> x       r rest success failure = p rest (\f rest'-> q rest' (success . f) failure) failure    {-# INLINABLE (<*>) #-} -instance FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected "empty"])+instance (FactorialMonoid s, Ord s) => Alternative (Parser g s) where+   empty = Parser (\rest _ failure-> failure $ ParseFailure (fromEnd $ Factorial.length rest) [] [])    (<|>) = alt  -- | A named and unconstrained version of the '<|>' operator-alt :: forall g s a. Parser g s a -> Parser g s a -> Parser g s a+alt :: forall g s a. Ord s => Parser g s a -> Parser g s a -> Parser g s a Parser p `alt` Parser q = Parser r where-   r :: forall x. s -> (a -> s -> x) -> (FailureInfo s -> x) -> x+   r :: forall x. s -> (a -> s -> x) -> (ParseFailure Pos s -> x) -> x    r rest success failure = p rest success (\f1-> q rest success $ \f2 -> failure (f1 <> f2))     instance Factorial.FactorialMonoid s => Filterable (Parser g s) where    mapMaybe :: forall a b. (a -> Maybe b) -> Parser g s a -> Parser g s b    mapMaybe f (Parser p) = Parser q where-      q :: forall x. s -> (b -> s -> x) -> (FailureInfo s -> x) -> x+      q :: forall x. s -> (b -> s -> x) -> (ParseFailure Pos s -> x) -> x       q rest success failure = p rest (maybe filterFailure success . f) failure-         where filterFailure _ = failure (FailureInfo (Factorial.length rest) [Expected "filter"])+         where filterFailure _ = failure (expected (fromEnd $ Factorial.length rest) "filter")    {-# INLINABLE mapMaybe #-} -instance Monad (Parser g s) where+#if MIN_VERSION_base(4,13,0)+instance Ord s => Monad (Parser g s) where+#else+instance (Factorial.FactorialMonoid s, Ord s) => Monad (Parser g s) where+#endif    return = pure    (>>=) :: forall a b. Parser g s a -> (a -> Parser g s b) -> Parser g s b    Parser p >>= f = Parser r where-      r :: forall x. s -> (b -> s -> x) -> (FailureInfo s -> x) -> x+      r :: forall x. s -> (b -> s -> x) -> (ParseFailure Pos s -> x) -> x       r rest success failure = p rest (\a rest'-> applyParser (f a) rest' success failure) failure -instance FactorialMonoid s => MonadFail (Parser g s) where-   fail msg = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected msg])+#if MIN_VERSION_base(4,13,0)+instance (FactorialMonoid s, Ord s) => MonadFail (Parser g s) where+#endif+   fail msg = Parser (\rest _ failure-> failure $+                       ParseFailure (fromEnd $ Factorial.length rest) [StaticDescription msg] []) -instance FactorialMonoid s => MonadPlus (Parser g s) where+instance (FactorialMonoid s, Ord s) => MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) -instance Semigroup x => Semigroup (Parser g s x) where+instance (Semigroup x, Ord s) => Semigroup (Parser g s x) where    (<>) = liftA2 (<>) -instance Monoid x => Monoid (Parser g s x) where+instance (Monoid x, Ord s) => Monoid (Parser g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>) -instance FactorialMonoid s => Parsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => Parsing (Parser g s) where    try :: forall a. Parser g s a -> Parser g s a    try (Parser p) = Parser q-      where q :: forall x. s -> (a -> s -> x) -> (FailureInfo s -> x) -> x-            q input success failure = p input success (failure . rewindFailure)-               where rewindFailure (FailureInfo _pos _msgs) = FailureInfo (Factorial.length input) []+      where q :: forall x. s -> (a -> s -> x) -> (ParseFailure Pos s -> x) -> x+            q input success failure = p input success (const $ failure+                                                       $ ParseFailure (fromEnd $ Factorial.length input) [] [])    (<?>) :: forall a. Parser g s a -> String -> Parser g s a    Parser p <?> msg  = Parser q-      where q :: forall x. s -> (a -> s -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (a -> s -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success (failure . replaceFailure)-               where replaceFailure (FailureInfo pos msgs) =-                        FailureInfo pos (if pos == Factorial.length input then [Expected msg] else msgs)+               where replaceFailure (ParseFailure pos msgs erroneous) =+                        ParseFailure pos (if pos == fromEnd (Factorial.length input) then [StaticDescription msg]+                                          else msgs) erroneous    eof = Parser p       where p rest success failure                | Null.null rest = success () rest-               | otherwise = failure (FailureInfo (Factorial.length rest) [Expected "end of input"])-   unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (Factorial.length t) [Expected msg])+               | otherwise = failure (ParseFailure (fromEnd $ Factorial.length rest)+                                                   [StaticDescription "end of input"] [])+   unexpected msg = Parser (\t _ failure ->+                             failure $ ParseFailure (fromEnd $ Factorial.length t) [] [StaticDescription msg])    notFollowedBy (Parser p) = Parser q-      where q :: forall x. s -> (() -> s -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (() -> s -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success' failure'-               where success' _ _ = failure (FailureInfo (Factorial.length input) [Expected "notFollowedBy"])+               where success' _ _ =+                        failure (ParseFailure (fromEnd $ Factorial.length input) [StaticDescription "notFollowedBy"] [])                      failure' _ = success () input +instance (FactorialMonoid s, Ord s) => CommittedParsing (Parser g s) where+   type CommittedResults (Parser g s) = ParseResults s+   commit :: forall a. Parser g s a -> Parser g s (ParseResults s a)+   commit (Parser p) = Parser q+      where q :: forall x. s -> (ParseResults s a -> s -> x) -> (ParseFailure Pos s -> x) -> x+            q input success _failure = p input (success . Right) failure'+               where failure' f = success (Left f) input+   admit :: forall a. Parser g s (ParseResults s a) -> Parser g s a+   admit (Parser p) = Parser q+      where q :: forall x. s -> (a -> s -> x) -> (ParseFailure Pos s -> x) -> x+            q input success failure = p input success' failure+               where success' (Left f) _rest = failure f+                     success' (Right a) rest = success a rest+ -- | Every PEG parser is deterministic all the time.-instance FactorialMonoid s => DeterministicParsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => DeterministicParsing (Parser g s) where    (<<|>) = alt    takeSome = some    takeMany = many    skipAll = skipMany -instance FactorialMonoid s => LookAheadParsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => LookAheadParsing (Parser g s) where    lookAhead :: forall a. Parser g s a -> Parser g s a    lookAhead (Parser p) = Parser q-      where q :: forall x. s -> (a -> s -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (a -> s -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success' failure'                where success' a _ = success a input                      failure' f = failure f -instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where+instance (Ord s, Show s, TextualMonoid s) => CharParsing (Parser g s) where    satisfy predicate = Parser p-      where p :: forall x. s -> (Char -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (Char -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> success first suffix-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "Char.satisfy"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+instance (LeftReductive s, FactorialMonoid s, Ord s) => InputParsing (Parser g s) where    type ParserInput (Parser g s) = s    getInput = Parser p       where p rest success _ = success rest rest@@ -160,82 +191,82 @@       where p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) -> success first suffix-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "anyToken"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "anyToken")    satisfy predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) | predicate first -> success first suffix-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfy"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "satisfy")    notSatisfy predicate = Parser p-      where p :: forall x. s -> (() -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (() -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, _)-                     | predicate first -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfy"])+                     | predicate first -> failure (expected (fromEnd $ Factorial.length rest) "notSatisfy")                   _ -> success () rest    scan :: forall state. state -> (state -> s -> Maybe state) -> Parser g s s    scan s0 f = Parser (p s0)-      where p :: forall x. state -> s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. state -> s -> (s -> s -> x) -> (ParseFailure Pos s -> x) -> x             p s rest success _ = success prefix suffix                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest    take n = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success _                | (prefix, suffix) <- Factorial.splitAt n rest, Factorial.length prefix == n = success prefix suffix-            p rest _ failure = failure (FailureInfo (Factorial.length rest) [Expected $ "take" ++ show n])+            p rest _ failure = failure (expected (fromEnd $ Factorial.length rest) $ "take" ++ show n)    takeWhile predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success _ | (prefix, suffix) <- Factorial.span predicate rest = success prefix suffix    takeWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure                | (prefix, suffix) <- Factorial.span predicate rest =                     if Null.null prefix-                    then failure (FailureInfo (Factorial.length rest) [Expected "takeWhile1"])+                    then failure (expected (fromEnd $ Factorial.length rest) "takeWhile1")                     else success prefix suffix    string s = Parser p where-      p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      p :: forall x. s -> (s -> s -> x) -> (ParseFailure Pos s -> x) -> x       p s' success failure          | Just suffix <- stripPrefix s s' = success s suffix-         | otherwise = failure (FailureInfo (Factorial.length s') [ExpectedInput s])+         | otherwise = failure (ParseFailure (fromEnd $ Factorial.length s') [LiteralDescription 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+      where q :: forall x. s -> (a -> s -> x) -> (ParseFailure Pos 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+instance (Ord s, Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> success (Factorial.primePrefix rest) suffix-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfyChar"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "satisfyChar")    notSatisfyChar predicate = Parser p-      where p :: forall x. s -> (() -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (() -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.characterPrefix rest                of Just first | predicate first-                               -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfyChar"])+                               -> failure (expected (fromEnd $ Factorial.length rest) "notSatisfyChar")                   _ -> success () rest    scanChars :: forall state. state -> (state -> Char -> Maybe state) -> Parser g s s    scanChars s0 f = Parser (p s0)-      where p :: forall x. state -> s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. state -> s -> (s -> s -> x) -> (ParseFailure Pos s -> x) -> x             p s rest success _ = success prefix suffix                where (prefix, suffix, _) = Textual.spanMaybe_' s f rest    takeCharsWhile predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success _ | (prefix, suffix) <- Textual.span_ False predicate rest = success prefix suffix    takeCharsWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure-               | Null.null prefix = failure (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])+               | Null.null prefix = failure (expected (fromEnd $ Factorial.length rest) "takeCharsWhile1")                | otherwise = success prefix suffix                where (prefix, suffix) = Textual.span_ False predicate rest @@ -245,12 +276,9 @@ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) => --                  g (Continued.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance (LeftReductive s, FactorialMonoid s) => MultiParsing (Parser g s) where+instance (LeftReductive s, FactorialMonoid s, Ord s) => MultiParsing (Parser g s) where    type ResultFunctor (Parser g s) = ParseResults s    -- | Returns an input prefix parse paired with the remaining input suffix.-   parsePrefix g input = Rank2.fmap (Compose . (\p-> applyParser p input (flip $ curry Right) (Left . fromFailure input))) g-   parseComplete g input = Rank2.fmap (\p-> applyParser p input (const . Right) (Left . fromFailure input))+   parsePrefix g input = Rank2.fmap (Compose . (\p-> applyParser p input (flip $ curry Right) Left)) g+   parseComplete g input = Rank2.fmap (\p-> applyParser p input (const . Right) Left)                                       (Rank2.fmap (<* eof) g)--fromFailure :: (Eq s, FactorialMonoid s) => s -> FailureInfo s -> ParseFailure s-fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - pos + 1) (nub msgs)

@@ -1,12 +1,15 @@-{-# LANGUAGE BangPatterns, InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE BangPatterns, CPP, FlexibleContexts, InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} -- | Continuation-passing parser for Parsing Expression Grammars that keeps track of the parsed prefix length module Text.Grampa.PEG.Continued.Measured (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2)-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..))+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif  import Data.Functor.Compose (Compose(..))-import Data.List (nub)+import Data.Kind (Type) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid)@@ -26,16 +29,18 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),-                          MultiParsing(..), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))+import Text.Parser.Input.Position (fromEnd)+import Text.Grampa.Class (CommittedParsing(..), DeterministicParsing(..),+                          InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),+                          MultiParsing(..), ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (TraceableParsing(..), expected) import Text.Grampa.PEG.Continued (Result(..))  -- | Parser type for Parsing Expression Grammars that uses a continuation-passing algorithm and keeps track of the -- parsed prefix length, fast for grammars in LL(1) class but with potentially exponential performance for longer -- ambiguous prefixes.-newtype Parser (g :: (* -> *) -> *) s r =-   Parser{applyParser :: forall x. s -> (r -> Int -> s -> x) -> (FailureInfo s -> x) -> x}+newtype Parser (g :: (Type -> Type) -> Type) s r =+   Parser{applyParser :: forall x. s -> (r -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x}     instance Functor (Parser g s) where    fmap f (Parser p) = Parser (\input success-> p input (success . f))@@ -45,41 +50,47 @@    pure a = Parser (\input success _-> success a 0 input)    (<*>) :: forall a b. Parser g s (a -> b) -> Parser g s a -> Parser g s b    Parser p <*> Parser q = Parser r where-      r :: forall x. s -> (b -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      r :: forall x. s -> (b -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x       r rest success failure = p rest (\f len rest'-> q rest' (\a len'-> success (f a) $! len + len') failure) failure    {-# INLINABLE (<*>) #-} -instance FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected "empty"])+instance (FactorialMonoid s, Ord s) => Alternative (Parser g s) where+   empty = Parser (\rest _ failure-> failure $ ParseFailure (fromEnd $ Factorial.length rest) [] [])    (<|>) = alt  -- | A named and unconstrained version of the '<|>' operator-alt :: forall g s a. Parser g s a -> Parser g s a -> Parser g s a+alt :: forall g s a. Ord s => Parser g s a -> Parser g s a -> Parser g s a Parser p `alt` Parser q = Parser r where-   r :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo s -> x) -> x+   r :: forall x. s -> (a -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x    r rest success failure = p rest success (\f1-> q rest success $ \f2 -> failure (f1 <> f2))     instance Factorial.FactorialMonoid s => Filterable (Parser g s) where    mapMaybe :: forall a b. (a -> Maybe b) -> Parser g s a -> Parser g s b    mapMaybe f (Parser p) = Parser q where-      q :: forall x. s -> (b -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      q :: forall x. s -> (b -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x       q rest success failure = p rest (maybe filterFailure success . f) failure-         where filterFailure _ _ = failure (FailureInfo (Factorial.length rest) [Expected "filter"])+         where filterFailure _ _ = failure (expected (fromEnd $ Factorial.length rest) "filter")    {-# INLINABLE mapMaybe #-} +#if MIN_VERSION_base(4,13,0) instance Monad (Parser g s) where+#else+instance Factorial.FactorialMonoid s => Monad (Parser g s) where+#endif    return = pure    (>>=) :: forall a b. Parser g s a -> (a -> Parser g s b) -> Parser g s b    Parser p >>= f = Parser r where-      r :: forall x. s -> (b -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      r :: forall x. s -> (b -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x       r rest success failure = p rest                                   (\a len rest'-> applyParser (f a) rest' (\b len'-> success b $! len + len') failure)                                  failure +#if MIN_VERSION_base(4,13,0) instance FactorialMonoid s => MonadFail (Parser g s) where-   fail msg = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected msg])+#endif+   fail msg = Parser (\rest _ failure-> failure $ expected (fromEnd $ Factorial.length rest) msg) -instance FactorialMonoid s => MonadPlus (Parser g s) where+instance (FactorialMonoid s, Ord s) => MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) @@ -88,57 +99,72 @@  instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>) -instance FactorialMonoid s => Parsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => Parsing (Parser g s) where    try :: forall a. Parser g s a -> Parser g s a    try (Parser p) = Parser q-      where q :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo s -> x) -> x-            q input success failure = p input success (failure . rewindFailure)-               where rewindFailure (FailureInfo _pos _msgs) = FailureInfo (Factorial.length input) []+      where q :: forall x. s -> (a -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x+            q input success failure =+               p input success (const $ failure $ ParseFailure (fromEnd $ Factorial.length input) [] [])    (<?>) :: forall a. Parser g s a -> String -> Parser g s a    Parser p <?> msg  = Parser q-      where q :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (a -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success (failure . replaceFailure)-               where replaceFailure (FailureInfo pos msgs) =-                        FailureInfo pos (if pos == Factorial.length input then [Expected msg] else msgs)+               where replaceFailure (ParseFailure pos msgs erroneous) =+                        ParseFailure pos (if pos == fromEnd (Factorial.length input) then [StaticDescription msg]+                                          else msgs) erroneous    eof = Parser p       where p rest success failure                | Null.null rest = success () 0 rest-               | otherwise = failure (FailureInfo (Factorial.length rest) [Expected "end of input"])-   unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (Factorial.length t) [Expected msg])+               | otherwise = failure (expected (fromEnd $ Factorial.length rest) "end of input")+   unexpected msg = Parser (\t _ failure -> failure $ expected (fromEnd $ Factorial.length t) msg)    notFollowedBy (Parser p) = Parser q-      where q :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (() -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success' failure'-               where success' _ _ _ = failure (FailureInfo (Factorial.length input) [Expected "notFollowedBy"])+               where success' _ _ _ = failure (expected (fromEnd $ Factorial.length input) "notFollowedBy")                      failure' _ = success () 0 input +instance (FactorialMonoid s, Ord s) => CommittedParsing (Parser g s) where+   type CommittedResults (Parser g s) = ParseResults s+   commit :: forall a. Parser g s a -> Parser g s (ParseResults s a)+   commit (Parser p) = Parser q+      where q :: forall x. s -> (ParseResults s a -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x+            q input success _failure = p input (success . Right) failure'+               where failure' f = success (Left f) 0 input+   admit :: forall a. Parser g s (ParseResults s a) -> Parser g s a+   admit (Parser p) = Parser q+      where q :: forall x. s -> (a -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x+            q input success failure = p input success' failure+               where success' (Left f) _len _rest = failure f+                     success' (Right a) len rest = success a len rest+ -- | Every PEG parser is deterministic all the time.-instance FactorialMonoid s => DeterministicParsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => DeterministicParsing (Parser g s) where    (<<|>) = alt    takeSome = some    takeMany = many    skipAll = skipMany -instance FactorialMonoid s => LookAheadParsing (Parser g s) where+instance (FactorialMonoid s, Ord s) => LookAheadParsing (Parser g s) where    lookAhead :: forall a. Parser g s a -> Parser g s a    lookAhead (Parser p) = Parser q-      where q :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> (a -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             q input success failure = p input success' failure'                where success' a _ _ = success a 0 input                      failure' f = failure f -instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where+instance (Ord s, Show s, TextualMonoid s) => CharParsing (Parser g s) where    satisfy predicate = Parser p-      where p :: forall x. s -> (Char -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (Char -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> success first 1 suffix-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "Char.satisfy"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+instance (LeftReductive s, FactorialMonoid s, Ord s) => InputParsing (Parser g s) where    type ParserInput (Parser g s) = s    getInput = Parser p       where p rest success _ = success rest 0 rest@@ -146,97 +172,97 @@       where p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) -> success first 1 suffix-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "anyToken"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "anyToken")    satisfy predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) | predicate first -> success first 1 suffix-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfy"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "satisfy")    notSatisfy predicate = Parser p-      where p :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (() -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, _)-                     | predicate first -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfy"])+                     | predicate first -> failure (expected (fromEnd $ Factorial.length rest) "notSatisfy")                   _ -> success () 0 rest    scan :: forall state. state -> (state -> s -> Maybe state) -> Parser g s s    scan s0 f = Parser (p s0)-      where p :: forall x. state -> s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. state -> s -> (s -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p s rest success _ = success prefix len suffix                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest                      !len = Factorial.length prefix    take n = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success _                | (prefix, suffix) <- Factorial.splitAt n rest,                  len <- Factorial.length prefix, len == n = success prefix len suffix-            p rest _ failure = failure (FailureInfo (Factorial.length rest) [Expected $ "take" ++ show n])+            p rest _ failure = failure (expected (fromEnd $ Factorial.length rest) $ "take" ++ show n)    takeWhile predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success _                 | (prefix, suffix) <- Factorial.span predicate rest,                   !len <- Factorial.length prefix = success prefix len suffix    takeWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure                | (prefix, suffix) <- Factorial.span predicate rest,                   !len <- Factorial.length prefix =                     if len == 0-                    then failure (FailureInfo (Factorial.length rest) [Expected "takeWhile1"])+                    then failure (expected (fromEnd $ Factorial.length rest) "takeWhile1")                     else success prefix len suffix    string s = Parser p where-      p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      p :: forall x. s -> (s -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x       p s' success failure          | Just suffix <- stripPrefix s s', !len <- Factorial.length s = success s len suffix-         | otherwise = failure (FailureInfo (Factorial.length s') [ExpectedInput s])+         | otherwise = failure (ParseFailure (fromEnd $ Factorial.length s') [LiteralDescription s] [])    {-# INLINABLE string #-} -instance (LeftReductive s, FactorialMonoid s) => ConsumedInputParsing (Parser g s) where+instance (LeftReductive s, FactorialMonoid s, Ord s) => ConsumedInputParsing (Parser g s) where    match :: forall a. Parser g s a -> Parser g s (s, a)    match (Parser p) = Parser q-      where q :: forall x. s -> ((s, a) -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where q :: forall x. s -> ((s, a) -> Int -> s -> x) -> (ParseFailure Pos 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+      where q :: forall x. s -> (a -> Int -> s -> x) -> (ParseFailure Pos 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+instance (Ord s, Show s, TextualMonoid s) => InputCharParsing (Parser g s) where    satisfyCharInput predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.splitCharacterPrefix rest                of Just (first, suffix) | predicate first -> success (Factorial.primePrefix rest) 1 suffix-                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfyCharInput"])+                  _ -> failure (expected (fromEnd $ Factorial.length rest) "satisfyCharInput")    notSatisfyChar predicate = Parser p-      where p :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (() -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure =                case Textual.characterPrefix rest                of Just first | predicate first-                               -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfyChar"])+                               -> failure (expected (fromEnd $ Factorial.length rest) "notSatisfyChar")                   _ -> success () 0 rest    scanChars :: forall state. state -> (state -> Char -> Maybe state) -> Parser g s s    scanChars s0 f = Parser (p s0)-      where p :: forall x. state -> s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. state -> s -> (s -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p s rest success _ = success prefix len suffix                where (prefix, suffix, _) = Textual.spanMaybe_' s f rest                      !len = Factorial.length prefix    takeCharsWhile predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success _                | (prefix, suffix) <- Textual.span_ False predicate rest,                   !len <- Factorial.length prefix = success prefix len suffix    takeCharsWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (ParseFailure Pos s -> x) -> x             p rest success failure-               | Null.null prefix = failure (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])+               | Null.null prefix = failure (expected (fromEnd $ Factorial.length rest) "takeCharsWhile1")                | otherwise = success prefix len suffix                where (prefix, suffix) = Textual.span_ False predicate rest                      !len = Factorial.length prefix@@ -247,13 +273,8 @@ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) => --                  g (Continued.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance (LeftReductive s, FactorialMonoid s) => MultiParsing (Parser g s) where+instance (LeftReductive s, FactorialMonoid s, Ord s) => MultiParsing (Parser g s) where    type ResultFunctor (Parser g s) = ParseResults s    -- | Returns an input prefix parse paired with the remaining input suffix.-   parsePrefix g input = Rank2.fmap (Compose . (\p-> applyParser p input (\a _ rest-> Right (rest, a)) -                                                                 (Left . fromFailure input))) g-   parseComplete g input = Rank2.fmap (\p-> applyParser p input (const . const . Right) (Left . fromFailure input))-                                      (Rank2.fmap (<* eof) g)--fromFailure :: (Eq s, FactorialMonoid s) => s -> FailureInfo s -> ParseFailure s-fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - pos + 1) (nub msgs)+   parsePrefix g input = Rank2.fmap (Compose . (\p-> applyParser p input (\a _ rest-> Right (rest, a)) Left)) g+   parseComplete g input = Rank2.fmap (\p-> applyParser p input (const . const . Right) Left) (Rank2.fmap (<* eof) g)

@@ -1,16 +1,19 @@-{-# LANGUAGE TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies, UndecidableInstances #-} -- | Packrat parser module Text.Grampa.PEG.Packrat (Parser(..), Result(..)) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2)-import Control.Monad (Monad(..), MonadFail(fail), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..))+#if MIN_VERSION_base(4,13,0)+import Control.Monad (MonadFail(fail))+#endif  import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.List (genericLength, nub) import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid)+import Data.Ord (Down(Down)) import Data.Semigroup (Semigroup(..)) import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString)@@ -27,14 +30,16 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..),+import Text.Parser.Input.Position (fromEnd)+import Text.Grampa.Class (CommittedParsing(..), DeterministicParsing(..),+                          InputParsing(..), InputCharParsing(..),                           GrammarParsing(..), MultiParsing(..),-                          TailsParsing(parseTails), ParseResults, ParseFailure(..), Expected(..))-import Text.Grampa.Internal (FailureInfo(..), TraceableParsing(..))+                          TailsParsing(parseTails), ParseResults, ParseFailure(..), FailureDescription(..), Pos)+import Text.Grampa.Internal (expected, TraceableParsing(..))  data Result g s v = Parsed{parsedPrefix :: !v,                             parsedSuffix :: ![(s, g (Result g s))]}-                  | NoParse (FailureInfo s)+                  | NoParse (ParseFailure Pos s)  -- | 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 the backtracking 'Text.Grampa.PEG.Backtrack.Parser'. The@@ -51,7 +56,7 @@  instance Filterable (Result g s) where    mapMaybe f (Parsed a rest) =-      maybe (NoParse $ FailureInfo (Factorial.length rest) [Expected "filter"]) (`Parsed` rest) (f a)+      maybe (NoParse $ expected (fromEnd $ Factorial.length rest) "filter") (`Parsed` rest) (f a)    mapMaybe _ (NoParse failure) = NoParse failure     instance Functor (Parser g s) where@@ -65,7 +70,7 @@                   NoParse failure -> NoParse failure  instance Alternative (Parser g s) where-   empty = Parser (\rest-> NoParse $ FailureInfo (genericLength rest) [Expected "empty"])+   empty = Parser (\rest-> NoParse $ ParseFailure (Down $ length rest) [] [])    Parser p <|> Parser q = Parser r where       r rest = case p rest                of x@Parsed{} -> x@@ -82,39 +87,55 @@                of Parsed a rest' -> applyParser (f a) rest'                   NoParse failure -> NoParse failure +#if MIN_VERSION_base(4,13,0)+instance MonadFail (Parser g s) where+#endif+   fail msg = Parser (\rest-> NoParse $ ParseFailure (Down $ length rest) [] [StaticDescription msg])+ instance MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) -instance MonadFail (Parser g s) where-   fail msg = Parser (\rest-> NoParse $ FailureInfo (genericLength rest) [Expected msg])- instance Semigroup x => Semigroup (Parser g s x) where    (<>) = liftA2 (<>)  instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty-   mappend = liftA2 mappend+   mappend = (<>)  instance FactorialMonoid s => Parsing (Parser g s) where    try (Parser p) = Parser q       where q rest = rewindFailure (p rest)-               where rewindFailure (NoParse (FailureInfo _pos _msgs)) = NoParse (FailureInfo (genericLength rest) [])+               where rewindFailure NoParse{} = NoParse (ParseFailure (Down $ length rest) [] [])                      rewindFailure parsed = parsed    Parser p <?> msg  = Parser q       where q rest = replaceFailure (p rest)-               where replaceFailure (NoParse (FailureInfo pos msgs)) =-                        NoParse (FailureInfo pos $ if pos == genericLength rest then [Expected msg] else msgs)+               where replaceFailure (NoParse (ParseFailure pos msgs erroneous)) =+                        NoParse (ParseFailure pos+                                              (if pos == Down (length rest) then [StaticDescription msg] else msgs)+                                              erroneous)                      replaceFailure parsed = parsed    eof = Parser p       where p rest@((s, _) : _)-               | not (Null.null s) = NoParse (FailureInfo (genericLength rest) [Expected "end of input"])+               | not (Null.null s) = NoParse (ParseFailure (Down $ length rest) [StaticDescription "end of input"] [])             p rest = Parsed () rest-   unexpected msg = Parser (\t-> NoParse $ FailureInfo (genericLength t) [Expected msg])+   unexpected msg = Parser (\t-> NoParse $ ParseFailure (Down $ length t) [] [StaticDescription msg])    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))-      where rewind t Parsed{} = NoParse (FailureInfo (genericLength t) [Expected "notFollowedBy"])+      where rewind t Parsed{} = NoParse (ParseFailure (Down $ length t) [StaticDescription "notFollowedBy"] [])             rewind t NoParse{} = Parsed () t +instance FactorialMonoid s => CommittedParsing (Parser g s) where+   type CommittedResults (Parser g s) = ParseResults s+   commit (Parser p) = Parser q+      where q rest = case p rest+                     of NoParse failure -> Parsed (Left failure) rest+                        Parsed a rest' -> Parsed (Right a) rest'+   admit (Parser p) = Parser q+      where q rest = case p rest+                     of NoParse failure -> NoParse failure+                        Parsed (Left failure) _ -> NoParse failure+                        Parsed (Right a) rest' -> Parsed a rest'+ -- | Every PEG parser is deterministic all the time. instance FactorialMonoid s => DeterministicParsing (Parser g s) where    (<<|>) = (<|>)@@ -132,8 +153,8 @@       where p rest@((s, _):t) =                case Textual.characterPrefix s                of Just first | predicate first -> Parsed first t-                  _ -> NoParse (FailureInfo (genericLength rest) [Expected "Char.satisfy"])-            p [] = NoParse (FailureInfo 0 [Expected "Char.satisfy"])+                  _ -> NoParse (expected (Down $ length rest) "Char.satisfy")+            p [] = NoParse (expected 0 "Char.satisfy")    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) @@ -141,10 +162,10 @@ 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-   parsingResult = fromResult+   parsingResult = const fromResult    nonTerminal f = Parser p where       p ((_, d) : _) = f d-      p _ = NoParse (FailureInfo 0 [Expected "NonTerminal at endOfInput"])+      p _ = NoParse (expected 0 "NonTerminal at endOfInput")  instance (Eq s, LeftReductive s, FactorialMonoid s) => TailsParsing (Parser g s) where    parseTails = applyParser@@ -157,18 +178,18 @@    anyToken = Parser p       where p rest@((s, _):t) = case Factorial.splitPrimePrefix s                                 of Just (first, _) -> Parsed first t-                                   _ -> NoParse (FailureInfo (genericLength rest) [Expected "anyToken"])-            p [] = NoParse (FailureInfo 0 [Expected "anyToken"])+                                   _ -> NoParse (expected (Down $ length rest) "anyToken")+            p [] = NoParse (expected 0 "anyToken")    satisfy predicate = Parser p       where p rest@((s, _):t) =                case Factorial.splitPrimePrefix s                of Just (first, _) | predicate first -> Parsed first t-                  _ -> NoParse (FailureInfo (genericLength rest) [Expected "satisfy"])-            p [] = NoParse (FailureInfo 0 [Expected "satisfy"])+                  _ -> NoParse (expected (Down $ length rest) "satisfy")+            p [] = NoParse (expected 0 "satisfy")    notSatisfy predicate = Parser p       where p rest@((s, _):_)                | Just (first, _) <- Factorial.splitPrimePrefix s, -                 predicate first = NoParse (FailureInfo (genericLength rest) [Expected "notSatisfy"])+                 predicate first = NoParse (expected (Down $ length rest) "notSatisfy")             p rest = Parsed () rest    scan s0 f = Parser (p s0)       where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)@@ -182,16 +203,16 @@       where p rest@((s, _) : _)                | x <- Factorial.take n s, Factorial.length x == n = Parsed x (drop n rest)             p [] | n == 0 = Parsed mempty []-            p rest = NoParse (FailureInfo (genericLength rest) [Expected $ "take " ++ show n])+            p rest = NoParse (expected (Down $ length rest) $ "take " ++ show n)    takeWhile1 predicate = Parser p       where p rest@((s, _) : _)                | x <- Factorial.takeWhile predicate s, not (Null.null x) =                     Parsed x (Factorial.drop (Factorial.length x) rest)-            p rest = NoParse (FailureInfo (genericLength rest) [Expected "takeWhile1"])+            p rest = NoParse (expected (Down $ length rest) "takeWhile1")    string s = Parser p where       p rest@((s', _) : _)          | s `isPrefixOf` s' = Parsed s (Factorial.drop (Factorial.length s) rest)-      p rest = NoParse (FailureInfo (genericLength rest) [ExpectedInput s])+      p rest = NoParse (ParseFailure (Down $ length rest) [LiteralDescription s] [])  instance (InputParsing (Parser g s), Monoid s)  => TraceableParsing (Parser g s) where    traceInput description (Parser p) = Parser q@@ -207,12 +228,12 @@       where p rest@((s, _):t) =                case Textual.characterPrefix s                of Just first | predicate first -> Parsed (Factorial.primePrefix s) t-                  _ -> NoParse (FailureInfo (genericLength rest) [Expected "satisfyCharInput"])-            p [] = NoParse (FailureInfo 0 [Expected "satisfyCharInput"])+                  _ -> NoParse (expected (Down $ length rest) "satisfyCharInput")+            p [] = NoParse (expected 0 "satisfyCharInput")    notSatisfyChar predicate = Parser p       where p rest@((s, _):_)                | Just first <- Textual.characterPrefix s, -                 predicate first = NoParse (FailureInfo (genericLength rest) [Expected "notSatisfyChar"])+                 predicate first = NoParse (expected (Down $ length rest) "notSatisfyChar")             p rest = Parsed () rest    scanChars s0 f = Parser (p s0)       where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)@@ -227,7 +248,7 @@       where p rest@((s, _) : _)                | x <- Textual.takeWhile_ False predicate s, not (Null.null x) =                     Parsed x (drop (Factorial.length x) rest)-            p rest = NoParse (FailureInfo (genericLength rest) [Expected "takeCharsWhile1"])+            p rest = NoParse (expected (Down $ length rest) "takeCharsWhile1")  -- | Packrat parser --@@ -239,8 +260,8 @@    type ResultFunctor (Parser g s) = ParseResults s    type GrammarConstraint (Parser g s) g' = (g ~ g', Rank2.Functor g)    {-# NOINLINE parsePrefix #-}-   parsePrefix g input = Rank2.fmap (Compose . fromResult input) (snd $ head $ parseGrammarTails g input)-   parseComplete g input = Rank2.fmap ((snd <$>) . fromResult input)+   parsePrefix g input = Rank2.fmap (Compose . fromResult) (snd $ head $ parseGrammarTails g input)+   parseComplete g input = Rank2.fmap ((snd <$>) . fromResult)                                       (snd $ head $ reparseTails close $ parseGrammarTails g input)       where close = Rank2.fmap (<* eof) g @@ -255,8 +276,7 @@ reparseTails final parsed@((s, _):_) = (s, gd):parsed    where gd = Rank2.fmap (`applyParser` parsed) final -fromResult :: (Eq s, FactorialMonoid s) => s -> Result g s r -> ParseResults s (s, r)-fromResult s (NoParse (FailureInfo pos msgs)) =-   Left (ParseFailure (Factorial.length s - pos + 1) (nub msgs))-fromResult _ (Parsed prefix []) = Right (mempty, prefix)-fromResult _ (Parsed prefix ((s, _):_)) = Right (s, prefix)+fromResult :: (Eq s, Monoid s) => Result g s r -> ParseResults s (s, r)+fromResult (NoParse (ParseFailure pos positive negative)) = Left (ParseFailure (pos - 1) positive negative)+fromResult (Parsed prefix []) = Right (mempty, prefix)+fromResult (Parsed prefix ((s, _):_)) = Right (s, prefix)

@@ -89,9 +89,9 @@ -- >>> parseComplete grammar "1+2*3" -- Arithmetic{ --   sum=Compose (Right [7]),---   product=Compose (Left (ParseFailure 1 [Expected "end of input"])),---   factor=Compose (Left (ParseFailure 1 [Expected "end of input"])),---   number=Compose (Left (ParseFailure 1 [Expected "end of input"]))}+--   product=Compose (Left (ParseFailure {failurePosition = Down 4, expectedAlternatives = [StaticDescription "end of input"], errorAlternatives = []})),+--   factor=Compose (Left (ParseFailure {failurePosition = Down 4, expectedAlternatives = [StaticDescription "end of input"], errorAlternatives = []})),+--   number=Compose (Left (ParseFailure {failurePosition = Down 4, expectedAlternatives = [StaticDescription "end of input"], errorAlternatives = []}))} -- >>> parsePrefix grammar "1+2*3 apples" -- Arithmetic{ --   sum=Compose (Compose (Right [("+2*3 apples",1),("*3 apples",3),(" apples",7)])),

@@ -2,7 +2,7 @@              ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeFamilies, UndecidableInstances #-} module Main where -import Control.Applicative (Applicative, Alternative, Const(..), pure, empty, many, optional, (<*>), (*>), (<|>))+import Control.Applicative (Applicative, Alternative, Const(..), pure, empty, liftA2, many, optional, (<*>), (*>), (<|>)) import Control.Arrow (first) import Control.Monad (MonadPlus(mzero, mplus), guard, liftM, liftM2, void) import Data.Char (isSpace, isLetter)@@ -22,12 +22,9 @@ import qualified Text.Parser.Char as Char import Text.Parser.Token (whiteSpace) -import Control.Enumerable (Shareable, Sized, share)-import Test.Feat (Enumerable(..), c0, c1, uniform)-import Test.Feat.Enumerate (pay) import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.QuickCheck (Arbitrary(..), Gen, Positive(..), Property,-                              (===), (==>), (.&&.), forAll, mapSize, property, sized, testProperty, within)+import Test.Tasty.QuickCheck (Arbitrary(..), CoArbitrary, Gen, Positive(..), Property,+                              (===), (==>), (.&&.), elements, forAll, mapSize, oneof, property, resize, sized, testProperty, within) import Test.QuickCheck (verbose) import Test.QuickCheck.Checkers (Binop, EqProp(..), TestBatch, unbatch) import Test.QuickCheck.Classes (functor, monad, monoid, applicative, alternative,@@ -104,15 +101,15 @@  type Parser = Parallel.Parser -simpleParse :: (Eq s, FactorialMonoid s, LeftReductive s) =>+simpleParse :: (Ord 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) =>+memoizingParse :: (Ord 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) =>+leftRecursiveParse :: (Ord 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 @@ -145,9 +142,9 @@                testProperty "name list" $                  start (parseComplete nameListGrammar "foo, bar") == Compose (Right ["foo bar"]),                testProperty "filtered" $-                 start (parseComplete gf "") === Compose (Left (ParseFailure 0 [ExpectedInput "1"])),+                 start (parseComplete gf "") === Compose (Left (ParseFailure 0 [LiteralDescription "1"] [])),                testProperty "monadic" $-                 start (parseComplete gm "") === Compose (Left (ParseFailure 0 [Expected "empty"])),+                 start (parseComplete gm "") === Compose (Left (ParseFailure 0 [] [StaticDescription "empty"])),                testProperty "null monadic" $                  start (parseComplete gn "23") === Compose (Right ["23"])               ],@@ -187,7 +184,7 @@                                                      :| [Test.Ambiguous.Xy2                                                          (pure $ Test.Ambiguous.Xy1 "x" "") "y"]))]))],            testGroup "primitives"-             [testProperty "anyToken mempty" $ simpleParse anyToken "" == Left (ParseFailure 0 [Expected "anyToken"]),+             [testProperty "anyToken mempty" $ simpleParse anyToken "" == Left (expected 0 "anyToken"),               testProperty "anyToken list" $                 \(x::Word8) xs-> simpleParse anyToken (x:xs) == Right [(xs, [x])],               testProperty "satisfy success" $ \bools->@@ -197,10 +194,11 @@               testProperty "string success" $ \(xs::[Word8]) ys->                    simpleParse (string xs) (xs <> ys) == Right [(ys, xs)],               testProperty "string" $ \(xs::[Word8]) ys-> not (xs `isPrefixOf` ys)-                ==> simpleParse (string xs) ys == Left (ParseFailure 0 [ExpectedInput xs]),-              testProperty "eof mempty" $ simpleParse eof "" == Right [("", ())],+                ==> simpleParse (string xs) ys+                    === Left (ParseFailure (fromIntegral $ length ys) [LiteralDescription xs] []),+              testProperty "eof mempty" $ simpleParse eof "" === Right [("", ())],               testProperty "eof failure" $ \s->-                   s /= "" ==> simpleParse eof s == Left (ParseFailure 0 [Expected "end of input"])],+                   s /= "" ==> simpleParse eof s === Left (expected (fromIntegral $ length s) "end of input")],            testGroup "lookAhead"              [testProperty "lookAhead" lookAheadP,               testProperty "lookAhead p *> p" lookAheadConsumeP,@@ -254,9 +252,6 @@             notFollowedBy (notFollowedBy p) =-= (void (lookAhead p) :: Parser (Rank2.Only ()) String ())          lookAheadTokenP x xs = simpleParse (lookAhead anyToken) (x:xs) == Right [(x:xs, [x])] -instance Enumerable (DescribedParser s r) => Arbitrary (DescribedParser s r) where-   arbitrary = sized uniform- testBatch :: TestBatch -> TestTree testBatch (label, tests) = testGroup label (uncurry testProperty . (within 5000000 <$>) <$> tests) @@ -271,95 +266,119 @@ instance Show (DescribedParser s r) where    show (DescribedParser d _) = d -instance (Show s, MonoidNull s, Semigroup r) => Semigroup (DescribedParser s r) where+instance (MonoidNull s, Ord s, Show s, Semigroup r) => Semigroup (DescribedParser s r) where    DescribedParser d1 p1 <> DescribedParser d2 p2 = DescribedParser (d1 ++ " <> " ++ d2) (p1 <> p2) -instance (Show s, MonoidNull s, Monoid r) => Monoid (DescribedParser s r) where+instance (MonoidNull s, Ord s, Show s, Monoid r) => Monoid (DescribedParser s r) where    mempty = DescribedParser "mempty" mempty-   DescribedParser d1 p1 `mappend` DescribedParser d2 p2 = DescribedParser (d1 ++ " <> " ++ d2) (mappend p1 p2)+   mappend = (<>) -instance EqProp (ParseFailure s) where-   ParseFailure pos1 msg1 =-= ParseFailure pos2 msg2 = property (pos1 == pos2)+instance EqProp (ParseFailure Pos s) where+   ParseFailure pos1 expected1 erroneous1 =-= ParseFailure pos2 expected2 erroneous2 = property (pos1 == pos2) -instance (Ord r, Show r, EqProp r, Eq s, EqProp s, Show s, FactorialMonoid s, LeftReductive s, Arbitrary s) =>+instance (EqProp r, Ord r, Show r, Arbitrary s, EqProp s, FactorialMonoid s, LeftReductive s, Ord s, Show s) =>          EqProp (Parser (Rank2.Only r) s r) where    p1 =-= p2 = forAll arbitrary (\s-> (nub <$> simpleParse p1 s) =-= (nub <$> simpleParse p2 s)) -instance (Eq s, FactorialMonoid s, LeftReductive s, Show s, EqProp s, Arbitrary s, Ord r, Show r, EqProp r, Typeable r) =>-         EqProp (DescribedParser s r) where+instance (Arbitrary s, EqProp s, FactorialMonoid s, LeftReductive s, Ord s, Show s,+          EqProp r, Ord r, Show r, Typeable r) => EqProp (DescribedParser s r) where    DescribedParser _ p1 =-= DescribedParser _ p2 = forAll arbitrary $ \s->       simpleParse p1 s =-= simpleParse p2 s  instance Monoid s => Functor (DescribedParser s) where    fmap f (DescribedParser d p) = DescribedParser ("fmap ? " ++ d) (fmap f p) -instance (Show s, Monoid s) => Applicative (DescribedParser s) where+instance (Monoid s, Ord s, Show s) => Applicative (DescribedParser s) where    pure x = DescribedParser "pure ?" (pure x)    DescribedParser d1 p1 <*> DescribedParser d2 p2 = DescribedParser (d1 ++ " <*> " ++ d2) (p1 <*> p2)+   DescribedParser d1 p1  *> DescribedParser d2 p2 = DescribedParser (d1 ++ " *> " ++ d2) (p1 *> p2) -instance (Show s, Monoid s) => Monad (DescribedParser s) where-   return x = DescribedParser "return ?" (return x)+instance (FactorialMonoid s, Ord s, Show s) => Monad (DescribedParser s) where+   return = pure    DescribedParser d1 p1 >>= f = DescribedParser (d1 ++ " >>= ?") (p1 >>= \x-> let DescribedParser _ p = f x in p)-   DescribedParser d1 p1 >> DescribedParser d2 p2 = DescribedParser (d1 ++ " >> " ++ d2) (p1 >> p2) -instance (Show s, FactorialMonoid s) => Alternative (DescribedParser s) where+instance (FactorialMonoid s, Ord s, Show s) => Alternative (DescribedParser s) where    empty = DescribedParser "empty" empty    DescribedParser d1 p1 <|> DescribedParser d2 p2 = DescribedParser (d1 ++ " <|> " ++ d2) (p1 <|> p2) -instance (Show s, FactorialMonoid s) => MonadPlus (DescribedParser s) where+instance (FactorialMonoid s, Ord s, Show s) => MonadPlus (DescribedParser s) where    mzero = DescribedParser "mzero" mzero    DescribedParser d1 p1 `mplus` DescribedParser d2 p2 = DescribedParser (d1 ++ " `mplus` " ++ d2) (mplus p1 p2) -instance forall s. (Semigroup s, FactorialMonoid s, LeftReductive s, Ord s, Typeable s, Show s, Enumerable s) =>-         Enumerable (DescribedParser s s) where-   enumerate = share (choice [c0 (DescribedParser "anyToken" anyToken),-                              c0 (DescribedParser "getInput" getInput),-                              c0 (DescribedParser "empty" empty),-                              c0 (DescribedParser "mempty" mempty),-                              pay (c1 $ \s-> DescribedParser "string" (string s)),-                              pay (c1 $ \pred-> DescribedParser "satisfy" (satisfy pred)),-                              pay (c1 $ \pred-> DescribedParser "takeWhile" (takeWhile pred)),-                              pay (c1 $ \pred-> DescribedParser "takeWhile1" (takeWhile1 pred)),-                              binary " *> " (*>),-                              binary " <> " (<>),-                              binary " <|> " (<|>)])+instance forall s. (Semigroup s, FactorialMonoid s, LeftReductive s, Ord s, Typeable s, Show s,+                    Arbitrary s, CoArbitrary s) =>+         Arbitrary (DescribedParser s s) where+   arbitrary = sized tree+     where tree 0 = elements [DescribedParser "anyToken" anyToken,+                              DescribedParser "getInput" getInput,+                              DescribedParser "empty" empty,+                              DescribedParser "mempty" mempty]+           tree n = oneof [pure (DescribedParser "anyToken" anyToken),+                           pure (DescribedParser "getInput" getInput),+                           pure (DescribedParser "empty" empty),+                           pure (DescribedParser "mempty" mempty),+                           (\s-> DescribedParser "string" $ string s) <$> resize (n - 1) arbitrary,+                           (\p-> DescribedParser "satisfy" $ satisfy p) <$> resize (n - 1) arbitrary,+                           (\p-> DescribedParser "takeWhile" $ takeWhile p) <$> resize (n - 1) arbitrary,+                           (\p-> DescribedParser "takeWhile1" $ takeWhile1 p) <$> resize (n - 1) arbitrary,+                           binary " *> " (*>) branch branch,+                           binary " <> " (<>) branch branch,+                           binary " <|> " (<|>) branch branch]+             where branch = tree (n `div` 2) -instance forall s r. (Ord s, Semigroup s, FactorialMonoid s, LeftReductive s, Show s, Enumerable s) =>-         Enumerable (DescribedParser s ()) where-   enumerate = share (choice [c0 (DescribedParser "eof" eof),-                              pay (c1 $ \(DescribedParser d p :: DescribedParser s s)-> DescribedParser ("void " <> d) (void p)),-                              pay (c1 $ \(DescribedParser d p :: DescribedParser s s)->-                                    DescribedParser ("(notFollowedBy " <> d <> ")") (notFollowedBy p))])+instance forall s r. (Ord s, Semigroup s, FactorialMonoid s, LeftReductive s, Show s,+                      Arbitrary s, CoArbitrary s, Typeable s) =>+         Arbitrary (DescribedParser s ()) where+   arbitrary = oneof [pure (DescribedParser "eof" eof),+                      (\(DescribedParser d p :: DescribedParser s s)->+                        DescribedParser ("void " <> d) (void p)) <$> sized (\n-> resize (max (n - 1) 0) arbitrary),+                      (\(DescribedParser d p :: DescribedParser s s)->+                        DescribedParser ("notFollowedBy " <> d) (notFollowedBy p))+                      <$> sized (\n-> resize (max (n - 1) 0) arbitrary)] -instance forall s r. (Show s, Semigroup s, FactorialMonoid s, Typeable s) => Enumerable (DescribedParser s [Bool]) where-   enumerate = share (choice [c0 (DescribedParser "empty" empty),-                              c0 (DescribedParser "mempty" mempty),-                              pay (c1 $ \r-> DescribedParser ("(pure " ++ shows r ")") (pure r)),-                              pay (c1 $ \(DescribedParser d p)-> DescribedParser ("(lookAhead " <> d <> ")") (lookAhead p)),-                              binary " *> " (*>),-                              binary " <> " (<>),-                              binary " <|> " (<|>)])+instance forall s r. (Ord s, Show s, Semigroup s, FactorialMonoid s, Typeable s) =>+   Arbitrary (DescribedParser s [Bool]) where+   arbitrary = sized tree+     where tree 0 = elements [DescribedParser "empty" empty,+                              DescribedParser "mempty" mempty]+           tree n = oneof [pure (DescribedParser "empty" empty),+                           pure (DescribedParser "mempty" mempty),+                           (\r-> DescribedParser ("(pure " ++ shows r ")") (pure r)) <$> resize (n - 1) arbitrary,+                           (\(DescribedParser d p)-> DescribedParser ("(lookAhead " <> d <> ")") (lookAhead p))+                            <$> tree (n - 1),+                           binary " *> " (*>) branch branch,+                           binary " <> " (<>) branch branch,+                           binary " <|> " (<|>) branch branch]+             where branch = tree (n `div` 2) -instance forall s r. (Show s, Semigroup s, FactorialMonoid s, Typeable s) =>-         Enumerable (DescribedParser s ([Bool] -> [Bool])) where-   enumerate = share (choice [c0 (DescribedParser "empty" empty),-                              c0 (DescribedParser "mempty" mempty),-                              pay (c1 $ \r-> DescribedParser ("(pure " ++ shows r ")") (pure r)),-                              pay (c1 $ \(DescribedParser d p)-> DescribedParser ("(lookAhead " <> d <> ")") (lookAhead p)),-                              binary " *> " (*>),-                              binary " <> " (<>),-                              binary " <|> " (<|>)])+instance forall s r. (Ord s, Show s, Semigroup s, FactorialMonoid s, Typeable s) =>+         Arbitrary (DescribedParser s ([Bool] -> [Bool])) where+   arbitrary = sized tree+     where tree 0 = oneof [pure (DescribedParser "empty" empty),+                           pure (DescribedParser "mempty" mempty)]+           tree n = oneof [pure (DescribedParser "empty" empty),+                           pure (DescribedParser "mempty" mempty),+                           (\r-> DescribedParser ("(pure " ++ shows r ")") (pure r)) <$> resize (n - 1) arbitrary,+                           (\(DescribedParser d p)-> DescribedParser ("(lookAhead " <> d <> ")") (lookAhead p))+                            <$> tree (n - 1),+                           binary " *> " (*>) branch branch,+                           binary " <> " (<>) branch branch,+                           binary " <|> " (<|>) branch branch]+             where branch = tree (n `div` 2) -binary :: forall f s a. (Typeable f, Sized f, Enumerable (DescribedParser s a))-       => String+binary :: String        -> (forall g. Rank2.Functor g => Parser g s a -> Parser g s a -> Parser g s a)-       -> Shareable f (DescribedParser s a)-binary nm op = pay $ c1 (\(DescribedParser d1 p1, DescribedParser d2 p2)-> -                          DescribedParser (d1 <> nm <> d2) (op p1 p2))+       -> Gen (DescribedParser s a)+       -> Gen (DescribedParser s a)+       -> Gen (DescribedParser s a)+binary nm op = liftA2 (\(DescribedParser d1 p1) (DescribedParser d2 p2)-> DescribedParser (d1 <> nm <> d2) (op p1 p2)) -instance {-# OVERLAPS #-} (Ord s, Enumerable s) => Enumerable (s -> Bool) where-   enumerate = share (pay (c1 (<=)) <|> pay (c1 const))+expected :: Pos -> String -> ParseFailure Pos s+expected pos msg = ParseFailure pos [StaticDescription msg] [] +--instance {-# OVERLAPS #-} (Ord s, Arbitrary s) => Arbitrary (s -> Bool) where+--   arbitrary = elements [(<=), const False]+ -- instance Enumerable ([Bool] -> [Bool]) where --    enumerate = share (choice [c0 id, c0 (map not), pay (c1 const)]) @@ -367,3 +386,5 @@    a =-= b = property (a == b)  results = either (const []) id++

@@ -1,18 +1,14 @@ {-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-} module Test.Examples where -import Control.Applicative (empty, (<|>))+import Control.Applicative (empty, liftA2, liftA3, (<|>)) import Data.Functor.Compose (Compose(..)) import Data.Monoid (Monoid(..), (<>)) import Data.Monoid.Textual (TextualMonoid, toString) import Text.Parser.Combinators (choice) -import Control.Enumerable (share)-import Test.Feat (Enumerable(..), Enumerate, c0, c1, c2, c3, uniform)-import Test.Feat.Enumerate (pay)-import Test.Feat.Modifiers (Nat(..))-import Test.Tasty.QuickCheck (Arbitrary(..), Gen, Positive(..), Property, testProperty, (===), (==>), (.&&.),-                              forAll, mapSize, oneof, resize, sized, whenFail)+import Test.Tasty.QuickCheck (Arbitrary(..), Gen, NonNegative(..), Property, testProperty, (===), (==>), (.&&.),+                              elements, forAll, mapSize, oneof, resize, sized, whenFail) import Data.Word (Word8)  import qualified Rank2@@ -52,13 +48,13 @@ type ACBC = Rank2.Product ArithmeticComparisonsBoolean (Conditionals.Conditionals BooleanTree                                                         (ConditionalTree ArithmeticTree)) -data ArithmeticTree = Number (Nat Int)-                   | Add ArithmeticTree ArithmeticTree-                   | Multiply ArithmeticTree ArithmeticTree-                   | Negate ArithmeticTree-                   | Subtract ArithmeticTree ArithmeticTree-                   | Divide ArithmeticTree ArithmeticTree-                   deriving Eq+data ArithmeticTree = Number (NonNegative Int)+                    | Add ArithmeticTree ArithmeticTree+                    | Multiply ArithmeticTree ArithmeticTree+                    | Negate ArithmeticTree+                    | Subtract ArithmeticTree ArithmeticTree+                    | Divide ArithmeticTree ArithmeticTree+                    deriving Eq  data BooleanTree = BooleanConstant Bool                  | Comparison ArithmeticTree Relation ArithmeticTree@@ -79,7 +75,7 @@    showsPrec p (Negate e) rest | p < 1 = "- " <> showsPrec 1 e rest    showsPrec p (Multiply l r) rest | p < 2 = showsPrec 1 l (" * " <> showsPrec 2 r rest)    showsPrec p (Divide l r) rest | p < 2 = showsPrec 1 l (" / " <> showsPrec 2 r rest)-   showsPrec _ (Number (Nat n)) rest = shows n rest+   showsPrec _ (Number (NonNegative n)) rest = shows n rest    showsPrec p e rest = "(" <> showsPrec 0 e (")" <> rest)  instance Show BooleanTree where@@ -98,7 +94,7 @@    show (Relation rel) = rel  instance Arithmetic.ArithmeticDomain ArithmeticTree where-   number = Number . Nat+   number = Number . NonNegative    add = Add    multiply = Multiply    negate = Negate@@ -123,24 +119,34 @@    ifThenElse = If  instance Arbitrary ArithmeticTree where-   arbitrary = sized uniform-instance Arbitrary BooleanTree where-   arbitrary = sized uniform-instance Arbitrary (ConditionalTree ArithmeticTree) where-   arbitrary = sized uniform--instance Enumerable ArithmeticTree where-   enumerate = share (choice $ pay <$> [c1 (Number . (Nat . fromIntegral . nat :: Nat Integer -> Nat Int)), -                                        c2 Add, c2 Multiply, c1 Negate, c2 Subtract, c2 Divide])--instance Enumerable BooleanTree where-   enumerate = share $ choice $ pay <$> [c1 BooleanConstant, c3 Comparison, c2 And, c2 Or]+   arbitrary = sized tree+     where tree n | n < 1 = Number <$> arbitrary+                  | otherwise = oneof [Number <$> arbitrary,+                                       Negate <$> tree (n - 1),+                                       liftA2 Add branch branch,+                                       liftA2 Multiply branch branch,+                                       liftA2 Subtract branch branch,+                                       liftA2 Divide branch branch]+             where branch = tree (n `div` 2) -instance Enumerable a => Enumerable (ConditionalTree a) where-   enumerate = share (pay $ c3 $ \test true false-> If test (Unconditional true) (Unconditional false))+instance Arbitrary BooleanTree where+   arbitrary = sized tree+     where tree n | n < 1 = BooleanConstant <$> arbitrary+                  | otherwise = oneof [BooleanConstant <$> resize (n - 1) arbitrary,+                                       Not <$> tree (n - 1),+                                       liftA3 Comparison arbitrary' (elements relations) arbitrary',+                                       liftA2 And branch branch,+                                       liftA2 Or branch branch]+             where branch = tree (n `div` 2)+                   relations = Relation <$> ["<", ">", "==", "<=", ">="]+                   arbitrary' = resize (n `div` 2) arbitrary -instance Enumerable Relation where-   enumerate = share (choice $ pay . pure . Relation <$> ["<", "<=", "==", ">=", ">"])+instance Arbitrary (ConditionalTree ArithmeticTree) where+   arbitrary = sized tree+     where tree n = oneof [--Unconditional <$> resize (n - 1) arbitrary,+                           liftA3 If (resize (n `div` 3) arbitrary)+                                     (Unconditional <$> resize(n `div` 3) arbitrary)+                                     (Unconditional <$> resize(n `div` 3) arbitrary)]  uniqueParse :: (Ord s, TextualMonoid s, Show r, Rank2.Apply g, Rank2.Traversable g, Rank2.Distributive g) =>                Grammar g Parser s -> (forall f. g f -> f r) -> s -> Either String r