grammatical-parsers 0.2.2 → 0.3

raw patch · 25 files changed

+758/−204 lines, 25 filesdep ~basedep ~containersdep ~rank2classesPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, containers, rank2classes

API changes (from Hackage documentation)

Files

• examples/Arithmetic.hs +7/−3
• examples/Boolean.hs +8/−3
• examples/Combined.hs +4/−2
• examples/Comparisons.hs +3/−2
• examples/Conditionals.hs +7/−3
• examples/Lambda.hs +3/−2
• examples/Main.hs +11/−6
• examples/Utilities.hs +0/−8
• grammatical-parsers.cabal +14/−13
• src/Text/Grampa.hs +4/−3
• src/Text/Grampa/Class.hs +89/−10
• src/Text/Grampa/ContextFree/Continued.hs +14/−9
• src/Text/Grampa/ContextFree/Continued/Measured.hs +14/−9
• src/Text/Grampa/ContextFree/LeftRecursive.hs +110/−42
• src/Text/Grampa/ContextFree/Memoizing.hs +19/−10
• src/Text/Grampa/ContextFree/Parallel.hs +24/−13
• src/Text/Grampa/ContextFree/SortedMemoizing.hs +271/−0
• src/Text/Grampa/Internal.hs +67/−9
• src/Text/Grampa/PEG/Backtrack.hs +15/−9
• src/Text/Grampa/PEG/Backtrack/Measured.hs +15/−9
• src/Text/Grampa/PEG/Continued.hs +14/−9
• src/Text/Grampa/PEG/Continued/Measured.hs +14/−9
• src/Text/Grampa/PEG/Packrat.hs +16/−9
• test/Test.hs +5/−8
• test/Test/Examples.hs +10/−4

@@ -5,10 +5,11 @@ import Data.Char (isDigit) import Data.Functor.Compose (Compose(..)) import Data.Monoid ((<>))+import Text.Parser.Token (symbol)  import Text.Grampa import Text.Grampa.ContextFree.LeftRecursive (Parser)-import Utilities (infixJoin, symbol)+import Utilities (infixJoin)  import qualified Rank2 import Prelude hiding (negate, product, subtract, sum)@@ -87,7 +88,10 @@                   <*> f (factor a)                   <*> f (primary a) -arithmetic :: ArithmeticDomain e => GrammarBuilder (Arithmetic e) g Parser String+instance Lexical (Arithmetic e)++arithmetic :: (Lexical g, LexicalConstraint Parser g String, ArithmeticDomain e) =>+              GrammarBuilder (Arithmetic e) g Parser String arithmetic Arithmetic{..} = Arithmetic{    expr= sum,    sum= product@@ -99,7 +103,7 @@          <|> divide <$> product <* symbol "/" <*> factor,    factor= primary            <|> symbol "(" *> expr <* symbol ")",-   primary= whiteSpace *> ((number . read) <$> takeCharsWhile1 isDigit <?> "digits")}+   primary= lexicalToken ((number . read) <$> takeCharsWhile1 isDigit) <?> "digits"}  main :: IO () main = getContents >>=

@@ -1,15 +1,17 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, RecordWildCards, ScopedTypeVariables,+             TypeFamilies, TemplateHaskell #-} module Boolean where  import Control.Applicative import qualified Data.Bool import Data.Char (isSpace) import Data.Monoid ((<>))+import Text.Parser.Token (TokenParsing, symbol)  import qualified Rank2.TH  import Text.Grampa-import Utilities (infixJoin, keyword, symbol)+import Utilities (infixJoin)  import Prelude hiding (and, or, not) @@ -41,10 +43,13 @@       factor :: f e}    deriving Show +instance Lexical (Boolean e)+ $(Rank2.TH.deriveAll ''Boolean)  boolean :: forall e p (g :: (* -> *) -> *).-           (BooleanDomain e, Alternative (p g String), Parsing (p g String), MonoidParsing (p g)) =>+           (Lexical g, LexicalConstraint p g String,+            BooleanDomain e, TokenParsing (p g String), MonoidParsing (p g)) =>            p g String e -> Boolean e (p g String) -> Boolean e (p g String) boolean p Boolean{..} = Boolean{    expr= term

@@ -7,7 +7,7 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Rank2.TH-import Text.Grampa (GrammarBuilder)+import Text.Grampa (Lexical, LexicalConstraint, GrammarBuilder) import Text.Grampa.ContextFree.LeftRecursive (Parser) import qualified Arithmetic import qualified Boolean@@ -117,6 +117,8 @@                            (", conditionalGrammar=" ++ showsPrec prec (conditionalGrammar g)                            (", lambdaGrammar=" ++ showsPrec prec (lambdaGrammar g) ("}" ++ rest)))))) +instance Lexical Expression+ $(Rank2.TH.deriveAll ''Expression)  {-@@ -186,7 +188,7 @@                   <*> Rank2.traverse f (lambdaGrammar g) -} -expression :: GrammarBuilder Expression g Parser String+expression :: (Lexical g, LexicalConstraint Parser g String) => GrammarBuilder Expression g Parser String expression Expression{..} =    let combinedExpr = Arithmetic.expr arithmeticGrammar                       <|> Boolean.expr booleanGrammar

@@ -3,10 +3,10 @@  import Control.Applicative import Data.Monoid ((<>))+import Text.Parser.Token (TokenParsing, symbol)  import qualified Rank2 import Text.Grampa-import Utilities (symbol)  class ComparisonDomain c e where    greaterThan :: c -> c -> e@@ -62,7 +62,8 @@                   <$> f (test g)                   <*> f (term g) -comparisons :: (ComparisonDomain c e, Alternative (p g String), MonoidParsing (p 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 Comparisons{..} =    Comparisons{

@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RecordWildCards,+             TypeFamilies, TemplateHaskell #-} module Conditionals where  import Control.Applicative@@ -8,7 +9,6 @@  import Text.Grampa import Text.Grampa.ContextFree.LeftRecursive (Parser)-import Utilities (keyword)  class ConditionalDomain c e where    ifThenElse :: c -> e -> e -> e@@ -29,9 +29,13 @@                            (", 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)+ $(Rank2.TH.deriveAll ''Conditionals) -conditionals :: ConditionalDomain t e => GrammarBuilder (Conditionals t e) g Parser String+conditionals :: (ConditionalDomain t e, Lexical g, LexicalConstraint Parser g String)+             => GrammarBuilder (Conditionals t e) g Parser String conditionals Conditionals{..} =    Conditionals{expr= ifThenElse <$> (keyword "if" *> test) <*> (keyword "then" *> term) <*> (keyword "else" *> term),                 test= empty,

@@ -6,13 +6,13 @@ import Data.Char (isAlphaNum, isLetter) import Data.Map (Map, insert, (!)) import Data.Monoid ((<>))+import Text.Parser.Token (symbol, whiteSpace)  import qualified Rank2 import qualified Rank2.TH  import Text.Grampa import Text.Grampa.ContextFree.LeftRecursive (Parser)-import Utilities (symbol)  class LambdaDomain e where    apply :: e -> e -> e@@ -96,7 +96,8 @@  $(Rank2.TH.deriveAll ''Lambda) -lambdaCalculus :: LambdaDomain e => GrammarBuilder (Lambda e) g Parser String+lambdaCalculus :: (Lexical g, LexicalConstraint 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, MultiParamTypeClasses, RankNTypes, KindSignatures, UndecidableInstances #-}+{-# LANGUAGE 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 (GrammarBuilder, ParseResults, fixGrammar, parseComplete)+import Text.Grampa (Lexical, LexicalConstraint, GrammarBuilder, ParseResults, fixGrammar, parseComplete) import Text.Grampa.ContextFree.LeftRecursive (Parser) import Arithmetic (Arithmetic, arithmetic) import qualified Arithmetic@@ -37,17 +37,22 @@                  <$> (getCompose . Combined.expr $ parseComplete (fixGrammar Combined.expression) args)                  :: ParseResults [Combined.Tagged]) -comparisons :: GrammarBuilder (Rank2.Product (Arithmetic.Arithmetic Int) (Comparisons.Comparisons Int Bool))-                              g Parser String+comparisons :: (Lexical g, LexicalConstraint 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 :: GrammarBuilder ArithmeticComparisonsBoolean g Parser String+boolean :: (Lexical g, LexicalConstraint 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 :: GrammarBuilder ACBC g Parser String+conditionals :: (Lexical g, LexicalConstraint 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)+

@@ -21,11 +21,3 @@  infixJoin :: String -> String -> String -> String infixJoin op a b = "(" <> a <> op <> b <> ")"--keyword :: forall s (g :: (* -> *) -> *) p.-           (Show s, TextualMonoid s, Parsing (p g s), MonoidParsing (p g)) => s -> p g s s-keyword kwd = whiteSpace *> string kwd <* notFollowedBy (satisfyChar isAlphaNum)--symbol :: forall s (g :: (* -> *) -> *) p.-          (Show s, TextualMonoid s, Applicative (p g s), MonoidParsing (p g)) => s -> p g s s-symbol s = whiteSpace *> string s

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

@@ -6,9 +6,9 @@    MultiParsing(..),    simply,    -- * Types-   Grammar, GrammarBuilder, ParseResults, ParseFailure(..),+   Grammar, GrammarBuilder, ParseResults, ParseFailure(..), Ambiguous(..),    -- * Parser combinators and primitives-   GrammarParsing(..), MonoidParsing(..),+   GrammarParsing(..), MonoidParsing(..), AmbiguousParsing(..), Lexical(..),    module Text.Parser.Char,    module Text.Parser.Combinators,    module Text.Parser.LookAhead)@@ -19,7 +19,8 @@ import Text.Parser.LookAhead (LookAheadParsing(lookAhead))  import qualified Rank2-import Text.Grampa.Class (MultiParsing(..), GrammarParsing(..), MonoidParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Class (Lexical(..), MultiParsing(..), GrammarParsing(..), MonoidParsing(..), AmbiguousParsing(..),+                          Ambiguous(..), ParseResults, ParseFailure(..))  -- | 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)

@@ -1,14 +1,25 @@-{-# LANGUAGE ConstraintKinds, RankNTypes, TypeFamilies #-}-module Text.Grampa.Class (MultiParsing(..), GrammarParsing(..), MonoidParsing(..),-                          ParseResults, ParseFailure(..), completeParser) where+{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, DefaultSignatures, RankNTypes, ScopedTypeVariables,+             TypeApplications, TypeFamilies, DeriveDataTypeable, DeriveFunctor #-}+module Text.Grampa.Class (MultiParsing(..), AmbiguousParsing(..), GrammarParsing(..), MonoidParsing(..), Lexical(..),+                          ParseResults, ParseFailure(..), Ambiguous(..), completeParser) where +import Control.Applicative (Alternative(empty), liftA2, (<|>))+import Control.Monad (guard)+import Data.Char (isAlphaNum, isLetter, isSpace)+import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))-import Data.Monoid (Monoid)+import Data.List.NonEmpty (NonEmpty((:|)))+import Data.Data (Data)+import Data.Typeable (Typeable)+import Data.Monoid (Monoid, (<>)) import Data.Monoid.Cancellative (LeftReductiveMonoid) import qualified Data.Monoid.Null as Null import Data.Monoid.Null (MonoidNull) import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid)+import Text.Parser.Combinators (Parsing(notFollowedBy), skipMany, skipSome)+import Text.Parser.Char (CharParsing(char))+import Text.Parser.Token (TokenParsing, IdentifierStyle) import GHC.Exts (Constraint)  import qualified Rank2@@ -18,6 +29,15 @@ -- | 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) +-- | 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, Functor, Ord, Show, Typeable)++instance Show1 Ambiguous where+   liftShowsPrec sp sl d (Ambiguous (h :| l)) t+      | d > 5 = "(Ambiguous $ " <> sp 0 h (" :| " <> sl l (')' : t))+      | otherwise = "Ambiguous (" <> sp 0 h (" :| " <> sl l (')' : t))+ completeParser :: MonoidNull s => Compose ParseResults (Compose [] ((,) s)) r -> Compose ParseResults [] r completeParser (Compose (Left failure)) = Compose (Left failure) completeParser (Compose (Right (Compose results))) =@@ -38,7 +58,7 @@    parsePrefix :: (GrammarConstraint m g, FactorialMonoid s) =>                   g (m g s) -> s -> g (Compose (ResultFunctor m) ((,) s)) --- | Parsers that belong to this class memoize the parse results to avoid exponential performance complexity.+-- | 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 :: ((* -> *) -> *) -> * -> * -> *    -- | Used to reference a grammar production, only necessary from outside the grammar itself@@ -63,8 +83,6 @@     -- | A parser that accepts any single input atom.    anyToken :: FactorialMonoid s => m s s-   -- | A parser that accepts a specific input atom.-   token :: (Eq s, FactorialMonoid s) => s -> m s s    -- | A parser that accepts an input atom only if it satisfies the given predicate.    satisfy :: FactorialMonoid s => (s -> Bool) -> m s s    -- | Specialization of 'satisfy' on 'TextualMonoid' inputs, accepting and returning an input character only if it@@ -111,9 +129,70 @@    -- | 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-   -- | Consume all whitespace characters.-   whiteSpace :: TextualMonoid s => m s ()    -- | Zero or more argument occurrences like 'many', with concatenated monoidal results.    concatMany :: Monoid a => m s a -> m s a -   token x = satisfy (== x)+-- | Parsers that can produce alternative parses and collect them into an 'Ambiguous' node+class 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 'TokenParsing' class.+class Lexical (g :: (* -> *) -> *) where+   type LexicalConstraint (m :: ((* -> *) -> *) -> * -> * -> *) g s :: Constraint+   -- | Always succeeds, consuming all white space and comments+   lexicalWhiteSpace :: LexicalConstraint m g s => m g s ()+   -- | Consumes all whitespace and comments, failing if there are none+   someLexicalSpace :: LexicalConstraint m g s => m g s ()+   -- | Consumes a single comment, defaults to 'empty'+   lexicalComment :: LexicalConstraint m g s => m g s ()+   -- | 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+   -- | Applies the argument parser and consumes the trailing 'lexicalWhitespace'+   lexicalToken :: LexicalConstraint m g s => m g s a -> m g s 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+   -- | 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+   -- | 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 ()++   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),+                          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)+   lexicalComment = empty+   lexicalSemicolon = lexicalToken (char ';')+   lexicalToken p = p <* lexicalWhiteSpace+   isIdentifierStartChar c = isLetter c || c == '_'+   isIdentifierFollowChar c = isAlphaNum c || c == '_'+   identifier = identifierToken (liftA2 (<>) (satisfyCharInput (isIdentifierStartChar @g))+                                             (takeCharsWhile (isIdentifierFollowChar @g)))+   identifierToken = lexicalToken+   keyword s = lexicalToken (string s *> notSatisfyChar (isIdentifierFollowChar @g))

@@ -1,15 +1,15 @@-{-# LANGUAGE InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} -- | Continuation-passing parser for context-free grammars module Text.Grampa.ContextFree.Continued (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2) import Control.Monad (Monad(..), MonadPlus(..)) -import Data.Char (isSpace) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (nub)-import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString)@@ -25,8 +25,9 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing(someSpace))-import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Parser.Token (TokenParsing)+import qualified Text.Parser.Token+import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,@@ -81,6 +82,9 @@    mzero = empty    mplus = (<|>) +instance Semigroup x => Semigroup (Parser g s x) where+   (<>) = liftA2 (<>)+ instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty    mappend = liftA2 mappend@@ -112,8 +116,10 @@    anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = () <$ takeCharsWhile1 isSpace+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@@ -204,13 +210,12 @@       p s' success failure          | Just suffix <- Cancellative.stripPrefix s s' = success s suffix failure          | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])-   whiteSpace = () <$ takeCharsWhile isSpace    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 . (prefix <>)) (const $ success prefix suffix failure')+                        q suffix (success . mappend prefix) (const $ success prefix suffix failure')    {-# INLINABLE string #-}  -- | Continuation-passing context-free parser

@@ -1,15 +1,15 @@-{-# LANGUAGE BangPatterns, InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE BangPatterns, InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} -- | Continuation-passing parser for context-free grammars that keeps track of the parsed prefix length module Text.Grampa.ContextFree.Continued.Measured (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2) import Control.Monad (Monad(..), MonadPlus(..)) -import Data.Char (isSpace) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (nub)-import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString)@@ -25,8 +25,9 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing(someSpace))-import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Parser.Token (TokenParsing)+import qualified Text.Parser.Token+import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,@@ -83,6 +84,9 @@    mzero = empty    mplus = (<|>) +instance Semigroup x => Semigroup (Parser g s x) where+   (<>) = liftA2 (<>)+ instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty    mappend = liftA2 mappend@@ -115,8 +119,10 @@    anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = () <$ takeCharsWhile1 isSpace+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@@ -216,14 +222,13 @@       p s' success failure          | Just suffix <- Cancellative.stripPrefix s s', !len <- Factorial.length s = success s len suffix failure          | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])-   whiteSpace = () <$ takeCharsWhile isSpace    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 (prefix <> prefix') (len + len')) +                          (\prefix' !len'-> success (mappend prefix prefix') (len + len'))                            (const $ success prefix len suffix failure')    {-# INLINABLE string #-} 

@@ -1,7 +1,8 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, InstanceSigs,-             RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, UndecidableInstances #-}+             RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS -fno-full-laziness #-}-module Text.Grampa.ContextFree.LeftRecursive (Fixed, Parser, SeparatedParser(..), longest, peg, terminalPEG, +module Text.Grampa.ContextFree.LeftRecursive (Fixed, Parser, SeparatedParser(..),+                                              longest, peg, terminalPEG,                                               parseSeparated, separated, (<<|>)) where @@ -9,11 +10,12 @@ import Control.Monad (Monad(..), MonadPlus(..)) import Control.Monad.Trans.State.Lazy (State, evalState, get, put) -import Data.Char (isSpace) import Data.Functor.Compose (Compose(..))+import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe (isJust) -import Data.Monoid (Monoid(mempty), All(..), Any(..), (<>))+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(mempty), All(..), Any(..)) import Data.Monoid.Null (MonoidNull(null)) import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid)@@ -25,22 +27,26 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing(someSpace))+import Text.Parser.Token (TokenParsing)+import qualified Text.Parser.Token as Token  import qualified Rank2-import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults)-import Text.Grampa.Internal (BinTree(EmptyTree))-import Text.Grampa.ContextFree.Memoizing (ResultList(..), fromResultList)-import qualified Text.Grampa.ContextFree.Memoizing as Memoizing+import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), AmbiguousParsing(..),+                          Lexical(..), Ambiguous(..), ParseResults)+import Text.Grampa.Internal (ResultList(..), ResultsOfLength(..), fromResultList)+import qualified Text.Grampa.ContextFree.SortedMemoizing as Memoizing import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack  import Prelude hiding (cycle, null, span, takeWhile)  type Parser = Fixed Memoizing.Parser +type ResultAppend g s = ResultList g s Rank2.~> ResultList g s Rank2.~> ResultList 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,       cyclicDescendants :: Rank2.Apply g => g (Const (ParserFlags g)) -> ParserFlags g}    | DirectParser {       complete, direct0, direct1 :: p g s a}@@ -51,6 +57,7 @@                              | 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}@@ -69,6 +76,9 @@ --instance Rank2.Applicative g => Monoid (Union g) where --   mempty = Union (Rank2.pure $ Const False) +instance (Rank2.Apply g, Rank2.Distributive g) => Semigroup (Union g) where+   Union g1 <> Union g2 = Union (Rank2.liftA2 union g1 g2)+ instance (Rank2.Apply g, Rank2.Distributive g) => Monoid (Union g) where    mempty = Union (Rank2.cotraverse (Const . getConst) (Const False))    mappend (Union g1) (Union g2) = Union (Rank2.liftA2 union g1 g2)@@ -81,6 +91,7 @@    direct0= direct0 p',    direct1= direct1 p',    indirect= indirect p',+   appendResults= appendResults p',    cyclicDescendants= cyclicDescendants p'}    where p' = general' p @@ -90,6 +101,7 @@    direct0= empty,    direct1= complete p,    indirect= empty,+   appendResults= (<>),    cyclicDescendants= \cd-> ParserFlags False (const (Const False) Rank2.<$> cd)} general' p@DirectParser{} = Parser{    complete= complete p,@@ -97,6 +109,7 @@    direct0= direct0 p,    direct1= direct1 p,    indirect= empty,+   appendResults= (<>),    cyclicDescendants= \cd-> ParserFlags True (const (Const False) Rank2.<$> cd)} general' p@Parser{} = p @@ -129,6 +142,7 @@       direct0= empty,       direct1= empty,       indirect= ind,+      appendResults= (<>),       cyclicDescendants= parserFlags . f . Rank2.fmap (ParserFlagsFunctor . getConst) . addSelf}       where ind = nonTerminal (parserResults . f . Rank2.fmap ParserResultsFunctor)             addSelf g = Rank2.liftA2 adjust bits g@@ -159,7 +173,8 @@       direct= fmap f (direct p),       direct0= fmap f (direct0 p),       direct1= fmap f (direct1 p),-      indirect= fmap f (indirect p)}+      indirect= fmap f (indirect p),+      appendResults= (<>)}    {-# INLINABLE fmap #-}  instance Alternative (p g s) => Applicative (Fixed p g s) where@@ -180,6 +195,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= (<>),       cyclicDescendants= \deps-> let            pcd@(ParserFlags pn pd) = cyclicDescendants p' deps            ParserFlags qn qd = cyclicDescendants q deps@@ -193,6 +209,7 @@       direct0= direct0 p' <*> direct0 q',       direct1= direct0 p' <*> direct1 q' <|> direct1 p' <*> complete q',       indirect= indirect p' <*> complete q',+      appendResults= (<>),       cyclicDescendants= \deps-> let            pcd@(ParserFlags pn pd) = cyclicDescendants p' deps            ParserFlags qn qd = cyclicDescendants q' deps@@ -224,6 +241,7 @@                     direct0= direct0 p' <|> direct0 q',                     direct1= direct1 p' <|> direct1 q',                     indirect= indirect p' <|> indirect q',+                    appendResults= (<>),                     cyclicDescendants= \deps-> let                          ParserFlags pn pd = cyclicDescendants p' deps                          ParserFlags qn qd = cyclicDescendants q' deps@@ -244,6 +262,7 @@       direct0= d0,       direct1= d1,       indirect= (:) <$> indirect p <*> mcp,+      appendResults= (<>),       cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}       where d0 = pure [] <|> (:[]) <$> direct0 p             d1 = (:) <$> direct1 p <*> mcp@@ -259,6 +278,7 @@       direct0= d0,       direct1= d1,       indirect= (:) <$> indirect p <*> many (complete p),+      appendResults= (<>),       cyclicDescendants= cyclicDescendants p}       where d0 = (:[]) <$> direct0 p             d1= (:) <$> direct1 p <*> many (complete p)@@ -281,6 +301,7 @@                  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@@ -302,6 +323,7 @@       direct0= d0,       direct1= d1,       indirect= direct0 p >>= indirect . general' . cont,+      appendResults= (<>),       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)@@ -311,14 +333,23 @@       direct0= d0,       direct1= d1,       indirect= (indirect p >>= complete . cont) <|> (direct0 p >>= indirect . general' . cont),-      cyclicDescendants= \cd-> (ParserFlags True $ Rank2.fmap (const $ Const True) cd)}+      appendResults= (<>),+      cyclicDescendants= \cd->+         let pcd@(ParserFlags pn _) = cyclicDescendants p' cd+         in if pn+            then ParserFlags True (Rank2.fmap (const $ Const True) cd)+            else pcd}       where d0 = direct0 p >>= direct0 . general' . cont             d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont)+            p'@Parser{} = general' p  instance MonadPlus (p g s) => MonadPlus (Fixed p g s) where    mzero = empty    mplus = (<|>) +instance (Alternative (p g s), Semigroup x) => Semigroup (Fixed p g s x) where+   (<>) = liftA2 (<>)+ instance (Alternative (p g s), Monoid x) => Monoid (Fixed p g s x) where    mempty = pure mempty    mappend = liftA2 mappend@@ -331,7 +362,7 @@ positivePrimitive :: String -> p g s a -> Fixed p g s a positivePrimitive _name p = PositiveDirectParser{complete= p} -instance (LookAheadParsing (p g s), MonoidParsing (Fixed p g)) => Parsing (Fixed p g s) where+instance (Parsing (p g s), MonoidParsing (Fixed p g)) => Parsing (Fixed p g s) where    eof = primitive "eof" eof empty eof    try (PositiveDirectParser p) = PositiveDirectParser (try p)    try p@DirectParser{} = DirectParser{@@ -368,6 +399,7 @@       direct= notFollowedBy (direct p),       direct0= notFollowedBy (direct p),       direct1= empty,+      appendResults= (<>),       indirect= notFollowedBy (indirect p),       cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}    unexpected msg = positivePrimitive "unexpected" (unexpected msg)@@ -387,6 +419,7 @@       direct= lookAhead (direct p),       direct0= lookAhead (direct p),       direct1= empty,+      appendResults= appendResults p,       indirect= lookAhead (indirect p),       cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}} @@ -394,7 +427,6 @@    endOfInput = primitive "endOfInput" endOfInput empty endOfInput    getInput = primitive "getInput" (endOfInput *> getInput) (notFollowedBy endOfInput *> getInput) getInput    anyToken = positivePrimitive "anyToken" anyToken-   token x = positivePrimitive "token" (token x)    satisfy predicate = positivePrimitive "satisfy" (satisfy predicate)    satisfyChar predicate = positivePrimitive "satisfyChar" (satisfyChar predicate)    satisfyCharInput predicate = positivePrimitive "satisfyCharInput" (satisfyCharInput predicate)@@ -415,30 +447,30 @@    takeCharsWhile predicate = primitive "takeCharsWhile" (mempty <$ notSatisfyChar predicate)                                                          (takeCharsWhile1 predicate) (takeCharsWhile predicate)    takeCharsWhile1 predicate = positivePrimitive "takeCharsWhile1" (takeCharsWhile1 predicate)-   whiteSpace = primitive "whiteSpace" (notSatisfyChar isSpace) (satisfyChar isSpace *> whiteSpace) whiteSpace    concatMany p@PositiveDirectParser{} = DirectParser{       complete= cmp,       direct0= d0,       direct1= d1}       where d0 = pure mempty-            d1 = (<>) <$> complete p <*> cmp+            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 = (<>) <$> direct1 p <*> cmp+            d1 = mappend <$> direct1 p <*> cmp             cmp = concatMany (complete p)    concatMany p@Parser{} = Parser{       complete= cmp,       direct= d0 <|> d1,       direct0= d0,       direct1= d1,-      indirect= (<>) <$> indirect p <*> cmp,+      indirect= mappend <$> indirect p <*> cmp,+      appendResults= mappend,       cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}       where d0 = pure mempty <|> direct0 p-            d1 = (<>) <$> direct1 p <*> cmp+            d1 = mappend <$> direct1 p <*> cmp             cmp = concatMany (complete p)    {-# INLINABLE string #-} @@ -446,7 +478,6 @@    endOfInput = primitive "endOfInput" endOfInput empty endOfInput    getInput = primitive "getInput" (endOfInput *> getInput) (notFollowedBy endOfInput *> getInput) getInput    anyToken = positivePrimitive "anyToken" anyToken-   token x = positivePrimitive "token" (token x)    satisfy predicate = positivePrimitive "satisfy" (satisfy predicate)    satisfyChar predicate = positivePrimitive "satisfyChar" (satisfyChar predicate)    satisfyCharInput predicate = positivePrimitive "satisfyCharInput" (satisfyCharInput predicate)@@ -467,35 +498,34 @@    takeCharsWhile predicate = primitive "takeCharsWhile" (mempty <$ notSatisfyChar predicate)                                                          (takeCharsWhile1 predicate) (takeCharsWhile predicate)    takeCharsWhile1 predicate = positivePrimitive "takeCharsWhile1" (takeCharsWhile1 predicate)-   whiteSpace = primitive "whiteSpace" (notSatisfyChar isSpace) (satisfyChar isSpace *> whiteSpace) whiteSpace    concatMany p@PositiveDirectParser{} = DirectParser{       complete= cmp,       direct0= d0,       direct1= d1}       where d0 = pure mempty-            d1 = (<>) <$> complete p <*> cmp+            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 = (<>) <$> direct1 p <*> cmp+            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= (<>) <$> indirect p <*> cmp,+      indirect= mappend <$> indirect p <*> cmp,+      appendResults= mappend,       cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}       where d0 = pure mempty `Backtrack.alt` direct0 p-            d1 = (<>) <$> direct1 p <*> cmp+            d1 = mappend <$> direct1 p <*> cmp             cmp = concatMany (complete p)    {-# INLINABLE string #-} -instance (LookAheadParsing (p g s), MonoidParsing (Fixed p g), Show s, TextualMonoid s) =>-         CharParsing (Fixed p g s) where+instance (Parsing (p g s), MonoidParsing (Fixed p g), Show s, TextualMonoid s) => CharParsing (Fixed p g s) where    satisfy = satisfyChar    string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)    char = satisfyChar . (==)@@ -503,10 +533,41 @@    anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (LookAheadParsing (p g s), TokenParsing (p g s), MonoidParsing (Fixed p g), Show s, TextualMonoid s) => -         TokenParsing (Fixed p g s) where-   someSpace = positivePrimitive "someSpace" someSpace+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+   ambiguous (PositiveDirectParser p) = PositiveDirectParser (ambiguous p)+   ambiguous p@DirectParser{} = DirectParser{complete= ambiguous (complete p),+                                             direct0=  ambiguous (direct0 p),+                                             direct1=  ambiguous (direct1 p)}+   ambiguous p@Parser{} = Parser{complete= ambiguous (complete p),+                                 direct=   ambiguous (direct p),+                                 direct0=  ambiguous (direct0 p),+                                 direct1=  ambiguous (direct1 p),+                                 indirect= ambiguous (indirect p),+                                 appendResults= appendAmbiguous,+                                 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"+ -- | 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 :: Fixed Memoizing.Parser g s a -> Fixed Backtrack.Parser g [(s, g (ResultList g s))] a@@ -519,6 +580,7 @@                             direct0=  Memoizing.longest (direct0 p),                             direct1=  Memoizing.longest (direct1 p),                             indirect=  Memoizing.longest (indirect p),+                            appendResults= (<>),                             cyclicDescendants= cyclicDescendants p}  -- | Turns a backtracking PEG parser of the list of input tails into a context-free parser, opposite of 'longest'@@ -532,6 +594,7 @@                         direct0=  Memoizing.peg (direct0 p),                         direct1=  Memoizing.peg (direct1 p),                         indirect=  Memoizing.peg (indirect p),+                        appendResults= (<>),                         cyclicDescendants= cyclicDescendants p}  -- | Turns a backtracking PEG parser into a context-free parser@@ -545,6 +608,7 @@                                 direct0=  Memoizing.terminalPEG (direct0 p),                                 direct1=  Memoizing.terminalPEG (direct1 p),                                 indirect=  Memoizing.terminalPEG (indirect p),+                                appendResults= (<>),                                 cyclicDescendants= cyclicDescendants p}  parseRecursive :: forall g s. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, FactorialMonoid s) =>@@ -562,7 +626,8 @@          reseparate :: forall a. Const Bool a -> Const Bool a -> Const (g (Const Bool)) a -> Parser g s a                     -> SeparatedParser Memoizing.Parser g s a          reseparate (Const circular) (Const follower) (Const deps) p-            | circular || leader && follower = CycleParser (indirect p) (direct p) deps+            | circular || leader && follower =+              CycleParser (indirect p) (direct p) (Rank2.Arrow (Rank2.Arrow . appendResults p)) deps             | follower = BackParser (complete p)             | otherwise = FrontParser (complete p)             where leader = getAny (Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection circulars deps)@@ -621,27 +686,30 @@          fixRecursive :: s -> [(s, g (ResultList g s))] -> g (ResultList g s) -> g (ResultList g s)          whileAnyContinues :: g (ResultList g s) -> g (ResultList g s) -> g (ResultList g s)          recurseOnce :: s -> [(s, g (ResultList g s))] -> g (ResultList g s) -> g (ResultList g s)-         maybeDependencies :: g (Const (Maybe (g (Const Bool))))+         maybeDependencies :: g (Rank2.Product (Const (Maybe (g (Const Bool)))) (ResultAppend g s))+         maybeDependency :: SeparatedParser Memoizing.Parser g s r+                         -> Rank2.Product (Const (Maybe (g (Const Bool)))) (ResultAppend g s) r           directs = Rank2.fmap backParser parsers          indirects = Rank2.fmap (\p-> case p of {CycleParser{}-> cycleParser p; _ -> empty}) parsers-         maybeDependencies = Rank2.fmap (Const . maybeDependency) parsers-         maybeDependency p@CycleParser{} = Just (dependencies p)-         maybeDependency _ = Nothing-                                                                   +         maybeDependencies = Rank2.fmap maybeDependency parsers+         maybeDependency p@CycleParser{} = Rank2.Pair (Const $ Just $ dependencies p) (appendResultsArrow p)+         maybeDependency _ = Rank2.Pair (Const Nothing) (Rank2.Arrow (Rank2.Arrow . (<>)))+          fixRecursive s parsedTail initial =             foldr1 whileAnyContinues (iterate (recurseOnce s parsedTail) initial)           whileAnyContinues g1 g2 = Rank2.liftA3 choiceWhile maybeDependencies g1 g2-            where choiceWhile :: Const (Maybe (g (Const Bool))) x -> ResultList g i x -> ResultList g i x -                                 -> ResultList g i x-                  combine :: Const Bool x -> ResultList g i x -> Const Bool x-                  choiceWhile (Const Nothing) r1 _ = r1-                  choiceWhile (Const (Just deps)) r1 r2-                     | getAny (Rank2.foldMap (Any . getConst) (Rank2.liftA2 combine deps g1)) = r1 <> r2+            where choiceWhile :: Rank2.Product (Const (Maybe (g (Const Bool)))) (ResultAppend g s) x+                              -> ResultList g s x -> ResultList g s x -> ResultList g s x+                  combine :: Const Bool x -> ResultList g s x -> Const Bool x+                  choiceWhile (Rank2.Pair (Const Nothing) _) r1 _ = r1+                  choiceWhile (Rank2.Pair (Const (Just deps)) append) r1 r2+                     | getAny (Rank2.foldMap (Any . getConst) (Rank2.liftA2 combine deps g1)) =+                       append `Rank2.apply` r1 `Rank2.apply` r2                      | otherwise = r1                   combine (Const False) _ = Const False-                  combine (Const True) (ResultList EmptyTree _) = Const False+                  combine (Const True) (ResultList [] _) = Const False                   combine (Const True) _ = Const True           recurseOnce s parsedTail initial = Rank2.fmap (($ parsed) . Memoizing.applyParser) indirects

@@ -1,18 +1,18 @@ {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,-             RankNTypes, ScopedTypeVariables, TypeFamilies #-}+             RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} module Text.Grampa.ContextFree.Memoizing (FailureInfo(..), ResultList(..), Parser(..), BinTree(..), (<<|>),                                           fromResultList, reparseTails, longest, peg, terminalPEG) where  import Control.Applicative import Control.Monad (Monad(..), MonadPlus(..))-import Data.Char (isSpace) import Data.Function (on) import Data.Foldable (toList) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (genericLength, maximumBy, nub)-import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Cancellative (LeftReductiveMonoid (isPrefixOf)) import Data.Monoid.Null (MonoidNull(null)) import Data.Monoid.Factorial (FactorialMonoid(length, splitPrimePrefix))@@ -25,11 +25,13 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing(someSpace))+import Text.Parser.Token (TokenParsing)+import qualified Text.Parser.Token  import qualified Rank2 -import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Class (Lexical(..), GrammarParsing(..), MonoidParsing(..), MultiParsing(..), +                          ParseResults, ParseFailure(..)) import Text.Grampa.Internal (BinTree(..), FailureInfo(..)) import qualified Text.Grampa.PEG.Backtrack.Measured as Backtrack @@ -58,9 +60,12 @@ instance Functor (ResultList g s) where    fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure +instance Semigroup (ResultList g s r) where+   ResultList rl1 f1 <> ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2)+ instance Monoid (ResultList g s r) where    mempty = ResultList mempty mempty-   ResultList rl1 f1 `mappend` ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2)+   mappend = (<>)  instance Functor (Parser g i) where    fmap f (Parser p) = Parser (fmap f . p)@@ -103,6 +108,9 @@    mzero = empty    mplus = (<|>) +instance Semigroup x => Semigroup (Parser g s x) where+   (<>) = liftA2 (<>)+ instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty    mappend = liftA2 mappend@@ -205,9 +213,8 @@          | s `isPrefixOf` s' = ResultList (Leaf $ ResultInfo l (Factorial.drop l rest) s) mempty       p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["string " ++ show s])       l = Factorial.length s-   whiteSpace = () <$ takeCharsWhile isSpace    concatMany p = go-      where go = mempty <|> (<>) <$> p <*> go+      where go = mempty <|> mappend <$> p <*> go    notSatisfy predicate = Parser p       where p rest@((s, _):_)                | Just (first, _) <- splitPrimePrefix s, @@ -250,8 +257,10 @@    anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = () <$ takeCharsWhile1 isSpace+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)) =

@@ -1,16 +1,16 @@ {-# LANGUAGE FlexibleContexts, InstanceSigs, GeneralizedNewtypeDeriving,-             RankNTypes, ScopedTypeVariables, TypeFamilies #-}+             RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} module Text.Grampa.ContextFree.Parallel (FailureInfo(..), ResultList(..), Parser, fromResultList) where  import Control.Applicative import Control.Monad (Monad(..), MonadPlus(..))-import Data.Char (isSpace) import Data.Foldable (toList) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (nub)-import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Null (MonoidNull(null)) import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid)@@ -24,11 +24,12 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing(someSpace))+import Text.Parser.Token (TokenParsing)+import qualified Text.Parser.Token  import qualified Rank2 -import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..)) import Text.Grampa.Internal (BinTree(..))  import Prelude hiding (iterate, null, showList, span, takeWhile)@@ -57,13 +58,15 @@ instance Functor (ResultList s) where    fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure +instance Semigroup (ResultList s r) where+   ResultList rl1 f1 <> ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2)+ instance Monoid (ResultList s r) where    mempty = ResultList mempty mempty-   ResultList rl1 f1 `mappend` ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2)+   mappend = (<>) -instance Monoid FailureInfo where-   mempty = FailureInfo 0 maxBound []-   f1@(FailureInfo s1 pos1 exp1) `mappend` f2@(FailureInfo s2 pos2 exp2)+instance Semigroup FailureInfo where+   f1@(FailureInfo s1 pos1 exp1) <> f2@(FailureInfo s2 pos2 exp2)       | s1 < s2 = f2       | s1 > s2 = f1       | otherwise = FailureInfo s1 pos' exp'@@ -71,6 +74,10 @@                          | pos1 > pos2 = (pos2, exp2)                          | otherwise = (pos1, exp1 <> exp2) +instance Monoid FailureInfo where+   mempty = FailureInfo 0 maxBound []+   mappend = (<>)+ instance Functor (Parser g s) where    fmap f (Parser p) = Parser (fmap f . p) @@ -98,6 +105,9 @@    mzero = empty    mplus = (<|>) +instance Semigroup x => Semigroup (Parser g s x) where+   (<>) = liftA2 (<>)+ instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty    mappend = liftA2 mappend@@ -175,11 +185,10 @@    string s = Parser p where       p s' | Just suffix <- Cancellative.stripPrefix s s' = ResultList (Leaf $ ResultInfo suffix s) mempty            | otherwise = ResultList mempty (FailureInfo 1 (Factorial.length s') ["string " ++ show s])-   whiteSpace = () <$ takeCharsWhile isSpace    concatMany (Parser p) = Parser q       where q s = ResultList (Leaf $ ResultInfo s mempty) failure <> foldMap continue rs                where ResultList rs failure = p s-            continue (ResultInfo suffix prefix) = (prefix <>) <$> q suffix+            continue (ResultInfo suffix prefix) = mappend prefix <$> q suffix  instance FactorialMonoid s => Parsing (Parser g s) where    try (Parser p) = Parser (weakenResults . p)@@ -207,8 +216,10 @@    anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = () <$ takeCharsWhile1 isSpace+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 s (ResultList EmptyTree (FailureInfo _ pos msgs)) = 

@@ -0,0 +1,271 @@+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,+             RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}+module Text.Grampa.ContextFree.SortedMemoizing +       (FailureInfo(..), ResultList(..), Parser(..), (<<|>),+        reparseTails, longest, peg, terminalPEG)+where++import Control.Applicative+import Control.Monad (Monad(..), MonadPlus(..))+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 (LeftReductiveMonoid (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.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.Internal (FailureInfo(..), ResultList(..), ResultsOfLength(..), fromResultList)+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 of parse results. It does not support left-recursive+-- grammars.+newtype Parser g s r = Parser{applyParser :: [(s, g (ResultList g s))] -> ResultList g s r}++instance Functor (Parser g i) where+   fmap f (Parser p) = Parser (fmap f . p)+   {-# INLINABLE fmap #-}++instance Applicative (Parser g i) where+   pure a = Parser (\rest-> ResultList [ResultsOfLength 0 rest (a:|[])] mempty)+   Parser p <*> Parser q = Parser r where+      r rest = case p rest+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results+      continue (ResultsOfLength l rest' fs) = foldMap (continue' l $ q rest') fs+      continue' l (ResultList rs failure) f = ResultList (adjust l f <$> rs) failure+      adjust l f (ResultsOfLength l' rest' as) = ResultsOfLength (l+l') rest' (f <$> as)+   {-# INLINABLE pure #-}+   {-# INLINABLE (<*>) #-}++instance Alternative (Parser g i) where+   empty = Parser (\rest-> ResultList mempty $ FailureInfo 0 (genericLength rest) ["empty"])+   Parser p <|> Parser q = Parser r where+      r rest = p rest <> q rest+   {-# INLINABLE (<|>) #-}++infixl 3 <<|>+(<<|>) :: Parser g s a -> Parser g s a -> Parser g s a+Parser p <<|> Parser q = Parser r where+   r rest = case p rest+            of rl@(ResultList [] _failure) -> rl <> q rest+               rl -> rl++instance Monad (Parser g i) where+   return = pure+   (>>) = (*>)+   Parser p >>= f = Parser q where+      q rest = case p rest+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results+      continue (ResultsOfLength l rest' rs) = foldMap (continue' l . flip applyParser rest' . f) rs+      continue' l (ResultList rs failure) = ResultList (adjust l <$> rs) failure+      adjust l (ResultsOfLength l' rest' rs) = ResultsOfLength (l+l') rest' rs++instance MonadPlus (Parser g s) where+   mzero = empty+   mplus = (<|>)++instance Semigroup x => Semigroup (Parser g s x) where+   (<>) = liftA2 (<>)++instance Monoid x => Monoid (Parser g s x) where+   mempty = pure mempty+   mappend = liftA2 mappend++instance GrammarParsing Parser where+   type GrammarFunctor Parser = ResultList+   nonTerminal f = Parser p where+      p ((_, d) : _) = f d+      p _ = ResultList mempty (FailureInfo 1 0 ["NonTerminal at endOfInput"])+   {-# INLINE nonTerminal #-}++-- | 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' [])+-- @+instance MultiParsing Parser where+   type ResultFunctor Parser = Compose ParseResults []+   -- | 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 [])+   parseComplete g input = Rank2.fmap ((snd <$>) . Compose . fromResultList input)+                              (snd $ head $ reparseTails close $ parseTails g input)+      where close = Rank2.fmap (<* endOfInput) 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)+   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+   getInput = Parser p+      where p rest@((s, _):_) = ResultList [ResultsOfLength (length rest) [last 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 1 (genericLength rest) ["anyToken"])+            p [] = ResultList mempty (FailureInfo 1 0 ["anyToken"])+   satisfy predicate = Parser p+      where p rest@((s, _):t) =+               case splitPrimePrefix s+               of Just (first, _) | predicate first -> ResultList [ResultsOfLength 1 t (first:|[])] mempty+                  _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfy"])+            p [] = ResultList mempty (FailureInfo 1 0 ["satisfy"])+   satisfyChar predicate = Parser p+      where p rest@((s, _):t) =+               case Textual.characterPrefix s+               of Just first | predicate first -> ResultList [ResultsOfLength 1 t (first:|[])] mempty+                  _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfyChar"])+            p [] = ResultList mempty (FailureInfo 1 0 ["satisfyChar"])+   satisfyCharInput predicate = Parser p+      where p rest@((s, _):t) =+               case Textual.characterPrefix s+               of Just first | predicate first -> ResultList [ResultsOfLength 1 t (Factorial.primePrefix s:|[])] mempty+                  _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfyCharInput"])+            p [] = ResultList mempty (FailureInfo 1 0 ["satisfyCharInput"])+   scan s0 f = Parser (p s0)+      where p s rest@((i, _) : _) = ResultList [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+   takeWhile predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Factorial.takeWhile predicate s, l <- Factorial.length x =+                    ResultList [ResultsOfLength l (drop l rest) (x:|[])] mempty+            p [] = ResultList [ResultsOfLength 0 [] (mempty:|[])] mempty+   takeWhile1 predicate = Parser p+      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 1 (genericLength rest) ["takeWhile1"])+   takeCharsWhile predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x =+                    ResultList [ResultsOfLength l (drop l rest) (x:|[])] mempty+            p [] = ResultList [ResultsOfLength 0 [] (mempty:|[])] mempty+   takeCharsWhile1 predicate = Parser p+      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 1 (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 1 (genericLength rest) ["string " ++ show s])+      l = Factorial.length s+   concatMany p = go+      where go = mempty <|> mappend <$> p <*> go+   notSatisfy predicate = Parser p+      where p rest@((s, _):_)+               | Just (first, _) <- splitPrimePrefix s, +                 predicate first = ResultList mempty (FailureInfo 1 (genericLength rest) ["notSatisfy"])+            p rest = ResultList [ResultsOfLength 0 rest (():|[])] mempty+   notSatisfyChar predicate = Parser p+      where p rest@((s, _):_)+               | Just first <- Textual.characterPrefix s, +                 predicate first = ResultList mempty (FailureInfo 1 (genericLength rest) ["notSatisfyChar"])+            p rest = ResultList [ResultsOfLength 0 rest (():|[])] mempty+   {-# INLINABLE string #-}++instance MonoidNull s => Parsing (Parser g s) where+   try (Parser p) = Parser (weakenResults . p)+      where weakenResults (ResultList rl (FailureInfo s pos msgs)) = ResultList rl (FailureInfo (pred s) pos msgs)+   Parser p <?> msg  = Parser (strengthenResults . p)+      where strengthenResults (ResultList rl (FailureInfo s pos _msgs)) = ResultList rl (FailureInfo (succ s) pos [msg])+   notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))+      where rewind t (ResultList [] _) = ResultList [ResultsOfLength 0 t (():|[])] mempty+            rewind t ResultList{} = ResultList mempty (FailureInfo 1 (genericLength t) ["notFollowedBy"])+   skipMany p = go+      where go = pure () <|> p *> go+   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo 0 (genericLength t) [msg])+   eof = Parser f+      where f rest@((s, _):_)+               | null s = ResultList [ResultsOfLength 0 rest (():|[])] mempty+               | otherwise = ResultList mempty (FailureInfo 1 (genericLength rest) ["endOfInput"])+            f [] = ResultList [ResultsOfLength 0 [] (():|[])] mempty++instance MonoidNull s => LookAheadParsing (Parser g s) where+   lookAhead (Parser p) = Parser (\input-> rewind input (p input))+      where rewind _ rl@(ResultList [] _) = rl+            rewind t (ResultList rl failure) = ResultList [ResultsOfLength 0 t $ foldr1 (<>) (results <$> rl)] failure+            results (ResultsOfLength _ _ r) = r++instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where+   satisfy = satisfyChar+   string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)+   char = satisfyChar . (==)+   notChar = satisfyChar . (/=)+   anyChar = satisfyChar (const True)+   text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t)++instance (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+            groupByLength (ResultsOfLength l rest rs) = ResultsOfLength l rest (Ambiguous rs :| [])++-- | Turns a context-free parser into a backtracking PEG parser that consumes the longest possible prefix of the list+-- of input tails, opposite of 'peg'+longest :: Parser g s a -> Backtrack.Parser g [(s, g (ResultList g s))] a+longest p = Backtrack.Parser q where+   q rest = case applyParser p rest+            of ResultList [] failure -> Backtrack.NoParse failure+               ResultList rs _ -> parsed (last rs)+   parsed (ResultsOfLength l s (r:|_)) = Backtrack.Parsed l r s++-- | Turns a backtracking PEG parser of the list of input tails into a context-free parser, opposite of 'longest'+peg :: Backtrack.Parser g [(s, g (ResultList g s))] a -> Parser g s a+peg p = Parser q where+   q rest = case Backtrack.applyParser p rest+            of Backtrack.Parsed l result suffix -> ResultList [ResultsOfLength l suffix (result:|[])] mempty+               Backtrack.NoParse failure -> ResultList mempty failure++-- | Turns a backtracking PEG parser into a context-free parser+terminalPEG :: Monoid s => Backtrack.Parser g s a -> Parser g s a+terminalPEG p = Parser q where+   q [] = case Backtrack.applyParser p mempty+            of Backtrack.Parsed l result _ -> ResultList [ResultsOfLength l [] (result:|[])] mempty+               Backtrack.NoParse failure -> ResultList mempty failure+   q rest@((s, _):_) = case Backtrack.applyParser p s+                       of Backtrack.Parsed l result _ -> +                             ResultList [ResultsOfLength l (drop l rest) (result:|[])] mempty+                          Backtrack.NoParse failure -> ResultList mempty failure

@@ -1,18 +1,39 @@-module Text.Grampa.Internal (BinTree(..), FailureInfo(..)) where+module Text.Grampa.Internal (BinTree(..), FailureInfo(..), ResultList(..), ResultsOfLength(..), fromResultList) where -import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Foldable (toList)+import Data.Functor.Classes (Show1(..))+import Data.List.NonEmpty (NonEmpty)+import Data.List (nub)+import Data.Monoid (Monoid(mappend, mempty))+import Data.Semigroup (Semigroup((<>))) import Data.Word (Word64) +import Data.Monoid.Factorial (FactorialMonoid(length))++import Text.Grampa.Class (ParseFailure(..), ParseResults)++import Prelude hiding (length, showList)+ data FailureInfo = FailureInfo !Int Word64 [String] 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 BinTree a = Fork !(BinTree a) !(BinTree a)                | Leaf !a                | EmptyTree                deriving (Show) -instance Monoid FailureInfo where-   mempty = FailureInfo 0 maxBound []-   f1@(FailureInfo s1 pos1 exp1) `mappend` f2@(FailureInfo s2 pos2 exp2)+fromResultList :: FactorialMonoid s => s -> ResultList g s r -> ParseResults [(s, r)]+fromResultList s (ResultList [] (FailureInfo _ pos msgs)) =+   Left (ParseFailure (length s - fromIntegral pos + 1) (nub msgs))+fromResultList _ (ResultList rl _failure) = Right (foldMap f rl)+   where f (ResultsOfLength _ ((s, _):_) r) = (,) s <$> toList r+         f (ResultsOfLength _ [] r) = (,) mempty <$> toList r++instance Semigroup FailureInfo where+   f1@(FailureInfo s1 pos1 exp1) <> f2@(FailureInfo s2 pos2 exp2)       | s1 < s2 = f2       | s1 > s2 = f1       | otherwise = FailureInfo s1 pos' exp'@@ -20,18 +41,55 @@                          | pos1 > pos2 = (pos2, exp2)                          | otherwise = (pos1, exp1 <> exp2) +instance Monoid FailureInfo where+   mempty = FailureInfo 0 maxBound []+   mappend = (<>)++instance Show r => Show (ResultList g s r) where+   show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")")++instance Show1 (ResultList g s) where+   liftShowsPrec _sp showList _prec (ResultList rol f) rest = +      "ResultList " ++ shows (simplify <$> toList rol) (shows f rest)+      where simplify (ResultsOfLength l _ r) = "ResultsOfLength " <> show l <> " _ " <> showList (toList r) ""++instance Show r => Show (ResultsOfLength g s r) where+   show (ResultsOfLength l _ r) = "(ResultsOfLength @" ++ show l ++ " " ++ shows r ")"++instance Functor (ResultsOfLength g s) where+   fmap f (ResultsOfLength l t r) = ResultsOfLength l t (f <$> r)++instance Functor (ResultList g s) where+   fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure++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++instance Monoid (ResultList g s r) where+   mempty = ResultList mempty mempty+   mappend = (<>)+ instance Functor BinTree where    fmap f (Fork left right) = Fork (fmap f left) (fmap f right)    fmap f (Leaf a) = Leaf (f a)    fmap _ EmptyTree = EmptyTree  instance Foldable BinTree where-   foldMap f (Fork left right) = foldMap f left <> foldMap f right+   foldMap f (Fork left right) = foldMap f left `mappend` foldMap f right    foldMap f (Leaf a) = f a    foldMap _ EmptyTree = mempty +instance Semigroup (BinTree a) where+   EmptyTree <> t = t+   t <> EmptyTree = t+   l <> r = Fork l r+ instance Monoid (BinTree a) where    mempty = EmptyTree-   mappend EmptyTree t = t-   mappend t EmptyTree = t-   mappend l r = Fork l r+   mappend = (<>)

@@ -1,16 +1,17 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, UndecidableInstances #-} -- | Backtracking parser for Parsing Expression Grammars module Text.Grampa.PEG.Backtrack (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2) import Control.Monad (Monad(..), MonadPlus(..)) -import Data.Char (isSpace) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (nub)-import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Semigroup (Semigroup(..))+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@@ -24,8 +25,9 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing(someSpace))-import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Parser.Token (TokenParsing)+import qualified Text.Parser.Token+import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,@@ -78,6 +80,9 @@    mzero = empty    mplus = (<|>) +instance Semigroup x => Semigroup (Parser g s x) where+   (<>) = liftA2 (<>)+ instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty    mappend = liftA2 mappend@@ -104,8 +109,10 @@    anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Show s, Textual.TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = () <$ takeCharsWhile1 isSpace+instance (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@@ -166,11 +173,10 @@    string s = Parser p where       p s' | Just suffix <- Cancellative.stripPrefix s s' = Parsed s suffix            | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])-   whiteSpace = () <$ takeCharsWhile isSpace    concatMany (Parser p) = Parser q       where q rest = case p rest                      of Parsed prefix suffix -> let Parsed prefix' suffix' = q suffix-                                                in Parsed (prefix <> prefix') suffix'+                                                in Parsed (mappend prefix prefix') suffix'                         NoParse{} -> Parsed mempty rest    {-# INLINABLE string #-} 

@@ -1,16 +1,17 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, UndecidableInstances #-} -- | Backtracking parser for Parsing Expression Grammars, tracking the consumed input length module Text.Grampa.PEG.Backtrack.Measured (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2) import Control.Monad (Monad(..), MonadPlus(..)) -import Data.Char (isSpace) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (nub)-import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Semigroup (Semigroup(..))+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@@ -24,8 +25,9 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing(someSpace))-import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Parser.Token (TokenParsing)+import qualified Text.Parser.Token+import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedLength :: !Int,@@ -83,6 +85,9 @@    mzero = empty    mplus = (<|>) +instance Semigroup x => Semigroup (Parser g s x) where+   (<>) = liftA2 (<>)+ instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty    mappend = liftA2 mappend@@ -109,8 +114,10 @@    anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Show s, Textual.TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = () <$ takeCharsWhile1 isSpace+instance (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@@ -174,11 +181,10 @@       p s' | Just suffix <- Cancellative.stripPrefix s s' = Parsed l s suffix            | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])       l = Factorial.length s-   whiteSpace = () <$ takeCharsWhile isSpace    concatMany (Parser p) = Parser q       where q rest = case p rest                      of Parsed l prefix suffix -> let Parsed l' prefix' suffix' = q suffix-                                                  in Parsed (l+l') (prefix <> prefix') suffix'+                                                  in Parsed (l+l') (mappend prefix prefix') suffix'                         NoParse{} -> Parsed 0 mempty rest    {-# INLINABLE string #-} 

@@ -1,15 +1,15 @@-{-# LANGUAGE InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} -- | Continuation-passing parser for Parsing Expression Grammars module Text.Grampa.PEG.Continued (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2) import Control.Monad (Monad(..), MonadPlus(..)) -import Data.Char (isSpace) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (nub)-import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString)@@ -25,8 +25,9 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing(someSpace))-import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Parser.Token (TokenParsing)+import qualified Text.Parser.Token+import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,@@ -79,6 +80,9 @@    mzero = empty    mplus = (<|>) +instance Semigroup x => Semigroup (Parser g s x) where+   (<>) = liftA2 (<>)+ instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty    mappend = liftA2 mappend@@ -110,8 +114,10 @@    anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = () <$ takeCharsWhile1 isSpace+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@@ -201,12 +207,11 @@       p s' success failure          | Just suffix <- Cancellative.stripPrefix s s' = success s suffix          | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])-   whiteSpace = () <$ takeCharsWhile isSpace    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 . (prefix <>)) (const $ success prefix suffix)+               where success' prefix suffix = q suffix (success . mappend prefix) (const $ success prefix suffix)                      failure _ = success mempty rest    {-# INLINABLE string #-} 

@@ -1,15 +1,15 @@-{-# LANGUAGE BangPatterns, InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}+{-# LANGUAGE BangPatterns, InstanceSigs, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} -- | Continuation-passing parser for Parsing Expression Grammars that keeps track of the parsed prefix length module Text.Grampa.PEG.Continued.Measured (Parser(..), Result(..), alt) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2) import Control.Monad (Monad(..), MonadPlus(..)) -import Data.Char (isSpace) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (nub)-import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Semigroup (Semigroup(..))+import Data.Monoid (Monoid(mappend, mempty)) import Data.Monoid.Factorial(FactorialMonoid) import Data.Monoid.Textual(TextualMonoid) import Data.String (fromString)@@ -25,8 +25,9 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing(someSpace))-import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Parser.Token (TokenParsing)+import qualified Text.Parser.Token+import Text.Grampa.Class (Lexical(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..)) import Text.Grampa.Internal (FailureInfo(..))  data Result (g :: (* -> *) -> *) s v = Parsed{parsedPrefix :: !v,@@ -82,6 +83,9 @@    mzero = empty    mplus = (<|>) +instance Semigroup x => Semigroup (Parser g s x) where+   (<>) = liftA2 (<>)+ instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty    mappend = liftA2 mappend@@ -113,8 +117,10 @@    anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Show s, TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = () <$ takeCharsWhile1 isSpace+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@@ -213,13 +219,12 @@       p s' success failure          | Just suffix <- Cancellative.stripPrefix s s', !len <- Factorial.length s = success s len suffix          | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])-   whiteSpace = () <$ takeCharsWhile isSpace    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 (prefix <> prefix') (len + len')) +                        q suffix (\prefix' !len'-> success (mappend prefix prefix') (len + len'))                            (const $ success prefix len suffix)                      failure _ = success mempty 0 rest    {-# INLINABLE string #-}

@@ -1,16 +1,17 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, UndecidableInstances #-} -- | Packrat parser module Text.Grampa.PEG.Packrat (Parser(..), Result(..)) where  import Control.Applicative (Applicative(..), Alternative(..), liftA2) import Control.Monad (Monad(..), MonadPlus(..)) -import Data.Char (isSpace) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..)) import Data.List (genericLength, nub)-import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Semigroup (Semigroup(..))+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@@ -24,8 +25,10 @@ import Text.Parser.Char (CharParsing) import Text.Parser.Combinators (Parsing(..)) import Text.Parser.LookAhead (LookAheadParsing(..))-import Text.Parser.Token (TokenParsing(someSpace))-import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import Text.Parser.Token (TokenParsing)+import qualified Text.Parser.Token+import Text.Grampa.Class (Lexical(..), GrammarParsing(..), MonoidParsing(..), MultiParsing(..), +                          ParseResults, ParseFailure(..)) import Text.Grampa.Internal (FailureInfo(..)) import qualified Text.Grampa.PEG.Backtrack as Backtrack (Parser) @@ -74,6 +77,9 @@    mzero = empty    mplus = (<|>) +instance Semigroup x => Semigroup (Parser g s x) where+   (<>) = liftA2 (<>)+ instance Monoid x => Monoid (Parser g s x) where    mempty = pure mempty    mappend = liftA2 mappend@@ -100,8 +106,10 @@    anyChar = satisfyChar (const True)    text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t) -instance (Show s, Textual.TextualMonoid s) => TokenParsing (Parser g s) where-   someSpace = () <$ takeCharsWhile1 isSpace+instance (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@@ -181,9 +189,8 @@       p rest@((s', _) : _)          | Cancellative.isPrefixOf s s' = Parsed s (Factorial.drop (Factorial.length s) rest)       p rest = NoParse (FailureInfo 1 (genericLength rest) ["string " ++ show s])-   whiteSpace = () <$ takeCharsWhile isSpace    concatMany p = go-      where go = (<>) <$> p <*> go <|> mempty+      where go = mappend <$> p <*> go <|> mempty   -- | Packrat parser

@@ -17,6 +17,7 @@  import Data.Functor.Compose (Compose(..)) import Text.Parser.Combinators (sepBy1, skipMany)+import Text.Parser.Token (whiteSpace)  import Test.Feat (Enumerable(..), Enumerate, FreePair(Free), consts, shared, unary, uniform) import Test.Feat.Enumerate (pay)@@ -29,7 +30,7 @@  import qualified Rank2 import qualified Rank2.TH-import Text.Grampa+import Text.Grampa hiding (symbol) import qualified Text.Grampa.ContextFree.Parallel as Parallel import qualified Text.Grampa.ContextFree.LeftRecursive as LeftRecursive @@ -43,6 +44,8 @@                              next :: f String} deriving instance (Show (f String), Show (f [String])) => Show (Recursive f) +instance Lexical Recursive+ $(Rank2.TH.deriveAll ''Recursive)  recursiveManyGrammar Recursive{..} = Recursive{@@ -56,7 +59,7 @@ nameListGrammarBuilder g@Recursive{..} = Recursive{    start= pure (const . unwords) <*> rec <*> (True <$ symbol "," <* symbol "..." <|> pure False) <|>           pure id <*> symbol "..." <?> "start",-   rec= sepBy1 one (ignorable *> string "," <* whiteSpace <?> "comma") <?> "rec",+   rec= sepBy1 one (ignorable *> string "," <?> "comma") <?> "rec",    one= do ignorable            identifier <- ((:) <$> satisfyChar isLetter <*> (toString (const "") <$> takeCharsWhile isLetter))            guard (identifier /= "reserved")@@ -93,11 +96,6 @@              [testProperty "anyToken mempty" $ simpleParse anyToken "" == Left (ParseFailure 0 ["anyToken"]),               testProperty "anyToken list" $                 \(x::Word8) xs-> simpleParse anyToken (x:xs) == Right [(xs, [x])],-              testProperty "token success" $-                \(x::Word8) xs-> simpleParse (token [x]) (x:xs) == Right [(xs, [x])],-              testProperty "token failure" $ \(x::Word8) y xs->-                   x /= y ==> results (simpleParse (token [y]) (x:xs)) == [],-              testProperty "token mempty" $ \x-> results (simpleParse (token [x]) "") == [],               testProperty "satisfy success" $ \bools->                    simpleParse (satisfy head) (True:bools) == Right [(bools, [True])],               testProperty "satisfy failure" $ \bools-> results (simpleParse (satisfy head) (False:bools)) == [],@@ -205,7 +203,6 @@                                  DescribedParser "getInput" getInput,                                  DescribedParser "empty" empty,                                  DescribedParser "mempty" mempty])-               <> pay (unary $ \t-> DescribedParser "token" (token t))                <> pay (unary $ \s-> DescribedParser "string" (string s))                <> pay (unary $ \pred-> DescribedParser "satisfy" (satisfy pred))                <> pay (unary $ \pred-> DescribedParser "takeWhile" (takeWhile pred))

@@ -1,4 +1,4 @@-{-# Language RankNTypes, ScopedTypeVariables #-}+{-# Language FlexibleInstances, RankNTypes, ScopedTypeVariables #-} module Test.Examples where  import Control.Applicative (empty, (<|>))@@ -30,7 +30,8 @@    where f = uniqueParse (fixGrammar comparisons) (Comparisons.test . Rank2.snd)          s' = f s -comparisons :: Rank2.Functor g => GrammarBuilder ArithmeticComparisons g Parser String+comparisons :: (Rank2.Functor g, Lexical g, LexicalConstraint 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} @@ -39,7 +40,8 @@    where f = uniqueParse (fixGrammar boolean) (Boolean.expr . Rank2.snd)          s' = f s -boolean :: Rank2.Functor g => GrammarBuilder ArithmeticComparisonsBoolean g Parser String+boolean :: (Rank2.Functor g, Lexical g, LexicalConstraint 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 :: Conditional -> Bool@@ -47,7 +49,7 @@    where f = uniqueParse (fixGrammar conditionals) (Conditionals.expr . Rank2.snd)          s' = f s -conditionals :: Rank2.Functor g => GrammarBuilder ACBC g Parser String+conditionals :: (Rank2.Functor g, Lexical g, LexicalConstraint 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),@@ -129,3 +131,7 @@                        Right [] -> error "Unparseable"                        Right _ -> error "Ambiguous"                        Left (ParseFailure pos exp) -> error ("At " <> show pos <> " expected one of " <> show exp)++instance Lexical ArithmeticComparisons+instance Lexical ArithmeticComparisonsBoolean+instance Lexical ACBC