diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/examples/Arithmetic.hs b/examples/Arithmetic.hs
new file mode 100644
--- /dev/null
+++ b/examples/Arithmetic.hs
@@ -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])
diff --git a/examples/Boolean.hs b/examples/Boolean.hs
new file mode 100644
--- /dev/null
+++ b/examples/Boolean.hs
@@ -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 ")"}
diff --git a/examples/Combined.hs b/examples/Combined.hs
new file mode 100644
--- /dev/null
+++ b/examples/Combined.hs
@@ -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}}
diff --git a/examples/Comparisons.hs b/examples/Comparisons.hs
new file mode 100644
--- /dev/null
+++ b/examples/Comparisons.hs
@@ -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}
diff --git a/examples/Conditionals.hs b/examples/Conditionals.hs
new file mode 100644
--- /dev/null
+++ b/examples/Conditionals.hs
@@ -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}
diff --git a/examples/Lambda.hs b/examples/Lambda.hs
new file mode 100644
--- /dev/null
+++ b/examples/Lambda.hs
@@ -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}
diff --git a/examples/Main.hs b/examples/Main.hs
new file mode 100644
--- /dev/null
+++ b/examples/Main.hs
@@ -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)})
diff --git a/examples/Utilities.hs b/examples/Utilities.hs
new file mode 100644
--- /dev/null
+++ b/examples/Utilities.hs
@@ -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
diff --git a/grammatical-parsers.cabal b/grammatical-parsers.cabal
new file mode 100644
--- /dev/null
+++ b/grammatical-parsers.cabal
@@ -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
diff --git a/src/Text/Grampa.hs b/src/Text/Grampa.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Grampa.hs
@@ -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)
diff --git a/src/Text/Grampa/Class.hs b/src/Text/Grampa/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Grampa/Class.hs
@@ -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)
diff --git a/src/Text/Grampa/ContextFree/LeftRecursive.hs b/src/Text/Grampa/ContextFree/LeftRecursive.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Grampa/ContextFree/LeftRecursive.hs
@@ -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
diff --git a/src/Text/Grampa/ContextFree/Memoizing.hs b/src/Text/Grampa/ContextFree/Memoizing.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Grampa/ContextFree/Memoizing.hs
@@ -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)
diff --git a/src/Text/Grampa/ContextFree/Parallel.hs b/src/Text/Grampa/ContextFree/Parallel.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Grampa/ContextFree/Parallel.hs
@@ -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)
diff --git a/src/Text/Grampa/PEG/Backtrack.hs b/src/Text/Grampa/PEG/Backtrack.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Grampa/PEG/Backtrack.hs
@@ -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)
diff --git a/src/Text/Grampa/PEG/Packrat.hs b/src/Text/Grampa/PEG/Packrat.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Grampa/PEG/Packrat.hs
@@ -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)
diff --git a/test/Benchmark.hs b/test/Benchmark.hs
new file mode 100644
--- /dev/null
+++ b/test/Benchmark.hs
@@ -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]
+      ]
+   
diff --git a/test/Doctest.hs b/test/Doctest.hs
new file mode 100644
--- /dev/null
+++ b/test/Doctest.hs
@@ -0,0 +1,3 @@
+import Test.DocTest
+
+main = doctest ["-pgmL", "markdown-unlit", "-isrc", "test/README.lhs"]
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644
--- /dev/null
+++ b/test/Test.hs
@@ -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
diff --git a/test/Test/Examples.hs b/test/Test/Examples.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Examples.hs
@@ -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)