distributors 0.4.0.0 → 0.5.0.0

raw patch · 20 files changed

+811/−564 lines, 20 filesdep +megaparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: megaparsec

API changes (from Hackage documentation)

Files

• CHANGELOG.md +24/−2
• distributors.cabal +4/−2
• src/Control/Lens/Bifocal.hs +1/−2
• src/Control/Lens/Grammar.hs +86/−11
• src/Control/Lens/Grammar/BackusNaur.hs +46/−17
• src/Control/Lens/Grammar/Boole.hs +1/−2
• src/Control/Lens/Grammar/Internal/NestedPrismTH.hs +342/−0
• src/Control/Lens/Grammar/Internal/Orphanage.hs +140/−0
• src/Control/Lens/Grammar/Kleene.hs +9/−1
• src/Control/Lens/Grammar/Symbol.hs +11/−2
• src/Control/Lens/Grammar/Token.hs +27/−8
• src/Control/Lens/Internal/NestedPrismTH.hs +0/−342
• src/Control/Lens/PartialIso.hs +2/−30
• src/Control/Monad/Fail/Try.hs +20/−6
• src/Data/Profunctor/Distributor.hs +6/−0
• src/Data/Profunctor/Filtrator.hs +8/−2
• src/Data/Profunctor/Grammar.hs +4/−3
• src/Data/Profunctor/Grammar/Parsector.hs +41/−42
• src/Data/Profunctor/Monoidal.hs +3/−88
• test/Main.hs +36/−4

@@ -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`

@@ -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

@@ -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) 

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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+    )

@@ -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

@@ -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 ()

@@ -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

@@ -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]

@@ -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)

@@ -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

@@ -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 ())))

@@ -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)     )

@@ -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

@@ -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           }

@@ -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-    )

@@ -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)