grammatical-parsers (empty) → 0.1

raw patch · 23 files changed

+2769/−0 lines, 23 filesdep +QuickCheckdep +basedep +checkerssetup-changed

Dependencies added: QuickCheck, base, checkers, containers, criterion, deepseq, doctest, grammatical-parsers, monoid-subclasses, parsers, rank2classes, tasty, tasty-quickcheck, testing-feat, text, transformers

Files

• LICENSE +26/−0
• README.md +109/−0
• Setup.hs +2/−0
• examples/Arithmetic.hs +109/−0
• examples/Boolean.hs +58/−0
• examples/Combined.hs +211/−0
• examples/Comparisons.hs +74/−0
• examples/Conditionals.hs +38/−0
• examples/Lambda.hs +109/−0
• examples/Main.hs +53/−0
• examples/Utilities.hs +31/−0
• grammatical-parsers.cabal +80/−0
• src/Text/Grampa.hs +39/−0
• src/Text/Grampa/Class.hs +113/−0
• src/Text/Grampa/ContextFree/LeftRecursive.hs +448/−0
• src/Text/Grampa/ContextFree/Memoizing.hs +232/−0
• src/Text/Grampa/ContextFree/Parallel.hs +198/−0
• src/Text/Grampa/PEG/Backtrack.hs +152/−0
• src/Text/Grampa/PEG/Packrat.hs +182/−0
• test/Benchmark.hs +102/−0
• test/Doctest.hs +3/−0
• test/Test.hs +269/−0
• test/Test/Examples.hs +131/−0

@@ -0,0 +1,26 @@+Copyright (c) 2016, Mario Blažević+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the+   distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,109 @@+Grammatical Parsers+===================++Behold, yet another parser combinator library in Haskell.++You can apply the usual+[Applicative](http://hackage.haskell.org/package/base/docs/Control-Applicative.html#t:Applicative),+[Alternative](http://hackage.haskell.org/package/base/docs/Control-Applicative.html#t:Alternative), and+[Monad](http://hackage.haskell.org/package/base/docs/Control-Monad.html#t:Monad) operators to combine primitive parsers+into larger ones. The combinators from the [parsers](http://hackage.haskell.org/package/parsers) library type classes+are also available. Here are some typical imports you may need:++~~~ {.haskell}+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}+module README where+import Control.Applicative+import Data.Char (isDigit)+import Data.Functor.Classes (Show1, showsPrec1)+import Text.Grampa+import Text.Grampa.ContextFree.LeftRecursive (Parser)+import qualified Rank2.TH+~~~++What puts this library apart from most is that these parsers are *grammatical*, just as the library name says. Instead+of writing the parser definitions as top-level bindings, you can and should group them into a grammar record definition,+like this:++~~~ {.haskell}+arithmetic :: GrammarBuilder Arithmetic g Parser String+arithmetic Arithmetic{..} = Arithmetic{+   sum= product+         <|> string "-" *> (negate <$> product)+         <|> (+) <$> sum <* string "+" <*> product+         <|> (-) <$> sum <* string "-" <*> product,+   product= factor+         <|> (*) <$> product <* string "*" <*> factor+         <|> div <$> product <* string "/" <*> factor,+   factor= read <$> number+           <|> string "(" *> sum <* string ")",+   number= takeCharsWhile1 isDigit <?> "number"}+~~~++What on Earth for? One good reason is that these parser definitions can then be left-recursive, which is normally a+death knell for parser libraries. There are other benefits like memoization and grammar composability, and the main+downside is the obligation to declare the grammar record:++~~~ {.haskell}+data Arithmetic f = Arithmetic{sum     :: f Int,+                               product :: f Int,+                               factor  :: f Int,+                               number  :: f String}+~~~++and to make it an instance of several rank 2 type classes:++~~~ {.haskell}+$(Rank2.TH.deriveAll ''Arithmetic)+~~~++Optionally, you may also be inclined to declare a proper ``Show`` instance, as it's often handy:++~~~ {.haskell}+instance Show1 f => Show (Arithmetic f) where+   show Arithmetic{..} =+      "Arithmetic{\n  sum=" ++ showsPrec1 0 sum+           (",\n  product=" ++ showsPrec1 0 factor+           (",\n  factor=" ++ showsPrec1 0 factor+           (",\n  number=" ++ showsPrec1 0 number "}")))+~~~++Once that's done, use [fixGrammar](http://hackage.haskell.org/package/grammatical-parsers/docs/Text-Grampa.html#v:fixGrammar) to, well, fix the grammar++~~~ {.haskell}+grammar = fixGrammar arithmetic+~~~++and then [parseComplete](http://hackage.haskell.org/package/grammatical-parsers/docs/Text-Grampa.html#v:parseComplete)+or [parsePrefix](http://hackage.haskell.org/package/grammatical-parsers/docs/Text-Grampa.html#v:parsePrefix) to parse+some input.++~~~ {.haskell}+-- |+-- >>> parseComplete grammar "42"+-- Arithmetic{+--   sum=Compose (Right [42]),+--   product=Compose (Right [42]),+--   factor=Compose (Right [42]),+--   number=Compose (Right ["42"])}+-- >>> parseComplete grammar "1+2*3"+-- Arithmetic{+--   sum=Compose (Right [7]),+--   product=Compose (Left (ParseFailure 1 ["endOfInput"])),+--   factor=Compose (Left (ParseFailure 1 ["endOfInput"])),+--   number=Compose (Left (ParseFailure 1 ["endOfInput"]))}+-- >>> parsePrefix grammar "1+2*3"+-- Arithmetic{+--   sum=Compose (Compose (Right [("+2*3",1),("*3",3),("",7)])),+--   product=Compose (Compose (Right [("+2*3",1)])),+--   factor=Compose (Compose (Right [("+2*3",1)])),+--   number=Compose (Compose (Right [("+2*3","1")]))}+~~~++To see more grammar examples, go straight to the+[examples](https://github.com/blamario/grampa/tree/master/grammatical-parsers/examples) directory that builds up several+smaller grammars and combines them all together in the+[Combined](https://github.com/blamario/grampa/blob/master/grammatical-parsers/examples/Combined.hs) module.++For more conventional tastes there is a monolithic+[Lua grammar](https://github.com/blamario/language-lua2/blob/master/src/Language/Lua/Grammar.hs) example as well.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, RecordWildCards, ScopedTypeVariables #-}+module Arithmetic where++import Control.Applicative+import Data.Char (isDigit)+import Data.Functor.Compose (Compose(..))+import Data.Monoid ((<>))++import Text.Grampa+import Text.Grampa.ContextFree.LeftRecursive (Parser)+import Utilities (infixJoin, symbol)++import qualified Rank2+import Prelude hiding (negate, product, subtract, sum)++class ArithmeticDomain e where+   number :: Int -> e+   add :: e -> e -> e+   multiply :: e -> e -> e+   negate :: e -> e+   subtract :: e -> e -> e+   divide :: e -> e -> e++instance ArithmeticDomain Int where+   number = id+   add = (+)+   multiply = (*)+   negate = (0 -)+   subtract = (-)+   divide = div++instance ArithmeticDomain [Char] where+   number = show+   add = infixJoin "+"+   multiply = infixJoin "*"+   negate = ("-" <>)+   subtract = infixJoin "-"+   divide = infixJoin "/"++data Arithmetic e f = Arithmetic{expr    :: f e,+                                 sum     :: f e,+                                 product :: f e,+                                 factor  :: f e,+                                 primary :: f e}++instance Show (f e) => Show (Arithmetic e f) where+   showsPrec prec a rest = "Arithmetic{expr=" ++ showsPrec prec (expr a)+                           (", sum=" ++ showsPrec prec (sum a)+                            (", product=" ++ showsPrec prec (product a)+                             (", factor=" ++ showsPrec prec (factor a)+                              (", primary=" ++ showsPrec prec (primary a) ("}" ++ rest)))))++instance Rank2.Functor (Arithmetic e) where+   f <$> a = a{expr= f (expr a),+               sum= f (sum a),+               product= f (product a),+               factor= f (factor a),+               primary= f (primary a)}++instance Rank2.Apply (Arithmetic e) where+   a <*> a' = Arithmetic (expr a `Rank2.apply` expr a')+                         (sum a `Rank2.apply` sum a')+                         (product a `Rank2.apply` product a')+                         (factor a `Rank2.apply` factor a')+                         (primary a `Rank2.apply` primary a')++instance Rank2.Applicative (Arithmetic e) where+   pure f = Arithmetic f f f f f++instance Rank2.Distributive (Arithmetic e) where+   distributeM f = Arithmetic{expr= f >>= expr,+                              sum= f >>= sum,+                              product= f >>= product,+                              factor= f >>= factor,+                              primary= f >>= primary}+   distributeWith w f = Arithmetic{expr= w (expr <$> f),+                                   sum= w (sum <$> f),+                                   product= w (product <$> f),+                                   factor= w (factor <$> f),+                                   primary= w (primary <$> f)}++instance Rank2.Foldable (Arithmetic e) where+   foldMap f a = f (expr a) <> f (sum a) <> f (product a) <> f (factor a) <> f (primary a)++instance Rank2.Traversable (Arithmetic e) where+   traverse f a = Arithmetic+                  <$> f (expr a)+                  <*> f (sum a)+                  <*> f (product a)+                  <*> f (factor a)+                  <*> f (primary a)++arithmetic :: ArithmeticDomain e => GrammarBuilder (Arithmetic e) g Parser String+arithmetic Arithmetic{..} = Arithmetic{+   expr= sum,+   sum= product+         <|> symbol "-" *> (negate <$> product)+         <|> add <$> sum <* symbol "+" <*> product+         <|> subtract <$> sum <* symbol "-" <*> product,+   product= factor+         <|> multiply <$> product <* symbol "*" <*> factor+         <|> divide <$> product <* symbol "/" <*> factor,+   factor= primary+           <|> symbol "(" *> expr <* symbol ")",+   primary= whiteSpace *> ((number . read) <$> takeCharsWhile1 isDigit <?> "digits")}++main :: IO ()+main = getContents >>=+       print . (getCompose . expr . parseComplete (fixGrammar arithmetic) :: String -> ParseResults [Int])

@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}+module Boolean where++import Control.Applicative+import qualified Data.Bool+import Data.Char (isSpace)+import Data.Monoid ((<>))++import qualified Rank2.TH++import Text.Grampa+import Utilities (infixJoin, keyword, symbol)++import Prelude hiding (and, or, not)++class BooleanDomain e where+   and :: e -> e -> e+   or :: e -> e -> e+   not :: e -> e+   true :: e+   false :: e++instance BooleanDomain Bool where+   true = True+   false = False+   and = (&&)+   or = (||)+   not = Data.Bool.not++instance BooleanDomain [Char] where+   true = "True"+   false = "False"+   and = infixJoin "&&"+   or = infixJoin "||"+   not = ("not " <> )++data Boolean e f =+   Boolean{+      expr :: f e,+      term :: f e,+      factor :: f e}+   deriving Show++$(Rank2.TH.deriveAll ''Boolean)++boolean :: forall e p (g :: (* -> *) -> *).+           (BooleanDomain e, Alternative (p g String), Parsing (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+         <|> or <$> expr <* symbol "||" <*> term,+   term= factor+         <|> and <$> term <* symbol "&&" <*> factor,+   factor= keyword "True" *> pure true+           <|> keyword "False" *> pure false+           <|> keyword "not" *> takeCharsWhile isSpace *> (not <$> factor)+           <|> p+           <|> symbol "(" *> expr <* symbol ")"}

@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, UndecidableInstances #-}++module Combined where++import Control.Applicative+import qualified Data.Bool+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Rank2.TH+import Text.Grampa (GrammarBuilder)+import Text.Grampa.ContextFree.LeftRecursive (Parser)+import qualified Arithmetic+import qualified Boolean+import qualified Comparisons+import qualified Conditionals+import qualified Lambda++data Expression f =+   Expression{+      expr :: f Domain,+      term :: f Domain,+      primary :: f Domain,+      arithmeticGrammar :: Arithmetic.Arithmetic Domain f,+      booleanGrammar :: Boolean.Boolean Domain f,+      comparisonGrammar :: Comparisons.Comparisons Domain Domain f,+      conditionalGrammar :: Conditionals.Conditionals Domain Domain f,+      lambdaGrammar :: Lambda.Lambda Domain f}++data Tagged = IntExpression {intFromExpression :: Int}+            | BoolExpression {boolFromExpression :: Bool}+            | FunctionExpression {functionFromExpression :: Tagged -> Tagged}+            | TypeError String+            deriving (Eq, Ord, Show)++type Env = Map String Tagged++type Domain = Env -> Tagged++instance Eq (Tagged -> Tagged) where+   (==) = error "Can't compare fuctions"++instance Ord (Tagged -> Tagged) where+   (<=) = error "Can't compare fuctions"++instance Show (Tagged -> Tagged) where+   show _ = "function"++instance Arithmetic.ArithmeticDomain Tagged where+   number = IntExpression+   IntExpression a `add` IntExpression b = IntExpression (a+b)+   _ `add` _ = TypeError "type error: add expects numbers"+   IntExpression a `multiply` IntExpression b = IntExpression (a*b)+   _ `multiply` _ = TypeError "type error: multiply expects numbers"+   negate (IntExpression a) = IntExpression (Prelude.negate a)+   negate _ = TypeError "type error: negate expects a number"+   IntExpression a `subtract` IntExpression b = IntExpression (a-b)+   _ `subtract` _ = TypeError "type error: subtract expects numbers"+   IntExpression a `divide` IntExpression b = IntExpression (div a b)+   _ `divide` _ = TypeError "type error: divide expects numbers"++instance Arithmetic.ArithmeticDomain (Env -> Tagged) where+   number n _ = IntExpression n+   (a `add` b) env = case (a env, b env)+                     of (IntExpression a', IntExpression b') -> IntExpression (a' + b')+                        _ -> TypeError "type error: add expects numbers"+   (a `multiply` b) env = case (a env, b env)+                          of (IntExpression a', IntExpression b') -> IntExpression (a' * b')+                             _ -> TypeError "type error: multiply expects numbers"+   negate a env = case a env+                  of IntExpression a' -> IntExpression (Prelude.negate a')+                     _ -> TypeError "type error: negate expects a number"+   (a `subtract` b) env = case (a env, b env)+                          of (IntExpression a', IntExpression b') -> IntExpression (a' - b')+                             _ -> TypeError "type error: subtract expects numbers"+   (a `divide` b) env = case (a env, b env)+                        of (IntExpression a', IntExpression b') -> IntExpression (div a' b')+                           _ -> TypeError "type error: divide expects numbers"++instance Boolean.BooleanDomain (Env -> Tagged) where+   true _ = BoolExpression True+   false _ = BoolExpression False+   (a `and` b) env = case (a env, b env)+                     of (BoolExpression a', BoolExpression b') -> BoolExpression (a' && b')+                        _ -> TypeError "type error: and expects booleans"+   (a `or` b) env = case (a env, b env)+                    of (BoolExpression a', BoolExpression b') -> BoolExpression (a' || b')+                       _ -> TypeError "type error: r expects booleans"+   not a env = case a env+               of BoolExpression a' -> BoolExpression (Data.Bool.not a')+                  _ -> TypeError "type error: not expects a boolean"++instance Comparisons.ComparisonDomain Domain Domain  where+   greaterThan a b env = BoolExpression (a env > b env)+   lessThan a b env = BoolExpression (a env < b env)+   equal a b env = BoolExpression (a env == b env)+   greaterOrEqual a b env = BoolExpression (a env >= b env)+   lessOrEqual a b env = BoolExpression (a env <= b env)++instance Conditionals.ConditionalDomain Domain Domain where+   ifThenElse test t f env = case test env+                             of BoolExpression True -> t env+                                BoolExpression False -> f env+                                _ -> TypeError "type error: if expects a boolean"++instance Lambda.LambdaDomain (Env -> Tagged) where+   apply f arg env = case (f env, arg env)+                     of (FunctionExpression f', x) -> f' x+                        (f', _) -> TypeError ("Applying a non-function " ++ show f')+   lambda v body env = FunctionExpression (\arg-> body (Map.insert v arg env))+   var v env = Map.findWithDefault (TypeError $ "Free variable " ++ show v) v env++instance (Show (f Domain), Show (f String)) => Show (Expression f) where+   showsPrec prec g rest = "Expression{expr=" ++ showsPrec prec (expr g)+                           (", arithmeticGrammar=" ++ showsPrec prec (arithmeticGrammar g)+                           (", booleanGrammar=" ++ showsPrec prec (booleanGrammar g)+                           (", comparisonGrammar=" ++ showsPrec prec (comparisonGrammar g)+                           (", conditionalGrammar=" ++ showsPrec prec (conditionalGrammar g)+                           (", lambdaGrammar=" ++ showsPrec prec (lambdaGrammar g) ("}" ++ rest))))))++$(Rank2.TH.deriveAll ''Expression)++{-+instance Rank2.Functor Expression where+   f <$> g = g{expr= f (expr g),+               term= f (term g),+               primary= f (primary g),+               arithmeticGrammar= Rank2.fmap f (arithmeticGrammar g),+               booleanGrammar= Rank2.fmap f (booleanGrammar g),+               comparisonGrammar= Rank2.fmap f (comparisonGrammar g),+               conditionalGrammar= Rank2.fmap f (conditionalGrammar g),+               lambdaGrammar= Rank2.fmap f (lambdaGrammar g)}++instance Rank2.Apply Expression where+   a <*> b = Expression{expr= expr a `Rank2.apply` expr b,+                        term= term a `Rank2.apply` term b,+                        primary= primary a `Rank2.apply` primary b,+                        arithmeticGrammar= arithmeticGrammar a `Rank2.ap` arithmeticGrammar b,+                        booleanGrammar= booleanGrammar a `Rank2.ap` booleanGrammar b,+                        comparisonGrammar= comparisonGrammar a `Rank2.ap` comparisonGrammar b,+                        conditionalGrammar= conditionalGrammar a `Rank2.ap` conditionalGrammar b,+                        lambdaGrammar= lambdaGrammar a `Rank2.ap` lambdaGrammar b}++instance Rank2.Applicative Expression where+   pure f = Expression{expr= f,+                       term= f,+                       primary= f,+                       arithmeticGrammar= Rank2.pure f,+                       booleanGrammar= Rank2.pure f,+                       comparisonGrammar= Rank2.pure f,+                       conditionalGrammar= Rank2.pure f,+                       lambdaGrammar= Rank2.pure f}++instance Rank2.Distributive Expression where+   distributeM f = Expression{expr= f >>= expr,+                              term= f >>= term,+                              primary= f >>= primary,+                              arithmeticGrammar= Rank2.distributeM (arithmeticGrammar <$> f),+                              booleanGrammar= Rank2.distributeM (booleanGrammar <$> f),+                              comparisonGrammar= Rank2.distributeM (comparisonGrammar <$> f),+                              conditionalGrammar= Rank2.distributeM (conditionalGrammar <$> f),+                              lambdaGrammar= Rank2.distributeM (lambdaGrammar <$> f)}+   distributeWith w f = Expression{expr= w (expr <$> f),+                                   term= w (term <$> f),+                                   primary= w (primary <$> f),+                                   arithmeticGrammar= Rank2.distributeWith w (arithmeticGrammar <$> f),+                                   booleanGrammar= Rank2.distributeWith w (booleanGrammar <$> f),+                                   comparisonGrammar= Rank2.distributeWith w (comparisonGrammar <$> f),+                                   conditionalGrammar= Rank2.distributeWith w (conditionalGrammar <$> f),+                                   lambdaGrammar= Rank2.distributeWith w (lambdaGrammar <$> f)}++instance Rank2.Foldable Expression where+   foldMap f g = f (expr g) <> f (term g) <> f (primary g)+                 <> Rank2.foldMap f (arithmeticGrammar g) <> Rank2.foldMap f (booleanGrammar g)+                 <> Rank2.foldMap f (comparisonGrammar g) <> Rank2.foldMap f (conditionalGrammar g)+                 <> Rank2.foldMap f (lambdaGrammar g)++instance Rank2.Traversable Expression where+   traverse f g = Expression+                  <$> f (expr g)+                  <*> f (term g)+                  <*> f (primary g)+                  <*> Rank2.traverse f (arithmeticGrammar g)+                  <*> Rank2.traverse f (booleanGrammar g)+                  <*> Rank2.traverse f (comparisonGrammar g)+                  <*> Rank2.traverse f (conditionalGrammar g)+                  <*> Rank2.traverse f (lambdaGrammar g)+-}++expression :: GrammarBuilder Expression g Parser String+expression Expression{..} =+   let combinedExpr = Arithmetic.expr arithmeticGrammar+                      <|> Boolean.expr booleanGrammar+                      <|> Conditionals.expr conditionalGrammar+                      <|> Lambda.expr lambdaGrammar+       combinedTerm = Lambda.application lambdaGrammar+                      <|> Arithmetic.sum arithmeticGrammar+       combinedPrimary = Arithmetic.primary arithmeticGrammar+                         <|> Boolean.factor booleanGrammar+                         <|> Lambda.primary lambdaGrammar+   in Expression{expr= combinedExpr,+                 term= combinedTerm,+                 primary= combinedPrimary,+                 arithmeticGrammar= Arithmetic.arithmetic arithmeticGrammar{Arithmetic.expr= expr,+                                                                            Arithmetic.primary= primary},+                 booleanGrammar= Boolean.boolean (Comparisons.test comparisonGrammar) booleanGrammar,+                 comparisonGrammar= Comparisons.comparisons comparisonGrammar{Comparisons.term= Arithmetic.expr arithmeticGrammar},+                 conditionalGrammar= Conditionals.conditionals conditionalGrammar{Conditionals.test= Boolean.expr booleanGrammar,+                                                                                  Conditionals.term= expr},+                 lambdaGrammar= Lambda.lambdaCalculus lambdaGrammar{Lambda.expr= expr,+                                                                    Lambda.application= term,+                                                                    Lambda.primary= primary}}

@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables #-}+module Comparisons where++import Control.Applicative+import Data.Monoid ((<>))++import qualified Rank2+import Text.Grampa+import Utilities (symbol)++class ComparisonDomain c e where+   greaterThan :: c -> c -> e+   lessThan :: c -> c -> e+   equal :: c -> c -> e+   greaterOrEqual :: c -> c -> e+   lessOrEqual :: c -> c -> e++instance Ord c => ComparisonDomain c Bool where+   greaterThan a b = a > b+   lessThan a b = a < b+   equal a b = a == b+   greaterOrEqual a b = a >= b+   lessOrEqual a b = a <= b++instance ComparisonDomain [Char] [Char] where+   lessThan = infixJoin "<"+   lessOrEqual = infixJoin "<="+   equal = infixJoin "=="+   greaterOrEqual = infixJoin ">="+   greaterThan = infixJoin ">"++infixJoin :: String -> String -> String -> String+infixJoin rel a b = a <> rel <> b++data Comparisons c e f =+   Comparisons{test :: f e,+               term :: f c}+   deriving (Show)++instance Rank2.Functor (Comparisons c e) where+   f <$> g = g{test= f (test g),+               term= f (term g)}++instance Rank2.Apply (Comparisons c e) where+   g <*> h = Comparisons{test= test g `Rank2.apply` test h,+                         term= term g `Rank2.apply` term h}++instance Rank2.Applicative (Comparisons c e) where+   pure f = Comparisons f f++instance Rank2.Distributive (Comparisons c e) where+   distributeM f = Comparisons{test= f >>= test,+                               term= f >>= term}+   distributeWith w f = Comparisons{test= w (test <$> f),+                                    term= w (term <$> f)}++instance Rank2.Foldable (Comparisons c e) where+   foldMap f g = f (test g) <> f (term g)++instance Rank2.Traversable (Comparisons c e) where+   traverse f g = Comparisons +                  <$> f (test g)+                  <*> f (term g)++comparisons :: (ComparisonDomain c e, Alternative (p g String), MonoidParsing (p g)) =>+               GrammarBuilder (Comparisons c e) g p String+comparisons Comparisons{..} =+   Comparisons{+      test= lessThan <$> term <* symbol "<" <*> term+            <|> lessOrEqual <$> term <* symbol "<=" <*> term+            <|> equal <$> term <* symbol "==" <*> term+            <|> greaterOrEqual <$> term <* symbol ">=" <*> term+            <|> greaterThan <$> term <* symbol ">" <*> term,+      term= empty}

@@ -0,0 +1,38 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell #-}+module Conditionals where++import Control.Applicative+import Data.Monoid ((<>))++import qualified Rank2.TH++import Text.Grampa+import Text.Grampa.ContextFree.LeftRecursive (Parser)+import Utilities (keyword)++class ConditionalDomain c e where+   ifThenElse :: c -> e -> e -> e++instance ConditionalDomain Bool e where+   ifThenElse True t _ = t+   ifThenElse False _ f = f++instance ConditionalDomain [Char] [Char] where+   ifThenElse cond t f = "if " <> cond <> " then " <> t <> " else " <> f++data Conditionals t e f = Conditionals{expr :: f e,+                                       test :: f t,+                                       term :: f e}++instance (Show (f t), Show (f e)) => Show (Conditionals t e f) where+   showsPrec prec a rest = "Conditionals{expr=" ++ showsPrec prec (expr a)+                           (", test= " ++ showsPrec prec (test a)+                            (", term= " ++ showsPrec prec (term a) ("}" ++ rest)))++$(Rank2.TH.deriveAll ''Conditionals)++conditionals :: ConditionalDomain t e => GrammarBuilder (Conditionals t e) g Parser String+conditionals Conditionals{..} =+   Conditionals{expr= ifThenElse <$> (keyword "if" *> test) <*> (keyword "then" *> term) <*> (keyword "else" *> term),+                test= empty,+                term= empty}

@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}+module Lambda where++import Control.Applicative+import Data.Char (isAlphaNum, isLetter)+import Data.Map (Map, insert, (!))+import Data.Monoid ((<>))++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+   lambda :: String -> e -> e+   var :: String -> e++data LambdaInitial = ApplyI LambdaInitial LambdaInitial+                   | LambdaI String LambdaInitial+                   | VarI String+                   deriving Show++data LambdaDeBruin = ApplyB LambdaDeBruin LambdaDeBruin+                   | LambdaB LambdaDeBruin+                   | VarB Int+                   deriving Show++data LambdaPHOAS a = ApplyP (LambdaPHOAS a) (LambdaPHOAS a)+                   | LambdaP (a -> LambdaPHOAS a)+                   | VarP a++instance LambdaDomain (Map String a -> [a] -> a) where+   apply f arg env stack = f env (arg env [] : stack)+   lambda v body env (arg:stack) = body (insert v arg env) stack+   var v env _stack = env ! v++reduceNormallyI :: Map String a -> [a] -> LambdaInitial -> a+reduceNormallyI env stack (ApplyI f arg) = reduceNormallyI env (reduceNormallyI env stack arg : stack) f+reduceNormallyI env (arg:stack) (LambdaI v body) = reduceNormallyI (insert v arg env) stack body+reduceNormallyI env _stack (VarI v) = env ! v++reduceNormallyP :: (a -> LambdaPHOAS a) -> LambdaPHOAS a -> LambdaPHOAS a+reduceNormallyP use (ApplyP f arg) = case reduceNormallyP use f+                                     of LambdaP f' -> reduceNormallyP use (reduceNormallyP f' arg)+                                        x -> ApplyP x arg+reduceNormallyP use (VarP x) = use x+reduceNormallyP _ x@LambdaP{} = x++instance LambdaDomain LambdaInitial where+   apply = ApplyI+   lambda = LambdaI+   var = VarI++instance LambdaDomain (Map String a -> LambdaPHOAS a) where+   apply f arg env = ApplyP (f env) (arg env)+   lambda v body env = LambdaP (\x-> body $ insert v x env)+   var v env = VarP (env ! v)++instance LambdaDomain (Map String Int -> Int -> LambdaDeBruin) where+   apply f arg env depth = ApplyB (f env depth) (arg env depth)+   lambda v body env depth = LambdaB (body (insert v (succ depth) env) (succ depth))+   var v env depth = VarB (depth - env ! v)++{-+instance LambdaDomain (Map String e -> [e] -> e) where+   apply f arg env stack = f env (arg env stack : stack)+   lambda v body env (arg : stack) = body (insert v arg env) stack+   var v map = (map ! v) map+-}++instance LambdaDomain String where+   apply f arg = f ++ " " ++ arg+   lambda v body = "(\\" ++ v ++ ". " ++ body ++ ")"+   var v = v++data Lambda e f =+   Lambda{+      expr :: f e,+      abstraction :: f e,+      application :: f e,+      argument :: f e,+      primary :: f e,+      varName :: f String}++instance (Show (f e), Show (f String)) => Show (Lambda e f) where+   showsPrec prec g rest = "Lambda{expr=" ++ showsPrec prec (expr g)+                           (", abstraction=" ++ showsPrec prec (abstraction g)+                            (", application=" ++ showsPrec prec (application g)+                             (", argument=" ++ showsPrec prec (application g)+                              (", primary=" ++ showsPrec prec (primary g)+                               (", varName=" ++ showsPrec prec (varName g) ("}" ++ rest))))))++$(Rank2.TH.deriveAll ''Lambda)++lambdaCalculus :: LambdaDomain e => GrammarBuilder (Lambda e) g Parser String+lambdaCalculus Lambda{..} = Lambda{+   expr= abstraction,+   abstraction= lambda <$> (symbol "\\" *> varName <* symbol "->") <*> abstraction+                <|> application,+   application= apply <$> application <*> argument+                <|> argument,+   argument= symbol "(" *> expr <* symbol ")"+             <|> primary,+   primary= var <$> varName,+   varName= whiteSpace *> takeCharsWhile1 isLetter <> takeCharsWhile isAlphaNum}

@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, 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.ContextFree.LeftRecursive (Parser)+import Arithmetic (Arithmetic, arithmetic)+import qualified Arithmetic+import qualified Boolean+import qualified Comparisons+import qualified Conditionals+import qualified Combined+import qualified Lambda++type ArithmeticComparisons = Rank2.Product (Arithmetic.Arithmetic Int) (Comparisons.Comparisons Int Bool)+type ArithmeticComparisonsBoolean = Rank2.Product ArithmeticComparisons (Boolean.Boolean Bool)+type ACBC = Rank2.Product ArithmeticComparisonsBoolean (Conditionals.Conditionals Bool Int)+   +main :: IO ()+main = do args <- concat <$> getArgs+          -- let a = fixGrammar (Arithmetic.arithmetic (production id Arithmetic.expr a))+          -- let a = fixGrammar (Arithmetic.arithmetic (recursive $ Arithmetic.expr a))+          print (getCompose . Lambda.expr $ parseComplete (fixGrammar Lambda.lambdaCalculus) args+                 :: ParseResults [Lambda.LambdaInitial])+          -- print (((\f-> f (mempty :: Map String Int) [1 :: Int]) <$>) <$> parse (fixGrammar Lambda.lambdaCalculus) Lambda.expr args :: ParseResults Int)+          print (getCompose . Arithmetic.expr $ parseComplete (fixGrammar arithmetic) args :: ParseResults [Int])+          print (getCompose . Comparisons.test . Rank2.snd $ parseComplete (fixGrammar comparisons) args+                 :: ParseResults [Bool])+          print (getCompose . Boolean.expr . Rank2.snd $+                 parseComplete (fixGrammar boolean) args :: ParseResults [Bool])+          print (getCompose . Conditionals.expr . Rank2.snd $ parseComplete (fixGrammar conditionals) args+                 :: ParseResults [Int])+          print (((\f-> f (mempty :: Map String Combined.Tagged)) <$>)+                 <$> (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 (Rank2.Pair a c) =+   Rank2.Pair (Arithmetic.arithmetic a) (Comparisons.comparisons c{Comparisons.term= Arithmetic.expr a})++boolean :: 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 (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)})

@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, KindSignatures, RankNTypes, ScopedTypeVariables #-}+module Utilities where++import Data.Char (isAlphaNum)+import Data.Functor.Compose (Compose(..))+import Data.List (intercalate)+import Data.Monoid ((<>))+import Data.Monoid.Factorial (FactorialMonoid)+import Data.Monoid.Textual (TextualMonoid)++import Text.Grampa+import Text.Grampa.ContextFree.LeftRecursive+import qualified Rank2++parseUnique :: (FactorialMonoid s, Rank2.Traversable g, Rank2.Distributive g, Rank2.Apply g) =>+               Grammar g Parser s -> (forall f. g f -> f r) -> s -> r+parseUnique g prod s = case getCompose (prod $ parseComplete g s)+                       of Left (ParseFailure pos expected) -> error ("Parse failure at " ++ show pos+                                                                     ++ ", expected " ++ intercalate " or " expected)+                          Right [x] -> x++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

@@ -0,0 +1,80 @@+name:                grammatical-parsers+version:             0.1+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+  to grammar record fields. All parser types support the same set of parser combinators, but have different semantics+  and performance characteristics.++homepage:            https://github.com/blamario/grampa/tree/master/grammatical-parsers+bug-reports:         https://github.com/blamario/grampa/issues+license:             BSD3+license-file:        LICENSE+author:              Mario Blažević+maintainer:          Mario Blažević <blamario@protonmail.com>+copyright:           (c) 2017 Mario Blažević+category:            Text+build-type:          Simple+cabal-version:       >=1.10+extra-source-files:  README.md+source-repository head+  type:              git+  location:          https://github.com/blamario/grampa++library+  hs-source-dirs:      src+  exposed-modules:     Text.Grampa,+                       Text.Grampa.PEG.Backtrack, Text.Grampa.PEG.Packrat,+                       Text.Grampa.ContextFree.Parallel, Text.Grampa.ContextFree.Memoizing,+                       Text.Grampa.ContextFree.LeftRecursive+  other-modules:       Text.Grampa.Class+  default-language:    Haskell2010+  -- other-modules:+  ghc-options:         -Wall+  build-depends:       base >=4.7 && <5,+                       rank2classes < 1.0,+                       containers >= 0.4 && < 0.6,+                       transformers >= 0.5 && < 0.6,+                       monoid-subclasses >=0.4 && <0.5,+                       parsers < 0.13+  -- hs-source-dirs:      +  default-language:    Haskell2010++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,+                       rank2classes < 1.0, grammatical-parsers == 0.1,+                       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 == 0.1,+                     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+  default-language:  Haskell2010++test-suite           doctests+  type:              exitcode-stdio-1.0+  hs-source-dirs:    test+  default-language:  Haskell2010+  main-is:           Doctest.hs+  ghc-options:       -threaded -pgmL markdown-unlit+  build-depends:     base, rank2classes, doctest >= 0.8++benchmark            benchmarks+  type:              exitcode-stdio-1.0+  hs-source-dirs:    test, examples+  ghc-options:       -O2 -Wall -rtsopts -main-is Benchmark.main+  Build-Depends:     base >=4.7 && < 5, rank2classes < 1.0, grammatical-parsers == 0.1, monoid-subclasses >=0.4 && <0.5,+                     criterion >= 1.0, deepseq >= 1.1, containers >= 0.5.7.0 && < 0.6, text >= 1.1+  main-is:           Benchmark.hs+  other-modules:     Arithmetic+  default-language:  Haskell2010

@@ -0,0 +1,39 @@+-- | Collection of parsing algorithms with a common interface, operating on grammars represented as records with rank-2+-- field types.+{-# LANGUAGE FlexibleContexts, KindSignatures, RankNTypes, ScopedTypeVariables #-}+module Text.Grampa (+   -- * Parsing methods+   MultiParsing(..),+   simply,+   -- * Types+   Grammar, GrammarBuilder, ParseResults, ParseFailure(..),+   -- * Parser combinators and primitives+   GrammarParsing(..), MonoidParsing(..),+   module Text.Parser.Char,+   module Text.Parser.Combinators,+   module Text.Parser.LookAhead)+where++import Text.Parser.Char (CharParsing(char, notChar, anyChar))+import Text.Parser.Combinators (Parsing((<?>), notFollowedBy, skipMany, skipSome, unexpected))+import Text.Parser.LookAhead (LookAheadParsing(lookAhead))++import Data.Functor.Compose (Compose(..))+import qualified Rank2+import Text.Grampa.Class (MultiParsing(..), GrammarParsing(..), MonoidParsing(..), ParseResults, ParseFailure(..))++-- | 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)++-- | A type synonym for an endomorphic function on a grammar record type @g@, whose parsers of type @p@ build grammars+-- of type @g'@, parsing input streams of type @s@+type GrammarBuilder (g  :: (* -> *) -> *)+                    (g' :: (* -> *) -> *)+                    (p  :: ((* -> *) -> *) -> * -> * -> *)+                    (s  :: *)+   = g (p g' s) -> g (p g' s)++-- | Apply the given 'parse' function to the given grammar-free parser and its input.+simply :: (Rank2.Only r (p (Rank2.Only r) s) -> s -> Rank2.Only r f)+            -> p (Rank2.Only r) s r -> s -> f r+simply parseGrammar p input = Rank2.fromOnly (parseGrammar (Rank2.Only p) input)

@@ -0,0 +1,113 @@+{-# LANGUAGE ConstraintKinds, RankNTypes, TypeFamilies #-}+module Text.Grampa.Class (MultiParsing(..), GrammarParsing(..), MonoidParsing(..),+                          ParseResults, ParseFailure(..), completeParser) where++import Data.Functor.Compose (Compose(..))+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 GHC.Exts (Constraint)+import Text.Parser.Combinators (Parsing)++import qualified Rank2++type ParseResults = Either ParseFailure++-- | A 'ParseFailure' contains the offset of the parse failure and the list of things expected at that offset. +data ParseFailure = ParseFailure Int [String] deriving (Eq, Show)++completeParser :: MonoidNull s => Compose ParseResults (Compose [] ((,) s)) r -> Compose ParseResults [] r+completeParser (Compose (Left failure)) = Compose (Left failure)+completeParser (Compose (Right (Compose results))) =+   case filter (Null.null . fst) results+   of [] -> Compose (Left $ ParseFailure 0 ["complete parse"])+      completeResults -> Compose (Right $ snd <$> completeResults)++-- | Choose one of the instances of this class to parse with.+class MultiParsing m where+   -- | Some parser types produce a single result, others a list of results.+   type ResultFunctor m :: * -> *+   type GrammarConstraint m (g :: (* -> *) -> *) :: Constraint+   type GrammarConstraint m g = Rank2.Functor g+   -- | Given a rank-2 record of parsers and input, produce a record of parses of the complete input.+   parseComplete :: (GrammarConstraint m g, FactorialMonoid s) =>+                    g (m g s) -> s -> g (ResultFunctor m)+   -- | Given a rank-2 record of parsers and input, produce a record of prefix parses paired with the remaining input+   -- suffix.+   parsePrefix :: (GrammarConstraint m g, FactorialMonoid s) =>+                  g (m g s) -> s -> g (Compose (ResultFunctor m) ((,) s))++-- | Parsers that belong to this class 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+   nonTerminal :: (g (GrammarFunctor m g s) -> GrammarFunctor m g s a) -> m g s a+   -- | Construct a grammar whose every production refers to itself.+   selfReferring :: Rank2.Distributive g => g (m g s)+   -- | Convert a self-referring grammar function to a grammar.+   fixGrammar :: forall g s. Rank2.Distributive g => (g (m g s) -> g (m g s)) -> g (m g s)+   -- | Mark a parser that relies on primitive recursion to prevent an infinite loop in 'fixGrammar'.+   recursive :: m g s a -> m g s a++   selfReferring = Rank2.distributeWith nonTerminal id+   fixGrammar = ($ selfReferring)+   recursive = id++-- | Methods for parsing monoidal inputs+class MonoidParsing m where+   -- | A parser that fails on any input and succeeds at its end.+   endOfInput :: FactorialMonoid s => m s ()+   -- | Always sucessful parser that returns the remaining input without consuming it.+   getInput :: MonoidNull s => m s s++   -- | 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 an input character only if it satisfies the+   -- given predicate.+   satisfyChar :: TextualMonoid s => (Char -> Bool) -> m s Char++   -- | A stateful scanner. The predicate modifies a state argument, and each transformed state is passed to successive+   -- invocations of the predicate on each token of the input until one returns 'Nothing' or the input ends.+   --+   -- This parser does not fail.  It will return an empty string if the predicate returns 'Nothing' on the first+   -- character.+   --+   -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers+   -- loop until a failure occurs.  Careless use will thus result in an infinite loop.+   scan :: FactorialMonoid t => s -> (s -> t -> Maybe s) -> m t t+   -- | Stateful scanner like `scanChars`, but specialized for 'TextualMonoid' inputs.+   scanChars :: TextualMonoid t => s -> (s -> Char -> Maybe s) -> m t t+   -- | A parser that consumes and returns the given prefix of the input.+   string :: (FactorialMonoid s, LeftReductiveMonoid s, Show s) => s -> m s s++   -- | A parser accepting the longest sequence of input atoms that match the given predicate; an optimized version of+   -- 'concatMany . satisfy'.+   --+   -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers+   -- loop until a failure occurs.  Careless use will thus result in an infinite loop.+   takeWhile :: FactorialMonoid s => (s -> Bool) -> m s s+   -- | A parser accepting the longest non-empty sequence of input atoms that match the given predicate; an optimized+   -- version of 'concatSome . satisfy'.+   takeWhile1 :: FactorialMonoid s => (s -> Bool) -> m s s+   -- | Specialization of 'takeWhile' on 'TextualMonoid' inputs, accepting the longest sequence of input characters that+   -- match the given predicate; an optimized version of 'fmap fromString  . many . satisfyChar'.+   --+   -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers+   -- loop until a failure occurs.  Careless use will thus result in an infinite loop.+   takeCharsWhile :: TextualMonoid s => (Char -> Bool) -> m s s+   -- | Specialization of 'takeWhile1' on 'TextualMonoid' inputs, accepting the longest sequence of input characters+   -- that match the given predicate; an optimized version of 'fmap fromString  . some . satisfyChar'.+   takeCharsWhile1 :: TextualMonoid s => (Char -> Bool) -> m s s+   -- | 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)

@@ -0,0 +1,448 @@+{-# LANGUAGE FlexibleContexts, GADTs, InstanceSigs, GeneralizedNewtypeDeriving,+             RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}+{-# OPTIONS -fno-full-laziness #-}+module Text.Grampa.ContextFree.LeftRecursive (Parser)+where++import Control.Applicative+import Control.Arrow((&&&))+import Control.Monad (Monad(..), MonadPlus(..))+import Control.Monad.Trans.State.Lazy (State, evalState, get, put)++import Data.Char (isSpace)+import Data.Functor.Classes (Show1(..))+import Data.Functor.Compose (Compose(..))+import Data.IntMap (IntMap)+import Data.IntSet (IntSet)+import Data.Maybe (isJust, maybe)++import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet++import Data.Monoid (Monoid(mempty), All(..), Any(..), (<>))+import Data.Monoid.Null (MonoidNull(null))+import Data.Monoid.Factorial (FactorialMonoid)+import Data.Monoid.Textual (TextualMonoid)+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Textual as Textual+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(someSpace))++import qualified Rank2+import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults)+import Text.Grampa.ContextFree.Memoizing (ResultList(..), fromResultList)+import qualified Text.Grampa.ContextFree.Memoizing as Memoizing++import Prelude hiding (null, showsPrec, span, takeWhile)++data Parser g s a where+   NonTerminal   :: (g (Parser g s) -> Parser g s a) -> Parser g s a+   Primitive     :: String -> Maybe (Memoizing.Parser g s a) -> Maybe (Memoizing.Parser g s a)+                 -> Memoizing.Parser g s a -> Parser g s a+   Recursive     :: Parser g s a -> Parser g s a+   Map           :: (a -> b) -> Parser g s a -> Parser g s b+   Ap            :: Parser g s (a -> b) -> Parser g s a -> Parser g s b+   Pure          :: a -> Parser g s a+   Empty         :: Parser g s a+   Bind          :: Parser g s a -> (a -> Parser g s b) -> Parser g s b+   Choice        :: Parser g s a -> Parser g s a -> Parser g s a+   Try           :: Parser g s a -> Parser g s a+   Describe      :: Parser g s a -> String -> Parser g s a+   NotFollowedBy :: Show a => Parser g s a -> Parser g s ()+   Lookahead     :: Parser g s a -> Parser g s a+   Many          :: Parser g s a -> Parser g s [a]+   Some          :: Parser g s a -> Parser g s [a]+   ConcatMany    :: Monoid a => Parser g s a -> Parser g s a+   ResultsWrap   :: ResultList g s a -> Parser g s a+   Index         :: Int -> Parser g s a++-- | Parser of general context-free grammars, including left recursion. O(n³) performance.+--+-- @+-- 'parseComplete' :: ("Rank2".'Rank2.Apply' g, "Rank2".'Rank2.Traversable' g, 'FactorialMonoid' s) =>+--                  g (LeftRecursive.'Parser' g s) -> s -> g ('Compose' 'ParseResults' [])+-- @+instance MultiParsing Parser where+   type GrammarConstraint Parser g = (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)+   type ResultFunctor Parser = Compose ParseResults []+   parsePrefix :: (Rank2.Apply g, Rank2.Traversable g, FactorialMonoid s) =>+                  g (Parser g s) -> s -> g (Compose (Compose ParseResults []) ((,) s))+   parsePrefix g input = Rank2.fmap (Compose . Compose . fromResultList input)+                                    (snd $ head $ parseRecursive g input)+   parseComplete :: (FactorialMonoid s, Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g) =>+                    g (Parser g s) -> s -> g (Compose ParseResults [])+   parseComplete g input = Rank2.fmap ((snd <$>) . Compose . fromResultList input)+                                      (snd $ head $ Memoizing.reparseTails close $ parseRecursive g input)+      where close = Rank2.fmap (<* endOfInput) selfReferring++instance GrammarParsing Parser where+   type GrammarFunctor Parser = Parser+   nonTerminal = NonTerminal+   recursive = Recursive++instance (Rank2.Distributive g, Rank2.Traversable g) => Show (Parser g s a) where+   show (NonTerminal accessor) = "nt" ++ show i+      where Index i = accessor orderedSelfReferring+   show (Primitive name _ _ _) = name+   show Recursive{} = "recursive"+   show (Map _ ast) = "(f <$> " ++ shows ast ")"+   show (Ap f p) = "(" ++ show f ++ " <*> " ++ shows p ")"+   show (Pure _) = "pure x"+   show Empty = "empty"+   show (Bind ast _) = "(" ++ show ast ++ " >>= " ++ ")"+   show (Choice l r) = "(" ++ show l ++ " <|> " ++ shows r ")"+   show (Try ast) = "(try " ++ shows ast ")"+   show (Describe ast msg) = "(" ++ shows ast (" <?> " ++ shows msg ")")+   show (NotFollowedBy ast) = "(notFollowedBy " ++ shows ast ")"+   show (Lookahead ast) = "(lookAhead " ++ shows ast ")"+   show (Many ast) = "(many " ++ shows ast ")"+   show (Some ast) = "(some " ++ shows ast ")"+   show (ConcatMany ast) = "(concatMany " ++ shows ast ")"+   show Index{} = error "Index should be temporary only"+   show ResultsWrap{} = error "ResultsWrap should be temporary only"++instance (Rank2.Distributive g, Rank2.Traversable g) => Show1 (Parser g s) where+   liftShowsPrec _showsPrec _showList _prec (NonTerminal accessor) _rest = "nt" ++ show i+      where Index i = accessor orderedSelfReferring+   liftShowsPrec _showsPrec _showL _prec (Primitive name _ _ _) rest = name ++ rest+   liftShowsPrec _showsPrec _showL _prec Recursive{} rest = "recursive" ++ rest+   liftShowsPrec _showsPrec _showL _prec (Map _ ast) rest = "(f <$> " ++ shows ast (")" ++ rest)+   liftShowsPrec _showsPrec _showL _prec (Ap f p) rest = "(" ++ show f ++ " <*> " ++ shows p (")" ++ rest)+   liftShowsPrec  showsPrec _showL  prec (Pure x) rest = "pure " ++ showsPrec prec x rest+   liftShowsPrec _showsPrec _showL _prec Empty _rest = "empty"+   liftShowsPrec _showsPrec _showL _prec (Bind ast _) rest = "(" ++ shows ast (" >>= " ++ ")" ++ rest)+   liftShowsPrec _showsPrec _showL _prec (Choice l r) rest = "(" ++ show l ++ " <|> " ++ shows r (")" ++ rest)+   liftShowsPrec _showsPrec _showL _prec (Try ast) rest = "(try " ++ shows ast (")" ++ rest)+   liftShowsPrec _showsPrec _showL _prec (Describe ast msg) rest = "(" ++ shows ast (" <?> " ++ shows msg (")" ++ rest))+   liftShowsPrec _showsPrec _showL _prec (NotFollowedBy ast) rest = "(notFollowedBy " ++ shows ast (")" ++ rest)+   liftShowsPrec _showsPrec _showL _prec (Lookahead ast) rest = "(lookAhead " ++ shows ast (")" ++ rest)+   liftShowsPrec _showsPrec _showL _prec (Many ast) rest = "(many " ++ shows ast (")" ++ rest)+   liftShowsPrec _showsPrec _showL _prec (Some ast) rest = "(some " ++ shows ast (")" ++ rest)+   liftShowsPrec _showsPrec _showL _prec (ConcatMany ast) rest = "(concatMany " ++ shows ast (")" ++ rest)+   liftShowsPrec _showsPrec _showL _prec Index{} _rest = error "Index should be temporary only"+   liftShowsPrec _showsPrec _showL _prec ResultsWrap{} _rest = error "ResultsWrap should be temporary only"++instance Functor (Parser g s) where+   fmap _ Empty = Empty+   fmap f ast = Map f ast++instance Applicative (Parser g s) where+   pure = Pure+   Empty <*> _ = Empty+   _ <*> Empty = Empty+   p <*> q = Ap p q++instance Alternative (Parser g s) where+   empty = Empty+   Empty <|> ast = ast+   ast <|> Empty = ast+   p <|> q = Choice p q+   many Empty = pure []+   many ast = Many ast+   some Empty = Empty+   some ast = Some ast++instance Monad (Parser g s) where+   return = pure+   (>>) = (*>)+   Empty >>= _ = Empty+   ast >>= cont = Bind ast cont++instance MonadPlus (Parser g s) where+   mzero = empty+   mplus = (<|>)++instance Monoid x => Monoid (Parser g s x) where+   mempty = pure mempty+   mappend = liftA2 mappend++instance MonoidNull s => Parsing (Parser g s) where+   eof = Primitive "eof" (Just eof) Nothing eof+   try Empty = Empty+   try ast = Try ast+   Empty <?> _ = Empty+   ast <?> msg = Describe ast msg+   notFollowedBy = NotFollowedBy+   unexpected msg = Primitive "unexpected" Nothing (Just $ unexpected msg) (unexpected msg)+   skipMany = ConcatMany . (() <$)++instance MonoidNull s => LookAheadParsing (Parser g s) where+   lookAhead = Lookahead++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 (Show s, TextualMonoid s) => TokenParsing (Parser g s) where+   someSpace = () <$ takeCharsWhile1 isSpace++instance MonoidParsing (Parser g) where+   endOfInput = Primitive "endOfInput" (Just endOfInput) Nothing endOfInput+   getInput = Primitive "getInput" (Just $ eof *> getInput) (Just $ notFollowedBy eof *> getInput) getInput+   anyToken = Primitive "anyToken" Nothing (Just anyToken) anyToken+   token x = Primitive "token" Nothing (Just $ token x) (token x)+   satisfy predicate = Primitive "satisfy" Nothing (Just $ satisfy predicate) (satisfy predicate)+   satisfyChar predicate = Primitive "satisfyChar" Nothing (Just $ satisfyChar predicate) (satisfyChar predicate)+   scan s0 f = Primitive "scan" (Just $ mempty <$ notFollowedBy (() <$ p1)) (Just $ lookAhead p1 *> p) p+      where p = scan s0 f+            p1 = satisfy (isJust . f s0)+   scanChars s0 f = Primitive "scanChars" (Just $ mempty <$ notFollowedBy p1) (Just $ lookAhead p1 *> p) p+      where p = scanChars s0 f+            p1 = satisfyChar (isJust . f s0)+   string s+      | null s = Primitive ("(string " ++ shows s ")") (Just $ string s) Nothing (string s)+      | otherwise = Primitive ("(string " ++ shows s ")") Nothing (Just $ string s) (string s)+   takeWhile predicate = Primitive "takeWhile" (Just $ mempty <$ notFollowedBy (() <$ satisfy predicate))+                                               (Just $ takeWhile1 predicate) (takeWhile predicate)+   takeWhile1 predicate = Primitive "takeWhile1" Nothing (Just $ takeWhile1 predicate) (takeWhile1 predicate)+   takeCharsWhile predicate = Primitive "takeCharsWhile" (Just $ mempty <$ notFollowedBy (satisfyChar predicate))+                                                         (Just $ takeCharsWhile1 predicate) (takeCharsWhile predicate)+   takeCharsWhile1 predicate = Primitive "takeCharsWhile1" Nothing (Just $ takeCharsWhile1 predicate)+                                                           (takeCharsWhile1 predicate)+   whiteSpace = Primitive "whiteSpace" (Just $ notFollowedBy whiteSpace) (Just whiteSpace) whiteSpace+   concatMany = ConcatMany++toParser :: (Rank2.Functor g, FactorialMonoid s) => Parser g s a -> Memoizing.Parser g s a+toParser (NonTerminal accessor) = nonTerminal (unwrap . accessor . Rank2.fmap ResultsWrap)+   where unwrap (ResultsWrap x) = x+         unwrap _ = error "should have been wrapped"+toParser (Primitive _ _ _ p) = p+toParser (Recursive ast) = toParser ast+toParser (Map f ast) = f <$> toParser ast+toParser (Ap f a) = toParser f <*> toParser a+toParser (Pure x) = pure x+toParser Empty = empty+toParser (Bind ast cont) = toParser ast >>= toParser . cont+toParser (Choice l r) = toParser l <|> toParser r+toParser (Try ast) = try (toParser ast)+toParser (Describe ast msg) = toParser ast <?> msg+toParser (NotFollowedBy ast) = notFollowedBy (toParser ast)+toParser (Lookahead ast) = lookAhead (toParser ast)+toParser (Many ast) = many (toParser ast)+toParser (Some ast) = some (toParser ast)+toParser (ConcatMany ast) = concatMany (toParser ast)+toParser Index{} = error "Index should be temporary only"+toParser ResultsWrap{} = error "ResultsWrap should be temporary only"++splitDirect :: (Rank2.Functor g, FactorialMonoid s) => Parser g s a -> (Parser g s a, Parser g s a)+splitDirect ast@NonTerminal{} = (empty, ast)+splitDirect ast@Primitive{} = (ast, empty)+splitDirect (Recursive ast) = both Recursive (splitDirect ast)+splitDirect (Map f ast) = both (f <$>) (splitDirect ast)+splitDirect (Ap f a)+   | Empty <- an = (fd <*> a, fn <*> a)+   | otherwise = (fd0 <*> ad <|> fd1 <*> a, fd0 <*> an <|> fn <*> a)+   where (fd, fn) = splitDirect f+         (ad, an) = splitDirect a+         (fd0, fd1) = splitNullable fd+splitDirect ast@Pure{} = (ast, empty)+splitDirect Empty = (Empty, Empty)+splitDirect (Bind ast cont) = (d0cd <|> (d1 >>= cont), d0cn <|> (n >>= cont))+   where (d, n) = splitDirect ast+         (d0, d1) = splitNullable d+         (d0cd, d0cn) = splitDirect (d0 >>= cont)+splitDirect (Choice l r) = (ld <|> rd, ln <|> rn)+   where (ld, ln) = splitDirect l+         (rd, rn) = splitDirect r+splitDirect (Try ast) = both try (splitDirect ast)+splitDirect (Describe ast msg) = both (<?> msg) (splitDirect ast)+splitDirect (NotFollowedBy ast) = both notFollowedBy (splitDirect ast)+splitDirect (Lookahead ast) = both lookAhead (splitDirect ast)+splitDirect ast@(Many ast1) = (pure [] <|> (:) <$> d <*> ast, (:) <$> n <*> ast)+   where (d, n) = splitDirect ast1+splitDirect (Some ast) = ((:) <$> d <*> ast', (:) <$> n <*> ast')+   where (d, n) = splitDirect ast+         ast' = Many ast+splitDirect ast@(ConcatMany ast1) = (pure mempty <|> (<>) <$> d <*> ast, (<>) <$> n <*> ast)+   where (d, n) = splitDirect ast1+splitDirect Index{} = error "Index should be temporary only"+splitDirect ResultsWrap{} = error "ResultsWrap should be temporary only"++splitNullable :: MonoidNull s => Parser g s a -> (Parser g s a, Parser g s a)+splitNullable ast@NonTerminal{} = (ast, empty)+splitNullable (Primitive name p0 p1 _) = (maybe empty (\p-> Primitive name (Just p) Nothing p) p0,+                                          maybe empty (\p-> Primitive name Nothing (Just p) p) p1)+splitNullable (Recursive ast) = both Recursive (splitNullable ast)+splitNullable (Map f ast) = both (f <$>) (splitNullable ast)+splitNullable (Ap f a)+   | Empty <- f0 = (empty, f <*> a)+   | Empty <- a0 = (empty, f <*> a)+   | otherwise = (f0 <*> a0, f1 <*> a <|> f <*> a1)+   where (f0, f1) = splitNullable f+         (a0, a1) = splitNullable a+splitNullable ast@Pure{} = (ast, empty)+splitNullable Empty = (empty, empty)+splitNullable (Bind ast cont) = (fst c0, snd c0 <|> (ast1 >>= cont))+   where (ast0, ast1) = splitNullable ast+         c0 = splitNullable (ast0 >>= cont)+splitNullable (Choice l r) = (l0 <|> r0, l1 <|> r1)+   where (l0, l1) = splitNullable l+         (r0, r1) = splitNullable r+splitNullable (Try ast) = both try (splitNullable ast)+splitNullable (Describe ast msg) = both (<?> msg) (splitNullable ast)+splitNullable ast@NotFollowedBy{} = (ast, empty)+splitNullable ast@Lookahead{} = (ast, empty)+splitNullable (Many ast) = (pure [] <|> (:[]) <$> ast0, (:) <$> ast1 <*> many ast)+   where (ast0, ast1) = splitNullable ast+splitNullable (Some ast) = ((:[]) <$> ast0, (:) <$> ast1 <*> many ast)+   where (ast0, ast1) = splitNullable ast+splitNullable (ConcatMany ast) = (pure mempty <|> ast0, (<>) <$> ast1 <*> concatMany ast)+   where (ast0, ast1) = splitNullable ast+splitNullable (ResultsWrap _) = error "ResultsWrap should be temporary only"+splitNullable (Index _) = error "Index should be temporary only"++both :: (a -> b) -> (a, a) -> (b, b)+both f (x, y) = (f x, f y)++leftDescendants :: forall g s. (Rank2.Apply g, Rank2.Traversable g) => g (Parser g s) -> g (Const (Bool, g (Const Bool)))+leftDescendants g = evalState (Rank2.traverse (const replaceFromList) g) $ map (setToBools <$>) $+                    IntMap.elems $ calcLeftSets $ IntMap.fromList $ zip [0..] $ Rank2.foldMap successorSet g+   where replaceFromList :: State [x] (Const x y)+         replaceFromList = do next:rest <- get+                              put rest+                              return (Const next)+         setToBools :: IntSet -> g (Const Bool)+         setToBools = Rank2.traverse isElem enumeration+         isElem :: Parser g s a -> IntSet -> Const Bool a+         isElem (Index i) set = Const (IntSet.member i set)+         successorSet :: Parser g s a -> [IntSet]+         successorSet a = [leftRecursiveOn a]+         enumeration = ordered g+         universe = Rank2.foldMap (\(Index i)-> IntSet.singleton i) enumeration+         g0 = fixNullable g+         leftRecursiveOn :: Parser g s a -> IntSet+         leftRecursiveOn (NonTerminal accessor) = IntSet.singleton i+            where Index i = accessor enumeration+         leftRecursiveOn Primitive{} = mempty+         leftRecursiveOn (Recursive ast) = leftRecursiveOn ast+         leftRecursiveOn (Map _ ast) = leftRecursiveOn ast+         leftRecursiveOn (Ap f p) = leftRecursiveOn f <> if nullable g0 f then leftRecursiveOn p else mempty+         leftRecursiveOn Pure{} = mempty+         leftRecursiveOn Empty = mempty+         leftRecursiveOn (Bind ast _cont) = if nullable g0 ast then universe else leftRecursiveOn ast+         leftRecursiveOn (Choice l r) = leftRecursiveOn l <> leftRecursiveOn r+         leftRecursiveOn (Try ast) = leftRecursiveOn ast+         leftRecursiveOn (Describe ast _) = leftRecursiveOn ast+         leftRecursiveOn (NotFollowedBy ast) = leftRecursiveOn ast+         leftRecursiveOn (Lookahead ast) = leftRecursiveOn ast+         leftRecursiveOn (Many ast) = leftRecursiveOn ast+         leftRecursiveOn (Some ast) = leftRecursiveOn ast+         leftRecursiveOn (ConcatMany ast) = leftRecursiveOn ast++nullable :: Rank2.Functor g => g (Const Bool) -> Parser g s a -> Bool+nullable gn (NonTerminal accessor) = n == 1+   where Index n = accessor (Rank2.fmap (\(Const z)-> Index $ if z then 1 else 0) gn)+nullable _  (Primitive _name z _ _) = isJust z+nullable gn (Recursive ast) = nullable gn ast+nullable gn (Map _ ast) = nullable gn ast+nullable gn (Ap f p) = nullable gn f && nullable gn p+nullable _  Pure{} = True+nullable _  Empty = False+nullable gn (Bind ast _cont) = nullable gn ast+nullable gn (Choice l r) = nullable gn l || nullable gn r+nullable gn (Try ast) = nullable gn ast+nullable gn (Describe ast _) = nullable gn ast+nullable _  NotFollowedBy{} = True+nullable _  Lookahead{} = True+nullable _  Many{} = True+nullable gn (Some ast) = nullable gn ast+nullable _  ConcatMany{} = True++fixNullable :: (Rank2.Apply g, Rank2.Foldable g) => g (Parser g s) -> g (Const Bool)+fixNullable g = go (Rank2.fmap (const $ Const True) g)+   where go gn+            | getAll (Rank2.foldMap (All . getConst) $ Rank2.liftA2 agree gn gn') = gn+            | otherwise = go gn'+            where gn' = Rank2.fmap (Const . nullable gn) g+         agree x y = Const (x == y)++orderedSelfReferring :: (Rank2.Distributive g, Rank2.Traversable g) => g (Parser g s)+orderedSelfReferring = ordered (Rank2.distributeWith NonTerminal id)++ordered :: Rank2.Traversable g => g (Parser g s) -> g (Parser g s)+ordered g = evalState (Rank2.traverse (const increment) g) 0+   where increment :: State Int (Parser g s a)+         increment = do {n <- get; put (n+1); return (Index n)}++data AdvanceFront = AdvanceFront{visited       :: IntSet,+                                 cyclic        :: Bool,+                                 front         :: IntSet}+                  deriving Show++calcLeftSets :: IntMap IntSet -> IntMap (Bool, IntSet)+calcLeftSets successors = (cyclic &&& visited) <$> expandPaths initialDepths+   where expandPaths :: IntMap AdvanceFront -> IntMap AdvanceFront+         expandPaths paths+            | all (IntSet.null . front) paths' = paths'+            | otherwise = expandPaths paths'+            where paths' = expandReachables <$> paths+                  expandReachables :: AdvanceFront -> AdvanceFront+                  expandReachables x = +                     AdvanceFront{visited= visited x <> front x,+                                  cyclic= cyclic x || not (IntSet.null $ IntSet.intersection (front x) (visited x)),+                                  front= IntSet.foldr' addSuccessors mempty (IntSet.difference (front x) (visited x))}+         addSuccessors :: Int -> IntSet -> IntSet+         addSuccessors node set = set <> successors IntMap.! node+         initialDepths = IntMap.mapWithKey setToFront successors+         setToFront root set = AdvanceFront{visited= mempty,+                                            cyclic= IntSet.member root set,+                                            front= set}++newtype Couple f a = Couple{unCouple :: (f a, f a)} deriving Show++parseRecursive :: forall g s. (Rank2.Apply g, Rank2.Traversable g, FactorialMonoid s) =>+                  g (Parser g s) -> s -> [(s, g (ResultList g s))]+parseRecursive ast = parseSeparated descendants (Rank2.fmap toParser indirect) (Rank2.fmap toParser direct)+   where directRecursive = Rank2.fmap (Couple . splitDirect) ast+         cyclicDescendants = leftDescendants ast+         cyclic = Rank2.fmap (mapConst fst) cyclicDescendants+         descendants = Rank2.liftA3 cond cyclic (Rank2.fmap (mapConst snd) cyclicDescendants) noDescendants+         direct = Rank2.liftA3 cond cyclic (Rank2.fmap (fst . unCouple) directRecursive) ast+         indirect = Rank2.liftA3 cond cyclic (Rank2.fmap (snd . unCouple) directRecursive) emptyGrammar+         emptyGrammar :: g (Parser g s)+         emptyGrammar = Rank2.fmap (const empty) ast+         noDescendants = Rank2.fmap (const $ Const $ Rank2.fmap (const $ Const False) ast) ast+         cond (Const False) _t f = f+         cond (Const True) t _f = t+         mapConst f (Const c) = Const (f c)++-- | Parse the given input using a context-free grammar separated into two parts: the first specifying all the+-- left-recursive productions, the second all others. The first function argument specifies the left-recursive+-- dependencies among the grammar productions.+parseSeparated :: forall g s. (Rank2.Apply g, Rank2.Foldable g, FactorialMonoid s) =>+                  g (Const (g (Const Bool))) -> g (Memoizing.Parser g s) -> g (Memoizing.Parser g s) -> s+               -> [(s, g (ResultList g s))]+parseSeparated dependencies indirect direct input = foldr parseTail [] (Factorial.tails input)+   where parseTail s parsedTail = parsed+            where parsed = (s,d'):parsedTail+                  d      = Rank2.fmap (($ (s,d):parsedTail) . Memoizing.applyParser) direct+                  d'     = fixRecursive s parsedTail d++         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)++         fixRecursive s parsedTail initial =+            foldr1 whileAnyContinues (iterate (recurseOnce s parsedTail) initial)++         whileAnyContinues g1 g2 = Rank2.liftA3 choiceWhile dependencies g1 g2+            where choiceWhile :: Const (g (Const Bool)) x -> ResultList g i x -> ResultList g i x -> ResultList g i x+                  combine :: Const Bool x -> ResultList g i x -> Const Bool x+                  choiceWhile (Const deps) r1 r2+                     | getAny (Rank2.foldMap (Any . getConst) (Rank2.liftA2 combine deps g1)) = r1 <> r2+                     | otherwise = r1+                  combine (Const False) _ = Const False+                  combine (Const True) (ResultList [] _) = Const False+                  combine (Const True) _ = Const True++         recurseOnce s parsedTail initial = Rank2.fmap (($ parsed) . Memoizing.applyParser) indirect+            where parsed = (s, initial):parsedTail

@@ -0,0 +1,232 @@+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,+             RankNTypes, ScopedTypeVariables, TypeFamilies #-}+module Text.Grampa.ContextFree.Memoizing (FailureInfo(..), ResultList(..), Parser(..), fromResultList, reparseTails)+where++import Control.Applicative+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.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.String (fromString)+import Data.Word (Word64)++import qualified Text.Parser.Char+import Text.Parser.Char (CharParsing)+import Text.Parser.Combinators (Parsing(..))+import Text.Parser.LookAhead (LookAheadParsing(..))+import Text.Parser.Token (TokenParsing(someSpace))++import qualified Rank2++import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))++import Prelude hiding (iterate, length, null, showList, span, takeWhile)++-- | Parser for a context-free grammar with packrat-like sharing of parse results. It does not support left-recursive+-- grammars.+newtype Parser g s r = Parser{applyParser :: [(s, g (ResultList g s))] -> ResultList g s r}+            +data ResultList g s r = ResultList ![ResultInfo g s r] {-# UNPACK #-} !FailureInfo+data ResultInfo g s r = ResultInfo ![(s, g (ResultList g s))] !r+data FailureInfo = FailureInfo !Int Word64 [String] deriving (Eq, Show)++instance (Show s, Show r) => Show (ResultList g s r) where+   show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")")++instance Show1 (ResultList g s) where+   liftShowsPrec _sp showList _prec (ResultList l f) rest = "ResultList " ++ showList (simplify <$> l) (shows f rest)+      where simplify (ResultInfo _ r) = r++instance (Show s, Show r) => Show (ResultInfo g s r) where+   show (ResultInfo t r) = "(ResultInfo @" ++ show (fst $ head t) ++ " " ++ shows r ")"++instance Functor (ResultInfo g s) where+   fmap f (ResultInfo t r) = ResultInfo t (f r)++instance Functor (ResultList g s) where+   fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure++instance Monoid (ResultList g s r) where+   mempty = ResultList [] mempty+   ResultList rl1 f1 `mappend` ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2)++instance Monoid FailureInfo where+   mempty = FailureInfo 0 maxBound []+   f1@(FailureInfo s1 pos1 exp1) `mappend` f2@(FailureInfo s2 pos2 exp2)+      | s1 < s2 = f2+      | s1 > s2 = f1+      | otherwise = FailureInfo s1 pos' exp'+      where (pos', exp') | pos1 < pos2 = (pos1, exp1)+                         | pos1 > pos2 = (pos2, exp2)+                         | otherwise = (pos1, exp1 <> exp2)++instance Functor (Parser g i) where+   fmap f (Parser p) = Parser (fmap f . p)++instance Applicative (Parser g i) where+   pure a = Parser (\rest-> ResultList [ResultInfo rest a] mempty)+   Parser p <*> Parser q = Parser r where+      r rest = case p rest+               of ResultList results failure -> ResultList [] failure <> foldMap continue results+      continue (ResultInfo rest' f) = f <$> q rest'+++instance Alternative (Parser g i) where+   empty = Parser (\rest-> ResultList [] $ FailureInfo 0 (genericLength rest) ["empty"])+   Parser p <|> Parser q = Parser r where+      r rest = p rest <> q rest++instance Monad (Parser g i) where+   return = pure+   Parser p >>= f = Parser q where+      q rest = case p rest+               of ResultList results failure -> ResultList [] failure <> foldMap continue results+      continue (ResultInfo rest' a) = applyParser (f a) rest'++instance MonadPlus (Parser g s) where+   mzero = empty+   mplus = (<|>)++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 [] (FailureInfo 1 0 ["NonTerminal at endOfInput"])++-- | Memoizing parser guarantees O(n²) performance, 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 [ResultInfo [last rest] s] mempty+            p [] = ResultList [ResultInfo [] mempty] mempty+   anyToken = Parser p+      where p rest@((s, _):t) = case splitPrimePrefix s+                                of Just (first, _) -> ResultList [ResultInfo t first] mempty+                                   _ -> ResultList [] (FailureInfo 1 (genericLength rest) ["anyToken"])+            p [] = ResultList [] (FailureInfo 1 0 ["anyToken"])+   satisfy predicate = Parser p+      where p rest@((s, _):t) =+               case splitPrimePrefix s+               of Just (first, _) | predicate first -> ResultList [ResultInfo t first] mempty+                  _ -> ResultList [] (FailureInfo 1 (genericLength rest) ["satisfy"])+            p [] = ResultList [] (FailureInfo 1 0 ["satisfy"])+   satisfyChar predicate = Parser p+      where p rest@((s, _):t) =+               case Textual.splitCharacterPrefix s+               of Just (first, _) | predicate first -> ResultList [ResultInfo t first] mempty+                  _ -> ResultList [] (FailureInfo 1 (genericLength rest) ["satisfyChar"])+            p [] = ResultList [] (FailureInfo 1 0 ["satisfyChar"])+   scan s0 f = Parser (p s0)+      where p s rest@((i, _) : _) = ResultList [ResultInfo (drop (Factorial.length prefix) rest) prefix] mempty+               where (prefix, _, _) = Factorial.spanMaybe' s f i+            p _ [] = ResultList [ResultInfo [] mempty] mempty+   scanChars s0 f = Parser (p s0)+      where p s rest@((i, _) : _) = ResultList [ResultInfo (drop (Factorial.length prefix) rest) prefix] mempty+               where (prefix, _, _) = Textual.spanMaybe_' s f i+            p _ [] = ResultList [ResultInfo [] mempty] mempty+   takeWhile predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Factorial.takeWhile predicate s =+                    ResultList [ResultInfo (drop (Factorial.length x) rest) x] mempty+            p [] = ResultList [ResultInfo [] mempty] mempty+   takeWhile1 predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Factorial.takeWhile predicate s, not (null x) =+                    ResultList [ResultInfo (drop (Factorial.length x) rest) x] mempty+            p rest = ResultList [] (FailureInfo 1 (genericLength rest) ["takeWhile1"])+   takeCharsWhile predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Textual.takeWhile_ False predicate s =+                    ResultList [ResultInfo (drop (Factorial.length x) rest) x] mempty+            p [] = ResultList [ResultInfo [] mempty] mempty+   takeCharsWhile1 predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Textual.takeWhile_ False predicate s, not (null x) =+                    ResultList [ResultInfo (drop (Factorial.length x) rest) x] mempty+            p rest = ResultList [] (FailureInfo 1 (genericLength rest) ["takeCharsWhile1"])+   string s = Parser p where+      p rest@((s', _) : _)+         | s `isPrefixOf` s' = ResultList [ResultInfo (Factorial.drop (Factorial.length s) rest) s] mempty+      p rest = ResultList [] (FailureInfo 1 (genericLength rest) ["string " ++ show s])+   whiteSpace = () <$ takeCharsWhile isSpace+   concatMany p = go+      where go = mempty <|> (<>) <$> p <*> go++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 [ResultInfo t ()] mempty+            rewind t ResultList{} = ResultList [] (FailureInfo 1 (genericLength t) ["notFollowedBy"])+   skipMany p = go+      where go = pure () <|> p *> go+   unexpected msg = Parser (\t-> ResultList [] $ FailureInfo 0 (genericLength t) [msg])+   eof = Parser f+      where f rest@((s, _):_)+               | null s = ResultList [ResultInfo rest ()] mempty+               | otherwise = ResultList [] (FailureInfo 1 (genericLength rest) ["endOfInput"])+            f [] = ResultList [ResultInfo [] ()] mempty++instance MonoidNull s => LookAheadParsing (Parser g s) where+   lookAhead (Parser p) = Parser (\input-> rewind input (p input))+      where rewind t (ResultList rl failure) = ResultList (rewindInput t <$> rl) failure+            rewindInput t (ResultInfo _ r) = ResultInfo t r++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 (Show s, TextualMonoid s) => TokenParsing (Parser g s) where+   someSpace = () <$ takeCharsWhile1 isSpace++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 (f <$> rl)+   where f (ResultInfo ((s, _):_) r) = (s, r)+         f (ResultInfo [] r) = (mempty, r)

@@ -0,0 +1,198 @@+{-# LANGUAGE FlexibleContexts, InstanceSigs, GeneralizedNewtypeDeriving,+             RankNTypes, ScopedTypeVariables, TypeFamilies #-}+module Text.Grampa.ContextFree.Parallel (FailureInfo(..), ResultList(..), Parser, fromResultList)+where++import Control.Applicative+import Control.Monad (Monad(..), MonadPlus(..))+import Data.Char (isSpace)+import Data.Functor.Classes (Show1(..))+import Data.Functor.Compose (Compose(..))+import Data.List (nub)+import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Monoid.Null (MonoidNull(null))+import Data.Monoid.Factorial (FactorialMonoid)+import Data.Monoid.Textual (TextualMonoid)+import qualified Data.Monoid.Cancellative as Cancellative+import qualified Data.Monoid.Null as Null+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Textual as Textual+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(someSpace))++import qualified Rank2++import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..), completeParser)++import Prelude hiding (iterate, null, showList, span, takeWhile)++-- | Parser type for context-free grammars using a parallel parsing algorithm with no result sharing nor left recursion+-- support.+newtype Parser (g :: (* -> *) -> *) s r = Parser{applyParser :: s -> ResultList s r}++data ResultList s r = ResultList ![ResultInfo s r] {-# UNPACK #-} !FailureInfo+data ResultInfo s r = ResultInfo !s !r+data FailureInfo = FailureInfo !Int Int [String] deriving (Eq, Show)++instance (Show s, Show r) => Show (ResultList s r) where+   show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")")++instance Show1 (ResultList s) where+   liftShowsPrec _sp showList _prec (ResultList l f) rest = "ResultList " ++ showList (simplify <$> l) (shows f rest)+      where simplify (ResultInfo _ r) = r++instance (Show s, Show r) => Show (ResultInfo s r) where+   show (ResultInfo s r) = "(ResultInfo @" ++ show s ++ " " ++ shows r ")"++instance Functor (ResultInfo s) where+   fmap f (ResultInfo s r) = ResultInfo s (f r)++instance Functor (ResultList s) where+   fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure++instance Monoid (ResultList s r) where+   mempty = ResultList [] mempty+   ResultList rl1 f1 `mappend` ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2)++instance Monoid FailureInfo where+   mempty = FailureInfo 0 maxBound []+   f1@(FailureInfo s1 pos1 exp1) `mappend` f2@(FailureInfo s2 pos2 exp2)+      | s1 < s2 = f2+      | s1 > s2 = f1+      | otherwise = FailureInfo s1 pos' exp'+      where (pos', exp') | pos1 < pos2 = (pos1, exp1)+                         | pos1 > pos2 = (pos2, exp2)+                         | otherwise = (pos1, exp1 <> exp2)++instance Functor (Parser g s) where+   fmap f (Parser p) = Parser (fmap f . p)++instance Applicative (Parser g s) where+   pure a = Parser (\rest-> ResultList [ResultInfo rest a] mempty)+   Parser p <*> Parser q = Parser r where+      r rest = case p rest+               of ResultList results failure -> ResultList [] failure <> foldMap continue results+      continue (ResultInfo rest' f) = f <$> q rest'+++instance FactorialMonoid s => Alternative (Parser g s) where+   empty = Parser (\s-> ResultList [] $ FailureInfo 0 (Factorial.length s) ["empty"])+   Parser p <|> Parser q = Parser r where+      r rest = p rest <> q rest++instance Monad (Parser g s) where+   return = pure+   Parser p >>= f = Parser q where+      q rest = case p rest+               of ResultList results failure -> ResultList [] failure <> foldMap continue results+      continue (ResultInfo rest' a) = applyParser (f a) rest'++instance FactorialMonoid s => MonadPlus (Parser g s) where+   mzero = empty+   mplus = (<|>)++instance Monoid x => Monoid (Parser g s x) where+   mempty = pure mempty+   mappend = liftA2 mappend++-- | Parallel parser produces a list of all possible parses.+--+-- @+-- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>+--                  g (Parallel.'Parser' g s) -> s -> g ('Compose' 'ParseResults' [])+-- @+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 . (`applyParser` input)) g+   -- | Returns the list of all possible parses of complete input.+   parseComplete :: forall g s. (Rank2.Functor g, FactorialMonoid s) =>+                    g (Parser g s) -> s -> g (Compose ParseResults [])+   parseComplete g input = Rank2.fmap ((snd <$>) . getCompose) (parsePrefix (Rank2.fmap (<* endOfInput) g) input)++instance MonoidParsing (Parser g) where+   endOfInput = Parser f+      where f s | null s = ResultList [ResultInfo s ()] mempty+                | otherwise = ResultList [] (FailureInfo 1 (Factorial.length s) ["endOfInput"])+   getInput = Parser p+      where p s = ResultList [ResultInfo mempty s] mempty+   anyToken = Parser p+      where p s = case Factorial.splitPrimePrefix s+                  of Just (first, rest) -> ResultList [ResultInfo rest first] mempty+                     _ -> ResultList [] (FailureInfo 1 (Factorial.length s) ["anyToken"])+   satisfy predicate = Parser p+      where p s = case Factorial.splitPrimePrefix s+                  of Just (first, rest) | predicate first -> ResultList [ResultInfo rest first] mempty+                     _ -> ResultList [] (FailureInfo 1 (Factorial.length s) ["satisfy"])+   satisfyChar predicate = Parser p+      where p s =+               case Textual.splitCharacterPrefix s+               of Just (first, rest) | predicate first -> ResultList [ResultInfo rest first] mempty+                  _ -> ResultList [] (FailureInfo 1 (Factorial.length s) ["satisfyChar"])+   scan s0 f = Parser (p s0)+      where p s i = ResultList [ResultInfo suffix prefix] mempty+               where (prefix, suffix, _) = Factorial.spanMaybe' s f i+   scanChars s0 f = Parser (p s0)+      where p s i = ResultList [ResultInfo suffix prefix] mempty+               where (prefix, suffix, _) = Textual.spanMaybe_' s f i+   takeWhile predicate = Parser p+      where p s | (prefix, suffix) <- Factorial.span predicate s = ResultList [ResultInfo suffix prefix] mempty+   takeWhile1 predicate = Parser p+      where p s | (prefix, suffix) <- Factorial.span predicate s = +               if Null.null prefix+               then ResultList [] (FailureInfo 1 (Factorial.length s) ["takeWhile1"])+               else ResultList [ResultInfo suffix prefix] mempty+   takeCharsWhile predicate = Parser p+      where p s | (prefix, suffix) <- Textual.span_ False predicate s = ResultList [ResultInfo suffix prefix] mempty+   takeCharsWhile1 predicate = Parser p+      where p s | (prefix, suffix) <- Textual.span_ False predicate s =+               if null prefix+               then ResultList [] (FailureInfo 1 (Factorial.length s) ["takeCharsWhile1"])+               else ResultList [ResultInfo suffix prefix] mempty+   string s = Parser p where+      p s' | Just suffix <- Cancellative.stripPrefix s s' = ResultList [ResultInfo suffix s] mempty+           | otherwise = ResultList [] (FailureInfo 1 (Factorial.length s') ["string " ++ show s])+   whiteSpace = () <$ takeCharsWhile isSpace+   concatMany (Parser p) = Parser q+      where q s = ResultList [] failure <> foldMap continue rs+               where ResultList rs failure = p s+            continue (ResultInfo suffix prefix) = (prefix <>) <$> q suffix++instance FactorialMonoid 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 [ResultInfo t ()] mempty+            rewind t ResultList{} = ResultList [] (FailureInfo 1 (Factorial.length t) ["notFollowedBy"])+   skipMany p = go+      where go = pure () <|> p *> go+   unexpected msg = Parser (\t-> ResultList [] $ FailureInfo 0 (Factorial.length t) [msg])+   eof = endOfInput++instance FactorialMonoid s => LookAheadParsing (Parser g s) where+   lookAhead (Parser p) = Parser (\input-> rewind input (p input))+      where rewind t (ResultList rl failure) = ResultList (rewindInput t <$> rl) failure+            rewindInput t (ResultInfo _ r) = ResultInfo t r++instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where+   satisfy = satisfyChar+   string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)+   char = satisfyChar . (==)+   notChar = satisfyChar . (/=)+   anyChar = satisfyChar (const True)+   text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t)++instance (Show s, TextualMonoid s) => TokenParsing (Parser g s) where+   someSpace = () <$ takeCharsWhile1 isSpace++fromResultList :: FactorialMonoid s => s -> ResultList s r -> ParseResults [(s, r)]+fromResultList s (ResultList [] (FailureInfo _ pos msgs)) = Left (ParseFailure (Factorial.length s - pos) (nub msgs))+fromResultList _ (ResultList rl _failure) = Right (f <$> rl)+   where f (ResultInfo s r) = (s, r)

@@ -0,0 +1,152 @@+{-# LANGUAGE TypeFamilies #-}+-- | Backtracking parser for Parsing Expression Grammars+module Text.Grampa.PEG.Backtrack (Parser) where++import Control.Applicative (Applicative(..), Alternative(..), liftA2)+import Control.Monad (Monad(..), MonadPlus(..))++import Data.Char (isSpace)+import Data.Functor.Classes (Show1(..))+import Data.Functor.Compose (Compose(..))+import Data.List (nub)+import Data.Monoid (Monoid(mappend, mempty), (<>))+import Data.Monoid.Factorial(FactorialMonoid)+import Data.Word (Word64)++import qualified Data.Monoid.Cancellative as Cancellative+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Null as Null+import qualified Data.Monoid.Textual as Textual++import qualified Rank2++import Text.Parser.Combinators (Parsing(..))+import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))++data Result (g :: (* -> *) -> *) s v = Parsed{ parsedPrefix :: v, +                                              _parsedSuffix :: s}+                                     | NoParse FailureInfo+data FailureInfo = FailureInfo !Int Word64 [String] deriving (Eq, Show)++-- | Parser type for Parsing Expression Grammars that uses a backtracking algorithm, fast for grammars in LL(1) class+-- but with potentially exponential performance for longer ambiguous prefixes.+newtype Parser g s r = Parser{applyParser :: s -> Result g s r}++instance Show1 (Result g s) where+   liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest+   liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest++instance Functor (Result g s) where+   fmap f (Parsed a rest) = Parsed (f a) rest+   fmap _ (NoParse failure) = NoParse failure+   +instance Functor (Parser g s) where+   fmap f (Parser p) = Parser (fmap f . p)++instance Applicative (Parser g s) where+   pure a = Parser (Parsed a)+   Parser p <*> Parser q = Parser r where+      r rest = case p rest+               of Parsed f rest' -> f <$> q rest'+                  NoParse failure -> NoParse failure++instance Factorial.FactorialMonoid s => Alternative (Parser g s) where+   empty = Parser (\rest-> NoParse $ FailureInfo 0 (fromIntegral $ Factorial.length rest) ["empty"])+   Parser p <|> Parser q = Parser r where+      r rest = case p rest+               of x@Parsed{} -> x+                  NoParse{} -> q rest++instance Monad (Parser g s) where+   return = pure+   Parser p >>= f = Parser r where+      r rest = case p rest+               of Parsed a rest' -> applyParser (f a) rest'+                  NoParse failure -> NoParse failure++instance Factorial.FactorialMonoid s => MonadPlus (Parser g s) where+   mzero = empty+   mplus = (<|>)++instance Monoid x => Monoid (Parser g s x) where+   mempty = pure mempty+   mappend = liftA2 mappend++instance Factorial.FactorialMonoid s => Parsing (Parser g s) where+   try = id+   (<?>) = const+   eof = endOfInput+   unexpected msg = Parser (\t-> NoParse $ FailureInfo 0 (fromIntegral $ Factorial.length t) [msg])+   notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))+      where rewind t Parsed{} = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length t) ["notFollowedBy"])+            rewind t NoParse{} = Parsed () t++instance MonoidParsing (Parser g) where+   endOfInput = Parser p+      where p rest = if Null.null rest+                     then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])+                     else Parsed () rest+   getInput = Parser p+      where p rest = Parsed rest mempty+   anyToken = Parser p+      where p rest = case Factorial.splitPrimePrefix rest+                     of Just (first, suffix) -> Parsed first suffix+                        _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["anyToken"])+   satisfy predicate = Parser p+      where p rest =+               case Factorial.splitPrimePrefix rest+               of Just (first, suffix) | predicate first -> Parsed first suffix+                  _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfy"])+   satisfyChar predicate = Parser p+      where p rest =+               case Textual.splitCharacterPrefix rest+               of Just (first, suffix) | predicate first -> Parsed first suffix+                  _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+   scan s0 f = Parser (p s0)+      where p s rest = Parsed prefix suffix+               where (prefix, suffix, _) = Factorial.spanMaybe' s f rest+   scanChars s0 f = Parser (p s0)+      where p s rest = Parsed prefix suffix+               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest+   takeWhile predicate = Parser p+      where p rest | (prefix, suffix) <- Factorial.span predicate rest = Parsed prefix suffix+   takeWhile1 predicate = Parser p+      where p rest | (prefix, suffix) <- Factorial.span predicate rest =+                        if Null.null prefix+                        then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeWhile1"])+                        else Parsed prefix suffix+   takeCharsWhile predicate = Parser p+      where p rest | (prefix, suffix) <- Textual.span_ False predicate rest = Parsed prefix suffix+   takeCharsWhile1 predicate = Parser p+      where p rest | (prefix, suffix) <- Textual.span_ False predicate rest =+                     if Null.null prefix+                     then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"])+                     else Parsed prefix suffix+   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'+                        NoParse{} -> Parsed mempty rest++-- | Backtracking PEG parser+--+-- @+-- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>+--                  g (Backtrack.'Parser' g s) -> s -> g 'ParseResults'+-- @+instance MultiParsing Parser where+   type ResultFunctor Parser = ParseResults+   {-# NOINLINE parsePrefix #-}+   -- | Returns an input prefix parse paired with the remaining input suffix.+   parsePrefix g input = Rank2.fmap (Compose . fromResult input . (`applyParser` input)) g+   parseComplete g input = Rank2.fmap ((snd <$>) . fromResult input . (`applyParser` input))+                                      (Rank2.fmap (<* endOfInput) g)++fromResult :: FactorialMonoid s => s -> Result g s r -> ParseResults (s, r)+fromResult s (NoParse (FailureInfo _ pos msgs)) =+   Left (ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs))+fromResult _ (Parsed prefix suffix) = Right (suffix, prefix)

@@ -0,0 +1,182 @@+{-# LANGUAGE TypeFamilies #-}+-- | Packrat parser+module Text.Grampa.PEG.Packrat (Parser) 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.Monoid.Factorial(FactorialMonoid)+import Data.Word (Word64)++import qualified Data.Monoid.Cancellative as Cancellative+import qualified Data.Monoid.Factorial as Factorial+import qualified Data.Monoid.Null as Null+import qualified Data.Monoid.Textual as Textual++import qualified Rank2++import Text.Parser.Combinators (Parsing(..))+import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))+import qualified Text.Grampa.PEG.Backtrack as Backtrack (Parser)++data Result g s v = Parsed{parsedPrefix :: v, +                           parsedSuffix :: [(s, g (Result g s))]}+                  | NoParse FailureInfo+data FailureInfo = FailureInfo !Int Word64 [String] deriving (Eq, Show)++-- | Parser type for Parsing Expression Grammars that uses an improved packrat algorithm, with O(1) performance bounds+-- but with worse constants and more memory consumption than 'Backtrack.Parser'. The 'parse' function returns an input+-- prefix parse paired with the remaining input suffix.+newtype Parser g s r = Parser{applyParser :: [(s, g (Result g s))] -> Result g s r}++instance Show1 (Result g s) where+   liftShowsPrec showsPrecSub _showList prec Parsed{parsedPrefix= r} rest = "Parsed " ++ showsPrecSub prec r rest+   liftShowsPrec _showsPrec _showList _prec (NoParse f) rest = "NoParse " ++ shows f rest++instance Functor (Result g s) where+   fmap f (Parsed a rest) = Parsed (f a) rest+   fmap _ (NoParse failure) = NoParse failure+   +instance Functor (Parser g s) where+   fmap f (Parser p) = Parser (fmap f . p)++instance Applicative (Parser g s) where+   pure a = Parser (Parsed a)+   Parser p <*> Parser q = Parser r where+      r rest = case p rest+               of Parsed f rest' -> f <$> q rest'+                  NoParse failure -> NoParse failure++instance Alternative (Parser g s) where+   empty = Parser (\rest-> NoParse $ FailureInfo 0 (genericLength rest) ["empty"])+   Parser p <|> Parser q = Parser r where+      r rest = case p rest+               of x@Parsed{} -> x+                  NoParse{} -> q rest++instance Monad (Parser g s) where+   return = pure+   Parser p >>= f = Parser r where+      r rest = case p rest+               of Parsed a rest' -> applyParser (f a) rest'+                  NoParse failure -> NoParse failure++instance MonadPlus (Parser g s) where+   mzero = empty+   mplus = (<|>)++instance Monoid x => Monoid (Parser g s x) where+   mempty = pure mempty+   mappend = liftA2 mappend++instance Factorial.FactorialMonoid s => Parsing (Parser g s) where+   try = id+   (<?>) = const+   eof = endOfInput+   unexpected msg = Parser (\t-> NoParse $ FailureInfo 0 (genericLength t) [msg])+   notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))+      where rewind t Parsed{} = NoParse (FailureInfo 1 (genericLength t) ["notFollowedBy"])+            rewind t NoParse{} = Parsed () t++instance GrammarParsing Parser where+   type GrammarFunctor Parser = Result+   nonTerminal f = Parser p where+      p ((_, d) : _) = f d+      p _ = NoParse (FailureInfo 1 0 ["NonTerminal at endOfInput"])++instance MonoidParsing (Parser g) where+   endOfInput = Parser p+      where p rest@((s, _) : _)+               | not (Null.null s) = NoParse (FailureInfo 1 (genericLength rest) ["endOfInput"])+            p rest = Parsed () rest+   getInput = Parser p+      where p rest@((s, _):_) = Parsed s [last rest]+            p [] = Parsed mempty []+   anyToken = Parser p+      where p rest@((s, _):t) = case Factorial.splitPrimePrefix s+                                of Just (first, _) -> Parsed first t+                                   _ -> NoParse (FailureInfo 1 (genericLength rest) ["anyToken"])+            p [] = NoParse (FailureInfo 1 0 ["anyToken"])+   satisfy predicate = Parser p+      where p rest@((s, _):t) =+               case Factorial.splitPrimePrefix s+               of Just (first, _) | predicate first -> Parsed first t+                  _ -> NoParse (FailureInfo 1 (genericLength rest) ["satisfy"])+            p [] = NoParse (FailureInfo 1 0 ["satisfy"])+   satisfyChar predicate = Parser p+      where p rest@((s, _):t) =+               case Textual.splitCharacterPrefix s+               of Just (first, _) | predicate first -> Parsed first t+                  _ -> NoParse (FailureInfo 1 (genericLength rest) ["satisfyChar"])+            p [] = NoParse (FailureInfo 1 0 ["satisfyChar"])+   scan s0 f = Parser (p s0)+      where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)+               where (prefix, _, _) = Factorial.spanMaybe' s f i+            p _ [] = Parsed mempty []+   scanChars s0 f = Parser (p s0)+      where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)+               where (prefix, _, _) = Textual.spanMaybe_' s f i+            p _ [] = Parsed mempty []+   takeWhile predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Factorial.takeWhile predicate s = Parsed x (Factorial.drop (Factorial.length x) rest)+            p [] = Parsed mempty []+   takeWhile1 predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Factorial.takeWhile predicate s, not (Null.null x) =+                    Parsed x (Factorial.drop (Factorial.length x) rest)+            p rest = NoParse (FailureInfo 1 (genericLength rest) ["takeWhile1"])+   takeCharsWhile predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Textual.takeWhile_ False predicate s =+                    Parsed x (Factorial.drop (Factorial.length x) rest)+            p [] = Parsed mempty []+   takeCharsWhile1 predicate = Parser p+      where p rest@((s, _) : _)+               | x <- Textual.takeWhile_ False predicate s, not (Null.null x) =+                    Parsed x (drop (Factorial.length x) rest)+            p rest = NoParse (FailureInfo 1 (genericLength rest) ["takeCharsWhile1"])+   string s = Parser p where+      p rest@((s', _) : _)+         | Cancellative.isPrefixOf s s' = Parsed s (Factorial.drop (Factorial.length s) rest)+      p rest = NoParse (FailureInfo 1 (genericLength rest) ["string " ++ show s])+   whiteSpace = () <$ takeCharsWhile isSpace+   concatMany p = go+      where go = (<>) <$> p <*> go <|> mempty+++-- | Packrat parser+--+-- @+-- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>+--                  g (Packrat.'Parser' g s) -> s -> g 'ParseResults'+-- @+instance MultiParsing Parser where+   type ResultFunctor Parser = ParseResults+   {-# NOINLINE parsePrefix #-}+   parsePrefix g input = Rank2.fmap (Compose . fromResult input) (snd $ head $ parseTails g input)+   parseComplete g input = Rank2.fmap ((snd <$>) . fromResult 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 (Result 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 (Result g s))] -> [(s, g (Result g s))]+reparseTails _ [] = []+reparseTails final parsed@((s, _):_) = (s, gd):parsed+   where gd = Rank2.fmap (`applyParser` parsed) final++fromResult :: FactorialMonoid s => s -> Result g s r -> ParseResults (s, r)+fromResult s (NoParse (FailureInfo _ pos msgs)) =+   Left (ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs))+fromResult _ (Parsed prefix []) = Right (mempty, prefix)+fromResult _ (Parsed prefix ((s, _):_)) = Right (s, prefix)

@@ -0,0 +1,102 @@+{-# LANGUAGE Haskell2010, BangPatterns, ExistentialQuantification, FlexibleContexts, OverloadedStrings,+  RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}++module Benchmark where++import Control.Applicative+import Data.Functor.Compose (Compose(..))+import Data.Monoid ((<>))++import Control.DeepSeq (deepseq)+import Criterion.Main (bench, bgroup, defaultMain, nf)++import qualified Rank2+import qualified Rank2.TH++import Text.Grampa+import Text.Grampa.ContextFree.Parallel (Parser)+import qualified Arithmetic+import qualified Boolean+import Main (arithmetic, boolean)++data Recursive f = Recursive{start :: f String,+                             rec :: f String,+                             next :: f String}++$(Rank2.TH.deriveAll ''Recursive)++recursiveManyGrammar :: Recursive (Parser g String) -> Recursive (Parser g String)+recursiveManyGrammar Recursive{..} = Recursive{+   start= rec <* endOfInput,+   rec= many (char ';') <* optional next,+   next= string "END"}++parseInt :: String -> [Int]+parseInt s = case Arithmetic.expr (parseComplete (fixGrammar arithmetic) s)+             of Compose (Right [r]) -> [r]+                r -> error ("Unexpected " <> show r)++parseBoolean :: String -> [Bool]+parseBoolean s = case (Boolean.expr . Rank2.snd) (parseComplete (fixGrammar boolean) s)+                 of Compose (Right [r]) -> [r]+                    r -> error ("Unexpected " <> show r)++zeroes, ones, falsehoods, truths, groupedLeft, groupedRight :: Int -> String+zeroes n = "0" <> concat (replicate n "+0")+ones n = "1" <> concat (replicate n "*1")+falsehoods n = "False" <> concat (replicate n " || False")+truths n = "True" <> concat (replicate n " && True")++groupedLeft n = replicate n '(' <> "0" <> concat (replicate n "+0)")+groupedRight n = concat (replicate n "(0+") <> "0" <> replicate n ')'++main :: IO ()+main = do+   let zeroes100 = zeroes 100+       zeroes200 = zeroes 200+       zeroes300 = zeroes 300+       groupedLeft100 = groupedLeft 100+       groupedLeft200 = groupedLeft 200+       groupedLeft300 = groupedLeft 300+       groupedRight100 = groupedRight 100+       groupedRight200 = groupedRight 200+       groupedRight300 = groupedRight 300+       ones100 = ones 100+       ones200 = ones 200+       ones300 = ones 300+       falsehoods80 = falsehoods 80+       falsehoods160 = falsehoods 160+       falsehoods240 = falsehoods 240+   deepseq (zeroes100, zeroes200, zeroes300,+            groupedLeft100, groupedLeft200, groupedLeft300,+            groupedRight100, groupedRight200, groupedRight300) $+      defaultMain [+{-+      bgroup "many" [+          bench "simple" $ nf (simpleParse $ many (string ";") <* endOfInput) (replicate 400 ';'),+          bench "recursive" $ nf (parse (fixGrammar recursiveManyGrammar) start) (replicate 400 ';')],+-}+      bgroup "zero sum" [+         bench "100" $ nf parseInt zeroes100,+         bench "200" $ nf parseInt zeroes200,+         bench "300" $ nf parseInt zeroes300],+      bgroup "grouped left" [+         bench "100" $ nf parseInt groupedLeft100,+         bench "200" $ nf parseInt groupedLeft200,+         bench "300" $ nf parseInt groupedLeft300],+{-+      bgroup "grouped right" [+            bench "100" $ nf parseInt groupedRight100,+            bench "200" $ nf parseInt groupedRight200,+            bench "300" $ nf parseInt groupedRight300],+-}+      bgroup "one product" [+         bench "100" $ nf parseInt ones100,+         bench "200" $ nf parseInt ones200,+         bench "300" $ nf parseInt ones300],+      bgroup "false disjunction" [+         bench "80" $ nf parseBoolean falsehoods80,+         bench "160" $ nf parseBoolean falsehoods160,+         bench "240" $ nf parseBoolean falsehoods240]+      ]+   

@@ -0,0 +1,3 @@+import Test.DocTest++main = doctest ["-pgmL", "markdown-unlit", "-isrc", "test/README.lhs"]

@@ -0,0 +1,269 @@+{-# Language FlexibleContexts, FlexibleInstances, RankNTypes, RecordWildCards, ScopedTypeVariables, +             StandaloneDeriving, TemplateHaskell, UndecidableInstances #-}+module Main where++import Control.Applicative (Applicative, Alternative, Const(..), pure, empty, many, optional, (<*>), (*>), (<|>))+import Control.Arrow (first)+import Control.Monad (MonadPlus(mzero, mplus), guard, liftM, liftM2, void)+import Data.Char (isSpace, isLetter)+import Data.List (find, minimumBy, nub, sort)+import Data.Monoid (Monoid(..), Product(..), (<>))+import Data.Monoid.Cancellative (LeftReductiveMonoid(..))+import Data.Monoid.Null (MonoidNull(null))+import Data.Monoid.Factorial (FactorialMonoid(factors))+import Data.Monoid.Textual (TextualMonoid(toString))+import Data.Typeable (Typeable)+import Data.Word (Word8, Word64)++import Data.Functor.Compose (Compose(..))+import Text.Parser.Combinators (sepBy1, skipMany)++import Test.Feat (Enumerable(..), Enumerate, FreePair(Free), consts, shared, unary, uniform)+import Test.Feat.Enumerate (pay)+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.QuickCheck (Arbitrary(..), Gen, Positive(..), Property,+                              (===), (==>), (.&&.), forAll, property, sized, testProperty, within)+import Test.QuickCheck.Checkers (Binop, EqProp(..), TestBatch, unbatch)+import Test.QuickCheck.Classes (functor, monad, monoid, applicative, alternative,+                                monadFunctor, monadApplicative, monadOr, monadPlus)++import qualified Rank2+import qualified Rank2.TH+import Text.Grampa+import qualified Text.Grampa.ContextFree.Parallel as Parallel+import qualified Text.Grampa.ContextFree.LeftRecursive as LeftRecursive++import qualified Test.Examples++import Prelude hiding (null, takeWhile)++data Recursive f = Recursive{start :: f String,+                             rec :: f [String],+                             one :: f String,+                             next :: f String}+deriving instance (Show (f String), Show (f [String])) => Show (Recursive f)++$(Rank2.TH.deriveAll ''Recursive)++recursiveManyGrammar Recursive{..} = Recursive{+   start= optional (string "[") *> (concat <$> rec) <* optional next,+   rec= (:) <$> one <*> rec <|> pure [],+   one = string "(" *> start <* string ")",+   next= string "]"}++nameListGrammar :: Recursive (LeftRecursive.Parser Recursive String)+nameListGrammar = fixGrammar nameListGrammarBuilder+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",+   one= do ignorable+           identifier <- ((:) <$> satisfyChar isLetter <*> (toString (const "") <$> takeCharsWhile isLetter))+           guard (identifier /= "reserved")+           pure id <*> pure identifier+        <?> "one",+   next= string "--" *> (toString (const "") <$> takeCharsWhile (/= '\n') <* (void (char '\n') <|> endOfInput)) <?> "next"+   }++symbol s = ignorable *> string s <* ignorable+ignorable = whiteSpace *> skipMany (nonTerminal next *> whiteSpace <?> "ignorable1") <?> "ignorable"+--ignorable = recursiveOn [next] $ whiteSpace *> skipMany (next nameListGrammar *> whiteSpace <?> "ignorable1") <?> "ignorable"+--ignorable = whiteSpace *> (Parser.NonTerminal next *> ignorable <<|> pure ())++main = defaultMain tests++type Parser = Parallel.Parser++simpleParse :: FactorialMonoid s => Parallel.Parser (Rank2.Only r) s r -> s -> ParseResults [(s, r)]+simpleParse p input = getCompose . getCompose $ simply parsePrefix p input++tests = testGroup "Grampa" [+           let g = fixGrammar recursiveManyGrammar :: Recursive (LeftRecursive.Parser Recursive String)+           in testGroup "recursive"+              [testProperty "minimal" $ start (parseComplete g "()") == Compose (Right [""]),+               testProperty "bracketed" $ start (parseComplete g "[()]") == Compose (Right [""]),+               testProperty "name list" $+                 start (parseComplete nameListGrammar "foo, bar") == Compose (Right ["foo bar"])],+           testGroup "arithmetic"+             [testProperty "arithmetic"   $ Test.Examples.parseArithmetical,+              testProperty "comparisons"  $ Test.Examples.parseComparison,+              testProperty "boolean"      $ Test.Examples.parseBoolean,+              testProperty "conditionals" $ Test.Examples.parseConditional],+           testGroup "primitives"+             [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)) == [],+              testProperty "satisfy mempty" $ results (simpleParse (satisfy (undefined :: [Char] -> Bool)) []) == [],+              testProperty "string success" $ \(xs::[Word8]) ys->+                   simpleParse (string xs) (xs <> ys) == Right [(ys, xs)],+              testProperty "string" $ \(xs::[Word8]) ys-> not (xs `isPrefixOf` ys)+                ==> simpleParse (string xs) ys == Left (ParseFailure 0 ["string " ++ show xs]),+              testProperty "endOfInput mempty" $ simpleParse endOfInput "" == Right [("", ())],+              testProperty "endOfInput failure" $ \s->+                   s /= "" ==> simpleParse endOfInput s == Left (ParseFailure 0 ["endOfInput"])],+           testGroup "lookAhead"+             [testProperty "lookAhead" lookAheadP,+              testProperty "lookAhead p *> p" lookAheadConsumeP,+              testProperty "lookAhead or not" lookAheadOrNotP,+              testProperty "notFollowedBy p *> p" lookAheadNotAndP,+              testProperty "not not" lookAheadNotNotP,+              testProperty "lookAhead anyToken" lookAheadTokenP],+           testGroup "classes"+             [testBatch (monoid parser3s),+              testBatch (functor parser3s),+              testBatch (applicative parser3s),+              testBatch (alternative parser2s),+              testBatch $ monad parser3s,+              testBatch $ monadFunctor parser2s,+              testBatch $ monadApplicative parser2s,+              -- testBatch $ monadOr parser2s,+              testBatch $ monadPlus parser2s+             ]]+   where lookAheadP :: String -> DescribedParser String [Bool] -> Bool+         lookAheadConsumeP :: DescribedParser String [Bool] -> Property+         lookAheadOrNotP :: DescribedParser String () -> Property+         lookAheadNotAndP :: DescribedParser String [Bool] -> Property+         lookAheadNotNotP :: DescribedParser String [Bool] -> Property+         lookAheadTokenP :: Char -> String -> Bool+         +         lookAheadP xs (DescribedParser _ p) = simpleParse (lookAhead p) xs+                                               == (map (first $ const xs) <$> simpleParse p xs)+         lookAheadConsumeP (DescribedParser _ p) = (lookAhead p *> p :: Parser (Rank2.Only [Bool]) String [Bool])+                                                   =-= p+         lookAheadOrNotP (DescribedParser _ p) = within 2000000 $+            (notFollowedBy p <|> lookAhead p) =-= (mempty :: Parser (Rank2.Only ()) String ())+         lookAheadNotAndP (DescribedParser _ p) = within 2000000 $+            (notFollowedBy p *> p) =-= (empty :: Parser (Rank2.Only [Bool]) String [Bool])+         lookAheadNotNotP (DescribedParser d p) =+            notFollowedBy (notFollowedBy p) =-= (void (lookAhead p) :: Parser (Rank2.Only ()) String ())+         lookAheadTokenP x xs = simpleParse (lookAhead anyToken) (x:xs) == Right [(x:xs, [x])]++instance Enumerable (DescribedParser s r) => Arbitrary (DescribedParser s r) where+   arbitrary = sized uniform++testBatch :: TestBatch -> TestTree+testBatch (label, tests) = testGroup label (uncurry testProperty . (within 1000000 <$>) <$> tests)++parser2s :: DescribedParser ([Bool], [Bool]) ([Bool], [Bool])+parser2s = undefined++parser3s :: DescribedParser ([Bool], [Bool], [Bool]) ([Bool], [Bool], [Bool])+parser3s = undefined++data DescribedParser s r = DescribedParser String (forall g. (Typeable g, Rank2.Functor g) => Parser g s r)++instance Show (DescribedParser s r) where+   show (DescribedParser d _) = d++instance (Show s, MonoidNull s, Monoid r) => Monoid (DescribedParser s r) where+   mempty = DescribedParser "mempty" mempty+   DescribedParser d1 p1 `mappend` DescribedParser d2 p2 = DescribedParser (d1 ++ " <> " ++ d2) (mappend p1 p2)++instance EqProp ParseFailure where+   ParseFailure pos1 msg1 =-= ParseFailure pos2 msg2 = property (pos1 == pos2)++instance (Ord r, Show r, EqProp r, Eq s, EqProp s, Show s, FactorialMonoid s, Arbitrary s) =>+         EqProp (Parser (Rank2.Only r) s r) where+   p1 =-= p2 = forAll arbitrary (\s-> (nub <$> simpleParse p1 s) =-= (nub <$> simpleParse p2 s))++instance (FactorialMonoid s, Show s, EqProp s, Arbitrary s, Ord r, Show r, EqProp r, Typeable r) =>+         EqProp (DescribedParser s r) where+   DescribedParser _ p1 =-= DescribedParser _ p2 = forAll arbitrary $ \s->+      simpleParse p1 s =-= simpleParse p2 s++instance Monoid s => Functor (DescribedParser s) where+   fmap f (DescribedParser d p) = DescribedParser ("fmap ? " ++ d) (fmap f p)++instance (Show s, Monoid s) => Applicative (DescribedParser s) where+   pure x = DescribedParser "pure ?" (pure x)+   DescribedParser d1 p1 <*> DescribedParser d2 p2 = DescribedParser (d1 ++ " <*> " ++ d2) (p1 <*> p2)++instance (Show s, Monoid s) => Monad (DescribedParser s) where+   return x = DescribedParser "return ?" (return x)+   DescribedParser d1 p1 >>= f = DescribedParser (d1 ++ " >>= ?") (p1 >>= \x-> let DescribedParser _ p = f x in p)+   DescribedParser d1 p1 >> DescribedParser d2 p2 = DescribedParser (d1 ++ " >> " ++ d2) (p1 >> p2)++instance (Show s, FactorialMonoid s) => Alternative (DescribedParser s) where+   empty = DescribedParser "empty" empty+   DescribedParser d1 p1 <|> DescribedParser d2 p2 = DescribedParser (d1 ++ " <|> " ++ d2) (p1 <|> p2)++instance (Show s, FactorialMonoid s) => MonadPlus (DescribedParser s) where+   mzero = DescribedParser "mzero" mzero+   DescribedParser d1 p1 `mplus` DescribedParser d2 p2 = DescribedParser (d1 ++ " `mplus` " ++ d2) (mplus p1 p2)++instance forall s. (FactorialMonoid s, LeftReductiveMonoid s, Ord s, Typeable s, Show s, Enumerable s) =>+         Enumerable (DescribedParser s s) where+   enumerate = consts (pure <$> [DescribedParser "anyToken" anyToken,+                                 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))+               <> pay (unary $ \pred-> DescribedParser "takeWhile1" (takeWhile1 pred))+               <> binary " *> " (*>)+               <> binary " <> " (<>)+               <> binary " <|> " (<|>)+      where binary :: String -> (forall g. Rank2.Functor g => Parser g s s -> Parser g s s -> Parser g s s)+                   -> Enumerate (DescribedParser s s)+            binary nm op = (\(Free (DescribedParser d1 p1, DescribedParser d2 p2))-> DescribedParser (d1 <> nm <> d2) (op p1 p2))+                           <$> pay enumerate++instance forall s r. (Ord s, FactorialMonoid s, LeftReductiveMonoid s, Show s, Enumerable s) =>+         Enumerable (DescribedParser s ()) where+   enumerate = consts (pure <$> [DescribedParser "endOfInput" endOfInput])+               <> pay (unary $ \(DescribedParser d p :: DescribedParser s s)-> DescribedParser ("void " <> d) (void p))+               <> pay (unary $ \(DescribedParser d p :: DescribedParser s s)->+                                  DescribedParser ("(notFollowedBy " <> d <> ")") (notFollowedBy p))++instance forall s r. (Show s, FactorialMonoid s, Typeable s) => Enumerable (DescribedParser s [Bool]) where+   enumerate = consts (pure <$> [DescribedParser "empty" empty,+                                 DescribedParser "mempty" mempty])+               <> pay (unary $ \r-> DescribedParser ("(pure " ++ shows r ")") (pure r))+               <> pay (unary $ \(DescribedParser d p)-> DescribedParser ("(lookAhead " <> d <> ")") (lookAhead p))+               <> binary " *> " (*>)+               <> binary " <> " (<>)+               <> binary " <|> " (<|>)+      where binary :: String+                   -> (forall g. Rank2.Functor g => Parser g s [Bool] -> Parser g s [Bool] -> Parser g s [Bool])+                   -> Enumerate (DescribedParser s [Bool])+            binary nm op = (\(Free (DescribedParser d1 p1, DescribedParser d2 p2))-> DescribedParser (d1 <> nm <> d2) (op p1 p2))+                           <$> pay enumerate++instance forall s r. (Show s, FactorialMonoid s, Typeable s) => Enumerable (DescribedParser s ([Bool] -> [Bool])) where+   enumerate = consts (pure <$> [DescribedParser "empty" empty,+                                 DescribedParser "mempty" mempty])+               <> pay (unary $ \r-> DescribedParser ("(pure " ++ shows r ")") (pure r))+               <> pay (unary $ \(DescribedParser d p)-> DescribedParser ("(lookAhead " <> d <> ")") (lookAhead p))+               <> binary " *> " (*>)+               <> binary " <> " (<>)+               <> binary " <|> " (<|>)+      where binary :: String+                   -> (forall g. Rank2.Functor g => Parser g s ([Bool] -> [Bool]) -> Parser g s ([Bool] -> [Bool])+                                                    -> Parser g s ([Bool] -> [Bool]))+                   -> Enumerate (DescribedParser s ([Bool] -> [Bool]))+            binary nm op = (\(Free (DescribedParser d1 p1, DescribedParser d2 p2))-> DescribedParser (d1 <> nm <> d2) (op p1 p2))+                           <$> pay enumerate++instance (Ord s, Enumerable s) => Enumerable (s -> Bool) where+   enumerate = pay (unary (<=))+               <> pay (unary const)++instance Enumerable ([Bool] -> [Bool]) where+   enumerate = consts [pure id,+                       pure (map not)]+               <> pay (unary const)++instance EqProp Word64 where+   a =-= b = property (a == b)++results = either (const []) id

@@ -0,0 +1,131 @@+{-# Language RankNTypes, ScopedTypeVariables #-}+module Test.Examples where++import Control.Applicative (empty, (<|>))+import Data.Functor.Compose (Compose(..))+import Data.Monoid (Monoid(..), (<>))+import Data.Monoid.Factorial (FactorialMonoid)++import Test.Feat (Enumerable(..), Enumerate, FreePair(Free), consts, shared, unary, uniform)+import Test.Feat.Enumerate (pay)+import Test.Tasty.QuickCheck (Arbitrary(..), Gen, Positive(..), Property, testProperty, (===), (==>), (.&&.),+                              forAll, mapSize, oneof, resize, sized, whenFail)+import Data.Word (Word8)++import qualified Rank2+import Text.Grampa+import Text.Grampa.ContextFree.LeftRecursive (Parser)+import qualified Arithmetic+import qualified Comparisons+import qualified Boolean+import qualified Conditionals++parseArithmetical :: Sum -> Bool+parseArithmetical (Sum s) = f s' == s'+   where f = uniqueParse (fixGrammar Arithmetic.arithmetic) Arithmetic.expr+         s' = f s++parseComparison :: Comparison -> Bool+parseComparison (Comparison s) = f s' == s'+   where f = uniqueParse (fixGrammar comparisons) (Comparisons.test . Rank2.snd)+         s' = f s++comparisons :: Rank2.Functor g => GrammarBuilder ArithmeticComparisons g Parser String+comparisons (Rank2.Pair a c) =+   Rank2.Pair (Arithmetic.arithmetic a) (Comparisons.comparisons c){Comparisons.term= Arithmetic.expr a}++parseBoolean :: Disjunction -> Bool+parseBoolean (Disjunction s) = f s' == s'+   where f = uniqueParse (fixGrammar boolean) (Boolean.expr . Rank2.snd)+         s' = f s++boolean :: Rank2.Functor g => 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+parseConditional (Conditional s) = f s' == s'+   where f = uniqueParse (fixGrammar conditionals) (Conditionals.expr . Rank2.snd)+         s' = f s++conditionals :: Rank2.Functor g => GrammarBuilder ACBC g Parser String+conditionals (Rank2.Pair acb c) =+   boolean acb `Rank2.Pair`+   Conditionals.conditionals c{Conditionals.test= Boolean.expr (Rank2.snd acb),+                               Conditionals.term= Arithmetic.expr (Rank2.fst $ Rank2.fst acb)}++type ArithmeticComparisons = Rank2.Product (Arithmetic.Arithmetic String) (Comparisons.Comparisons String String)+type ArithmeticComparisonsBoolean = Rank2.Product ArithmeticComparisons (Boolean.Boolean String)+type ACBC = Rank2.Product ArithmeticComparisonsBoolean (Conditionals.Conditionals String String)++newtype Factor      = Factor {factorString :: String}           deriving (Show)+newtype Product     = Product {productString :: String}         deriving (Show)+newtype Sum         = Sum {sumString :: String}                 deriving (Show)+newtype Comparison  = Comparison {compString :: String}         deriving (Show)+newtype Truth       = Truth {truthString :: String}             deriving (Show)+newtype Conjunction = Conjunction {conjunctionString :: String} deriving (Show)+newtype Disjunction = Disjunction {disjunctionString :: String} deriving (Show)+newtype Conditional = Conditional {conditionalString :: String} deriving (Show)++instance Arbitrary Factor where+   arbitrary = sized uniform+instance Arbitrary Product where+   arbitrary = sized uniform+instance Arbitrary Sum where+   arbitrary = sized uniform+instance Arbitrary Comparison where+   arbitrary = sized uniform+instance Arbitrary Truth where+   arbitrary = sized uniform+instance Arbitrary Conjunction where+   arbitrary = sized uniform+instance Arbitrary Disjunction where+   arbitrary = sized uniform+instance Arbitrary Conditional where+   arbitrary = sized uniform++instance Enumerable Factor where+   enumerate = unary (Factor . (show :: Word8 -> String))+               <> pay (unary $ Factor . (\s-> "(" <> s <> ")") . productString)++instance Enumerable Product where+   enumerate = unary (Product . factorString)+               <> (Product <$> (\(Free (Product a, Factor b))-> a <> "*" <> b) <$> pay enumerate)+               <> (Product <$> (\(Free (Product a, Factor b))-> a <> "/" <> b) <$> pay enumerate)++instance Enumerable Sum where+   enumerate = unary (Sum . productString)+               <> (Sum <$> (\(Free (Sum a, Product b))-> a <> "+" <> b) <$> pay enumerate)+               <> (Sum <$> (\(Free (Sum a, Product b))-> a <> "-" <> b) <$> pay enumerate)++instance Enumerable Comparison where+   enumerate = Comparison <$> (((\(Free (Sum a, Sum b))-> a <> "<" <> b) <$> pay enumerate)+                               <> ((\(Free (Sum a, Sum b))-> a <> "<=" <> b) <$> pay enumerate)+                               <> ((\(Free (Sum a, Sum b))-> a <> "==" <> b) <$> pay enumerate)+                               <> ((\(Free (Sum a, Sum b))-> a <> ">=" <> b) <$> pay enumerate)+                               <> ((\(Free (Sum a, Sum b))-> a <> ">" <> b) <$> pay enumerate))++instance Enumerable Truth where+   enumerate = Truth <$> (consts [pure "False", pure "True"]+                          <> pay (unary $ ("not " <>) . truthString)+                          <> pay (unary $ (\s-> "(" <> s <> ")") . disjunctionString))++instance Enumerable Conjunction where+   enumerate = unary (Conjunction . truthString)+               <> (Conjunction <$> (\(Free (Conjunction a, Truth b))-> a <> "&&" <> b) <$> pay enumerate)++instance Enumerable Disjunction where+   enumerate = unary (Disjunction . conjunctionString)+               <> (Disjunction <$> (\(Free (Disjunction a, Conjunction b))-> a <> "||" <> b) <$> pay enumerate)++instance Enumerable Conditional where+   enumerate = Conditional+               <$> (\(Free (Disjunction a, Free (Sum b, Sum c)))-> "if " <> a <> " then " <> b <> " else " <> c)+               <$> pay enumerate++uniqueParse :: (Eq s, FactorialMonoid s, Rank2.Apply g, Rank2.Traversable g, Rank2.Distributive g) =>+               Grammar g Parser s -> (forall f. g f -> f r) -> s -> r+uniqueParse g p s = case getCompose (p $ parseComplete g s)+                    of Right [r] -> r+                       Right [] -> error "Unparseable"+                       Right _ -> error "Ambiguous"+                       Left (ParseFailure pos exp) -> error ("At " <> show pos <> " expected one of " <> show exp)