grammatical-parsers 0.4.1.2 → 0.5

raw patch · 35 files changed

+2132/−1440 lines, 35 filesdep +attoparsecdep +bytestringdep +input-parsersdep ~containersdep ~monoid-subclassesdep ~rank2classesnew-component:exe:boolean-transformationsPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, bytestring, input-parsers

Dependency ranges changed: containers, monoid-subclasses, rank2classes

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +3/−3
• examples/Arithmetic.hs +6/−5
• examples/Boolean.hs +7/−4
• examples/BooleanTransformations.hs +234/−0
• examples/Combined.hs +7/−4
• examples/Comparisons.hs +1/−3
• examples/Conditionals.hs +3/−3
• examples/Lambda.hs +1/−3
• examples/Main.hs +21/−16
• examples/Utilities.hs +6/−9
• grammatical-parsers.cabal +26/−11
• src/Text/Grampa.hs +23/−35
• src/Text/Grampa/Class.hs +70/−141
• src/Text/Grampa/Combinators.hs +16/−11
• src/Text/Grampa/ContextFree/Continued.hs +89/−97
• src/Text/Grampa/ContextFree/Continued/Measured.hs +97/−100
• src/Text/Grampa/ContextFree/LeftRecursive.hs +286/−261
• src/Text/Grampa/ContextFree/LeftRecursive/Transformer.hs +26/−0
• src/Text/Grampa/ContextFree/Memoizing.hs +102/−87
• src/Text/Grampa/ContextFree/Parallel.hs +89/−88
• src/Text/Grampa/ContextFree/SortedMemoizing.hs +106/−87
• src/Text/Grampa/ContextFree/SortedMemoizing/Transformer.hs +395/−0
• src/Text/Grampa/Internal.hs +50/−23
• src/Text/Grampa/PEG/Backtrack.hs +60/−62
• src/Text/Grampa/PEG/Backtrack/Measured.hs +71/−67
• src/Text/Grampa/PEG/Continued.hs +90/−102
• src/Text/Grampa/PEG/Continued/Measured.hs +100/−106
• src/Text/Grampa/PEG/Packrat.hs +83/−76
• test/Benchmark.hs +2/−1
• test/Doctest.hs +4/−1
• test/README.lhs +3/−3
• test/Test.hs +27/−20
• test/Test/Ambiguous.hs +0/−2
• test/Test/Examples.hs +17/−9

@@ -1,3 +1,14 @@+Version 0.5+---------------+* Replaced `MonoidParsing` by `InputParsing`+* Moved the `InputParsing` and `InputCharParser` classes into the `input-parsers` package+* Added the `Expected` data type to eliminate the `Show` constraint on `string`+* Fixed the signature of `scan` and `scanChars`+* Deprecated `endOfInput` and `satisfyChar`+* Replaced `Lexical g` with `LexicalParsing m`+* Added modules `SortedMemoizing.Transformer` and `LeftRecursive.Transformer`+* Added the `getAmbiguous` destructor+ Version 0.4.1.2 --------------- * Fixed the doctests using cabal-doctest

@@ -89,9 +89,9 @@ -- >>> parseComplete grammar "1+2*3" -- Arithmetic{ --   sum=Compose (Right [7]),---   product=Compose (Left (ParseFailure 1 ["endOfInput"])),---   factor=Compose (Left (ParseFailure 1 ["endOfInput"])),---   number=Compose (Left (ParseFailure 1 ["endOfInput"]))}+--   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"]))} -- >>> parsePrefix grammar "1+2*3 apples" -- Arithmetic{ --   sum=Compose (Compose (Right [("+2*3 apples",1),("*3 apples",3),(" apples",7)])),

@@ -88,12 +88,13 @@                   <*> f (factor a)                   <*> f (primary a) -instance Lexical (Arithmetic e)+instance TokenParsing (Parser (Arithmetic e) String) where+   token = lexicalToken+instance LexicalParsing (Parser (Arithmetic e) String) -arithmetic :: (Lexical g, LexicalConstraint Parser g String, ArithmeticDomain e) =>-              GrammarBuilder (Arithmetic e) g Parser String+arithmetic :: (LexicalParsing (Parser g String), ArithmeticDomain e) => GrammarBuilder (Arithmetic e) g Parser String arithmetic Arithmetic{..} = Arithmetic{-   expr= sum,+   expr= lexicalWhiteSpace *> sum,    sum= product          <|> symbol "-" *> (negate <$> product)          <|> add <$> sum <* symbol "+" <*> product@@ -107,4 +108,4 @@  main :: IO () main = getContents >>=-       print . (getCompose . expr . parseComplete (fixGrammar arithmetic) :: String -> ParseResults [Int])+       print . (getCompose . expr . parseComplete (fixGrammar arithmetic) :: String -> ParseResults String [Int])

@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, RecordWildCards, ScopedTypeVariables,-             TypeFamilies, TemplateHaskell #-}+             TypeFamilies, TemplateHaskell, UndecidableInstances #-} module Boolean where  import Control.Applicative@@ -43,13 +43,16 @@       factor :: f e}    deriving Show -instance Lexical (Boolean e)+instance CharParsing (p (Boolean e) String) => TokenParsing (p (Boolean e) String) +instance (DeterministicParsing (p (Boolean e) String),+          InputCharParsing (p (Boolean e) String), ParserInput (p (Boolean e) String) ~ String) =>+         LexicalParsing (p (Boolean e) String)+ $(Rank2.TH.deriveAll ''Boolean)  boolean :: forall e p (g :: (* -> *) -> *).-           (Lexical g, LexicalConstraint p g String,-            BooleanDomain e, TokenParsing (p g String), MonoidParsing (p g)) =>+           (BooleanDomain e, LexicalParsing (p g String), ParserInput (p g String) ~ String) =>            p g String e -> Boolean e (p g String) -> Boolean e (p g String) boolean p Boolean{..} = Boolean{    expr= term

@@ -0,0 +1,234 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, RankNTypes, RecordWildCards,+             StandaloneDeriving, UndecidableInstances #-}+module Main where++import Control.Applicative ((<|>), empty)+import Control.Arrow (first)+import Control.Monad (guard, join)+import Data.Char (isSpace)+import Data.List (isPrefixOf)+import Data.Functor.Compose (Compose(..))+import Data.Functor.Identity (Identity(..))+import Data.Maybe (mapMaybe)+import System.Environment (getArgs)+import Text.Parser.Token (TokenParsing(..), symbol)+import qualified Text.Grampa+import Text.Grampa (TokenParsing(someSpace), LexicalParsing(lexicalComment, lexicalWhiteSpace, someLexicalSpace),+                    GrammarBuilder, ParseResults,+                    fixGrammar, parseComplete,+                    char, identifier, keyword, takeCharsWhile)+import Text.Grampa.ContextFree.LeftRecursive.Transformer (ParserT, lift, tmap)+import qualified Boolean+import Boolean(Boolean(..))++-- |+-- >>> simplifiedSource "True && [comment] x"+-- "[comment] x"+-- >>> simplifiedSource "False || [comment1] (True || [comment2] x)"+-- "[comment1] True "+-- >>> simplifiedSource "False || [^ trailing comment] [leading comment] (True || [comment2] x)"+-- "[leading comment] True "+-- >>> simplifiedSource "False || [^ trailing comment] [leading comment] (True [operator leading] || [comment2] x)"+-- "[leading comment] True "+-- >>> simplifiedSource "([^1][1] True [^2][2] && [^3][3] x [^4][4])[^5][5] || [^6][6] False [^7][7]"+-- "[3] x [^4][^5]"++type Parser = ParserT ((,) [Ignorables])++data AST f = And (f (AST f)) (f (AST f))+           | Or (f (AST f)) (f (AST f))+           | Not (f (AST f))+           | Literal Bool+           | Variable String++deriving instance (Show (f (AST f)), Show (f Bool), Show (f String)) => Show (AST f)++instance Boolean.BooleanDomain (ParsedWrap (AST ParsedWrap)) where+   and = binary And+   or = binary Or+   not = bare . Not+   true = bare (Literal True)+   false = bare (Literal False)++binary :: (ParsedWrap (AST ParsedWrap) -> ParsedWrap (AST ParsedWrap) -> AST ParsedWrap)+       -> ParsedWrap (AST ParsedWrap) -> ParsedWrap (AST ParsedWrap) -> ParsedWrap (AST ParsedWrap)+binary f a b = bare (f a b)++type ParsedWrap = (,) ParsedIgnorables+type NodeWrap = (,) AttachedIgnorables+data AttachedIgnorables = Attached Ignorables AttachedIgnorables Ignorables+                        | Blank+                        | AttachedToOperator Ignorables Ignorables+                        | Parenthesized Ignorables AttachedIgnorables Ignorables+                        deriving Show+data ParsedIgnorables = Trailing Ignorables+                      | OperatorTrailing [Ignorables]+                      | ParenthesesTrailing Ignorables ParsedIgnorables Ignorables+                      deriving Show+type Ignorables = [Either WhiteSpace Comment]+newtype Comment    = Comment{getComment :: String} deriving Show+newtype WhiteSpace = WhiteSpace String deriving Show++type Grammar = Boolean.Boolean (ParsedWrap (AST ParsedWrap))++main :: IO ()+main = do args <- concat <$> getArgs+          let tree = parse args+          print tree+          case tree+             of Right [parsed] -> do let rearranged = completeRearranged mempty parsed+                                     print rearranged+                                     putStrLn (showSource $ simplified rearranged)+                other -> error (show other)++parse :: String -> ParseResults String [ParsedWrap (AST ParsedWrap)]+parse = getCompose . fmap snd . getCompose . Boolean.expr . parseComplete (fixGrammar grammar)++simplifiedSource :: String -> String+simplifiedSource input = case (parse input)+                         of Right [parsed] -> showSource (simplified $ completeRearranged mempty parsed)+                            other -> error (show other)++class ShowSource a where+   showSource :: a -> String+   showsSourcePrec :: Int -> a -> String -> String+   showSource a = showsSourcePrec 0 a mempty++instance ShowSource (NodeWrap (AST NodeWrap)) where+   showsSourcePrec prec (Attached lead Blank follow, node) rest =+      whiteString lead <> showsSourcePrec prec node (whiteString follow <> rest)+   showsSourcePrec prec (Parenthesized lead ws follow, node) rest =+      whiteString lead <> showsSourcePrec 0 (ws, node) (whiteString follow <> rest)++instance ShowSource (AST NodeWrap) where+   showsSourcePrec prec (Or left right) rest+      | prec < 1 = showsSourcePrec 1 left ("||" <> showsSourcePrec 0 right rest)+   showsSourcePrec prec (And left right) rest+      | prec < 2 = showsSourcePrec 2 left ("&&" <> showsSourcePrec 1 right rest)+   showsSourcePrec prec (Not expr) rest+      | prec < 3 = "not" <> showsSourcePrec 2 expr rest+   showsSourcePrec _ (Literal True) rest = "True" <> rest+   showsSourcePrec _ (Literal False) rest = "False" <> rest+   showsSourcePrec _ (Variable name) rest = name <> rest+   showsSourcePrec _ node rest =   "(" <> showsSourcePrec 0 node (")" <> rest)++completeRearranged :: Ignorables -> ParsedWrap (AST ParsedWrap) -> NodeWrap (AST NodeWrap)+completeRearranged ws node+   | ((ws', node'), trailing) <- rearranged ws node = (embed [] ws' trailing, node')++rearranged :: Ignorables -> ParsedWrap (AST ParsedWrap) -> (NodeWrap (AST NodeWrap), Ignorables)+rearranged leftover (Trailing follow, node)+   | (follow', lead') <- splitDirections follow, (lead'', node', follow'') <- rearrangedChildren [] node =+        ((Attached (leftover <> lead'') Blank (follow'' <> follow'), node'), lead')+rearranged leftover (OperatorTrailing [[], follow], node)+   | (follow', lead') <- splitDirections follow,+     (lead'', node', follow'') <- rearrangedChildren [[], lead'] node =+        ((Attached leftover (AttachedToOperator lead'' follow') [], node'), follow'')+rearranged leftover (ParenthesesTrailing lead ws follow, node)+   | (follow', lead') <- splitDirections follow, (ws', node') <- completeRearranged lead (ws, node) =+        ((Parenthesized leftover ws' follow', node'), lead')++embed leading Blank trailing = Attached leading Blank trailing+embed leading (Attached lead inside follow) trailing = embed (leading <> lead) inside (follow <> trailing)+embed leading (AttachedToOperator lead follow) trailing = AttachedToOperator (leading <> lead) (follow <> trailing)+embed leading (Parenthesized lead inside follow) trailing = Parenthesized (leading <> lead) inside (follow <> trailing)++rearrangedChildren :: [Ignorables] -> AST ParsedWrap -> (Ignorables, AST NodeWrap, Ignorables)+rearrangedChildren [left, right] (And a b)+   | (a', follow1) <- rearranged left a,+     (b', follow2) <- rearranged right b = (follow1, And a' b', follow2)+rearrangedChildren [left, right] (Or a b)+   | (a', follow1) <- rearranged left a,+     (b', follow2) <- rearranged right b = (follow1, Or a' b', follow2)+rearrangedChildren [leftover] (Not a)+   | (a', follow) <- rearranged leftover a = ([], Not a', follow)+rearrangedChildren [] (Literal a) = ([], Literal a, [])+rearrangedChildren [] (Variable name) = ([], Variable name, [])++-- | Separates the whitespace and comments that refer to the preceding construct.+splitDirections :: Ignorables -> (Ignorables, Ignorables)+splitDirections = span (either (const True) (isPrefixOf "^" . getComment))++-- | Simplifies the given expression according to the laws of Boolean algebra.+simplified :: NodeWrap (AST NodeWrap) -> NodeWrap (AST NodeWrap)+simplified e@(_, Literal{}) = e+simplified e@(_, Variable{}) = e+simplified (a, Not e) = case simplified e+                        of (b, Literal True) -> (raise a b, Literal False)+                           (b, Literal False) -> (raise a b, Literal True)+                           e' -> (a, Not e')+simplified (a, And l r) = case (simplified l, simplified r)+                          of ((b, Literal False), _) -> (raise a b, Literal False)+                             ((b, Literal True), (c, r')) -> (raise a c, r')+                             (_, (b, Literal False)) -> (raise a b, Literal False)+                             ((b, l'), (c, Literal True)) -> (raise a b, l')+                             (l', r') -> (a, And l' r')+simplified (a, Or l r) =  case (simplified l, simplified r)+                          of ((b, Literal False), (c, r')) -> (raise a c, r')+                             ((b, Literal True), _) -> (raise a b, Literal True)+                             ((b, l'), (c, Literal False)) -> (raise a b, l')+                             (_, (b, Literal True)) -> (raise a b, Literal True)+                             (l', r') -> (a, Or l' r')++raise :: AttachedIgnorables -> AttachedIgnorables -> AttachedIgnorables+raise Blank arg = arg+raise op Blank = op+raise AttachedToOperator{} arg = arg+raise (Parenthesized opl op opr) arg = Parenthesized opl (raise op arg) opr+raise (Attached opl inside opr) (Parenthesized l arg r) =+   Parenthesized (comments opl <> l) (raise inside arg) (r <> comments opr)+-- raise (AttachedToOperator opl opr) (Parenthesized l arg r) = Parenthesized (comments opl <> l) arg (r <> comments opr)+-- raise (AttachedToOperator opl opr) (Attached argl inside argr) =+--    Attached (comments opl <> argl) inside (argr <> comments opr)++comments :: Ignorables -> Ignorables+comments = mapMaybe (either (const Nothing) (Just . Right))++whiteString :: Ignorables -> String+whiteString (Left (WhiteSpace ws) : rest) = ws <> whiteString rest+whiteString (Right (Comment c) : rest) = "[" <> c <> "]" <> whiteString rest+whiteString [] = ""++grammar :: GrammarBuilder Grammar Grammar Parser String+grammar Boolean{..} = Boolean{+   expr= term+         <|> operatorTrailingWhiteSpace [mempty] (Boolean.or <$> term <* symbol "||" <*> expr),+   term= factor+         <|> operatorTrailingWhiteSpace [mempty] (Boolean.and <$> factor <* symbol "&&" <*> term),+   factor= trailingWhiteSpace (keyword "True" *> pure Boolean.true+                                 <|> keyword "False" *> pure Boolean.false+                                 <|> bare . Variable <$> identifier)+           <|> operatorTrailingWhiteSpace [] (keyword "not" *> (Boolean.not <$> factor))+           <|> parenthesizedWhiteSpace (symbol "(" *> expr <* symbol ")")}++bare :: a -> ParsedWrap a+bare a = (Trailing [], a)++operatorTrailingWhiteSpace :: [Ignorables] -> Parser Grammar String (ParsedWrap (AST ParsedWrap))+                           -> Parser Grammar String (ParsedWrap (AST ParsedWrap))+trailingWhiteSpace, parenthesizedWhiteSpace+   :: Parser Grammar String (ParsedWrap (AST ParsedWrap)) -> Parser Grammar String (ParsedWrap (AST ParsedWrap))+trailingWhiteSpace = tmap store+   where store ([ws], (Trailing ws', a)) = (mempty, (Trailing $ ws' <> ws, a))+operatorTrailingWhiteSpace prefix = tmap store+   where store (wss, (Trailing [], a)) = (mempty, (OperatorTrailing (prefix <> wss), a))+parenthesizedWhiteSpace = tmap store+   where store ([ws,ws'], (aws, a)) = ([], (ParenthesesTrailing ws aws ws', a))++instance {-# OVERLAPS #-} TokenParsing (Parser Grammar String) where+   someSpace = someLexicalSpace+   token p = p <* lexicalWhiteSpace++instance {-# OVERLAPS #-} LexicalParsing (Parser Grammar String) where+   lexicalWhiteSpace = tmap (first (\ws-> [concat ws])) $+                       do ws <- takeCharsWhile isSpace+                          lift ([[Left $ WhiteSpace ws]], ())+                          (lexicalComment *> lexicalWhiteSpace <|> pure ())+   lexicalComment = do char '['+                       comment <- takeCharsWhile (/= ']')+                       char ']'+                       lift ([[Right $ Comment comment]], ())+   identifierToken p = do ident <- p+                          guard (ident /= "True" && ident /= "False")+                          lexicalWhiteSpace+                          pure ident

@@ -1,4 +1,6 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RecordWildCards,+             TemplateHaskell, UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}  module Combined where @@ -7,7 +9,7 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Rank2.TH-import Text.Grampa (Lexical, LexicalConstraint, GrammarBuilder)+import Text.Grampa (TokenParsing, LexicalParsing, GrammarBuilder) import Text.Grampa.ContextFree.LeftRecursive (Parser) import qualified Arithmetic import qualified Boolean@@ -117,7 +119,8 @@                            (", conditionalGrammar=" ++ showsPrec prec (conditionalGrammar g)                            (", lambdaGrammar=" ++ showsPrec prec (lambdaGrammar g) ("}" ++ rest)))))) -instance Lexical Expression+instance TokenParsing (Parser Expression String)+instance LexicalParsing (Parser Expression String)  $(Rank2.TH.deriveAll ''Expression) @@ -188,7 +191,7 @@                   <*> Rank2.traverse f (lambdaGrammar g) -} -expression :: (Lexical g, LexicalConstraint Parser g String) => GrammarBuilder Expression g Parser String+expression :: (LexicalParsing (Parser g String)) => GrammarBuilder Expression g Parser String expression Expression{..} =    let combinedExpr = Arithmetic.expr arithmeticGrammar                       <|> Boolean.expr booleanGrammar

@@ -62,9 +62,7 @@                   <$> f (test g)                   <*> f (term g) -comparisons :: (Lexical g, LexicalConstraint p g String,-                ComparisonDomain c e, TokenParsing (p g String), MonoidParsing (p g)) =>-               GrammarBuilder (Comparisons c e) g p String+comparisons :: (ComparisonDomain c e, LexicalParsing (p g String)) => GrammarBuilder (Comparisons c e) g p String comparisons Comparisons{..} =    Comparisons{       test= lessThan <$> term <* symbol "<" <*> term

@@ -29,12 +29,12 @@                            (", test= " ++ showsPrec prec (test a)                             (", term= " ++ showsPrec prec (term a) ("}" ++ rest))) -instance Lexical (Conditionals t e) where-   type LexicalConstraint p (Conditionals t e) s = (p ~ Parser, s ~ String)+instance TokenParsing (Parser (Conditionals t e) String)+instance LexicalParsing (Parser (Conditionals t e) String)  $(Rank2.TH.deriveAll ''Conditionals) -conditionals :: (ConditionalDomain t e, Lexical g, LexicalConstraint Parser g String)+conditionals :: (ConditionalDomain t e, LexicalParsing (Parser g String))              => GrammarBuilder (Conditionals t e) g Parser String conditionals Conditionals{..} =    Conditionals{expr= ifThenElse <$> (keyword "if" *> test) <*> (keyword "then" *> term) <*> (keyword "else" *> term),

@@ -8,7 +8,6 @@ import Data.Monoid ((<>)) import Text.Parser.Token (symbol, whiteSpace) -import qualified Rank2 import qualified Rank2.TH  import Text.Grampa@@ -96,8 +95,7 @@  $(Rank2.TH.deriveAll ''Lambda) -lambdaCalculus :: (Lexical g, LexicalConstraint Parser g String, LambdaDomain e)-               => GrammarBuilder (Lambda e) g Parser String+lambdaCalculus :: (LexicalParsing (Parser g String), LambdaDomain e) => GrammarBuilder (Lambda e) g Parser String lambdaCalculus Lambda{..} = Lambda{    expr= abstraction,    abstraction= lambda <$> (symbol "\\" *> varName <* symbol "->") <*> abstraction

@@ -1,11 +1,11 @@-{-# LANGUAGE FlexibleInstances, RankNTypes, KindSignatures, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, KindSignatures, UndecidableInstances #-} module Main (main, arithmetic, comparisons, boolean, conditionals) where  import System.Environment (getArgs) import Data.Functor.Compose (Compose(..)) import Data.Map (Map) import qualified Rank2-import Text.Grampa (Lexical, LexicalConstraint, GrammarBuilder, ParseResults, fixGrammar, parseComplete)+import Text.Grampa (TokenParsing, LexicalParsing, GrammarBuilder, ParseResults, fixGrammar, parseComplete) import Text.Grampa.ContextFree.LeftRecursive (Parser) import Arithmetic (Arithmetic, arithmetic) import qualified Arithmetic@@ -24,35 +24,40 @@           -- let a = fixGrammar (Arithmetic.arithmetic (production id Arithmetic.expr a))           -- let a = fixGrammar (Arithmetic.arithmetic (recursive $ Arithmetic.expr a))           print (getCompose . Lambda.expr $ parseComplete (fixGrammar Lambda.lambdaCalculus) args-                 :: ParseResults [Lambda.LambdaInitial])-          -- print (((\f-> f (mempty :: Map String Int) [1 :: Int]) <$>) <$> parse (fixGrammar Lambda.lambdaCalculus) Lambda.expr args :: ParseResults Int)-          print (getCompose . Arithmetic.expr $ parseComplete (fixGrammar arithmetic) args :: ParseResults [Int])+                 :: ParseResults String [Lambda.LambdaInitial])+          -- print (((\f-> f (mempty :: Map String Int) [1 :: Int]) <$>) <$> parse (fixGrammar Lambda.lambdaCalculus) Lambda.expr args :: ParseResults String Int)+          print (getCompose . Arithmetic.expr $ parseComplete (fixGrammar arithmetic) args :: ParseResults String [Int])           print (getCompose . Comparisons.test . Rank2.snd $ parseComplete (fixGrammar comparisons) args-                 :: ParseResults [Bool])+                 :: ParseResults String [Bool])           print (getCompose . Boolean.expr . Rank2.snd $-                 parseComplete (fixGrammar boolean) args :: ParseResults [Bool])+                 parseComplete (fixGrammar boolean) args :: ParseResults String [Bool])           print (getCompose . Conditionals.expr . Rank2.snd $ parseComplete (fixGrammar conditionals) args-                 :: ParseResults [Int])+                 :: ParseResults String [Int])           print (((\f-> f (mempty :: Map String Combined.Tagged)) <$>)                  <$> (getCompose . Combined.expr $ parseComplete (fixGrammar Combined.expression) args)-                 :: ParseResults [Combined.Tagged])+                 :: ParseResults String [Combined.Tagged]) -comparisons :: (Lexical g, LexicalConstraint Parser g String) => GrammarBuilder ArithmeticComparisons g Parser String+comparisons :: (LexicalParsing (Parser g String)) => GrammarBuilder ArithmeticComparisons g Parser String comparisons (Rank2.Pair a c) =    Rank2.Pair (Arithmetic.arithmetic a) (Comparisons.comparisons c{Comparisons.term= Arithmetic.expr a}) -boolean :: (Lexical g, LexicalConstraint Parser g String) => GrammarBuilder ArithmeticComparisonsBoolean g Parser String+boolean :: (LexicalParsing (Parser g String)) => GrammarBuilder ArithmeticComparisonsBoolean g Parser String boolean (Rank2.Pair ac b) = Rank2.Pair (comparisons ac) (Boolean.boolean (Comparisons.test $ Rank2.snd ac) b) -conditionals :: (Lexical g, LexicalConstraint Parser g String) => GrammarBuilder ACBC g Parser String+conditionals :: (LexicalParsing (Parser g String)) => GrammarBuilder ACBC g Parser String conditionals (Rank2.Pair acb c) =    Rank2.Pair       (boolean acb)       (Conditionals.conditionals c{Conditionals.test= Boolean.expr (Rank2.snd acb),                                    Conditionals.term= Arithmetic.expr (Rank2.fst $ Rank2.fst acb)}) -instance Lexical ArithmeticComparisons-instance Lexical ArithmeticComparisonsBoolean-instance Lexical ACBC-instance Lexical (Lambda.Lambda Lambda.LambdaInitial)+instance TokenParsing (Parser ArithmeticComparisons String)+instance TokenParsing (Parser ArithmeticComparisonsBoolean String)+instance TokenParsing (Parser ACBC String)+instance TokenParsing (Parser (Lambda.Lambda Lambda.LambdaInitial) String)++instance LexicalParsing (Parser ArithmeticComparisons String)+instance LexicalParsing (Parser ArithmeticComparisonsBoolean String)+instance LexicalParsing (Parser ACBC String)+instance LexicalParsing (Parser (Lambda.Lambda Lambda.LambdaInitial) String) 

@@ -1,23 +1,20 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, RankNTypes, ScopedTypeVariables #-} module Utilities where -import Data.Char (isAlphaNum) import Data.Functor.Compose (Compose(..))-import Data.List (intercalate) import Data.Monoid ((<>))-import Data.Monoid.Factorial (FactorialMonoid)-import Data.Monoid.Textual (TextualMonoid)+import Data.Monoid.Textual (TextualMonoid, toString)  import Text.Grampa import Text.Grampa.ContextFree.LeftRecursive import qualified Rank2 -parseUnique :: (FactorialMonoid s, Rank2.Traversable g, Rank2.Distributive g, Rank2.Apply g) =>+parseUnique :: (Ord s, TextualMonoid s, Rank2.Traversable g, Rank2.Distributive g, Rank2.Apply g) =>                Grammar g Parser s -> (forall f. g f -> f r) -> s -> r-parseUnique g prod s = case getCompose (prod $ parseComplete g s)-                       of Left (ParseFailure pos expected) -> error ("Parse failure at " ++ show pos-                                                                     ++ ", expected " ++ intercalate " or " expected)-                          Right [x] -> x+parseUnique g prod s =+   case getCompose (prod $ parseComplete g s)+   of Left failure -> error ("Parse failure: " ++ toString (error "non-character") (failureDescription s failure 3))+      Right [x] -> x  infixJoin :: String -> String -> String -> String infixJoin op a b = "(" <> a <> op <> b <> ")"

@@ -1,5 +1,5 @@ name:                grammatical-parsers-version:             0.4.1.2+version:             0.5 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@@ -32,21 +32,26 @@                        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.LeftRecursive+                       Text.Grampa.ContextFree.Memoizing,+                       Text.Grampa.ContextFree.SortedMemoizing,+                       Text.Grampa.ContextFree.SortedMemoizing.Transformer,+                       Text.Grampa.ContextFree.LeftRecursive,+                       Text.Grampa.ContextFree.LeftRecursive.Transformer   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.Continued.Measured   default-language:    Haskell2010-  -- other-modules:   ghc-options:         -Wall   build-depends:       base >=4.9 && <5,+                       bytestring >= 0.10 && < 0.11,                        containers >= 0.4 && < 0.7,                        transformers >= 0.5 && < 0.6,-                       monoid-subclasses >=0.4 && <1.1,+                       monoid-subclasses >=1.0 && <1.1,                        parsers < 0.13,-                       rank2classes >= 1.0.2 && < 1.4+                       input-parsers < 0.2,+                       attoparsec >= 0.13 && < 0.14,+                       rank2classes >= 1.0.2 && < 1.5  executable             arithmetic   hs-source-dirs:      examples@@ -55,16 +60,26 @@   default-language:    Haskell2010   build-depends:       base >=4.9 && <5, containers >= 0.5.7.0 && < 0.7,                        parsers < 0.13,-                       rank2classes >= 1.0.2 && < 1.4, grammatical-parsers,-                       monoid-subclasses >=0.4 && <1.1+                       rank2classes >= 1.0.2 && < 1.5, grammatical-parsers,+                       monoid-subclasses >=1.0 && <1.1 +executable             boolean-transformations+  hs-source-dirs:      examples+  main-is:             BooleanTransformations.hs+  other-modules:       Boolean, Utilities+  default-language:    Haskell2010+  build-depends:       base >=4.9 && <5, containers >= 0.5.7.0 && < 0.7,+                       parsers < 0.13,+                       rank2classes >= 1.0.2 && < 1.5, grammatical-parsers,+                       monoid-subclasses >=1.0 && <1.1+ test-suite           quicktests   type:              exitcode-stdio-1.0   hs-source-dirs:    test, examples   x-uses-tf:         true   build-depends:     base >=4.9 && < 5, containers >= 0.5.7.0 && < 0.7,                      monoid-subclasses < 1.1, parsers < 0.13,-                     rank2classes >= 1.0.2 && < 1.4, grammatical-parsers,+                     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,                      tasty >= 0.7, tasty-quickcheck >= 0.7@@ -87,8 +102,8 @@   type:              exitcode-stdio-1.0   hs-source-dirs:    test, examples   ghc-options:       -O2 -Wall -rtsopts -main-is Benchmark.main-  Build-Depends:     base >=4.9 && < 5, rank2classes >= 1.0.2 && < 1.4, grammatical-parsers,-                     monoid-subclasses >=0.4 && <1.1, parsers < 0.13,+  Build-Depends:     base >=4.9 && < 5, rank2classes >= 1.0.2 && < 1.5, grammatical-parsers,+                     monoid-subclasses >=1.0 && <1.1, parsers < 0.13,                      criterion >= 1.0, deepseq >= 1.1, containers >= 0.5.7.0 && < 0.7, text >= 1.1   main-is:           Benchmark.hs   other-modules:     Main, Arithmetic, Boolean, Combined, Comparisons, Conditionals, Lambda, Utilities

@@ -3,29 +3,37 @@ {-# LANGUAGE FlexibleContexts, KindSignatures, OverloadedStrings, RankNTypes, ScopedTypeVariables #-} module Text.Grampa (    -- * Parsing methods-   MultiParsing(..),-   offsetContext, offsetLineAndColumn, positionOffset, failureDescription, simply,+   failureDescription, simply,    -- * Types-   Grammar, GrammarBuilder, ParseResults, ParseFailure(..), Ambiguous(..), Position,+   Grammar, GrammarBuilder, ParseResults, ParseFailure(..), Expected(..), Ambiguous(..), Position,    -- * Parser combinators and primitives-   GrammarParsing(..), MonoidParsing(..), AmbiguousParsing(..), Lexical(..),+   DeterministicParsing(..), AmbiguousParsing(..),+   InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),+   MultiParsing(..), GrammarParsing(..),+   TokenParsing(..), LexicalParsing(..),    module Text.Parser.Char,    module Text.Parser.Combinators,-   module Text.Parser.LookAhead)+   module Text.Parser.LookAhead,+   module Text.Grampa.Combinators) where -import Data.List (intersperse)+import Data.List (intersperse, nub, sort) import Data.Monoid ((<>))-import qualified Data.Monoid.Factorial as Factorial-import Data.Monoid.Factorial (FactorialMonoid)+import Data.Monoid.Textual (TextualMonoid) import Data.String (IsString(fromString)) import Text.Parser.Char (CharParsing(char, notChar, anyChar)) import Text.Parser.Combinators (Parsing((<?>), notFollowedBy, skipMany, skipSome, unexpected)) import Text.Parser.LookAhead (LookAheadParsing(lookAhead))+import Text.Parser.Token (TokenParsing(..))+import Text.Parser.Input.Position (Position)+import qualified Text.Parser.Input.Position as Position+import Text.Grampa.Combinators (concatMany, concatSome)  import qualified Rank2-import Text.Grampa.Class (Lexical(..), MultiParsing(..), GrammarParsing(..), MonoidParsing(..), AmbiguousParsing(..),-                          Ambiguous(..), ParseResults, ParseFailure(..), Position, positionOffset)+import Text.Grampa.Class (MultiParsing(..), GrammarParsing(..),+                          InputParsing(..), InputCharParsing(..),+                          ConsumedInputParsing(..), DeterministicParsing(..), LexicalParsing(..),+                          AmbiguousParsing(..), Ambiguous(..), ParseResults, ParseFailure(..), Expected(..))  -- | 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)@@ -44,10 +52,10 @@  -- | 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. (Eq s, IsString s, FactorialMonoid s) => s -> ParseFailure -> Int -> s+failureDescription :: forall s. (Ord s, TextualMonoid s) => s -> ParseFailure s -> Int -> s failureDescription input (ParseFailure pos expected) contextLineCount =-   offsetContext input pos contextLineCount-   <> "expected " <> oxfordComma (fromString <$> expected)+   Position.context input (Position.fromStart pos) contextLineCount+   <> "expected " <> oxfordComma (fromExpected <$> nub (sort expected))    where oxfordComma :: [s] -> s          oxfordComma [] = ""          oxfordComma [x] = x@@ -56,25 +64,5 @@          onLast _ [] = []          onLast f [x] = [f x]          onLast f (x:xs) = x : onLast f xs---- | Given the parser input, an offset within it, and desired number of context lines, returns a description of--- the offset position in English.-offsetContext :: (Eq s, IsString s, FactorialMonoid s) => s -> Int -> Int -> s-offsetContext input offset contextLineCount = -   foldMap (<> "\n") prevLines <> fromString (replicate column ' ') <> "^\n"-   <> "at line " <> fromString (show $ length allPrevLines) <> ", column " <> fromString (show $ column+1) <> "\n"-   where (allPrevLines, column) = offsetLineAndColumn input offset-         prevLines = reverse (take contextLineCount allPrevLines)---- | Given the full input and an offset within it, returns all the input lines up to and including the offset--- in reverse order, as well as the zero-based column number of the offset-offsetLineAndColumn :: (Eq s, IsString s, FactorialMonoid s) => s -> Int -> ([s], Int)-offsetLineAndColumn input pos = context [] pos (Factorial.split (== "\n") input)-  where context revLines restCount []-          | restCount > 0 = (["Error: the offset is beyond the input length"], -1)-          | otherwise = (revLines, restCount)-        context revLines restCount (next:rest)-          | restCount' < 0 = (next:revLines, restCount)-          | otherwise = context (next:revLines) restCount' rest-          where nextLength = Factorial.length next-                restCount' = restCount - nextLength - 1+         fromExpected (Expected s) = fromString s+         fromExpected (ExpectedInput s) = "string \"" <> s <> "\""

@@ -1,9 +1,13 @@-{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, DefaultSignatures, OverloadedStrings, RankNTypes,-             ScopedTypeVariables, TypeApplications, TypeFamilies, DeriveDataTypeable #-}-module Text.Grampa.Class (MultiParsing(..), GrammarParsing(..), AmbiguousParsing(..), MonoidParsing(..), Lexical(..),-                          ParseResults, ParseFailure(..), Ambiguous(..), Position, positionOffset, completeParser) where+{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor,+             FlexibleContexts, FlexibleInstances, OverloadedStrings, RankNTypes, ScopedTypeVariables, TypeApplications,+             TypeFamilies, TypeSynonymInstances, UndecidableInstances #-}+module Text.Grampa.Class (MultiParsing(..), GrammarParsing(..),+                          AmbiguousParsing(..), DeterministicParsing(..), InputParsing(..), InputCharParsing(..),+                          ConsumedInputParsing(..), LexicalParsing(..), TailsParsing(..),+                          ParseResults, ParseFailure(..), Expected(..),+                          Ambiguous(..), completeParser) where -import Control.Applicative (Alternative(empty), liftA2, (<|>))+import Control.Applicative (Alternative(empty), liftA2) import Data.Char (isAlphaNum, isLetter, isSpace) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))@@ -11,38 +15,33 @@ import Data.Data (Data) import Data.Typeable (Typeable) import Data.Monoid (Monoid(mempty, mappend))-import Data.Monoid.Cancellative (LeftReductiveMonoid) import qualified Data.Monoid.Null as Null import Data.Monoid.Null (MonoidNull)-import qualified Data.Monoid.Factorial as Factorial import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid) import Data.Semigroup (Semigroup((<>)))-import Text.Parser.Combinators (Parsing((<?>)), skipMany)-import Text.Parser.Char (CharParsing(char))-import GHC.Exts (Constraint)+import Text.Parser.Combinators (Parsing((<?>)))+import Text.Parser.Token (TokenParsing)+import Text.Parser.Deterministic (DeterministicParsing(..))+import Text.Parser.Input (ConsumedInputParsing(..), InputParsing(..), InputCharParsing(..))+import qualified Text.Parser.Char+import Data.Kind (Constraint)  import qualified Rank2 -type ParseResults = Either ParseFailure---- | A 'ParseFailure' contains the offset of the parse failure and the list of things expected at that offset.-data ParseFailure = ParseFailure Int [String] deriving (Eq, Show)+import Prelude hiding (takeWhile) --- | Opaque data type that represents an input position.-newtype Position s = Position{-  -- | The length of the input from the position to end.-  remainderLength :: Int}+type ParseResults s = Either (ParseFailure s) --- | Map the position into its offset from the beginning of the full input.-positionOffset :: FactorialMonoid s => s -> Position s -> Int-positionOffset wholeInput = (wholeLength -) . remainderLength-   where wholeLength = Factorial.length wholeInput-{-# INLINE positionOffset #-}+-- | 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, Show)+data Expected s = Expected String+                | ExpectedInput s+                deriving (Functor, Eq, Ord, Read, Show)  -- | An 'Ambiguous' parse result, produced by the 'ambiguous' combinator, contains a 'NonEmpty' list of -- alternative results.-newtype Ambiguous a = Ambiguous (NonEmpty a) deriving (Data, Eq, Ord, Show, Typeable)+newtype Ambiguous a = Ambiguous{getAmbiguous :: NonEmpty a} deriving (Data, Eq, Ord, Show, Typeable)  instance Show1 Ambiguous where    liftShowsPrec sp sl d (Ambiguous (h :| l)) t@@ -69,37 +68,43 @@    mempty = Ambiguous (mempty :| [])    Ambiguous xs `mappend` Ambiguous ys = Ambiguous (liftA2 mappend xs ys) -completeParser :: MonoidNull s => Compose ParseResults (Compose [] ((,) s)) r -> Compose ParseResults [] r+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 ["complete parse"])+   of [] -> Compose (Left $ ParseFailure 0 [Expected "complete parse"])       completeResults -> Compose (Right $ snd <$> completeResults)  -- | Choose one of the instances of this class to parse with.-class MultiParsing m where+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 GrammarConstraint m g = Rank2.Functor g    -- | Given a rank-2 record of parsers and input, produce a record of parses of the complete input.-   parseComplete :: (GrammarConstraint m g, FactorialMonoid s) => g (m g s) -> s -> g (ResultFunctor m)+   parseComplete :: (ParserInput m ~ s, GrammarConstraint m g, Eq s, FactorialMonoid s) =>+                    g m -> s -> g (ResultFunctor m)    -- | Given a rank-2 record of parsers and input, produce a record of prefix parses paired with the remaining input    -- suffix.-   parsePrefix :: (GrammarConstraint m g, FactorialMonoid s) =>-                  g (m g s) -> s -> g (Compose (ResultFunctor m) ((,) s))+   parsePrefix :: (ParserInput m ~ s, GrammarConstraint m g, Eq s, FactorialMonoid s) =>+                  g m -> s -> g (Compose (ResultFunctor m) ((,) s))  -- | Parsers that belong to this class can memoize the parse results to avoid exponential performance complexity. class MultiParsing m => GrammarParsing m where-   type GrammarFunctor m :: ((* -> *) -> *) -> * -> * -> *+   -- | The record of grammar productions associated with the parser+   type ParserGrammar m :: (* -> *) -> *+   -- | For internal use by 'notTerminal'+   type GrammarFunctor m :: * -> *+   -- | 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-   nonTerminal :: GrammarConstraint m g => (g (GrammarFunctor m g s) -> GrammarFunctor m g s a) -> m g s a+   nonTerminal :: (g ~ ParserGrammar m, GrammarConstraint m g) => (g (GrammarFunctor m) -> GrammarFunctor m a) -> m a    -- | Construct a grammar whose every production refers to itself.-   selfReferring :: (GrammarConstraint m g, Rank2.Distributive g) => g (m g s)+   selfReferring :: (g ~ ParserGrammar m, GrammarConstraint m g, Rank2.Distributive g) => g m    -- | Convert a self-referring grammar function to a grammar.-   fixGrammar :: forall g s. (GrammarConstraint m g, Rank2.Distributive g) => (g (m g s) -> g (m g s)) -> g (m g s)+   fixGrammar :: (g ~ ParserGrammar m, GrammarConstraint m g, Rank2.Distributive g) => (g m -> g m) -> g m    -- | Mark a parser that relies on primitive recursion to prevent an infinite loop in 'fixGrammar'.-   recursive :: m g s a -> m g s a+   recursive :: m a -> m a     selfReferring = Rank2.cotraverse nonTerminal id    {-# INLINE selfReferring #-}@@ -107,137 +112,61 @@    {-# INLINE fixGrammar #-}    recursive = id --- | Methods for parsing monoidal inputs-class MonoidParsing m where-   -- | A parser that fails on any input and succeeds at its end.-   endOfInput :: FactorialMonoid s => m s ()-   -- | Always sucessful parser that returns the remaining input without consuming it.-   getInput :: FactorialMonoid s => m s s-   -- | Retrieve the 'Position' the parser has reached in the input source.-   getSourcePos :: FactorialMonoid s => m s (Position s)--   -- | A parser that accepts any single input atom.-   anyToken :: FactorialMonoid s => m s s-   -- | A parser that accepts an input atom only if it satisfies the given predicate.-   satisfy :: FactorialMonoid s => (s -> Bool) -> m s s-   -- | Specialization of 'satisfy' on 'TextualMonoid' inputs, accepting and returning an input character only if it-   -- satisfies the given predicate.-   satisfyChar :: TextualMonoid s => (Char -> Bool) -> m s Char-   -- | Specialization of 'satisfy' on 'TextualMonoid' inputs, accepting an input character only if it satisfies the-   -- given predicate, and returning the input atom that represents the character. A faster version of @singleton <$>-   -- satisfyChar p@ and of @satisfy (fromMaybe False p . characterPrefix)@.-   satisfyCharInput :: TextualMonoid s => (Char -> Bool) -> m s s-   -- | A parser that succeeds exactly when satisfy doesn't, equivalent to-   -- 'Text.Parser.Combinators.notFollowedBy' @. satisfy@-   notSatisfy :: FactorialMonoid s => (s -> Bool) -> m s ()-   -- | A parser that succeeds exactly when satisfyChar doesn't, equivalent to-   -- 'Text.Parser.Combinators.notFollowedBy' @. satisfyChar@-   notSatisfyChar :: TextualMonoid s => (Char -> Bool) -> m s ()--   -- | A stateful scanner. The predicate modifies a state argument, and each transformed state is passed to successive-   -- invocations of the predicate on each token of the input until one returns 'Nothing' or the input ends.-   ---   -- This parser does not fail.  It will return an empty string if the predicate returns 'Nothing' on the first-   -- character.-   ---   -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers-   -- loop until a failure occurs.  Careless use will thus result in an infinite loop.-   scan :: FactorialMonoid t => s -> (s -> t -> Maybe s) -> m t t-   -- | Stateful scanner like `scanChars`, but specialized for 'TextualMonoid' inputs.-   scanChars :: TextualMonoid t => s -> (s -> Char -> Maybe s) -> m t t-   -- | A parser that consumes and returns the given prefix of the input.-   string :: (FactorialMonoid s, LeftReductiveMonoid s, Show s) => s -> m s s--   -- | A parser accepting the longest sequence of input atoms that match the given predicate; an optimized version of-   -- 'concatMany . satisfy'.-   ---   -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers-   -- loop until a failure occurs.  Careless use will thus result in an infinite loop.-   takeWhile :: FactorialMonoid s => (s -> Bool) -> m s s-   -- | A parser accepting the longest non-empty sequence of input atoms that match the given predicate; an optimized-   -- version of 'concatSome . satisfy'.-   takeWhile1 :: FactorialMonoid s => (s -> Bool) -> m s s-   -- | Specialization of 'takeWhile' on 'TextualMonoid' inputs, accepting the longest sequence of input characters that-   -- match the given predicate; an optimized version of 'fmap fromString  . many . satisfyChar'.-   ---   -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers-   -- loop until a failure occurs.  Careless use will thus result in an infinite loop.-   takeCharsWhile :: TextualMonoid s => (Char -> Bool) -> m s s-   -- | Specialization of 'takeWhile1' on 'TextualMonoid' inputs, accepting the longest sequence of input characters-   -- that match the given predicate; an optimized version of 'fmap fromString  . some . satisfyChar'.-   takeCharsWhile1 :: TextualMonoid s => (Char -> Bool) -> m s s-   -- | Zero or more argument occurrences like 'many', with concatenated monoidal results.-   concatMany :: Monoid a => m s a -> m s a--   default concatMany :: (Monoid a, Alternative (m s)) => m s a -> m s a-   concatMany p = go-      where go = mappend <$> p <*> go <|> pure mempty-   default getSourcePos :: (FactorialMonoid s, Functor (m s)) => m s (Position s)-   getSourcePos = Position . Factorial.length <$> getInput-   {-# INLINE concatMany #-}-   {-# INLINE getSourcePos #-}+class GrammarParsing m => TailsParsing m where+   -- | Parse the tails of the input together with memoized parse results+   parseTails :: GrammarConstraint m g => m r -> [(ParserInput m, g (GrammarFunctor m))] -> GrammarFunctor m r+   parseAllTails :: (GrammarConstraint m g, Rank2.Functor g) =>+                    g m -> [(ParserInput m, g (GrammarFunctor m))] -> [(ParserInput m, g (GrammarFunctor m))]+   parseAllTails _ [] = []+   parseAllTails final parsed@((s, _):_) = (s, gd):parsed+      where gd = Rank2.fmap (`parseTails` parsed) final  -- | Parsers that can produce alternative parses and collect them into an 'Ambiguous' node-class AmbiguousParsing m where+class Alternative m => AmbiguousParsing m where    -- | Collect all alternative parses of the same length into a 'NonEmpty' list of results.    ambiguous :: m a -> m (Ambiguous a) --- | If a grammar is 'Lexical', its parsers can instantiate the 'Text.Parser.Token.TokenParsing' class.-class Lexical (g :: (* -> *) -> *) where-   type LexicalConstraint (m :: ((* -> *) -> *) -> * -> * -> *) g s :: Constraint+-- | 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-   lexicalWhiteSpace :: LexicalConstraint m g s => m g s ()+   lexicalWhiteSpace :: m ()    -- | Consumes all whitespace and comments, failing if there are none-   someLexicalSpace :: LexicalConstraint m g s => m g s ()+   someLexicalSpace :: m ()    -- | Consumes a single comment, defaults to 'empty'-   lexicalComment :: LexicalConstraint m g s => m g s ()+   lexicalComment :: m ()    -- | Consumes a single semicolon and any trailing whitespace, returning the character |';'|. The method can be    -- overridden for automatic semicolon insertion, but if it succeeds on semicolon or white space input it must    -- consume it.-   lexicalSemicolon :: LexicalConstraint m g s => m g s Char+   lexicalSemicolon :: m Char    -- | Applies the argument parser and consumes the trailing 'lexicalWhitespace'-   lexicalToken :: LexicalConstraint m g s => m g s a -> m g s a+   lexicalToken :: m a -> m a    -- | Applies the argument parser, determines whether its result is a legal identifier, and consumes the trailing    -- 'lexicalWhitespace'-   identifierToken :: LexicalConstraint m g s => m g s s -> m g s s+   identifierToken :: m (ParserInput m) -> m (ParserInput m)    -- | Determines whether the given character can start an identifier token, allows only a letter or underscore by    -- default    isIdentifierStartChar :: Char -> Bool    -- | Determines whether the given character can be any part of an identifier token, also allows numbers    isIdentifierFollowChar :: Char -> Bool    -- | Parses a valid identifier and consumes the trailing 'lexicalWhitespace'-   identifier :: LexicalConstraint m g s => m g s s+   identifier :: m (ParserInput m)    -- | Parses the argument word whole, not followed by any identifier character, and consumes the trailing    -- 'lexicalWhitespace'-   keyword :: LexicalConstraint m g s => s -> m g s ()+   keyword :: ParserInput m -> m () -   type instance LexicalConstraint m g s = (Applicative (m g ()), Monad (m g s),-                                            CharParsing (m g s), MonoidParsing (m g),-                                            Show s, TextualMonoid s)-   default lexicalComment :: Alternative (m g s) => m g s ()-   default lexicalWhiteSpace :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)-                             => m g s ()-   default someLexicalSpace :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)-                            => m g s ()-   default lexicalSemicolon :: (LexicalConstraint m g s, CharParsing (m g s), MonoidParsing (m g), TextualMonoid s)-                            => m g s Char-   default lexicalToken :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)-                        => m g s a -> m g s a-   default identifierToken :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)-                           => m g s s -> m g s s-   default identifier :: (LexicalConstraint m g s, Monad (m g s), Alternative (m g s),-                          Parsing (m g s), MonoidParsing (m g), TextualMonoid s) => m g s s-   default keyword :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), Show s, TextualMonoid s)-                   => s -> m g s ()-   lexicalWhiteSpace = takeCharsWhile isSpace *> skipMany (lexicalComment *> takeCharsWhile isSpace)-   someLexicalSpace = takeCharsWhile1 isSpace *> skipMany (lexicalComment *> takeCharsWhile isSpace)-                      <|> lexicalComment *> skipMany (takeCharsWhile isSpace *> lexicalComment)+   default identifier :: TextualMonoid (ParserInput m) => m (ParserInput m)+   default keyword :: (Show (ParserInput m), TextualMonoid (ParserInput m)) => ParserInput m -> m ()++   lexicalWhiteSpace = takeCharsWhile isSpace *> skipAll (lexicalComment *> takeCharsWhile isSpace)+   someLexicalSpace = takeCharsWhile1 isSpace *> (lexicalComment *> lexicalWhiteSpace <<|> pure ())+                      <<|> lexicalComment *> lexicalWhiteSpace+                      <?> "whitespace"    lexicalComment = empty-   lexicalSemicolon = lexicalToken (char ';')+   lexicalSemicolon = lexicalToken (Text.Parser.Char.char ';')    lexicalToken p = p <* lexicalWhiteSpace    isIdentifierStartChar c = isLetter c || c == '_'    isIdentifierFollowChar c = isAlphaNum c || c == '_'-   identifier = identifierToken (liftA2 mappend (satisfyCharInput (isIdentifierStartChar @g))-                                                (takeCharsWhile (isIdentifierFollowChar @g))) <?> "an identifier"+   identifier = identifierToken (liftA2 mappend (satisfyCharInput (isIdentifierStartChar @m))+                                                (takeCharsWhile (isIdentifierFollowChar @m))) <?> "an identifier"    identifierToken = lexicalToken-   keyword s = lexicalToken (string s *> notSatisfyChar (isIdentifierFollowChar @g)) <?> ("keyword " <> show s)+   keyword s = lexicalToken (string s *> notSatisfyChar (isIdentifierFollowChar @m)) <?> ("keyword " <> show s)

@@ -1,23 +1,30 @@+{-# LANGUAGE TypeFamilies #-}+ module Text.Grampa.Combinators (moptional, concatMany, concatSome,                                 flag, count, upto,                                 delimiter, operator, keyword) where  import Control.Applicative(Applicative(..), Alternative(..))-import Data.Monoid.Cancellative (LeftReductiveMonoid)-import Data.Monoid (Monoid, (<>))+import Data.List.NonEmpty (fromList)+import Data.Monoid (Monoid) import Data.Monoid.Factorial (FactorialMonoid)+import Data.Semigroup (Semigroup(sconcat))+import Data.Semigroup.Cancellative (LeftReductive) -import Text.Grampa.Class (MonoidParsing(concatMany, string), -                          Lexical(LexicalConstraint, lexicalToken, keyword))+import Text.Grampa.Class (InputParsing(ParserInput, string), LexicalParsing(lexicalToken, keyword)) import Text.Parser.Combinators (Parsing((<?>)), count)  -- | Attempts to parse a monoidal value, if the argument parser fails returns 'mempty'.-moptional :: (Monoid x, Alternative p) => p x -> p x+moptional :: (Alternative p, Monoid a) => p a -> p a moptional p = p <|> pure mempty +-- | Zero or more argument occurrences like 'many', with concatenated monoidal results.+concatMany :: (Alternative p, Monoid a) => p a -> p a+concatMany p = mconcat <$> many p+ -- | One or more argument occurrences like 'some', with concatenated monoidal results.-concatSome :: (Monoid x, Applicative (p s), MonoidParsing p) => p s x -> p s x-concatSome p = (<>) <$> p <*> concatMany p+concatSome :: (Alternative p, Semigroup a) => p a -> p a+concatSome p = sconcat . fromList <$> some p  -- | Returns 'True' if the argument parser succeeds and 'False' otherwise. flag :: Alternative p => p a -> p Bool@@ -31,11 +38,9 @@    | otherwise = pure []  -- | Parses the given delimiter, such as a comma or a brace-delimiter :: (Show s, FactorialMonoid s, LeftReductiveMonoid s,-              Parsing (p g s), MonoidParsing (p g), Lexical g, LexicalConstraint p g s) => s -> p g s s+delimiter :: (Show s, FactorialMonoid s, LeftReductive s, s ~ ParserInput m, LexicalParsing m) => s -> m s delimiter s = lexicalToken (string s) <?> ("delimiter " <> show s)  -- | Parses the given operator symbol-operator :: (Show s, FactorialMonoid s, LeftReductiveMonoid s,-             Parsing (p g s), MonoidParsing (p g), Lexical g, LexicalConstraint p g s) => s -> p g s s+operator :: (Show s, FactorialMonoid s, LeftReductive s, s ~ ParserInput m, LexicalParsing m) => s -> m s operator s = lexicalToken (string s) <?> ("operator " <> show s)

@@ -14,10 +14,10 @@ import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString) -import qualified Data.Monoid.Cancellative as Cancellative import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null import qualified Data.Monoid.Textual as Textual+import qualified Data.Semigroup.Cancellative as Cancellative  import qualified Rank2 @@ -25,21 +25,20 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token-import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          ParseResults, ParseFailure(..), Expected(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,                                               parsedSuffix :: !s}-                                     | NoParse FailureInfo+                                     | NoParse (FailureInfo 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 -> x) -> x) -> (FailureInfo -> x) -> x}+   Parser{applyParser :: forall x. s -> (r -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x} -instance Show1 (Result g s) where+instance Show s => Show1 (Result g s) where    liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest    liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest @@ -55,18 +54,18 @@    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 -> x) -> x) -> (FailureInfo -> x) -> x+      r :: forall x. s -> (b -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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) ["empty"])+   empty = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected "empty"])    (<|>) = 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 Parser p `alt` Parser q = Parser r where-   r :: forall x. s -> (a -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+   r :: forall x. s -> (a -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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))@@ -75,7 +74,7 @@    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 -> x) -> x) -> (FailureInfo -> x) -> x+      r :: forall x. s -> (b -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x       r rest success failure = p rest (\a rest'-> applyParser (f a) rest' success) failure  instance Factorial.FactorialMonoid s => MonadPlus (Parser g s) where@@ -92,154 +91,147 @@ instance Factorial.FactorialMonoid 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 -> x) -> x) -> (FailureInfo -> x) -> x+      where q :: forall x. s -> (a -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             q input success failure = p input success (failure . rewindFailure)                where rewindFailure (FailureInfo _pos _msgs) = FailureInfo (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 -> x) -> x) -> (FailureInfo -> x) -> x+      where q :: forall x. s -> (a -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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 [msg] else msgs)+                        FailureInfo pos (if pos == Factorial.length input then [Expected msg] else msgs) -   eof = endOfInput-   unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (Factorial.length t) [msg])+   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])    notFollowedBy (Parser p) = Parser q-      where q :: forall x. s -> (() -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where q :: forall x. s -> (() -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             q input success failure = p input success' failure'-               where success' _ _ _ = failure (FailureInfo (Factorial.length input) ["notFollowedBy"])+               where success' _ _ _ = failure (FailureInfo (Factorial.length input) [Expected "notFollowedBy"])                      failure' _ = success () input failure +instance FactorialMonoid 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 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    lookAhead :: forall a. Parser g s a -> Parser g s a    lookAhead (Parser p) = Parser q-      where q :: forall x. s -> (a -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where q :: forall x. s -> (a -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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-   satisfy = satisfyChar+   satisfy predicate = Parser p+      where p :: forall x. s -> (Char -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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"])    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint Parser g s, Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--instance MonoidParsing (Parser g) where-   endOfInput = Parser p-      where p rest success failure-               | Null.null rest = success () rest failure-               | otherwise = failure (FailureInfo (Factorial.length rest) ["endOfInput"])+instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s) => InputParsing (Parser g s) where+   type ParserInput (Parser g s) = s    getInput = Parser p       where p rest success failure = success rest rest failure    anyToken = Parser p       where p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) -> success first suffix failure-                  _ -> failure (FailureInfo (Factorial.length rest) ["anyToken"])-   satisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s+                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "anyToken"])    satisfy predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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) ["satisfy"])-   satisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s Char-   satisfyChar predicate = Parser p-      where p :: forall x. s -> (Char -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> 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) ["satisfyChar"])-   satisfyCharInput :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s-   satisfyCharInput predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> 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) ["satisfyChar"])-   notSatisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s ()+                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfy"])    notSatisfy predicate = Parser p-      where p :: forall x. s -> (() -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (() -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, _)-                     | predicate first -> failure (FailureInfo (Factorial.length rest) ["notSatisfy"])-                  _ -> success () rest failure-   notSatisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s ()-   notSatisfyChar predicate = Parser p-      where p :: forall x. s -> (() -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x-            p rest success failure =-               case Textual.characterPrefix rest-               of Just first | predicate first-                               -> failure (FailureInfo (Factorial.length rest) ["notSatisfyChar"])+                     | predicate first -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfy"])                   _ -> success () rest failure-   scan :: forall t s. FactorialMonoid t => s -> (s -> t -> Maybe s) -> Parser g t t+   scan :: forall state. state -> (state -> s -> Maybe state) -> Parser g s s    scan s0 f = Parser (p s0)-      where p :: forall x. s -> t -> (t -> t -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. state -> s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             p s rest success failure = success prefix suffix failure                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest-   scanChars :: forall t s. TextualMonoid t => s -> (s -> Char -> Maybe s) -> Parser g t t-   scanChars s0 f = Parser (p s0)-      where p :: forall x. s -> t -> (t -> t -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x-            p s rest success failure = success prefix suffix failure-               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest-   takeWhile :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s+   take n = Parser p+      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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])    takeWhile predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             p rest success failure | (prefix, suffix) <- Factorial.span predicate rest = success prefix suffix failure-   takeWhile1 :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s    takeWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             p rest success failure                | (prefix, suffix) <- Factorial.span predicate rest =                     if Null.null prefix-                    then failure (FailureInfo (Factorial.length rest) ["takeWhile1"])+                    then failure (FailureInfo (Factorial.length rest) [Expected "takeWhile1"])                     else success prefix suffix failure-   takeCharsWhile :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s+   string s = Parser p where+      p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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])+   {-# INLINABLE string #-}++instance (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+            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"])+   notSatisfyChar predicate = Parser p+      where p :: forall x. s -> (() -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+            p rest success failure =+               case Textual.characterPrefix rest+               of Just first | predicate first+                               -> failure (FailureInfo (Factorial.length rest) [Expected "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+            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 -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             p rest success failure                | (prefix, suffix) <- Textual.span_ False predicate rest = success prefix suffix failure-   takeCharsWhile1 :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s    takeCharsWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             p rest success failure-               | Null.null prefix = failure (FailureInfo (Factorial.length rest) ["takeCharsWhile1"])+               | Null.null prefix = failure (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])                | otherwise = success prefix suffix failure                where (prefix, suffix) = Textual.span_ False predicate rest-   string :: forall s. (Cancellative.LeftReductiveMonoid s, FactorialMonoid s, Show s) => s -> Parser g s s-   string s = Parser p where-      p :: forall x. s -> (s -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x-      p s' success failure-         | Just suffix <- Cancellative.stripPrefix s s' = success s suffix failure-         | otherwise = failure (FailureInfo (Factorial.length s') ["string " ++ show s])-   concatMany :: forall s a. Monoid a => Parser g s a -> Parser g s a-   concatMany (Parser p) = Parser q-      where q :: forall x. s -> (a -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x-            q rest success failure = p rest success' (const $ success mempty rest failure)-               where success' prefix suffix failure' =-                        q suffix (success . mappend prefix) (const $ success prefix suffix failure')-   {-# INLINABLE string #-}  -- | Continuation-passing context-free parser -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>---                  g (Continued.'Parser' g s) -> s -> g 'ParseResults'+--                  g (Continued.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance MultiParsing Parser where-   type ResultFunctor Parser = ParseResults+instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid 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 (<* endOfInput) g)+                                      (Rank2.fmap (<* eof) g) -fromFailure :: FactorialMonoid s => s -> FailureInfo -> ParseFailure+fromFailure :: (Eq s, FactorialMonoid s) => s -> FailureInfo s -> ParseFailure s fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - pos + 1) (nub msgs)

@@ -14,10 +14,10 @@ import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString) -import qualified Data.Monoid.Cancellative as Cancellative import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null import qualified Data.Monoid.Textual as Textual+import qualified Data.Semigroup.Cancellative as Cancellative  import qualified Rank2 @@ -25,21 +25,20 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token-import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),+                          MultiParsing(..), ParseResults, ParseFailure(..), Expected(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,                                               parsedSuffix :: !s}-                                     | NoParse FailureInfo+                                     | NoParse (FailureInfo 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 -> x) -> x) -> (FailureInfo -> x) -> x}+   Parser{applyParser :: forall x. s -> (r -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x} -instance Show1 (Result g s) where+instance Show s => Show1 (Result g s) where    liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest    liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest @@ -55,18 +54,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 -> x) -> x) -> (FailureInfo -> x) -> x+      r :: forall x. s -> (b -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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) ["empty"])+   empty = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected "empty"])    (<|>) = 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 Parser p `alt` Parser q = Parser r where-   r :: forall x. s -> (a -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+   r :: forall x. s -> (a -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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,7 +74,7 @@    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 -> x) -> x) -> (FailureInfo -> x) -> x+      r :: forall x. s -> (b -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x       r rest success failure = p rest                                  (\a len rest'-> applyParser (f a) rest' $ \b len'-> success b $! len + len')                                  failure@@ -94,159 +93,157 @@ instance Factorial.FactorialMonoid 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 -> x) -> x) -> (FailureInfo -> x) -> x+      where q :: forall x. s -> (a -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             q input success failure = p input success (failure . rewindFailure)                where rewindFailure (FailureInfo _pos _msgs) = FailureInfo (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 -> x) -> x) -> (FailureInfo -> x) -> x+      where q :: forall x. s -> (a -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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 [msg] else msgs)-   eof = endOfInput-   unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (Factorial.length t) [msg])+                        FailureInfo pos (if pos == Factorial.length input then [Expected msg] else msgs)+   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])    notFollowedBy (Parser p) = Parser q-      where q :: forall x. s -> (() -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where q :: forall x. s -> (() -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             q input success failure = p input success' failure'-               where success' _ _ _ _ = failure (FailureInfo (Factorial.length input) ["notFollowedBy"])+               where success' _ _ _ _ = failure (FailureInfo (Factorial.length input) [Expected "notFollowedBy"])                      failure' _ = success () 0 input failure +instance Factorial.FactorialMonoid 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 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    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 -> x) -> x) -> (FailureInfo -> x) -> x+      where q :: forall x. s -> (a -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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-   satisfy = satisfyChar+   satisfy predicate = Parser p+      where p :: forall x. s -> (Char -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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"])    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint Parser g s, Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--instance MonoidParsing (Parser g) where-   endOfInput = Parser p-      where p rest success failure-               | Null.null rest = success () 0 rest failure-               | otherwise = failure (FailureInfo (Factorial.length rest) ["endOfInput"])+instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid 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    anyToken = Parser p       where p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) -> success first 1 suffix failure-                  _ -> failure (FailureInfo (Factorial.length rest) ["anyToken"])-   satisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s+                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "anyToken"])    satisfy predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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) ["satisfy"])-   satisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s Char-   satisfyChar predicate = Parser p-      where p :: forall x. s -> (Char -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> 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) ["satisfyChar"])-   satisfyCharInput :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s-   satisfyCharInput predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> 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) ["satisfyChar"])-   notSatisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s ()+                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfy"])    notSatisfy predicate = Parser p-      where p :: forall x. s -> (() -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (() -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, _)-                     | predicate first -> failure (FailureInfo (Factorial.length rest) ["notSatisfy"])-                  _ -> success () 0 rest failure-   notSatisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s ()-   notSatisfyChar predicate = Parser p-      where p :: forall x. s -> (() -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x-            p rest success failure =-               case Textual.characterPrefix rest-               of Just first | predicate first-                               -> failure (FailureInfo (Factorial.length rest) ["notSatisfyChar"])+                     | predicate first -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfy"])                   _ -> success () 0 rest failure-   scan :: forall t s. FactorialMonoid t => s -> (s -> t -> Maybe s) -> Parser g t t+   scan :: forall state. state -> (state -> s -> Maybe state) -> Parser g s s    scan s0 f = Parser (p s0)-      where p :: forall x. s -> t -> (t -> Int -> t -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. state -> s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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-   scanChars :: forall t s. TextualMonoid t => s -> (s -> Char -> Maybe s) -> Parser g t t-   scanChars s0 f = Parser (p s0)-      where p :: forall x. s -> t -> (t -> Int -> t -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x-            p s rest success failure = success prefix len suffix failure-               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest-                     !len = Factorial.length prefix-   takeWhile :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s+   take n = Parser p+      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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])    takeWhile predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             p rest success failure                 | (prefix, suffix) <- Factorial.span predicate rest,                   !len <- Factorial.length prefix =                      success prefix len suffix failure-   takeWhile1 :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s    takeWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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) ["takeWhile1"])+                    then failure (FailureInfo (Factorial.length rest) [Expected "takeWhile1"])                     else success prefix len suffix failure-   takeCharsWhile :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s+   string s = Parser p where+      p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo 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])+   {-# INLINABLE string #-}++instance (Cancellative.LeftReductive s, FactorialMonoid 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+            q rest success failure = p rest success' failure+               where success' r !len suffix failure' = success (Factorial.take len rest, r) len suffix failure'++instance (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+            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"])+   notSatisfyChar predicate = Parser p+      where p :: forall x. s -> (() -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x+            p rest success failure =+               case Textual.characterPrefix rest+               of Just first | predicate first+                               -> failure (FailureInfo (Factorial.length rest) [Expected "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+            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 -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             p rest success failure                | (prefix, suffix) <- Textual.span_ False predicate rest,                   !len <- Factorial.length prefix = success prefix len suffix failure-   takeCharsWhile1 :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s    takeCharsWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> (FailureInfo s -> x) -> x) -> (FailureInfo s -> x) -> x             p rest success failure-               | Null.null prefix = failure (FailureInfo (Factorial.length rest) ["takeCharsWhile1"])+               | Null.null prefix = failure (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])                | otherwise = len `seq` success prefix len suffix failure                where (prefix, suffix) = Textual.span_ False predicate rest                      len = Factorial.length prefix-   string :: forall s. (Cancellative.LeftReductiveMonoid s, FactorialMonoid s, Show s) => s -> Parser g s s-   string s = Parser p where-      p :: forall x. s -> (s -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> 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') ["string " ++ show s])-   concatMany :: forall s a. Monoid a => Parser g s a -> Parser g s a-   concatMany (Parser p) = Parser q-      where q :: forall x. s -> (a -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x-            q rest success failure = p rest success' (const $ success mempty 0 rest failure)-               where success' prefix !len suffix failure' =-                        q suffix -                          (\prefix' !len'-> success (mappend prefix prefix') (len + len')) -                          (const $ success prefix len suffix failure')-   {-# INLINABLE string #-}  -- | Continuation-passing context-free parser that keeps track of the parsed prefix length -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>---                  g (Continued.'Parser' g s) -> s -> g 'ParseResults'+--                  g (Continued.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance MultiParsing Parser where-   type ResultFunctor Parser = ParseResults+instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid 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))@@ -255,7 +252,7 @@    parseComplete g input = Rank2.fmap (\p-> applyParser p input                                                         (const . const . const . Right)                                                         (Left . fromFailure input))-                                      (Rank2.fmap (<* endOfInput) g)+                                      (Rank2.fmap (<* eof) g) -fromFailure :: FactorialMonoid s => s -> FailureInfo -> ParseFailure+fromFailure :: (Eq s, FactorialMonoid s) => s -> FailureInfo s -> ParseFailure s fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - pos + 1) (nub msgs)

@@ -1,17 +1,18 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, InstanceSigs,-             RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, InstanceSigs,+             RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators,+             UndecidableInstances #-} {-# OPTIONS -fno-full-laziness #-}-module Text.Grampa.ContextFree.LeftRecursive (Fixed, Parser, SeparatedParser(..),+module Text.Grampa.ContextFree.LeftRecursive (Fixed, Parser, SeparatedParser(..), FallibleWithExpectations(..),                                               longest, peg, terminalPEG,-                                              parseSeparated, separated, (<<|>))+                                              liftPositive, liftPure, mapPrimitive,+                                              parseSeparated, separated) where  import Control.Applicative-import Control.Monad (Monad(..), MonadPlus(..))+import Control.Monad (Monad(..), MonadPlus(..), void) import Control.Monad.Trans.State.Lazy (State, evalState, get, put)  import Data.Functor.Compose (Compose(..))-import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (isJust)  import Data.Semigroup (Semigroup(..))@@ -19,57 +20,63 @@ import Data.Monoid.Null (MonoidNull(null)) import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid)+import Data.Semigroup.Cancellative (LeftReductive) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual import Data.String (fromString)+import Data.Type.Equality ((:~:)(Refl)) -import qualified Text.Parser.Char+import qualified Text.Parser.Char as Char import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token as Token  import qualified Rank2-import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), AmbiguousParsing(..),-                          Lexical(..), Ambiguous(..), ParseResults)-import Text.Grampa.Internal (ResultList(..), ResultsOfLength(..), fromResultList)+import Text.Grampa.Class (GrammarParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          AmbiguousParsing(..), Ambiguous(..),+                          ConsumedInputParsing(..), DeterministicParsing(..),+                          TailsParsing(parseTails, parseAllTails), Expected(..))+import Text.Grampa.Internal (ResultList(..), FailureInfo(..), AmbiguousAlternative(ambiguousOr)) import qualified Text.Grampa.ContextFree.SortedMemoizing as Memoizing import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack -import Prelude hiding (cycle, null, span, takeWhile)+import Prelude hiding (cycle, null, span, take, takeWhile)  type Parser = Fixed Memoizing.Parser -type ResultAppend g s = ResultList g s Rank2.~> ResultList g s Rank2.~> ResultList g s+type ResultAppend p (g :: (* -> *) -> *) s =+   GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s)  data Fixed p g s a =    Parser {       complete, direct, direct0, direct1, indirect :: p g s a,-      appendResults :: ResultList g s a -> ResultList g s a -> ResultList g s a,+      isAmbiguous :: Maybe (AmbiguityWitness a),       cyclicDescendants :: Rank2.Apply g => g (Const (ParserFlags g)) -> ParserFlags g}    | DirectParser {       complete, direct0, direct1 :: p g s a}    | PositiveDirectParser {       complete :: p g s a} -data SeparatedParser p g s a = FrontParser (p g s a)-                             | CycleParser {-                                  cycleParser  :: p g s a,-                                  backParser   :: p g s a,-                                  appendResultsArrow :: ResultAppend g s a,-                                  dependencies :: g (Const Bool)}-                             | BackParser {-                                  backParser :: p g s a}+data AmbiguityWitness a where+   AmbiguityWitness :: (a :~: Ambiguous b) -> AmbiguityWitness 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 :: g (Const Bool)}+                                                | BackParser {+                                                     backParser :: p g s a}+ data ParserFlags g = ParserFlags {    nullable :: Bool,    dependsOn :: g (Const Bool)}  deriving instance Show (g (Const Bool)) => Show (ParserFlags g) -data ParserFunctor g s a = ParserResultsFunctor {parserResults :: ResultList g s a}-                         | ParserFlagsFunctor {parserFlags :: ParserFlags g}+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)} @@ -83,6 +90,19 @@    mempty = Union (Rank2.cotraverse (Const . getConst) (Const False))    mappend (Union g1) (Union g2) = Union (Rank2.liftA2 union g1 g2) +mapPrimitive :: (p g s a -> p g s a) -> Fixed p g s a -> Fixed p g s a+mapPrimitive f p@PositiveDirectParser{} = PositiveDirectParser{complete= f (complete p)}+mapPrimitive f p@DirectParser{} = DirectParser{complete= f (complete p),+                                               direct0= f (direct0 p),+                                               direct1= f (direct1 p)}+mapPrimitive f p@Parser{} = Parser{complete= f (complete p),+                                   isAmbiguous= isAmbiguous p,+                                   cyclicDescendants= cyclicDescendants p,+                                   indirect= f (indirect p),+                                   direct= f (direct p),+                                   direct0= f (direct0 p),+                                   direct1= f (direct1 p)}+ general, general' :: Alternative (p g s) => Fixed p g s a -> Fixed p g s a  general p = Parser{@@ -91,7 +111,9 @@    direct0= direct0 p',    direct1= direct1 p',    indirect= indirect p',-   appendResults= appendResults p',+   isAmbiguous= case p+                of Parser{isAmbiguous= a} -> a+                   _ -> Nothing,    cyclicDescendants= cyclicDescendants p'}    where p' = general' p @@ -101,7 +123,7 @@    direct0= empty,    direct1= complete p,    indirect= empty,-   appendResults= (<>),+   isAmbiguous= Nothing,    cyclicDescendants= \cd-> ParserFlags False (const (Const False) Rank2.<$> cd)} general' p@DirectParser{} = Parser{    complete= complete p,@@ -109,7 +131,7 @@    direct0= direct0 p,    direct1= direct1 p,    indirect= empty,-   appendResults= (<>),+   isAmbiguous= Nothing,    cyclicDescendants= \cd-> ParserFlags True (const (Const False) Rank2.<$> cd)} general' p@Parser{} = p @@ -117,35 +139,50 @@ -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Apply' g, "Rank2".'Rank2.Traversable' g, 'FactorialMonoid' s) =>---                  g (LeftRecursive.'Fixed g s) -> s -> g ('Compose' 'ParseResults' [])+--                  g (LeftRecursive.'Fixed g s) -> s -> g ('Compose' ('ParseResults' s) []) -- @-instance MultiParsing (Fixed Memoizing.Parser) where-   type GrammarConstraint (Fixed Memoizing.Parser) g = (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)-   type ResultFunctor (Fixed Memoizing.Parser) = Compose ParseResults []-   parsePrefix :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, FactorialMonoid s) =>-                  g (Parser g s) -> s -> g (Compose (Compose ParseResults []) ((,) s))-   parsePrefix g input = Rank2.fmap (Compose . Compose . fromResultList input)+instance (Eq s, LeftReductive s, FactorialMonoid s, Alternative (p g s),+          TailsParsing (p g s), GrammarConstraint (p g s) g, ParserGrammar (p g s) ~ g,+          Functor (ResultFunctor (p g s)),+          s ~ ParserInput (p g s), GrammarFunctor (p g s) ~ rl s, FallibleWithExpectations rl,+          AmbiguousAlternative (GrammarFunctor (p g s))) =>+         MultiParsing (Fixed p g s) where+   type GrammarConstraint (Fixed p g s) g' = (GrammarConstraint (p g s) g', g ~ g',+                                              Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)+   type ResultFunctor (Fixed p g s) = ResultFunctor (p g s)+   parsePrefix :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, Eq s, FactorialMonoid s) =>+                  g (Fixed p g s) -> s -> g (Compose (ResultFunctor (p g s)) ((,) s))+   parsePrefix g input = Rank2.fmap (Compose . parsingResult @(p g s) input)                                     (snd $ head $ parseRecursive g input)    {-# INLINE parsePrefix #-}-   parseComplete :: (FactorialMonoid s, Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g) =>-                    g (Parser g s) -> s -> g (Compose ParseResults [])-   parseComplete g = \input-> let close = Rank2.fmap (<* endOfInput) selfReferring-                              in Rank2.fmap ((snd <$>) . Compose . fromResultList input)-                                            (snd $ head $ Memoizing.reparseTails close $ parseSeparated g' input)+   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)+                                            (snd $ head $ parseAllTails close $ parseSeparated g' input)       where g' = separated g    {-# INLINE parseComplete #-} -instance GrammarParsing (Fixed Memoizing.Parser) where-   type GrammarFunctor (Fixed Memoizing.Parser) = ParserFunctor-   nonTerminal :: forall g s a. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)-                  => (g (ParserFunctor g s) -> ParserFunctor g s a) -> Parser g s a+instance (Eq s, LeftReductive s, FactorialMonoid s, Alternative (p g s),+          TailsParsing (p g s), GrammarConstraint (p g s) g, ParserGrammar (p g s) ~ g,+          Functor (ResultFunctor (p g s)),+          s ~ ParserInput (p g s), GrammarFunctor (p g s) ~ rl s, FallibleWithExpectations rl,+          AmbiguousAlternative (GrammarFunctor (p g s))) =>+         GrammarParsing (Fixed p g s) where+   type ParserGrammar (Fixed p g s) = g+   type GrammarFunctor (Fixed p g s) = ParserFunctor p g s+   parsingResult :: s -> ParserFunctor p g s a -> ResultFunctor (p g s) (s, a)+   parsingResult s = parsingResult @(p g s) s . parserResults+   nonTerminal :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g) =>+                  (g (ParserFunctor p g s) -> ParserFunctor p g s a) -> Fixed p g s a    nonTerminal f = Parser{       complete= ind,       direct= empty,       direct0= empty,       direct1= empty,       indirect= ind,-      appendResults= (<>),+      isAmbiguous= Nothing,       cyclicDescendants= parserFlags . f . Rank2.fmap (ParserFlagsFunctor . getConst) . addSelf}       where ind = nonTerminal (parserResults . f . Rank2.fmap ParserResultsFunctor)             addSelf g = Rank2.liftA2 adjust bits g@@ -177,7 +214,7 @@       direct0= fmap f (direct0 p),       direct1= fmap f (direct1 p),       indirect= fmap f (indirect p),-      appendResults= (<>)}+      isAmbiguous= Nothing}    {-# INLINABLE fmap #-}  instance Alternative (p g s) => Applicative (Fixed p g s) where@@ -198,7 +235,7 @@       direct0= direct0 p' <*> direct0 q,       direct1= direct0 p' <*> direct1 q <|> direct1 p' <*> complete q,       indirect= direct0 p' <*> indirect q <|> indirect p' <*> complete q,-      appendResults= (<>),+      isAmbiguous= Nothing,       cyclicDescendants= \deps-> let            pcd@(ParserFlags pn pd) = cyclicDescendants p' deps            ParserFlags qn qd = cyclicDescendants q deps@@ -212,7 +249,7 @@       direct0= direct0 p' <*> direct0 q',       direct1= direct0 p' <*> direct1 q' <|> direct1 p' <*> complete q',       indirect= indirect p' <*> complete q',-      appendResults= (<>),+      isAmbiguous= Nothing,       cyclicDescendants= \deps-> let            pcd@(ParserFlags pn pd) = cyclicDescendants p' deps            ParserFlags qn qd = cyclicDescendants q' deps@@ -244,7 +281,7 @@                     direct0= direct0 p' <|> direct0 q',                     direct1= direct1 p' <|> direct1 q',                     indirect= indirect p' <|> indirect q',-                    appendResults= (<>),+                    isAmbiguous= Nothing,                     cyclicDescendants= \deps-> let                          ParserFlags pn pd = cyclicDescendants p' deps                          ParserFlags qn qd = cyclicDescendants q' deps@@ -265,7 +302,7 @@       direct0= d0,       direct1= d1,       indirect= (:) <$> indirect p <*> mcp,-      appendResults= (<>),+      isAmbiguous= Nothing,       cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}       where d0 = pure [] <|> (:[]) <$> direct0 p             d1 = (:) <$> direct1 p <*> mcp@@ -281,7 +318,7 @@       direct0= d0,       direct1= d1,       indirect= (:) <$> indirect p <*> many (complete p),-      appendResults= (<>),+      isAmbiguous= Nothing,       cyclicDescendants= cyclicDescendants p}       where d0 = (:[]) <$> direct0 p             d1= (:) <$> direct1 p <*> many (complete p)@@ -289,29 +326,6 @@    {-# INLINABLE many #-}    {-# INLINABLE some #-} -infixl 3 <<|>-(<<|>) :: Parser g s a -> Parser g s a -> Parser g s a-p@DirectParser{} <<|> q@PositiveDirectParser{} = DirectParser{-   complete= complete p Memoizing.<<|> complete q,-   direct0 = direct0 p,-   direct1= direct1 p Memoizing.<<|> complete q}-p@DirectParser{} <<|> q@DirectParser{} = DirectParser{-   complete= complete p Memoizing.<<|> complete q,-   direct0 = direct0 p Memoizing.<<|> direct0 q,-   direct1= direct1 p Memoizing.<<|> direct1 q}-p <<|> q = Parser{complete= complete p' Memoizing.<<|> complete q',-                 direct= direct p' Memoizing.<<|> direct q',-                 direct0= direct0 p' Memoizing.<<|> direct0 q',-                 direct1= direct1 p' Memoizing.<<|> direct1 q',-                 indirect= indirect p' Memoizing.<<|> indirect q',-                 appendResults= (<>),-                 cyclicDescendants= \deps-> let-                         ParserFlags pn pd = cyclicDescendants p' deps-                         ParserFlags qn qd = cyclicDescendants q' deps-                      in ParserFlags (pn || qn) (Rank2.liftA2 union pd qd)}-   where p'@Parser{} = general p-         q'@Parser{} = general q- union :: Const Bool x -> Const Bool x -> Const Bool x union (Const False) d = d union (Const True) _ = Const True@@ -326,7 +340,7 @@       direct0= d0,       direct1= d1,       indirect= direct0 p >>= indirect . general' . cont,-      appendResults= (<>),+      isAmbiguous= Nothing,       cyclicDescendants= \cd-> (ParserFlags True $ Rank2.fmap (const $ Const True) cd)}       where d0 = direct0 p >>= direct0 . general' . cont             d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont)@@ -336,7 +350,7 @@       direct0= d0,       direct1= d1,       indirect= (indirect p >>= complete . cont) <|> (direct0 p >>= indirect . general' . cont),-      appendResults= (<>),+      isAmbiguous= Nothing,       cyclicDescendants= \cd->          let pcd@(ParserFlags pn _) = cyclicDescendants p' cd          in if pn@@ -357,18 +371,26 @@    mempty = pure mempty    mappend = liftA2 mappend -primitive :: String -> p g s a -> p g s a -> p g s a -> Fixed p g s a-primitive _name d0 d1 d = DirectParser{complete= d,-                                       direct0= d0,-                                       direct1= d1}+primitive :: p g s a -> p g s a -> p g s a -> Fixed p g s a+primitive d0 d1 d = DirectParser{complete= d,+                                 direct0= d0,+                                 direct1= d1} {-# INLINE primitive #-} -positivePrimitive :: String -> p g s a -> Fixed p g s a-positivePrimitive _name p = PositiveDirectParser{complete= p}-{-# INLINE positivePrimitive #-}+-- | Lifts a primitive positive parser (/i.e./, one that always consumes some input) into a left-recursive one+liftPositive :: p g s a -> Fixed p g s a+liftPositive p = PositiveDirectParser{complete= p}+{-# INLINE liftPositive #-} -instance (Parsing (p g s), MonoidParsing (Fixed p g)) => Parsing (Fixed p g s) where-   eof = primitive "eof" eof empty eof+-- | Lifts a primitive pure parser (/i.e./, one that consumes no input) into a left-recursive one+liftPure :: Alternative (p g s) => p g s a -> Fixed p g s a+liftPure p = DirectParser{complete= p,+                          direct0= p,+                          direct1= empty}+{-# INLINE liftPure #-}++instance (Parsing (p g s), InputParsing (Fixed p g s)) => Parsing (Fixed p g s) where+   eof = primitive eof empty eof    try (PositiveDirectParser p) = PositiveDirectParser (try p)    try p@DirectParser{} = DirectParser{       complete= try (complete p),@@ -404,13 +426,73 @@       direct= notFollowedBy (direct p),       direct0= notFollowedBy (direct p),       direct1= empty,-      appendResults= (<>),+      isAmbiguous= Nothing,       indirect= notFollowedBy (indirect p),       cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}-   unexpected msg = positivePrimitive "unexpected" (unexpected msg)-   skipMany p = concatMany (() <$ p)+   unexpected msg = liftPositive (unexpected msg) -instance (LookAheadParsing (p g s), MonoidParsing (Fixed p g)) => LookAheadParsing (Fixed p g s) where+instance (InputParsing (Fixed p g s), DeterministicParsing (p g s)) => DeterministicParsing (Fixed p g s) where+   p@DirectParser{} <<|> q@PositiveDirectParser{} = DirectParser{+      complete= complete p <<|> complete q,+      direct0 = direct0 p,+      direct1= direct1 p <<|> complete q}+   p@DirectParser{} <<|> q@DirectParser{} = DirectParser{+      complete= complete p <<|> complete q,+      direct0 = direct0 p <<|> direct0 q,+      direct1= direct1 p <<|> direct1 q}+   p <<|> q = Parser{complete= complete p' <<|> complete q',+                    direct= direct p' <<|> direct q',+                    direct0= direct0 p' <<|> direct0 q',+                    direct1= direct1 p' <<|> direct1 q',+                    indirect= indirect p' <<|> indirect q',+                    isAmbiguous= Nothing,+                    cyclicDescendants= \deps-> let+                            ParserFlags pn pd = cyclicDescendants p' deps+                            ParserFlags qn qd = cyclicDescendants q' deps+                         in ParserFlags (pn || qn) (Rank2.liftA2 union pd qd)}+      where p'@Parser{} = general p+            q'@Parser{} = general q+   takeSome p = (:) <$> p <*> takeMany p+   takeMany (PositiveDirectParser p) = DirectParser{+      complete = takeMany p,+      direct0= [] <$ notFollowedBy (void p),+      direct1= takeSome p}+   takeMany p@DirectParser{} = DirectParser{+      complete = takeMany (complete p),+      direct0= (:[]) <$> direct0 p <<|> [] <$ notFollowedBy (void $ complete p),+      direct1= (:) <$> direct1 p <*> takeMany (complete p)}+   takeMany p@Parser{} = Parser{+      complete= mcp,+      direct= d1 <<|> d0,+      direct0= d0,+      direct1= d1,+      indirect= (:) <$> indirect p <*> mcp,+      isAmbiguous= Nothing,+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}+      where d0 = (:[]) <$> direct0 p <<|> [] <$ notFollowedBy (void $ direct p)+            d1 = (:) <$> direct1 p <*> mcp+            mcp = takeMany (complete p)+   skipAll (PositiveDirectParser p) = DirectParser{+      complete = skipAll p,+      direct0= () <$ notFollowedBy (void p),+      direct1= p *> skipAll p}+   skipAll p@DirectParser{} = DirectParser{+      complete = skipAll (complete p),+      direct0= void (direct0 p) <<|> notFollowedBy (void $ complete p),+      direct1= direct1 p *> skipAll (complete p)}+   skipAll p@Parser{} = Parser{+      complete= mcp,+      direct= d1 <<|> d0,+      direct0= d0,+      direct1= d1,+      indirect= indirect p *> mcp,+      isAmbiguous= Nothing,+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}+      where d0 = () <$ direct0 p <<|> notFollowedBy (void $ direct p)+            d1 = direct1 p *> mcp+            mcp = skipAll (complete p)++instance (LookAheadParsing (p g s), InputParsing (Fixed p g s)) => LookAheadParsing (Fixed p g s) where    lookAhead p@PositiveDirectParser{} = DirectParser{       complete= lookAhead (complete p),       direct0= lookAhead (complete p),@@ -424,135 +506,64 @@       direct= lookAhead (direct p),       direct0= lookAhead (direct p),       direct1= empty,-      appendResults= appendResults p,+      isAmbiguous= isAmbiguous p,       indirect= lookAhead (indirect p),       cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}} -instance MonoidParsing (Fixed Memoizing.Parser g) where-   endOfInput = primitive "endOfInput" endOfInput empty endOfInput-   getInput = primitive "getInput" getInput empty getInput-   anyToken = positivePrimitive "anyToken" anyToken-   satisfy predicate = positivePrimitive "satisfy" (satisfy predicate)-   satisfyChar predicate = positivePrimitive "satisfyChar" (satisfyChar predicate)-   satisfyCharInput predicate = positivePrimitive "satisfyCharInput" (satisfyCharInput predicate)-   notSatisfy predicate = primitive "notSatisfy" (notSatisfy predicate) empty (notSatisfy predicate)-   notSatisfyChar predicate = primitive "notSatisfyChar" (notSatisfyChar predicate) empty (notSatisfyChar predicate)-   scan s0 f = primitive "scan" (mempty <$ notSatisfy test) (lookAhead (satisfy test) *> p) p+instance (LeftReductive s, FactorialMonoid s, InputParsing (p g s), ParserInput (p g s) ~ s) =>+         InputParsing (Fixed p g s) where+   type ParserInput (Fixed p g s) = s+   getInput = primitive getInput empty getInput+   anyToken = liftPositive anyToken+   satisfy predicate = liftPositive (satisfy predicate)+   notSatisfy predicate = primitive (notSatisfy predicate) empty (notSatisfy predicate)+   scan s0 f = primitive (mempty <$ notSatisfy test) (lookAhead (satisfy test) *> p) p       where p = scan s0 f             test = isJust . f s0-   scanChars s0 f = primitive "scanChars" (mempty <$ notSatisfyChar test) (lookAhead (satisfyChar test) *> p) p-      where p = scanChars s0 f-            test = isJust . f s0    string s-      | null s = primitive ("(string " ++ shows s ")") (string s) empty (string s)-      | otherwise = positivePrimitive ("(string " ++ shows s ")") (string s)-   takeWhile predicate = primitive "takeWhile" (mempty <$ notSatisfy predicate)+      | null s = primitive (string s) empty (string s)+      | otherwise = liftPositive (string s)+   take 0 = mempty+   take n = liftPositive (take n)+   takeWhile predicate = primitive (mempty <$ notSatisfy predicate)                                                (takeWhile1 predicate) (takeWhile predicate)-   takeWhile1 predicate = positivePrimitive "takeWhile1" (takeWhile1 predicate)-   takeCharsWhile predicate = primitive "takeCharsWhile" (mempty <$ notSatisfyChar predicate)-                                                         (takeCharsWhile1 predicate) (takeCharsWhile predicate)-   takeCharsWhile1 predicate = positivePrimitive "takeCharsWhile1" (takeCharsWhile1 predicate)-   concatMany p@PositiveDirectParser{} = DirectParser{-      complete= cmp,-      direct0= d0,-      direct1= d1}-      where d0 = pure mempty-            d1 = mappend <$> complete p <*> cmp-            cmp = concatMany (complete p)-   concatMany p@DirectParser{} = DirectParser{-      complete= cmp,-      direct0= d0,-      direct1= d1}-      where d0 = pure mempty <|> direct0 p-            d1 = mappend <$> direct1 p <*> cmp-            cmp = concatMany (complete p)-   concatMany p@Parser{} = Parser{-      complete= cmp,-      direct= d0 <|> d1,-      direct0= d0,-      direct1= d1,-      indirect= mappend <$> indirect p <*> cmp,-      appendResults= mappend,-      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}-      where d0 = pure mempty <|> direct0 p-            d1 = mappend <$> direct1 p <*> cmp-            cmp = concatMany (complete p)+   takeWhile1 predicate = liftPositive (takeWhile1 predicate)    {-# INLINABLE string #-}-   {-# INLINABLE concatMany #-} -instance MonoidParsing (Fixed Backtrack.Parser g) where-   endOfInput = primitive "endOfInput" endOfInput empty endOfInput-   getInput = primitive "getInput" getInput empty getInput-   anyToken = positivePrimitive "anyToken" anyToken-   satisfy predicate = positivePrimitive "satisfy" (satisfy predicate)-   satisfyChar predicate = positivePrimitive "satisfyChar" (satisfyChar predicate)-   satisfyCharInput predicate = positivePrimitive "satisfyCharInput" (satisfyCharInput predicate)-   notSatisfy predicate = primitive "notSatisfy" (notSatisfy predicate) empty (notSatisfy predicate)-   notSatisfyChar predicate = primitive "notSatisfyChar" (notSatisfyChar predicate) empty (notSatisfyChar predicate)-   scan s0 f = primitive "scan" (mempty <$ notSatisfy test) (lookAhead (satisfy test) *> p) p-      where p = scan s0 f-            test = isJust . f s0-   scanChars s0 f = primitive "scanChars" (mempty <$ notSatisfyChar test) (lookAhead (satisfyChar test) *> p) p+instance (LeftReductive s, FactorialMonoid s,+          ConsumedInputParsing (p g s), ParserInput (p g s) ~ s) => ConsumedInputParsing (Fixed p g s) where+   match (PositiveDirectParser p) = PositiveDirectParser (match p)+   match p@DirectParser{} = DirectParser{+      complete= match (complete p),+      direct0 = match (direct0 p),+      direct1 = match (direct1 p)}+   match p@Parser{} = Parser{+      complete= match (complete p),+      direct =  match (direct p),+      direct0 = match (direct0 p),+      direct1 = match (direct1 p),+      indirect= match (indirect p),+      isAmbiguous= Nothing,+      cyclicDescendants= cyclicDescendants p}++instance (Show s, TextualMonoid s, InputCharParsing (p g s), ParserInput (p g s) ~ s) =>+         InputCharParsing (Fixed p g s) where+   satisfyCharInput predicate = liftPositive (satisfyCharInput predicate)+   notSatisfyChar predicate = primitive (notSatisfyChar predicate) empty (notSatisfyChar predicate)+   scanChars s0 f = primitive (mempty <$ notSatisfyChar test) (lookAhead (Char.satisfy test) *> p) p       where p = scanChars s0 f             test = isJust . f s0-   string s-      | null s = primitive ("(string " ++ shows s ")") (string s) empty (string s)-      | otherwise = positivePrimitive ("(string " ++ shows s ")") (string s)-   takeWhile predicate = primitive "takeWhile" (mempty <$ notSatisfy predicate)-                                               (takeWhile1 predicate) (takeWhile predicate)-   takeWhile1 predicate = positivePrimitive "takeWhile1" (takeWhile1 predicate)-   takeCharsWhile predicate = primitive "takeCharsWhile" (mempty <$ notSatisfyChar predicate)-                                                         (takeCharsWhile1 predicate) (takeCharsWhile predicate)-   takeCharsWhile1 predicate = positivePrimitive "takeCharsWhile1" (takeCharsWhile1 predicate)-   concatMany p@PositiveDirectParser{} = DirectParser{-      complete= cmp,-      direct0= d0,-      direct1= d1}-      where d0 = pure mempty-            d1 = mappend <$> complete p <*> cmp-            cmp = concatMany (complete p)-   concatMany p@DirectParser{} = DirectParser{-      complete= cmp,-      direct0= d0,-      direct1= d1}-      where d0 = pure mempty `Backtrack.alt` direct0 p-            d1 = mappend <$> direct1 p <*> cmp-            cmp = concatMany (complete p)-   concatMany p@Parser{} = Parser{-      complete= cmp,-      direct= d0 `Backtrack.alt` d1,-      direct0= d0,-      direct1= d1,-      indirect= mappend <$> indirect p <*> cmp,-      appendResults= mappend,-      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}-      where d0 = pure mempty `Backtrack.alt` direct0 p-            d1 = mappend <$> direct1 p <*> cmp-            cmp = concatMany (complete p)-   {-# INLINABLE string #-}-   {-# INLINABLE concatMany #-}+   takeCharsWhile predicate = primitive (mempty <$ notSatisfyChar predicate)+                                        (takeCharsWhile1 predicate) (takeCharsWhile predicate)+   takeCharsWhile1 predicate = liftPositive (takeCharsWhile1 predicate) -instance (Parsing (p g s), MonoidParsing (Fixed p g), Show s, TextualMonoid s) => CharParsing (Fixed p g s) where-   satisfy = satisfyChar+instance (CharParsing (p g s), InputCharParsing (Fixed p g s), TextualMonoid s,+          s ~ ParserInput (Fixed p g s), Show s) => CharParsing (Fixed p g s) where+   satisfy predicate = liftPositive (Char.satisfy predicate)    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint (Fixed Backtrack.Parser) g s, Show s, TextualMonoid s) =>-         TokenParsing (Fixed Backtrack.Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--instance (Lexical g, LexicalConstraint (Fixed Memoizing.Parser) g s, Show s, TextualMonoid s) =>-         TokenParsing (Fixed Memoizing.Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--instance AmbiguousParsing (Fixed Memoizing.Parser g s) where+instance AmbiguousParsing (p g s) => AmbiguousParsing (Fixed p g s) where    ambiguous (PositiveDirectParser p) = PositiveDirectParser (ambiguous p)    ambiguous p@DirectParser{} = DirectParser{complete= ambiguous (complete p),                                              direct0=  ambiguous (direct0 p),@@ -562,18 +573,8 @@                                  direct0=  ambiguous (direct0 p),                                  direct1=  ambiguous (direct1 p),                                  indirect= ambiguous (indirect p),-                                 appendResults= appendAmbiguous,+                                 isAmbiguous= Just (AmbiguityWitness Refl),                                  cyclicDescendants= cyclicDescendants p}-      where appendAmbiguous (ResultList rl1 f1) (ResultList rl2 f2) = ResultList (join rl1 rl2) (f1 <> f2)-            join [] rl = rl-            join rl [] = rl-            join rl1'@(rol1@(ResultsOfLength l1 s1 r1) : rest1) rl2'@(rol2@(ResultsOfLength l2 _ r2) : rest2)-               | l1 < l2 = rol1 : join rest1 rl2'-               | l1 > l2 = rol2 : join rl1' rest2-               | Ambiguous ar1 :| [] <- r1,-                 Ambiguous ar2 :| [] <- r2 =-                    ResultsOfLength l1 s1 (Ambiguous (ar1 <> ar2) :| []) : join rest1 rest2-               | otherwise = error "Ambiguous results should be grouped as a single value"    {-# INLINABLE ambiguous #-}  -- | Turns a context-free parser into a backtracking PEG parser that consumes the longest possible prefix of the list@@ -588,7 +589,7 @@                             direct0=  Memoizing.longest (direct0 p),                             direct1=  Memoizing.longest (direct1 p),                             indirect=  Memoizing.longest (indirect p),-                            appendResults= (<>),+                            isAmbiguous= Nothing,                             cyclicDescendants= cyclicDescendants p}  -- | Turns a backtracking PEG parser of the list of input tails into a context-free parser, opposite of 'longest'@@ -602,7 +603,7 @@                         direct0=  Memoizing.peg (direct0 p),                         direct1=  Memoizing.peg (direct1 p),                         indirect=  Memoizing.peg (indirect p),-                        appendResults= (<>),+                        isAmbiguous= Nothing,                         cyclicDescendants= cyclicDescendants p}  -- | Turns a backtracking PEG parser into a context-free parser@@ -616,30 +617,39 @@                                 direct0=  Memoizing.terminalPEG (direct0 p),                                 direct1=  Memoizing.terminalPEG (direct1 p),                                 indirect=  Memoizing.terminalPEG (indirect p),-                                appendResults= (<>),+                                isAmbiguous= Nothing,                                 cyclicDescendants= cyclicDescendants p} -parseRecursive :: forall g s. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, FactorialMonoid s) =>-                  g (Parser g s) -> s -> [(s, g (ResultList g s))]+parseRecursive :: forall p g s rl. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g,+                                    Eq s, FactorialMonoid s, LeftReductive s, Alternative (p g s),+                                    TailsParsing (p g s), GrammarConstraint (p g s) g,+                                    s ~ ParserInput (p g s), GrammarFunctor (p g s) ~ rl s, FallibleWithExpectations rl,+                                    AmbiguousAlternative (GrammarFunctor (p g s))) =>+                  g (Fixed p g s) -> s -> [(s, g (GrammarFunctor (p g s)))] parseRecursive = parseSeparated . separated {-# INLINE parseRecursive #-} -separated :: forall g s. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g) =>-             g (Parser g s) -> g (SeparatedParser Memoizing.Parser g s)+separated :: forall p g s. (Alternative (p g s), Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g,+                            AmbiguousAlternative (GrammarFunctor (p g s))) =>+             g (Fixed p g s) -> g (SeparatedParser p g s) separated g = Rank2.liftA4 reseparate circulars cycleFollowers descendants g    where descendants :: g (Const (g (Const Bool)))          cycleFollowers, circulars :: g (Const Bool)          cyclicDescendantses :: g (Const (ParserFlags g))+         appendResults :: forall a. Maybe (AmbiguityWitness a)+                       -> GrammarFunctor (p g s) a -> GrammarFunctor (p g s) a -> GrammarFunctor (p g s) a          leftRecursive :: forall a. Const (g (Const Bool)) a -> Const (ParserFlags g) a -> Const Bool a          leftRecursiveDeps :: forall a. Const Bool a -> Const (ParserFlags g) a -> Const (g (Const Bool)) a-         reseparate :: forall a. Const Bool a -> Const Bool a -> Const (g (Const Bool)) a -> Parser g s a-                    -> SeparatedParser Memoizing.Parser g s a+         reseparate :: forall a. Const Bool a -> Const Bool a -> Const (g (Const Bool)) a -> Fixed p g s a+                    -> SeparatedParser p g s a          reseparate (Const circular) (Const follower) (Const deps) p             | circular || leader && follower =-              CycleParser (indirect p) (direct p) (Rank2.Arrow (Rank2.Arrow . appendResults p)) deps+              CycleParser (indirect p) (direct p) (Rank2.Arrow (Rank2.Arrow . appendResults (isAmbiguous p))) deps             | follower = BackParser (complete p)             | otherwise = FrontParser (complete p)             where leader = getAny (Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection circulars deps)+         appendResults (Just (AmbiguityWitness Refl)) = ambiguousOr+         appendResults Nothing = (<|>)          descendants = Rank2.fmap (Const . dependsOn . getConst) cyclicDescendantses          cyclicDescendantses = fixDescendants (Rank2.fmap (Const . cyclicDescendants . general) g)          circulars = Rank2.liftA2 leftRecursive bits cyclicDescendantses@@ -684,37 +694,40 @@ -- | Parse the given input using a context-free grammar separated into two parts: the first specifying all the -- left-recursive productions, the second all others. The first function argument specifies the left-recursive -- dependencies among the grammar productions.-parseSeparated :: forall g s. (Rank2.Apply g, Rank2.Foldable g, FactorialMonoid s) =>-                  g (SeparatedParser Memoizing.Parser g s) -> s -> [(s, g (ResultList g s))]+parseSeparated :: forall p g rl s. (Rank2.Apply g, Rank2.Foldable g, Eq s, FactorialMonoid s, LeftReductive s,+                                    TailsParsing (p g s), GrammarConstraint (p g s) g,+                                    GrammarFunctor (p g s) ~ rl s, FallibleWithExpectations rl,+                                    s ~ ParserInput (p g s)) =>+                  g (SeparatedParser p g s) -> s -> [(s, g (GrammarFunctor (p g s)))] parseSeparated parsers input = foldr parseTail [] (Factorial.tails input)    where parseTail s parsedTail = parsed             where parsed = (s,d''):parsedTail-                  d      = Rank2.fmap (($ (s,d):parsedTail) . Memoizing.applyParser) directs+                  d      = Rank2.fmap (($ (s,d):parsedTail) . parseTails) directs                   d'     = fixRecursive s parsedTail d                   d''    = Rank2.liftA2 f parsers d'-                  f :: forall a. SeparatedParser Memoizing.Parser g s a -> ResultList g s a -> ResultList g s a-                  f (FrontParser p) _ = Memoizing.applyParser p ((s,d''):parsedTail)+                  f :: forall a. SeparatedParser p g s a -> GrammarFunctor (p g s) a -> GrammarFunctor (p g s) a+                  f (FrontParser p) _ = parseTails p ((s,d''):parsedTail)                   f _ result = result-         fixRecursive :: s -> [(s, g (ResultList g s))] -> g (ResultList g s) -> g (ResultList g s)-         whileAnyContinues :: (g (ResultList g s) -> g (ResultList g s))-                           -> (g (ResultList g s) -> g (ResultList g s))-                           -> g (ResultList g s) -> g (ResultList g s) -> g (ResultList g s)-         recurseTotal :: s -> g (ResultList g s Rank2.~> ResultList g s) -> [(s, g (ResultList g s))]-                      -> g (ResultList g s)-                      -> g (ResultList g s)-         recurseMarginal :: s -> [(s, g (ResultList g s))]-                      -> g (ResultList g s)-                      -> g (ResultList g s)+         fixRecursive :: s -> [(s, g (GrammarFunctor (p g s)))] -> g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s))+         whileAnyContinues :: (g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s)))+                           -> (g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s)))+                           -> g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s)) -> g (GrammarFunctor (p g s))+         recurseTotal :: s -> g (GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s)) -> [(s, g (GrammarFunctor (p g s)))]+                      -> g (GrammarFunctor (p g s))+                      -> g (GrammarFunctor (p g s))+         recurseMarginal :: s -> [(s, g (GrammarFunctor (p g s)))]+                      -> g (GrammarFunctor (p g s))+                      -> g (GrammarFunctor (p g s))          maybeDependencies :: g (Const (Maybe (g (Const Bool))))-         maybeDependency :: SeparatedParser Memoizing.Parser g s r -> Const (Maybe (g (Const Bool))) r-         appends :: g (ResultAppend g s)-         parserAppend :: SeparatedParser Memoizing.Parser g s r -> ResultAppend g s r+         maybeDependency :: SeparatedParser p g s r -> Const (Maybe (g (Const Bool))) r+         appends :: g (ResultAppend p g s)+         parserAppend :: SeparatedParser p g s r -> ResultAppend p g s r           directs = Rank2.fmap backParser parsers          indirects = Rank2.fmap (\p-> case p of {CycleParser{}-> cycleParser p; _ -> empty}) parsers          appends = Rank2.fmap parserAppend parsers          parserAppend p@CycleParser{} = appendResultsArrow p-         parserAppend _ = Rank2.Arrow (Rank2.Arrow . (<>))+         parserAppend _ = Rank2.Arrow (Rank2.Arrow . const)          maybeDependencies = Rank2.fmap maybeDependency parsers          maybeDependency p@CycleParser{} = Const (Just $ dependencies p)          maybeDependency _ = Const Nothing@@ -727,30 +740,42 @@          whileAnyContinues ft fm total marginal =             Rank2.liftA3 choiceWhile maybeDependencies total (whileAnyContinues ft fm (ft total) (fm marginal))             where choiceWhile :: Const (Maybe (g (Const Bool))) x-                              -> ResultList g s x -> ResultList g s x-                              -> ResultList g s x+                              -> GrammarFunctor (p g s) x -> GrammarFunctor (p g s) x+                              -> GrammarFunctor (p g s) x                   choiceWhile (Const Nothing) t _ = t                   choiceWhile (Const (Just deps)) t t'                      | getAny (Rank2.foldMap (Any . getConst) (Rank2.liftA2 combine deps marginal)) = t'-                     | ResultList [] (Memoizing.FailureInfo _ expected) <- t =-                        let ResultList _ (Memoizing.FailureInfo pos expected') =-                               if getAny (Rank2.foldMap (Any . getConst) $-                                          Rank2.liftA2 (combineFailures expected) deps marginal)-                                  then t' else t-                        in ResultList [] (Memoizing.FailureInfo pos expected')-                     | otherwise = t-                     where combine :: Const Bool x -> ResultList g s x -> Const Bool x-                           combineFailures :: [String] -> Const Bool x -> ResultList g s x -> Const Bool x+                     | hasSuccess t = t+                     | otherwise =+                        let expected = expectations t+                            FailureInfo pos expected' =+                               failureOf (if getAny (Rank2.foldMap (Any . getConst) $+                                                     Rank2.liftA2 (combineFailures expected) deps marginal)+                                          then t' else t)+                        in failWith (FailureInfo pos expected')+                     where combine :: Const Bool x -> GrammarFunctor (p g s) x -> Const Bool x+                           combineFailures :: [Expected s] -> Const Bool x -> GrammarFunctor (p g s) x -> Const Bool x                            combine (Const False) _ = Const False-                           combine (Const True) (ResultList [] _) = Const False-                           combine (Const True) _ = Const True+                           combine (Const True) results = Const (hasSuccess results)                            combineFailures _ (Const False) _ = Const False-                           combineFailures expected (Const True) (ResultList _ (Memoizing.FailureInfo _ expected'))-                              = Const (any (`notElem` expected) expected')+                           combineFailures expected (Const True) rl = Const (any (`notElem` expected) $ expectations rl)           recurseTotal s initialAppends parsedTail total = Rank2.liftA2 reparse initialAppends indirects-            where reparse :: (ResultList g s Rank2.~> ResultList g s) a -> Memoizing.Parser g s a -> ResultList g s a-                  reparse append p = Rank2.apply append (Memoizing.applyParser p $ (s, total) : parsedTail)+            where reparse :: (GrammarFunctor (p g s) Rank2.~> GrammarFunctor (p g s)) a -> p g s a -> GrammarFunctor (p g s) a+                  reparse append p = Rank2.apply append (parseTails p $ (s, total) : parsedTail)          recurseMarginal s parsedTail marginal =-            flip Memoizing.applyParser ((s, marginal) : parsedTail) Rank2.<$> indirects+            flip parseTails ((s, marginal) : parsedTail) Rank2.<$> indirects {-# NOINLINE parseSeparated #-}++class FallibleWithExpectations f where+   hasSuccess   :: f s a -> Bool+   failureOf    :: f s a -> FailureInfo s+   failWith     :: FailureInfo s -> f s a+   expectations :: f s a -> [Expected s]++instance FallibleWithExpectations (ResultList g) where+   hasSuccess (ResultList [] _) = False+   hasSuccess _ = True+   failureOf (ResultList _ failure) = failure+   failWith = ResultList []+   expectations (ResultList _ (FailureInfo _ expected)) = expected

@@ -0,0 +1,26 @@+module Text.Grampa.ContextFree.LeftRecursive.Transformer (ParserT, SeparatedParser(..),+                                                          lift, liftPositive, tmap,+                                                          parseSeparated, separated)+where++import Text.Grampa.ContextFree.LeftRecursive (Fixed, SeparatedParser(..), FallibleWithExpectations(..),+                                              liftPositive, liftPure, mapPrimitive, parseSeparated, separated)+import qualified Text.Grampa.ContextFree.SortedMemoizing.Transformer as Transformer+import Text.Grampa.ContextFree.SortedMemoizing.Transformer (ResultListT(ResultList), FailureInfo(FailureInfo))++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 = liftPure . Transformer.lift++-- | Modify the computation carried by the parser.+tmap :: (m a -> m a) -> ParserT m g s a -> ParserT m g s a+tmap = mapPrimitive . Transformer.tmap++instance FallibleWithExpectations (ResultListT m g) where+   hasSuccess (ResultList [] _) = False+   hasSuccess _ = True+   failureOf (ResultList _ failure) = failure+   failWith = ResultList []+   expectations (ResultList _ (FailureInfo _ expected)) = expected

@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,              RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}-module Text.Grampa.ContextFree.Memoizing (FailureInfo(..), ResultList(..), Parser(..), BinTree(..), (<<|>),+module Text.Grampa.ContextFree.Memoizing (FailureInfo(..), ResultList(..), Parser(..), BinTree(..),                                           fromResultList, reparseTails, longest, peg, terminalPEG) where @@ -11,27 +11,26 @@ import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (genericLength, maximumBy, nub)-import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(mappend, mempty))-import Data.Monoid.Cancellative (isPrefixOf) 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.Semigroup (Semigroup((<>)))+import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString)  import qualified Text.Parser.Char import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token  import qualified Rank2 -import Text.Grampa.Class (Lexical(..), GrammarParsing(..), MonoidParsing(..), MultiParsing(..), -                          ParseResults, ParseFailure(..))+import Text.Grampa.Class (GrammarParsing(..), MultiParsing(..),+                          DeterministicParsing(..), InputParsing(..), InputCharParsing(..),+                          TailsParsing(parseTails), ParseResults, ParseFailure(..), Expected(..)) import Text.Grampa.Internal (BinTree(..), FailureInfo(..)) import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack @@ -41,17 +40,17 @@ -- 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+data ResultList g s r = ResultList !(BinTree (ResultInfo g s r)) {-# UNPACK #-} !(FailureInfo s) data ResultInfo g s r = ResultInfo !Int ![(s, g (ResultList g s))] !r -instance Show r => Show (ResultList g s r) where+instance (Show s, Show r) => Show (ResultList g s r) where    show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")") -instance Show1 (ResultList g s) where+instance Show s => Show1 (ResultList g s) where    liftShowsPrec _sp showList _prec (ResultList l f) rest = "ResultList " ++ showList (simplify <$> toList l) (shows f rest)       where simplify (ResultInfo _ _ r) = r -instance Show r => Show (ResultInfo g s r) where+instance (Show s, Show r) => Show (ResultInfo g s r) where    show (ResultInfo l _ r) = "(ResultInfo @" ++ show l ++ " " ++ shows r ")"  instance Functor (ResultInfo g s) where@@ -83,18 +82,11 @@    {-# INLINABLE (<*>) #-}  instance Alternative (Parser g i) where-   empty = Parser (\rest-> ResultList mempty $ FailureInfo (genericLength rest) ["empty"])+   empty = Parser (\rest-> ResultList mempty $ FailureInfo (genericLength rest) [Expected "empty"])    Parser p <|> Parser q = Parser r where       r rest = p rest <> q rest    {-# INLINABLE (<|>) #-} -infixl 3 <<|>-(<<|>) :: Parser g s a -> Parser g s a -> Parser g s a-Parser p <<|> Parser q = Parser r where-   r rest = case p rest-            of rl@(ResultList EmptyTree _failure) -> rl <> q rest-               rl -> rl- instance Monad (Parser g i) where    return = pure    Parser p >>= f = Parser q where@@ -115,32 +107,38 @@    mempty = pure mempty    mappend = liftA2 mappend -instance GrammarParsing Parser where-   type GrammarFunctor Parser = ResultList+instance (Eq s, LeftReductive s, FactorialMonoid s) => GrammarParsing (Parser g s) where+   type ParserGrammar (Parser g s) = g+   type GrammarFunctor (Parser g s) = ResultList g s+   parsingResult s = Compose . fromResultList s    nonTerminal f = Parser p where       p ((_, d) : _) = f d-      p _ = ResultList mempty (FailureInfo 0 ["NonTerminal at endOfInput"])+      p _ = ResultList mempty (FailureInfo 0 [Expected "NonTerminal at endOfInput"])    {-# INLINE nonTerminal #-} +instance (Eq s, LeftReductive s, FactorialMonoid s) => TailsParsing (Parser g s) where+   parseTails = applyParser+ -- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions, but provides no left -- recursion support. -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>---                  g (Memoizing.'Parser' g s) -> s -> g ('Compose' 'ParseResults' [])+--                  g (Memoizing.'Parser' g s) -> s -> g ('Compose' ('ParseResults' s) []) -- @-instance MultiParsing Parser where-   type ResultFunctor Parser = Compose ParseResults []+instance (LeftReductive s, FactorialMonoid 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 $ parseTails g input)-   parseComplete :: forall g s. (Rank2.Functor g, FactorialMonoid s) =>-                    g (Parser g s) -> s -> g (Compose ParseResults [])+   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)-                              (snd $ head $ reparseTails close $ parseTails g input)-      where close = Rank2.fmap (<* endOfInput) g+                              (snd $ head $ reparseTails close $ parseGrammarTails g input)+      where close = Rank2.fmap (<* eof) g -parseTails :: (Rank2.Functor g, FactorialMonoid s) => g (Parser g s) -> s -> [(s, g (ResultList g s))]-parseTails g input = foldr parseTail [] (Factorial.tails input)+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@@ -150,44 +148,33 @@ reparseTails final parsed@((s, _):_) = (s, gd):parsed    where gd = Rank2.fmap (`applyParser` parsed) final -instance MonoidParsing (Parser g) where-   endOfInput = eof+instance (LeftReductive s, FactorialMonoid 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             p [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty    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) ["anyToken"])-            p [] = ResultList mempty (FailureInfo 0 ["anyToken"])+                                   _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "anyToken"])+            p [] = ResultList mempty (FailureInfo 0 [Expected "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) ["satisfy"])-            p [] = ResultList mempty (FailureInfo 0 ["satisfy"])-   satisfyChar 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) ["satisfyChar"])-            p [] = ResultList mempty (FailureInfo 0 ["satisfyChar"])-   satisfyCharInput predicate = Parser p-      where p rest@((s, _):t) =-               case Textual.characterPrefix s-               of Just first | predicate first -> ResultList (Leaf $ ResultInfo 1 t $ Factorial.primePrefix s) mempty-                  _ -> ResultList mempty (FailureInfo (genericLength rest) ["satisfyCharInput"])-            p [] = ResultList mempty (FailureInfo 0 ["satisfyCharInput"])+                  _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "satisfy"])+            p [] = ResultList mempty (FailureInfo 0 [Expected "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                      l = Factorial.length prefix             p _ [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty-   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-                     l = Factorial.length prefix-            p _ [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty+   take 0 = mempty+   take n = Parser p+      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])    takeWhile predicate = Parser p       where p rest@((s, _) : _)                | x <- Factorial.takeWhile predicate s, l <- Factorial.length x =@@ -197,7 +184,31 @@       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) ["takeWhile1"])+            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected "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])+      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"])+            p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty+   {-# INLINABLE string #-}++instance (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"])+   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+                     l = Factorial.length prefix+            p _ [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty    takeCharsWhile predicate = Parser p       where p rest@((s, _) : _)                | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x =@@ -207,23 +218,12 @@       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) ["takeCharsWhile1"])-   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) ["string " ++ show s])-      l = Factorial.length s-   notSatisfy predicate = Parser p-      where p rest@((s, _):_)-               | Just (first, _) <- splitPrimePrefix s, -                 predicate first = ResultList mempty (FailureInfo (genericLength rest) ["notSatisfy"])-            p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty+            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected "takeCharsWhile1"])    notSatisfyChar predicate = Parser p       where p rest@((s, _):_)                | Just first <- Textual.characterPrefix s, -                 predicate first = ResultList mempty (FailureInfo (genericLength rest) ["notSatisfyChar"])+                 predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfyChar"])             p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty-   {-# INLINABLE string #-}  instance MonoidNull s => Parsing (Parser g s) where    try (Parser p) = Parser q@@ -233,41 +233,54 @@    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 [msg] else msgs)+                        ResultList EmptyTree (FailureInfo pos $ if pos == genericLength rest then [Expected msg] else msgs)                      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) ["notFollowedBy"])+            rewind t ResultList{} = ResultList mempty (FailureInfo (genericLength t) [Expected "notFollowedBy"])    skipMany p = go       where go = pure () <|> p *> go-   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (genericLength t) [msg])+   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (genericLength t) [Expected msg])    eof = Parser f       where f rest@((s, _):_)                | null s = ResultList (Leaf $ ResultInfo 0 rest ()) mempty-               | otherwise = ResultList mempty (FailureInfo (genericLength rest) ["endOfInput"])+               | otherwise = ResultList mempty (FailureInfo (genericLength rest) [Expected "endOfInput"])             f [] = ResultList (Leaf $ ResultInfo 0 [] ()) mempty +instance MonoidNull 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+                  rl -> rl+   takeSome p = (:) <$> p <*> takeMany p+   takeMany (Parser p) = Parser (q 0 id) where+      q len acc rest = case p rest+                       of ResultList EmptyTree _failure -> ResultList (Leaf $ ResultInfo len rest (acc [])) mempty+                          ResultList rl _ -> foldMap continue rl+         where continue (ResultInfo len' rest' result) = q (len + len') (acc . (result:)) rest'+   skipAll (Parser p) = Parser (q 0) where+      q len rest = case p rest+                   of ResultList EmptyTree _failure -> ResultList (Leaf $ ResultInfo len rest ()) mempty+                      ResultList rl _failure -> foldMap continue rl+         where continue (ResultInfo len' rest' _) = q (len + len') rest'+ instance MonoidNull s => LookAheadParsing (Parser g s) where    lookAhead (Parser p) = Parser (\input-> rewind input (p input))       where rewind t (ResultList rl failure) = ResultList (rewindInput t <$> rl) failure             rewindInput t (ResultInfo _ _ r) = ResultInfo 0 t r  instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where-   satisfy = satisfyChar+   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"])    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint Parser g s, Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--fromResultList :: FactorialMonoid s => s -> ResultList g s r -> ParseResults [(s, r)]-fromResultList s (ResultList EmptyTree (FailureInfo pos msgs)) =-   Left (ParseFailure (length s - pos + 1) (nub msgs))+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)    where f (ResultInfo _ ((s, _):_) r) = (s, r)          f (ResultInfo _ [] r) = (mempty, r)@@ -277,17 +290,19 @@ 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 failure -> Backtrack.NoParse failure+            of ResultList EmptyTree (FailureInfo pos expected) -> Backtrack.NoParse (FailureInfo pos $ map message expected)                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")]  -- | Turns a backtracking PEG parser of the list of input tails into a context-free parser, opposite of 'longest' peg :: Backtrack.Parser g [(s, g (ResultList g s))] a -> Parser g s a peg p = Parser q where    q rest = case Backtrack.applyParser p rest             of Backtrack.Parsed l result suffix -> ResultList (Leaf $ ResultInfo l suffix result) mempty-               Backtrack.NoParse failure -> ResultList mempty failure+               Backtrack.NoParse (FailureInfo pos expected) -> ResultList mempty (FailureInfo pos ((fst . head <$>) <$> expected))  -- | Turns a backtracking PEG parser into a context-free parser terminalPEG :: Monoid s => Backtrack.Parser g s a -> Parser g s a

@@ -10,11 +10,11 @@ import Data.Functor.Compose (Compose(..)) import Data.List (nub) import Data.Semigroup (Semigroup(..))+import qualified Data.Semigroup.Cancellative as Cancellative import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Null (MonoidNull(null)) import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid)-import qualified Data.Monoid.Cancellative as Cancellative import qualified Data.Monoid.Null as Null import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Textual as Textual@@ -24,13 +24,12 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token  import qualified Rank2 -import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))-import Text.Grampa.Internal (BinTree(..))+import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          ParseResults, ParseFailure(..), Expected(..))+import Text.Grampa.Internal (BinTree(..), FailureInfo(..), noFailure)  import Prelude hiding (iterate, null, showList, span, takeWhile) @@ -38,14 +37,13 @@ -- support. newtype Parser (g :: (* -> *) -> *) s r = Parser{applyParser :: s -> ResultList s r} -data ResultList s r = ResultList !(BinTree (ResultInfo s r)) {-# UNPACK #-} !FailureInfo+data ResultList s r = ResultList !(BinTree (ResultInfo s r)) {-# UNPACK #-} !(FailureInfo s) data ResultInfo s r = ResultInfo !s !r-data FailureInfo = FailureInfo Int [String] deriving (Eq, Show)  instance (Show s, Show r) => Show (ResultList s r) where    show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")") -instance Show1 (ResultList s) where+instance Show s => Show1 (ResultList s) where    liftShowsPrec _sp showList _prec (ResultList l f) rest = "ResultList " ++ showList (simplify <$> toList l) (shows f rest)       where simplify (ResultInfo _ r) = r @@ -62,24 +60,14 @@    ResultList rl1 f1 <> ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2)  instance Monoid (ResultList s r) where-   mempty = ResultList mempty mempty-   mappend = (<>)--instance Semigroup FailureInfo 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)--instance Monoid FailureInfo where-   mempty = FailureInfo maxBound []+   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-   pure a = Parser (\rest-> ResultList (Leaf $ ResultInfo rest a) mempty)+   pure a = Parser (\rest-> ResultList (Leaf $ ResultInfo rest a) noFailure)    Parser p <*> Parser q = Parser r where       r rest = case p rest                of ResultList results failure -> ResultList mempty failure <> foldMap continue results@@ -87,7 +75,7 @@   instance FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\s-> ResultList mempty $ FailureInfo (Factorial.length s) ["empty"])+   empty = Parser (\s-> ResultList mempty $ FailureInfo (Factorial.length s) [Expected "empty"])    Parser p <|> Parser q = Parser r where       r rest = p rest <> q rest @@ -112,80 +100,78 @@ -- | Parallel parser produces a list of all possible parses. -- -- @--- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>---                  g (Parallel.'Parser' g s) -> s -> g ('Compose' 'ParseResults' [])+-- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, Eq s, 'FactorialMonoid' s) =>+--                  g (Parallel.'Parser' g s) -> s -> g ('Compose' ('ParseResults' s) []) -- @-instance MultiParsing Parser where-   type ResultFunctor Parser = Compose ParseResults []+instance (Cancellative.LeftReductive s, FactorialMonoid 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    -- | Returns the list of all possible parses of complete input.-   parseComplete :: forall g s. (Rank2.Functor g, FactorialMonoid s) =>-                    g (Parser g s) -> s -> g (Compose ParseResults [])-   parseComplete g input = Rank2.fmap ((snd <$>) . getCompose) (parsePrefix (Rank2.fmap (<* endOfInput) 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 <$>) . getCompose) (parsePrefix (Rank2.fmap (<* eof) g) input) -instance MonoidParsing (Parser g) where-   endOfInput = Parser f-      where f s | null s = ResultList (Leaf $ ResultInfo s ()) mempty-                | otherwise = ResultList mempty (FailureInfo (Factorial.length s) ["endOfInput"])+instance (Cancellative.LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+   type ParserInput (Parser g s) = s    getInput = Parser p-      where p s = ResultList (Leaf $ ResultInfo s s) mempty+      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) mempty-                     _ -> ResultList mempty (FailureInfo (Factorial.length s) ["anyToken"])+                  of Just (first, rest) -> ResultList (Leaf $ ResultInfo rest first) noFailure+                     _ -> ResultList mempty (FailureInfo (Factorial.length s) [Expected "anyToken"])    satisfy predicate = Parser p       where p s = case Factorial.splitPrimePrefix s-                  of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) mempty-                     _ -> ResultList mempty (FailureInfo (Factorial.length s) ["satisfy"])-   satisfyChar predicate = Parser p-      where p s =-               case Textual.splitCharacterPrefix s-               of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) mempty-                  _ -> ResultList mempty (FailureInfo (Factorial.length s) ["satisfyChar"])-   satisfyCharInput predicate = Parser p-      where p s =-               case Textual.splitCharacterPrefix s-               of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest $ Factorial.primePrefix s) mempty-                  _ -> ResultList mempty (FailureInfo (Factorial.length s) ["satisfyChar"])+                  of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) noFailure+                     _ -> ResultList mempty (FailureInfo (Factorial.length s) [Expected "satisfy"])    notSatisfy predicate = Parser p       where p s = case Factorial.splitPrimePrefix s                   of Just (first, _) -                        | predicate first -> ResultList mempty (FailureInfo (Factorial.length s) ["notSatisfy"])-                     _ -> ResultList (Leaf $ ResultInfo s ()) mempty-   notSatisfyChar predicate = Parser p-      where p s = case Textual.characterPrefix s-                  of Just first -                        | predicate first -> ResultList mempty (FailureInfo (Factorial.length s) ["notSatisfyChar"])-                     _ -> ResultList (Leaf $ ResultInfo s ()) mempty+                        | predicate first -> ResultList mempty (FailureInfo (Factorial.length s) [Expected "notSatisfy"])+                     _ -> ResultList (Leaf $ ResultInfo s ()) noFailure    scan s0 f = Parser (p s0)-      where p s i = ResultList (Leaf $ ResultInfo suffix prefix) mempty+      where p s i = ResultList (Leaf $ ResultInfo suffix prefix) noFailure                where (prefix, suffix, _) = Factorial.spanMaybe' s f i-   scanChars s0 f = Parser (p s0)-      where p s i = ResultList (Leaf $ ResultInfo suffix prefix) mempty-               where (prefix, suffix, _) = Textual.spanMaybe_' s f i+   take n = Parser p+      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])    takeWhile predicate = Parser p-      where p s | (prefix, suffix) <- Factorial.span predicate s = ResultList (Leaf $ ResultInfo suffix prefix) mempty+      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) ["takeWhile1"])-               else ResultList (Leaf $ ResultInfo suffix prefix) mempty+               then ResultList mempty (FailureInfo (Factorial.length s) [Expected "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])++instance 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"])+   notSatisfyChar predicate = Parser p+      where p s = case Textual.characterPrefix s+                  of Just first +                        | predicate first -> ResultList mempty (FailureInfo (Factorial.length s) [Expected "notSatisfyChar"])+                     _ -> ResultList (Leaf $ ResultInfo s ()) noFailure+   scanChars s0 f = Parser (p s0)+      where p s i = ResultList (Leaf $ ResultInfo suffix prefix) noFailure+               where (prefix, suffix, _) = Textual.spanMaybe_' s f i    takeCharsWhile predicate = Parser p       where p s | (prefix, suffix) <- Textual.span_ False predicate s = -               ResultList (Leaf $ ResultInfo suffix prefix) mempty+               ResultList (Leaf $ ResultInfo suffix prefix) noFailure    takeCharsWhile1 predicate = Parser p       where p s | (prefix, suffix) <- Textual.span_ False predicate s =                if null prefix-               then ResultList mempty (FailureInfo (Factorial.length s) ["takeCharsWhile1"])-               else ResultList (Leaf $ ResultInfo suffix prefix) mempty-   string s = Parser p where-      p s' | Just suffix <- Cancellative.stripPrefix s s' = ResultList (Leaf $ ResultInfo suffix s) mempty-           | otherwise = ResultList mempty (FailureInfo (Factorial.length s') ["string " ++ show s])-   concatMany (Parser p) = Parser q-      where q s = ResultList (Leaf $ ResultInfo s mempty) failure <> foldMap continue rs-               where ResultList rs failure = p s-            continue (ResultInfo suffix prefix) = mappend prefix <$> q suffix+               then ResultList mempty (FailureInfo (Factorial.length s) [Expected "takeCharsWhile1"])+               else ResultList (Leaf $ ResultInfo suffix prefix) noFailure  instance FactorialMonoid s => Parsing (Parser g s) where    try (Parser p) = Parser q@@ -196,35 +182,50 @@       where q rest = replaceFailure (p rest)                where replaceFailure (ResultList EmptyTree (FailureInfo pos msgs)) =                         ResultList EmptyTree (FailureInfo pos $-                                              if pos == Factorial.length rest then [msg] else msgs)+                                              if pos == Factorial.length rest then [Expected msg] else msgs)                      replaceFailure rl = rl    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))-      where rewind t (ResultList EmptyTree _) = ResultList (Leaf $ ResultInfo t ()) mempty-            rewind t ResultList{} = ResultList mempty (FailureInfo (Factorial.length t) ["notFollowedBy"])+      where rewind t (ResultList EmptyTree _) = ResultList (Leaf $ ResultInfo t ()) noFailure+            rewind t ResultList{} = ResultList mempty (FailureInfo (Factorial.length t) [Expected "notFollowedBy"])    skipMany p = go-      where go = pure () <|> p *> go-   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (Factorial.length t) [msg])-   eof = endOfInput+      where go = pure () <|> try p *> go+   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (Factorial.length t) [Expected 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"]) +instance FactorialMonoid 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+                  rl -> rl+   takeSome p = (:) <$> p <*> takeMany p+   takeMany (Parser p) = Parser (q id) where+      q acc rest = case p rest+                   of ResultList EmptyTree _failure -> ResultList (Leaf $ ResultInfo rest (acc [])) mempty+                      ResultList rl _ -> foldMap continue rl+         where continue (ResultInfo rest' result) = q (acc . (result:)) rest'+   skipAll (Parser p) = Parser q where+      q rest = case p rest+               of ResultList EmptyTree _failure -> ResultList (Leaf $ ResultInfo rest ()) mempty+                  ResultList rl _failure -> foldMap continue rl+         where continue (ResultInfo rest' _) = q rest'+ instance FactorialMonoid 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 (Show s, TextualMonoid s) => CharParsing (Parser g s) where-   satisfy = satisfyChar+instance TextualMonoid 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"])    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint Parser g s, Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--fromResultList :: FactorialMonoid s => s -> ResultList s r -> ParseResults [(s, r)]+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)

@@ -1,8 +1,8 @@-{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,+{-# LANGUAGE BangPatterns, FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,              RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} module Text.Grampa.ContextFree.SortedMemoizing -       (FailureInfo(..), ResultList(..), Parser(..), (<<|>),-        reparseTails, longest, peg, terminalPEG)+       (FailureInfo(..), ResultList(..), Parser(..),+        longest, peg, terminalPEG) where  import Control.Applicative@@ -10,28 +10,27 @@ import Data.Functor.Compose (Compose(..)) import Data.List (genericLength) import Data.List.NonEmpty (NonEmpty((:|)))-import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(mappend, mempty))-import Data.Monoid.Cancellative (isPrefixOf) 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.Semigroup (Semigroup((<>)))+import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString)  import qualified Text.Parser.Char import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token  import qualified Rank2 -import Text.Grampa.Class (Lexical(..), GrammarParsing(..), MonoidParsing(..), MultiParsing(..), AmbiguousParsing(..),-                          Ambiguous(Ambiguous), ParseResults)+import Text.Grampa.Class (GrammarParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          AmbiguousParsing(..), Ambiguous(Ambiguous),+                          ConsumedInputParsing(..), DeterministicParsing(..),+                          TailsParsing(parseTails, parseAllTails), ParseResults, Expected(..)) import Text.Grampa.Internal (FailureInfo(..), ResultList(..), ResultsOfLength(..), fromResultList) import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack @@ -63,13 +62,6 @@    {-# INLINE (<|>) #-}    {-# INLINABLE empty #-} -infixl 3 <<|>-(<<|>) :: Parser g s a -> Parser g s a -> Parser g s a-Parser p <<|> Parser q = Parser r where-   r rest = case p rest-            of rl@(ResultList [] _failure) -> rl <> q rest-               rl -> rl- instance Monad (Parser g i) where    return = pure    (>>) = (*>)@@ -91,79 +83,70 @@    mempty = pure mempty    mappend = liftA2 mappend -instance GrammarParsing Parser where-   type GrammarFunctor Parser = ResultList+instance (Eq s, LeftReductive s, FactorialMonoid s) => GrammarParsing (Parser g s) where+   type ParserGrammar (Parser g s) = g+   type GrammarFunctor (Parser g s) = ResultList g s+   parsingResult s = Compose . fromResultList s+   nonTerminal :: (Rank2.Functor g, ParserInput (Parser g s) ~ s) => (g (ResultList g s) -> ResultList g s a) -> Parser g s a    nonTerminal f = Parser p where       p ((_, d) : _) = f d-      p _ = ResultList mempty (FailureInfo 0 ["NonTerminal at endOfInput"])+      p _ = ResultList mempty (FailureInfo 0 [Expected "NonTerminal at endOfInput"])    {-# INLINE nonTerminal #-} +instance (Eq s, LeftReductive s, FactorialMonoid s) => TailsParsing (Parser g s) where+   parseTails = applyParser+ -- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions, but provides no left -- recursion support. -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>---                  g (Memoizing.'Parser' g s) -> s -> g ('Compose' 'ParseResults' [])+--                  g (Memoizing.'Parser' g s) -> s -> g ('Compose' ('ParseResults' s) []) -- @-instance MultiParsing Parser where-   type ResultFunctor Parser = Compose ParseResults []+instance (LeftReductive s, FactorialMonoid 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 $ parseTails g input)-   parseComplete :: forall g s. (Rank2.Functor g, FactorialMonoid s) =>-                    g (Parser g s) -> s -> g (Compose ParseResults [])+   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)-                              (snd $ head $ reparseTails close $ parseTails g input)-      where close = Rank2.fmap (<* endOfInput) g+                              (snd $ head $ parseAllTails close $ parseGrammarTails g input)+      where close = Rank2.fmap (<* eof) g -parseTails :: (Rank2.Functor g, FactorialMonoid s) => g (Parser g s) -> s -> [(s, g (ResultList g s))]-parseTails g input = foldr parseTail [] (Factorial.tails input)+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 -reparseTails :: Rank2.Functor g => g (Parser g s) -> [(s, g (ResultList g s))] -> [(s, g (ResultList g s))]-reparseTails _ [] = []-reparseTails final parsed@((s, _):_) = (s, gd):parsed-   where gd = Rank2.fmap (`applyParser` parsed) final--instance MonoidParsing (Parser g) where-   endOfInput = eof+instance (LeftReductive s, FactorialMonoid 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             p [] = ResultList [ResultsOfLength 0 [] (mempty:|[])] mempty    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) ["anyToken"])-            p [] = ResultList mempty (FailureInfo 0 ["anyToken"])+                                   _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "anyToken"])+            p [] = ResultList mempty (FailureInfo 0 [Expected "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) ["satisfy"])-            p [] = ResultList mempty (FailureInfo 0 ["satisfy"])-   satisfyChar 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) ["satisfyChar"])-            p [] = ResultList mempty (FailureInfo 0 ["satisfyChar"])-   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) ["satisfyCharInput"])-            p [] = ResultList mempty (FailureInfo 0 ["satisfyCharInput"])+                  _ -> ResultList mempty (FailureInfo (genericLength rest) [Expected "satisfy"])+            p [] = ResultList mempty (FailureInfo 0 [Expected "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                      l = Factorial.length prefix             p _ [] = ResultList [ResultsOfLength 0 [] (mempty:|[])] mempty-   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-                     l = Factorial.length prefix-            p _ [] = ResultList [ResultsOfLength 0 [] (mempty:|[])] mempty+   take 0 = mempty+   take n = Parser p+      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])    takeWhile predicate = Parser p       where p rest@((s, _) : _)                | x <- Factorial.takeWhile predicate s, l <- Factorial.length x =@@ -173,7 +156,31 @@       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) ["takeWhile1"])+            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected "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])+      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"])+            p rest = ResultList [ResultsOfLength 0 rest (():|[])] mempty+   {-# INLINABLE string #-}++instance (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"])+   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+                     l = Factorial.length prefix+            p _ [] = ResultList [ResultsOfLength 0 [] (mempty:|[])] mempty    takeCharsWhile predicate = Parser p       where p rest@((s, _) : _)                | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x =@@ -183,24 +190,20 @@       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) ["takeCharsWhile1"])-   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) ["string " ++ show s])-      l = Factorial.length s-   notSatisfy predicate = Parser p-      where p rest@((s, _):_)-               | Just (first, _) <- splitPrimePrefix s, -                 predicate first = ResultList mempty (FailureInfo (genericLength rest) ["notSatisfy"])-            p rest = ResultList [ResultsOfLength 0 rest (():|[])] mempty+            p rest = ResultList mempty (FailureInfo (genericLength rest) [Expected "takeCharsWhile1"])    notSatisfyChar predicate = Parser p       where p rest@((s, _):_)                | Just first <- Textual.characterPrefix s, -                 predicate first = ResultList mempty (FailureInfo (genericLength rest) ["notSatisfyChar"])+                 predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfyChar"])             p rest = ResultList [ResultsOfLength 0 rest (():|[])] mempty-   {-# INLINABLE string #-} +instance (LeftReductive s, FactorialMonoid 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    try (Parser p) = Parser q       where q rest = rewindFailure (p rest)@@ -209,20 +212,37 @@    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 [msg] else msgs)+                        ResultList [] (FailureInfo pos $ if pos == genericLength rest then [Expected msg] else msgs)                      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) ["notFollowedBy"])+            rewind t ResultList{} = ResultList mempty (FailureInfo (genericLength t) [Expected "notFollowedBy"])    skipMany p = go-      where go = pure () <|> p *> go-   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (genericLength t) [msg])+      where go = pure () <|> try p *> go+   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (genericLength t) [Expected msg])    eof = Parser f       where f rest@((s, _):_)                | null s = ResultList [ResultsOfLength 0 rest (():|[])] mempty-               | otherwise = ResultList mempty (FailureInfo (genericLength rest) ["endOfInput"])+               | otherwise = ResultList mempty (FailureInfo (genericLength rest) [Expected "end of input"])             f [] = ResultList [ResultsOfLength 0 [] (():|[])] mempty +instance MonoidNull 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+                  rl -> rl+   takeSome p = (:) <$> p <*> takeMany p+   takeMany (Parser p) = Parser (q 0 id) where+      q !len acc rest = case p rest+                        of ResultList [] _failure -> ResultList [ResultsOfLength len rest (acc [] :| [])] mempty+                           ResultList rl _ -> foldMap continue rl+         where continue (ResultsOfLength len' rest' results) = foldMap (\r-> q (len + len') (acc . (r:)) rest') results+   skipAll (Parser p) = Parser (q 0) where+      q !len rest = case p rest+                    of ResultList [] _failure -> ResultList [ResultsOfLength len rest (():|[])] mempty+                       ResultList rl _failure -> foldMap continue rl+         where continue (ResultsOfLength len' rest' _) = q (len + len') rest'+ instance MonoidNull s => LookAheadParsing (Parser g s) where    lookAhead (Parser p) = Parser (\input-> rewind input (p input))       where rewind _ rl@(ResultList [] _) = rl@@ -230,18 +250,15 @@             results (ResultsOfLength _ _ r) = r  instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where-   satisfy = satisfyChar+   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"])    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint Parser g s, Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken- instance AmbiguousParsing (Parser g s) where    ambiguous (Parser p) = Parser q       where q rest | ResultList rs failure <- p rest = ResultList (groupByLength <$> rs) failure@@ -252,16 +269,18 @@ 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 [] failure -> Backtrack.NoParse failure+            of ResultList [] (FailureInfo pos expected) -> Backtrack.NoParse (FailureInfo pos $ map message expected)                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")]  -- | Turns a backtracking PEG parser of the list of input tails into a context-free parser, opposite of 'longest' peg :: Backtrack.Parser g [(s, g (ResultList g s))] a -> Parser g s a peg p = Parser q where    q rest = case Backtrack.applyParser p rest             of Backtrack.Parsed l result suffix -> ResultList [ResultsOfLength l suffix (result:|[])] mempty-               Backtrack.NoParse failure -> ResultList mempty failure+               Backtrack.NoParse (FailureInfo pos expected) -> ResultList mempty (FailureInfo pos ((fst . head <$>) <$> expected))  -- | Turns a backtracking PEG parser into a context-free parser terminalPEG :: Monoid s => Backtrack.Parser g s a -> Parser g s a

@@ -0,0 +1,395 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,+             RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+module Text.Grampa.ContextFree.SortedMemoizing.Transformer+       (FailureInfo(..), ResultListT(..), ParserT(..), (<<|>),+        lift, tmap, longest, peg, terminalPEG)+where++import Control.Applicative+import Control.Monad (MonadPlus(..), join, void)+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, 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.Semigroup.Cancellative (LeftReductive(isPrefixOf))+import Data.String (fromString)++import qualified Text.Parser.Char+import Text.Parser.Char (CharParsing)+import Text.Parser.Combinators (Parsing(..))+import Text.Parser.LookAhead (LookAheadParsing(..))++import qualified Rank2++import Text.Grampa.Class (GrammarParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          ConsumedInputParsing(..), DeterministicParsing(..),+                          AmbiguousParsing(..), Ambiguous(Ambiguous),+                          TailsParsing(..), ParseResults, ParseFailure(..), Expected(..))+import Text.Grampa.Internal (FailureInfo(..), AmbiguousAlternative(..))+import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack++import Prelude hiding (iterate, length, 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.+newtype ParserT m g s r = Parser{applyParser :: [(s, g (ResultListT m g s))] -> ResultListT m g s r}++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)}++singleResult :: Applicative m => 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+   pure a = Parser (\rest-> singleResult 0 rest a)+   Parser p <*> Parser q = Parser r where+      r rest = case p rest+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results+      continue (ResultsOfLengthT (ROL l rest' fs)) = foldMap (continue' l $ q rest') fs+      continue' l (ResultList rs failure) f = ResultList (adjust l f <$> rs) failure+      adjust l f (ResultsOfLengthT (ROL l' rest' as)) = ResultsOfLengthT (ROL (l+l') rest' ((f <*>) <$> as))+   {-# INLINABLE pure #-}+   {-# INLINABLE (<*>) #-}++instance Applicative m => Alternative (ParserT m g s) where+   empty = Parser (\rest-> ResultList mempty $ FailureInfo (genericLength rest) [])+   Parser p <|> Parser q = Parser r where+      r rest = p rest <> q rest+   {-# INLINE (<|>) #-}+   {-# INLINABLE empty #-}++instance (Monad m, Traversable m) => Monad (ParserT m g s) where+   return = pure+   (>>) = (*>)+   Parser p >>= f = Parser q where+      q rest = case p rest+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results+      continue (ResultsOfLengthT (ROL l rest' rs)) = foldMap (continue' l . flip applyParser rest' . rejoin . fmap f) rs+      continue' l (ResultList rs failure) = ResultList (adjust l <$> rs) failure+      adjust l (ResultsOfLengthT (ROL l' rest' rs)) = ResultsOfLengthT (ROL (l+l') rest' rs)+      rejoin :: forall a. m (ParserT m g s a) -> ParserT m g s a+      rejoinResults :: forall a. m (ResultListT m g s a) -> ResultListT m g s a+      rejoinResultsOfLengthT :: forall a. m (ResultsOfLengthT m g s a) -> ResultsOfLengthT m g s a+      rejoin m = Parser (\rest-> rejoinResults $ flip applyParser rest <$> m)+      rejoinResults m = ResultList (fmap rejoinResultsOfLengthT $ sequence $ resultSuccesses <$> m) (foldMap resultFailures m)+      rejoinResultsOfLengthT m = ResultsOfLengthT (join <$> traverse getResultsOfLength m)++instance (Foldable m, Monad m, Traversable m) => 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 m = Parser (\rest-> ResultList [ResultsOfLengthT $ ROL 0 rest (m:|[])] mempty)++-- | Modify the computation carried by the parser.+tmap :: (m a -> m b) -> ParserT m g s a -> ParserT m g s b+tmap f (Parser p) = Parser (mapResultList f . p)++mapResultList :: (m a -> m b) -> ResultListT m g s a -> ResultListT m g s b+mapResultList f (ResultList successes failures) = ResultList (mapResults f <$> successes) failures++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+   (<>) = liftA2 (<>)++instance (Applicative m, Monoid x) => Monoid (ParserT m g s x) where+   mempty = pure mempty+   mappend = liftA2 mappend++-- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions, but provides no left+-- recursion support.+--+-- @+-- '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+   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)+                                    (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)+                              (snd $ head $ parseAllTails close $ parseGrammarTails g input)+      where close = Rank2.fmap (<* eof) g++instance (Applicative m, Eq s, LeftReductive s, FactorialMonoid s, Rank2.Functor g) =>+         GrammarParsing (ParserT m g s) where+   type ParserGrammar (ParserT m g s) = g+   type GrammarFunctor (ParserT m g s) = ResultListT m g s+   parsingResult s = Compose . Compose . fmap (fmap sequenceA) . fromResultList s+   nonTerminal :: (ParserInput (ParserT m g s) ~ s) => (g (ResultListT m g s) -> ResultListT m g s a) -> ParserT m g s a+   nonTerminal f = Parser p where+      p ((_, d) : _) = f d+      p _ = ResultList mempty (FailureInfo 0 [Expected "NonTerminal at endOfInput"])+   {-# INLINE nonTerminal #-}++instance (Applicative m, Eq s, LeftReductive s, FactorialMonoid s, Rank2.Functor g) =>+         TailsParsing (ParserT m g s) where+   parseTails = applyParser++parseGrammarTails :: (Rank2.Functor g, FactorialMonoid s) => g (ParserT m g s) -> s -> [(s, g (ResultListT m 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 (Applicative m, LeftReductive s, FactorialMonoid 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+            p [] = singleResult 0 [] mempty+   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"])+   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"])+   scan s0 f = Parser (p s0)+      where p s rest@((i, _) : _) = singleResult l (drop l rest) prefix+               where (prefix, _, _) = Factorial.spanMaybe' s f i+                     l = Factorial.length prefix+            p _ [] = singleResult 0 [] mempty+   takeWhile predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Factorial.takeWhile predicate s, l <- Factorial.length x =+                    singleResult l (drop l rest) x+            p [] = singleResult 0 [] mempty+   take 0 = mempty+   take n = Parser p+      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])+   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"])+   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])+      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"])+            p rest = singleResult 0 rest ()+   {-# INLINABLE string #-}++instance (Applicative m, 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"])+   scanChars s0 f = Parser (p s0)+      where p s rest@((i, _) : _) = singleResult l (drop l rest) prefix+               where (prefix, _, _) = Textual.spanMaybe_' s f i+                     l = Factorial.length prefix+            p _ [] = singleResult 0 [] mempty+   takeCharsWhile predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x =+                    singleResult l (drop l rest) x+            p [] = singleResult 0 [] mempty+   takeCharsWhile1 predicate = Parser p+      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"])+   notSatisfyChar predicate = Parser p+      where p rest@((s, _):_)+               | Just first <- Textual.characterPrefix s, +                 predicate first = ResultList mempty (FailureInfo (genericLength rest) [Expected "notSatisfyChar"])+            p rest = singleResult 0 rest ()++instance (Applicative m, LeftReductive s, FactorialMonoid s) => ConsumedInputParsing (ParserT m 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 (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+   try (Parser p) = Parser q+      where q rest = rewindFailure (p rest)+               where rewindFailure (ResultList rl (FailureInfo _pos _msgs)) =+                        ResultList rl (FailureInfo (genericLength 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)+                     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"])+   skipMany p = go+      where go = pure () <|> try p *> go+   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (genericLength t) [Expected msg])+   eof = Parser f+      where f rest@((s, _):_)+               | null s = singleResult 0 rest ()+               | otherwise = ResultList mempty (FailureInfo (genericLength rest) [Expected "end of input"])+            f [] = singleResult 0 [] ()++instance (Applicative m, MonoidNull 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+                  rl -> rl+   takeSome p = (:) <$> p <*> takeMany p+   takeMany (Parser p) = Parser (q 0 (pure id)) where+      q !len acc rest = case p rest+                        of ResultList [] _failure+                              -> ResultList [ResultsOfLengthT $ ROL len rest (fmap ($ []) acc :| [])] mempty+                           ResultList rl _ -> foldMap continue rl+         where continue (ResultsOfLengthT (ROL len' rest' results)) =+                  foldMap (\r-> q (len + len') (liftA2 (.) acc ((:) <$> r)) rest') results+   skipAll (Parser p) = Parser (q 0) where+      q !len rest = case p rest+                    of ResultList [] _failure -> singleResult len rest ()+                       ResultList rl _failure -> foldMap continue rl+         where continue (ResultsOfLengthT (ROL len' rest' _)) = q (len + len') rest'++instance (Applicative m, MonoidNull 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+   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"])+   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+   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)+            groupByLength (ResultsOfLengthT (ROL l rest rs)) =+               ResultsOfLengthT (ROL l rest $ (Ambiguous <$>) <$> fromList (sequenceA <$> groupBy ((==) `on` void) 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 :: 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)+               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")]++-- | 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 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))++-- | 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 p = Parser q where+   q [] = case Backtrack.applyParser p mempty+            of Backtrack.Parsed l result _ -> singleResult l [] result+               Backtrack.NoParse failure -> ResultList mempty failure+   q rest@((s, _):_) = case Backtrack.applyParser p s+                       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)+   where f (ResultsOfLengthT (ROL _ ((s, _):_) r)) = (,) s <$> toList r+         f (ResultsOfLengthT (ROL _ [] r)) = (,) mempty <$> toList r+{-# INLINABLE fromResultList #-}++instance Functor (ResultsOfLength m g s) where+   fmap f (ROL l t a) = ROL l t (f <$> a)+   {-# INLINE fmap #-}++instance Functor m => Functor (ResultsOfLengthT m g s) where+   fmap f (ResultsOfLengthT rol) = ResultsOfLengthT (fmap f <$> rol)+   {-# INLINE fmap #-}++instance Functor m => Functor (ResultListT m g s) where+   fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure+   {-# INLINE fmap #-}++instance Applicative m => 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+   pure = ResultsOfLengthT . pure . pure+   ResultsOfLengthT rol1 <*> ResultsOfLengthT rol2 = ResultsOfLengthT (liftA2 (<*>) rol1 rol2)++instance Applicative m => 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+   empty = ResultList mempty mempty+   (<|>) = (<>)++instance Applicative m => 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+            merge rl1'@(rol1@(ResultsOfLengthT (ROL l1 s1 r1)) : rest1)+                  rl2'@(rol2@(ResultsOfLengthT (ROL l2 _ r2)) : rest2)+               | l1 < l2 = rol1 : merge rest1 rl2'+               | l1 > l2 = rol2 : merge rl1' rest2+               | otherwise = ResultsOfLengthT (ROL l1 s1 $ liftA2 (liftA2 collect) r1 r2) : merge rest1 rest2+            collect (Ambiguous xs) (Ambiguous ys) = Ambiguous (xs <> ys)++instance 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+            merge rl1'@(rol1@(ResultsOfLengthT (ROL l1 s1 r1)) : rest1)+                 rl2'@(rol2@(ResultsOfLengthT (ROL l2 _ r2)) : rest2)+               | l1 < l2 = rol1 : merge rest1 rl2'+               | l1 > l2 = rol2 : merge rl1' rest2+               | otherwise = ResultsOfLengthT (ROL l1 s1 (r1 <> r2)) : merge rest1 rest2++instance Monoid (ResultListT m g s r) where+   mempty = ResultList mempty mempty+   mappend = (<>)

@@ -1,5 +1,10 @@-module Text.Grampa.Internal (BinTree(..), FailureInfo(..), ResultList(..), ResultsOfLength(..), fromResultList) where+{-# LANGUAGE FlexibleInstances, RankNTypes #-} +module Text.Grampa.Internal (BinTree(..), FailureInfo(..), ResultList(..), ResultsOfLength(..),+                             AmbiguousAlternative(..),+                             fromResultList, noFailure) where++import Control.Applicative (Applicative(..), Alternative(..)) import Data.Foldable (toList) import Data.Functor.Classes (Show1(..)) import Data.List.NonEmpty (NonEmpty)@@ -9,22 +14,22 @@  import Data.Monoid.Factorial (FactorialMonoid, length) -import Text.Grampa.Class (ParseFailure(..), ParseResults)+import Text.Grampa.Class (Ambiguous(..), Expected(..), ParseFailure(..), ParseResults)  import Prelude hiding (length, showList) -data FailureInfo = FailureInfo Int [String] deriving (Eq, Show)+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+data ResultList g s r = ResultList ![ResultsOfLength g s r] !(FailureInfo s)  data BinTree a = Fork !(BinTree a) !(BinTree a)                | Leaf !a                | EmptyTree                deriving (Show) -fromResultList :: FactorialMonoid s => s -> ResultList g s r -> ParseResults [(s, r)]+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)@@ -32,26 +37,23 @@          f (ResultsOfLength _ [] r) = (,) mempty <$> toList r {-# INLINABLE fromResultList #-} -instance Semigroup FailureInfo where+noFailure :: FailureInfo s+noFailure = FailureInfo 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, merge exp1 exp2)-            merge [] exps = exps-            merge exps [] = exps-            merge xs@(x:xs') ys@(y:ys')-               | x < y = x : merge xs' ys-               | x > y = y : merge xs ys'-               | otherwise = x : merge xs' ys'+                         | otherwise = (pos1, exp1 <> exp2) -instance Monoid FailureInfo where+instance Monoid (FailureInfo s) where    mempty = FailureInfo maxBound []    mappend = (<>) -instance Show r => Show (ResultList g s r) where+instance (Show s, Show r) => Show (ResultList g s r) where    show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")") -instance Show1 (ResultList g s) where+instance Show s => Show1 (ResultList g s) where    liftShowsPrec _sp showList _prec (ResultList rol f) rest =        "ResultList " ++ shows (simplify <$> toList rol) (shows f rest)       where simplify (ResultsOfLength l _ r) = "ResultsOfLength " <> show l <> " _ " <> showList (toList r) ""@@ -67,14 +69,39 @@    fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure    {-# INLINE fmap #-} +instance 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+   pure a = ResultList [pure a] mempty+   ResultList rl1 f1 <*> ResultList rl2 f2 = ResultList ((<*>) <$> rl1 <*> rl2) (f1 <> f2)++instance Alternative (ResultList g s) where+   empty = ResultList mempty mempty+   (<|>) = (<>)+ instance Semigroup (ResultList g s r) where-   ResultList rl1 f1 <> ResultList rl2 f2 = ResultList (join rl1 rl2) (f1 <> f2)-      where join [] rl = rl-            join rl [] = rl-            join rl1'@(rol1@(ResultsOfLength l1 s1 r1) : rest1) rl2'@(rol2@(ResultsOfLength l2 _ r2) : rest2)-               | l1 < l2 = rol1 : join rest1 rl2'-               | l1 > l2 = rol2 : join rl1' rest2-               | otherwise = ResultsOfLength l1 s1 (r1 <> r2) : join rest1 rest2+   ResultList rl1 f1 <> ResultList rl2 f2 = ResultList (merge rl1 rl2) (f1 <> f2)+      where merge [] rl = rl+            merge rl [] = rl+            merge rl1'@(rol1@(ResultsOfLength l1 s1 r1) : rest1) rl2'@(rol2@(ResultsOfLength l2 _ r2) : rest2)+               | l1 < l2 = rol1 : merge rest1 rl2'+               | l1 > l2 = rol2 : merge rl1' rest2+               | otherwise = ResultsOfLength l1 s1 (r1 <> r2) : merge rest1 rest2++instance 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+            merge rl1'@(rol1@(ResultsOfLength l1 s1 r1) : rest1) rl2'@(rol2@(ResultsOfLength l2 _ r2) : rest2)+               | l1 < l2 = rol1 : merge rest1 rl2'+               | l1 > l2 = rol2 : merge rl1' rest2+               | otherwise = ResultsOfLength l1 s1 (liftA2 collect r1 r2) : merge rest1 rest2+            collect (Ambiguous xs) (Ambiguous ys) = Ambiguous (xs <> ys)++class Alternative f => AmbiguousAlternative f where+   ambiguousOr :: f (Ambiguous a) -> f (Ambiguous a) -> f (Ambiguous a)  instance Monoid (ResultList g s r) where    mempty = ResultList mempty mempty

@@ -14,10 +14,10 @@ import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString) -import qualified Data.Monoid.Cancellative as Cancellative import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null import qualified Data.Monoid.Textual as Textual+import qualified Data.Semigroup.Cancellative as Cancellative  import qualified Rank2 @@ -25,20 +25,19 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token-import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          ParseResults, ParseFailure(..), Expected(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,                                               parsedSuffix :: !s}-                                     | NoParse FailureInfo+                                     | NoParse (FailureInfo 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. newtype Parser g s r = Parser{applyParser :: s -> Result g s r} -instance Show1 (Result g s) where+instance Show s => Show1 (Result g s) where    liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest    liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest @@ -59,7 +58,7 @@    {-# INLINABLE (<*>) #-}  instance Factorial.FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\rest-> NoParse $ FailureInfo (Factorial.length rest) ["empty"])+   empty = Parser (\rest-> NoParse $ FailureInfo (Factorial.length rest) [Expected "empty"])    (<|>) = alt  -- | A named and unconstrained version of the '<|>' operator@@ -96,113 +95,112 @@    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 [msg] else msgs)+                        NoParse (FailureInfo pos $ if pos == Factorial.length rest then [Expected msg] else msgs)                      replaceFailure parsed = parsed-   eof = endOfInput-   unexpected msg = Parser (\t-> NoParse $ FailureInfo (Factorial.length t) [msg])+   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])    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))-      where rewind t Parsed{} = NoParse (FailureInfo (Factorial.length t) ["notFollowedBy"])+      where rewind t Parsed{} = NoParse (FailureInfo (Factorial.length t) [Expected "notFollowedBy"])             rewind t NoParse{} = Parsed () t +-- | Every PEG parser is deterministic all the time.+instance FactorialMonoid s => DeterministicParsing (Parser g s) where+   (<<|>) = alt+   takeSome = some+   takeMany = many+   skipAll = skipMany+ instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where    lookAhead (Parser p) = Parser (\input-> rewind input (p input))       where rewind t (Parsed r _) = Parsed r t             rewind _ r@NoParse{} = r  instance (Show s, Textual.TextualMonoid s) => CharParsing (Parser g s) where-   satisfy = satisfyChar+   satisfy predicate = Parser p+      where p rest =+               case Textual.splitCharacterPrefix rest+               of Just (first, suffix) | predicate first -> Parsed first suffix+                  _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "Char.satisfy"])    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint Parser g s, Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--instance MonoidParsing (Parser g) where-   endOfInput = Parser p-      where p rest-               | Null.null rest = Parsed () rest-               | otherwise = NoParse (FailureInfo (Factorial.length rest) ["endOfInput"])+instance (Cancellative.LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+   type ParserInput (Parser g s) = s    getInput = Parser p       where p rest = Parsed rest rest    anyToken = Parser p       where p rest = case Factorial.splitPrimePrefix rest                      of Just (first, suffix) -> Parsed first suffix-                        _ -> NoParse (FailureInfo (Factorial.length rest) ["anyToken"])+                        _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "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) ["satisfy"])-   satisfyChar predicate = Parser p-      where p rest =-               case Textual.splitCharacterPrefix rest-               of Just (first, suffix) | predicate first -> Parsed first suffix-                  _ -> NoParse (FailureInfo (Factorial.length rest) ["satisfyChar"])-   satisfyCharInput predicate = Parser p-      where p rest =-               case Textual.splitCharacterPrefix rest-               of Just (first, suffix) | predicate first -> Parsed (Factorial.primePrefix rest) suffix-                  _ -> NoParse (FailureInfo (Factorial.length rest) ["satisfyChar"])+                  _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "satisfy"])    notSatisfy predicate = Parser p       where p s = case Factorial.splitPrimePrefix s                   of Just (first, _) -                        | predicate first -> NoParse (FailureInfo (Factorial.length s) ["notSatisfy"])-                     _ -> Parsed () s-   notSatisfyChar predicate = Parser p-      where p s = case Textual.characterPrefix s-                  of Just first | predicate first -                                  -> NoParse (FailureInfo (Factorial.length s) ["notSatisfyChar"])+                        | predicate first -> NoParse (FailureInfo (Factorial.length s) [Expected "notSatisfy"])                      _ -> Parsed () s    scan s0 f = Parser (p s0)       where p s rest = Parsed prefix suffix                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest-   scanChars s0 f = Parser (p s0)-      where p s rest = Parsed prefix suffix-               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest+   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])    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) ["takeWhile1"])+                        then NoParse (FailureInfo (Factorial.length rest) [Expected "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])+   {-# INLINABLE string #-}++instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where+   satisfyCharInput predicate = Parser p+      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"])+   notSatisfyChar predicate = Parser p+      where p s = case Textual.characterPrefix s+                  of Just first | predicate first +                                  -> NoParse (FailureInfo (Factorial.length s) [Expected "notSatisfyChar"])+                     _ -> Parsed () s+   scanChars s0 f = Parser (p s0)+      where p s rest = Parsed prefix suffix+               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest    takeCharsWhile predicate = Parser p       where p rest | (prefix, suffix) <- Textual.span_ False predicate rest = Parsed prefix suffix    takeCharsWhile1 predicate = Parser p       where p rest | (prefix, suffix) <- Textual.span_ False predicate rest =                      if Null.null prefix-                     then NoParse (FailureInfo (Factorial.length rest) ["takeCharsWhile1"])+                     then NoParse (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])                      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') ["string " ++ show s])-   concatMany (Parser p) = Parser q-      where q rest = case p rest-                     of Parsed prefix suffix -> let Parsed prefix' suffix' = q suffix-                                                in Parsed (mappend prefix prefix') suffix'-                        NoParse{} -> Parsed mempty rest-   {-# INLINABLE string #-}  -- | Backtracking PEG parser -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>---                  g (Backtrack.'Parser' g s) -> s -> g 'ParseResults'+--                  g (Backtrack.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance MultiParsing Parser where-   type ResultFunctor Parser = ParseResults+instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s) => MultiParsing (Parser g s) where+   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))-                                      (Rank2.fmap (<* endOfInput) g)+                                      (Rank2.fmap (<* eof) g) -fromResult :: FactorialMonoid s => s -> Result g s r -> ParseResults (s, r)+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)

@@ -14,10 +14,10 @@ import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString) -import qualified Data.Monoid.Cancellative as Cancellative import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null import qualified Data.Monoid.Textual as Textual+import qualified Data.Semigroup.Cancellative as Cancellative  import qualified Rank2 @@ -25,21 +25,20 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token-import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),+                          MultiParsing(..), ParseResults, ParseFailure(..), Expected(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedLength :: !Int,                                               parsedResult :: !v,                                               parsedSuffix :: !s}-                                     | NoParse FailureInfo+                                     | NoParse (FailureInfo 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. newtype Parser g s r = Parser{applyParser :: s -> Result g s r} -instance Show1 (Result g s) where+instance Show s => Show1 (Result g s) where    liftShowsPrec showsPrecSub _showList prec Parsed{parsedResult= r} rest = "Parsed " ++ showsPrecSub prec r rest    liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest @@ -61,8 +60,8 @@                   NoParse failure -> NoParse failure    {-# INLINABLE (<*>) #-} -instance Factorial.FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\rest-> NoParse $ FailureInfo (Factorial.length rest) ["empty"])+instance FactorialMonoid s => Alternative (Parser g s) where+   empty = Parser (\rest-> NoParse $ FailureInfo (Factorial.length rest) [Expected "empty"])    (<|>) = alt  -- | A named and unconstrained version of the '<|>' operator@@ -81,7 +80,7 @@                                          NoParse failure -> NoParse failure                   NoParse failure -> NoParse failure -instance Factorial.FactorialMonoid s => MonadPlus (Parser g s) where+instance FactorialMonoid s => MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) @@ -92,7 +91,7 @@    mempty = pure mempty    mappend = liftA2 mappend -instance Factorial.FactorialMonoid s => Parsing (Parser g s) where+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)) =@@ -101,116 +100,121 @@    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 [msg] else msgs)+                        NoParse (FailureInfo pos $ if pos == Factorial.length rest then [Expected msg] else msgs)                      replaceFailure parsed = parsed-   eof = endOfInput-   unexpected msg = Parser (\t-> NoParse $ FailureInfo (Factorial.length t) [msg])+   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])    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))-      where rewind t Parsed{} = NoParse (FailureInfo (Factorial.length t) ["notFollowedBy"])+      where rewind t Parsed{} = NoParse (FailureInfo (Factorial.length t) [Expected "notFollowedBy"])             rewind t NoParse{} = Parsed 0 () t -instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where+-- | Every PEG parser is deterministic all the time.+instance FactorialMonoid s => DeterministicParsing (Parser g s) where+   (<<|>) = alt+   takeSome = some+   takeMany = many+   skipAll = skipMany++instance FactorialMonoid s => LookAheadParsing (Parser g s) where    lookAhead (Parser p) = Parser (\input-> rewind input (p input))       where rewind t (Parsed _ r _) = Parsed 0 r t             rewind _ r@NoParse{} = r  instance (Show s, Textual.TextualMonoid s) => CharParsing (Parser g s) where-   satisfy = satisfyChar+   satisfy predicate = Parser p+      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"])    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint Parser g s, Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--instance MonoidParsing (Parser g) where-   endOfInput = Parser p-      where p rest-               | Null.null rest = Parsed 0 () rest-               | otherwise = NoParse (FailureInfo (Factorial.length rest) ["endOfInput"])+instance (Cancellative.LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+   type ParserInput (Parser g s) = s    getInput = Parser p       where p rest = Parsed 0 rest rest    anyToken = Parser p       where p rest = case Factorial.splitPrimePrefix rest                      of Just (first, suffix) -> Parsed 1 first suffix-                        _ -> NoParse (FailureInfo (Factorial.length rest) ["anyToken"])+                        _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "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) ["satisfy"])-   satisfyChar predicate = Parser p-      where p rest =-               case Textual.splitCharacterPrefix rest-               of Just (first, suffix) | predicate first -> Parsed 1 first suffix-                  _ -> NoParse (FailureInfo (Factorial.length rest) ["satisfyChar"])-   satisfyCharInput predicate = Parser p-      where p rest =-               case Textual.splitCharacterPrefix rest-               of Just (first, suffix) | predicate first -> Parsed 1 (Factorial.primePrefix rest) suffix-                  _ -> NoParse (FailureInfo (Factorial.length rest) ["satisfyChar"])+                  _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "satisfy"])    notSatisfy predicate = Parser p       where p s = case Factorial.splitPrimePrefix s                   of Just (first, _) -                        | predicate first -> NoParse (FailureInfo (Factorial.length s) ["notSatisfy"])-                     _ -> Parsed 0 () s-   notSatisfyChar predicate = Parser p-      where p s = case Textual.characterPrefix s-                  of Just first | predicate first -                                  -> NoParse (FailureInfo (Factorial.length s) ["notSatisfyChar"])+                        | predicate first -> NoParse (FailureInfo (Factorial.length s) [Expected "notSatisfy"])                      _ -> Parsed 0 () s    scan s0 f = Parser (p s0)       where p s rest = Parsed (Factorial.length prefix) prefix suffix                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest-   scanChars s0 f = Parser (p s0)-      where p s rest = Parsed (Factorial.length prefix) prefix suffix-               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest+   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])    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) ["takeWhile1"])+                        then NoParse (FailureInfo (Factorial.length rest) [Expected "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])+      l = Factorial.length s+   {-# INLINABLE string #-}++instance (Cancellative.LeftReductive s, FactorialMonoid s) => ConsumedInputParsing (Parser g s) where+   match (Parser p) = Parser q+      where q rest = case p rest+                     of Parsed l prefix suffix -> Parsed l (Factorial.take l rest, prefix) suffix+                        NoParse failure -> NoParse failure++instance (Show s, TextualMonoid s) => InputCharParsing (Parser g s) where+   satisfyCharInput predicate = Parser p+      where p rest =+               case Textual.splitCharacterPrefix rest+               of Just (first, suffix) | predicate first -> Parsed 1 (Factorial.primePrefix rest) suffix+                  _ -> NoParse (FailureInfo (Factorial.length rest) [Expected "satisfyChar"])+   notSatisfyChar predicate = Parser p+      where p s = case Textual.characterPrefix s+                  of Just first | predicate first +                                  -> NoParse (FailureInfo (Factorial.length s) [Expected "notSatisfyChar"])+                     _ -> Parsed 0 () s+   scanChars s0 f = Parser (p s0)+      where p s rest = Parsed (Factorial.length prefix) prefix suffix+               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest    takeCharsWhile predicate = Parser p       where p rest | (prefix, suffix) <- Textual.span_ False predicate rest =                 Parsed (Factorial.length prefix) prefix suffix    takeCharsWhile1 predicate = Parser p       where p rest | (prefix, suffix) <- Textual.span_ False predicate rest =                      if Null.null prefix-                     then NoParse (FailureInfo (Factorial.length rest) ["takeCharsWhile1"])+                     then NoParse (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])                      else Parsed (Factorial.length prefix) prefix suffix-   string s = Parser p where-      p s' | Just suffix <- Cancellative.stripPrefix s s' = Parsed l s suffix-           | otherwise = NoParse (FailureInfo (Factorial.length s') ["string " ++ show s])-      l = Factorial.length s-   concatMany (Parser p) = Parser q-      where q rest = case p rest-                     of Parsed l prefix suffix -> let Parsed l' prefix' suffix' = q suffix-                                                  in Parsed (l+l') (mappend prefix prefix') suffix'-                        NoParse{} -> Parsed 0 mempty rest-   {-# INLINABLE string #-}  -- | Backtracking PEG parser -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>---                  g (Backtrack.'Parser' g s) -> s -> g 'ParseResults'+--                  g (Backtrack.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance MultiParsing Parser where-   type ResultFunctor Parser = ParseResults+instance (Cancellative.LeftReductive s, Factorial.FactorialMonoid s) => MultiParsing (Parser g s) where+   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))-                                      (Rank2.fmap (<* endOfInput) g)+                                      (Rank2.fmap (<* eof) g) -fromResult :: FactorialMonoid s => s -> Result g s r -> ParseResults (s, r)+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)

@@ -8,13 +8,13 @@ import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (nub)-import Data.Semigroup (Semigroup(..))+import Data.Semigroup (Semigroup((<>)))+import Data.Semigroup.Cancellative (LeftReductive(stripPrefix)) import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString) -import qualified Data.Monoid.Cancellative as Cancellative import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null import qualified Data.Monoid.Textual as Textual@@ -25,21 +25,20 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token-import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), MultiParsing(..),+                          ParseResults, ParseFailure(..), Expected(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,                                               parsedSuffix :: !s}-                                     | NoParse FailureInfo+                                     | NoParse (FailureInfo 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 -> x) -> x}+   Parser{applyParser :: forall x. s -> (r -> s -> x) -> (FailureInfo s -> x) -> x} -instance Show1 (Result g s) where+instance Show s => Show1 (Result g s) where    liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest    liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest @@ -55,28 +54,28 @@    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 -> x) -> x+      r :: forall x. s -> (b -> s -> x) -> (FailureInfo s -> x) -> x       r rest success failure = p rest (\f rest'-> q rest' (success . f) failure) failure    {-# INLINABLE (<*>) #-} -instance Factorial.FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) ["empty"])+instance FactorialMonoid s => Alternative (Parser g s) where+   empty = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected "empty"])    (<|>) = 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 Parser p `alt` Parser q = Parser r where-   r :: forall x. s -> (a -> s -> x) -> (FailureInfo -> x) -> x+   r :: forall x. s -> (a -> s -> x) -> (FailureInfo s -> x) -> x    r rest success failure = p rest success (\f1-> q rest success $ \f2 -> failure (f1 <> f2))  instance Monad (Parser g s) where    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 -> x) -> x+      r :: forall x. s -> (b -> s -> x) -> (FailureInfo s -> x) -> x       r rest success failure = p rest (\a rest'-> applyParser (f a) rest' success failure) failure -instance Factorial.FactorialMonoid s => MonadPlus (Parser g s) where+instance FactorialMonoid s => MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) @@ -87,155 +86,144 @@    mempty = pure mempty    mappend = liftA2 mappend -instance Factorial.FactorialMonoid s => Parsing (Parser g s) where+instance FactorialMonoid 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 -> x) -> x+      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) []    (<?>) :: 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 -> x) -> x+      where q :: forall x. s -> (a -> s -> x) -> (FailureInfo 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 [msg] else msgs)-   eof = endOfInput-   unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (Factorial.length t) [msg])+                        FailureInfo pos (if pos == Factorial.length input then [Expected msg] else msgs)+   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])    notFollowedBy (Parser p) = Parser q-      where q :: forall x. s -> (() -> s -> x) -> (FailureInfo -> x) -> x+      where q :: forall x. s -> (() -> s -> x) -> (FailureInfo s -> x) -> x             q input success failure = p input success' failure'-               where success' _ _ = failure (FailureInfo (Factorial.length input) ["notFollowedBy"])+               where success' _ _ = failure (FailureInfo (Factorial.length input) [Expected "notFollowedBy"])                      failure' _ = success () input -instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where+-- | Every PEG parser is deterministic all the time.+instance FactorialMonoid s => DeterministicParsing (Parser g s) where+   (<<|>) = alt+   takeSome = some+   takeMany = many+   skipAll = skipMany++instance FactorialMonoid 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 -> x) -> x+      where q :: forall x. s -> (a -> s -> x) -> (FailureInfo 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-   satisfy = satisfyChar+   satisfy predicate = Parser p+      where p :: forall x. s -> (Char -> s -> x) -> (FailureInfo 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"])    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint Parser g s, Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--instance MonoidParsing (Parser g) where-   endOfInput = Parser p-      where p rest success failure-               | Null.null rest = success () rest-               | otherwise = failure (FailureInfo (Factorial.length rest) ["endOfInput"])+instance (LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+   type ParserInput (Parser g s) = s    getInput = Parser p       where p rest success _ = success rest rest    anyToken = Parser p       where p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) -> success first suffix-                  _ -> failure (FailureInfo (Factorial.length rest) ["anyToken"])-   satisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s+                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "anyToken"])    satisfy predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo 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) ["satisfy"])-   satisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s Char-   satisfyChar predicate = Parser p-      where p :: forall x. s -> (Char -> s -> x) -> (FailureInfo -> x) -> x-            p rest success failure =-               case Textual.splitCharacterPrefix rest-               of Just (first, suffix) | predicate first -> success first suffix-                  _ -> failure (FailureInfo (Factorial.length rest) ["satisfyChar"])-   satisfyCharInput :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s-   satisfyCharInput predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo -> 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) ["satisfyChar"])-   notSatisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s ()+                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfy"])    notSatisfy predicate = Parser p-      where p :: forall x. s -> (() -> s -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (() -> s -> x) -> (FailureInfo s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, _)-                     | predicate first -> failure (FailureInfo (Factorial.length rest) ["notSatisfy"])-                  _ -> success () rest-   notSatisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s ()-   notSatisfyChar predicate = Parser p-      where p :: forall x. s -> (() -> s -> x) -> (FailureInfo -> x) -> x-            p rest success failure =-               case Textual.characterPrefix rest-               of Just first | predicate first-                               -> failure (FailureInfo (Factorial.length rest) ["notSatisfyChar"])+                     | predicate first -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfy"])                   _ -> success () rest-   scan :: forall t s. FactorialMonoid t => s -> (s -> t -> Maybe s) -> Parser g t t+   scan :: forall state. state -> (state -> s -> Maybe state) -> Parser g s s    scan s0 f = Parser (p s0)-      where p :: forall x. s -> t -> (t -> t -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. state -> s -> (s -> s -> x) -> (FailureInfo s -> x) -> x             p s rest success _ = success prefix suffix                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest-   scanChars :: forall t s. TextualMonoid t => s -> (s -> Char -> Maybe s) -> Parser g t t-   scanChars s0 f = Parser (p s0)-      where p :: forall x. s -> t -> (t -> t -> x) -> (FailureInfo -> x) -> x-            p s rest success _ = success prefix suffix-               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest-   takeWhile :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s+   take n = Parser p+      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo 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])    takeWhile predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x             p rest success _ | (prefix, suffix) <- Factorial.span predicate rest = success prefix suffix-   takeWhile1 :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s    takeWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x             p rest success failure                | (prefix, suffix) <- Factorial.span predicate rest =                     if Null.null prefix-                    then failure (FailureInfo (Factorial.length rest) ["takeWhile1"])+                    then failure (FailureInfo (Factorial.length rest) [Expected "takeWhile1"])                     else success prefix suffix-   takeCharsWhile :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s+   string s = Parser p where+      p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x+      p s' success failure+         | Just suffix <- stripPrefix s s' = success s suffix+         | otherwise = failure (FailureInfo (Factorial.length s') [ExpectedInput s])+   {-# INLINABLE string #-}++instance (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+            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"])+   notSatisfyChar predicate = Parser p+      where p :: forall x. s -> (() -> s -> x) -> (FailureInfo s -> x) -> x+            p rest success failure =+               case Textual.characterPrefix rest+               of Just first | predicate first+                               -> failure (FailureInfo (Factorial.length rest) [Expected "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+            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 -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x             p rest success _ | (prefix, suffix) <- Textual.span_ False predicate rest = success prefix suffix-   takeCharsWhile1 :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s    takeCharsWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> s -> x) -> (FailureInfo s -> x) -> x             p rest success failure-               | Null.null prefix = failure (FailureInfo (Factorial.length rest) ["takeCharsWhile1"])+               | Null.null prefix = failure (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])                | otherwise = success prefix suffix                where (prefix, suffix) = Textual.span_ False predicate rest-   string :: forall s. (Cancellative.LeftReductiveMonoid s, FactorialMonoid s, Show s) => s -> Parser g s s-   string s = Parser p where-      p :: forall x. s -> (s -> s -> x) -> (FailureInfo -> x) -> x-      p s' success failure-         | Just suffix <- Cancellative.stripPrefix s s' = success s suffix-         | otherwise = failure (FailureInfo (Factorial.length s') ["string " ++ show s])-   concatMany :: forall s a. Monoid a => Parser g s a -> Parser g s a-   concatMany (Parser p) = Parser q-      where q :: forall x. s -> (a -> s -> x) -> (FailureInfo -> x) -> x-            q rest success _ = p rest success' failure-               where success' prefix suffix = q suffix (success . mappend prefix) (const $ success prefix suffix)-                     failure _ = success mempty rest-   {-# INLINABLE string #-}  -- | Continuation-passing PEG parser -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>---                  g (Continued.'Parser' g s) -> s -> g 'ParseResults'+--                  g (Continued.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance MultiParsing Parser where-   type ResultFunctor Parser = ParseResults+instance (LeftReductive s, FactorialMonoid 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))-                                      (Rank2.fmap (<* endOfInput) g)+                                      (Rank2.fmap (<* eof) g) -fromFailure :: FactorialMonoid s => s -> FailureInfo -> ParseFailure+fromFailure :: (Eq s, FactorialMonoid s) => s -> FailureInfo s -> ParseFailure s fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - pos + 1) (nub msgs)

@@ -14,33 +14,32 @@ import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString) -import qualified Data.Monoid.Cancellative as Cancellative+import Data.Semigroup.Cancellative (LeftReductive(stripPrefix)) import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null import qualified Data.Monoid.Textual as Textual  import qualified Rank2 -import qualified Text.Parser.Char+import qualified Text.Parser.Char as Char import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token-import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..),+                          MultiParsing(..), ParseResults, ParseFailure(..), Expected(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,                                               parsedSuffix :: !s}-                                     | NoParse FailureInfo+                                     | NoParse (FailureInfo s)  -- | 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 -> x) -> x}+   Parser{applyParser :: forall x. s -> (r -> Int -> s -> x) -> (FailureInfo s -> x) -> x} -instance Show1 (Result g s) where+instance Show s => Show1 (Result g s) where    liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest    liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest @@ -56,30 +55,30 @@    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 -> x) -> x+      r :: forall x. s -> (b -> Int -> s -> x) -> (FailureInfo 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 Factorial.FactorialMonoid s => Alternative (Parser g s) where-   empty = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) ["empty"])+instance FactorialMonoid s => Alternative (Parser g s) where+   empty = Parser (\rest _ failure-> failure $ FailureInfo (Factorial.length rest) [Expected "empty"])    (<|>) = 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 Parser p `alt` Parser q = Parser r where-   r :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo -> x) -> x+   r :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo s -> x) -> x    r rest success failure = p rest success (\f1-> q rest success $ \f2 -> failure (f1 <> f2))  instance Monad (Parser g s) where    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 -> x) -> x+      r :: forall x. s -> (b -> Int -> s -> x) -> (FailureInfo s -> x) -> x       r rest success failure = p rest                                   (\a len rest'-> applyParser (f a) rest' (\b len'-> success b $! len + len') failure)                                  failure -instance Factorial.FactorialMonoid s => MonadPlus (Parser g s) where+instance FactorialMonoid s => MonadPlus (Parser g s) where    mzero = empty    mplus = (<|>) @@ -90,166 +89,161 @@    mempty = pure mempty    mappend = liftA2 mappend -instance Factorial.FactorialMonoid s => Parsing (Parser g s) where+instance FactorialMonoid 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 -> x) -> x+      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) []    (<?>) :: 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 -> x) -> x+      where q :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo 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 [msg] else msgs)-   eof = endOfInput-   unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (Factorial.length t) [msg])+                        FailureInfo pos (if pos == Factorial.length input then [Expected msg] else msgs)+   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])    notFollowedBy (Parser p) = Parser q-      where q :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo -> x) -> x+      where q :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo s -> x) -> x             q input success failure = p input success' failure'-               where success' _ _ _ = failure (FailureInfo (Factorial.length input) ["notFollowedBy"])+               where success' _ _ _ = failure (FailureInfo (Factorial.length input) [Expected "notFollowedBy"])                      failure' _ = success () 0 input -instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where+-- | Every PEG parser is deterministic all the time.+instance FactorialMonoid s => DeterministicParsing (Parser g s) where+   (<<|>) = alt+   takeSome = some+   takeMany = many+   skipAll = skipMany++instance FactorialMonoid 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 -> x) -> x+      where q :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo 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-   satisfy = satisfyChar+   satisfy predicate = Parser p+      where p :: forall x. s -> (Char -> Int -> s -> x) -> (FailureInfo 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"])    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint Parser g s, Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--instance MonoidParsing (Parser g) where-   endOfInput = Parser p-      where p rest success failure-               | Null.null rest = success () 0 rest-               | otherwise = failure (FailureInfo (Factorial.length rest) ["endOfInput"])+instance (LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+   type ParserInput (Parser g s) = s    getInput = Parser p       where p rest success _ = success rest 0 rest    anyToken = Parser p       where p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, suffix) -> success first 1 suffix-                  _ -> failure (FailureInfo (Factorial.length rest) ["anyToken"])-   satisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s+                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "anyToken"])    satisfy predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo 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) ["satisfy"])-   satisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s Char-   satisfyChar predicate = Parser p-      where p :: forall x. s -> (Char -> Int -> s -> x) -> (FailureInfo -> 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) ["satisfyChar"])-   satisfyCharInput :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s-   satisfyCharInput predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo -> 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) ["satisfyChar"])-   notSatisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s ()+                  _ -> failure (FailureInfo (Factorial.length rest) [Expected "satisfy"])    notSatisfy predicate = Parser p-      where p :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo s -> x) -> x             p rest success failure =                case Factorial.splitPrimePrefix rest                of Just (first, _)-                     | predicate first -> failure (FailureInfo (Factorial.length rest) ["notSatisfy"])-                  _ -> success () 0 rest-   notSatisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s ()-   notSatisfyChar predicate = Parser p-      where p :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo -> x) -> x-            p rest success failure =-               case Textual.characterPrefix rest-               of Just first | predicate first-                               -> failure (FailureInfo (Factorial.length rest) ["notSatisfyChar"])+                     | predicate first -> failure (FailureInfo (Factorial.length rest) [Expected "notSatisfy"])                   _ -> success () 0 rest-   scan :: forall t s. FactorialMonoid t => s -> (s -> t -> Maybe s) -> Parser g t t+   scan :: forall state. state -> (state -> s -> Maybe state) -> Parser g s s    scan s0 f = Parser (p s0)-      where p :: forall x. s -> t -> (t -> Int -> t -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. state -> s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x             p s rest success _ = success prefix len suffix                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest                      !len = Factorial.length prefix-   scanChars :: forall t s. TextualMonoid t => s -> (s -> Char -> Maybe s) -> Parser g t t-   scanChars s0 f = Parser (p s0)-      where p :: forall x. s -> t -> (t -> Int -> t -> x) -> (FailureInfo -> x) -> x-            p s rest success _ = success prefix len suffix-               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest-                     !len = Factorial.length prefix-   takeWhile :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s+   take n = Parser p+      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo 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])    takeWhile predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x             p rest success _                 | (prefix, suffix) <- Factorial.span predicate rest,                   !len <- Factorial.length prefix = success prefix len suffix-   takeWhile1 :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s    takeWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo 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) ["takeWhile1"])+                    then failure (FailureInfo (Factorial.length rest) [Expected "takeWhile1"])                     else success prefix len suffix-   takeCharsWhile :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s+   string s = Parser p where+      p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo 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])+   {-# INLINABLE string #-}++instance (LeftReductive s, FactorialMonoid 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+            q rest success failure = p rest success' failure+               where success' r !len suffix = success (Factorial.take len rest, r) len suffix++instance (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+            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"])+   notSatisfyChar predicate = Parser p+      where p :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo s -> x) -> x+            p rest success failure =+               case Textual.characterPrefix rest+               of Just first | predicate first+                               -> failure (FailureInfo (Factorial.length rest) [Expected "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+            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 -> x) -> x-            p rest success _ +      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x+            p rest success _                | (prefix, suffix) <- Textual.span_ False predicate rest,                   !len <- Factorial.length prefix = success prefix len suffix-   takeCharsWhile1 :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s    takeCharsWhile1 predicate = Parser p-      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo -> x) -> x+      where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo s -> x) -> x             p rest success failure-               | Null.null prefix = failure (FailureInfo (Factorial.length rest) ["takeCharsWhile1"])+               | Null.null prefix = failure (FailureInfo (Factorial.length rest) [Expected "takeCharsWhile1"])                | otherwise = success prefix len suffix                where (prefix, suffix) = Textual.span_ False predicate rest                      !len = Factorial.length prefix-   string :: forall s. (Cancellative.LeftReductiveMonoid s, FactorialMonoid s, Show s) => s -> Parser g s s-   string s = Parser p where-      p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo -> x) -> x-      p s' success failure-         | Just suffix <- Cancellative.stripPrefix s s', !len <- Factorial.length s = success s len suffix-         | otherwise = failure (FailureInfo (Factorial.length s') ["string " ++ show s])-   concatMany :: forall s a. Monoid a => Parser g s a -> Parser g s a-   concatMany (Parser p) = Parser q-      where q :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo -> x) -> x-            q rest success _ = p rest success' failure-               where success' prefix !len suffix = -                        q suffix (\prefix' !len'-> success (mappend prefix prefix') (len + len')) -                          (const $ success prefix len suffix)-                     failure _ = success mempty 0 rest-   {-# INLINABLE string #-}  -- | Continuation-passing PEG parser that keeps track of the parsed prefix length -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>---                  g (Continued.'Parser' g s) -> s -> g 'ParseResults'+--                  g (Continued.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance MultiParsing Parser where-   type ResultFunctor Parser = ParseResults+instance (LeftReductive s, FactorialMonoid 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 (<* endOfInput) g)+                                      (Rank2.fmap (<* eof) g) -fromFailure :: FactorialMonoid s => s -> FailureInfo -> ParseFailure+fromFailure :: (Eq s, FactorialMonoid s) => s -> FailureInfo s -> ParseFailure s fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - pos + 1) (nub msgs)

@@ -8,13 +8,13 @@ import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (genericLength, nub)-import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid)+import Data.Semigroup (Semigroup(..))+import Data.Semigroup.Cancellative (LeftReductive(isPrefixOf)) import Data.String (fromString) -import qualified Data.Monoid.Cancellative as Cancellative import qualified Data.Monoid.Factorial as Factorial import qualified Data.Monoid.Null as Null import qualified Data.Monoid.Textual as Textual@@ -25,22 +25,21 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing)-import qualified Text.Parser.Token-import Text.Grampa.Class (Lexical(..), GrammarParsing(..), MonoidParsing(..), MultiParsing(..), -                          ParseResults, ParseFailure(..))+import Text.Grampa.Class (DeterministicParsing(..), InputParsing(..), InputCharParsing(..),+                          GrammarParsing(..), MultiParsing(..),+                          TailsParsing(parseTails), ParseResults, ParseFailure(..), Expected(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result g s v = Parsed{parsedPrefix :: !v,                             parsedSuffix :: ![(s, g (Result g s))]}-                  | NoParse FailureInfo+                  | NoParse (FailureInfo 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 -- 'parse' function returns an input prefix parse paired with the remaining input suffix. newtype Parser g s r = Parser{applyParser :: [(s, g (Result g s))] -> Result g s r} -instance Show1 (Result g s) where+instance Show s => Show1 (Result g s) where    liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest    liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest @@ -59,7 +58,7 @@                   NoParse failure -> NoParse failure  instance Alternative (Parser g s) where-   empty = Parser (\rest-> NoParse $ FailureInfo (genericLength rest) ["empty"])+   empty = Parser (\rest-> NoParse $ FailureInfo (genericLength rest) [Expected "empty"])    Parser p <|> Parser q = Parser r where       r rest = case p rest                of x@Parsed{} -> x@@ -83,7 +82,7 @@    mempty = pure mempty    mappend = liftA2 mappend -instance Factorial.FactorialMonoid s => Parsing (Parser g s) where+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) [])@@ -91,96 +90,110 @@    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 [msg] else msgs)+                        NoParse (FailureInfo pos $ if pos == genericLength rest then [Expected msg] else msgs)                      replaceFailure parsed = parsed-   eof = endOfInput-   unexpected msg = Parser (\t-> NoParse $ FailureInfo (genericLength t) [msg])+   eof = Parser p+      where p rest@((s, _) : _)+               | not (Null.null s) = NoParse (FailureInfo (genericLength rest) [Expected "end of input"])+            p rest = Parsed () rest+   unexpected msg = Parser (\t-> NoParse $ FailureInfo (genericLength t) [Expected msg])    notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))-      where rewind t Parsed{} = NoParse (FailureInfo (genericLength t) ["notFollowedBy"])+      where rewind t Parsed{} = NoParse (FailureInfo (genericLength t) [Expected "notFollowedBy"])             rewind t NoParse{} = Parsed () t -instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where+-- | Every PEG parser is deterministic all the time.+instance FactorialMonoid s => DeterministicParsing (Parser g s) where+   (<<|>) = (<|>)+   takeSome = some+   takeMany = many+   skipAll = skipMany++instance FactorialMonoid s => LookAheadParsing (Parser g s) where    lookAhead (Parser p) = Parser (\input-> rewind input (p input))       where rewind t (Parsed r _) = Parsed r t             rewind _ r@NoParse{} = r  instance (Show s, Textual.TextualMonoid s) => CharParsing (Parser g s) where-   satisfy = satisfyChar+   satisfy predicate = Parser p+      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"])    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)-   char = satisfyChar . (==)-   notChar = satisfyChar . (/=)-   anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Lexical g, LexicalConstraint Parser g s, Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = someLexicalSpace-   semi = lexicalSemicolon-   token = lexicalToken--instance GrammarParsing Parser where-   type GrammarFunctor Parser = Result+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    nonTerminal f = Parser p where       p ((_, d) : _) = f d-      p _ = NoParse (FailureInfo 0 ["NonTerminal at endOfInput"])+      p _ = NoParse (FailureInfo 0 [Expected "NonTerminal at endOfInput"]) -instance MonoidParsing (Parser g) where-   endOfInput = Parser p-      where p rest@((s, _) : _)-               | not (Null.null s) = NoParse (FailureInfo (genericLength rest) ["endOfInput"])-            p rest = Parsed () rest+instance (Eq s, LeftReductive s, FactorialMonoid s) => TailsParsing (Parser g s) where+   parseTails = applyParser++instance (LeftReductive s, FactorialMonoid s) => InputParsing (Parser g s) where+   type ParserInput (Parser g s) = s    getInput = Parser p       where p rest@((s, _):_) = Parsed s rest             p [] = Parsed mempty []    anyToken = Parser p       where p rest@((s, _):t) = case Factorial.splitPrimePrefix s                                 of Just (first, _) -> Parsed first t-                                   _ -> NoParse (FailureInfo (genericLength rest) ["anyToken"])-            p [] = NoParse (FailureInfo 0 ["anyToken"])+                                   _ -> NoParse (FailureInfo (genericLength rest) [Expected "anyToken"])+            p [] = NoParse (FailureInfo 0 [Expected "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) ["satisfy"])-            p [] = NoParse (FailureInfo 0 ["satisfy"])-   satisfyChar predicate = Parser p-      where p rest@((s, _):t) =-               case Textual.characterPrefix s-               of Just first | predicate first -> Parsed first t-                  _ -> NoParse (FailureInfo (genericLength rest) ["satisfyChar"])-            p [] = NoParse (FailureInfo 0 ["satisfyChar"])-   satisfyCharInput predicate = Parser p-      where p rest@((s, _):t) =-               case Textual.characterPrefix s-               of Just first | predicate first -> Parsed (Factorial.primePrefix s) t-                  _ -> NoParse (FailureInfo (genericLength rest) ["satisfyChar"])-            p [] = NoParse (FailureInfo 0 ["satisfyChar"])+                  _ -> NoParse (FailureInfo (genericLength rest) [Expected "satisfy"])+            p [] = NoParse (FailureInfo 0 [Expected "satisfy"])    notSatisfy predicate = Parser p       where p rest@((s, _):_)                | Just (first, _) <- Factorial.splitPrimePrefix s, -                 predicate first = NoParse (FailureInfo (genericLength rest) ["notSatisfy"])-            p rest = Parsed () rest-   notSatisfyChar predicate = Parser p-      where p rest@((s, _):_)-               | Just first <- Textual.characterPrefix s, -                 predicate first = NoParse (FailureInfo (genericLength rest) ["notSatisfyChar"])+                 predicate first = NoParse (FailureInfo (genericLength rest) [Expected "notSatisfy"])             p rest = Parsed () rest    scan s0 f = Parser (p s0)       where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)                where (prefix, _, _) = Factorial.spanMaybe' s f i             p _ [] = Parsed mempty []-   scanChars s0 f = Parser (p s0)-      where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)-               where (prefix, _, _) = Textual.spanMaybe_' s f i-            p _ [] = Parsed mempty []    takeWhile predicate = Parser p       where p rest@((s, _) : _)                | x <- Factorial.takeWhile predicate s = Parsed x (Factorial.drop (Factorial.length x) rest)             p [] = Parsed mempty []+   take n = Parser p+      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])    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) ["takeWhile1"])+            p rest = NoParse (FailureInfo (genericLength rest) [Expected "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])++instance (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 -> Parsed (Factorial.primePrefix s) t+                  _ -> NoParse (FailureInfo (genericLength rest) [Expected "satisfyCharInput"])+            p [] = NoParse (FailureInfo 0 [Expected "satisfyCharInput"])+   notSatisfyChar predicate = Parser p+      where p rest@((s, _):_)+               | Just first <- Textual.characterPrefix s, +                 predicate first = NoParse (FailureInfo (genericLength rest) [Expected "notSatisfyChar"])+            p rest = Parsed () rest+   scanChars s0 f = Parser (p s0)+      where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)+               where (prefix, _, _) = Textual.spanMaybe_' s f i+            p _ [] = Parsed mempty []    takeCharsWhile predicate = Parser p       where p rest@((s, _) : _)                | x <- Textual.takeWhile_ False predicate s =@@ -190,31 +203,25 @@       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) ["takeCharsWhile1"])-   string s = Parser p where-      p rest@((s', _) : _)-         | Cancellative.isPrefixOf s s' = Parsed s (Factorial.drop (Factorial.length s) rest)-      p rest = NoParse (FailureInfo (genericLength rest) ["string " ++ show s])-   concatMany p = go-      where go = mappend <$> p <*> go <|> mempty-+            p rest = NoParse (FailureInfo (genericLength rest) [Expected "takeCharsWhile1"])  -- | Packrat parser -- -- @ -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>---                  g (Packrat.'Parser' g s) -> s -> g 'ParseResults'+--                  g (Packrat.'Parser' g s) -> s -> g ('ParseResults' s) -- @-instance MultiParsing Parser where-   type ResultFunctor Parser = ParseResults+instance (LeftReductive s, FactorialMonoid s) => MultiParsing (Parser g s) where+   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 $ parseTails g input)+   parsePrefix g input = Rank2.fmap (Compose . fromResult input) (snd $ head $ parseGrammarTails g input)    parseComplete g input = Rank2.fmap ((snd <$>) . fromResult input)-                                      (snd $ head $ reparseTails close $ parseTails g input)-      where close = Rank2.fmap (<* endOfInput) g+                                      (snd $ head $ reparseTails close $ parseGrammarTails g input)+      where close = Rank2.fmap (<* eof) g -parseTails :: (Rank2.Functor g, FactorialMonoid s) => g (Parser g s) -> s -> [(s, g (Result g s))]-parseTails g input = foldr parseTail [] (Factorial.tails input)+parseGrammarTails :: (Rank2.Functor g, FactorialMonoid s) => g (Parser g s) -> s -> [(s, g (Result 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@@ -224,7 +231,7 @@ reparseTails final parsed@((s, _):_) = (s, gd):parsed    where gd = Rank2.fmap (`applyParser` parsed) final -fromResult :: FactorialMonoid s => s -> Result g s r -> ParseResults (s, r)+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)

@@ -13,6 +13,7 @@ import qualified Rank2 import qualified Rank2.TH +import Text.Parser.Combinators (eof) import Text.Grampa import Text.Grampa.ContextFree.Parallel (Parser) import qualified Arithmetic@@ -27,7 +28,7 @@  recursiveManyGrammar :: Recursive (Parser g String) -> Recursive (Parser g String) recursiveManyGrammar Recursive{..} = Recursive{-   start= rec <* endOfInput,+   start= rec <* eof,    rec= many (char ';') <* optional next,    next= string "END"} 

@@ -1,7 +1,10 @@-import Build_doctests (flags, pkgs, module_sources)+import Build_doctests import Test.DocTest (doctest)  main :: IO () main = do     doctest (flags ++ pkgs ++ module_sources)+    doctest (flags_exe_arithmetic ++ pkgs_exe_arithmetic ++ module_sources_exe_arithmetic)+    doctest (flags_exe_boolean_transformations ++ pkgs_exe_boolean_transformations+             ++ module_sources_exe_boolean_transformations)     doctest (flags ++ pkgs ++ ["-pgmL", "markdown-unlit", "-isrc", "test/README.lhs"])

@@ -89,9 +89,9 @@ -- >>> parseComplete grammar "1+2*3" -- Arithmetic{ --   sum=Compose (Right [7]),---   product=Compose (Left (ParseFailure 1 ["endOfInput"])),---   factor=Compose (Left (ParseFailure 1 ["endOfInput"])),---   number=Compose (Left (ParseFailure 1 ["endOfInput"]))}+--   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"]))} -- >>> parsePrefix grammar "1+2*3 apples" -- Arithmetic{ --   sum=Compose (Compose (Right [("+2*3 apples",1),("*3 apples",3),(" apples",7)])),

@@ -1,5 +1,5 @@ {-# Language FlexibleContexts, FlexibleInstances, RankNTypes, RecordWildCards, -             ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, UndecidableInstances #-}+             ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeFamilies, UndecidableInstances #-} module Main where  import Control.Applicative (Applicative, Alternative, Const(..), pure, empty, many, optional, (<*>), (*>), (<|>))@@ -10,15 +10,16 @@ import Data.List.NonEmpty (NonEmpty((:|))) import Data.Semigroup (Semigroup, (<>)) import Data.Monoid (Monoid(..), Product(..))-import Data.Monoid.Cancellative (LeftReductiveMonoid, isPrefixOf) import Data.Monoid.Null (MonoidNull(null)) import Data.Monoid.Factorial (FactorialMonoid, factors) import Data.Monoid.Textual (TextualMonoid(toString))+import Data.Semigroup.Cancellative (LeftReductive, isPrefixOf) import Data.Typeable (Typeable) import Data.Word (Word8, Word64)  import Data.Functor.Compose (Compose(..))-import Text.Parser.Combinators (choice, sepBy1, skipMany)+import Text.Parser.Combinators (choice, eof, sepBy1, skipMany)+import qualified Text.Parser.Char as Char import Text.Parser.Token (whiteSpace)  import Control.Enumerable (Shareable, Sized, share)@@ -49,7 +50,8 @@                              next :: f String} deriving instance (Show (f String), Show (f [String])) => Show (Recursive f) -instance Lexical Recursive+instance TokenParsing (LeftRecursive.Parser Recursive String)+instance LexicalParsing (LeftRecursive.Parser Recursive String)  $(Rank2.TH.deriveAll ''Recursive) @@ -66,11 +68,11 @@           pure id <*> symbol "..." <?> "start",    rec= sepBy1 one (ignorable *> string "," <?> "comma") <?> "rec",    one= do ignorable-           identifier <- ((:) <$> satisfyChar isLetter <*> (toString (const "") <$> takeCharsWhile isLetter))+           identifier <- ((:) <$> Char.satisfy isLetter <*> (toString (const "") <$> takeCharsWhile isLetter))            guard (identifier /= "reserved")            pure id <*> pure identifier         <?> "one",-   next= string "--" *> (toString (const "") <$> takeCharsWhile (/= '\n') <* (void (char '\n') <|> endOfInput)) <?> "next"+   next= string "--" *> (toString (const "") <$> takeCharsWhile (/= '\n') <* (void (char '\n') <|> eof)) <?> "next"    }  symbol s = ignorable *> string s <* ignorable@@ -82,7 +84,7 @@  type Parser = Parallel.Parser -simpleParse :: FactorialMonoid s => Parallel.Parser (Rank2.Only r) s r -> s -> ParseResults [(s, r)]+simpleParse :: (Eq s, FactorialMonoid s, LeftReductive s) => Parallel.Parser (Rank2.Only r) s r -> s -> ParseResults s [(s, r)] simpleParse p input = getCompose . getCompose $ simply parsePrefix p input  tests = testGroup "Grampa" [@@ -123,7 +125,7 @@                                                      :| [Test.Ambiguous.Xy2                                                          (pure $ Test.Ambiguous.Xy1 "x" "") "y"]))]))],            testGroup "primitives"-             [testProperty "anyToken mempty" $ simpleParse anyToken "" == Left (ParseFailure 0 ["anyToken"]),+             [testProperty "anyToken mempty" $ simpleParse anyToken "" == Left (ParseFailure 0 [Expected "anyToken"]),               testProperty "anyToken list" $                 \(x::Word8) xs-> simpleParse anyToken (x:xs) == Right [(xs, [x])],               testProperty "satisfy success" $ \bools->@@ -133,10 +135,10 @@               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 ["string " ++ show xs]),-              testProperty "endOfInput mempty" $ simpleParse endOfInput "" == Right [("", ())],-              testProperty "endOfInput failure" $ \s->-                   s /= "" ==> simpleParse endOfInput s == Left (ParseFailure 0 ["endOfInput"])],+                ==> simpleParse (string xs) ys == Left (ParseFailure 0 [ExpectedInput xs]),+              testProperty "eof mempty" $ simpleParse eof "" == Right [("", ())],+              testProperty "eof failure" $ \s->+                   s /= "" ==> simpleParse eof s == Left (ParseFailure 0 [Expected "end of input"])],            testGroup "lookAhead"              [testProperty "lookAhead" lookAheadP,               testProperty "lookAhead p *> p" lookAheadConsumeP,@@ -156,11 +158,16 @@               testBatch $ monadPlus parser2s],            testGroup "errors"              [testProperty "start" (Test.Examples.parseArithmetical ":4" -                                    === Left ":4\n^\nat line 1, column 1\nexpected digits, string \"(\", or string \"-\""),+                                    === Left (":4\n^\nat line 1, column 1\n" <>+                                              "expected digits, string \"(\", or string \"-\"")),+              testProperty "tabs" (Test.Examples.parseArithmetical "\t\t :4" +                                   === Left ("\t\t :4\n\t\t ^\nat line 1, column 4\n" <>+                                             "expected digits, string \"(\", or string \"-\"")),               testProperty "middle" (Test.Examples.parseArithmetical "4 - :3"                                      === Left "4 - :3\n    ^\nat line 1, column 5\nexpected digits or string \"(\""),               testProperty "middle line" (Test.Examples.parseArithmetical "4 -\n :3\n+ 2"-                                           === Left "4 -\n :3\n ^\nat line 2, column 2\nexpected digits or string \"(\""),+                                          === Left ("4 -\n :3\n ^\nat line 2, column 2\n" <>+                                                    "expected digits or string \"(\"")),               testProperty "missing" (Test.Examples.parseArithmetical "4 - "                                        === Left "4 - \n    ^\nat line 1, column 5\nexpected digits or string \"(\""),               testProperty "missing" (Test.Examples.parseArithmetical "4 -\n" @@ -209,14 +216,14 @@    mempty = DescribedParser "mempty" mempty    DescribedParser d1 p1 `mappend` DescribedParser d2 p2 = DescribedParser (d1 ++ " <> " ++ d2) (mappend p1 p2) -instance EqProp ParseFailure where+instance EqProp (ParseFailure s) where    ParseFailure pos1 msg1 =-= ParseFailure pos2 msg2 = property (pos1 == pos2) -instance (Ord r, Show r, EqProp r, Eq s, EqProp s, Show s, FactorialMonoid s, Arbitrary s) =>+instance (Ord r, Show r, EqProp r, Eq s, EqProp s, Show s, FactorialMonoid s, LeftReductive s, Arbitrary s) =>          EqProp (Parser (Rank2.Only r) s r) where    p1 =-= p2 = forAll arbitrary (\s-> (nub <$> simpleParse p1 s) =-= (nub <$> simpleParse p2 s)) -instance (FactorialMonoid s, Show s, EqProp s, Arbitrary s, Ord r, Show r, EqProp r, Typeable r) =>+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    DescribedParser _ p1 =-= DescribedParser _ p2 = forAll arbitrary $ \s->       simpleParse p1 s =-= simpleParse p2 s@@ -241,7 +248,7 @@    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, LeftReductiveMonoid s, Ord s, Typeable s, Show s, Enumerable s) =>+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),@@ -255,9 +262,9 @@                               binary " <> " (<>),                               binary " <|> " (<|>)]) -instance forall s r. (Ord s, Semigroup s, FactorialMonoid s, LeftReductiveMonoid s, Show s, Enumerable s) =>+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 "endOfInput" endOfInput),+   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))])

@@ -30,6 +30,4 @@                     <|> Xyzw <$> amb <*> string "w")    } -instance Lexical Test- $(Rank2.TH.deriveAll ''Test)

@@ -1,4 +1,4 @@-{-# Language FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-}+{-# Language FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-} module Test.Examples where  import Control.Applicative (empty, (<|>))@@ -29,19 +29,19 @@ parseBoolean :: String -> Either String BooleanTree parseBoolean = uniqueParse (fixGrammar boolean) (Boolean.expr . Rank2.snd) -comparisons :: (Rank2.Functor g, Lexical g, LexicalConstraint Parser g String) =>+comparisons :: (Rank2.Functor g, LexicalParsing (Parser g String)) =>                GrammarBuilder ArithmeticComparisons g Parser String comparisons (Rank2.Pair a c) =    Rank2.Pair (Arithmetic.arithmetic a) (Comparisons.comparisons c){Comparisons.term= Arithmetic.expr a} -boolean :: (Rank2.Functor g, Lexical g, LexicalConstraint Parser g String) =>+boolean :: (Rank2.Functor g, LexicalParsing (Parser g String)) =>            GrammarBuilder ArithmeticComparisonsBoolean g Parser String boolean (Rank2.Pair ac b) = Rank2.Pair (comparisons ac) (Boolean.boolean (Comparisons.test $ Rank2.snd ac) b)  parseConditional :: String -> Either String (ConditionalTree ArithmeticTree) parseConditional = uniqueParse (fixGrammar conditionals) (Conditionals.expr . Rank2.snd) -conditionals :: (Rank2.Functor g, Lexical g, LexicalConstraint Parser g String) => GrammarBuilder ACBC g Parser String+conditionals :: (Rank2.Functor g, LexicalParsing (Parser g String)) => GrammarBuilder ACBC g Parser String conditionals (Rank2.Pair acb c) =    boolean acb `Rank2.Pair`    Conditionals.conditionals c{Conditionals.test= Boolean.expr (Rank2.snd acb),@@ -142,14 +142,22 @@ instance Enumerable Relation where    enumerate = share (choice $ pay . pure . Relation <$> ["<", "<=", "==", ">=", ">"]) -uniqueParse :: (Eq s, TextualMonoid s, Rank2.Apply g, Rank2.Traversable g, Rank2.Distributive g) =>+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 uniqueParse g p s = case getCompose (p $ parseComplete g s)                     of Right [r] -> Right r                        Right [] -> Left "Unparseable"-                       Right _ -> Left "Ambiguous"+                       Right rs -> Left ("Ambiguous: " ++ show rs)                        Left err -> Left (toString mempty $ failureDescription s err 3) -instance Lexical ArithmeticComparisons-instance Lexical ArithmeticComparisonsBoolean-instance Lexical ACBC+instance TokenParsing (Parser ArithmeticComparisons String) where+   token = lexicalToken+instance TokenParsing (Parser ArithmeticComparisonsBoolean String) where+   token = lexicalToken+instance TokenParsing (Parser ACBC String) where+   token = lexicalToken++instance LexicalParsing (Parser ArithmeticComparisons String)+instance LexicalParsing (Parser ArithmeticComparisonsBoolean String)+instance LexicalParsing (Parser ACBC String)+