diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,12 +1,34 @@
 # Changelog for `distributors`
 
+## 0.5.0.0 - 2026-04-16
+
+### Changes
+
+- `MonadTry` now implies `BackusNaurForm` (so `rule` tracing/failure semantics are available)
+  and `Filtrator` (via `MonadPlus`, with `filtrate = mfiltrate`).
+- Simplified the default implementation of `terminal`.
+- Added `applicativeG` and `monadG` generators via `Joker` orphan and non-orphan instances.
+- Made nomenclature consistent with use of "fail" and "failure", not "error".
+
+### Internal
+
+- Moved orphan instances and Template Haskell internals to `Control.Lens.Grammar.Internal`.
+
+### Documentation
+
+- Expanded `BackusNaurForm` documentation with separate motivation from:
+  category-theoretic structure and failure-tracing semantics (both called “trace”
+  in different senses, and combined by BNF-style rules).
+- Added a `monadG` Megaparsec example.
+- Fixed typo in the `makeNestedPrisms` example.
+
 ## 0.4.0.0 - 2026-04-10
 
 ### New Modules
 
 - `Control.Monad.Fail.Try` - `MonadTry` class with `try` & `fail` for backtracking parsers
-- `Data.Profunctor.Grammar.Parsector` - Invertible LL(1) parser with Parsec-style error reporting:
-  `ParsecState`, `ParsecError`, `parsecP`, `unparsecP`; implements hints, LL(1) commitment
+- `Data.Profunctor.Grammar.Parsector` - Invertible LL(1) parser with Parsec-style failure reporting:
+  `ParsecState`, `ParsecFailure`, `parsecP`, `unparsecP`; implements hints, LL(1) commitment
   via `parsecLooked`, and `try` for explicit backtracking
 - `Data.Profunctor.Separator` - Separator/delimiter combinators: `sepWith`, `noSep`,
   `beginWith`, `endWith`, `several`, `several1`, `intercalateP`, `chain`, `chain1`
diff --git a/distributors.cabal b/distributors.cabal
--- a/distributors.cabal
+++ b/distributors.cabal
@@ -5,7 +5,7 @@
 -- see: https://github.com/sol/hpack
 
 name:           distributors
-version:        0.4.0.0
+version:        0.5.0.0
 synopsis:       Unifying Parsers, Printers & Grammars
 description:    Distributors provides mathematically inspired abstractions for coders to write parsers that can also be inverted to printers.
 category:       Profunctors, Optics, Parsing
@@ -33,11 +33,12 @@
       Control.Lens.Grammar
       Control.Lens.Grammar.BackusNaur
       Control.Lens.Grammar.Boole
+      Control.Lens.Grammar.Internal.NestedPrismTH
+      Control.Lens.Grammar.Internal.Orphanage
       Control.Lens.Grammar.Kleene
       Control.Lens.Grammar.Symbol
       Control.Lens.Grammar.Token
       Control.Lens.Grate
-      Control.Lens.Internal.NestedPrismTH
       Control.Lens.Monocle
       Control.Lens.PartialIso
       Control.Lens.Wither
@@ -186,6 +187,7 @@
     , doctest >=0.18 && <1
     , hspec >=2.7 && <3
     , lens >=5.0 && <6
+    , megaparsec >=9.0 && <10
     , mtl >=2.2 && <3
     , profunctors >=5.6 && <6
     , tagged >=0.8 && <1
diff --git a/src/Control/Lens/Bifocal.hs b/src/Control/Lens/Bifocal.hs
--- a/src/Control/Lens/Bifocal.hs
+++ b/src/Control/Lens/Bifocal.hs
@@ -59,8 +59,7 @@
   (Alternator p, Filtrator p, Alternative f, Filterable f)
     => p a (f b) -> p s (f t)
 
-{- | If you see `ABifocal` in a signature for a function,
-the function is expecting a `Bifocal`. -}
+{- | `ABifocal` is monomorphically a `Bifocal`. -}
 type ABifocal s t a b =
   Binocular a b a (Maybe b) -> Binocular a b s (Maybe t)
 
diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs
--- a/src/Control/Lens/Grammar.hs
+++ b/src/Control/Lens/Grammar.hs
@@ -23,6 +23,7 @@
   , RegBnf (..)
   , regbnfG
   , regbnfGrammar
+  , applicativeG
     -- * Context-sensitive grammar
   , CtxGrammar
   , printG
@@ -30,6 +31,8 @@
   , unparseG
   , parsecG
   , unparsecG
+  , readG
+  , monadG
     -- * Utility
   , putStringLn
     -- * Re-exports
@@ -44,6 +47,7 @@
 import Control.Lens.Grammar.Kleene
 import Control.Lens.Grammar.Token
 import Control.Lens.Grammar.Symbol
+import Data.Bifunctor.Joker
 import Data.Maybe hiding (mapMaybe)
 import Data.Monoid
 import Data.Profunctor.Distributor
@@ -56,6 +60,7 @@
 import Data.String
 import GHC.Exts
 import Prelude hiding (filter)
+import Text.ParserCombinators.ReadP (ReadP, readP_to_S)
 import Witherable
 
 -- Re-exports
@@ -94,7 +99,7 @@
 
 We'd like to define an optic @_SemVer@,
 corresponding to the constructor pattern @SemVer@.
-You _could_ generate it with the TemplateHaskell combinator,
+You could generate it with the TemplateHaskell combinator,
 `makeNestedPrisms`.
 
 @makeNestedPrisms ''SemVer@
@@ -275,8 +280,8 @@
 -}
 type Grammar token a = forall p.
   ( Lexical token p
-  , forall x. BackusNaurForm (p x x)
   , Alternator p
+  , forall x. BackusNaurForm (p x x)
   ) => p a a
 
 {- | For context-sensitivity,
@@ -358,7 +363,7 @@
 unrestricted filtration of grammars by computable predicates,
 which can recognize the larger class of recursively enumerable languages.
 
-Finally, `CtxGrammar`s support error reporting and backtracking.
+Finally, `CtxGrammar`s support failure reporting and backtracking.
 This has no effect on `printG`, `parseG` or `unparseG`;
 but it effects `parsecG` and `unparsecG`.
 For context, an @LL@ grammar can be (un)parsed by an @LL@ parser.
@@ -373,18 +378,17 @@
 diverge if the `CtxGrammar` they're run on is left-recursive.
 
 >>> parsecG (rule "foo" (fail "bar") <|> fail "baz") "abc"
-ParsecState {parsecLooked = False, parsecOffset = 0, parsecStream = "abc", parsecError = ParsecError {parsecExpect = TokenClass (OneOf (fromList "")), parsecLabels = [Node {rootLabel = "foo", subForest = [Node {rootLabel = "bar", subForest = []}]},Node {rootLabel = "baz", subForest = []}]}, parsecResult = Nothing}
+ParsecState {parsecLooked = False, parsecOffset = 0, parsecStream = "abc", parsecFailure = ParsecFailure {parsecExpect = TokenClass (OneOf (fromList "")), parsecLabels = [Node {rootLabel = "foo", subForest = [Node {rootLabel = "bar", subForest = []}]},Node {rootLabel = "baz", subForest = []}]}, parsecResult = Nothing}
 
 >>> parsecG (manyP (token 'a') >*< asIn @Char DecimalNumber) "aaab"
-ParsecState {parsecLooked = True, parsecOffset = 3, parsecStream = "b", parsecError = ParsecError {parsecExpect = TokenClass (Alternate (TokenClass (OneOf (fromList "a"))) (TokenClass (NotOneOf (fromList "") (AndAsIn DecimalNumber)))), parsecLabels = []}, parsecResult = Nothing}
+ParsecState {parsecLooked = True, parsecOffset = 3, parsecStream = "b", parsecFailure = ParsecFailure {parsecExpect = TokenClass (Alternate (TokenClass (OneOf (fromList "a"))) (TokenClass (NotOneOf (fromList "") (AndAsIn DecimalNumber)))), parsecLabels = []}, parsecResult = Nothing}
 
 >>> unparsecG (tokens "abc") "abx" ""
-ParsecState {parsecLooked = True, parsecOffset = 2, parsecStream = "ab", parsecError = ParsecError {parsecExpect = TokenClass (OneOf (fromList "c")), parsecLabels = []}, parsecResult = Nothing}
+ParsecState {parsecLooked = True, parsecOffset = 2, parsecStream = "ab", parsecFailure = ParsecFailure {parsecExpect = TokenClass (OneOf (fromList "c")), parsecLabels = []}, parsecResult = Nothing}
 
 -}
 type CtxGrammar token a = forall p.
   ( Lexical token p
-  , forall x. BackusNaurForm (p x x)
   , Alternator p
   , Filtrator p
   , MonadicTry p
@@ -768,8 +772,8 @@
 regbnfGrammar = rule "regbnf" $ _RegBnf . _Bnf >~
   terminal "{start} = " >* regexGrammar >*< several noSep
     (terminal "\n" >* nonterminalG *< terminal " = " >*< regexGrammar)
-      
 
+
 {- | `regstringG` generates a `RegString` from a regular grammar.
 Since context-free `Grammar`s and `CtxGrammar`s aren't necessarily regular,
 the type system will prevent `regstringG` from being applied to them.
@@ -841,7 +845,7 @@
 Running the parser on an input string value `uncons`es
 tokens from the beginning of an input string from left to right,
 returning `parsecResult` as `Nothing` on failure or `Just`
-an output syntax value, with parse failure stored in `parsecError`,
+an output syntax value, with parse failure stored in `parsecFailure`,
 and a remaining output `parsecStream`.
 -}
 parsecG
@@ -870,6 +874,77 @@
   -> ParsecState string a
 unparsecG parsector = unparsecP parsector
 
+{- | Generate any `Applicative` parser backend
+from a `Grammar` with `applicativeG`.
+It works the same way as `monadG`,
+for parsers without `Monad` instances.
+That permits backends to use algorithms
+that can only parse context-free `Grammar`s.
+-}
+applicativeG
+  :: ( Alternative f
+     , TokenAlgebra token (f token)
+     , TerminalSymbol token (f ())
+     , forall x. BackusNaurForm (f x)
+     )
+  => Grammar token a -- ^ context-free grammar
+  -> f a
+applicativeG joker = runJoker joker
+
+{- | Generate a `ReadP` backend from a `CtxGrammar` `Char`. -}
+readG :: CtxGrammar Char a -> ReadP a
+readG joker = monadG joker
+
+{- | Generate any parser `Monad` backend
+from a `CtxGrammar` with `monadG`.
+Let's see how to do this without orphan instances,
+using the Megaparsec library.
+
+@
+import qualified Text.Megaparsec as M
+import qualified Text.Megaparsec.Char as M
+import Control.Lens.Grammar
+
+newtype WrapMega a = WrapMega {unwrapMega :: M.Parsec String String a}
+  deriving newtype
+    ( Functor, Applicative, Alternative
+    , Monad, MonadPlus, MonadFail
+    )
+instance TerminalSymbol Char (WrapMega ()) where
+  terminal str = WrapMega (M.chunk str *> pure ())
+instance TokenAlgebra Char (WrapMega Char) where
+  tokenClass exam = WrapMega $ M.label (show exam) (M.satisfy (tokenClass exam))
+instance Tokenized Char (WrapMega Char) where
+  anyToken = WrapMega M.anySingle
+  token = WrapMega . M.single
+  oneOf = WrapMega . M.oneOf
+  notOneOf = WrapMega . M.noneOf
+  asIn cat = WrapMega $ M.label ("in category " ++ show cat) (M.satisfy (asIn cat))
+  notAsIn cat = WrapMega $ M.label ("not in category " ++ show cat) (M.satisfy (notAsIn cat))
+instance BackusNaurForm (WrapMega a) where
+  rule lbl (WrapMega p) = WrapMega (M.label lbl p)
+  ruleRec lbl = rule lbl . fix
+instance Filterable WrapMega where
+  catMaybes m = m >>= maybe (fail "unrestricted filtration") pure
+instance MonadTry WrapMega where
+  try (WrapMega p) = WrapMega (M.try p)
+
+megaparsecG
+  :: CtxGrammar Char a
+  -> M.Parsec String String a
+megaparsecG gram = unwrapMega (monadG gram)
+@
+
+-}
+monadG
+  :: ( MonadTry m
+     , TokenAlgebra token (m token)
+     , TerminalSymbol token (m ())
+     )
+  => CtxGrammar token a -- ^ context-sensitive grammar
+  -> m a
+monadG joker = runJoker joker
+
 {- | `putStringLn` is a utility that generalizes `putStrLn`
 to string-like interfaces such as `RegString` and `RegBnf`.
 -}
@@ -882,7 +957,7 @@
     = fromMaybe zeroK
     . listToMaybe
     . mapMaybe prsF
-    . parseP regexGrammar
+    . readP_to_S (readG regexGrammar)
     where
       prsF (rex,"") = Just rex
       prsF _ = Nothing
@@ -901,7 +976,7 @@
     = fromMaybe zeroK
     . listToMaybe
     . mapMaybe prsF
-    . parseP regbnfGrammar
+    . readP_to_S (readG regbnfGrammar)
     where
       prsF (regbnf,"") = Just regbnf
       prsF _ = Nothing
diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs
--- a/src/Control/Lens/Grammar/BackusNaur.hs
+++ b/src/Control/Lens/Grammar/BackusNaur.hs
@@ -29,35 +29,64 @@
 import Control.Lens.Grammar.Kleene
 import Control.Lens.Grammar.Token
 import Control.Lens.Grammar.Symbol
+import Data.Bifunctor.Joker
 import Data.Coerce
 import Data.Foldable
 import Data.Function
 import Data.MemoTrie
 import qualified Data.Set as Set
 import Data.Set (Set)
+import Text.ParserCombinators.ReadP (ReadP)
 
-{- | `BackusNaurForm` grammar combinators formalize
-`rule` abstraction and general recursion. Both context-free
-`Control.Lens.Grammar.Grammar`s & `Control.Lens.Grammar.CtxGrammar`s
-support the `BackusNaurForm` interface.
+{- | `BackusNaurForm` grammar combinators formalize traced
+`rule` abstraction and general recursion with `ruleRec`,
+related by this invariant.
 
-prop> rule name bnf = ruleRec name (\_ -> bnf)
+prop> rule label bnf = ruleRec label (\_ -> bnf)
 
+The `BackusNaurForm` interface is reminiscent of
+two distinct notions of "trace".
+First as a [traced Cartesian monoidal category]
+(https://ncatlab.org/nlab/show/traced+monoidal+category#in_cartesian_monoidal_categories)
+which models general recursion abstractly,
+and second as a `Debug.Trace.trace`-like label for `rule` abstraction.
+The category @(->)@ already has a traced @(,)@-monoidal structure
+in the form of `Data.Profunctor.unfirst` @=@ `Control.Arrow.loop`
+or equivalently the fixpoint function `fix`,
+determining default methods for a `BackusNaurForm`.
+
+prop> rule _ = id
+prop> ruleRec _ = fix
+
+The `BackusNaurForm` interface permits overloading these methods,
+and tracing them with a label.
+
+Both context-free `Control.Lens.Grammar.Grammar`s
+& `Control.Lens.Grammar.CtxGrammar`s
+support the `BackusNaurForm` interface.
 See Breitner, [Showcasing Applicative]
-(https://www.joachim-breitner.de/blog/710-Showcasing_Applicative).
+(https://www.joachim-breitner.de/blog/710-Showcasing_Applicative),
+for the original interface.
+
 -}
 class BackusNaurForm bnf where
 
-  {- | Rule abstraction, `rule` can be used to detail parse errors. -}
+  {- | Rule abstraction. -}
   rule :: String -> bnf -> bnf
   rule _ = id
 
-  {- | General recursion, using `ruleRec`, rules can refer to themselves. -}
+  {- | General recursion. -}
   ruleRec :: String -> (bnf -> bnf) -> bnf
   ruleRec _ = fix
 
 {- | A `Bnf` consists of a distinguished starting rule
-and a set of named rules, supporting the `BackusNaurForm` interface. -}
+and a set of named rules. When a `Bnf` supports `NonTerminalSymbol`s,
+then it supports the `BackusNaurForm` interface
+by replacing recursive calls with `nonTerminal`s.
+
+prop> ruleRec label f = rule label (f (nonTerminal label))
+
+-}
 data Bnf rule = Bnf
   { startBnf :: rule
   , rulesBnf :: Set (String, rule)
@@ -145,14 +174,14 @@
 -- instances
 instance (Ord rule, NonTerminalSymbol rule)
   => BackusNaurForm (Bnf rule) where
-    rule name = ruleRec name . const
-    ruleRec name f =
-      let
-        newStart = nonTerminal name
-        Bnf newRule oldRules = f (Bnf newStart mempty)
-        newRules = Set.insert (name, newRule) oldRules
-      in
-        Bnf newStart newRules
+    rule label (Bnf newRule oldRules) = (nonTerminal label)
+      {rulesBnf = Set.insert (label, newRule) oldRules}
+    ruleRec label f = rule label (f (nonTerminal label))
+instance (forall x. BackusNaurForm (f x))
+  => BackusNaurForm (Joker f a b) where
+    rule name = Joker . rule name . runJoker
+    ruleRec name = Joker . ruleRec name . dimap Joker runJoker
+instance BackusNaurForm (ReadP a)
 instance (Ord rule, TerminalSymbol token rule)
   => TerminalSymbol token (Bnf rule) where
   terminal = liftBnf0 . terminal
diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs
--- a/src/Control/Lens/Grammar/Boole.hs
+++ b/src/Control/Lens/Grammar/Boole.hs
@@ -1,6 +1,6 @@
 {- |
 Module      : Control.Lens.Grammar.Boole
-Description : Boolean algebras & token classes
+Description : Boolean algebras
 Copyright   : (C) 2026 - Eitan Chatav
 License     : BSD-style (see the file LICENSE)
 Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
@@ -9,7 +9,6 @@
 
 See Boole, [The Mathematical Analysis of Logic]
 (https://www.gutenberg.org/files/36884/36884-pdf.pdf).
-Categorized token classes form a Boolean algebra.
 -}
 
 module Control.Lens.Grammar.Boole
diff --git a/src/Control/Lens/Grammar/Internal/NestedPrismTH.hs b/src/Control/Lens/Grammar/Internal/NestedPrismTH.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Lens/Grammar/Internal/NestedPrismTH.hs
@@ -0,0 +1,342 @@
+{- |
+Module      : Control.Lens.Grammar.Internal.NestedPrismTH
+Description : nested pair prisms
+Copyright   : (C) 2026 - Eitan Chatav
+License     : BSD-style (see the file LICENSE)
+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
+Stability   : provisional
+Portability : non-portable
+
+Code is duplicated from `Control.Lens.Internal.PrismTH`,
+with small tweaks to support nested pairs.
+-}
+
+module Control.Lens.Grammar.Internal.NestedPrismTH
+  ( -- * Nested prisms
+    makeNestedPrisms
+  ) where
+
+import Control.Applicative
+import Control.Lens.Getter
+import Control.Lens.Internal.TH
+import Control.Lens.Lens
+import Control.Monad
+import Data.Char (isUpper)
+import qualified Data.List as List
+import Data.Set.Lens
+import Data.Traversable
+import Language.Haskell.TH
+import qualified Language.Haskell.TH.Datatype as D
+import Language.Haskell.TH.Lens
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Set (Set)
+import Prelude
+
+-- | Similar to `Control.Lens.Internal.PrismTH.makePrisms`,
+-- `makeNestedPrisms` generates a `Control.Lens.Prism.Prism`
+-- for each constructor of a data type.
+-- `Control.Lens.Iso.Iso`s are generated when possible.
+-- `Control.Lens.Review.Review`s are generated for constructors
+-- with existentially quantified constructors and GADTs.
+-- The difference in `makeNestedPrisms`
+-- is that constructors with @n > 2@ arguments
+-- will use right-nested pairs, rather than a flat @n@-tuple.
+-- This makes them suitable for pattern bonding,
+-- by use of the applicator `Control.Lens.PartialIso.>?`
+-- to `Data.Profunctor.Monoidal.Monoidal` idiom notation
+-- with `Data.Profunctor.Monoidal.>*<`,
+-- or to `Data.Profunctor.Monadic.Monadic` qualified do-notation.
+--
+-- /e.g./
+--
+-- @
+-- data FooBar a
+--   = Foo a
+--   | Bar Int
+--   | Baz Int Char
+--   | Buzz Double String Bool
+--   | Boop
+-- makeNestedPrisms ''FooBar
+-- @
+--
+-- will create
+--
+-- @
+-- _Foo :: Prism (FooBar a) (FooBar b) a b
+-- _Bar :: Prism' (FooBar a) Int
+-- _Baz :: Prism' (FooBar a) (Int, Char)
+-- _Buzz :: Prism' (FooBar a) (Double, (String, Bool))
+-- _Boop :: Prism' (FooBar a) ()
+-- @
+makeNestedPrisms :: Name -> DecsQ
+makeNestedPrisms typeName =
+  do info <- D.reifyDatatype typeName
+     let cons = D.datatypeCons info
+     makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons)
+
+-- Generate prisms for the given type, and normalized constructors.
+-- This function dispatches between Iso generation, and normal top-level
+makeConsPrisms :: Type -> [NCon] -> DecsQ
+-- special case: single constructor -> make iso
+makeConsPrisms t [con@(NCon _ [] [] _)] = makeConIso t con
+-- top-level definitions
+makeConsPrisms t cons =
+  fmap concat $ for cons $ \con ->
+    do let conName = view nconName con
+       stab <- computeOpticType t cons con
+       let n = prismName conName
+       sequenceA
+         ( [ sigD n (return (quantifyType [] (stabToType Set.empty stab)))
+           , valD (varP n) (normalB (makeConOpticExp stab cons con)) []
+           ]
+           ++ inlinePragma n
+         )
+
+data OpticType = PrismType | ReviewType
+
+data Stab  = Stab Cxt OpticType Type Type Type Type
+
+stabSimple :: Stab -> Bool
+stabSimple (Stab _ _ s t a b) = s == t && a == b
+
+stabToType :: Set Name -> Stab -> Type
+stabToType clsTVBNames stab@(Stab cx ty s t a b) =
+  quantifyType' clsTVBNames cx stabTy
+  where
+  stabTy =
+    case ty of
+      PrismType  | stabSimple stab -> prism'TypeName  `conAppsT` [t,b]
+                 | otherwise       -> prismTypeName   `conAppsT` [s,t,a,b]
+      ReviewType                   -> reviewTypeName  `conAppsT` [t,b]
+
+stabType :: Stab -> OpticType
+stabType (Stab _ o _ _ _ _) = o
+
+computeOpticType :: Type -> [NCon] -> NCon -> Q Stab
+computeOpticType t cons con =
+  do let cons' = List.delete con cons
+     if null (_nconVars con)
+         then computePrismType t (view nconCxt con) cons' con
+         else computeReviewType t (view nconCxt con) (view nconTypes con)
+
+computeReviewType :: Type -> Cxt -> [Type] -> Q Stab
+computeReviewType s' cx tys =
+  do let t = s'
+     s <- fmap VarT (newName "s")
+     a <- fmap VarT (newName "a")
+     b <- toNestedPairT (map return tys)
+     return (Stab cx ReviewType s t a b)
+
+-- Compute the full type-changing Prism type given an outer type,
+-- list of constructors, and target constructor name. Additionally
+-- return 'True' if the resulting type is a "simple" prism.
+computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab
+computePrismType t cx cons con =
+  do let ts      = view nconTypes con
+         unbound = setOf typeVars t Set.\\ setOf typeVars cons
+     sub <- sequenceA (Map.fromSet (newName . nameBase) unbound)
+     b   <- toNestedPairT (map return ts)
+     a   <- toNestedPairT (map return (substTypeVars sub ts))
+     let s = substTypeVars sub t
+     return (Stab cx PrismType s t a b)
+
+computeIsoType :: Type -> [Type] -> TypeQ
+computeIsoType t' fields =
+  do sub <- sequenceA (Map.fromSet (newName . nameBase) (setOf typeVars t'))
+     let t = return                    t'
+         s = return (substTypeVars sub t')
+         b = toNestedPairT (map return                    fields)
+         a = toNestedPairT (map return (substTypeVars sub fields))
+         ty | Map.null sub = appsT (conT iso'TypeName) [t,b]
+            | otherwise    = appsT (conT isoTypeName) [s,t,a,b]
+     quantifyType [] <$> ty
+
+-- Construct either a Review or Prism as appropriate
+makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ
+makeConOpticExp stab cons con =
+  case stabType stab of
+    PrismType  -> makeConPrismExp stab cons con
+    ReviewType -> makeConReviewExp con
+
+-- Construct an iso declaration
+makeConIso :: Type -> NCon -> DecsQ
+makeConIso s con =
+  do let ty      = computeIsoType s (view nconTypes con)
+         defName = prismName (view nconName con)
+     sequenceA
+       ( [ sigD       defName  ty
+         , valD (varP defName) (normalB (makeConIsoExp con)) []
+         ] ++
+         inlinePragma defName
+       )
+
+-- Construct prism expression
+--
+-- prism <<reviewer>> <<remitter>>
+makeConPrismExp ::
+  Stab ->
+  [NCon] {- ^ constructors       -} ->
+  NCon   {- ^ target constructor -} ->
+  ExpQ
+makeConPrismExp stab cons con = appsE [varE prismValName, reviewer, remitter]
+  where
+  ts = view nconTypes con
+  fields  = length ts
+  conName = view nconName con
+  reviewer                   = makeReviewer       conName fields
+  remitter | stabSimple stab = makeSimpleRemitter conName (length cons) fields
+           | otherwise       = makeFullRemitter cons conName
+
+-- Construct an Iso expression
+--
+-- iso <<reviewer>> <<remitter>>
+makeConIsoExp :: NCon -> ExpQ
+makeConIsoExp con = appsE [varE isoValName, remitter, reviewer]
+  where
+  conName = view nconName con
+  fields  = length (view nconTypes con)
+  reviewer = makeReviewer    conName fields
+  remitter = makeIsoRemitter conName fields
+
+-- Construct a Review expression
+--
+-- unto (\(x,y,z) -> Con x y z)
+makeConReviewExp :: NCon -> ExpQ
+makeConReviewExp con = appE (varE untoValName) reviewer
+  where
+  conName = view nconName con
+  fields  = length (view nconTypes con)
+  reviewer = makeReviewer conName fields
+
+------------------------------------------------------------------------
+-- Prism and Iso component builders
+------------------------------------------------------------------------
+
+-- Construct the review portion of a prism.
+--
+-- (\(x,y,z) -> Con x y z) :: b -> t
+makeReviewer :: Name -> Int -> ExpQ
+makeReviewer conName fields =
+  do xs <- newNames "x" fields
+     lam1E (toNestedPairP (map varP xs))
+           (conE conName `appsE1` map varE xs)
+
+-- Construct the remit portion of a prism.
+-- Pattern match only target constructor, no type changing
+--
+-- (\x -> case s of
+--          Con x y z -> Right (x,y,z)
+--          _         -> Left x
+-- ) :: s -> Either s a
+makeSimpleRemitter ::
+  Name {- The name of the constructor on which this prism focuses -} ->
+  Int  {- The number of constructors the parent data type has     -} ->
+  Int  {- The number of fields the constructor has                -} ->
+  ExpQ
+makeSimpleRemitter conName numCons fields =
+  do x  <- newName "x"
+     xs <- newNames "y" fields
+     let matches =
+           [ match (conP conName (map varP xs))
+                   (normalB (appE (conE rightDataName) (toNestedPairE (map varE xs))))
+                   []
+           ] ++
+           [ match wildP (normalB (appE (conE leftDataName) (varE x))) []
+           | numCons > 1 -- Only generate a catch-all case if there is at least
+                         -- one constructor besides the one being focused on.
+           ]
+     lam1E (varP x) (caseE (varE x) matches)
+
+-- Pattern match all constructors to enable type-changing
+--
+-- (\x -> case s of
+--          Con x y z -> Right (x,y,z)
+--          Other_n w   -> Left (Other_n w)
+-- ) :: s -> Either t a
+makeFullRemitter :: [NCon] -> Name -> ExpQ
+makeFullRemitter cons target =
+  do x <- newName "x"
+     lam1E (varP x) (caseE (varE x) (map mkMatch cons))
+  where
+  mkMatch (NCon conName _ _ n) =
+    do xs <- newNames "y" (length n)
+       match (conP conName (map varP xs))
+             (normalB
+               (if conName == target
+                  then appE (conE rightDataName) (toNestedPairE (map varE xs))
+                  else appE (conE leftDataName) (conE conName `appsE1` map varE xs)))
+             []
+
+-- Construct the remitter suitable for use in an 'Iso'
+--
+-- (\(Con x y z) -> (x,y,z)) :: s -> a
+makeIsoRemitter :: Name -> Int -> ExpQ
+makeIsoRemitter conName fields =
+  do xs <- newNames "x" fields
+     lam1E (conP conName (map varP xs))
+           (toNestedPairE (map varE xs))
+
+------------------------------------------------------------------------
+-- Utilities
+------------------------------------------------------------------------
+
+-- Normalized constructor
+data NCon = NCon
+  { _nconName :: Name
+  , _nconVars :: [Name]
+  , _nconCxt  :: Cxt
+  , _nconTypes :: [Type]
+  }
+  deriving (Eq)
+instance HasTypeVars NCon where
+  typeVarsEx s f (NCon x vars y z) = NCon x vars <$> typeVarsEx s' f y <*> typeVarsEx s' f z
+    where s' = List.foldl' (flip Set.insert) s vars
+
+nconName :: Lens' NCon Name
+nconName f x = fmap (\y -> x {_nconName = y}) (f (_nconName x))
+
+nconCxt :: Lens' NCon Cxt
+nconCxt f x = fmap (\y -> x {_nconCxt = y}) (f (_nconCxt x))
+
+nconTypes :: Lens' NCon [Type]
+nconTypes f x = fmap (\y -> x {_nconTypes = y}) (f (_nconTypes x))
+
+-- Normalize a single 'Con' to its constructor name and field types.
+normalizeCon :: D.ConstructorInfo -> NCon
+normalizeCon info = NCon (D.constructorName info)
+                         (D.tvName <$> D.constructorVars info)
+                         (D.constructorContext info)
+                         (D.constructorFields info)
+
+-- Compute a prism's name by prefixing an underscore for normal
+-- constructors and period for operators.
+prismName ::
+  Name {- type constructor        -} ->
+  Name {- prism name              -}
+prismName n =
+  case nameBase n of
+    [] -> error "prismName: empty name base?"
+    nb@(x:_) | isUpper x -> mkName (prefix '_' nb)
+             | otherwise -> mkName (prefix '.' nb) -- operator
+  where
+    prefix :: Char -> String -> String
+    prefix char str = char:str
+
+-- Construct a tuple type given a list of types.
+toNestedPairT :: [TypeQ] -> TypeQ
+toNestedPairT [] = appsT (tupleT 0) []
+toNestedPairT [x] = x
+toNestedPairT (x:xs) = appsT (tupleT 2) [x, toNestedPairT xs]
+
+-- Construct a tuple value given a list of expressions.
+toNestedPairE :: [ExpQ] -> ExpQ
+toNestedPairE [] = tupE []
+toNestedPairE [x] = x
+toNestedPairE (x:xs) = tupE [x, toNestedPairE xs]
+
+-- Construct a tuple pattern given a list of patterns.
+toNestedPairP :: [PatQ] -> PatQ
+toNestedPairP [] = tupP []
+toNestedPairP [x] = x
+toNestedPairP (x:xs) = tupP [x, toNestedPairP xs]
diff --git a/src/Control/Lens/Grammar/Internal/Orphanage.hs b/src/Control/Lens/Grammar/Internal/Orphanage.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Lens/Grammar/Internal/Orphanage.hs
@@ -0,0 +1,140 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+{- |
+Module      : Control.Lens.Grammar.Internal.Orphanage
+Description : orphanage
+Copyright   : (C) 2026 - Eitan Chatav
+License     : BSD-style (see the file LICENSE)
+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
+Stability   : provisional
+Portability : non-portable
+
+An orphanage for instances without a home.
+-}
+
+module Control.Lens.Grammar.Internal.Orphanage () where
+
+import Control.Applicative hiding (WrappedArrow)
+import Control.Applicative qualified as Ap (WrappedArrow)
+import Control.Arrow
+import Control.Lens
+import Control.Lens.Internal.Prism
+import Control.Lens.Internal.Profunctor
+import Control.Monad
+import Data.Bifunctor.Clown
+import Data.Bifunctor.Joker
+import Data.Bifunctor.Product
+import Data.Distributive
+import Data.Functor.Compose
+import Data.Functor.Contravariant.Divisible
+import Data.Profunctor hiding (WrappedArrow)
+import Data.Profunctor qualified as Pro (WrappedArrow)
+import Data.Profunctor.Cayley
+import Data.Profunctor.Composition
+import Data.Profunctor.Monad
+import Data.Profunctor.Yoneda
+import Text.ParserCombinators.ReadP (ReadP)
+import Witherable
+
+-- Orphanage --
+instance (Profunctor p, Functor f)
+  => Functor (WrappedPafb f p a) where fmap = rmap
+deriving via Compose (p a) f instance
+  (Profunctor p, Functor (p a), Filterable f)
+    => Filterable (WrappedPafb f p a)
+instance (Profunctor p, Filterable f)
+  => Cochoice (WrappedPafb f p) where
+    unleft (WrapPafb p) = WrapPafb $
+      dimap Left (mapMaybe (either Just (const Nothing))) p
+    unright (WrapPafb p) = WrapPafb $
+      dimap Right (mapMaybe (either (const Nothing) Just)) p
+instance (Profunctor p, Filterable (p a))
+  => Filterable (Yoneda p a) where
+    catMaybes = proreturn . catMaybes . proextract
+instance (Profunctor p, Filterable (p a))
+  => Filterable (Coyoneda p a) where
+    catMaybes = proreturn . catMaybes . proextract
+instance Filterable f => Filterable (Star f a) where
+  catMaybes (Star f) = Star (catMaybes . f)
+instance Monoid r => Applicative (Forget r a) where
+  pure _ = Forget mempty
+  Forget f <*> Forget g = Forget (f <> g)
+instance Filterable (Forget r a) where
+  catMaybes (Forget f) = Forget f
+instance Decidable f => Applicative (Clown f a) where
+  pure _ = Clown conquer
+  Clown x <*> Clown y = Clown (divide (id &&& id) x y)
+deriving newtype instance Applicative f => Applicative (Joker f a)
+deriving newtype instance Alternative f => Alternative (Joker f a)
+deriving newtype instance Filterable f => Filterable (Joker f a)
+deriving newtype instance Monad m => Monad (Joker m a)
+deriving newtype instance MonadFail m => MonadFail (Joker m a)
+deriving newtype instance MonadPlus m => MonadPlus (Joker m a)
+instance Filterable f => Cochoice (Joker f) where
+  unleft (Joker x) = Joker
+    (mapMaybe (either Just (const Nothing)) x)
+  unright (Joker x) = Joker
+    (mapMaybe (either (const Nothing) Just) x)
+instance Filterable ReadP where
+  catMaybes m = m >>= maybe empty pure
+deriving via Compose (p a) f instance
+  (Profunctor p, Applicative (p a), Applicative f)
+    => Applicative (WrappedPafb f p a)
+deriving via Compose (p a) f instance
+  (Profunctor p, Alternative (p a), Applicative f)
+    => Alternative (WrappedPafb f p a)
+instance (Closed p, Distributive f)
+  => Closed (WrappedPafb f p) where
+    closed (WrapPafb p) = WrapPafb (rmap distribute (closed p))
+deriving via (Ap.WrappedArrow p a) instance Arrow p
+  => Functor (Pro.WrappedArrow p a)
+deriving via (Ap.WrappedArrow p a) instance Arrow p
+  => Applicative (Pro.WrappedArrow p a)
+deriving via (Pro.WrappedArrow p) instance Arrow p
+  => Profunctor (Ap.WrappedArrow p)
+instance
+  ( forall x. Applicative (p x), Profunctor p
+  , Applicative (q a), Profunctor q
+  ) => Applicative (Procompose p q a) where
+    pure b = Procompose (pure b) (pure b)
+    Procompose wb aw <*> Procompose vb av = Procompose
+      (liftA2 ($) (lmap fst wb) (lmap snd vb))
+      (liftA2 (,) aw av)
+instance (forall x. Applicative (p x), forall x. Applicative (q x))
+  => Applicative (Product p q a) where
+    pure b = Pair (pure b) (pure b)
+    Pair x0 y0 <*> Pair x1 y1 = Pair (x0 <*> x1) (y0 <*> y1)
+instance (Functor f, Functor (p a)) => Functor (Cayley f p a) where
+  fmap f (Cayley x) = Cayley (fmap (fmap f) x)
+instance (Applicative f, Applicative (p a)) => Applicative (Cayley f p a) where
+  pure b = Cayley (pure (pure b))
+  Cayley x <*> Cayley y = Cayley ((<*>) <$> x <*> y)
+instance (Profunctor p, Applicative (p a))
+  => Applicative (Yoneda p a) where
+    pure = proreturn . pure
+    ab <*> cd = proreturn (proextract ab <*> proextract cd)
+instance (Profunctor p, Applicative (p a))
+  => Applicative (Coyoneda p a) where
+    pure = proreturn . pure
+    ab <*> cd = proreturn (proextract ab <*> proextract cd)
+instance (Profunctor p, Alternative (p a))
+  => Alternative (Yoneda p a) where
+    empty = proreturn empty
+    ab <|> cd = proreturn (proextract ab <|> proextract cd)
+    many = proreturn . many . proextract
+instance (Profunctor p, Alternative (p a))
+  => Alternative (Coyoneda p a) where
+    empty = proreturn empty
+    ab <|> cd = proreturn (proextract ab <|> proextract cd)
+    many = proreturn . many . proextract
+instance Applicative (Market a b s) where
+  pure t = Market (pure t) (pure (Left t))
+  Market f0 g0 <*> Market f1 g1 = Market
+    (\b -> f0 b (f1 b))
+    (\s ->
+      case g0 s of
+        Left bt -> case g1 s of
+          Left b -> Left (bt b)
+          Right a -> Right a
+        Right a -> Right a
+    )
diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs
--- a/src/Control/Lens/Grammar/Kleene.hs
+++ b/src/Control/Lens/Grammar/Kleene.hs
@@ -1,6 +1,6 @@
 {- |
 Module      : Control.Lens.Grammar.Kleene
-Description : Kleene star algebras & regular expressions
+Description : Kleene star algebras, regular expressions & token classes
 Copyright   : (C) 2026 - Eitan Chatav
 License     : BSD-style (see the file LICENSE)
 Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
@@ -29,6 +29,7 @@
 import Control.Lens.Grammar.Boole
 import Control.Lens.Grammar.Symbol
 import Control.Lens.Grammar.Token
+import Data.Bifunctor.Joker
 import Data.Foldable
 import Data.MemoTrie
 import Data.Monoid
@@ -37,6 +38,8 @@
 import Data.Set (Set)
 import qualified Data.Set as Set
 import GHC.Generics
+import Text.ParserCombinators.ReadP (ReadP)
+import qualified Text.ParserCombinators.ReadP as ReadP
 
 {- | A `KleeneStarAlgebra` is a ring
 with a generally non-commutative multiplication,
@@ -217,6 +220,11 @@
     NotOneOf as catTest -> RegExam (NotOneOf as catTest)
     Alternate exam1 exam2 ->
       RegExam (Alternate (tokenClass exam1) (tokenClass exam2))
+instance TokenAlgebra token (f token)
+  => TokenAlgebra token (Joker f token token) where
+    tokenClass = Joker . tokenClass
+instance TokenAlgebra Char (ReadP Char) where
+  tokenClass = ReadP.satisfy . tokenClass
 instance Categorized token => Monoid (RegEx token) where
   mempty = SeqEmpty
 instance Categorized token => Semigroup (RegEx token) where
diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs
--- a/src/Control/Lens/Grammar/Symbol.hs
+++ b/src/Control/Lens/Grammar/Symbol.hs
@@ -17,17 +17,26 @@
 import Control.Lens
 import Control.Lens.PartialIso
 import Control.Lens.Grammar.Token
+import Data.Bifunctor.Joker
 import Data.Profunctor
 import Data.Profunctor.Monoidal
+import Text.ParserCombinators.ReadP (ReadP, string)
 
 -- | A `terminal` symbol in a grammar.
 class TerminalSymbol token s | s -> token where
   terminal :: [token] -> s
   default terminal
-    :: (p () () ~ s, Tokenized token (p token token), Monoidal p, Cochoice p)
+    :: (p () () ~ s, Tokenized token (p token token), Monoidal p, Choice p, Cochoice p)
     => [token] -> s
-  terminal = foldr (\a p -> only a ?< token a *> p) oneP
+  terminal str = only str ?< tokens str
 
 -- | A `nonTerminal` symbol in a grammar.
 class NonTerminalSymbol s where
   nonTerminal :: String -> s
+
+-- instances
+instance TerminalSymbol token (f ())
+  => TerminalSymbol token (Joker f () ()) where
+    terminal = Joker . terminal @token
+instance TerminalSymbol Char (ReadP ()) where
+  terminal str = string str *> pure ()
diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs
--- a/src/Control/Lens/Grammar/Token.hs
+++ b/src/Control/Lens/Grammar/Token.hs
@@ -20,10 +20,13 @@
 
 import Control.Lens
 import Control.Lens.PartialIso
+import Data.Bifunctor.Joker
 import Data.Char
 import Data.Profunctor
 import Data.Profunctor.Monoidal
 import Data.Word
+import Text.ParserCombinators.ReadP (ReadP)
+import qualified Text.ParserCombinators.ReadP as ReadP
 
 {- | `Categorized` provides a type family `Categorize`
 and a function to `categorize` tokens into disjoint categories.
@@ -96,14 +99,6 @@
     => Categorize token -> p
   notAsIn = satisfy . notAsIn
 
-instance Categorized token => Tokenized token (token -> Bool) where
-  anyToken _ = True
-  token = (==)
-  oneOf = flip elem
-  notOneOf = flip notElem
-  asIn = lmap categorize . (==)
-  notAsIn = lmap categorize . (/=)
-
 {- | A single token that satisfies a predicate. -}
 satisfy
   :: (Tokenized a (p a a), Choice p, Cochoice p)
@@ -118,3 +113,27 @@
      )
   => f a -> p s s
 tokens = foldr ((>:<) . token) asEmpty
+
+-- instances
+instance Categorized token => Tokenized token (token -> Bool) where
+  anyToken _ = True
+  token = (==)
+  oneOf = flip elem
+  notOneOf = flip notElem
+  asIn = lmap categorize . (==)
+  notAsIn = lmap categorize . (/=)
+instance Tokenized token (f token)
+  => Tokenized token (Joker f token token) where
+    anyToken = Joker (anyToken @token)
+    token = Joker . token @token
+    oneOf = Joker . oneOf @token
+    notOneOf = Joker . notOneOf @token
+    asIn = Joker . asIn @token
+    notAsIn = Joker . notAsIn @token
+instance Tokenized Char (ReadP Char) where
+  anyToken = ReadP.get
+  token = ReadP.char
+  oneOf = ReadP.satisfy . oneOf
+  notOneOf = ReadP.satisfy . notOneOf
+  asIn = ReadP.satisfy . asIn
+  notAsIn = ReadP.satisfy . notAsIn
diff --git a/src/Control/Lens/Internal/NestedPrismTH.hs b/src/Control/Lens/Internal/NestedPrismTH.hs
deleted file mode 100644
--- a/src/Control/Lens/Internal/NestedPrismTH.hs
+++ /dev/null
@@ -1,342 +0,0 @@
-{- |
-Module      : Control.Lens.Internal.NestedPrismTH
-Description : nested pair prisms
-Copyright   : (C) 2026 - Eitan Chatav
-License     : BSD-style (see the file LICENSE)
-Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
-Stability   : provisional
-Portability : non-portable
-
-Code is duplicated from `Control.Lens.Internal.PrismTH`,
-with small tweaks to support nested pairs.
--}
-
-module Control.Lens.Internal.NestedPrismTH
-  ( -- * Nested prisms
-    makeNestedPrisms
-  ) where
-
-import Control.Applicative
-import Control.Lens.Getter
-import Control.Lens.Internal.TH
-import Control.Lens.Lens
-import Control.Monad
-import Data.Char (isUpper)
-import qualified Data.List as List
-import Data.Set.Lens
-import Data.Traversable
-import Language.Haskell.TH
-import qualified Language.Haskell.TH.Datatype as D
-import Language.Haskell.TH.Lens
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.Set (Set)
-import Prelude
-
--- | Similar to `Control.Lens.Internal.PrismTH.makePrisms`,
--- `makeNestedPrisms` generates a `Control.Lens.Prism.Prism`
--- for each constructor of a data type.
--- `Control.Lens.Iso.Iso`s are generated when possible.
--- `Control.Lens.Review.Review`s are generated for constructors
--- with existentially quantified constructors and GADTs.
--- The difference in `makeNestedPrisms`
--- is that constructors with @n > 2@ arguments
--- will use right-nested pairs, rather than a flat @n@-tuple.
--- This makes them suitable for pattern bonding,
--- by use of the applicator `Control.Lens.PartialIso.>?`
--- to `Data.Profunctor.Monoidal.Monoidal` idiom notation
--- with `Data.Profunctor.Monoidal.>*<`,
--- or to `Data.Profunctor.Monadic.Monadic` qualified do-notation.
---
--- /e.g./
---
--- @
--- data FooBar a
---   = Foo a
---   | Bar Int
---   | Baz Int Char
---   | Buzz Double String Bool
---   | Boop
--- makeNestedPrisms ''FooBar
--- @
---
--- will create
---
--- @
--- _Foo :: Prism (FooBarBaz a) (FooBarBaz b) a b
--- _Bar :: Prism' (FooBarBaz a) Int
--- _Baz :: Prism' (FooBarBaz a) (Int, Char)
--- _Buzz :: Prism' (FooBarBaz a) (Double, (String, Bool))
--- _Boop :: Prism' (FooBarBaz a) ()
--- @
-makeNestedPrisms :: Name -> DecsQ
-makeNestedPrisms typeName =
-  do info <- D.reifyDatatype typeName
-     let cons = D.datatypeCons info
-     makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons)
-
--- Generate prisms for the given type, and normalized constructors.
--- This function dispatches between Iso generation, and normal top-level
-makeConsPrisms :: Type -> [NCon] -> DecsQ
--- special case: single constructor -> make iso
-makeConsPrisms t [con@(NCon _ [] [] _)] = makeConIso t con
--- top-level definitions
-makeConsPrisms t cons =
-  fmap concat $ for cons $ \con ->
-    do let conName = view nconName con
-       stab <- computeOpticType t cons con
-       let n = prismName conName
-       sequenceA
-         ( [ sigD n (return (quantifyType [] (stabToType Set.empty stab)))
-           , valD (varP n) (normalB (makeConOpticExp stab cons con)) []
-           ]
-           ++ inlinePragma n
-         )
-
-data OpticType = PrismType | ReviewType
-
-data Stab  = Stab Cxt OpticType Type Type Type Type
-
-stabSimple :: Stab -> Bool
-stabSimple (Stab _ _ s t a b) = s == t && a == b
-
-stabToType :: Set Name -> Stab -> Type
-stabToType clsTVBNames stab@(Stab cx ty s t a b) =
-  quantifyType' clsTVBNames cx stabTy
-  where
-  stabTy =
-    case ty of
-      PrismType  | stabSimple stab -> prism'TypeName  `conAppsT` [t,b]
-                 | otherwise       -> prismTypeName   `conAppsT` [s,t,a,b]
-      ReviewType                   -> reviewTypeName  `conAppsT` [t,b]
-
-stabType :: Stab -> OpticType
-stabType (Stab _ o _ _ _ _) = o
-
-computeOpticType :: Type -> [NCon] -> NCon -> Q Stab
-computeOpticType t cons con =
-  do let cons' = List.delete con cons
-     if null (_nconVars con)
-         then computePrismType t (view nconCxt con) cons' con
-         else computeReviewType t (view nconCxt con) (view nconTypes con)
-
-computeReviewType :: Type -> Cxt -> [Type] -> Q Stab
-computeReviewType s' cx tys =
-  do let t = s'
-     s <- fmap VarT (newName "s")
-     a <- fmap VarT (newName "a")
-     b <- toNestedPairT (map return tys)
-     return (Stab cx ReviewType s t a b)
-
--- Compute the full type-changing Prism type given an outer type,
--- list of constructors, and target constructor name. Additionally
--- return 'True' if the resulting type is a "simple" prism.
-computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab
-computePrismType t cx cons con =
-  do let ts      = view nconTypes con
-         unbound = setOf typeVars t Set.\\ setOf typeVars cons
-     sub <- sequenceA (Map.fromSet (newName . nameBase) unbound)
-     b   <- toNestedPairT (map return ts)
-     a   <- toNestedPairT (map return (substTypeVars sub ts))
-     let s = substTypeVars sub t
-     return (Stab cx PrismType s t a b)
-
-computeIsoType :: Type -> [Type] -> TypeQ
-computeIsoType t' fields =
-  do sub <- sequenceA (Map.fromSet (newName . nameBase) (setOf typeVars t'))
-     let t = return                    t'
-         s = return (substTypeVars sub t')
-         b = toNestedPairT (map return                    fields)
-         a = toNestedPairT (map return (substTypeVars sub fields))
-         ty | Map.null sub = appsT (conT iso'TypeName) [t,b]
-            | otherwise    = appsT (conT isoTypeName) [s,t,a,b]
-     quantifyType [] <$> ty
-
--- Construct either a Review or Prism as appropriate
-makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ
-makeConOpticExp stab cons con =
-  case stabType stab of
-    PrismType  -> makeConPrismExp stab cons con
-    ReviewType -> makeConReviewExp con
-
--- Construct an iso declaration
-makeConIso :: Type -> NCon -> DecsQ
-makeConIso s con =
-  do let ty      = computeIsoType s (view nconTypes con)
-         defName = prismName (view nconName con)
-     sequenceA
-       ( [ sigD       defName  ty
-         , valD (varP defName) (normalB (makeConIsoExp con)) []
-         ] ++
-         inlinePragma defName
-       )
-
--- Construct prism expression
---
--- prism <<reviewer>> <<remitter>>
-makeConPrismExp ::
-  Stab ->
-  [NCon] {- ^ constructors       -} ->
-  NCon   {- ^ target constructor -} ->
-  ExpQ
-makeConPrismExp stab cons con = appsE [varE prismValName, reviewer, remitter]
-  where
-  ts = view nconTypes con
-  fields  = length ts
-  conName = view nconName con
-  reviewer                   = makeReviewer       conName fields
-  remitter | stabSimple stab = makeSimpleRemitter conName (length cons) fields
-           | otherwise       = makeFullRemitter cons conName
-
--- Construct an Iso expression
---
--- iso <<reviewer>> <<remitter>>
-makeConIsoExp :: NCon -> ExpQ
-makeConIsoExp con = appsE [varE isoValName, remitter, reviewer]
-  where
-  conName = view nconName con
-  fields  = length (view nconTypes con)
-  reviewer = makeReviewer    conName fields
-  remitter = makeIsoRemitter conName fields
-
--- Construct a Review expression
---
--- unto (\(x,y,z) -> Con x y z)
-makeConReviewExp :: NCon -> ExpQ
-makeConReviewExp con = appE (varE untoValName) reviewer
-  where
-  conName = view nconName con
-  fields  = length (view nconTypes con)
-  reviewer = makeReviewer conName fields
-
-------------------------------------------------------------------------
--- Prism and Iso component builders
-------------------------------------------------------------------------
-
--- Construct the review portion of a prism.
---
--- (\(x,y,z) -> Con x y z) :: b -> t
-makeReviewer :: Name -> Int -> ExpQ
-makeReviewer conName fields =
-  do xs <- newNames "x" fields
-     lam1E (toNestedPairP (map varP xs))
-           (conE conName `appsE1` map varE xs)
-
--- Construct the remit portion of a prism.
--- Pattern match only target constructor, no type changing
---
--- (\x -> case s of
---          Con x y z -> Right (x,y,z)
---          _         -> Left x
--- ) :: s -> Either s a
-makeSimpleRemitter ::
-  Name {- The name of the constructor on which this prism focuses -} ->
-  Int  {- The number of constructors the parent data type has     -} ->
-  Int  {- The number of fields the constructor has                -} ->
-  ExpQ
-makeSimpleRemitter conName numCons fields =
-  do x  <- newName "x"
-     xs <- newNames "y" fields
-     let matches =
-           [ match (conP conName (map varP xs))
-                   (normalB (appE (conE rightDataName) (toNestedPairE (map varE xs))))
-                   []
-           ] ++
-           [ match wildP (normalB (appE (conE leftDataName) (varE x))) []
-           | numCons > 1 -- Only generate a catch-all case if there is at least
-                         -- one constructor besides the one being focused on.
-           ]
-     lam1E (varP x) (caseE (varE x) matches)
-
--- Pattern match all constructors to enable type-changing
---
--- (\x -> case s of
---          Con x y z -> Right (x,y,z)
---          Other_n w   -> Left (Other_n w)
--- ) :: s -> Either t a
-makeFullRemitter :: [NCon] -> Name -> ExpQ
-makeFullRemitter cons target =
-  do x <- newName "x"
-     lam1E (varP x) (caseE (varE x) (map mkMatch cons))
-  where
-  mkMatch (NCon conName _ _ n) =
-    do xs <- newNames "y" (length n)
-       match (conP conName (map varP xs))
-             (normalB
-               (if conName == target
-                  then appE (conE rightDataName) (toNestedPairE (map varE xs))
-                  else appE (conE leftDataName) (conE conName `appsE1` map varE xs)))
-             []
-
--- Construct the remitter suitable for use in an 'Iso'
---
--- (\(Con x y z) -> (x,y,z)) :: s -> a
-makeIsoRemitter :: Name -> Int -> ExpQ
-makeIsoRemitter conName fields =
-  do xs <- newNames "x" fields
-     lam1E (conP conName (map varP xs))
-           (toNestedPairE (map varE xs))
-
-------------------------------------------------------------------------
--- Utilities
-------------------------------------------------------------------------
-
--- Normalized constructor
-data NCon = NCon
-  { _nconName :: Name
-  , _nconVars :: [Name]
-  , _nconCxt  :: Cxt
-  , _nconTypes :: [Type]
-  }
-  deriving (Eq)
-instance HasTypeVars NCon where
-  typeVarsEx s f (NCon x vars y z) = NCon x vars <$> typeVarsEx s' f y <*> typeVarsEx s' f z
-    where s' = List.foldl' (flip Set.insert) s vars
-
-nconName :: Lens' NCon Name
-nconName f x = fmap (\y -> x {_nconName = y}) (f (_nconName x))
-
-nconCxt :: Lens' NCon Cxt
-nconCxt f x = fmap (\y -> x {_nconCxt = y}) (f (_nconCxt x))
-
-nconTypes :: Lens' NCon [Type]
-nconTypes f x = fmap (\y -> x {_nconTypes = y}) (f (_nconTypes x))
-
--- Normalize a single 'Con' to its constructor name and field types.
-normalizeCon :: D.ConstructorInfo -> NCon
-normalizeCon info = NCon (D.constructorName info)
-                         (D.tvName <$> D.constructorVars info)
-                         (D.constructorContext info)
-                         (D.constructorFields info)
-
--- Compute a prism's name by prefixing an underscore for normal
--- constructors and period for operators.
-prismName ::
-  Name {- type constructor        -} ->
-  Name {- prism name              -}
-prismName n =
-  case nameBase n of
-    [] -> error "prismName: empty name base?"
-    nb@(x:_) | isUpper x -> mkName (prefix '_' nb)
-             | otherwise -> mkName (prefix '.' nb) -- operator
-  where
-    prefix :: Char -> String -> String
-    prefix char str = char:str
-
--- Construct a tuple type given a list of types.
-toNestedPairT :: [TypeQ] -> TypeQ
-toNestedPairT [] = appsT (tupleT 0) []
-toNestedPairT [x] = x
-toNestedPairT (x:xs) = appsT (tupleT 2) [x, toNestedPairT xs]
-
--- Construct a tuple value given a list of expressions.
-toNestedPairE :: [ExpQ] -> ExpQ
-toNestedPairE [] = tupE []
-toNestedPairE [x] = x
-toNestedPairE (x:xs) = tupE [x, toNestedPairE xs]
-
--- Construct a tuple pattern given a list of patterns.
-toNestedPairP :: [PatQ] -> PatQ
-toNestedPairP [] = tupP []
-toNestedPairP [x] = x
-toNestedPairP (x:xs) = tupP [x, toNestedPairP xs]
diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs
--- a/src/Control/Lens/PartialIso.hs
+++ b/src/Control/Lens/PartialIso.hs
@@ -11,8 +11,6 @@
 [Invertible syntax descriptions](https://www.informatik.uni-marburg.de/~rendel/unparse/)
 -}
 
-{-# OPTIONS_GHC -Wno-orphans #-}
-
 module Control.Lens.PartialIso
   ( -- * PartialIso
     dimapMaybe
@@ -55,15 +53,13 @@
   ) where
 
 import Control.Lens
-import Control.Lens.Internal.NestedPrismTH
+import Control.Lens.Grammar.Internal.Orphanage ()
+import Control.Lens.Grammar.Internal.NestedPrismTH
 import Control.Lens.Internal.Profunctor
 import Control.Lens.Iso
 import Control.Lens.Prism
 import Control.Monad
-import Data.Functor.Compose
 import Data.Profunctor
-import Data.Profunctor.Monad
-import Data.Profunctor.Yoneda
 import Witherable
 
 {- | The `dimapMaybe` function endows
@@ -333,27 +329,3 @@
 difoldr pattern
   = dimap (Empty,) (fmap snd)
   . difoldr1 pattern
-
--- Orphanage --
-
-instance (Profunctor p, Functor f)
-  => Functor (WrappedPafb f p a) where fmap = rmap
-deriving via Compose (p a) f instance
-  (Profunctor p, Functor (p a), Filterable f)
-    => Filterable (WrappedPafb f p a)
-instance (Profunctor p, Filterable f)
-  => Cochoice (WrappedPafb f p) where
-    unleft (WrapPafb p) = WrapPafb $
-      dimap Left (mapMaybe (either Just (const Nothing))) p
-    unright (WrapPafb p) = WrapPafb $
-      dimap Right (mapMaybe (either (const Nothing) Just)) p
-instance (Profunctor p, Filterable (p a))
-  => Filterable (Yoneda p a) where
-    catMaybes = proreturn . catMaybes . proextract
-instance (Profunctor p, Filterable (p a))
-  => Filterable (Coyoneda p a) where
-    catMaybes = proreturn . catMaybes . proextract
-instance Filterable (Forget r a) where
-  catMaybes (Forget f) = Forget f
-instance Filterable f => Filterable (Star f a) where
-  catMaybes (Star f) = Star (catMaybes . f)
diff --git a/src/Control/Monad/Fail/Try.hs b/src/Control/Monad/Fail/Try.hs
--- a/src/Control/Monad/Fail/Try.hs
+++ b/src/Control/Monad/Fail/Try.hs
@@ -17,25 +17,35 @@
   , MonadPlus (..)
     -- * Alternative
   , Alternative (..)
+    -- * Filterable
+  , Filterable (..)
   ) where
 
 import Control.Applicative
+import Control.Lens.Grammar.BackusNaur
+import Control.Lens.PartialIso ()
 import Control.Monad
+import Data.Bifunctor.Joker
+import Text.ParserCombinators.ReadP (ReadP)
+import Witherable
 
-{- | `MonadTry` is a failure handling interface,
-with `fail` & `try` and redundant alternation operators.
+{- | `MonadTry` is a failure handling interface, with `fail` & `try`
+and redundant alternation & filtration operators.
 
 prop> empty = mzero
 prop> (<|>) = mplus
+prop> filter = mfilter
 
-When a `MonadTry` is also a
-`Control.Lens.Grammar.BackusNaur.BackusNaurForm`,
-then the following invariant should hold.
+`MonadTry` also supports the `BackusNaurForm` interface
+for tracing failures and the following invariant should hold.
 
 prop> fail label = rule label empty
 
 -}
-class (MonadFail m, MonadPlus m) => MonadTry m where
+class
+  ( MonadFail m, MonadPlus m, Filterable m
+  , forall x. BackusNaurForm (m x)
+  ) => MonadTry m where
 
   {- | A handler for failures.
   Used for backtracking state on failure in
@@ -44,3 +54,7 @@
   try :: m a -> m a
   default try :: m a -> m a
   try = id
+
+instance MonadTry m => MonadTry (Joker m a) where
+  try = Joker . try . runJoker
+instance MonadTry ReadP
diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs
--- a/src/Data/Profunctor/Distributor.hs
+++ b/src/Data/Profunctor/Distributor.hs
@@ -276,3 +276,9 @@
   alternate (Right p) = proreturn (alternate (Right (proextract p)))
   someP = proreturn . someP . proextract
   optionP def = proreturn . optionP def . proextract
+instance Alternative f => Alternator (Joker f) where
+  alternate (Left (Joker x)) = Joker (Left <$> x)
+  alternate (Right (Joker y)) = Joker (Right <$> y)
+  someP (Joker x) = Joker (some x)
+  optionP def (Joker x) =
+    Joker (x <|> withPrism def (\f _ -> pure (f ())))
diff --git a/src/Data/Profunctor/Filtrator.hs b/src/Data/Profunctor/Filtrator.hs
--- a/src/Data/Profunctor/Filtrator.hs
+++ b/src/Data/Profunctor/Filtrator.hs
@@ -19,6 +19,7 @@
 import Control.Lens.PartialIso
 import Control.Lens.Internal.Profunctor
 import Control.Monad
+import Data.Bifunctor.Joker
 import Data.Profunctor
 import Data.Profunctor.Distributor
 import Data.Profunctor.Monad
@@ -38,8 +39,8 @@
   => Filtrator p where
 
     {- |
-    prop> unleft = fst . filtrate
-    prop> unright = snd . filtrate
+    prop> unleft = fst . filtrate = lmap Left . mapMaybe (either Just (const Nothing))
+    prop> unright = snd . filtrate = lmap Right . mapMaybe (either (const Nothing) Just)
 
     `filtrate` is a distant relative to `Data.Either.partitionEithers`.
     `filtrate` can be given a default value for `Monadic`
@@ -99,4 +100,9 @@
   filtrate (PartialExchange f g) =
     ( PartialExchange (f . Left) (either Just (pure Nothing) <=< g)
     , PartialExchange (f . Right) (either (pure Nothing) Just <=< g)
+    )
+instance Filterable f => Filtrator (Joker f) where
+  filtrate (Joker x) =
+    ( Joker (mapMaybe (either Just (const Nothing)) x)
+    , Joker (mapMaybe (either (const Nothing) Just) x)
     )
diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs
--- a/src/Data/Profunctor/Grammar.hs
+++ b/src/Data/Profunctor/Grammar.hs
@@ -40,7 +40,6 @@
 import Data.Void
 import Prelude hiding (id, (.))
 import GHC.Exts
-import Witherable
 
 -- | `Printor` is a simple printer `Profunctor`.
 newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)}
@@ -180,7 +179,8 @@
 instance BackusNaurForm (Parsor s m a b)
 instance (Alternative m, Monad m) => MonadFail (Parsor s m a) where
   fail _ = empty
-instance (Alternative m, Monad m) => MonadTry (Parsor s m a)
+instance (Alternative m, Monad m, Filterable m)
+  => MonadTry (Parsor s m a)
 instance AsEmpty s => Matching s (Parsor s [] a b) where
   word =~ p = case
     [ () | (_, remaining) <- runParsor p Nothing word
@@ -289,7 +289,8 @@
 instance BackusNaurForm (Printor s m a b)
 instance (Alternative m, Monad m) => MonadFail (Printor s m a) where
   fail _ = empty
-instance (Alternative m, Monad m) => MonadTry (Printor s m a)
+instance (Alternative m, Monad m, Filterable m)
+  => MonadTry (Printor s m a)
 
 -- Grammor instances
 instance Functor (Grammor k a) where fmap _ = coerce
diff --git a/src/Data/Profunctor/Grammar/Parsector.hs b/src/Data/Profunctor/Grammar/Parsector.hs
--- a/src/Data/Profunctor/Grammar/Parsector.hs
+++ b/src/Data/Profunctor/Grammar/Parsector.hs
@@ -1,6 +1,6 @@
 {-|
 Module      : Data.Profunctor.Grammar.Parsector
-Description : grammar distributor with errors
+Description : grammar distributor with failures
 Copyright   : (C) 2026 - Eitan Chatav
 License     : BSD-style (see the file LICENSE)
 Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
@@ -18,7 +18,7 @@
   , parsecP
   , unparsecP
   , ParsecState (..)
-  , ParsecError (..)
+  , ParsecFailure (..)
   ) where
 
 import Control.Applicative
@@ -41,10 +41,9 @@
 import Data.Tree
 import GHC.Exts
 import Prelude hiding (id, (.))
-import Witherable
 
 {- | `Parsector` is an invertible @LL(1)@ parser which is intended
-to provide detailed error information, based on [Parsec]
+to provide detailed failure information, based on [Parsec]
 (https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/parsec-paper-letter.pdf).
 -}
 newtype Parsector s a b = Parsector
@@ -91,11 +90,11 @@
   , parsecOffset :: !Word
     -- ^ Number of tokens consumed from the start of the stream.
   , parsecStream :: s -- ^ stream
-  , parsecError  :: ParsecError s
-    {- ^ `ParsecError` channel.
+  , parsecFailure  :: ParsecFailure s
+    {- ^ `ParsecFailure` channel.
 
     * If `parsecResult` is `Nothing`, this is the hard failure.
-    * If `parsecResult` is `Just`, this is deferred error/hint info
+    * If `parsecResult` is `Just`, this is deferred failure/hint info
       from empty-failing alternatives at the current position.
 
     `<|>` and `>>=` propagate and merge this field to preserve
@@ -106,22 +105,22 @@
     As input, `Nothing` means parse mode and
     `Just` means print mode with an input syntax value.
 
-    As output `Nothing` means failure (inspect `parsecError`) and
+    As output `Nothing` means failure (inspect `parsecFailure`) and
     `Just` means success with an output syntax value.
     -}
   }
 
-{- | `ParsecError` is the error payload produced by `Parsector`,
-stored in `parsecError`.
-`ParsecError` is a `Monoid` and `Parsector` merges errors/hints
+{- | `ParsecFailure` is the failure payload produced by `Parsector`,
+stored in `parsecFailure`.
+`ParsecFailure` is a `Monoid` and `Parsector` merges failures/hints
 when control flow reaches the same offset without commitment.
 -}
-data ParsecError s = ParsecError
+data ParsecFailure s = ParsecFailure
   { parsecExpect :: TokenClass (Item s)
     {- ^ Class of expected token `Item`s at the `parsecOffset`.
     `tokenClass`es and `Tokenized` combinators specify expectations.
     Under `<>`, expectations are combined with disjunction `>||<`.
-    In case of a parse error, contrast with the actual `parsecStream`,
+    In case of a parse failure, contrast with the actual `parsecStream`,
     which is either unexpectedly empty or begins with an unexpected token.
     -}
   , parsecLabels :: [Tree String]
@@ -133,21 +132,21 @@
     -}
   }
 
--- ParsecError instances
+-- ParsecFailure instances
 deriving stock instance
   ( Categorized (Item s)
   , Show (Item s), Show (Categorize (Item s))
-  ) => Show (ParsecError s)
+  ) => Show (ParsecFailure s)
 deriving stock instance
   ( Categorized (Item s)
   , Read (Item s), Read (Categorize (Item s))
-  ) => Read (ParsecError s)
-deriving stock instance Categorized (Item s) => Eq (ParsecError s)
-deriving stock instance Categorized (Item s) => Ord (ParsecError s)
-instance Categorized (Item s) => Semigroup (ParsecError s) where
-  ParsecError e1 l1 <> ParsecError e2 l2 = ParsecError (e1 >||< e2) (l1 ++ l2)
-instance Categorized (Item s) => Monoid (ParsecError s) where
-  mempty = ParsecError falseB []
+  ) => Read (ParsecFailure s)
+deriving stock instance Categorized (Item s) => Eq (ParsecFailure s)
+deriving stock instance Categorized (Item s) => Ord (ParsecFailure s)
+instance Categorized (Item s) => Semigroup (ParsecFailure s) where
+  ParsecFailure e1 l1 <> ParsecFailure e2 l2 = ParsecFailure (e1 >||< e2) (l1 ++ l2)
+instance Categorized (Item s) => Monoid (ParsecFailure s) where
+  mempty = ParsecFailure falseB []
 
 -- ParsecState instances
 deriving stock instance Functor (ParsecState s)
@@ -194,13 +193,13 @@
         offset = parsecOffset query
         replyOk tok str = query
           { parsecLooked = True
-          , parsecError  = mempty
+          , parsecFailure  = mempty
           , parsecStream = str
           , parsecOffset = offset + 1
           , parsecResult = Just tok
           }
         replyErr = query
-          { parsecError  = ParsecError test []
+          { parsecFailure  = ParsecFailure test []
           , parsecResult = Nothing }
       in
         callback $ case mode of
@@ -221,9 +220,9 @@
     flip (runParsector p) query $ \reply -> callback $
       case parsecResult reply of
         Nothing -> reply
-          { parsecError =
-              let ParsecError expect labels = parsecError reply
-              in ParsecError expect [Node name labels]
+          { parsecFailure =
+              let ParsecFailure expect labels = parsecFailure reply
+              in ParsecFailure expect [Node name labels]
           }
         Just _ -> reply
   ruleRec name = rule name . fix
@@ -246,10 +245,10 @@
         Nothing -> callback reply { parsecResult = Nothing }
         Just b ->
           let
-            hintP  = parsecError reply
+            hintP  = parsecFailure reply
             fQuery = reply
               { parsecLooked = False
-              , parsecError  = mempty
+              , parsecFailure  = mempty
               , parsecResult = parsecResult query
               }
           in
@@ -258,12 +257,12 @@
                 then fReply
                 else fReply
                   { parsecLooked = parsecLooked reply
-                  , parsecError  = hintP <> parsecError fReply
+                  , parsecFailure  = hintP <> parsecFailure fReply
                   }
 instance Categorized (Item s) => Alternative (Parsector s a) where
   -- | Always fails without consuming input; expects nothing.
   empty = Parsector $ \callback query ->
-    callback query { parsecError = mempty, parsecResult = Nothing }
+    callback query { parsecFailure = mempty, parsecResult = Nothing }
   p <|> q = Parsector $ \callback query ->
     flip (runParsector p) query $ \replyP -> callback $
       case parsecResult replyP of
@@ -273,15 +272,15 @@
         Nothing | parsecLooked replyP -> replyP
         -- if p failed without consuming, try q
         Nothing ->
-          let errP = parsecError replyP
+          let errP = parsecFailure replyP
           in flip (runParsector q) query $ \replyQ ->
           case (parsecLooked replyQ, parsecResult replyQ) of
             -- q consumed (ok or err): propagate as-is, drop errP
             (True, _)         -> replyQ
             -- q empty ok: carry errP forward as hint for downstream
-            (False, Just _)   -> replyQ { parsecError = errP <> parsecError replyQ }
-            -- both empty fail: merge errors
-            (False, Nothing)  -> replyP { parsecError = errP <> parsecError replyQ }
+            (False, Just _)   -> replyQ { parsecFailure = errP <> parsecFailure replyQ }
+            -- both empty fail: merge failures
+            (False, Nothing)  -> replyP { parsecFailure = errP <> parsecFailure replyQ }
 instance Categorized (Item s) => MonadPlus (Parsector s a)
 instance Categorized (Item s) => MonadFail (Parsector s a) where
   fail msg = rule msg empty
@@ -295,7 +294,7 @@
       case parsecResult reply of
         Nothing -> query
           { parsecLooked = False
-          , parsecError  = parsecError reply
+          , parsecFailure  = parsecFailure reply
           , parsecResult = Nothing
           }
         Just _ -> reply
@@ -348,7 +347,7 @@
             Just (Left a)   -> Just a
             Just (Right _)  -> Nothing
         }
-      replyErr = query { parsecError = mempty, parsecResult = Nothing }
+      replyErr = query { parsecFailure = mempty, parsecResult = Nothing }
     in
       case (parsecResult query, parsecResult replyOk) of
         (Just _, Nothing) -> replyErr
@@ -363,7 +362,7 @@
             Just (Left _)   -> Nothing
             Just (Right b)  -> Just b
         }
-      replyErr = query { parsecError = mempty, parsecResult = Nothing }
+      replyErr = query { parsecFailure = mempty, parsecResult = Nothing }
     in
       case (parsecResult query, parsecResult replyOk) of
         (Just _, Nothing) -> replyErr
@@ -382,18 +381,18 @@
     ( Parsector $ \callback query ->
         flip (runParsector p) (Left <$> query) $ \reply ->
           callback reply
-          { parsecError = case parsecResult reply of
+          { parsecFailure = case parsecResult reply of
             Just (Right _) -> mempty
-            _ -> parsecError reply
+            _ -> parsecFailure reply
           , parsecResult =
             parsecResult reply >>= either Just (const Nothing)
           }
     , Parsector $ \callback query ->
         flip (runParsector p) (Right <$> query) $ \reply ->
           callback reply
-          { parsecError = case parsecResult reply of
+          { parsecFailure = case parsecResult reply of
             Just (Left _) -> mempty
-            _ -> parsecError reply
+            _ -> parsecFailure reply
           , parsecResult =
             parsecResult reply >>= either (const Nothing) Just
           }
diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs
--- a/src/Data/Profunctor/Monoidal.hs
+++ b/src/Data/Profunctor/Monoidal.hs
@@ -20,26 +20,10 @@
   , meander, eotFunList
   ) where
 
-import Control.Applicative hiding (WrappedArrow)
-import Control.Applicative qualified as Ap (WrappedArrow)
-import Control.Arrow
-import Control.Lens hiding (chosen)
+import Control.Lens
 import Control.Lens.Internal.Context
-import Control.Lens.Internal.Prism
-import Control.Lens.Internal.Profunctor
 import Control.Lens.PartialIso
-import Data.Bifunctor.Clown
-import Data.Bifunctor.Joker
-import Data.Bifunctor.Product
 import Data.Distributive
-import Data.Functor.Compose
-import Data.Functor.Contravariant.Divisible
-import Data.Profunctor hiding (WrappedArrow)
-import Data.Profunctor qualified as Pro (WrappedArrow)
-import Data.Profunctor.Cayley
-import Data.Profunctor.Composition
-import Data.Profunctor.Monad
-import Data.Profunctor.Yoneda
 import GHC.IsList
 
 -- Monoidal --
@@ -161,11 +145,11 @@
 replicateP n _ | n <= 0 = asEmpty
 replicateP n a = a >:< replicateP (n-1) a
 
-{- | For any `Monoidal`, `Choice` & `Strong` `Profunctor`,
+{- | For any `Monoidal`, `Choice` & `Data.Profunctor.Strong` `Profunctor`,
 `meander` is invertible and gives a default implementation for the
 `Data.Profunctor.Traversing.wander`
 method of `Data.Profunctor.Traversing.Traversing`,
-though `Strong` is not needed for its definition.
+though `Data.Profunctor.Strong` is not needed for its definition.
 
 See Pickering, Gibbons & Wu,
 [Profunctor Optics - Modular Data Accessors](https://arxiv.org/abs/1703.10857)
@@ -217,72 +201,3 @@
     MoreFun a h -> \l ->
       MoreFun a (flip <$> h <*> fromFun l)
 instance Sellable (->) FunList where sell b = MoreFun b (pure id)
-
--- Orphanage --
-
-instance Monoid r => Applicative (Forget r a) where
-  pure _ = Forget mempty
-  Forget f <*> Forget g = Forget (f <> g)
-instance Decidable f => Applicative (Clown f a) where
-  pure _ = Clown conquer
-  Clown x <*> Clown y = Clown (divide (id &&& id) x y)
-deriving newtype instance Applicative f => Applicative (Joker f a)
-deriving via Compose (p a) f instance
-  (Profunctor p, Applicative (p a), Applicative f)
-    => Applicative (WrappedPafb f p a)
-deriving via Compose (p a) f instance
-  (Profunctor p, Alternative (p a), Applicative f)
-    => Alternative (WrappedPafb f p a)
-instance (Closed p, Distributive f)
-  => Closed (WrappedPafb f p) where
-    closed (WrapPafb p) = WrapPafb (rmap distribute (closed p))
-deriving via (Ap.WrappedArrow p a) instance Arrow p
-  => Functor (Pro.WrappedArrow p a)
-deriving via (Ap.WrappedArrow p a) instance Arrow p
-  => Applicative (Pro.WrappedArrow p a)
-deriving via (Pro.WrappedArrow p) instance Arrow p
-  => Profunctor (Ap.WrappedArrow p)
-instance (Monoidal p, Applicative (q a))
-  => Applicative (Procompose p q a) where
-    pure b = Procompose (pure b) (pure b)
-    Procompose wb aw <*> Procompose vb av = Procompose
-      (dimap2 fst snd ($) wb vb)
-      (liftA2 (,) aw av)
-instance (Monoidal p, Monoidal q)
-  => Applicative (Product p q a) where
-    pure b = Pair (pure b) (pure b)
-    Pair x0 y0 <*> Pair x1 y1 = Pair (x0 <*> x1) (y0 <*> y1)
-instance (Functor f, Functor (p a)) => Functor (Cayley f p a) where
-  fmap f (Cayley x) = Cayley (fmap (fmap f) x)
-instance (Applicative f, Applicative (p a)) => Applicative (Cayley f p a) where
-  pure b = Cayley (pure (pure b))
-  Cayley x <*> Cayley y = Cayley ((<*>) <$> x <*> y)
-instance (Profunctor p, Applicative (p a))
-  => Applicative (Yoneda p a) where
-    pure = proreturn . pure
-    ab <*> cd = proreturn (proextract ab <*> proextract cd)
-instance (Profunctor p, Applicative (p a))
-  => Applicative (Coyoneda p a) where
-    pure = proreturn . pure
-    ab <*> cd = proreturn (proextract ab <*> proextract cd)
-instance (Profunctor p, Alternative (p a))
-  => Alternative (Yoneda p a) where
-    empty = proreturn empty
-    ab <|> cd = proreturn (proextract ab <|> proextract cd)
-    many = proreturn . many . proextract
-instance (Profunctor p, Alternative (p a))
-  => Alternative (Coyoneda p a) where
-    empty = proreturn empty
-    ab <|> cd = proreturn (proextract ab <|> proextract cd)
-    many = proreturn . many . proextract
-instance Applicative (Market a b s) where
-  pure t = Market (pure t) (pure (Left t))
-  Market f0 g0 <*> Market f1 g1 = Market
-    (\b -> f0 b (f1 b))
-    (\s ->
-      case g0 s of
-        Left bt -> case g1 s of
-          Left b -> Left (bt b)
-          Right a -> Right a
-        Right a -> Right a
-    )
diff --git a/test/Main.hs b/test/Main.hs
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -4,12 +4,14 @@
 import Control.Lens.Grammar
 import Control.Monad (when)
 import Data.IORef
+import Data.Function (fix)
 import Data.List (genericLength)
 import Data.Maybe (isJust)
 import Data.Profunctor.Types (Star (..))
 import System.Environment (lookupEnv)
 import Test.DocTest
 import Test.Hspec
+import qualified Text.Megaparsec as M
 
 import Examples.Arithmetic
 import Examples.Chain
@@ -138,13 +140,43 @@
       let actualSyntax = parsecG grammar expectedString
       let expectedLength = genericLength expectedString
       let actualLooked = parsecLooked actualSyntax
-      let actualError  = parsecError  actualSyntax
+      let actualFailure  = parsecFailure  actualSyntax
       actualSyntax `shouldBe`
-        (ParsecState actualLooked expectedLength "" actualError (Just expectedSyntax))
+        (ParsecState actualLooked expectedLength "" actualFailure (Just expectedSyntax))
     it ("should unparsecG to " <> expectedString <> " correctly") $ do
       let actualString = unparsecG grammar expectedSyntax ""
       let expectedLength = genericLength expectedString
       let actualLooked = parsecLooked actualString
-      let actualError  = parsecError  actualString
+      let actualFailure  = parsecFailure  actualString
       actualString `shouldBe`
-        (ParsecState actualLooked expectedLength expectedString actualError (Just expectedSyntax))
+        (ParsecState actualLooked expectedLength expectedString actualFailure (Just expectedSyntax))
+    it ("should parse with megaparsec to " <> expectedString <> " correctly") $ do
+      let megaparsec = unwrapMega (monadG grammar)
+      let actualSyntax = M.parse megaparsec "<megaparsec>" expectedString
+      actualSyntax `shouldBe` Right expectedSyntax
+
+newtype WrapMega a = WrapMega {unwrapMega :: M.Parsec String String a}
+  deriving newtype
+    ( Functor, Applicative, Alternative
+    , Monad, MonadPlus, MonadFail
+    )
+instance TerminalSymbol Char (WrapMega ()) where
+  terminal str = WrapMega (M.chunk str *> pure ())
+instance TokenAlgebra Char (WrapMega Char) where
+  tokenClass exam = WrapMega $ M.label (show exam) (M.satisfy (tokenClass exam))
+instance Tokenized Char (WrapMega Char) where
+  anyToken = WrapMega M.anySingle
+  token = WrapMega . M.single
+  oneOf = WrapMega . M.oneOf
+  notOneOf = WrapMega . M.noneOf
+  asIn cat = WrapMega $ M.label ("in category " ++ show cat)
+    (M.satisfy (tokenClass (asIn cat)))
+  notAsIn cat = WrapMega $ M.label ("not in category " ++ show cat)
+    (M.satisfy (tokenClass (notAsIn cat)))
+instance BackusNaurForm (WrapMega a) where
+  rule lbl (WrapMega p) = WrapMega (M.label lbl p)
+  ruleRec lbl = rule lbl . fix
+instance Filterable WrapMega where
+  catMaybes m = m >>= maybe (fail "unrestricted filtration") pure
+instance MonadTry WrapMega where
+  try (WrapMega p) = WrapMega (M.try p)