Changes since 0.4

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`

distributors.cabal

@@ -5,7 +5,7 @@ cabal-version: 2.2
 -- 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 @@ library
       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 @@ test-suite test
     , 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

package.yaml

@@ -1,5 +1,5 @@
 name: distributors
-version: 0.4.0.0
+version: 0.5.0.0
 github: "morphismtech/distributors"
 license: BSD-3-Clause
 author: "Eitan Chatav"
@@ -97,4 +97,5 @@ tests:
       - distributors
       - doctest >= 0.18 && < 1
       - hspec >= 2.7 && < 3
+      - megaparsec >= 9.0 && < 10
       - QuickCheck >= 2.14 && < 3

src/Control/Lens/Bifocal.hs

@@ -59,8 +59,7 @@ type Bifocal s t a b = forall p f.
   (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)
 

src/Control/Lens/Grammar.hs

@@ -23,13 +23,16 @@ module Control.Lens.Grammar
   , RegBnf (..)
   , regbnfG
   , regbnfGrammar
+  , applicativeG
     -- * Context-sensitive grammar
   , CtxGrammar
   , printG
   , parseG
   , unparseG
   , parsecG
   , unparsecG
+  , readG
+  , monadG
     -- * Utility
   , putStringLn
     -- * Re-exports
@@ -44,6 +47,7 @@ import Control.Lens.Grammar.Boole
 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.Profunctor.Separator
 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 @@ data SemVer = SemVer          -- e.g., 2.1.5-rc.1+build.123
 
 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 @@ and generator support for `ruleRec`.
 -}
 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 @@ the context-sensitivity of `CtxGrammar` implies
 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 @@ Since both `Parsor` & `Parsector` are @LL@ parsers they
 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,7 +772,7 @@ regbnfGrammar :: Grammar Char RegBnf
 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,
@@ -841,7 +845,7 @@ the type system will allow `parsecG` to be applied to them.
 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 @@ unparsecG
   -> 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 @@ instance IsList RegString where
     = fromMaybe zeroK
     . listToMaybe
     . mapMaybe prsF
-    . parseP regexGrammar
+    . readP_to_S (readG regexGrammar)
     where
       prsF (rex,"") = Just rex
       prsF _ = Nothing
@@ -901,7 +976,7 @@ instance IsList RegBnf where
     = fromMaybe zeroK
     . listToMaybe
     . mapMaybe prsF
-    . parseP regbnfGrammar
+    . readP_to_S (readG regbnfGrammar)
     where
       prsF (regbnf,"") = Just regbnf
       prsF _ = Nothing

src/Control/Lens/Grammar/BackusNaur.hs

@@ -29,35 +29,64 @@ import Control.Lens.Extras
 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 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 name bnf = ruleRec name (\_ -> bnf)
+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 @@ rulesNamed nameX = foldl' (flip inserter) Set.empty where
 -- 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