diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,7 +1,7 @@
 Grammatical Parsers
 ===================
 
-Behold, yet another parser combinator library in Haskell.
+Behold, yet another parser combinator library in Haskell. Except this one is capable of working with grammars rather than mere parsers. A more in-depth description is available in the [paper](../Grampa.lhs.pdf) from Haskell Symposium 2017, what follows is a short tutorial.
 
 You can apply the usual
 [Applicative](http://hackage.haskell.org/package/base/docs/Control-Applicative.html#t:Applicative),
diff --git a/examples/Arithmetic.hs b/examples/Arithmetic.hs
--- a/examples/Arithmetic.hs
+++ b/examples/Arithmetic.hs
@@ -67,12 +67,9 @@
 instance Rank2.Applicative (Arithmetic e) where
    pure f = Arithmetic f f f f f
 
+instance Rank2.DistributiveTraversable (Arithmetic e)
+
 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),
diff --git a/examples/Comparisons.hs b/examples/Comparisons.hs
--- a/examples/Comparisons.hs
+++ b/examples/Comparisons.hs
@@ -48,9 +48,9 @@
 instance Rank2.Applicative (Comparisons c e) where
    pure f = Comparisons f f
 
+instance Rank2.DistributiveTraversable (Comparisons c e)
+
 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)}
 
diff --git a/grammatical-parsers.cabal b/grammatical-parsers.cabal
--- a/grammatical-parsers.cabal
+++ b/grammatical-parsers.cabal
@@ -1,5 +1,5 @@
 name:                grammatical-parsers
-version:             0.1
+version:             0.2
 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
@@ -27,16 +27,16 @@
                        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
+  other-modules:       Text.Grampa.Class, Text.Grampa.Internal, Text.Grampa.PEG.Backtrack.Length
   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
+                       parsers < 0.13,
+                       rank2classes < 1.0
   -- hs-source-dirs:      
   default-language:    Haskell2010
 
@@ -46,7 +46,8 @@
   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,
+                       parsers < 0.13,
+                       rank2classes < 1.0, grammatical-parsers,
                        monoid-subclasses >=0.4 && <0.5
 
 test-suite           quicktests
@@ -54,7 +55,7 @@
   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,
+                     rank2classes < 1.0, grammatical-parsers,
                      QuickCheck >= 2 && < 3, checkers >= 0.4.6 && < 0.5, testing-feat < 0.5,
                      tasty >= 0.7, tasty-quickcheck >= 0.7
   main-is:           Test.hs
@@ -73,7 +74,7 @@
   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,
+  Build-Depends:     base >=4.7 && < 5, rank2classes < 1.0, grammatical-parsers, monoid-subclasses >=0.4 && <0.5,
                      criterion >= 1.0, deepseq >= 1.1, containers >= 0.5.7.0 && < 0.6, text >= 1.1
   main-is:           Benchmark.hs
   other-modules:     Arithmetic
diff --git a/src/Text/Grampa.hs b/src/Text/Grampa.hs
--- a/src/Text/Grampa.hs
+++ b/src/Text/Grampa.hs
@@ -18,7 +18,6 @@
 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(..))
 
@@ -34,6 +33,5 @@
    = 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 :: (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
--- a/src/Text/Grampa/Class.hs
+++ b/src/Text/Grampa/Class.hs
@@ -10,7 +10,6 @@
 import Data.Monoid.Factorial (FactorialMonoid)
 import Data.Monoid.Textual (TextualMonoid)
 import GHC.Exts (Constraint)
-import Text.Parser.Combinators (Parsing)
 
 import qualified Rank2
 
@@ -33,8 +32,7 @@
    type GrammarConstraint m (g :: (* -> *) -> *) :: Constraint
    type GrammarConstraint m g = Rank2.Functor g
    -- | Given a rank-2 record of parsers and input, produce a record of parses of the complete input.
-   parseComplete :: (GrammarConstraint m g, FactorialMonoid s) =>
-                    g (m g s) -> s -> g (ResultFunctor m)
+   parseComplete :: (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) =>
@@ -44,11 +42,11 @@
 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
+   nonTerminal :: GrammarConstraint m g => (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)
+   selfReferring :: (GrammarConstraint m g, 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)
+   fixGrammar :: forall g s. (GrammarConstraint m g, 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
 
@@ -61,7 +59,7 @@
    -- | 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
+   getInput :: FactorialMonoid s => m s s
 
    -- | A parser that accepts any single input atom.
    anyToken :: FactorialMonoid s => m s s
@@ -69,9 +67,17 @@
    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.
+   -- | Specialization of 'satisfy' on 'TextualMonoid' inputs, accepting and returning an input character only if it
+   -- satisfies the given predicate.
    satisfyChar :: TextualMonoid s => (Char -> Bool) -> m s Char
+   -- | Specialization of 'satisfy' on 'TextualMonoid' inputs, accepting an input character only if it satisfies the
+   -- given predicate, and returning the input atom that represents the character. A faster version of @singleton <$>
+   -- satisfyChar p@ and of @satisfy (fromMaybe False p . characterPrefix)@.
+   satisfyCharInput :: TextualMonoid s => (Char -> Bool) -> m s s
+   -- | A parser that succeeds exactly when satisfy doesn't, equivalent to @notFollowedBy . satisfy@
+   notSatisfy :: FactorialMonoid s => (s -> Bool) -> m s ()
+   -- | A parser that succeeds exactly when satisfyChar doesn't, equivalent to @notFollowedBy . satisfyChar@
+   notSatisfyChar :: TextualMonoid s => (Char -> Bool) -> m s ()
 
    -- | A stateful scanner. The predicate modifies a state argument, and each transformed state is passed to successive
    -- invocations of the predicate on each token of the input until one returns 'Nothing' or the input ends.
diff --git a/src/Text/Grampa/ContextFree/LeftRecursive.hs b/src/Text/Grampa/ContextFree/LeftRecursive.hs
--- a/src/Text/Grampa/ContextFree/LeftRecursive.hs
+++ b/src/Text/Grampa/ContextFree/LeftRecursive.hs
@@ -1,23 +1,17 @@
-{-# LANGUAGE FlexibleContexts, GADTs, InstanceSigs, GeneralizedNewtypeDeriving,
-             RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, InstanceSigs,
+             RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, UndecidableInstances #-}
 {-# OPTIONS -fno-full-laziness #-}
-module Text.Grampa.ContextFree.LeftRecursive (Parser)
+module Text.Grampa.ContextFree.LeftRecursive (Fixed, Parser, SeparatedParser(..), longest, peg, terminalPEG, 
+                                              parseSeparated, separated, (<<|>))
 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.Maybe (isJust)
 
 import Data.Monoid (Monoid(mempty), All(..), Any(..), (<>))
 import Data.Monoid.Null (MonoidNull(null))
@@ -35,42 +29,87 @@
 
 import qualified Rank2
 import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults)
+import Text.Grampa.Internal (BinTree(EmptyTree))
 import Text.Grampa.ContextFree.Memoizing (ResultList(..), fromResultList)
 import qualified Text.Grampa.ContextFree.Memoizing as Memoizing
+import qualified Text.Grampa.PEG.Backtrack.Length as Backtrack
 
-import Prelude hiding (null, showsPrec, span, takeWhile)
+import Prelude hiding (cycle, null, 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
+type Parser = Fixed Memoizing.Parser
 
--- | Parser of general context-free grammars, including left recursion. O(n³) performance.
+data Fixed p g s a =
+   Parser {
+      complete, direct, direct0, direct1, indirect :: p g s a,
+      cyclicDescendants :: Rank2.Apply g => g (Const (ParserFlags g)) -> ParserFlags g}
+   | DirectParser {
+      complete, direct0, direct1 :: p g s a}
+   | PositiveDirectParser {
+      complete :: p g s a}
+
+data SeparatedParser p g s a = FrontParser (p g s a)
+                             | CycleParser {
+                                  cycleParser  :: p g s a,
+                                  backParser   :: p g s a,
+                                  dependencies :: g (Const Bool)}
+                             | BackParser {
+                                  backParser :: p g s a}
+
+data ParserFlags g = ParserFlags {
+   nullable :: Bool,
+   dependsOn :: g (Const Bool)}
+
+deriving instance Show (g (Const Bool)) => Show (ParserFlags g)
+
+data ParserFunctor g s a = ParserResultsFunctor {parserResults :: ResultList g s a}
+                         | ParserFlagsFunctor {parserFlags :: ParserFlags g}
+
+newtype Union (g :: (* -> *) -> *) = Union{getUnion :: g (Const Bool)}
+
+--instance Rank2.Applicative g => Monoid (Union g) where
+--   mempty = Union (Rank2.pure $ Const False)
+
+instance (Rank2.Apply g, Rank2.Distributive g) => Monoid (Union g) where
+   mempty = Union (Rank2.distributeWith (Const . getConst) (Const False))
+   mappend (Union g1) (Union g2) = Union (Rank2.liftA2 union g1 g2)
+
+general, general' :: Alternative (p g s) => Fixed p g s a -> Fixed p g s a
+
+general p = Parser{
+   complete= complete p,
+   direct = direct p',
+   direct0= direct0 p',
+   direct1= direct1 p',
+   indirect= indirect p',
+   cyclicDescendants= cyclicDescendants p'}
+   where p' = general' p
+
+general' p@PositiveDirectParser{} = Parser{
+   complete= complete p,
+   direct = complete p,
+   direct0= empty,
+   direct1= complete p,
+   indirect= empty,
+   cyclicDescendants= \cd-> ParserFlags False (const (Const False) Rank2.<$> cd)}
+general' p@DirectParser{} = Parser{
+   complete= complete p,
+   direct = complete p,
+   direct0= direct0 p,
+   direct1= direct1 p,
+   indirect= empty,
+   cyclicDescendants= \cd-> ParserFlags True (const (Const False) Rank2.<$> cd)}
+general' p@Parser{} = p
+
+-- | Parser of general context-free grammars, including left recursion.
 --
 -- @
 -- 'parseComplete' :: ("Rank2".'Rank2.Apply' g, "Rank2".'Rank2.Traversable' g, 'FactorialMonoid' s) =>
---                  g (LeftRecursive.'Parser' g s) -> s -> g ('Compose' 'ParseResults' [])
+--                  g (LeftRecursive.'Fixed 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) =>
+instance MultiParsing (Fixed Memoizing.Parser) where
+   type GrammarConstraint (Fixed Memoizing.Parser) g = (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)
+   type ResultFunctor (Fixed Memoizing.Parser) = Compose ParseResults []
+   parsePrefix :: (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, FactorialMonoid s) =>
                   g (Parser g s) -> s -> g (Compose (Compose ParseResults []) ((,) s))
    parsePrefix g input = Rank2.fmap (Compose . Compose . fromResultList input)
                                     (snd $ head $ parseRecursive g input)
@@ -80,369 +119,530 @@
                                       (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 GrammarParsing (Fixed Memoizing.Parser) where
+   type GrammarFunctor (Fixed Memoizing.Parser) = ParserFunctor
+   nonTerminal :: forall g s a. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g)
+                  => (g (ParserFunctor g s) -> ParserFunctor g s a) -> Parser g s a
+   nonTerminal f = Parser{
+      complete= ind,
+      direct= empty,
+      direct0= empty,
+      direct1= empty,
+      indirect= ind,
+      cyclicDescendants= parserFlags . f . Rank2.fmap (ParserFlagsFunctor . getConst) . addSelf}
+      where ind = nonTerminal (parserResults . f . Rank2.fmap ParserResultsFunctor)
+            addSelf g = Rank2.liftA2 adjust bits g
+            adjust :: forall b. Const (g (Const Bool)) b -> Const (ParserFlags g) b -> Const (ParserFlags g) b
+            adjust (Const bit) (Const (ParserFlags n d)) =
+               Const ParserFlags{
+                  nullable= n, 
+                  dependsOn= Rank2.liftA2 union bit d}
+   {-# INLINE nonTerminal #-}
+   recursive = general
 
-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"
+bits :: forall (g :: (* -> *) -> *). (Rank2.Distributive g, Rank2.Traversable g) => g (Const (g (Const Bool)))
+bits = start `seq` Rank2.fmap oneBit start
+   where start = evalState (Rank2.traverse next (Rank2.distributeJoin Nothing)) 0
+         oneBit :: Const Int a -> Const (g (Const Bool)) a
+         next :: f a -> State Int (Const Int a)
+         oneBit (Const i) = Const (Rank2.fmap (Const . (i ==) . getConst) start)
+         next _ = do {i <- get; let {i' = succ i}; seq i' (put i'); return (Const i)}
 
-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 (p g s) => Functor (Fixed p g s) where
+   fmap f (PositiveDirectParser p) = PositiveDirectParser (fmap f p)
+   fmap f p@DirectParser{} = DirectParser{
+      complete= fmap f (complete p),
+      direct0= fmap f (direct0 p),
+      direct1= fmap f (direct1 p)}
+   fmap f p@Parser{} = p{
+      complete= fmap f (complete p),
+      direct= fmap f (direct p),
+      direct0= fmap f (direct0 p),
+      direct1= fmap f (direct1 p),
+      indirect= fmap f (indirect p)}
+   {-# INLINABLE fmap #-}
 
-instance Functor (Parser g s) where
-   fmap _ Empty = Empty
-   fmap f ast = Map f ast
+instance Alternative (p g s) => Applicative (Fixed p g s) where
+   pure a = DirectParser{complete= pure a,
+                         direct0= pure a,
+                         direct1= empty}
+   p@PositiveDirectParser{} <*> q = PositiveDirectParser{
+      complete= complete p <*> complete q}
+   p@DirectParser{} <*> q@PositiveDirectParser{} = PositiveDirectParser{
+      complete= complete p <*> complete q}
+   p@DirectParser{} <*> q@DirectParser{} = DirectParser{
+      complete= complete p <*> complete q,
+      direct0= direct0 p <*> direct0 q,
+      direct1= direct0 p <*> direct1 q <|> direct1 p <*> complete q}
+   p <*> q@Parser{} = Parser{
+      complete= complete p' <*> complete q,
+      direct= direct0 p' <*> direct q <|> direct1 p' <*> complete q,
+      direct0= direct0 p' <*> direct0 q,
+      direct1= direct0 p' <*> direct1 q <|> direct1 p' <*> complete q,
+      indirect= direct0 p' <*> indirect q <|> indirect p' <*> complete q,
+      cyclicDescendants= \deps-> let
+           pcd@(ParserFlags pn pd) = cyclicDescendants p' deps
+           ParserFlags qn qd = cyclicDescendants q deps
+        in if pn
+           then ParserFlags qn (Rank2.liftA2 union pd qd)
+           else pcd}
+      where p'@Parser{} = general' p
+   p <*> q = Parser{
+      complete= complete p' <*> complete q',
+      direct= direct p' <*> complete q',
+      direct0= direct0 p' <*> direct0 q',
+      direct1= direct0 p' <*> direct1 q' <|> direct1 p' <*> complete q',
+      indirect= indirect p' <*> complete q',
+      cyclicDescendants= \deps-> let
+           pcd@(ParserFlags pn pd) = cyclicDescendants p' deps
+           ParserFlags qn qd = cyclicDescendants q' deps
+        in if pn
+           then ParserFlags qn (Rank2.liftA2 union pd qd)
+           else pcd}
+      where p'@Parser{} = general' p
+            q'@Parser{} = general' q
+   {-# INLINABLE pure #-}
+   {-# INLINABLE (<*>) #-}
 
-instance Applicative (Parser g s) where
-   pure = Pure
-   Empty <*> _ = Empty
-   _ <*> Empty = Empty
-   p <*> q = Ap p q
+instance Alternative (p g s) => Alternative (Fixed p g s) where
+   empty = PositiveDirectParser{complete= empty}
+   p@PositiveDirectParser{} <|> q@PositiveDirectParser{} = PositiveDirectParser{complete= complete p <|> complete q}
+   p@PositiveDirectParser{} <|> q@DirectParser{} = DirectParser{
+      complete= complete p <|> complete q,
+      direct0 = direct0 q,
+      direct1= complete p <|> direct1 q}
+   p@DirectParser{} <|> q@PositiveDirectParser{} = DirectParser{
+      complete= complete p <|> complete q,
+      direct0 = direct0 p,
+      direct1= direct1 p <|> complete q}
+   p@DirectParser{} <|> q@DirectParser{} = DirectParser{
+      complete= complete p <|> complete q,
+      direct0 = direct0 p <|> direct0 q,
+      direct1= direct1 p <|> direct1 q}
+   p <|> q = Parser{complete= complete p' <|> complete q',
+                    direct= direct p' <|> direct q',
+                    direct0= direct0 p' <|> direct0 q',
+                    direct1= direct1 p' <|> direct1 q',
+                    indirect= indirect p' <|> indirect q',
+                    cyclicDescendants= \deps-> let
+                         ParserFlags pn pd = cyclicDescendants p' deps
+                         ParserFlags qn qd = cyclicDescendants q' deps
+                      in ParserFlags (pn || qn) (Rank2.liftA2 union pd qd)}
+      where p'@Parser{} = general p
+            q'@Parser{} = general q
+   many (PositiveDirectParser p) = DirectParser{
+      complete= many p,
+      direct0= pure [],
+      direct1= some p}
+   many p@DirectParser{} = DirectParser{
+      complete= many (complete p),
+      direct0= pure [] <|> (:[]) <$> direct0 p,
+      direct1= (:) <$> direct1 p <*> many (complete p)}
+   many p@Parser{} = Parser{
+      complete= mcp,
+      direct= d0 <|> d1,
+      direct0= d0,
+      direct1= d1,
+      indirect= (:) <$> indirect p <*> mcp,
+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}
+      where d0 = pure [] <|> (:[]) <$> direct0 p
+            d1 = (:) <$> direct1 p <*> mcp
+            mcp = many (complete p)
+   some (PositiveDirectParser p) = PositiveDirectParser{complete= some p}
+   some p@DirectParser{} = DirectParser{
+      complete= some (complete p),
+      direct0= (:[]) <$> direct0 p,
+      direct1= (:) <$> direct1 p <*> many (complete p)}
+   some p@Parser{} = Parser{
+      complete= some (complete p),
+      direct= d0 <|> d1,
+      direct0= d0,
+      direct1= d1,
+      indirect= (:) <$> indirect p <*> many (complete p),
+      cyclicDescendants= cyclicDescendants p}
+      where d0 = (:[]) <$> direct0 p
+            d1= (:) <$> direct1 p <*> many (complete p)
+   {-# INLINABLE (<|>) #-}
+   {-# INLINABLE many #-}
+   {-# INLINABLE some #-}
 
-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
+infixl 3 <<|>
+(<<|>) :: Parser g s a -> Parser g s a -> Parser g s a
+p@DirectParser{} <<|> q@PositiveDirectParser{} = DirectParser{
+   complete= complete p Memoizing.<<|> complete q,
+   direct0 = direct0 p,
+   direct1= direct1 p Memoizing.<<|> complete q}
+p@DirectParser{} <<|> q@DirectParser{} = DirectParser{
+   complete= complete p Memoizing.<<|> complete q,
+   direct0 = direct0 p Memoizing.<<|> direct0 q,
+   direct1= direct1 p Memoizing.<<|> direct1 q}
+p <<|> q = Parser{complete= complete p' Memoizing.<<|> complete q',
+                 direct= direct p' Memoizing.<<|> direct q',
+                 direct0= direct0 p' Memoizing.<<|> direct0 q',
+                 direct1= direct1 p' Memoizing.<<|> direct1 q',
+                 indirect= indirect p' Memoizing.<<|> indirect q',
+                 cyclicDescendants= \deps-> let
+                         ParserFlags pn pd = cyclicDescendants p' deps
+                         ParserFlags qn qd = cyclicDescendants q' deps
+                      in ParserFlags (pn || qn) (Rank2.liftA2 union pd qd)}
+   where p'@Parser{} = general p
+         q'@Parser{} = general q
 
-instance Monad (Parser g s) where
+union :: Const Bool x -> Const Bool x -> Const Bool x
+union (Const False) d = d
+union (Const True) _ = Const True
+
+instance (Alternative (p g s), Monad (p g s)) => Monad (Fixed p g s) where
    return = pure
    (>>) = (*>)
-   Empty >>= _ = Empty
-   ast >>= cont = Bind ast cont
+   PositiveDirectParser p >>= cont = PositiveDirectParser (p >>= complete . cont)
+   p@DirectParser{} >>= cont = Parser{
+      complete= complete p >>= complete . cont,
+      direct= d0 <|> d1,
+      direct0= d0,
+      direct1= d1,
+      indirect= direct0 p >>= indirect . general' . cont,
+      cyclicDescendants= \cd-> (ParserFlags True $ Rank2.fmap (const $ Const True) cd)}
+      where d0 = direct0 p >>= direct0 . general' . cont
+            d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont)
+   p >>= cont = Parser{
+      complete= complete p >>= complete . cont,
+      direct= d0 <|> d1,
+      direct0= d0,
+      direct1= d1,
+      indirect= (indirect p >>= complete . cont) <|> (direct0 p >>= indirect . general' . cont),
+      cyclicDescendants= \cd-> (ParserFlags True $ Rank2.fmap (const $ Const True) cd)}
+      where d0 = direct0 p >>= direct0 . general' . cont
+            d1 = (direct0 p >>= direct1 . general' . cont) <|> (direct1 p >>= complete . cont)
 
-instance MonadPlus (Parser g s) where
+instance MonadPlus (p g s) => MonadPlus (Fixed p g s) where
    mzero = empty
    mplus = (<|>)
 
-instance Monoid x => Monoid (Parser g s x) where
+instance (Alternative (p g s), Monoid x) => Monoid (Fixed p 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 . (() <$)
+primitive :: String -> p g s a -> p g s a -> p g s a -> Fixed p g s a
+primitive _name d0 d1 d = DirectParser{complete= d,
+                                       direct0= d0,
+                                       direct1= d1}
 
-instance MonoidNull s => LookAheadParsing (Parser g s) where
-   lookAhead = Lookahead
+positivePrimitive :: String -> p g s a -> Fixed p g s a
+positivePrimitive _name p = PositiveDirectParser{complete= p}
 
-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 (LookAheadParsing (p g s), MonoidParsing (Fixed p g)) => Parsing (Fixed p g s) where
+   eof = primitive "eof" eof empty eof
+   try (PositiveDirectParser p) = PositiveDirectParser (try p)
+   try p@DirectParser{} = DirectParser{
+      complete= try (complete p),
+      direct0= try (direct0 p),
+      direct1= try (direct1 p)}
+   try p@Parser{} = p{
+      complete= try (complete p),
+      direct= try (direct p),
+      direct0= try (direct0 p),
+      direct1= try (direct1 p),
+      indirect= try (indirect p)}
+   PositiveDirectParser p <?> msg = PositiveDirectParser (p <?> msg)
+   p@DirectParser{} <?> msg = DirectParser{
+      complete= complete p <?> msg,
+      direct0= direct0 p <?> msg,
+      direct1= direct1 p <?> msg}
+   p@Parser{} <?> msg = p{
+      complete= complete p <?> msg,
+      direct= direct p <?> msg,
+      direct0= direct0 p <?> msg,
+      direct1= direct1 p <?> msg,
+      indirect= indirect p <?> msg}
+   notFollowedBy p@PositiveDirectParser{} = DirectParser{
+      complete= notFollowedBy (complete p),
+      direct0= notFollowedBy (complete p),
+      direct1= empty}
+   notFollowedBy p@DirectParser{} = DirectParser{
+      complete= notFollowedBy (complete p),
+      direct0= notFollowedBy (complete p),
+      direct1= empty}
+   notFollowedBy p@Parser{} = Parser{
+      complete= notFollowedBy (complete p),
+      direct= notFollowedBy (direct p),
+      direct0= notFollowedBy (direct p),
+      direct1= empty,
+      indirect= notFollowedBy (indirect p),
+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}
+   unexpected msg = positivePrimitive "unexpected" (unexpected msg)
+   skipMany p = concatMany (() <$ p)
 
-instance (Show s, TextualMonoid s) => TokenParsing (Parser g s) where
-   someSpace = () <$ takeCharsWhile1 isSpace
+instance (LookAheadParsing (p g s), MonoidParsing (Fixed p g)) => LookAheadParsing (Fixed p g s) where
+   lookAhead p@PositiveDirectParser{} = DirectParser{
+      complete= lookAhead (complete p),
+      direct0= lookAhead (complete p),
+      direct1= empty}
+   lookAhead p@DirectParser{} = DirectParser{
+      complete= lookAhead (complete p),
+      direct0= lookAhead (complete p),
+      direct1= empty}
+   lookAhead p@Parser{} = Parser{
+      complete= lookAhead (complete p),
+      direct= lookAhead (direct p),
+      direct0= lookAhead (direct p),
+      direct1= empty,
+      indirect= lookAhead (indirect p),
+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}
 
-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
+instance MonoidParsing (Fixed Memoizing.Parser g) where
+   endOfInput = primitive "endOfInput" endOfInput empty endOfInput
+   getInput = primitive "getInput" (endOfInput *> getInput) (notFollowedBy endOfInput *> getInput) getInput
+   anyToken = positivePrimitive "anyToken" anyToken
+   token x = positivePrimitive "token" (token x)
+   satisfy predicate = positivePrimitive "satisfy" (satisfy predicate)
+   satisfyChar predicate = positivePrimitive "satisfyChar" (satisfyChar predicate)
+   satisfyCharInput predicate = positivePrimitive "satisfyCharInput" (satisfyCharInput predicate)
+   notSatisfy predicate = primitive "notSatisfy" (notSatisfy predicate) empty (notSatisfy predicate)
+   notSatisfyChar predicate = primitive "notSatisfyChar" (notSatisfyChar predicate) empty (notSatisfyChar predicate)
+   scan s0 f = primitive "scan" (mempty <$ notSatisfy test) (lookAhead (satisfy test) *> p) p
       where p = scan s0 f
-            p1 = satisfy (isJust . f s0)
-   scanChars s0 f = Primitive "scanChars" (Just $ mempty <$ notFollowedBy p1) (Just $ lookAhead p1 *> p) p
+            test = isJust . f s0
+   scanChars s0 f = primitive "scanChars" (mempty <$ notSatisfyChar test) (lookAhead (satisfyChar test) *> p) p
       where p = scanChars s0 f
-            p1 = satisfyChar (isJust . f s0)
+            test = 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"
+      | null s = primitive ("(string " ++ shows s ")") (string s) empty (string s)
+      | otherwise = positivePrimitive ("(string " ++ shows s ")") (string s)
+   takeWhile predicate = primitive "takeWhile" (mempty <$ notSatisfy predicate)
+                                               (takeWhile1 predicate) (takeWhile predicate)
+   takeWhile1 predicate = positivePrimitive "takeWhile1" (takeWhile1 predicate)
+   takeCharsWhile predicate = primitive "takeCharsWhile" (mempty <$ notSatisfyChar predicate)
+                                                         (takeCharsWhile1 predicate) (takeCharsWhile predicate)
+   takeCharsWhile1 predicate = positivePrimitive "takeCharsWhile1" (takeCharsWhile1 predicate)
+   whiteSpace = primitive "whiteSpace" (notSatisfyChar isSpace) (satisfyChar isSpace *> whiteSpace) whiteSpace
+   concatMany p@PositiveDirectParser{} = DirectParser{
+      complete= cmp,
+      direct0= d0,
+      direct1= d1}
+      where d0 = pure mempty
+            d1 = (<>) <$> complete p <*> cmp
+            cmp = concatMany (complete p)
+   concatMany p@DirectParser{} = DirectParser{
+      complete= cmp,
+      direct0= d0,
+      direct1= d1}
+      where d0 = pure mempty <|> direct0 p
+            d1 = (<>) <$> direct1 p <*> cmp
+            cmp = concatMany (complete p)
+   concatMany p@Parser{} = Parser{
+      complete= cmp,
+      direct= d0 <|> d1,
+      direct0= d0,
+      direct1= d1,
+      indirect= (<>) <$> indirect p <*> cmp,
+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}
+      where d0 = pure mempty <|> direct0 p
+            d1 = (<>) <$> direct1 p <*> cmp
+            cmp = concatMany (complete p)
+   {-# INLINABLE string #-}
 
-both :: (a -> b) -> (a, a) -> (b, b)
-both f (x, y) = (f x, f y)
+instance MonoidParsing (Fixed Backtrack.Parser g) where
+   endOfInput = primitive "endOfInput" endOfInput empty endOfInput
+   getInput = primitive "getInput" (endOfInput *> getInput) (notFollowedBy endOfInput *> getInput) getInput
+   anyToken = positivePrimitive "anyToken" anyToken
+   token x = positivePrimitive "token" (token x)
+   satisfy predicate = positivePrimitive "satisfy" (satisfy predicate)
+   satisfyChar predicate = positivePrimitive "satisfyChar" (satisfyChar predicate)
+   satisfyCharInput predicate = positivePrimitive "satisfyCharInput" (satisfyCharInput predicate)
+   notSatisfy predicate = primitive "notSatisfy" (notSatisfy predicate) empty (notSatisfy predicate)
+   notSatisfyChar predicate = primitive "notSatisfyChar" (notSatisfyChar predicate) empty (notSatisfyChar predicate)
+   scan s0 f = primitive "scan" (mempty <$ notSatisfy test) (lookAhead (satisfy test) *> p) p
+      where p = scan s0 f
+            test = isJust . f s0
+   scanChars s0 f = primitive "scanChars" (mempty <$ notSatisfyChar test) (lookAhead (satisfyChar test) *> p) p
+      where p = scanChars s0 f
+            test = isJust . f s0
+   string s
+      | null s = primitive ("(string " ++ shows s ")") (string s) empty (string s)
+      | otherwise = positivePrimitive ("(string " ++ shows s ")") (string s)
+   takeWhile predicate = primitive "takeWhile" (mempty <$ notSatisfy predicate)
+                                               (takeWhile1 predicate) (takeWhile predicate)
+   takeWhile1 predicate = positivePrimitive "takeWhile1" (takeWhile1 predicate)
+   takeCharsWhile predicate = primitive "takeCharsWhile" (mempty <$ notSatisfyChar predicate)
+                                                         (takeCharsWhile1 predicate) (takeCharsWhile predicate)
+   takeCharsWhile1 predicate = positivePrimitive "takeCharsWhile1" (takeCharsWhile1 predicate)
+   whiteSpace = primitive "whiteSpace" (notSatisfyChar isSpace) (satisfyChar isSpace *> whiteSpace) whiteSpace
+   concatMany p@PositiveDirectParser{} = DirectParser{
+      complete= cmp,
+      direct0= d0,
+      direct1= d1}
+      where d0 = pure mempty
+            d1 = (<>) <$> complete p <*> cmp
+            cmp = concatMany (complete p)
+   concatMany p@DirectParser{} = DirectParser{
+      complete= cmp,
+      direct0= d0,
+      direct1= d1}
+      where d0 = pure mempty `Backtrack.alt` direct0 p
+            d1 = (<>) <$> direct1 p <*> cmp
+            cmp = concatMany (complete p)
+   concatMany p@Parser{} = Parser{
+      complete= cmp,
+      direct= d0 `Backtrack.alt` d1,
+      direct0= d0,
+      direct1= d1,
+      indirect= (<>) <$> indirect p <*> cmp,
+      cyclicDescendants= \deps-> (cyclicDescendants p deps){nullable= True}}
+      where d0 = pure mempty `Backtrack.alt` direct0 p
+            d1 = (<>) <$> direct1 p <*> cmp
+            cmp = concatMany (complete p)
+   {-# INLINABLE string #-}
 
-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
+instance (LookAheadParsing (p g s), MonoidParsing (Fixed p g), Show s, TextualMonoid s) =>
+         CharParsing (Fixed p g s) where
+   satisfy = satisfyChar
+   string s = Textual.toString (error "unexpected non-character") <$> string (fromString s)
+   char = satisfyChar . (==)
+   notChar = satisfyChar . (/=)
+   anyChar = satisfyChar (const True)
+   text t = (fromString . Textual.toString (error "unexpected non-character")) <$> string (Textual.fromText t)
 
-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
+instance (LookAheadParsing (p g s), TokenParsing (p g s), MonoidParsing (Fixed p g), Show s, TextualMonoid s) => 
+         TokenParsing (Fixed p g s) where
+   someSpace = positivePrimitive "someSpace" someSpace
 
-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)
+-- | Turns a context-free parser into a backtracking PEG parser that consumes the longest possible prefix of the list
+-- of input tails, opposite of 'peg'
+longest :: FactorialMonoid s => Fixed Memoizing.Parser g s a -> Fixed Backtrack.Parser g [(s, g (ResultList g s))] a
+longest (PositiveDirectParser p) = PositiveDirectParser (Memoizing.longest p)
+longest p@DirectParser{} = DirectParser{complete= Memoizing.longest (complete p),
+                                        direct0=  Memoizing.longest (direct0 p),
+                                        direct1=  Memoizing.longest (direct1 p)}
+longest p@Parser{} = Parser{complete= Memoizing.longest (complete p),
+                            direct=  Memoizing.longest (direct p),
+                            direct0=  Memoizing.longest (direct0 p),
+                            direct1=  Memoizing.longest (direct1 p),
+                            indirect=  Memoizing.longest (indirect p),
+                            cyclicDescendants= cyclicDescendants p}
 
-orderedSelfReferring :: (Rank2.Distributive g, Rank2.Traversable g) => g (Parser g s)
-orderedSelfReferring = ordered (Rank2.distributeWith NonTerminal id)
+-- | Turns a backtracking PEG parser of the list of input tails into a context-free parser, opposite of 'longest'
+peg :: Fixed Backtrack.Parser g [(s, g (ResultList g s))] a -> Fixed Memoizing.Parser g s a
+peg (PositiveDirectParser p) = PositiveDirectParser (Memoizing.peg p)
+peg p@DirectParser{} = DirectParser{complete= Memoizing.peg (complete p),
+                                        direct0=  Memoizing.peg (direct0 p),
+                                        direct1=  Memoizing.peg (direct1 p)}
+peg p@Parser{} = Parser{complete= Memoizing.peg (complete p),
+                        direct=  Memoizing.peg (direct p),
+                        direct0=  Memoizing.peg (direct0 p),
+                        direct1=  Memoizing.peg (direct1 p),
+                        indirect=  Memoizing.peg (indirect p),
+                        cyclicDescendants= cyclicDescendants p}
 
-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)}
+-- | Turns a backtracking PEG parser into a context-free parser
+terminalPEG :: Monoid s => Fixed Backtrack.Parser g s a -> Fixed Memoizing.Parser g s a
+terminalPEG (PositiveDirectParser p) = PositiveDirectParser (Memoizing.terminalPEG p)
+terminalPEG p@DirectParser{} = DirectParser{complete= Memoizing.terminalPEG (complete p),
+                                            direct0=  Memoizing.terminalPEG (direct0 p),
+                                            direct1=  Memoizing.terminalPEG (direct1 p)}
+terminalPEG p@Parser{} = Parser{complete= Memoizing.terminalPEG (complete p),
+                                direct=  Memoizing.terminalPEG (direct p),
+                                direct0=  Memoizing.terminalPEG (direct0 p),
+                                direct1=  Memoizing.terminalPEG (direct1 p),
+                                indirect=  Memoizing.terminalPEG (indirect p),
+                                cyclicDescendants= cyclicDescendants p}
 
-data AdvanceFront = AdvanceFront{visited       :: IntSet,
-                                 cyclic        :: Bool,
-                                 front         :: IntSet}
-                  deriving Show
+parseRecursive :: forall g s. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g, FactorialMonoid s) =>
+                  g (Parser g s) -> s -> [(s, g (ResultList g s))]
+parseRecursive = parseSeparated . separated
 
-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}
+separated :: forall g s. (Rank2.Apply g, Rank2.Distributive g, Rank2.Traversable g) =>
+             g (Parser g s) -> g (SeparatedParser Memoizing.Parser g s)
+separated g = Rank2.liftA4 reseparate circulars cycleFollowers descendants g
+   where descendants :: g (Const (g (Const Bool)))
+         cycleFollowers, circulars :: g (Const Bool)
+         cyclicDescendantses :: g (Const (ParserFlags g))
+         leftRecursive :: forall a. Const (g (Const Bool)) a -> Const (ParserFlags g) a -> Const Bool a
+         leftRecursiveDeps :: forall a. Const Bool a -> Const (ParserFlags g) a -> Const (g (Const Bool)) a
+         reseparate :: forall a. Const Bool a -> Const Bool a -> Const (g (Const Bool)) a -> Parser g s a
+                    -> SeparatedParser Memoizing.Parser g s a
+         reseparate (Const circular) (Const follower) (Const deps) p
+            | circular || leader && follower = CycleParser (indirect p) (direct p) deps
+            | follower = BackParser (complete p)
+            | otherwise = FrontParser (complete p)
+            where leader = getAny (Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection circulars deps)
+         descendants = Rank2.fmap (Const . dependsOn . getConst) cyclicDescendantses
+         cyclicDescendantses = fixDescendants (Rank2.fmap (Const . cyclicDescendants . general) g)
+         circulars = Rank2.liftA2 leftRecursive bits cyclicDescendantses
+         cycleFollowers = getUnion (Rank2.foldMap (Union . getConst) $
+                                    Rank2.liftA2 leftRecursiveDeps circulars cyclicDescendantses)
+         leftRecursive (Const bit) (Const flags) =
+            Const (getAny $ Rank2.foldMap (Any . getConst) $ Rank2.liftA2 intersection bit $ dependsOn flags)
+         leftRecursiveDeps (Const True) (Const flags) = Const (dependsOn flags)
+         leftRecursiveDeps (Const False) (Const flags) = Const (Rank2.fmap (const $ Const False) (dependsOn flags))
+         intersection (Const a) (Const b) = Const (a && b)
 
-newtype Couple f a = Couple{unCouple :: (f a, f a)} deriving Show
+fixDescendants :: forall g. (Rank2.Apply g, Rank2.Traversable g)
+                     => g (Const (g (Const (ParserFlags g)) -> (ParserFlags g))) -> g (Const (ParserFlags g))
+fixDescendants gf = go initial
+   where go :: g (Const (ParserFlags g)) -> g (Const (ParserFlags g))
+         go cd
+            | getAll (Rank2.foldMap (All . getConst) $ Rank2.liftA2 agree cd cd') = cd
+            | otherwise = go cd'
+            where cd' = Rank2.liftA2 depsUnion cd (Rank2.fmap (\(Const f)-> Const (f cd)) gf)
+         agree (Const (ParserFlags _xn xd)) (Const (ParserFlags _yn yd)) =
+            Const (getAll (Rank2.foldMap (All . getConst) (Rank2.liftA2 agree' xd yd)))
+         agree' (Const x) (Const y) = Const (x == y)
+         depsUnion (Const ParserFlags{dependsOn= old}) (Const (ParserFlags n new)) = 
+            Const (ParserFlags n $ Rank2.liftA2 union old new)
+         initial = Rank2.liftA2 (\_ (Const n)-> Const (ParserFlags n (const (Const False) Rank2.<$> gf))) gf nullabilities
+         nullabilities = fixNullabilities gf
 
-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)
+fixNullabilities :: forall g. (Rank2.Apply g, Rank2.Traversable g)
+                    => g (Const (g (Const (ParserFlags g)) -> (ParserFlags g))) -> g (Const Bool)
+fixNullabilities gf = Rank2.fmap (Const . nullable . getConst) (go initial)
+   where go :: g (Const (ParserFlags g)) -> g (Const (ParserFlags g))
+         go cd
+            | getAll (Rank2.foldMap (All . getConst) $ Rank2.liftA2 agree cd cd') = cd
+            | otherwise = go cd'
+            where cd' = Rank2.fmap (\(Const f)-> Const (f cd)) gf
+         agree (Const flags1) (Const flags2) = Const (nullable flags1 == nullable flags2)
+         initial = const (Const (ParserFlags True (const (Const False) Rank2.<$> gf))) Rank2.<$> gf
 
 -- | 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)
+                  g (SeparatedParser Memoizing.Parser g s) -> s -> [(s, g (ResultList g s))]
+parseSeparated parsers input = foldr parseTail [] (Factorial.tails input)
    where parseTail s parsedTail = parsed
-            where parsed = (s,d'):parsedTail
-                  d      = Rank2.fmap (($ (s,d):parsedTail) . Memoizing.applyParser) direct
+            where parsed = (s,d''):parsedTail
+                  d      = Rank2.fmap (($ (s,d):parsedTail) . Memoizing.applyParser) directs
                   d'     = fixRecursive s parsedTail d
-
+                  d''    = Rank2.liftA2 f parsers d'
+                  f :: forall a. SeparatedParser Memoizing.Parser g s a -> ResultList g s a -> ResultList g s a
+                  f (FrontParser p) _ = Memoizing.applyParser p ((s,d''):parsedTail)
+                  f _ result = result
          fixRecursive :: s -> [(s, g (ResultList g s))] -> g (ResultList g s) -> g (ResultList g s)
          whileAnyContinues :: g (ResultList g s) -> g (ResultList g s) -> g (ResultList g s)
          recurseOnce :: s -> [(s, g (ResultList g s))] -> g (ResultList g s) -> g (ResultList g s)
+         maybeDependencies :: g (Const (Maybe (g (Const Bool))))
 
+         directs = Rank2.fmap backParser parsers
+         indirects = Rank2.fmap (\p-> case p of {CycleParser{}-> cycleParser p; _ -> empty}) parsers
+         maybeDependencies = Rank2.fmap (Const . maybeDependency) parsers
+         maybeDependency p@CycleParser{} = Just (dependencies p)
+         maybeDependency _ = Nothing
+                                                                   
          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
+         whileAnyContinues g1 g2 = Rank2.liftA3 choiceWhile maybeDependencies g1 g2
+            where choiceWhile :: Const (Maybe (g (Const Bool))) x -> ResultList g i x -> ResultList g i x 
+                                 -> ResultList g i x
                   combine :: Const Bool x -> ResultList g i x -> Const Bool x
-                  choiceWhile (Const deps) r1 r2
+                  choiceWhile (Const Nothing) r1 _ = r1
+                  choiceWhile (Const (Just 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) (ResultList EmptyTree _) = Const False
                   combine (Const True) _ = Const True
 
-         recurseOnce s parsedTail initial = Rank2.fmap (($ parsed) . Memoizing.applyParser) indirect
+         recurseOnce s parsedTail initial = Rank2.fmap (($ parsed) . Memoizing.applyParser) indirects
             where parsed = (s, initial):parsedTail
diff --git a/src/Text/Grampa/ContextFree/Memoizing.hs b/src/Text/Grampa/ContextFree/Memoizing.hs
--- a/src/Text/Grampa/ContextFree/Memoizing.hs
+++ b/src/Text/Grampa/ContextFree/Memoizing.hs
@@ -1,14 +1,17 @@
 {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, InstanceSigs,
              RankNTypes, ScopedTypeVariables, TypeFamilies #-}
-module Text.Grampa.ContextFree.Memoizing (FailureInfo(..), ResultList(..), Parser(..), fromResultList, reparseTails)
+module Text.Grampa.ContextFree.Memoizing (FailureInfo(..), ResultList(..), Parser(..), BinTree(..), (<<|>),
+                                          fromResultList, reparseTails, longest, peg, terminalPEG)
 where
 
 import Control.Applicative
 import Control.Monad (Monad(..), MonadPlus(..))
 import Data.Char (isSpace)
+import Data.Function (on)
+import Data.Foldable (toList)
 import Data.Functor.Classes (Show1(..))
 import Data.Functor.Compose (Compose(..))
-import Data.List (genericLength, nub)
+import Data.List (genericLength, maximumBy, nub)
 import Data.Monoid (Monoid(mappend, mempty), (<>))
 import Data.Monoid.Cancellative (LeftReductiveMonoid (isPrefixOf))
 import Data.Monoid.Null (MonoidNull(null))
@@ -17,7 +20,6 @@
 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)
@@ -28,69 +30,74 @@
 import qualified Rank2
 
 import Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))
+import Text.Grampa.Internal (BinTree(..), FailureInfo(..))
+import qualified Text.Grampa.PEG.Backtrack.Length as Backtrack
 
 import Prelude hiding (iterate, length, null, showList, span, takeWhile)
 
 -- | Parser for a context-free grammar with packrat-like sharing of parse results. It does not support left-recursive
 -- grammars.
 newtype Parser g s r = Parser{applyParser :: [(s, g (ResultList g s))] -> ResultList g s r}
-            
-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)
 
+data ResultList g s r = ResultList !(BinTree (ResultInfo g s r)) {-# UNPACK #-} !FailureInfo
+data ResultInfo g s r = ResultInfo !Int ![(s, g (ResultList g s))] !r
+
 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
+   liftShowsPrec _sp showList _prec (ResultList l f) rest = "ResultList " ++ showList (simplify <$> toList 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 ")"
+   show (ResultInfo l _ r) = "(ResultInfo @" ++ show l ++ " " ++ shows r ")"
 
 instance Functor (ResultInfo g s) where
-   fmap f (ResultInfo t r) = ResultInfo t (f r)
+   fmap f (ResultInfo l t r) = ResultInfo l 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
+   mempty = ResultList mempty 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)
+   {-# INLINABLE fmap #-}
 
 instance Applicative (Parser g i) where
-   pure a = Parser (\rest-> ResultList [ResultInfo rest a] mempty)
+   pure a = Parser (\rest-> ResultList (Leaf $ ResultInfo 0 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'
-
+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results
+      continue (ResultInfo l rest' f) = continue' l f (q rest')
+      continue' l f (ResultList rs failure) = ResultList (adjust l f <$> rs) failure
+      adjust l f (ResultInfo l' rest' a) = ResultInfo (l+l') rest' (f a)
+   {-# INLINABLE pure #-}
+   {-# INLINABLE (<*>) #-}
 
 instance Alternative (Parser g i) where
-   empty = Parser (\rest-> ResultList [] $ FailureInfo 0 (genericLength rest) ["empty"])
+   empty = Parser (\rest-> ResultList mempty $ FailureInfo 0 (genericLength rest) ["empty"])
    Parser p <|> Parser q = Parser r where
       r rest = p rest <> q rest
+   {-# INLINABLE (<|>) #-}
 
+infixl 3 <<|>
+(<<|>) :: Parser g s a -> Parser g s a -> Parser g s a
+Parser p <<|> Parser q = Parser r where
+   r rest = case p rest
+            of rl@(ResultList EmptyTree _failure) -> rl <> q rest
+               rl -> rl
+
 instance Monad (Parser g i) where
    return = pure
    Parser p >>= f = Parser q where
       q rest = case p rest
-               of ResultList results failure -> ResultList [] failure <> foldMap continue results
-      continue (ResultInfo rest' a) = applyParser (f a) rest'
+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results
+      continue (ResultInfo l rest' a) = continue' l (applyParser (f a) rest')
+      continue' l (ResultList rs failure) = ResultList (adjust l <$> rs) failure
+      adjust l (ResultInfo l' rest' a) = ResultInfo (l+l') rest' a
 
 instance MonadPlus (Parser g s) where
    mzero = empty
@@ -104,9 +111,11 @@
    type GrammarFunctor Parser = ResultList
    nonTerminal f = Parser p where
       p ((_, d) : _) = f d
-      p _ = ResultList [] (FailureInfo 1 0 ["NonTerminal at endOfInput"])
+      p _ = ResultList mempty (FailureInfo 1 0 ["NonTerminal at endOfInput"])
+   {-# INLINE nonTerminal #-}
 
--- | Memoizing parser guarantees O(n²) performance, but provides no left recursion support.
+-- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions, but provides no left
+-- recursion support.
 --
 -- @
 -- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>
@@ -136,60 +145,80 @@
 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
+      where p rest@((s, _):_) = ResultList (Leaf $ ResultInfo (length rest) [last rest] s) mempty
+            p [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty
    anyToken = Parser p
       where p rest@((s, _):t) = case splitPrimePrefix s
-                                of Just (first, _) -> ResultList [ResultInfo t first] mempty
-                                   _ -> ResultList [] (FailureInfo 1 (genericLength rest) ["anyToken"])
-            p [] = ResultList [] (FailureInfo 1 0 ["anyToken"])
+                                of Just (first, _) -> ResultList (Leaf $ ResultInfo 1 t first) mempty
+                                   _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["anyToken"])
+            p [] = ResultList mempty (FailureInfo 1 0 ["anyToken"])
    satisfy predicate = Parser p
       where p rest@((s, _):t) =
                case splitPrimePrefix s
-               of Just (first, _) | predicate first -> ResultList [ResultInfo t first] mempty
-                  _ -> ResultList [] (FailureInfo 1 (genericLength rest) ["satisfy"])
-            p [] = ResultList [] (FailureInfo 1 0 ["satisfy"])
+               of Just (first, _) | predicate first -> ResultList (Leaf $ ResultInfo 1 t first) mempty
+                  _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfy"])
+            p [] = ResultList mempty (FailureInfo 1 0 ["satisfy"])
    satisfyChar predicate = Parser p
       where p rest@((s, _):t) =
-               case Textual.splitCharacterPrefix s
-               of Just (first, _) | predicate first -> ResultList [ResultInfo t first] mempty
-                  _ -> ResultList [] (FailureInfo 1 (genericLength rest) ["satisfyChar"])
-            p [] = ResultList [] (FailureInfo 1 0 ["satisfyChar"])
+               case Textual.characterPrefix s
+               of Just first | predicate first -> ResultList (Leaf $ ResultInfo 1 t first) mempty
+                  _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfyChar"])
+            p [] = ResultList mempty (FailureInfo 1 0 ["satisfyChar"])
+   satisfyCharInput predicate = Parser p
+      where p rest@((s, _):t) =
+               case Textual.characterPrefix s
+               of Just first | predicate first -> ResultList (Leaf $ ResultInfo 1 t $ Factorial.primePrefix s) mempty
+                  _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfyCharInput"])
+            p [] = ResultList mempty (FailureInfo 1 0 ["satisfyCharInput"])
    scan s0 f = Parser (p s0)
-      where p s rest@((i, _) : _) = ResultList [ResultInfo (drop (Factorial.length prefix) rest) prefix] mempty
+      where p s rest@((i, _) : _) = ResultList (Leaf $ ResultInfo l (drop l rest) prefix) mempty
                where (prefix, _, _) = Factorial.spanMaybe' s f i
-            p _ [] = ResultList [ResultInfo [] mempty] mempty
+                     l = Factorial.length prefix
+            p _ [] = ResultList (Leaf $ ResultInfo 0 [] mempty) mempty
    scanChars s0 f = Parser (p s0)
-      where p s rest@((i, _) : _) = ResultList [ResultInfo (drop (Factorial.length prefix) rest) prefix] mempty
+      where p s rest@((i, _) : _) = ResultList (Leaf $ ResultInfo l (drop l rest) prefix) mempty
                where (prefix, _, _) = Textual.spanMaybe_' s f i
-            p _ [] = ResultList [ResultInfo [] mempty] mempty
+                     l = Factorial.length prefix
+            p _ [] = ResultList (Leaf $ ResultInfo 0 [] 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
+               | x <- Factorial.takeWhile predicate s, l <- Factorial.length x =
+                    ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty
+            p [] = ResultList (Leaf $ ResultInfo 0 [] 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"])
+               | x <- Factorial.takeWhile predicate s, l <- Factorial.length x, l > 0 =
+                    ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty
+            p rest = ResultList mempty (FailureInfo 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
+               | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x =
+                    ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty
+            p [] = ResultList (Leaf $ ResultInfo 0 [] 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"])
+               | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x, l > 0 =
+                    ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty
+            p rest = ResultList mempty (FailureInfo 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])
+         | s `isPrefixOf` s' = ResultList (Leaf $ ResultInfo l (Factorial.drop l rest) s) mempty
+      p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["string " ++ show s])
+      l = Factorial.length s
    whiteSpace = () <$ takeCharsWhile isSpace
    concatMany p = go
       where go = mempty <|> (<>) <$> p <*> go
+   notSatisfy predicate = Parser p
+      where p rest@((s, _):_)
+               | Just (first, _) <- splitPrimePrefix s, 
+                 predicate first = ResultList mempty (FailureInfo 1 (genericLength rest) ["notSatisfy"])
+            p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty
+   notSatisfyChar predicate = Parser p
+      where p rest@((s, _):_)
+               | Just first <- Textual.characterPrefix s, 
+                 predicate first = ResultList mempty (FailureInfo 1 (genericLength rest) ["notSatisfyChar"])
+            p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty
+   {-# INLINABLE string #-}
 
 instance MonoidNull s => Parsing (Parser g s) where
    try (Parser p) = Parser (weakenResults . p)
@@ -197,21 +226,21 @@
    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"])
+      where rewind t (ResultList EmptyTree _) = ResultList (Leaf $ ResultInfo 0 t ()) mempty
+            rewind t ResultList{} = ResultList mempty (FailureInfo 1 (genericLength t) ["notFollowedBy"])
    skipMany p = go
       where go = pure () <|> p *> go
-   unexpected msg = Parser (\t-> ResultList [] $ FailureInfo 0 (genericLength t) [msg])
+   unexpected msg = Parser (\t-> ResultList mempty $ 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
+               | null s = ResultList (Leaf $ ResultInfo 0 rest ()) mempty
+               | otherwise = ResultList mempty (FailureInfo 1 (genericLength rest) ["endOfInput"])
+            f [] = ResultList (Leaf $ ResultInfo 0 [] ()) 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
+            rewindInput t (ResultInfo _ _ r) = ResultInfo 0 t r
 
 instance (Show s, TextualMonoid s) => CharParsing (Parser g s) where
    satisfy = satisfyChar
@@ -225,8 +254,35 @@
    someSpace = () <$ takeCharsWhile1 isSpace
 
 fromResultList :: FactorialMonoid s => s -> ResultList g s r -> ParseResults [(s, r)]
-fromResultList s (ResultList [] (FailureInfo _ pos msgs)) =
+fromResultList s (ResultList EmptyTree (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)
+fromResultList _ (ResultList rl _failure) = Right (f <$> toList rl)
+   where f (ResultInfo _ ((s, _):_) r) = (s, r)
+         f (ResultInfo _ [] r) = (mempty, r)
+
+-- | Turns a context-free parser into a backtracking PEG parser that consumes the longest possible prefix of the list
+-- of input tails, opposite of 'peg'
+longest :: FactorialMonoid s => Parser g s a -> Backtrack.Parser g [(s, g (ResultList g s))] a
+longest p = Backtrack.Parser q where
+   q rest = case applyParser p rest
+            of ResultList EmptyTree failure -> Backtrack.NoParse failure
+               ResultList rs _ -> parsed (maximumBy (compare `on` resultLength) rs)
+   resultLength (ResultInfo l _ _) = l
+   parsed (ResultInfo l s r) = Backtrack.Parsed l r s
+
+-- | Turns a backtracking PEG parser of the list of input tails into a context-free parser, opposite of 'longest'
+peg :: Backtrack.Parser g [(s, g (ResultList g s))] a -> Parser g s a
+peg p = Parser q where
+   q rest = case Backtrack.applyParser p rest
+            of Backtrack.Parsed l result suffix -> ResultList (Leaf $ ResultInfo l suffix result) mempty
+               Backtrack.NoParse failure -> ResultList mempty failure
+
+-- | Turns a backtracking PEG parser into a context-free parser
+terminalPEG :: Monoid s => Backtrack.Parser g s a -> Parser g s a
+terminalPEG p = Parser q where
+   q [] = case Backtrack.applyParser p mempty
+            of Backtrack.Parsed l result _ -> ResultList (Leaf $ ResultInfo l [] result) mempty
+               Backtrack.NoParse failure -> ResultList mempty failure
+   q rest@((s, _):_) = case Backtrack.applyParser p s
+                       of Backtrack.Parsed l result _ -> ResultList (Leaf $ ResultInfo l (drop l rest) result) mempty
+                          Backtrack.NoParse failure -> ResultList mempty failure
diff --git a/src/Text/Grampa/ContextFree/Parallel.hs b/src/Text/Grampa/ContextFree/Parallel.hs
--- a/src/Text/Grampa/ContextFree/Parallel.hs
+++ b/src/Text/Grampa/ContextFree/Parallel.hs
@@ -6,6 +6,7 @@
 import Control.Applicative
 import Control.Monad (Monad(..), MonadPlus(..))
 import Data.Char (isSpace)
+import Data.Foldable (toList)
 import Data.Functor.Classes (Show1(..))
 import Data.Functor.Compose (Compose(..))
 import Data.List (nub)
@@ -27,7 +28,8 @@
 
 import qualified Rank2
 
-import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..), completeParser)
+import Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))
+import Text.Grampa.Internal (BinTree(..))
 
 import Prelude hiding (iterate, null, showList, span, takeWhile)
 
@@ -35,7 +37,7 @@
 -- support.
 newtype Parser (g :: (* -> *) -> *) s r = Parser{applyParser :: s -> ResultList s r}
 
-data ResultList s r = ResultList ![ResultInfo s r] {-# UNPACK #-} !FailureInfo
+data ResultList s r = ResultList !(BinTree (ResultInfo s r)) {-# UNPACK #-} !FailureInfo
 data ResultInfo s r = ResultInfo !s !r
 data FailureInfo = FailureInfo !Int Int [String] deriving (Eq, Show)
 
@@ -43,7 +45,7 @@
    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)
+   liftShowsPrec _sp showList _prec (ResultList l f) rest = "ResultList " ++ showList (simplify <$> toList l) (shows f rest)
       where simplify (ResultInfo _ r) = r
 
 instance (Show s, Show r) => Show (ResultInfo s r) where
@@ -56,7 +58,7 @@
    fmap f (ResultList l failure) = ResultList ((f <$>) <$> l) failure
 
 instance Monoid (ResultList s r) where
-   mempty = ResultList [] mempty
+   mempty = ResultList mempty mempty
    ResultList rl1 f1 `mappend` ResultList rl2 f2 = ResultList (rl1 <> rl2) (f1 <> f2)
 
 instance Monoid FailureInfo where
@@ -73,15 +75,15 @@
    fmap f (Parser p) = Parser (fmap f . p)
 
 instance Applicative (Parser g s) where
-   pure a = Parser (\rest-> ResultList [ResultInfo rest a] mempty)
+   pure a = Parser (\rest-> ResultList (Leaf $ 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
+               of ResultList results failure -> ResultList mempty 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"])
+   empty = Parser (\s-> ResultList mempty $ FailureInfo 0 (Factorial.length s) ["empty"])
    Parser p <|> Parser q = Parser r where
       r rest = p rest <> q rest
 
@@ -89,7 +91,7 @@
    return = pure
    Parser p >>= f = Parser q where
       q rest = case p rest
-               of ResultList results failure -> ResultList [] failure <> foldMap continue results
+               of ResultList results failure -> ResultList mempty failure <> foldMap continue results
       continue (ResultInfo rest' a) = applyParser (f a) rest'
 
 instance FactorialMonoid s => MonadPlus (Parser g s) where
@@ -117,49 +119,65 @@
 
 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"])
+      where f s | null s = ResultList (Leaf $ ResultInfo s ()) mempty
+                | otherwise = ResultList mempty (FailureInfo 1 (Factorial.length s) ["endOfInput"])
    getInput = Parser p
-      where p s = ResultList [ResultInfo mempty s] mempty
+      where p s = ResultList (Leaf $ 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"])
+                  of Just (first, rest) -> ResultList (Leaf $ ResultInfo rest first) mempty
+                     _ -> ResultList mempty (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"])
+                  of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) mempty
+                     _ -> ResultList mempty (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"])
+               of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) mempty
+                  _ -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["satisfyChar"])
+   satisfyCharInput predicate = Parser p
+      where p s =
+               case Textual.splitCharacterPrefix s
+               of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest $ Factorial.primePrefix s) mempty
+                  _ -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["satisfyChar"])
+   notSatisfy predicate = Parser p
+      where p s = case Factorial.splitPrimePrefix s
+                  of Just (first, _) 
+                        | predicate first -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["notSatisfy"])
+                     _ -> ResultList (Leaf $ ResultInfo s ()) mempty
+   notSatisfyChar predicate = Parser p
+      where p s = case Textual.characterPrefix s
+                  of Just first 
+                        | predicate first -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["notSatisfyChar"])
+                     _ -> ResultList (Leaf $ ResultInfo s ()) mempty
    scan s0 f = Parser (p s0)
-      where p s i = ResultList [ResultInfo suffix prefix] mempty
+      where p s i = ResultList (Leaf $ 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 p s i = ResultList (Leaf $ 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
+      where p s | (prefix, suffix) <- Factorial.span predicate s = ResultList (Leaf $ 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
+               then ResultList mempty (FailureInfo 1 (Factorial.length s) ["takeWhile1"])
+               else ResultList (Leaf $ ResultInfo suffix prefix) mempty
    takeCharsWhile predicate = Parser p
-      where p s | (prefix, suffix) <- Textual.span_ False predicate s = ResultList [ResultInfo suffix prefix] mempty
+      where p s | (prefix, suffix) <- Textual.span_ False predicate s = 
+               ResultList (Leaf $ 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
+               then ResultList mempty (FailureInfo 1 (Factorial.length s) ["takeCharsWhile1"])
+               else ResultList (Leaf $ ResultInfo suffix prefix) mempty
    string s = Parser p where
-      p s' | Just suffix <- Cancellative.stripPrefix s s' = ResultList [ResultInfo suffix s] mempty
-           | otherwise = ResultList [] (FailureInfo 1 (Factorial.length s') ["string " ++ show s])
+      p s' | Just suffix <- Cancellative.stripPrefix s s' = ResultList (Leaf $ ResultInfo suffix s) mempty
+           | otherwise = ResultList mempty (FailureInfo 1 (Factorial.length s') ["string " ++ show s])
    whiteSpace = () <$ takeCharsWhile isSpace
    concatMany (Parser p) = Parser q
-      where q s = ResultList [] failure <> foldMap continue rs
+      where q s = ResultList mempty failure <> foldMap continue rs
                where ResultList rs failure = p s
             continue (ResultInfo suffix prefix) = (prefix <>) <$> q suffix
 
@@ -169,11 +187,11 @@
    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"])
+      where rewind t (ResultList EmptyTree _) = ResultList (Leaf $ ResultInfo t ()) mempty
+            rewind t ResultList{} = ResultList mempty (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])
+   unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo 0 (Factorial.length t) [msg])
    eof = endOfInput
 
 instance FactorialMonoid s => LookAheadParsing (Parser g s) where
@@ -193,6 +211,7 @@
    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)
+fromResultList s (ResultList EmptyTree (FailureInfo _ pos msgs)) = 
+   Left (ParseFailure (Factorial.length s - pos) (nub msgs))
+fromResultList _ (ResultList rl _failure) = Right (f <$> toList rl)
    where f (ResultInfo s r) = (s, r)
diff --git a/src/Text/Grampa/Internal.hs b/src/Text/Grampa/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Grampa/Internal.hs
@@ -0,0 +1,37 @@
+module Text.Grampa.Internal (BinTree(..), FailureInfo(..)) where
+
+import Data.Monoid (Monoid(mappend, mempty), (<>))
+import Data.Word (Word64)
+
+data FailureInfo = FailureInfo !Int Word64 [String] deriving (Eq, Show)
+
+data BinTree a = Fork !(BinTree a) !(BinTree a)
+               | Leaf !a
+               | EmptyTree
+               deriving (Show)
+
+instance Monoid FailureInfo where
+   mempty = FailureInfo 0 maxBound []
+   f1@(FailureInfo s1 pos1 exp1) `mappend` f2@(FailureInfo s2 pos2 exp2)
+      | 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 BinTree where
+   fmap f (Fork left right) = Fork (fmap f left) (fmap f right)
+   fmap f (Leaf a) = Leaf (f a)
+   fmap _ EmptyTree = EmptyTree
+
+instance Foldable BinTree where
+   foldMap f (Fork left right) = foldMap f left <> foldMap f right
+   foldMap f (Leaf a) = f a
+   foldMap _ EmptyTree = mempty
+
+instance Monoid (BinTree a) where
+   mempty = EmptyTree
+   mappend EmptyTree t = t
+   mappend t EmptyTree = t
+   mappend l r = Fork l r
diff --git a/src/Text/Grampa/PEG/Backtrack.hs b/src/Text/Grampa/PEG/Backtrack.hs
--- a/src/Text/Grampa/PEG/Backtrack.hs
+++ b/src/Text/Grampa/PEG/Backtrack.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
 -- | Backtracking parser for Parsing Expression Grammars
-module Text.Grampa.PEG.Backtrack (Parser) where
+module Text.Grampa.PEG.Backtrack (Parser(..), Result(..), alt) where
 
 import Control.Applicative (Applicative(..), Alternative(..), liftA2)
 import Control.Monad (Monad(..), MonadPlus(..))
@@ -11,7 +11,7 @@
 import Data.List (nub)
 import Data.Monoid (Monoid(mappend, mempty), (<>))
 import Data.Monoid.Factorial(FactorialMonoid)
-import Data.Word (Word64)
+import Data.String (fromString)
 
 import qualified Data.Monoid.Cancellative as Cancellative
 import qualified Data.Monoid.Factorial as Factorial
@@ -20,13 +20,17 @@
 
 import qualified Rank2
 
+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 Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))
+import Text.Grampa.Internal (FailureInfo(..))
 
-data Result (g :: (* -> *) -> *) s v = Parsed{ parsedPrefix :: v, 
-                                              _parsedSuffix :: s}
+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.
@@ -42,6 +46,7 @@
    
 instance Functor (Parser g s) where
    fmap f (Parser p) = Parser (fmap f . p)
+   {-# INLINABLE fmap #-}
 
 instance Applicative (Parser g s) where
    pure a = Parser (Parsed a)
@@ -49,10 +54,15 @@
       r rest = case p rest
                of Parsed f rest' -> f <$> q rest'
                   NoParse failure -> NoParse failure
+   {-# INLINABLE (<*>) #-}
 
 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
+   (<|>) = alt
+
+-- | A named and unconstrained version of the '<|>' operator
+alt :: Parser g s a -> Parser g s a -> Parser g s a
+Parser p `alt` Parser q = Parser r where
       r rest = case p rest
                of x@Parsed{} -> x
                   NoParse{} -> q rest
@@ -81,11 +91,27 @@
       where rewind t Parsed{} = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length t) ["notFollowedBy"])
             rewind t NoParse{} = Parsed () t
 
+instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where
+   lookAhead (Parser p) = Parser (\input-> rewind input (p input))
+      where rewind t (Parsed r _) = Parsed r t
+            rewind _ r@NoParse{} = r
+
+instance (Show s, Textual.TextualMonoid s) => CharParsing (Parser g s) where
+   satisfy = satisfyChar
+   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, Textual.TextualMonoid s) => TokenParsing (Parser g s) where
+   someSpace = () <$ takeCharsWhile1 isSpace
+
 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
+      where p rest
+               | Null.null rest = Parsed () rest
+               | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])
    getInput = Parser p
       where p rest = Parsed rest mempty
    anyToken = Parser p
@@ -102,6 +128,21 @@
                case Textual.splitCharacterPrefix rest
                of Just (first, suffix) | predicate first -> Parsed first suffix
                   _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])
+   satisfyCharInput predicate = Parser p
+      where p rest =
+               case Textual.splitCharacterPrefix rest
+               of Just (first, suffix) | predicate first -> Parsed (Factorial.primePrefix rest) suffix
+                  _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])
+   notSatisfy predicate = Parser p
+      where p s = case Factorial.splitPrimePrefix s
+                  of Just (first, _) 
+                        | predicate first -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfy"])
+                     _ -> Parsed () s
+   notSatisfyChar predicate = Parser p
+      where p s = case Textual.characterPrefix s
+                  of Just first | predicate first 
+                                  -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfyChar"])
+                     _ -> Parsed () s
    scan s0 f = Parser (p s0)
       where p s rest = Parsed prefix suffix
                where (prefix, suffix, _) = Factorial.spanMaybe' s f rest
@@ -131,6 +172,7 @@
                      of Parsed prefix suffix -> let Parsed prefix' suffix' = q suffix
                                                 in Parsed (prefix <> prefix') suffix'
                         NoParse{} -> Parsed mempty rest
+   {-# INLINABLE string #-}
 
 -- | Backtracking PEG parser
 --
diff --git a/src/Text/Grampa/PEG/Backtrack/Length.hs b/src/Text/Grampa/PEG/Backtrack/Length.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Grampa/PEG/Backtrack/Length.hs
@@ -0,0 +1,202 @@
+{-# LANGUAGE TypeFamilies #-}
+-- | Backtracking parser for Parsing Expression Grammars, tracking the consumed input length
+module Text.Grampa.PEG.Backtrack.Length (Parser(..), Result(..), alt) where
+
+import Control.Applicative (Applicative(..), Alternative(..), liftA2)
+import Control.Monad (Monad(..), MonadPlus(..))
+
+import Data.Char (isSpace)
+import Data.Functor.Classes (Show1(..))
+import Data.Functor.Compose (Compose(..))
+import Data.List (nub)
+import Data.Monoid (Monoid(mappend, mempty), (<>))
+import Data.Monoid.Factorial(FactorialMonoid)
+import Data.String (fromString)
+
+import qualified Data.Monoid.Cancellative as Cancellative
+import qualified Data.Monoid.Factorial as Factorial
+import qualified Data.Monoid.Null as Null
+import qualified Data.Monoid.Textual as Textual
+
+import qualified Rank2
+
+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 Text.Grampa.Class (MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))
+import Text.Grampa.Internal (FailureInfo(..))
+
+data Result (g :: (* -> *) -> *) s v = Parsed{parsedLength :: !Int,
+                                              parsedResult :: !v,
+                                              parsedSuffix :: !s}
+                                     | NoParse FailureInfo
+
+-- | 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{parsedResult= 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 l a rest) = Parsed l (f a) rest
+   fmap _ (NoParse failure) = NoParse failure
+   
+instance Functor (Parser g s) where
+   fmap f (Parser p) = Parser (fmap f . p)
+   {-# INLINABLE fmap #-}
+
+instance Applicative (Parser g s) where
+   pure a = Parser (Parsed 0 a)
+   Parser p <*> Parser q = Parser r where
+      r rest = case p rest
+               of Parsed l f rest' -> case q rest'
+                                      of Parsed l' a rest'' -> Parsed (l+l') (f a) rest''
+                                         NoParse failure -> NoParse failure
+                  NoParse failure -> NoParse failure
+   {-# INLINABLE (<*>) #-}
+
+instance Factorial.FactorialMonoid s => Alternative (Parser g s) where
+   empty = Parser (\rest-> NoParse $ FailureInfo 0 (fromIntegral $ Factorial.length rest) ["empty"])
+   (<|>) = alt
+
+-- | A named and unconstrained version of the '<|>' operator
+alt :: Parser g s a -> Parser g s a -> Parser g s a
+Parser p `alt` 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 l a rest' -> case applyParser (f a) rest'
+                                      of Parsed l' b rest'' -> Parsed (l+l') b rest''
+                                         NoParse failure -> NoParse failure
+                  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 0 () t
+
+instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where
+   lookAhead (Parser p) = Parser (\input-> rewind input (p input))
+      where rewind t (Parsed _ r _) = Parsed 0 r t
+            rewind _ r@NoParse{} = r
+
+instance (Show s, Textual.TextualMonoid s) => CharParsing (Parser g s) where
+   satisfy = satisfyChar
+   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, Textual.TextualMonoid s) => TokenParsing (Parser g s) where
+   someSpace = () <$ takeCharsWhile1 isSpace
+
+instance MonoidParsing (Parser g) where
+   endOfInput = Parser p
+      where p rest
+               | Null.null rest = Parsed 0 () rest
+               | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])
+   getInput = Parser p
+      where p rest = Parsed (Factorial.length rest) rest mempty
+   anyToken = Parser p
+      where p rest = case Factorial.splitPrimePrefix rest
+                     of Just (first, suffix) -> Parsed 1 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 1 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 1 first suffix
+                  _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])
+   satisfyCharInput predicate = Parser p
+      where p rest =
+               case Textual.splitCharacterPrefix rest
+               of Just (first, suffix) | predicate first -> Parsed 1 (Factorial.primePrefix rest) suffix
+                  _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])
+   notSatisfy predicate = Parser p
+      where p s = case Factorial.splitPrimePrefix s
+                  of Just (first, _) 
+                        | predicate first -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfy"])
+                     _ -> Parsed 0 () s
+   notSatisfyChar predicate = Parser p
+      where p s = case Textual.characterPrefix s
+                  of Just first | predicate first 
+                                  -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfyChar"])
+                     _ -> Parsed 0 () s
+   scan s0 f = Parser (p s0)
+      where p s rest = Parsed (Factorial.length prefix) prefix suffix
+               where (prefix, suffix, _) = Factorial.spanMaybe' s f rest
+   scanChars s0 f = Parser (p s0)
+      where p s rest = Parsed (Factorial.length prefix) prefix suffix
+               where (prefix, suffix, _) = Textual.spanMaybe_' s f rest
+   takeWhile predicate = Parser p
+      where p rest | (prefix, suffix) <- Factorial.span predicate rest =
+               Parsed (Factorial.length prefix) prefix suffix
+   takeWhile1 predicate = Parser p
+      where p rest | (prefix, suffix) <- Factorial.span predicate rest =
+                        if Null.null prefix
+                        then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeWhile1"])
+                        else Parsed (Factorial.length prefix) prefix suffix
+   takeCharsWhile predicate = Parser p
+      where p rest | (prefix, suffix) <- Textual.span_ False predicate rest = 
+               Parsed (Factorial.length prefix) prefix suffix
+   takeCharsWhile1 predicate = Parser p
+      where p rest | (prefix, suffix) <- Textual.span_ False predicate rest =
+                     if Null.null prefix
+                     then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"])
+                     else Parsed (Factorial.length prefix) prefix suffix
+   string s = Parser p where
+      p s' | Just suffix <- Cancellative.stripPrefix s s' = Parsed l s suffix
+           | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])
+      l = Factorial.length s
+   whiteSpace = () <$ takeCharsWhile isSpace
+   concatMany (Parser p) = Parser q
+      where q rest = case p rest
+                     of Parsed l prefix suffix -> let Parsed l' prefix' suffix' = q suffix
+                                                  in Parsed (l+l') (prefix <> prefix') suffix'
+                        NoParse{} -> Parsed 0 mempty rest
+   {-# INLINABLE string #-}
+
+-- | Backtracking PEG parser
+--
+-- @
+-- 'parseComplete' :: ("Rank2".'Rank2.Functor' g, 'FactorialMonoid' s) =>
+--                  g (Backtrack.'Parser' g s) -> s -> g 'ParseResults'
+-- @
+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
--- a/src/Text/Grampa/PEG/Packrat.hs
+++ b/src/Text/Grampa/PEG/Packrat.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE TypeFamilies #-}
 -- | Packrat parser
-module Text.Grampa.PEG.Packrat (Parser) where
+module Text.Grampa.PEG.Packrat (Parser(..), Result(..)) where
 
 import Control.Applicative (Applicative(..), Alternative(..), liftA2)
 import Control.Monad (Monad(..), MonadPlus(..))
@@ -11,7 +11,7 @@
 import Data.List (genericLength, nub)
 import Data.Monoid (Monoid(mappend, mempty), (<>))
 import Data.Monoid.Factorial(FactorialMonoid)
-import Data.Word (Word64)
+import Data.String (fromString)
 
 import qualified Data.Monoid.Cancellative as Cancellative
 import qualified Data.Monoid.Factorial as Factorial
@@ -20,14 +20,18 @@
 
 import qualified Rank2
 
+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 Text.Grampa.Class (GrammarParsing(..), MonoidParsing(..), MultiParsing(..), ParseResults, ParseFailure(..))
+import Text.Grampa.Internal (FailureInfo(..))
 import qualified Text.Grampa.PEG.Backtrack as Backtrack (Parser)
 
-data Result g s v = Parsed{parsedPrefix :: v, 
-                           parsedSuffix :: [(s, g (Result g s))]}
+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
@@ -83,6 +87,22 @@
       where rewind t Parsed{} = NoParse (FailureInfo 1 (genericLength t) ["notFollowedBy"])
             rewind t NoParse{} = Parsed () t
 
+instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where
+   lookAhead (Parser p) = Parser (\input-> rewind input (p input))
+      where rewind t (Parsed r _) = Parsed r t
+            rewind _ r@NoParse{} = r
+
+instance (Show s, Textual.TextualMonoid s) => CharParsing (Parser g s) where
+   satisfy = satisfyChar
+   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, Textual.TextualMonoid s) => TokenParsing (Parser g s) where
+   someSpace = () <$ takeCharsWhile1 isSpace
+
 instance GrammarParsing Parser where
    type GrammarFunctor Parser = Result
    nonTerminal f = Parser p where
@@ -110,10 +130,26 @@
             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
+               case Textual.characterPrefix s
+               of Just first | predicate first -> Parsed first t
                   _ -> NoParse (FailureInfo 1 (genericLength rest) ["satisfyChar"])
             p [] = NoParse (FailureInfo 1 0 ["satisfyChar"])
+   satisfyCharInput predicate = Parser p
+      where p rest@((s, _):t) =
+               case Textual.characterPrefix s
+               of Just first | predicate first -> Parsed (Factorial.primePrefix s) t
+                  _ -> NoParse (FailureInfo 1 (genericLength rest) ["satisfyChar"])
+            p [] = NoParse (FailureInfo 1 0 ["satisfyChar"])
+   notSatisfy predicate = Parser p
+      where p rest@((s, _):_)
+               | Just (first, _) <- Factorial.splitPrimePrefix s, 
+                 predicate first = NoParse (FailureInfo 1 (genericLength rest) ["notSatisfy"])
+            p rest = Parsed () rest
+   notSatisfyChar predicate = Parser p
+      where p rest@((s, _):_)
+               | Just first <- Textual.characterPrefix s, 
+                 predicate first = NoParse (FailureInfo 1 (genericLength rest) ["notSatisfyChar"])
+            p rest = Parsed () rest
    scan s0 f = Parser (p s0)
       where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)
                where (prefix, _, _) = Factorial.spanMaybe' s f i