distributors 0.3.0.0 → 0.4.0.0

raw patch · 35 files changed

+1726/−739 lines, 35 filesdep +QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck

API changes (from Hackage documentation)

Files

• CHANGELOG.md +41/−0
• README.md +1/−1
• distributors.cabal +8/−1
• src/Control/Lens/Bifocal.hs +6/−0
• src/Control/Lens/Diopter.hs +2/−2
• src/Control/Lens/Grammar.hs +209/−99
• src/Control/Lens/Grammar/BackusNaur.hs +19/−17
• src/Control/Lens/Grammar/Boole.hs +17/−145
• src/Control/Lens/Grammar/Kleene.hs +216/−80
• src/Control/Lens/Grammar/Symbol.hs +1/−1
• src/Control/Lens/Grammar/Token.hs +10/−2
• src/Control/Lens/Grate.hs +1/−2
• src/Control/Lens/Internal/NestedPrismTH.hs +32/−11
• src/Control/Lens/Monocle.hs +12/−2
• src/Control/Lens/PartialIso.hs +9/−10
• src/Control/Lens/Wither.hs +1/−3
• src/Control/Monad/Fail/Try.hs +46/−0
• src/Data/Profunctor/Distributor.hs +47/−228
• src/Data/Profunctor/Filtrator.hs +11/−5
• src/Data/Profunctor/Grammar.hs +22/−15
• src/Data/Profunctor/Grammar/Parsector.hs +400/−0
• src/Data/Profunctor/Monadic.hs +23/−5
• src/Data/Profunctor/Monoidal.hs +60/−21
• src/Data/Profunctor/Separator.hs +127/−0
• src/Data/Traversable/Homogeneous.hs +142/−0
• test/Examples/Arithmetic.hs +2/−8
• test/Examples/Chain.hs +36/−0
• test/Examples/Json.hs +2/−9
• test/Examples/Lambda.hs +1/−7
• test/Examples/LenVec.hs +1/−5
• test/Examples/RegString.hs +6/−12
• test/Examples/SExpr.hs +2/−9
• test/Examples/SemVer.hs +7/−11
• test/Main.hs +86/−28
• test/Properties/Kleene.hs +120/−0

@@ -1,5 +1,46 @@ # Changelog for `distributors` +## 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+  via `parsecLooked`, and `try` for explicit backtracking+- `Data.Profunctor.Separator` - Separator/delimiter combinators: `sepWith`, `noSep`,+  `beginWith`, `endWith`, `several`, `several1`, `intercalateP`, `chain`, `chain1`+- `Data.Traversable.Homogeneous` - `Homogeneous` class for static containers with uniform elements;+  `ditraverse` for distributive traversals++### New Combinators++- `Control.Lens.Grammar.Kleene`: `tokenClass` embedding into `RegEx`; `KleeneAlgebra` laws+  as QuickCheck properties; `RegExam` helpers `failExam`, `passExam`, `isFailExam`+- `Control.Lens.Grammar.Boole`: `trueB`, `falseB` added to `BooleanAlgebra`;+  `andB`, `orB`, `allB`, `anyB` fold combinators+- `Data.Profunctor.Monadic`: `MonadicTry` constraint alias; `P.return` combinator;+  improved documentation for qualified do-notation pattern bonding+- `Data.Profunctor.Distributor`: `manyP` / `optionalP` now place the empty case on+  the right of `>+<` for correct LL(1) behaviour (`p >*< manyP p >+< oneP`)++### Changes++- `<|>` in `Parsector` now commits when the left branch consumes input (LL(1));+  use `try` to opt into backtracking+- `TokenTest` renamed to `TokenClass` throughout+- `chain`, `chain1`, `intercalateP` moved from `Data.Profunctor.Distributor`+  to the new `Data.Profunctor.Separator`+- `BackusNaurForm`: `rule` documentation clarified; added reference to Breitner's+  *Showcasing Applicative*++### Testing++- `test/Properties/Kleene` - QuickCheck properties for `KleeneStarAlgebra`,+  `TokenAlgebra`, `BooleanAlgebra TokenClass`+- `test/Examples/Chain` - Chain grammar example+- `test/Main`: `testCtxGrammarExample` extended with `parsecG` / `unparsecG` round-trip checks+ ## 0.3.0.0 - 2026-02-05  ### New Modules

@@ -29,7 +29,7 @@  The idea for unifying Backus-Naur grammars with parsers comes from Joachim Breitner in a post [Showcasing Applicative](https://www.joachim-breitner.de/blog/710-Showcasing_Applicative). -The idea for using monadic profunctors for reversible context-free grammars+The idea for using monadic profunctors for reversible context-sensitive grammars comes from Li-Yao Xia, in some posts and a paper but particularly this post on [Monadic profunctors for bidirectional programming](https://blog.poisson.chat/posts/2017-01-01-monadic-profunctors.html). 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           distributors-version:        0.3.0.0+version:        0.4.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@@ -41,11 +41,15 @@       Control.Lens.Monocle       Control.Lens.PartialIso       Control.Lens.Wither+      Control.Monad.Fail.Try       Data.Profunctor.Distributor       Data.Profunctor.Filtrator       Data.Profunctor.Grammar+      Data.Profunctor.Grammar.Parsector       Data.Profunctor.Monadic       Data.Profunctor.Monoidal+      Data.Profunctor.Separator+      Data.Traversable.Homogeneous   other-modules:       Paths_distributors   autogen-modules:@@ -116,12 +120,14 @@   main-is: Main.hs   other-modules:       Examples.Arithmetic+      Examples.Chain       Examples.Json       Examples.Lambda       Examples.LenVec       Examples.RegString       Examples.SemVer       Examples.SExpr+      Properties.Kleene       Paths_distributors   autogen-modules:       Paths_distributors@@ -168,6 +174,7 @@   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints   build-depends:       MemoTrie >=0.6 && <1+    , QuickCheck >=2.14 && <3     , adjunctions >=4.4 && <5     , base >=4.15 && <5     , bifunctors >=5.5 && <6

@@ -22,6 +22,7 @@     -- * Prismoid   , Prismoid   , somed+  , opted   , lefted   , righted   , chained1@@ -39,6 +40,7 @@ import Data.Profunctor import Data.Profunctor.Distributor import Data.Profunctor.Filtrator+import Data.Profunctor.Separator import Witherable  {- | `Bifocal`s are bidirectional parser optics.@@ -92,6 +94,10 @@ {- | One or more. -} somed :: Prismoid [a] [b] a b somed = unwrapPafb . someP . WrapPafb++{- | One or zero with default. -}+opted :: APrism a b () () -> Prismoid a b a b+opted def = unwrapPafb . optionP def . WrapPafb  {- | `lefted` is like `_Left`, except with heterogeneous `Right` parameters. -}

@@ -27,6 +27,7 @@ import Control.Lens import Control.Lens.Internal.Profunctor import Data.Profunctor.Distributor+import Data.Traversable.Homogeneous import Data.Void import GHC.Generics @@ -41,8 +42,7 @@   (Distributor p, Applicative f)     => p a (f b) -> p s (f t) -{- | If you see `ADiopter` in a signature for a function,-the function is expecting a `Diopter`. -}+{- | `ADiopter` is monomorphically a `Diopter`. -} type ADiopter s t a b =   Dioptrice a b a (Identity b) -> Dioptrice a b s (Identity t) 

@@ -28,8 +28,12 @@   , printG   , parseG   , unparseG+  , parsecG+  , unparsecG     -- * Utility   , putStringLn+    -- * Re-exports+  , module X   ) where  import Control.Applicative@@ -47,17 +51,34 @@ import Data.Profunctor.Monadic import Data.Profunctor.Monoidal import Data.Profunctor.Grammar-import qualified Data.Set as Set+import Data.Profunctor.Grammar.Parsector+import Data.Profunctor.Separator import Data.String import GHC.Exts import Prelude hiding (filter) import Witherable +-- Re-exports+import Control.Lens.Grammar.BackusNaur as X+import Control.Lens.Grammar.Boole as X+import Control.Lens.Grammar.Kleene as X+import Control.Lens.Grammar.Symbol as X+import Control.Lens.Grammar.Token as X+import Control.Lens.PartialIso as X+import Control.Monad.Fail.Try as X+import Data.Profunctor.Distributor as X+import Data.Profunctor.Filtrator as X+import Data.Profunctor.Grammar as X+import Data.Profunctor.Grammar.Parsector as X+import Data.Profunctor.Monoidal as X+import Data.Profunctor.Separator as X+import Data.Traversable.Homogeneous as X+ {- | A regular grammar may be constructed using `Lexical` and `Alternator` combinators. Let's see an example using-[semantic versioning](https://semver.org/).+[semantic versioning](https://semver.org/) syntax.  >>> import Numeric.Natural (Natural) >>> :{@@ -73,12 +94,17 @@  We'd like to define an optic @_SemVer@, corresponding to the constructor pattern @SemVer@.+You _could_ generate it with the TemplateHaskell combinator,+`makeNestedPrisms`.++@makeNestedPrisms ''SemVer@+ Unfortunately, we can't use TemplateHaskell to generate it in [GHCi] (https://wiki.haskell.org/GHC/GHCi), which is used to test this documenation.-Normally we would write `makeNestedPrisms` @''SemVer@,-but here is equivalent explicit Haskell code instead.-Since @SemVer@ is a newtype, @_SemVer@ can be an `Control.Lens.Iso.Iso`.+Here is equivalent Haskell code instead.+Since @SemVer@ has only one constructor,+@_SemVer@ can be an `Control.Lens.Iso.Iso`.  >>> :set -XRecordWildCards >>> import Control.Lens (Iso', iso)@@ -98,11 +124,11 @@   >?  numberG   >*< terminal "." >* numberG   >*< terminal "." >* numberG-  >*< option [] (terminal "-" >* identifiersG)-  >*< option [] (terminal "+" >* identifiersG)+  >*< optionP _Empty (terminal "-" >* identifiersG)+  >*< optionP _Empty (terminal "+" >* identifiersG)   where     numberG = iso show read >~ someP (asIn @Char DecimalNumber)-    identifiersG = several1 (sepBy (terminal ".")) (someP charG)+    identifiersG = several1 (sepWith ".") (someP charG)     charG = asIn LowercaseLetter       <|> asIn UppercaseLetter       <|> asIn DecimalNumber@@ -122,15 +148,17 @@ +------------+---------------+ | `<$>`      | `>?`          | +------------+---------------++| `pure`     | `pureP`       |++------------+---------------+ | `*>`       | `>*`          | +------------+---------------+ | `<*`       | `*<`          | +------------+---------------+ | `<*>`      | `>*<`         | +------------+---------------+-| `<|>`      | `<|>`         |+| `empty`    | `empty`       | +------------+---------------+-| `option`   | `option`      |+| `<|>`      | `<|>`         | +------------+---------------+ | `choice`   | `choice`      | +------------+---------------+@@ -212,16 +240,16 @@ arithGrammar = ruleRec "arith" sumG   where     sumG arith = rule "sum" $-      chain1 Left _Add (sepBy (terminal "+")) (prodG arith)+      chain1 Left _Add (sepWith "+") (prodG arith)     prodG arith = rule "product" $-      chain1 Left _Mul (sepBy (terminal "*")) (factorG arith)+      chain1 Left _Mul (sepWith "*") (factorG arith)     factorG arith = rule "factor" $       numberG <|> terminal "(" >* arith *< terminal ")"     numberG = rule "number" $       _Num . iso show read >? someP (asIn @Char DecimalNumber) :} -We can generate a `RegBnf`, printers and parsers from @arithGrammar@.+We can generate grammar strings, printers and parsers from @arithGrammar@.  >>> putStringLn (regbnfG arithGrammar) {start} = \q{arith}@@ -230,14 +258,20 @@ {number} = \p{Nd}+ {product} = \q{factor}(\*\q{factor})* {sum} = \q{product}(\+\q{product})*- >>> [x | (x,"") <- parseG arithGrammar "1+2*3+4"] [Add (Add (Num 1) (Mul (Num 2) (Num 3))) (Num 4)] >>> unparseG arithGrammar (Add (Num 1) (Mul (Num 2) (Num 3))) "" :: Maybe String Just "1+2*3"->>> do pr <- printG arithGrammar (Num 69); return (pr "") :: Maybe String+>>> do pr <- printG arithGrammar (Num 69); pure (pr "") :: Maybe String Just "69" +If all `rule`s are non-recursive, then a `Grammar`+can be rewritten as a `RegGrammar`.+Since Haskell permits general recursion, and `RegGrammar`s are+embedded in Haskell, you can define context-free grammars with them.+But it's recommended to use `Grammar`s for `rule` abstraction+and generator support for `ruleRec`.+ -} type Grammar token a = forall p.   ( Lexical token p@@ -245,19 +279,7 @@   , Alternator p   ) => p a a -{- |-In addition to context-sensitivity via `Monadic` combinators,-`CtxGrammar`s adds general filtration via `Filtrator` to `Grammar`s.-->>> :{-palindromeG :: CtxGrammar Char String-palindromeG = rule "palindrome" $-  satisfied (\wrd -> reverse wrd == wrd) >?< manyP (anyToken @Char)-:}--The `satisfied` pattern is used together with the `Choice` &-`Data.Profunctor.Cochoice` applicator `>?<` for general filtration.-For context-sensitivity,+{- | For context-sensitivity, the `Monadic` interface is used by importing "Data.Profunctor.Monadic" qualified and using a "bonding" notation which mixes "idiom" style with qualified do-notation.@@ -280,7 +302,7 @@ lenvecGrammar = _LenVec >? P.do   let     numberG = iso show read >~ someP (asIn @Char DecimalNumber)-    vectorG n = intercalateP n (sepBy (terminal ",")) numberG+    vectorG n = intercalateP n (sepWith ",") numberG   len <- numberG             -- bonds to _LenVec   terminal ";"               -- doesn't bond   vectorG (fromIntegral len) -- bonds to _LenVec@@ -290,18 +312,19 @@ @P.@`Data.Profunctor.Monadic.>>=`, so that we must apply the constructor pattern @_LenVec@ to the do-block with the `>?` applicator.-Any bound named variable, @var <- action@,+Any scoped bound action, @var <- action@, gets "bonded" to the constructor pattern. Any unbound actions, except for the last action in the do-block, does not get bonded to the pattern. The last action does get bonded to the pattern.-Any unnamed bound action, @_ <- action@,+Any unscoped bound action, @_ <- action@, also gets bonded to the pattern,-but being unnamed means it isn't added to the context.-If all bound actions are unnamed, then a `CtxGrammar` can-be rewritten as a `Grammar` since it is context-free.-We can't generate a `RegBnf` since the `rule`s-of a `CtxGrammar` aren't static, but dynamic and contextual.+but being unscoped means it isn't added to the context.+If all bound actions are unscoped,+and filtration & failure handling aren't used,+then a `CtxGrammar` can be rewritten as a `Grammar` since it is context-free.+We can't generate a `RegBnf` from a `CtxGrammar` since the `rule`s+aren't static, but dynamic and contextual. We can generate parsers and printers as expected.  >>> [vec | (vec, "") <- parseG lenvecGrammar "3;1,2,3"] :: [LenVec]@@ -312,23 +335,64 @@ ["2;6,7"] >>> [pr "" | pr <- printG lenvecGrammar (LenVec 200 [100])] :: [String] []++In addition to context-sensitivity via `Monadic` combinators,+`CtxGrammar`s add unrestricted filtration to `Grammar`s.+The `satisfy` combinator is an unrestricted token filter.+And the `satisfied` pattern is used together with the `Choice` &+`Data.Profunctor.Cochoice` applicator `>?<` for unrestricted filtration.++>>> :{+palindromeG :: CtxGrammar Char String+palindromeG = rule "palindrome" $+  satisfied (\wrd -> reverse wrd == wrd) >?< manyP (anyToken @Char)+:}+ >>> [pal | word <- ["racecar", "word"], (pal, "") <- parseG palindromeG word] ["racecar"]++Since `CtxGrammar`s are embedded in Haskell,+permitting computable predicates,+and `Filtrator` has a default definition for `Monadic` `Alternator`s,+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.+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.+An @LL@ parser (un)parses from left to right,+and constucts leftmost derivations.+An @LL(k)@ parser can look @k@ tokens ahead.+`Parsor` is an @LL(∞)@ parser.+`Parsector` is an @LL(1)@ parser.+The backtracking `try` combinator+restores full lookahead to `Parsector`.+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}++>>> 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}++>>> unparsecG (tokens "abc") "abx" ""+ParsecState {parsecLooked = True, parsecOffset = 2, parsecStream = "ab", parsecError = ParsecError {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-  , Monadic p+  , MonadicTry p   ) => p a a  {- |-`Lexical` combinators include--* `terminal` symbols from "Control.Lens.Grammar.Symbol";-* `Tokenized` combinators from "Control.Lens.Grammar.Token";-* `tokenClass`es from "Control.Lens.Grammar.Boole".+`Lexical` combinators include `terminal` symbols,+`Tokenized` combinators and `tokenClass`es. -} type Lexical token p =   ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y)@@ -336,9 +400,10 @@   ) :: Constraint  {- | `RegString`s are an embedded domain specific language-of regular expression strings. Since they are strings,-they have a string-like interface.+of regular expression strings. +Since they are strings, they have a string-like interface.+ >>> let rex = fromString "ab|c" :: RegString >>> putStringLn rex ab|c@@ -353,7 +418,7 @@ `RegString`s are actually stored as an algebraic datatype, `RegEx`.  >>> runRegString rex-RegExam (Alternate (Terminal "ab") (Terminal "c"))+RegExam (Alternate (Sequence (RegExam (OneOf (fromList "a"))) (RegExam (OneOf (fromList "b")))) (RegExam (OneOf (fromList "c"))))  `RegString`s are similar to regular expression strings in many other programming languages. We can use them to see if a word and pattern@@ -442,6 +507,14 @@  {- | `RegBnf`s are an embedded domain specific language of Backus-Naur forms extended by regular expression strings.++A `RegBnf` consists of a distinguished `RegString` "start" rule,+and a set of named `RegString` `rule`s.++>>> putStringLn (rule "baz" (terminal "foo" >|< terminal "bar") :: RegBnf)+{start} = \q{baz}+{baz} = foo|bar+ Like `RegString`s they have a string-like interface.  >>> let bnf = fromString "{start} = foo|bar" :: RegBnf@@ -449,6 +522,8 @@ {start} = foo|bar >>> bnf "{start} = foo|bar"+>>> :type toList bnf+toList bnf :: [Char]  `RegBnf`s can be generated from context-free `Grammar`s with `regbnfG`. @@ -458,6 +533,13 @@ Like `RegString`s, `RegBnf`s can be constructed using `Lexical`, `Monoid` and `KleeneStarAlgebra` combinators. But they also support `BackusNaurForm` `rule`s and `ruleRec`s.++>>> putStringLn (rule "baz" (bnf >|< terminal "baz"))+{start} = \q{baz}+{baz} = foo|bar|baz+>>> putStringLn (ruleRec "∞-loop" (\x -> x) :: RegBnf)+{start} = \q{∞-loop}+{∞-loop} = \q{∞-loop} -} newtype RegBnf = RegBnf {runRegBnf :: Bnf RegString}   deriving newtype@@ -486,31 +568,28 @@ >>> putStringLn (regbnfG regexGrammar) {start} = \q{regex} {alternate} = \q{sequence}(\|\q{sequence})*-{atom} = (\\q\{)\q{char}*\}|\q{char}|\q{char-class}|\(\q{regex}\)+{atom} = \\q\q{nonterminal}|\q{class}|\(\q{regex}\) {category} = Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn-{category-test} = (\\p\{)\q{category}\}|(\\P\{)(\q{category}(\|\q{category})*)\} {char} = [^\(\)\*\+\?\[\\\]\^\{\|\}\P{Cc}]|\\\q{char-escaped}-{char-any} = \[\^\]-{char-class} = \q{fail}|\q{char-any}|\q{one-of}|\q{not-one-of}|\q{category-test} {char-control} = NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC {char-escaped} = [\(\)\*\+\?\[\\\]\^\{\|\}]|\q{char-control}+{class} = \q{class-one-of}|\q{class-not-one-of}+{class-category} = \\p\{\q{category}\}|\\P\{(\q{category}(\|\q{category})*)\}+{class-not-one-of} = \q{class-category}|\[\^\q{char}*(\q{class-category}?\])+{class-one-of} = \q{char}|\[\q{char}*\] {expression} = \q{atom}\?|\q{atom}\*|\q{atom}\+|\q{atom}-{fail} = \[\]-{not-one-of} = (\[\^)\q{char}+(\q{category-test}?\])-{one-of} = \[\q{char}+\]+{nonterminal} = \{\q{char}*\} {regex} = \q{alternate}-{sequence} = \q{char}*|\q{expression}*+{sequence} = \q{expression}* -} regexGrammar :: Grammar Char RegString regexGrammar = _RegString >~ ruleRec "regex" altG   where     altG rex = rule "alternate" $-      chain1 Left (_RegExam . _Alternate) (sepBy (terminal "|")) (seqG rex)+      chain1 Left (_RegExam . _Alternate) (sepWith "|") (seqG rex) -    seqG rex = rule "sequence" $ choice-      [ _Terminal >? manyP charG-      , chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex)-      ]+    seqG rex = rule "sequence" $+      chain Left _Sequence _SeqEmpty noSep (exprG rex)      exprG rex = rule "expression" $ choice       [ _KleeneOpt >? atomG rex *< terminal "?"@@ -520,20 +599,11 @@       ]      atomG rex = rule "atom" $ choice-      [ _NonTerminal >? terminal "\\q{" >* manyP charG *< terminal "}"-      , _Terminal >? charG >:< asEmpty+      [ _NonTerminal >? terminal "\\q" >* nonterminalG       , _RegExam >? classG       , terminal "(" >* rex *< terminal ")"       ] -    catTestG = rule "category-test" $ choice-      [ _AsIn >? terminal "\\p{" >* categoryG *< terminal "}"-      , _NotAsIn >? several1 (sepBy (terminal "|"))-          { beginBy = terminal "\\P{"-          , endBy = terminal "}"-          } categoryG-      ]-     categoryG = rule "category" $ choice       [ _LowercaseLetter >? terminal "Ll"       , _UppercaseLetter >? terminal "Lu"@@ -567,24 +637,32 @@       , _NotAssigned >? terminal "Cn"       ] -    classG = rule "char-class" $ choice-      [ _Fail >? failG-      , _Pass >? anyG-      , _OneOf >? oneOfG-      , _NotOneOf >? notOneOfG-      , _NotOneOf >? pure Set.empty >*< catTestG+    classG = rule "class" $ choice+      [ _OneOf >? classOneOfG+      , _NotOneOf >? classNotOneOfG       ] -    failG = rule "fail" $ terminal "[]"+    classCatG = rule "class-category" $ choice+      [ _AndAsIn >? terminal "\\p{" >* categoryG *< terminal "}"+      , _AndNotAsIn >? several1+          (sepWith "|" & beginWith "\\P{" & endWith "}")+          categoryG+      ] -    anyG = rule "char-any" $ terminal "[^]"+    classOneOfG = rule "class-one-of" $ choice+      [ onlyOne charG+      , terminal "[" >* several noSep charG *< terminal "]"+      ] -    oneOfG = rule "one-of" $ terminal "[" >* several1 noSep charG *< terminal "]"+    classNotOneOfG = rule "class-not-one-of" $ choice+      [ asEmpty >*< classCatG+      , terminal "[^" >* several noSep charG >*<+          optionP (_AndNotAsIn . _Empty) classCatG *< terminal "]"+      ] -    notOneOfG = rule "not-one-of" $-      terminal "[^" >* several1 noSep charG-        >*< option (NotAsIn Set.empty) catTestG-        *< terminal "]"+nonterminalG :: Grammar Char String+nonterminalG = rule "nonterminal" $+  terminal "{" >* manyP charG *< terminal "}"  charG :: Grammar Char Char charG = rule "char" $@@ -671,30 +749,26 @@ >>> putStringLn (regbnfG regbnfGrammar) {start} = \q{regbnf} {alternate} = \q{sequence}(\|\q{sequence})*-{atom} = (\\q\{)\q{char}*\}|\q{char}|\q{char-class}|\(\q{regex}\)+{atom} = \\q\q{nonterminal}|\q{class}|\(\q{regex}\) {category} = Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn-{category-test} = (\\p\{)\q{category}\}|(\\P\{)(\q{category}(\|\q{category})*)\} {char} = [^\(\)\*\+\?\[\\\]\^\{\|\}\P{Cc}]|\\\q{char-escaped}-{char-any} = \[\^\]-{char-class} = \q{fail}|\q{char-any}|\q{one-of}|\q{not-one-of}|\q{category-test} {char-control} = NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC {char-escaped} = [\(\)\*\+\?\[\\\]\^\{\|\}]|\q{char-control}+{class} = \q{class-one-of}|\q{class-not-one-of}+{class-category} = \\p\{\q{category}\}|\\P\{(\q{category}(\|\q{category})*)\}+{class-not-one-of} = \q{class-category}|\[\^\q{char}*(\q{class-category}?\])+{class-one-of} = \q{char}|\[\q{char}*\] {expression} = \q{atom}\?|\q{atom}\*|\q{atom}\+|\q{atom}-{fail} = \[\]-{not-one-of} = (\[\^)\q{char}+(\q{category-test}?\])-{one-of} = \[\q{char}+\]-{regbnf} = (\{start\} = )\q{regex}(\LF\q{rule})*+{nonterminal} = \{\q{char}*\}+{regbnf} = \{start\} = \q{regex}(\LF\q{nonterminal}( = )\q{regex})* {regex} = \q{alternate}-{rule} = \{\q{char}*(\} = )\q{regex}-{sequence} = \q{char}*|\q{expression}*+{sequence} = \q{expression}* -} regbnfGrammar :: Grammar Char RegBnf regbnfGrammar = rule "regbnf" $ _RegBnf . _Bnf >~-  terminal "{start} = " >* regexGrammar-    >*< several noSep (terminal "\n" >* ruleG)-  where-    ruleG = rule "rule" $ terminal "{" >* manyP charG *< terminal "} = "-      >*< regexGrammar+  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,@@ -727,7 +801,7 @@   -> m (string -> string) printG printor = printP printor -{- | `parseG` generates a parser from a `CtxGrammar`.+{- | `parseG` generates a parser from a @LL(∞)@ `CtxGrammar`. Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s, the type system will allow `parseG` to be applied to them. Running the parser on an input string value `uncons`es@@ -743,10 +817,10 @@   -> m (a, string) parseG parsor = parseP parsor -{- | `unparseG` generates an unparser from a `CtxGrammar`.+{- | `unparseG` generates a printer from a @LL(∞)@ `CtxGrammar`. Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s, the type system will allow `unparseG` to be applied to them.-Running the unparser on a syntax value and an input string+Running the printer on a syntax value and an input string `snoc`s tokens at the end of the string, from left to right, returning the output string. -}@@ -759,6 +833,42 @@   -> string {- ^ input -}   -> m string unparseG parsor = unparseP parsor++{- | `parsecG` generates a parser from a @LL(1)@ `CtxGrammar`,+with `try` for restoring full @LL(∞)@ lookahead.+Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s,+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`,+and a remaining output `parsecStream`.+-}+parsecG+  :: (Cons string string token token, Snoc string string token token)+  => (Item string ~ token, Categorized token)+  => CtxGrammar token a+  -> string {- ^ input -}+  -> ParsecState string a+parsecG parsector = parsecP parsector++{- | `unparsecG` generates a printer from a @LL(1)@ `CtxGrammar`,+with `try` for restoring full @LL(∞)@ lookahead.+Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s,+the type system will allow `unparsecG` to be applied to them.+Running the printer on a syntax value and an input string+`snoc`s tokens at the end of the string, from left to right,+returning `parsecResult` as `Nothing` on failure or `Just`+the input syntax value, with print success stored in `parsecStream`.+-}+unparsecG+  :: (Cons string string token token, Snoc string string token token)+  => (Item string ~ token, Categorized token)+  => CtxGrammar token a+  -> a {- ^ syntax -}+  -> string {- ^ input -}+  -> ParsecState string a+unparsecG parsector = unparsecP parsector  {- | `putStringLn` is a utility that generalizes `putStrLn` to string-like interfaces such as `RegString` and `RegBnf`.

@@ -9,7 +9,7 @@  See Naur & Backus, et al. [Report on the Algorithmic Language ALGOL 60]-(https://softwarepreservation.computerhistory.org/ALGOL/report/Algol60_report_CACM_1960_June.pdf)+(https://softwarepreservation.computerhistory.org/ALGOL/report/Algol60_report_CACM_1960_June.pdf). -}  module Control.Lens.Grammar.BackusNaur@@ -26,7 +26,6 @@  import Control.Lens import Control.Lens.Extras-import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Token import Control.Lens.Grammar.Symbol@@ -38,16 +37,18 @@ import Data.Set (Set)  {- | `BackusNaurForm` grammar combinators formalize-`rule` abstraction and general recursion. Context-free-`Control.Lens.Grammar.Grammar`s support the `BackusNaurForm` interface.+`rule` abstraction and general recursion. Both context-free+`Control.Lens.Grammar.Grammar`s & `Control.Lens.Grammar.CtxGrammar`s+support the `BackusNaurForm` interface.++prop> rule name bnf = ruleRec name (\_ -> bnf)++See Breitner, [Showcasing Applicative]+(https://www.joachim-breitner.de/blog/710-Showcasing_Applicative). -} class BackusNaurForm bnf where -  {- | For a `BackusNaurForm` parser instance,-  `rule` can be used to detail parse errors.--  prop> rule name bnf = ruleRec name (\_ -> bnf)-  -}+  {- | Rule abstraction, `rule` can be used to detail parse errors. -}   rule :: String -> bnf -> bnf   rule _ = id @@ -88,6 +89,11 @@ `RegEx`tended `Bnf`, with memoization.  prop> word =~ diffB prefix pattern = prefix <> word =~ pattern++Unfortunately, despite elegance & optimization, Brzozowski's+pattern matching algorithm is worst case exponential in grammar size.+See Might, Darais & Spiewak, [Parsing With Derivatives]+(https://matt.might.net/papers/might2011derivatives.pdf). -} diffB   :: (Categorized token, HasTrie token)@@ -97,9 +103,7 @@   where     -- derivative wrt 1 token, memoized     diff1B = memo2 $ \x -> \case-      Terminal [] -> zeroK-      Terminal (tokenY:streamY) ->-        if x == tokenY then terminal streamY else zeroK+      SeqEmpty -> zeroK       NonTerminal nameY -> anyK (diff1B x) (rulesNamed nameY rules)       Sequence y1 y2 ->         if δ (Bnf y1 rules) then y1'y2 >|< y1y2' else y1'y2@@ -109,14 +113,12 @@       KleeneStar y -> diff1B x y <> starK y       KleeneOpt y -> diff1B x y       KleenePlus y -> diff1B x y <> starK y-      RegExam Fail -> zeroK-      RegExam Pass -> mempty       RegExam (OneOf chars) ->         if x `elem` chars then mempty else zeroK-      RegExam (NotOneOf chars (AsIn cat)) ->+      RegExam (NotOneOf chars (AndAsIn cat)) ->         if elem x chars || categorize x /= cat           then zeroK else mempty-      RegExam (NotOneOf chars (NotAsIn cats)) ->+      RegExam (NotOneOf chars (AndNotAsIn cats)) ->         if elem x chars || elem (categorize x) cats           then zeroK else mempty       RegExam (Alternate y1 y2) -> diff1B x y1 >|< diff1B x y2@@ -126,7 +128,7 @@   => Bnf (RegEx token) -> Bool δ (Bnf start rules) = ν start where   ν = memo $ \case-    Terminal [] -> True+    SeqEmpty -> True     KleeneStar _ -> True     KleeneOpt _ -> True     KleenePlus y -> ν y

@@ -16,20 +16,10 @@   ( -- * BooleanAlgebra     BooleanAlgebra (..)   , andB, orB, allB, anyB-    -- * TokenAlgebra-  , TokenAlgebra (..)-  , TokenTest (..)   ) where -import Control.Applicative-import Control.Lens.Grammar.Kleene-import Control.Lens.Grammar.Token import Data.Foldable import Data.Monoid-import Data.Profunctor-import Data.Profunctor.Distributor-import qualified Data.Set as Set-import GHC.Generics  -- | A `BooleanAlgebra`, like `Bool`, supporting classical logical operations. class BooleanAlgebra b where@@ -52,159 +42,41 @@     :: (b ~ f bool, BooleanAlgebra bool, Functor f) => b -> b   notB = fmap notB -  -- | inclusion-  fromBool :: Bool -> b-  default fromBool-    :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => Bool -> b-  fromBool = pure . fromBool+  -- | true+  trueB :: b+  default trueB+    :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b+  trueB = pure trueB +  -- | false+  falseB :: b+  default falseB+    :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b+  falseB = pure falseB+ -- | cumulative conjunction andB :: (Foldable f, BooleanAlgebra b) => f b -> b-andB = foldl' (>&&<) (fromBool True)+andB = foldl' (>&&<) trueB  -- | cumulative disjunction orB :: (Foldable f, BooleanAlgebra b) => f b -> b-orB = foldl' (>||<) (fromBool False)+orB = foldl' (>||<) falseB  -- | universal allB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b-allB f = foldl' (\b a -> b >&&< f a) (fromBool True)+allB f = foldl' (\b a -> b >&&< f a) trueB  -- | existential anyB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b-anyB f = foldl' (\b a -> b >||< f a) (fromBool False)---- | `TokenTest` forms a closed `Tokenized` `BooleanAlgebra`--- of `Categorized` `tokenClass`es.-newtype TokenTest token = TokenTest (RegExam token (TokenTest token))---- | `TokenAlgebra` extends `Tokenized` methods to support--- `BooleanAlgebra` operations in a `tokenClass`-class Tokenized token p => TokenAlgebra token p where-  -- | Arguments of `tokenClass` can be constructed from-  -- `Tokenized` and `BooleanAlgebra` methods.-  tokenClass :: TokenTest token -> p-  default tokenClass-    :: (p ~ q token token, Alternator q, Cochoice q)-    => TokenTest token -> p-  tokenClass (TokenTest exam) = case exam of-    Fail -> empty-    Pass -> anyToken-    OneOf chars -> oneOf chars-    NotOneOf chars (AsIn cat) ->-      satisfy (notOneOf chars >&&< asIn cat)-    NotOneOf chars (NotAsIn cats) ->-      satisfy (notOneOf chars >&&< allB notAsIn cats)-    Alternate exam1 exam2 -> tokenClass exam1 <|> tokenClass exam2+anyB f = foldl' (\b a -> b >||< f a) falseB  --instances instance BooleanAlgebra (x -> Bool)-instance Categorized token => TokenAlgebra token (token -> Bool) where-  tokenClass (TokenTest exam) = case exam of-    Fail -> const False-    Pass -> const True-    OneOf chars -> oneOf chars-    NotOneOf chars (AsIn cat) -> notOneOf chars >&&< asIn cat-    NotOneOf chars (NotAsIn cats) -> notOneOf chars >&&< allB notAsIn cats-    Alternate exam1 exam2 -> tokenClass exam1 >||< tokenClass exam2 instance (Applicative f, BooleanAlgebra bool)   => BooleanAlgebra (Ap f bool)-deriving stock instance Generic (TokenTest token)-deriving stock instance-  (Categorized token, Read token, Read (Categorize token))-    => Read (TokenTest token)-deriving stock instance-  (Categorized token, Show token, Show (Categorize token))-    => Show (TokenTest token) instance BooleanAlgebra Bool where-  fromBool = id+  falseB = False+  trueB = True   notB = not   (>&&<) = (&&)   (>||<) = (||)-deriving newtype instance Categorized token-  => Eq (TokenTest token)-deriving newtype instance Categorized token-  => Ord (TokenTest token)-deriving newtype instance Categorized token-  => BooleanAlgebra (TokenTest token)-deriving newtype instance Categorized token-  => Tokenized token (TokenTest token)-instance Categorized token-  => TokenAlgebra token (RegEx token) where-  tokenClass (TokenTest tokenExam) = case tokenExam of-    Fail -> RegExam Fail-    Pass -> RegExam Pass-    OneOf as -> RegExam (OneOf as)-    NotOneOf as catTest -> RegExam (NotOneOf as catTest)-    Alternate exam1 exam2 ->-      RegExam (Alternate (tokenClass exam1) (tokenClass exam2))-instance Categorized token-  => BooleanAlgebra (RegExam token (TokenTest token)) where-  fromBool = \case-    False -> Fail-    True -> Pass-  notB Fail = Pass-  notB Pass = Fail-  notB (Alternate (TokenTest x) (TokenTest y)) = notB x >&&< notB y-  notB (OneOf xs) = notOneOf xs-  notB (NotOneOf xs (AsIn y)) = oneOf xs >||< notAsIn y-  notB (NotOneOf xs (NotAsIn ys)) = oneOf xs >||< anyB asIn ys-  _ >&&< Fail = Fail-  Fail >&&< _ = Fail-  x >&&< Pass = x-  Pass >&&< y = y-  x >&&< Alternate (TokenTest y) (TokenTest z) = (x >&&< y) >||< (x >&&< z)-  Alternate (TokenTest x) (TokenTest y) >&&< z = (x >&&< z) >||< (y >&&< z)-  OneOf xs >&&< OneOf ys = OneOf (Set.intersection xs ys)-  OneOf xs >&&< NotOneOf ys (AsIn z) = OneOf-    (Set.filter (\x -> categorize x == z) (Set.difference xs ys))-  NotOneOf xs (AsIn y) >&&< OneOf zs = OneOf-    (Set.filter (\z -> categorize z == y) (Set.difference zs xs))-  OneOf xs >&&< NotOneOf ys (NotAsIn zs) = OneOf-    (Set.filter (\x -> categorize x `notElem` zs) (Set.difference xs ys))-  NotOneOf xs (NotAsIn ys) >&&< OneOf zs = OneOf-    (Set.filter (\z -> categorize z `notElem` ys) (Set.difference zs xs))-  NotOneOf xs (AsIn y) >&&< NotOneOf ws (AsIn z) =-    if y /= z then Fail else NotOneOf-      (Set.filter (\x -> categorize x == y)-      (Set.union xs ws)) (AsIn y)-  NotOneOf xs (AsIn y) >&&< NotOneOf ws (NotAsIn zs) =-    if y `elem` zs then Fail else NotOneOf-      (Set.filter (\x -> categorize x == y)-      (Set.union xs ws)) (AsIn y)-  NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (AsIn z) =-    if z `elem` ys then Fail else NotOneOf-      (Set.filter (\x -> categorize x == z) (Set.union xs ws))-      (AsIn z)-  NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (NotAsIn zs) =-    let-      xws = Set.union xs ws-      yzs = Set.union ys zs-    in-      NotOneOf-        (Set.filter (\x -> categorize x `notElem` yzs) xws)-        (NotAsIn yzs)-  x >||< Fail = x-  Fail >||< y = y-  _ >||< Pass = Pass-  Pass >||< _ = Pass-  x >||< Alternate y z = Alternate (TokenTest x) (TokenTest (Alternate y z))-  Alternate x y >||< z = Alternate (TokenTest (Alternate x y)) (TokenTest z)-  OneOf xs >||< OneOf ys = oneOf (Set.union xs ys)-  OneOf xs >||< NotOneOf ys z =-    Alternate (TokenTest (OneOf xs)) (TokenTest (NotOneOf ys z))-  NotOneOf xs y >||< OneOf zs =-    Alternate (TokenTest (NotOneOf xs y)) (TokenTest (OneOf zs))-  NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (NotAsIn zs) =-    notOneOf (Set.intersection xs ws) >&&< allB notAsIn (Set.intersection ys zs)-  NotOneOf xs (AsIn y) >||< NotOneOf ws (AsIn z) =-    if y == z then NotOneOf (Set.intersection xs ws) (AsIn y)-    else Alternate-      (TokenTest (NotOneOf xs (AsIn y)))-      (TokenTest (NotOneOf ws (AsIn z)))-  NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (AsIn z) = Alternate-    (TokenTest (NotOneOf xs (NotAsIn ys)))-    (TokenTest (NotOneOf ws (AsIn z)))-  NotOneOf xs (AsIn y) >||< NotOneOf ws (NotAsIn zs) = Alternate-    (TokenTest (NotOneOf xs (AsIn y)))-    (TokenTest (NotOneOf ws (NotAsIn zs)))

@@ -16,25 +16,30 @@   ( -- * KleeneStarAlgebra     KleeneStarAlgebra (..)   , orK, anyK-    -- * RegEx+    -- * TokenAlgebra+  , TokenAlgebra (..)+    -- * RegEx & TokenClass   , RegEx (..)+  , TokenClass (..)   , RegExam (..)   , CategoryTest (..)   ) where  import Control.Applicative+import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Data.Foldable import Data.MemoTrie import Data.Monoid import Data.Profunctor+import Data.Profunctor.Distributor import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics  {- | A `KleeneStarAlgebra` is a ring-with a generally non-commutaive multiplication,+with a generally non-commutative multiplication, the `Monoid` concatenation operator `<>` with identity `mempty`; and an idempotent addition, the alternation operator `>|<` with identity `zeroK`.@@ -45,6 +50,14 @@ prop> plusK x = x <> starK x prop> optK x = mempty >|< x +The following invariants should hold.++prop> x >|< x = x+prop> zeroK >|< x = x = x >|< zeroK+prop> mempty >|< x = optK x = x >|< mempty+prop> zeroK <> x = zeroK = x <> zeroK+prop> mempty <> x = x = x <> mempty+ -} class Monoid k => KleeneStarAlgebra k where   starK, plusK, optK :: k -> k@@ -63,41 +76,95 @@ orK :: (Foldable f, KleeneStarAlgebra k) => f k -> k orK = foldl' (>|<) zeroK --- | universal+-- | existential anyK :: (Foldable f, KleeneStarAlgebra k) => (a -> k) -> f a -> k anyK f = foldl' (\b a -> b >|< f a) zeroK --- | The `RegEx`pression type is the prototypical `KleeneStarAlgebra`.+{- | The `RegEx`pression type forms the prototypical `KleeneStarAlgebra`.+It is also a `TokenAlgebra`, such that the following invariants hold.++prop> zeroK = tokenClass falseB+prop> tokenClass x >|< tokenClass y = tokenClass (x >||< y)++-} data RegEx token-  = Terminal [token]-  | NonTerminal String+  = SeqEmpty   | Sequence (RegEx token) (RegEx token)+  | NonTerminal String   | KleeneStar (RegEx token)   | KleeneOpt (RegEx token)   | KleenePlus (RegEx token)   | RegExam (RegExam token (RegEx token)) -{- | A component of both `RegEx`pressions-and `Control.Lens.Grammar.Boole.TokenTest`s, so that the latter can-be embedded in the former with `Control.Lens.Grammar.Boole.tokenClass`.+{- | A component of both `RegEx`pressions and `TokenClass`es,+so that the latter can be embedded in the former with `tokenClass`. -} data RegExam token alg-  = Fail-  | Pass-  | OneOf (Set token)+  = OneOf (Set token)   | NotOneOf (Set token) (CategoryTest token)   | Alternate alg alg +failExam :: RegExam token alg+failExam = OneOf Set.empty++passExam :: RegExam token alg+passExam = NotOneOf Set.empty (AndNotAsIn Set.empty)++isFailExam :: RegExam token alg -> Bool+isFailExam (OneOf xs) = Set.null xs+isFailExam _ = False++isPassExam :: RegExam token alg -> Bool+isPassExam (NotOneOf xs (AndNotAsIn ys)) = Set.null xs && Set.null ys+isPassExam _ = False+ {- | `CategoryTest`s for `Categorized` tokens.-} data CategoryTest token-  = AsIn (Categorize token)-  | NotAsIn (Set (Categorize token))+  = AndAsIn (Categorize token)+  | AndNotAsIn (Set (Categorize token)) +{- | `TokenClass` forms a `Tokenized` `BooleanAlgebra`,+such that the following invariants hold.++prop> trueB = anyToken+prop> trueB = notOneOf []+prop> falseB = oneOf []+prop> notB . oneOf = notOneOf+prop> notB . notOneOf = oneOf+prop> notB . asIn = notAsIn+prop> notB . notAsIn = asIn++-}+newtype TokenClass token = TokenClass (RegExam token (TokenClass token))++{- | `TokenAlgebra` extends `Tokenized` methods to support+`BooleanAlgebra` operations within a `tokenClass`.+When a `TokenAlgebra` is an `Alternative`,+then `tokenClass` is expected to act homomorphically on disjunction.++prop> empty = tokenClass falseB+prop> tokenClass x <|> tokenClass y = tokenClass (x >||< y)++-}+class Tokenized token p => TokenAlgebra token p where+  tokenClass :: TokenClass token -> p+  default tokenClass+    :: (p ~ q token token, Alternator q, Cochoice q)+    => TokenClass token -> p+  tokenClass (TokenClass exam) = case exam of+    OneOf chars -> oneOf chars+    NotOneOf chars (AndAsIn cat) ->+      satisfy (notOneOf chars >&&< asIn cat)+    NotOneOf chars (AndNotAsIn cats) ->+      satisfy (notOneOf chars >&&< allB notAsIn cats)+    Alternate exam1 exam2 -> tokenClass exam1 <|> tokenClass exam2+ --instances instance (Alternative f, Monoid k) => KleeneStarAlgebra (Ap f k) deriving stock instance Generic (RegEx token) deriving stock instance Generic (RegExam token alg) deriving stock instance Generic1 (RegExam token)+deriving stock instance Generic (TokenClass token) deriving stock instance Generic (CategoryTest token) deriving stock instance Categorized token => Eq (RegEx token) deriving stock instance Categorized token => Ord (RegEx token)@@ -107,67 +174,145 @@ deriving stock instance   (Categorized token, Show token, Show (Categorize token))     => Show (RegEx token)-instance TerminalSymbol token (RegEx token) where-  terminal = Terminal . toList+deriving stock instance+  (Categorized token, Read token, Read (Categorize token))+    => Read (TokenClass token)+deriving stock instance+  (Categorized token, Show token, Show (Categorize token))+    => Show (TokenClass token)+deriving newtype instance Categorized token => Eq (TokenClass token)+deriving newtype instance Categorized token => Ord (TokenClass token)+deriving newtype instance Categorized token => Tokenized token (TokenClass token)+deriving newtype instance Categorized token => BooleanAlgebra (TokenClass token)+instance Categorized token+  => TokenAlgebra token (TokenClass token) where+  tokenClass = id+instance Categorized token+  => TokenAlgebra token (RegExam token (TokenClass token)) where+  tokenClass (TokenClass exam) = exam+instance Categorized token => TerminalSymbol token (RegEx token) where+  terminal = foldl (\acc t -> acc <> token t) mempty instance NonTerminalSymbol (RegEx token) where   nonTerminal = NonTerminal instance Categorized token => Tokenized token (RegEx token) where-  anyToken = RegExam Pass-  token a = Terminal [a]-  oneOf as | null as = RegExam Fail-  oneOf as | length as == 1 = Terminal (toList as)-  oneOf as = RegExam (OneOf (foldr Set.insert Set.empty as))-  notOneOf as | null as = RegExam Pass-  notOneOf as = RegExam-    (NotOneOf (foldr Set.insert Set.empty as) (NotAsIn Set.empty))-  asIn cat = RegExam (NotOneOf Set.empty (AsIn cat))-  notAsIn cat = RegExam-    (NotOneOf Set.empty (NotAsIn (Set.singleton cat)))+  anyToken = RegExam passExam+  token a = RegExam (OneOf (Set.singleton a))+  oneOf as = RegExam (OneOf (Set.fromList (toList as)))+  notOneOf as =+    RegExam (NotOneOf (Set.fromList (toList as)) (AndNotAsIn Set.empty))+  asIn cat = RegExam (NotOneOf Set.empty (AndAsIn cat))+  notAsIn cat = RegExam (NotOneOf Set.empty (AndNotAsIn (Set.singleton cat)))+instance Categorized token => TokenAlgebra token (token -> Bool) where+  tokenClass (TokenClass exam) x = case exam of+    OneOf xs -> Set.member x xs+    NotOneOf xs (AndAsIn y) ->+      Set.notMember x xs && categorize x == y+    NotOneOf xs (AndNotAsIn ys) ->+      Set.notMember x xs && Set.notMember (categorize x) ys+    Alternate exam1 exam2 ->+      tokenClass exam1 x || tokenClass exam2 x+instance Categorized token => TokenAlgebra token (RegEx token) where+  tokenClass (TokenClass exam) = case exam of+    OneOf as -> RegExam (OneOf as)+    NotOneOf as catTest -> RegExam (NotOneOf as catTest)+    Alternate exam1 exam2 ->+      RegExam (Alternate (tokenClass exam1) (tokenClass exam2))+instance Categorized token => Monoid (RegEx token) where+  mempty = SeqEmpty instance Categorized token => Semigroup (RegEx token) where-  Terminal [] <> rex = rex-  rex <> Terminal [] = rex-  RegExam Fail <> _ = zeroK-  _ <> RegExam Fail = zeroK-  Terminal str0 <> Terminal str1 = Terminal (str0 <> str1)-  KleeneStar rex0 <> rex1-    | rex0 == rex1 = plusK rex0-  rex0 <> KleeneStar rex1-    | rex0 == rex1 = plusK rex1+  SeqEmpty <> rex = rex+  rex <> SeqEmpty = rex+  RegExam exam <> _ | isFailExam exam = zeroK+  _ <> RegExam exam | isFailExam exam = zeroK+  KleeneStar rex0 <> rex1 | rex0 == rex1 = plusK rex0+  rex0 <> KleeneStar rex1 | rex0 == rex1 = plusK rex1   rex0 <> rex1 = Sequence rex0 rex1-instance Categorized token => Monoid (RegEx token) where-  mempty = Terminal [] instance Categorized token => KleeneStarAlgebra (RegEx token) where-  zeroK = RegExam Fail-  optK (RegExam Fail) = mempty-  optK (Terminal []) = mempty+  zeroK = RegExam failExam+  optK (RegExam exam) | isFailExam exam = mempty+  optK SeqEmpty = mempty   optK (KleenePlus rex) = starK rex   optK rex = KleeneOpt rex-  starK (RegExam Fail) = mempty-  starK (Terminal []) = mempty+  starK (RegExam exam) | isFailExam exam = mempty+  starK SeqEmpty = mempty   starK rex = KleeneStar rex-  plusK (RegExam Fail) = zeroK-  plusK (Terminal []) = mempty+  plusK (RegExam exam) | isFailExam exam = zeroK+  plusK SeqEmpty = mempty   plusK rex = KleenePlus rex-  KleenePlus rex >|< Terminal [] = starK rex-  Terminal [] >|< KleenePlus rex = starK rex-  rex >|< Terminal [] = optK rex-  Terminal [] >|< rex = optK rex-  rex >|< RegExam Fail = rex-  RegExam Fail >|< rex = rex   rex0 >|< rex1 | rex0 == rex1 = rex0+  KleenePlus rex >|< SeqEmpty = starK rex+  SeqEmpty >|< KleenePlus rex = starK rex+  rex >|< SeqEmpty = optK rex+  SeqEmpty >|< rex = optK rex+  rex >|< RegExam exam | isFailExam exam = rex+  RegExam exam >|< rex | isFailExam exam = rex+  rex0 >|< rex1 | Just tokenOr <- maybeOr = tokenClass tokenOr+    where+      toTokenClass (RegExam exam) =+        TokenClass <$> traverse toTokenClass exam+      toTokenClass _ = Nothing+      maybeOr = (>||<) <$> toTokenClass rex0 <*> toTokenClass rex1   rex0 >|< rex1 = RegExam (Alternate rex0 rex1)-instance Categorized token-  => Tokenized token (RegExam token alg) where-  anyToken = Pass+instance Categorized token => Tokenized token (RegExam token alg) where+  anyToken = passExam   token a = OneOf (Set.singleton a)-  oneOf as | null as = Fail+  oneOf as | null as = failExam   oneOf as = OneOf (Set.fromList (toList as))-  notOneOf as | null as = Pass+  notOneOf as | null as = passExam   notOneOf as =-    NotOneOf (Set.fromList (toList as)) (NotAsIn Set.empty)-  asIn cat = NotOneOf Set.empty (AsIn cat)-  notAsIn cat =-    NotOneOf Set.empty (NotAsIn (Set.singleton cat))+    NotOneOf (Set.fromList (toList as)) (AndNotAsIn Set.empty)+  asIn cat = NotOneOf Set.empty (AndAsIn cat)+  notAsIn cat = NotOneOf Set.empty (AndNotAsIn (Set.singleton cat))+instance Categorized token+  => BooleanAlgebra (RegExam token (TokenClass token)) where+  falseB = failExam+  trueB = passExam+  notB exam | isFailExam exam = passExam+  notB exam | isPassExam exam = failExam+  notB (Alternate (TokenClass x) (TokenClass y)) = notB x >&&< notB y+  notB (OneOf xs) = notOneOf xs+  notB (NotOneOf xs (AndAsIn y)) = oneOf xs >||< notAsIn y+  notB (NotOneOf xs (AndNotAsIn ys)) = oneOf xs >||< anyB asIn ys+  x >&&< y | x == y = x+  _ >&&< exam | isFailExam exam = failExam+  exam >&&< _ | isFailExam exam = failExam+  x >&&< exam | isPassExam exam = x+  exam >&&< z | isPassExam exam = z+  x >&&< Alternate (TokenClass y) (TokenClass z) = (x >&&< y) >||< (x >&&< z)+  Alternate (TokenClass x) (TokenClass y) >&&< z = (x >&&< z) >||< (y >&&< z)+  OneOf xs >&&< OneOf ys = OneOf (Set.intersection xs ys)+  OneOf xs >&&< NotOneOf ys (AndAsIn z) = OneOf+    (Set.filter (\x -> categorize x == z) (Set.difference xs ys))+  NotOneOf xs (AndAsIn y) >&&< OneOf zs = OneOf+    (Set.filter (\z -> categorize z == y) (Set.difference zs xs))+  OneOf xs >&&< NotOneOf ys (AndNotAsIn zs) = OneOf+    (Set.filter (\x -> categorize x `notElem` zs) (Set.difference xs ys))+  NotOneOf xs (AndNotAsIn ys) >&&< OneOf zs = OneOf+    (Set.filter (\z -> categorize z `notElem` ys) (Set.difference zs xs))+  NotOneOf xs (AndAsIn y) >&&< NotOneOf ws (AndAsIn z) =+    if y /= z then failExam else NotOneOf+      (Set.filter (\x -> categorize x == y) (Set.union xs ws)) (AndAsIn y)+  NotOneOf xs (AndAsIn y) >&&< NotOneOf ws (AndNotAsIn zs) =+    if y `elem` zs then failExam else NotOneOf+      (Set.filter (\x -> categorize x == y) (Set.union xs ws)) (AndAsIn y)+  NotOneOf xs (AndNotAsIn ys) >&&< NotOneOf ws (AndAsIn z) =+    if z `elem` ys then failExam else NotOneOf+      (Set.filter (\x -> categorize x == z) (Set.union xs ws)) (AndAsIn z)+  NotOneOf xs (AndNotAsIn ys) >&&< NotOneOf ws (AndNotAsIn zs) =+    let+      xws = Set.union xs ws+      yzs = Set.union ys zs+    in+      NotOneOf+        (Set.filter (\x -> categorize x `notElem` yzs) xws)+        (AndNotAsIn yzs)+  x >||< y | x == y = x+  x >||< exam | isFailExam exam = x+  exam >||< y | isFailExam exam = y+  _ >||< exam | isPassExam exam = passExam+  exam >||< _ | isPassExam exam = passExam+  OneOf xs >||< OneOf ys = oneOf (Set.union xs ys)+  x >||< y = Alternate (TokenClass x) (TokenClass y) deriving stock instance   (Categorized token, Read token, Read alg, Read (Categorize token))     => Read (RegExam token alg)@@ -177,10 +322,8 @@ deriving stock instance Functor (RegExam token) deriving stock instance Foldable (RegExam token) deriving stock instance Traversable (RegExam token)-deriving stock instance (Categorized token, Eq alg)-  => Eq (RegExam token alg)-deriving stock instance (Categorized token, Ord alg)-  => Ord (RegExam token alg)+deriving stock instance (Categorized token, Eq alg) => Eq (RegExam token alg)+deriving stock instance (Categorized token, Ord alg) => Ord (RegExam token alg) deriving stock instance Categorized token => Eq (CategoryTest token) deriving stock instance Categorized token => Ord (CategoryTest token) deriving stock instance@@ -192,62 +335,55 @@ instance (Categorized token, HasTrie token)   => HasTrie (RegEx token) where     data (RegEx token :->: b) = RegExTrie-      { terminalTrie :: [token] :->: b+      { seqEmptyTrie :: b       , nonTerminalTrie :: String :->: b       , sequenceTrie :: (RegEx token, RegEx token) :->: b       , alternateTrie :: (RegEx token, RegEx token) :->: b       , kleeneStarTrie :: RegEx token :->: b       , kleeneOptTrie :: RegEx token :->: b       , kleenePlusTrie :: RegEx token :->: b-      , failTrie :: b-      , passTrie :: b       , oneOfTrie :: [token] :->: b       , notOneOfTrie :: ([token], Either Int [Int]) :->: b       }     trie f = RegExTrie-      { terminalTrie = trie (f . terminal)+      { seqEmptyTrie = f mempty       , nonTerminalTrie = trie (f . nonTerminal)       , sequenceTrie = trie (f . uncurry (<>))       , alternateTrie = trie (f . uncurry (>|<))       , kleeneStarTrie = trie (f . starK)       , kleeneOptTrie = trie (f . optK)       , kleenePlusTrie = trie (f . plusK)-      , failTrie = f zeroK-      , passTrie = f anyToken       , oneOfTrie = trie (f . oneOf)       , notOneOfTrie = trie (f . testNotOneOf)       }     untrie rex = \case-      Terminal word -> untrie (terminalTrie rex) word+      SeqEmpty -> seqEmptyTrie rex       NonTerminal name -> untrie (nonTerminalTrie rex) name       Sequence x1 x2 -> untrie (sequenceTrie rex) (x1,x2)       KleeneStar x -> untrie (kleeneStarTrie rex) x       KleenePlus x -> untrie (kleenePlusTrie rex) x       KleeneOpt x -> untrie (kleeneOptTrie rex) x-      RegExam Fail -> failTrie rex-      RegExam Pass -> passTrie rex       RegExam (OneOf chars) -> untrie (oneOfTrie rex) (Set.toList chars)-      RegExam (NotOneOf chars (AsIn cat)) ->+      RegExam (NotOneOf chars (AndAsIn cat)) ->         untrie (notOneOfTrie rex) (Set.toList chars, Left (fromEnum cat))-      RegExam (NotOneOf chars (NotAsIn cats)) ->+      RegExam (NotOneOf chars (AndNotAsIn cats)) ->         untrie (notOneOfTrie rex)           (Set.toList chars, Right (Set.toList (Set.map fromEnum cats)))       RegExam (Alternate x1 x2) -> untrie (alternateTrie rex) (x1,x2)     enumerate rex = mconcat-      [ first' Terminal <$> enumerate (terminalTrie rex)+      [ [(SeqEmpty, seqEmptyTrie rex)]       , first' NonTerminal <$> enumerate (nonTerminalTrie rex)       , first' (uncurry Sequence) <$> enumerate (sequenceTrie rex)       , first' (RegExam . uncurry Alternate) <$> enumerate (alternateTrie rex)       , first' KleeneStar <$> enumerate (kleeneStarTrie rex)       , first' KleeneOpt <$> enumerate (kleeneOptTrie rex)       , first' KleenePlus <$> enumerate (kleenePlusTrie rex)-      , [(RegExam Fail, failTrie rex)]-      , [(RegExam Pass, passTrie rex)]       , first' (RegExam . OneOf . Set.fromList) <$> enumerate (oneOfTrie rex)       , first' testNotOneOf <$> enumerate (notOneOfTrie rex)       ] testNotOneOf   :: Categorized token   => ([token], Either Int [Int]) -> RegEx token-testNotOneOf (chars, catTest) = RegExam $-  NotOneOf (Set.fromList chars) (either (AsIn . toEnum) (NotAsIn . Set.map toEnum . Set.fromList) catTest)+testNotOneOf (chars, catTest) = RegExam $ NotOneOf+  (Set.fromList chars)+  (either (AndAsIn . toEnum) (AndNotAsIn . Set.map toEnum . Set.fromList) catTest)

@@ -26,7 +26,7 @@   default terminal     :: (p () () ~ s, Tokenized token (p token token), Monoidal p, Cochoice p)     => [token] -> s-  terminal = foldr (\a p -> only a ?< anyToken *> p) oneP+  terminal = foldr (\a p -> only a ?< token a *> p) oneP  -- | A `nonTerminal` symbol in a grammar. class NonTerminalSymbol s where

@@ -60,14 +60,22 @@     => token -> p   token = satisfy . token -  {- | A single token which is `oneOf` a set. -}+  {- | A single token which is `oneOf` a set.++  prop> token x = oneOf [x]+  +  -}   oneOf :: Foldable f => f token -> p   default oneOf     :: (p ~ q token token, Choice q, Cochoice q, Foldable f)     => f token -> p   oneOf = satisfy . oneOf -  {- | A single token which is `notOneOf` a set. -}+  {- | A single token which is `notOneOf` a set.+  +  prop> anyToken = notOneOf []+  +  -}   notOneOf :: Foldable f => f token -> p   default notOneOf     :: (p ~ q token token, Choice q, Cochoice q, Foldable f)

@@ -48,8 +48,7 @@   (Closed p, Monoidal p, Distributive f, Applicative f)     => p a (f b) -> p s (f t) -{- | If you see `AGrate` in a signature for a function,-the function is expecting a `Grate`. -}+{- | `AGrate` is monomorphically a `Grate`. -} type AGrate s t a b =   Grating a b a (Identity b) -> Grating a b s (Identity t) 

@@ -33,21 +33,42 @@ import Data.Set (Set) import Prelude --- | Generate a `Control.Lens.Prism.Prism`+-- | 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 generated when possible.--- `Control.Lens.Review.Review`s are created for constructors with existentially--- quantified constructors and GADTs.------ See `Control.Lens.Internal.PrismTH.makePrisms` for details and examples.+-- `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 use on the left-hand-side of--- `Control.Lens.PartialIso.>~`,--- `Control.Lens.PartialIso.>?` and `Control.Lens.PartialIso.>?<`;--- with repeated use of `Data.Profunctor.Distributor.>*<`--- on the right-hand-side, resulting in right-nested pairs.+-- 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

@@ -19,6 +19,7 @@   , monocle   , withMonocle   , cloneMonocle+  , imprism   , mapMonocle   , ditraversed   , forevered@@ -42,8 +43,7 @@   (Monoidal p, Applicative f)     => p a (f b) -> p s (f t) -{- | If you see `AMonocle` in a signature for a function,-the function is expecting a `Monocle`. -}+{- | `AMonocle` is monomorphically a `Monocle`. -} type AMonocle s t a b =   Monocular a b a (Identity b) -> Monocular a b s (Identity t) @@ -60,6 +60,16 @@ -} cloneMonocle :: AMonocle s t a b -> Monocle s t a b cloneMonocle mon = unwrapPafb . mapMonocle mon . WrapPafb++{- | Convert a `Monocle` to an improper `Control.Lens.Prism.Prism`.++>>> review (imprism ditraversed) 1 :: Complex Int+1 :+ 1+>>> preview (imprism ditraversed) (1 :+ 2 :: Complex Int)+Just 1+-}+imprism :: Monocle s t a b -> Prism s t a b+imprism mon = clonePrism mon  {- | Build a `Monocle` from a `Traversable` & `Distributive`, homogeneous, countable product.

@@ -117,8 +117,7 @@ -} type PartialIso' s a = PartialIso s s a a -{- | If you see `APartialIso` in a signature for a function,-the function is expecting a `PartialIso`. -}+{- | `APartialIso` is monomorphically a `PartialIso`. -} type APartialIso s t a b =   PartialExchange a b a (Maybe b) -> PartialExchange a b s (Maybe t) @@ -149,7 +148,7 @@ partialIso f g =   unright . iso (maybe (Left ()) Right . f =<<) (mapMaybe g) . right' -{- | Given a function that is its own partial inverse,+{- | Given a partial function that is its own inverse, this gives you a `PartialIso'` using it in both directions. -} partialInvoluted :: (a -> Maybe a) -> PartialIso' a a partialInvoluted f = partialIso f f@@ -222,7 +221,7 @@ (?<) pat = withPrism pat $ \f g -> unright . dimap (either id f) g infixl 4 ?< -{- | Action of `APartialIso` on `Choice` and `Cochoice` `Profunctor`s. -}+{- | Action of `APartialIso` on `Choice` & `Cochoice` partial profunctors. -} (>?<)   :: (Choice p, Cochoice p)   => APartialIso s t a b@@ -265,18 +264,18 @@   nonEmp s = if isn't _Empty s then Just s else Nothing  {- | The either-of-tuples representation of `Maybe`. -}-eotMaybe :: Iso (Maybe a) (Maybe b) (Either () a) (Either () b)+eotMaybe :: Iso (Maybe a) (Maybe b) (Either a ()) (Either b ()) eotMaybe = iso-  (maybe (Left ()) Right)-  (either (pure Nothing) Just)+  (maybe (Right ()) Left)+  (either Just (const Nothing))  {- | The either-of-tuples representation of list-like streams. -} eotList   :: (Cons s s a a, AsEmpty t, Cons t t b b)-  => Iso s t (Either () (a,s)) (Either () (b,t))+  => Iso s t (Either (a,s) ()) (Either (b,t) ()) eotList = iso-  (maybe (Left ()) Right . uncons)-  (either (const Empty) (review _Cons))+  (maybe (Right ()) Left . uncons)+  (either (review _Cons) (const Empty))  {- | Iterate the application of a partial isomorphism, useful for constructing fold/unfold isomorphisms. -}

@@ -37,7 +37,6 @@  {- | `Wither`s extends `Control.Lens.Traversal.Traversal`s by filtering. - Every one of the following is a `Wither`.  * `Control.Lens.Iso.Iso`@@ -48,8 +47,7 @@ -} type Wither s t a b = forall f. Alternative f => (a -> f b) -> s -> f t -{- | If you see `AWither` in a signature for a function,-the function is expecting a `Wither`. -}+{- | `AWither` is monomorphically a `Wither`. -} type AWither s t a b = (a -> Altar a b b) -> s -> Altar a b t  {- | `Witheroid`s generalize `Wither`s.

@@ -0,0 +1,46 @@+{-|+Module      : Control.Monad.Fail.Try+Description : try & fail+Copyright   : (C) 2026 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable+-}++module Control.Monad.Fail.Try+  ( -- * MonadTry+    MonadTry (..)+    -- * MonadFail+  , MonadFail (..)+    -- * MonadPlus+  , MonadPlus (..)+    -- * Alternative+  , Alternative (..)+  ) where++import Control.Applicative+import Control.Monad++{- | `MonadTry` is a failure handling interface,+with `fail` & `try` and redundant alternation operators.++prop> empty = mzero+prop> (<|>) = mplus++When a `MonadTry` is also a+`Control.Lens.Grammar.BackusNaur.BackusNaurForm`,+then the following invariant should hold.++prop> fail label = rule label empty++-}+class (MonadFail m, MonadPlus m) => MonadTry m where++  {- | A handler for failures.+  Used for backtracking state on failure in+  `Data.Profunctor.Grammar.Parsector.Parsector`.+  -}+  try :: m a -> m a+  default try :: m a -> m a+  try = id

@@ -10,22 +10,11 @@  module Data.Profunctor.Distributor   ( -- * Distributor-    Distributor (..), dialt+    Distributor (..)+  , dialt     -- * Alternator   , Alternator (..)   , choice-  , option-    -- * Homogeneous-  , Homogeneous (..)-    -- * SepBy-  , SepBy (..)-  , sepBy-  , noSep-  , several-  , several1-  , chain-  , chain1-  , intercalateP   ) where  import Control.Applicative hiding (WrappedArrow)@@ -37,14 +26,9 @@ import Data.Bifunctor.Clown import Data.Bifunctor.Joker import Data.Bifunctor.Product-import Data.Complex import Data.Foldable hiding (toList) import Data.Functor.Adjunction-import Data.Functor.Compose import Data.Functor.Contravariant.Divisible-import qualified Data.Functor.Product as Functor-import qualified Data.Functor.Sum as Functor-import qualified Data.Monoid as Monoid import Data.Profunctor hiding (WrappedArrow) import Data.Profunctor qualified as Pro (WrappedArrow) import Data.Profunctor.Cayley@@ -52,14 +36,7 @@ import Data.Profunctor.Monad import Data.Profunctor.Monoidal import Data.Profunctor.Yoneda-import Data.Proxy-import Data.Sequence (Seq)-import Data.Tagged-import Data.Tree (Tree (..))-import Data.Vector (Vector) import Data.Void-import GHC.Exts-import GHC.Generics  -- Distributor -- @@ -88,12 +65,19 @@ prop> p >+< q >+< r = assoc ((p >+< q) >+< r) prop> dimap (f >+< g) (h >+< i) (p >+< q) = dimap f h p >+< dimap g i q +`Distributor` additionally has methods `manyP` & `optionalP`,+distributing an action over @[]@ and `Maybe` datatypes,+which generalize to `Data.Traversable.Homogeneous.homogeneously`+distributing an action over+`Data.Traversable.Homogeneous.Homogeneous`+sum-of-products datatypes.+ -} class Monoidal p => Distributor p where    {- | The zero structure morphism of a `Distributor`. -  `zeroP` has a default for `Alternator`.+  `zeroP` has a default for `Alternator`s.    prop> zeroP = empty   -}@@ -103,7 +87,7 @@    {- | The sum structure morphism of a `Distributor`. -  `>+<` has a default for `Alternator`.+  `>+<` has a default for `Alternator`s.    prop> x >+< y = alternate (Left x) <|> alternate (Right y)   -}@@ -116,11 +100,11 @@    {- | One or none. -}   optionalP :: p a b -> p (Maybe a) (Maybe b)-  optionalP p = eotMaybe >~ oneP >+< p+  optionalP p = eotMaybe >~ p >+< oneP    {- | Zero or more. -}   manyP :: p a b -> p [a] [b]-  manyP p = eotList >~ oneP >+< p >*< manyP p+  manyP p = eotList >~ p >*< manyP p >+< oneP  instance Distributor (->) where   zeroP = id@@ -203,134 +187,42 @@   -> p a b -> p c d -> p s t dialt f g h p q = dimap f (either g h) (p >+< q) -{- | A class of `Homogeneous`-countable sums of countable products.--}-class Traversable t => Homogeneous t where-  {- | Sequences actions `homogeneously`.--  prop> homogeneously @Maybe = optionalP-  prop> homogeneously @[] = manyP--  Any `Traversable` & `Data.Distributive.Distributive` countable product-  can be given a default implementation for the `homogeneously` method.--  prop> homogeneously = ditraverse--  And any user-defined homogeneous algebraic datatype has-  a default instance for `Homogeneous`, by deriving `Generic1`.-  -}-  homogeneously :: Distributor p => p a b -> p (t a) (t b)-  default homogeneously-    :: (Generic1 t, Homogeneous (Rep1 t), Distributor p)-    => p a b -> p (t a) (t b)-  homogeneously = dimap from1 to1 . homogeneously-instance Homogeneous Par1 where-  homogeneously = dimap unPar1 Par1-instance Homogeneous Identity where-  homogeneously = dimap runIdentity Identity-instance Homogeneous Monoid.Dual where-  homogeneously = dimap Monoid.getDual Monoid.Dual-instance Homogeneous Monoid.Product where-  homogeneously = dimap Monoid.getProduct Monoid.Product-instance Homogeneous Monoid.Sum where-  homogeneously = dimap Monoid.getSum Monoid.Sum-instance Homogeneous (Tagged s) where-  homogeneously = dimap unTagged Tagged-instance Homogeneous U1 where-  homogeneously _ = pure U1-instance Homogeneous (K1 i ()) where-  homogeneously _ = pure (K1 ())-instance Homogeneous (Const ()) where-  homogeneously _ = pure (Const ())-instance Homogeneous Proxy where-  homogeneously _ = pure Proxy-instance (Homogeneous s, Homogeneous t)-  => Homogeneous (s :.: t) where-    homogeneously-      = dimap unComp1 Comp1-      . homogeneously . homogeneously-instance (Homogeneous s, Homogeneous t)-  => Homogeneous (Compose s t) where-    homogeneously-      = dimap getCompose Compose-      . homogeneously . homogeneously-instance (Homogeneous s, Homogeneous t)-  => Homogeneous (s :*: t) where-    homogeneously p = dimap2-      (\(s :*: _) -> s)-      (\(_ :*: t) -> t)-      (:*:)-      (homogeneously p)-      (homogeneously p)-instance (Homogeneous s, Homogeneous t)-  => Homogeneous (Functor.Product s t) where-    homogeneously p = dimap2-      (\(Functor.Pair s _) -> s)-      (\(Functor.Pair _ t) -> t)-      Functor.Pair-      (homogeneously p)-      (homogeneously p)-instance Homogeneous V1 where-  homogeneously _ = dimap (\case) (\case) zeroP-instance Homogeneous (K1 i Void) where-  homogeneously _ = dimap unK1 K1 zeroP-instance Homogeneous (Const Void) where-  homogeneously _ = dimap getConst Const zeroP-instance (Homogeneous s, Homogeneous t)-  => Homogeneous (s :+: t) where-    homogeneously p = dialt-      (\case {L1 s -> Left s; R1 t -> Right t})-      L1-      R1-      (homogeneously p)-      (homogeneously p)-instance (Homogeneous s, Homogeneous t)-  => Homogeneous (Functor.Sum s t) where-    homogeneously p = dialt-      (\case {Functor.InL s -> Left s; Functor.InR t -> Right t})-      Functor.InL-      Functor.InR-      (homogeneously p)-      (homogeneously p)-instance Homogeneous t-  => Homogeneous (M1 i c t) where-    homogeneously = dimap unM1 M1 . homogeneously-instance Homogeneous f => Homogeneous (Rec1 f) where-  homogeneously = dimap unRec1 Rec1 . homogeneously-instance Homogeneous Maybe where-  homogeneously = optionalP-instance Homogeneous [] where-  homogeneously = manyP-instance Homogeneous Vector where-  homogeneously p = eotList >~ oneP >+< p >*< homogeneously p-instance Homogeneous Seq where-  homogeneously p = eotList >~ oneP >+< p >*< homogeneously p-instance Homogeneous Complex where-  homogeneously p = dimap2 realPart imagPart (:+) p p-instance Homogeneous Tree where-  homogeneously p = dimap2 rootLabel subForest Node p (manyP (homogeneously p))- -- Alternator --  {- | The `Alternator` class co-extends `Choice` and `Distributor`, as well as `Alternative`, adding the `alternate` method,-which is a lax monoidal structure morphism on sums.+which is a lax monoidal structure morphism on sums,+and methods `someP` & `optionP`,+with these these laws relating them. -For the case of `Functor`s the analog of `alternate` can be defined+prop> left' = alternate . Left+prop> right' = alternate . Right+prop> zeroP = empty+prop> x >+< y = alternate (Left x) <|> alternate (Right y)+prop> manyP p = optionP _Empty (someP p)+prop> optionalP p = optionP _Nothing (_Just >? p)+prop> someP p = p >:< manyP p++For the case of `Functor`s, the analog of `alternate` can be defined without any other constraint, but the case of `Profunctor`s turns-out to be slighly more complex.+out to be slighly more complex, necessitating `Alternator`.++>>> :{+alternateF :: Functor f => Either (f a) (f b) -> f (Either a b)+alternateF = either (fmap Left) (fmap Right)+:}++Not all `Distributor`s are `Alternator`s, in particular @(->)@ is+a `Distributor` but cannot be `Alternative`,+because there is no general polymorphic function @empty :: a -> b@,+so @(->)@ isn't an `Alternator`.+ -} class (Choice p, Distributor p, forall x. Alternative (p x))   => Alternator p where -    {- |-    prop> left' = alternate . Left-    prop> right' = alternate . Right-    prop> zeroP = empty-    prop> x >+< y = alternate (Left x) <|> alternate (Right y)--    `alternate` has a default for `Cochoice`.+    {- | The structure morphism for an `Alternator`,+    `alternate` has a default for `Choice` & `Cochoice` partial distributors.     -}     alternate       :: Either (p a b) (p c d)@@ -346,16 +238,16 @@      {- | One or more. -}     someP :: p a b -> p [a] [b]-    someP p = _Cons >? p >*< manyP p+    someP x = x >:< manyP x +    {- | One or zero-with-default. -}+    optionP :: APrism a b () () {- ^ default -} -> p a b -> p a b+    optionP def p = p <|> pureP def+ -- | Combines all `Alternative` choices in the specified list. choice :: (Foldable f, Alternative p) => f (p a) -> p a choice = foldl' (<|>) empty --- | Perform an `Alternative` action or return a default value.-option :: Alternative p => a {- ^ default value -} -> p a -> p a-option a p = p <|> pure a- instance (Alternator p, Applicative f)   => Alternator (WrappedPafb f p) where     alternate =@@ -372,88 +264,15 @@           . unwrapPafb       in         either f g-     someP (WrapPafb x) = WrapPafb (rmap sequenceA (someP x))+    optionP def (WrapPafb x) = WrapPafb (optionP (prism pure pure . def) x) instance Alternator p => Alternator (Coyoneda p) where   alternate (Left p) = proreturn (alternate (Left (proextract p)))   alternate (Right p) = proreturn (alternate (Right (proextract p)))   someP = proreturn . someP . proextract+  optionP def = proreturn . optionP def . proextract instance Alternator p => Alternator (Yoneda p) where   alternate (Left p) = proreturn (alternate (Left (proextract p)))   alternate (Right p) = proreturn (alternate (Right (proextract p)))   someP = proreturn . someP . proextract--{- | Used to sequence multiple times,-separated by a `separateBy`,-begun by a `beginBy`,-and ended by an `endBy`. -}-data SepBy p = SepBy-  { beginBy :: p-  , endBy :: p-  , separateBy :: p-  } deriving stock-    ( Functor, Foldable, Traversable-    , Eq, Ord, Show, Read-    )--{- | A `SepBy` smart constructor,-setting the `separateBy` field,-with no beginning or ending delimitors,-except by updating `beginBy` or `endBy` fields. -}-sepBy :: Monoidal p => p () () -> SepBy (p () ())-sepBy = SepBy oneP oneP--{- | A `SepBy` smart constructor for no separator,-beginning or ending delimiters. -}-noSep :: Monoidal p => SepBy (p () ())-noSep = sepBy oneP--{- |-prop> several noSep = manyP--}-several-  :: (IsList s, IsList t, Distributor p)-  => SepBy (p () ()) -> p (Item s) (Item t) -> p s t-several (SepBy beg end sep) p = iso toList fromList . eotList >~-  beg >* (oneP >+< p >*< manyP (sep >* p)) *< end--{- |-prop> several1 noSep p = someP p--}-several1-  :: (IsList s, IsList t, Distributor p, Choice p)-  => SepBy (p () ()) -> p (Item s) (Item t) -> p s t-several1 (SepBy beg end sep) p = iso toList fromList . _Cons >?-  beg >* (p >*< manyP (sep >* p)) *< end--{- | Use a nilary constructor pattern to sequence zero times, or-associate a binary constructor pattern to sequence one or more times. -}-chain-  :: Alternator p-  => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate-  -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern-  -> APrism a b () () -- ^ nilary constructor pattern-  -> SepBy (p () ()) -> p a b -> p a b-chain association pat2 pat0 (SepBy beg end sep) p =-  beg >* (pat0 >? oneP <|> chain1 association pat2 (sepBy sep) p) *< end--{- | Associate a binary constructor pattern to sequence one or more times. -}-chain1-  :: (Distributor p, Choice p)-  => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate-  -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern-  -> SepBy (p () ()) -> p a b -> p a b-chain1 association pat (SepBy beg end sep) = leftOrRight chainl1 chainr1-  where-    leftOrRight a b = case association () of Left _ -> a; Right _ -> b-    chainl1 p = difoldl pat >? beg >* p >*< manyP (sep >* p) *< end-    chainr1 p = difoldr pat >? beg >* manyP (p *< sep) >*< p *< end--{- | `intercalateP` adds a `SepBy` to `replicateP`. -}-intercalateP-  :: (Monoidal p, Choice p, AsEmpty s, AsEmpty t, Cons s t a b)-  => Int -> SepBy (p () ()) -> p a b -> p s t-intercalateP n (SepBy beg end _) _ | n <= 0 =-  beg >* lmap (const Empty) asEmpty *< end-intercalateP n (SepBy beg end comma) p =-  beg >* p >:< replicateP (n-1) (comma >* p) *< end+  optionP def = proreturn . optionP def . proextract

@@ -28,7 +28,8 @@  {- | The `Filtrator` class extends `Cochoice`, as well as `Filterable`, adding the `filtrate` method,-which is an oplax monoidal structure morphism dual to `>+<`.+which is an oplax monoidal structure morphism dual to+`>+<`.  prop> filtrate . uncurry (>+<) = id prop> uncurry (>+<) . filtrate = id@@ -41,8 +42,12 @@     prop> unright = snd . filtrate      `filtrate` is a distant relative to `Data.Either.partitionEithers`.+    `filtrate` can be given a default value for `Monadic`+    `Alternator`s via `mfiltrate`. -    `filtrate` has a default for `Choice`.+    prop> filtrate = mfiltrate++    `filtrate` has a default for `Choice` & `Cochoice` partial profunctors.     -}     filtrate       :: p (Either a c) (Either b d)@@ -56,12 +61,13 @@       &&&       dimapMaybe (Just . Right) (either (const Nothing) Just) --- | `mfiltrate` can be used as `filtrate`, for `Monadic` `Alternator`s.+-- | A `Monadic` `Alternator` has+-- an equivalent to `filtrate`, given by `mfiltrate`. ----- prop> mfiltrate = filtrate+-- prop> filtrate = mfiltrate mfiltrate   :: (Monadic p, Alternator p)-  => p (Either a c) (Either b d)+  => p (Either a c) (Either b d) -- ^ partition `Either`   -> (p a b, p c d) mfiltrate =   (lmap Left >=> either pure (const empty))

@@ -9,13 +9,13 @@ -}  module Data.Profunctor.Grammar-  ( -- * Parsor-    Parsor (..)+  ( -- * Printor+    Printor (..)+  , printP+    -- * Parsor+  , Parsor (..)   , unparseP   , parseP-    -- * Printor-  , Printor (..)-  , printP     -- * Grammor   , Grammor (..)   ) where@@ -26,11 +26,11 @@ import Control.Lens import Control.Lens.Extras import Control.Lens.Grammar.BackusNaur-import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Control.Monad+import Control.Monad.Fail.Try import Data.Coerce import Data.Monoid import Data.Profunctor@@ -42,6 +42,15 @@ import GHC.Exts import Witherable +-- | `Printor` is a simple printer `Profunctor`.+newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)}++-- | Run the printer on a value, returning a function+-- that `cons`es tokens at the beginning of an input string,+-- from right to left.+printP :: Functor f => Printor s f a b -> a -> f (s -> s)+printP (Printor f) = fmap snd . f+ -- | `Parsor` is a simple invertible parser `Profunctor`. newtype Parsor s f a b = Parsor {runParsor :: Maybe a -> s -> f (b,s)} @@ -57,15 +66,6 @@ unparseP :: Functor f => Parsor s f a b -> a -> s -> f s unparseP (Parsor f) a = fmap snd . f (Just a) --- | `Printor` is a simple printer `Profunctor`.-newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)}---- | Run the printer on a value, returning a function--- that `cons`es tokens at the beginning of an input string,--- from right to left.-printP :: Functor f => Printor s f a b -> a -> f (s -> s)-printP (Printor f) = fmap snd . f- -- | `Grammor` is a constant `Profunctor`. newtype Grammor k a b = Grammor {runGrammor :: k} @@ -120,6 +120,9 @@       Nothing -> fmap (first' Right) (p Nothing s)       Just (Right a) -> fmap (first' Right) (p (Just a) s)       Just (Left _) -> empty+  optionP def p = Parsor $ \ma s -> case ma of+    Nothing -> runParsor (p <|> pureP def) ma s+    Just _ -> runParsor (pureP def <|> p) ma s instance (Alternative m, Monad m) => Category (Parsor s m) where   id = Parsor $ \ma s -> case ma of     Nothing -> empty@@ -177,6 +180,7 @@ 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 AsEmpty s => Matching s (Parsor s [] a b) where   word =~ p = case     [ () | (_, remaining) <- runParsor p Nothing word@@ -215,6 +219,7 @@       either (fmap (first' Left) . p) (\_ -> empty)     Right (Printor p) -> Printor $       either (\_ -> empty) (fmap (first' Right) . p)+  optionP def p = pureP def <|> p instance Filterable f => Filtrator (Printor s f) where   filtrate (Printor p) =     let@@ -284,6 +289,7 @@ 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)  -- Grammor instances instance Functor (Grammor k a) where fmap _ = coerce@@ -309,6 +315,7 @@ instance KleeneStarAlgebra k => Alternator (Grammor k) where   alternate = either coerce coerce   someP (Grammor rex) = Grammor (plusK rex)+  optionP _ (Grammor rex) = Grammor (optK rex) instance Tokenized token k => Tokenized token (Grammor k a b) where   anyToken = Grammor anyToken   token = Grammor . token

@@ -0,0 +1,400 @@+{-|+Module      : Data.Profunctor.Grammar.Parsector+Description : grammar distributor with errors+Copyright   : (C) 2026 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable++See Leijen,+[Parsec: Direct Style Monadic Parser Combinators For The Real World]+(https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/parsec-paper-letter.pdf)+-}++module Data.Profunctor.Grammar.Parsector+  ( -- * Parsector+    Parsector (..)+  , parsecP+  , unparsecP+  , ParsecState (..)+  , ParsecError (..)+  ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Data.Function (fix)+import Control.Lens+import Control.Lens.Grammar.BackusNaur+import Control.Lens.Grammar.Boole+import Control.Lens.Grammar.Kleene+import Control.Lens.Grammar.Symbol+import Control.Lens.Grammar.Token+import Control.Lens.PartialIso+import Control.Monad+import Control.Monad.Fail.Try+import Data.Profunctor+import Data.Profunctor.Distributor+import Data.Profunctor.Filtrator+import Data.Profunctor.Monoidal+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]+(https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/parsec-paper-letter.pdf).+-}+newtype Parsector s a b = Parsector+  {runParsector :: forall x. (ParsecState s b -> x) -> ParsecState s a -> x}++{- | Run `Parsector` as a parser: consume tokens from @s@,+left to right, returning a `ParsecState` whose `parsecResult`+is `Nothing` on failure and `Just` the output syntax value on success. -}+parsecP+  :: Categorized (Item s)+  => Parsector s a b+  -> s -- ^ input stream+  -> ParsecState s b+parsecP p s = runParsector p id (ParsecState False 0 s mempty Nothing)++{- | Run `Parsector` as a printer: given a syntax value @a@ and+an input stream, append tokens to @s@ left to right,+returning a `ParsecState` whose `parsecResult` is+`Nothing` on failure or `Just` a successful output syntax value,+in which case, `parsecStream` is the output stream. -}+unparsecP+  :: Categorized (Item s)+  => Parsector s a b+  -> a -- ^ input syntax+  -> s -- ^ input stream+  -> ParsecState s b+unparsecP p a s = runParsector p id (ParsecState False 0 s mempty (Just a))++{- | `ParsecState` is both the input and output type of the+underlying function inside `Parsector`.+@Parsector s a b@ is equivalent to++@ParsecState s a -> ParsecState s b@++So `ParsecState` has a dual interpretation as input and output. -}+data ParsecState s a = ParsecState+  { parsecLooked :: !Bool+    {- ^ `True` once the parser has consumed/produced at least one token+    since the last `<|>` / `try` decision point.+    Controls @LL(1)@ commitment: a failure with `parsecLooked` `True`+    is propagated immediately without trying alternatives.+    Reset to `False` by `try` on failure.+    -}+  , parsecOffset :: !Word+    -- ^ Number of tokens consumed from the start of the stream.+  , parsecStream :: s -- ^ stream+  , parsecError  :: ParsecError s+    {- ^ `ParsecError` channel.++    * If `parsecResult` is `Nothing`, this is the hard failure.+    * If `parsecResult` is `Just`, this is deferred error/hint info+      from empty-failing alternatives at the current position.++    `<|>` and `>>=` propagate and merge this field to preserve+    expected-token reporting on downstream failures.+    -}+  , parsecResult :: Maybe a+    {- ^+    As input, `Nothing` means parse mode and+    `Just` means print mode with an input syntax value.++    As output `Nothing` means failure (inspect `parsecError`) 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+when control flow reaches the same offset without commitment.+-}+data ParsecError s = ParsecError+  { 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`,+    which is either unexpectedly empty or begins with an unexpected token.+    -}+  , parsecLabels :: [Tree String]+    {- ^ Forest of `rule` labels active at the `parsecOffset`.+    Each `rule` wraps its inner labels in a new `Node`.+    `ruleRec` & `fail` also create label nodes.+    Under `<>`, forests are concatenated as siblings.+    Use `drawForest` to display.+    -}+  }++-- ParsecError instances+deriving stock instance+  ( Categorized (Item s)+  , Show (Item s), Show (Categorize (Item s))+  ) => Show (ParsecError 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 []++-- ParsecState instances+deriving stock instance Functor (ParsecState s)+deriving stock instance Foldable (ParsecState s)+deriving stock instance Traversable (ParsecState s)+deriving stock instance+  ( Categorized (Item s)+  , Show (Item s), Show (Categorize (Item s))+  , Show a, Show s+  ) => Show (ParsecState s a)+deriving stock instance+  ( Categorized (Item s)+  , Read (Item s), Read (Categorize (Item s))+  , Read a, Read s+  ) => Read (ParsecState s a)+deriving stock instance+  ( Categorized (Item s)+  , Eq a, Eq s+  ) => Eq (ParsecState s a)+deriving stock instance+  ( Categorized (Item s)+  , Ord a, Ord s+  ) => Ord (ParsecState s a)++-- Parsector instances+instance+  ( Categorized token, Item s ~ token+  , Cons s s token token, Snoc s s token token+  ) => Tokenized token (Parsector s token token) where+  anyToken = tokenClass anyToken+  token t = tokenClass (token t)+  oneOf ts = tokenClass (oneOf ts)+  notOneOf ts = tokenClass (notOneOf ts)+  asIn cat = tokenClass (asIn cat)+  notAsIn cat = tokenClass (notAsIn cat)+instance+  ( Categorized token, Item s ~ token+  , Cons s s token token, Snoc s s token token+  ) => TokenAlgebra token (Parsector s token token) where+    tokenClass test = Parsector $ \callback query ->+      let+        stream = parsecStream query+        mode = parsecResult query+        offset = parsecOffset query+        replyOk tok str = query+          { parsecLooked = True+          , parsecError  = mempty+          , parsecStream = str+          , parsecOffset = offset + 1+          , parsecResult = Just tok+          }+        replyErr = query+          { parsecError  = ParsecError test []+          , parsecResult = Nothing }+      in+        callback $ case mode of+          -- print mode+          Just tok+            | tokenClass test tok -> replyOk tok (snoc stream tok)+            | otherwise -> replyErr+          -- parse mode+          Nothing -> case uncons stream of+            Just (tok, rest)+              | tokenClass test tok -> replyOk tok rest+              | otherwise -> replyErr+            Nothing -> replyErr+instance BackusNaurForm (Parsector s a b) where+  -- | Wraps inner `parsecLabels` in a new `Node name` on failure.+  -- Has no effect on success.+  rule name p = Parsector $ \callback query ->+    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]+          }+        Just _ -> reply+  ruleRec name = rule name . fix+instance+  ( Categorized token, Item s ~ token+  , Cons s s token token, Snoc s s token token+  ) => TerminalSymbol token (Parsector s () ())+instance Functor (Parsector s a) where+  fmap = rmap+instance Categorized (Item s) => Applicative (Parsector s a) where+  pure b = Parsector $ \callback query ->+    callback query { parsecResult = Just b }+  (<*>) = ap++instance Categorized (Item s) => Monad (Parsector s a) where+  return = pure+  p >>= f = Parsector $ \callback query ->+    flip (runParsector p) query $ \reply ->+      case parsecResult reply of+        Nothing -> callback reply { parsecResult = Nothing }+        Just b ->+          let+            hintP  = parsecError reply+            fQuery = reply+              { parsecLooked = False+              , parsecError  = mempty+              , parsecResult = parsecResult query+              }+          in+            flip (runParsector (f b)) fQuery $ \fReply -> callback $+              if parsecLooked fReply+                then fReply+                else fReply+                  { parsecLooked = parsecLooked reply+                  , parsecError  = hintP <> parsecError 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 }+  p <|> q = Parsector $ \callback query ->+    flip (runParsector p) query $ \replyP -> callback $+      case parsecResult replyP of+        -- if p succeeds, take p's branch+        Just _ -> replyP+        -- if p failed after consuming (committed), propagate immediately+        Nothing | parsecLooked replyP -> replyP+        -- if p failed without consuming, try q+        Nothing ->+          let errP = parsecError 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 }+instance Categorized (Item s) => MonadPlus (Parsector s a)+instance Categorized (Item s) => MonadFail (Parsector s a) where+  fail msg = rule msg empty+instance Categorized (Item s) => MonadTry (Parsector s a) where+  -- | On failure, resets `parsecLooked` to @False@, allowing+  -- the enclosing `<|>` to try the next alternative even if @p@+  -- consumed input. Also restores the stream/offset decision state.+  -- Has no effect on success.+  try p = Parsector $ \callback query ->+    flip (runParsector p) query $ \reply -> callback $+      case parsecResult reply of+        Nothing -> query+          { parsecLooked = False+          , parsecError  = parsecError reply+          , parsecResult = Nothing+          }+        Just _ -> reply+instance Categorized (Item s) => Filterable (Parsector s a) where+  mapMaybe = dimapMaybe Just+instance Category (Parsector s) where+  id = Parsector id+  Parsector q . Parsector p = Parsector (p . q)+instance Categorized (Item s) => Arrow (Parsector s) where+  arr f = Parsector $ \callback reply -> callback (f <$> reply)+  (***) = (>*<)+  first = first'+  second = second'+instance Categorized (Item s) => ArrowZero (Parsector s) where+  zeroArrow = empty+instance Categorized (Item s) => ArrowPlus (Parsector s) where+  (<+>) = (<|>)+instance Categorized (Item s) => ArrowChoice (Parsector s) where+  (+++) = (>+<)+  left = left'+  right = right'+instance Profunctor (Parsector s) where+  dimap f g (Parsector p) = Parsector $+    dimap (lmap (fmap g)) (lmap (fmap f)) p+instance Strong (Parsector s) where+  first' p = Parsector $ \callback reply0 ->+    flip (runParsector p) (fst <$> reply0) $ \reply1 ->+      callback reply1+        { parsecResult = (,)+            <$> parsecResult reply1+            <*> (snd <$> parsecResult reply0)+        }+  second' p = Parsector $ \callback reply0 ->+    flip (runParsector p) (snd <$> reply0) $ \reply1 ->+      callback reply1+        { parsecResult = (,)+            <$> (fst <$> parsecResult reply0)+            <*> parsecResult reply1+        }+instance Categorized (Item s) => Choice (Parsector s) where+  left' = alternate . Left+  right' = alternate . Right+instance Categorized (Item s) => Distributor (Parsector s)+instance Categorized (Item s) => Alternator (Parsector s) where+  alternate (Left p) = Parsector $ \callback query -> callback $+    let+      replyOk = query+        { parsecResult = case parsecResult query of+            Nothing         -> Nothing+            Just (Left a)   -> Just a+            Just (Right _)  -> Nothing+        }+      replyErr = query { parsecError = mempty, parsecResult = Nothing }+    in+      case (parsecResult query, parsecResult replyOk) of+        (Just _, Nothing) -> replyErr+        _________________ ->+          flip (runParsector p) replyOk $ \reply -> reply+            { parsecResult = fmap Left (parsecResult reply) }+  alternate (Right p) = Parsector $ \callback query -> callback $+    let+      replyOk = query+        { parsecResult = case parsecResult query of+            Nothing         -> Nothing+            Just (Left _)   -> Nothing+            Just (Right b)  -> Just b+        }+      replyErr = query { parsecError = mempty, parsecResult = Nothing }+    in+      case (parsecResult query, parsecResult replyOk) of+        (Just _, Nothing) -> replyErr+        _________________ ->+          flip (runParsector p) replyOk $ \reply -> reply+            { parsecResult = fmap Right (parsecResult reply) }+  optionP def p = Parsector $ \callback query ->+    case parsecResult query of+      Nothing -> runParsector (p <|> pureP def) callback query+      Just _ -> runParsector (pureP def <|> p) callback query+instance Categorized (Item s) => Cochoice (Parsector s) where+  unleft = fst . filtrate+  unright = snd . filtrate+instance Categorized (Item s) => Filtrator (Parsector s) where+  filtrate p =+    ( Parsector $ \callback query ->+        flip (runParsector p) (Left <$> query) $ \reply ->+          callback reply+          { parsecError = case parsecResult reply of+            Just (Right _) -> mempty+            _ -> parsecError reply+          , parsecResult =+            parsecResult reply >>= either Just (const Nothing)+          }+    , Parsector $ \callback query ->+        flip (runParsector p) (Right <$> query) $ \reply ->+          callback reply+          { parsecError = case parsecResult reply of+            Just (Left _) -> mempty+            _ -> parsecError reply+          , parsecResult =+            parsecResult reply >>= either (const Nothing) Just+          }+    )

@@ -16,7 +16,8 @@ >>> import qualified Data.Profunctor.Monadic as P  See "Control.Lens.Grammar#t:CtxGrammar" for-an example of how to use "bonding" notation.+an example of how to use qualified do-notation+with pattern bonding. -}  module Data.Profunctor.Monadic@@ -25,17 +26,23 @@   , (>>=)   , (>>)   , return+    -- * MonadicTry+  , MonadicTry+  , try   , fail   ) where -import Data.Profunctor-import Prelude hiding ((>>=), (>>))+import Control.Lens+import Control.Monad hiding ((>>=), (>>), return)+import Control.Monad.Fail.Try+import Data.Profunctor.Monoidal+import Prelude hiding ((>>=), (>>), return)  {- | A `Profunctor` which is also a `Monad`. -} type Monadic p = (Profunctor p, forall x. Monad (p x))  {- | The pair bonding operator @P.@`>>=` is a context-sensitive-version of `Data.Profunctor.Monoidal.>*<`.+version of `>*<`.  prop> x >*< y = x P.>>= (\_ -> y) -}@@ -44,9 +51,20 @@ p >>= f = do   b <- lmap fst p   d <- lmap snd (f b)-  return (b,d)+  pure (b,d)  {- | @P.@`>>` sequences actions. -} (>>) :: Monadic p => p () c -> p a b -> p a b infixl 1 >> x >> y = do _ <- lmap (const ()) x; y++{- | @P.@`return` is a `Monadic`-restricted+version of `pureP`.++prop> pureP = P.return+-}+return :: (Monadic p, Choice p) => Prism a b () () -> p a b+return = pureP++{- | A `Profunctor` which is also a `MonadTry`. -}+type MonadicTry p = (Profunctor p, forall x. MonadTry (p x))

@@ -16,7 +16,7 @@   , oneP, (>*<), (>*), (*<)   , dimap2, foreverP, ditraverse     -- * Monoidal & Choice-  , replicateP, (>:<), asEmpty+  , pureP, asEmpty, (>:<), replicateP, onlyOne   , meander, eotFunList   ) where @@ -25,6 +25,7 @@ import Control.Arrow import Control.Lens hiding (chosen) import Control.Lens.Internal.Context+import Control.Lens.Internal.Prism import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso import Data.Bifunctor.Clown@@ -39,6 +40,7 @@ import Data.Profunctor.Composition import Data.Profunctor.Monad import Data.Profunctor.Yoneda+import GHC.IsList  -- Monoidal -- @@ -93,44 +95,70 @@ analagous to `liftA2`. -} dimap2   :: Monoidal p-  => (s -> a)-  -> (s -> c)-  -> (b -> d -> t)+  => (s -> a) -- ^ first projection, e.g. `fst`+  -> (s -> c) -- ^ second projection, e.g. `snd`+  -> (b -> d -> t) -- ^ pairing function, e.g. @(,)@   -> p a b -> p c d -> p s t dimap2 f g h p q = liftA2 h (lmap f p) (lmap g q) -{- | `foreverP` repeats an action indefinitely;+{- | `foreverP` repeats an action a countable infinity of times; analagous to `Control.Monad.forever`, extending it to `Monoidal`. -} foreverP :: Monoidal p => p () c -> p a b foreverP a = let a' = a >* a' in a' -{- | A `Monoidal` & `Choice` nil operator. -}-asEmpty :: (AsEmpty s, Monoidal p, Choice p) => p s s-asEmpty = _Empty >? oneP--{- | A `Monoidal` & `Choice` cons operator. -}-(>:<) :: (Cons s t a b, Monoidal p, Choice p) => p a b -> p s t -> p s t-x >:< xs = _Cons >? x >*< xs-infixr 5 >:<- {- | Thanks to Fy on Monoidal Café Discord.  A `Traversable` & `Data.Distributive.Distributive` type is a homogeneous countable product.-That means it is a static length container, so unlike `replicateP`,-`ditraverse` does not need an `Int` argument.+That means it is a static countable-length container,+so unlike `replicateP`, `ditraverse` doesn't need+an additional argument for number of repetitions. -} ditraverse   :: (Traversable t, Distributive t, Monoidal p)   => p a b -> p (t a) (t b) ditraverse p = traverse (\f -> lmap f p) (distribute id) +{- | Lift a single bidirectional element+into a `Monoidal` & `Choice` structure.+Bidirectionality is encoded by `APrism`.+Singularity is encoded by the unit type @()@.+Bidirectional elements can be generated from+nilary constructors of algebraic datatypes using `makeNestedPrisms`,+from terms of a type with an `Eq` instance using `only`,+from nil elements using `_Empty`,+or from any `.`-composition of `Control.Lens.Prism.Prism`s+terminating with a bidirectional element.+-}+pureP+  :: (Monoidal p, Choice p)+  => APrism a b () () -- ^ bidirectional element+  -> p a b+pureP pattern = pattern >? oneP++{- | A `Monoidal` & `Choice` nil combinator. -}+asEmpty :: (AsEmpty s, Monoidal p, Choice p) => p s s+asEmpty = pureP _Empty++{- | A `Monoidal` & `Choice` cons combinator. -}+(>:<) :: (Cons s t a b, Monoidal p, Choice p) => p a b -> p s t -> p s t+x >:< xs = _Cons >? x >*< xs+infixr 5 >:<++{- | Use when `IsList` with `onlyOne` `Item`. -}+onlyOne+  :: (Monoidal p, Choice p, IsList s)+  => p (Item s) (Item s) -> p s s+onlyOne p = iso toList (fromListN 1) >? p >:< asEmpty+ {- | `replicateP` is analagous to `Control.Monad.replicateM`,-for `Monoidal` & `Choice` `Profunctor`s. -}+for `Monoidal` & `Choice` `Profunctor`s. When the number+of repetitions is less than or equal to 0, it returns `asEmpty`.+-} replicateP-  :: (Monoidal p, Choice p, AsEmpty s, AsEmpty t, Cons s t a b)-  => Int -> p a b -> p s t-replicateP n _ | n <= 0 = lmap (const Empty) asEmpty+  :: (Monoidal p, Choice p, AsEmpty s, Cons s s a a)+  => Int {- ^ number of repetitions -} -> p a a -> p s s+replicateP n _ | n <= 0 = asEmpty replicateP n a = a >:< replicateP (n-1) a  {- | For any `Monoidal`, `Choice` & `Strong` `Profunctor`,@@ -177,7 +205,7 @@ fromFun :: FunList a b t -> Bazaar (->) a b t fromFun = \case   DoneFun t -> pure t-  MoreFun a f -> ($) <$> f <*> sell a+  MoreFun a f -> flip ($) <$> sell a <*> f instance Functor (FunList a b) where   fmap f = \case     DoneFun t -> DoneFun (f t)@@ -247,3 +275,14 @@     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+    )

@@ -0,0 +1,127 @@+{-|+Module      : Data.Profunctor.Separator+Description : separators+Copyright   : (C) 2026 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable+-}++module Data.Profunctor.Separator+  ( -- * SepBy+    SepBy (..)+  , sepBy+  , noSep+  , sepWith+  , beginWith+  , endWith+    -- * SepBy Combinators+  , several+  , several1+  , chain+  , chain1+  , intercalateP+  ) where++import Control.Lens+import Control.Lens.PartialIso+import Control.Lens.Grammar.Symbol+import Data.Profunctor.Distributor+import Data.Profunctor.Monoidal+import GHC.Exts++{- | Used to sequence multiple times,+separated by a `separateBy`,+begun by a `beginBy`,+and ended by an `endBy`. -}+data SepBy p = SepBy+  { beginBy :: p+  , endBy :: p+  , separateBy :: p+  } deriving stock+    ( Functor, Foldable, Traversable+    , Eq, Ord, Show, Read+    )++{- | A `SepBy` smart constructor,+setting the `separateBy` field.+Beginning and ending delimitors will be no-ops,+except by modifier record updates `beginBy` or `endBy`. -}+sepBy :: Applicative p => p () -> SepBy (p ())+sepBy = SepBy (pure ()) (pure ())++{- | A `SepBy` smart constructor for no separator,+beginning or ending delimiters. -}+noSep :: Applicative p => SepBy (p ())+noSep = sepBy (pure ())++{- | A `SepBy` smart constructor like `sepBy`,+with a `terminal` argument.+Beginning and ending delimitors will be no-ops,+except by applying smart modifiers `beginWith` or `endWith`. -}+sepWith+  :: (Applicative p, TerminalSymbol c (p ()))+  => [c] -> SepBy (p ())+sepWith = sepBy . terminal++{- | A `SepBy` smart modifier like `beginBy`,+with a `terminal` argument. -}+beginWith :: TerminalSymbol c p => [c] -> SepBy p -> SepBy p+beginWith str separator = separator {beginBy = terminal str}++{- | A `SepBy` smart modifier like `endBy`,+with a `terminal` argument. -}+endWith :: TerminalSymbol c p => [c] -> SepBy p -> SepBy p+endWith str separator = separator {endBy = terminal str}++{- |+prop> several noSep = manyP+-}+several+  :: (IsList s, IsList t, Distributor p)+  => SepBy (p () ()) -> p (Item s) (Item t) -> p s t+several (SepBy beg end sep) p = iso toList fromList . eotList >~+  beg >* (p >*< manyP (sep >* p) >+< oneP) *< end++{- |+prop> several1 noSep = someP+-}+several1+  :: (IsList s, IsList t, Distributor p, Choice p)+  => SepBy (p () ()) -> p (Item s) (Item t) -> p s t+several1 (SepBy beg end sep) p = iso toList fromList . _Cons >?+  beg >* (p >*< manyP (sep >* p)) *< end++{- | Use a nilary constructor pattern to sequence zero times, or+associate a binary constructor pattern to sequence one or more times. -}+chain+  :: Alternator p+  => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate+  -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern+  -> APrism a b () () -- ^ nilary constructor pattern+  -> SepBy (p () ()) -> p a b -> p a b+chain association pat2 pat0 (SepBy beg end sep) p =+  beg >* optionP pat0 (chain1 association pat2 (sepBy sep) p) *< end++{- | Associate a binary constructor pattern to sequence one or more times. -}+chain1+  :: (Distributor p, Choice p)+  => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate+  -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern+  -> SepBy (p () ()) -> p a b -> p a b+chain1 association pat (SepBy beg end sep) = leftOrRight chainl1 chainr1+  where+    leftOrRight a b = case association () of Left _ -> a; Right _ -> b+    chainl1 p = difoldl pat >? beg >* p >*< manyP (sep >* p) *< end+    chainr1 p = difoldr pat >? beg >* manyP (p *< sep) >*< p *< end++{- | Add a `SepBy` to `replicateP` using `intercalateP`. -}+intercalateP+  :: (Monoidal p, Choice p, AsEmpty s, Cons s s a a)+  => Int {- ^ number of repetitions -}+  -> SepBy (p () ()) -> p a a -> p s s+intercalateP n (SepBy beg end _) _ | n <= 0 =+  beg >* asEmpty *< end+intercalateP n (SepBy beg end comma) p =+  beg >* p >:< replicateP (n-1) (comma >* p) *< end

@@ -0,0 +1,142 @@+{-|+Module      : Data.Traversable.Homogeneous+Description : homogeneous+Copyright   : (C) 2026 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable+-}++module Data.Traversable.Homogeneous+  ( -- * Homogeneous+    Homogeneous (..)+  ) where++import Control.Applicative+import Control.Lens hiding (chosen)+import Control.Lens.PartialIso+import Data.Complex+import Data.Functor.Compose+import qualified Data.Functor.Product as Functor+import qualified Data.Functor.Sum as Functor+import qualified Data.Monoid as Monoid+import Data.Profunctor.Monoidal+import Data.Proxy+import Data.Sequence (Seq)+import Data.Tagged+import Data.Tree (Tree (..))+import Data.Vector (Vector)+import Data.Void+import GHC.Generics++import Data.Profunctor.Distributor++{- | A class of `Homogeneous`+countable sums of countable products.+-}+class Traversable t => Homogeneous t where+  {- | Sequences actions `homogeneously`.++  prop> homogeneously @Maybe = optionalP+  prop> homogeneously @[] = manyP++  Any `Traversable` & `Data.Distributive.Distributive` countable product+  can be given a default implementation for the `homogeneously` method+  with `ditraverse`.++  prop> homogeneously = ditraverse++  And any user-defined homogeneous algebraic datatype has+  a default instance for `Homogeneous`, by deriving `Generic1`.+  -}+  homogeneously :: Distributor p => p a b -> p (t a) (t b)+  default homogeneously+    :: (Generic1 t, Homogeneous (Rep1 t), Distributor p)+    => p a b -> p (t a) (t b)+  homogeneously = dimap from1 to1 . homogeneously+instance Homogeneous Par1 where+  homogeneously = dimap unPar1 Par1+instance Homogeneous Identity where+  homogeneously = dimap runIdentity Identity+instance Homogeneous Monoid.Dual where+  homogeneously = dimap Monoid.getDual Monoid.Dual+instance Homogeneous Monoid.Product where+  homogeneously = dimap Monoid.getProduct Monoid.Product+instance Homogeneous Monoid.Sum where+  homogeneously = dimap Monoid.getSum Monoid.Sum+instance Homogeneous (Tagged s) where+  homogeneously = dimap unTagged Tagged+instance Homogeneous U1 where+  homogeneously _ = pure U1+instance Homogeneous (K1 i ()) where+  homogeneously _ = pure (K1 ())+instance Homogeneous (Const ()) where+  homogeneously _ = pure (Const ())+instance Homogeneous Proxy where+  homogeneously _ = pure Proxy+instance (Homogeneous s, Homogeneous t)+  => Homogeneous (s :.: t) where+    homogeneously+      = dimap unComp1 Comp1+      . homogeneously . homogeneously+instance (Homogeneous s, Homogeneous t)+  => Homogeneous (Compose s t) where+    homogeneously+      = dimap getCompose Compose+      . homogeneously . homogeneously+instance (Homogeneous s, Homogeneous t)+  => Homogeneous (s :*: t) where+    homogeneously p = dimap2+      (\(s :*: _) -> s)+      (\(_ :*: t) -> t)+      (:*:)+      (homogeneously p)+      (homogeneously p)+instance (Homogeneous s, Homogeneous t)+  => Homogeneous (Functor.Product s t) where+    homogeneously p = dimap2+      (\(Functor.Pair s _) -> s)+      (\(Functor.Pair _ t) -> t)+      Functor.Pair+      (homogeneously p)+      (homogeneously p)+instance Homogeneous V1 where+  homogeneously _ = dimap (\case) (\case) zeroP+instance Homogeneous (K1 i Void) where+  homogeneously _ = dimap unK1 K1 zeroP+instance Homogeneous (Const Void) where+  homogeneously _ = dimap getConst Const zeroP+instance (Homogeneous s, Homogeneous t)+  => Homogeneous (s :+: t) where+    homogeneously p = dialt+      (\case {L1 s -> Left s; R1 t -> Right t})+      L1+      R1+      (homogeneously p)+      (homogeneously p)+instance (Homogeneous s, Homogeneous t)+  => Homogeneous (Functor.Sum s t) where+    homogeneously p = dialt+      (\case {Functor.InL s -> Left s; Functor.InR t -> Right t})+      Functor.InL+      Functor.InR+      (homogeneously p)+      (homogeneously p)+instance Homogeneous t+  => Homogeneous (M1 i c t) where+    homogeneously = dimap unM1 M1 . homogeneously+instance Homogeneous f => Homogeneous (Rec1 f) where+  homogeneously = dimap unRec1 Rec1 . homogeneously+instance Homogeneous Maybe where+  homogeneously = optionalP+instance Homogeneous [] where+  homogeneously = manyP+instance Homogeneous Vector where+  homogeneously p = eotList >~ p >*< homogeneously p >+< oneP+instance Homogeneous Seq where+  homogeneously p = eotList >~ p >*< homogeneously p >+< oneP+instance Homogeneous Complex where+  homogeneously p = dimap2 realPart imagPart (:+) p p+instance Homogeneous Tree where+  homogeneously p = dimap2 rootLabel subForest Node p (manyP (homogeneously p))

@@ -7,12 +7,6 @@ import Control.Applicative import Control.Lens import Control.Lens.Grammar-import Control.Lens.Grammar.BackusNaur-import Control.Lens.Grammar.Symbol-import Control.Lens.Grammar.Token-import Control.Lens.PartialIso-import Data.Profunctor.Distributor-import Data.Profunctor.Monoidal import Numeric.Natural  data Arith@@ -27,9 +21,9 @@ arithGrammar = ruleRec "arith" sumG   where     sumG arith = rule "sum" $-      chain1 Left _Add (sepBy (terminal "+")) (prodG arith)+      chain1 Left _Add (sepWith "+") (prodG arith)     prodG arith = rule "product" $-      chain1 Left _Mul (sepBy (terminal "*")) (factorG arith)+      chain1 Left _Mul (sepWith "*") (factorG arith)     factorG arith = rule "factor" $       number <|> terminal "(" >* arith *< terminal ")"     number = rule "number" $

@@ -0,0 +1,36 @@+module Examples.Chain+  ( Chain (..)+  , chainGrammar+  , chainExamples+  ) where++import Control.Applicative+import Control.Lens+import Control.Lens.Grammar++data Chain+  = Emp+  | Char Char+  | Seq Chain Chain+  deriving stock (Eq, Ord, Show, Read)++makePrisms ''Chain++chainGrammar :: CtxGrammar Char Chain+chainGrammar = ruleRec "chain" seqG+  where+    seqG chn = rule "seq" $+      chain Left _Seq _Emp noSep (atomG chn)+    atomG chn = rule "atom" $+      _Char >? charG <|> terminal "(" >* chn *< terminal ")"+    charG = notOneOf "()\\"+      <|> terminal "\\" >* oneOf "()\\"++chainExamples :: [(Chain, String)]+chainExamples =+  [ (Char 'x', "x")+  , (Seq (Char '1') (Char '2'), "12")+  , (Seq (Seq (Char 'x') (Char 'y')) (Char 'z'), "xyz")+  , (Seq (Char 'x') (Seq (Char 'y') (Char 'z')), "x(yz)")+  , (Emp, "")+  ]

@@ -7,13 +7,6 @@ import Control.Applicative import Control.Lens import Control.Lens.Grammar-import Control.Lens.Grammar.BackusNaur-import Control.Lens.Grammar.Boole-import Control.Lens.Grammar.Symbol-import Control.Lens.Grammar.Token-import Control.Lens.PartialIso-import Data.Profunctor.Distributor-import Data.Profunctor.Monoidal import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) import Numeric.Natural@@ -60,7 +53,7 @@      -- members = member | member ',' members     membersG json = rule "members" $-      several1 (sepBy (terminal ",")) (memberG json)+      several1 (sepWith ",") (memberG json)      -- member = ws string ws ':' element     memberG json = rule "member" $@@ -74,7 +67,7 @@      -- elements = element | element ',' elements     elementsG json = rule "elements" $-      several1 (sepBy (terminal ",")) (elementG json)+      several1 (sepWith ",") (elementG json)      -- string = '"' characters '"'     stringG = rule "string" $

@@ -6,12 +6,6 @@  import Control.Lens import Control.Lens.Grammar-import Control.Lens.Grammar.BackusNaur-import Control.Lens.Grammar.Symbol-import Control.Lens.Grammar.Token-import Control.Lens.PartialIso-import Data.Profunctor.Distributor-import Data.Profunctor.Monoidal  -- | Abstract syntax tree for lambda calculus terms data Lambda@@ -40,7 +34,7 @@     -- Application: left-associative chain of atoms     -- e.g., "f x y" parses as "(f x) y"     appG term = rule "application" $-      chain1 Left _App (sepBy (terminal " ")) (atomG term)+      chain1 Left _App (sepWith " ") (atomG term)      -- Atomic term: variable or parenthesized term     atomG term = rule "atom" $ choice

@@ -5,10 +5,6 @@   ) where  import Control.Lens.Grammar-import Control.Lens.Grammar.Symbol-import Control.Lens.Grammar.Token-import Control.Lens.PartialIso-import Data.Profunctor.Distributor import qualified Data.Profunctor.Monadic as P import Numeric.Natural @@ -21,7 +17,7 @@ lenvecGrammar = _LenVec >? P.do   let     numberG = iso show read >~ someP (asIn @Char DecimalNumber)-    vectorG n = intercalateP n (sepBy (terminal ",")) numberG+    vectorG n = intercalateP n (sepWith ",") numberG   len <- numberG             -- bonds to _LenVec   terminal ";"               -- doesn't bond   vectorG (fromIntegral len) -- bonds to _LenVec

@@ -3,17 +3,14 @@   ) where  import Control.Lens.Grammar-import Control.Lens.Grammar.Boole-import Control.Lens.Grammar.Kleene-import Control.Lens.Grammar.Symbol-import Control.Lens.Grammar.Token  regexExamples :: [(RegString, String)] regexExamples =   [ (terminal "abc123etc.", "abc123etc.")   , (terminal "x" <> terminal "y", "xy")   , (zeroK, "[]")-  , (terminal "x" >|< terminal "y", "x|y")+  , (terminal "xy" >|< terminal "z", "xy|z")+  , (token 'x' >|< token 'y', "[xy]")   , (optK (terminal "x"), "x?")   , (starK (terminal "x"), "x*")   , (plusK (terminal "x"), "x+")@@ -29,13 +26,10 @@    -- Boolean OR (>||<) operations   , (tokenClass (oneOf "abc" >||< oneOf "xyz"), "[abcxyz]")-  , (tokenClass (notOneOf "abc" >||< notOneOf "xyz"), "[^]")   , (tokenClass (oneOf "abc" >||< notOneOf "xyz"), "[abc]|[^xyz]")   , (tokenClass (notOneOf "abc" >||< oneOf "xyz"), "[^abc]|[xyz]")   , (tokenClass (asIn UppercaseLetter >||< asIn LowercaseLetter), "\\p{Lu}|\\p{Ll}")-  , (tokenClass (notAsIn Control >||< notAsIn Space), "[^]")   , (tokenClass (oneOf "abc" >||< asIn DecimalNumber), "[abc]|\\p{Nd}")-  , (tokenClass (notOneOf "xyz" >||< notAsIn UppercaseLetter), "[^]")    -- Boolean AND (>&&<) operations   , (tokenClass (oneOf "abcdef" >&&< oneOf "def123"), "[def]")@@ -45,7 +39,7 @@   , (tokenClass (notOneOf "abc" >&&< notAsIn Control), "[^abc\\P{Cc}]")   , (tokenClass (asIn UppercaseLetter >&&< notOneOf "XYZ"), "[^XYZ\\p{Lu}]")   , (tokenClass (notAsIn Control >&&< notAsIn Space), "\\P{Zs|Cc}")-  , (tokenClass (oneOf "0123456789" >&&< asIn DecimalNumber), "[0123456789]")+  , (tokenClass (oneOf "0123456789xyz" >&&< asIn DecimalNumber), "[0123456789]")    -- Boolean NOT (notB) operations   , (tokenClass (notB (oneOf "abc")), "[^abc]")@@ -55,9 +49,9 @@   , (tokenClass (notB (notAsIn Control)), "\\p{Cc}")   , (tokenClass (notB (notOneOf "abc" >&&< asIn LowercaseLetter)), "[abc]|\\P{Ll}") -  -- fromBool operations-  , (tokenClass (fromBool True), "[^]")-  , (tokenClass (fromBool False), "[]")+  -- trueB & falseB+  , (tokenClass trueB, "[^]")+  , (tokenClass falseB, "[]")    -- Complex combinations   , (tokenClass (notOneOf "abc" >&&< (asIn LowercaseLetter >||< asIn UppercaseLetter)), "[^abc\\p{Ll}]|\\p{Lu}")

@@ -5,14 +5,7 @@   ) where  import Control.Lens hiding (List)-import Control.Lens.Grammar-import Control.Lens.Grammar.BackusNaur-import Control.Lens.Grammar.Boole-import Control.Lens.Grammar.Symbol-import Control.Lens.Grammar.Token-import Control.Lens.PartialIso hiding (List)-import Data.Profunctor.Distributor-import Data.Profunctor.Monoidal+import Control.Lens.Grammar hiding (List)  -- | Abstract syntax tree for S-expressions data SExpr@@ -36,7 +29,7 @@     -- List: parenthesized sequence of S-expressions     -- Elements are separated by whitespace     listG sexpr = rule "list" $-      terminal "(" >* several (sepBy (terminal " ")) sexpr *< terminal ")"+      terminal "(" >* several (sepWith " ") sexpr *< terminal ")"      -- Characters allowed in atoms: letters, digits, and symbols     atomChars =

@@ -6,13 +6,9 @@   ) where  import Control.Applicative+import Control.Lens import Control.Lens.Grammar-import Control.Lens.Grammar.Symbol-import Control.Lens.Grammar.Token-import Control.Lens.PartialIso-import Data.Profunctor.Distributor import qualified Data.Profunctor.Monadic as P-import Data.Profunctor.Monoidal import Numeric.Natural  -- | Semantic version structure following semver.org specification@@ -42,11 +38,11 @@   >?  numberG   >*< terminal "." >* numberG   >*< terminal "." >* numberG-  >*< option [] (terminal "-" >* identifiersG)-  >*< option [] (terminal "+" >* identifiersG)+  >*< optionP _Empty (terminal "-" >* identifiersG)+  >*< optionP _Empty (terminal "+" >* identifiersG)   where     numberG = iso show read >~ someP (asIn @Char DecimalNumber)-    identifiersG = several1 (sepBy (terminal ".")) (someP charG)+    identifiersG = several1 (sepWith ".") (someP charG)     charG = asIn LowercaseLetter       <|> asIn UppercaseLetter       <|> asIn DecimalNumber@@ -57,7 +53,7 @@ semverCtxGrammar = _SemVer >? P.do   let     numberG = iso show read >~ someP (asIn @Char DecimalNumber)-    identifiersG = several1 (sepBy (terminal ".")) (someP charG)+    identifiersG = several1 (sepWith ".") (someP charG)     charG = asIn LowercaseLetter       <|> asIn UppercaseLetter       <|> asIn DecimalNumber@@ -65,8 +61,8 @@   _ <- numberG   _ <- terminal "." >* numberG   _ <- terminal "." >* numberG-  _ <- option [] (terminal "-" >* identifiersG)-  option [] (terminal "+" >* identifiersG)+  _ <- optionP _Empty (terminal "-" >* identifiersG)+  optionP _Empty (terminal "+" >* identifiersG)  semverExamples :: [(SemVer, String)] semverExamples =

@@ -1,39 +1,66 @@ module Main (main) where  import Data.Foldable hiding (toList)-import Data.Maybe (listToMaybe) import Control.Lens.Grammar+import Control.Monad (when)+import Data.IORef+import Data.List (genericLength)+import Data.Maybe (isJust)+import Data.Profunctor.Types (Star (..))+import System.Environment (lookupEnv) import Test.DocTest import Test.Hspec -import Examples.RegString import Examples.Arithmetic+import Examples.Chain import Examples.Json-import Examples.SExpr import Examples.Lambda import Examples.LenVec+import Examples.RegString import Examples.SemVer+import Examples.SExpr+import Properties.Kleene  main :: IO () main = do-  doctests+  shouldRunDoctests <- isJust <$> lookupEnv "DISTRIBUTORS_RUN_DOCTESTS"   hspec $ do-    testGrammar "regexGrammar" regexGrammar regexExamples-    testGrammar "semverGrammar" semverGrammar semverExamples-    testGrammar "semverCtxGrammar" semverCtxGrammar semverExamples-    testGrammar "arithGrammar" arithGrammar arithExamples-    testGrammar "jsonGrammar" jsonGrammar jsonExamples-    testGrammar "sexprGrammar" sexprGrammar sexprExamples-    testGrammar "lambdaGrammar" lambdaGrammar lambdaExamples-    testGrammar "lenvecGrammar" lenvecGrammar lenvecExamples+    when shouldRunDoctests $+      describe "doctest" $+        it "should run haddock examples" doctests+    describe "regexGrammar" $ for_ regexExamples $ testGrammar False regexGrammar+    describe "semverGrammar" $ for_ semverExamples $ testCtxGrammar True semverGrammar+    describe "semverCtxGrammar" $ for_ semverExamples $ testCtxGrammar True semverCtxGrammar+    describe "arithGrammar" $ for_ arithExamples $ testGrammar True arithGrammar+    describe "jsonGrammar" $ for_ jsonExamples $ testCtxGrammar False jsonGrammar+    describe "sexprGrammar" $ for_ sexprExamples $ testCtxGrammar True sexprGrammar+    describe "lambdaGrammar" $ for_ lambdaExamples $ testCtxGrammar True lambdaGrammar+    describe "lenvecGrammar" $ for_ lenvecExamples $ testCtxGrammar True lenvecGrammar+    describe "chainGrammar" $ for_ chainExamples $ testCtxGrammar True chainGrammar+    describe "Parsector try rollback" tryRollbackTests+    describe "Kleene" kleeneProperties+    describe "meander" meanderProperties +tryRollbackTests :: Spec+tryRollbackTests = do+  it "rolls back parse stream/offset on failed try" $ do+    let actual = parsecG (try (tokens "ab")) "ax"+    parsecLooked actual `shouldBe` False+    parsecOffset actual `shouldBe` 0+    parsecStream actual `shouldBe` "ax"+    parsecResult actual `shouldBe` (Nothing :: Maybe String)+  it "rolls back unparse stream/offset on failed try" $ do+    let actual = unparsecG (try (tokens "ab")) "ax" ""+    parsecLooked actual `shouldBe` False+    parsecOffset actual `shouldBe` 0+    parsecStream actual `shouldBe` ""+    parsecResult actual `shouldBe` (Nothing :: Maybe String)+ doctests :: IO () doctests = do   let     modulePaths =-      [ "src/Control/Lens/Grammar.hs"-      , "src/Control/Lens/Grammar/Token.hs"-      ]+      [ "src/Control/Lens/Grammar.hs" ]     languageExtensions =       [ "-XAllowAmbiguousTypes"       , "-XArrows"@@ -77,16 +104,47 @@     putStrLn modulePath     doctest (modulePath : languageExtensions) -testGrammar :: (Show a, Eq a) => String -> CtxGrammar Char a -> [(a, String)] -> Spec-testGrammar name grammar examples =-  describe name $-    for_ examples $ \(expectedSyntax, expectedString) -> do-      it ("should parse from " <> expectedString <> " correctly") $ do-        let actualSyntax = [parsed | (parsed, "") <- parseG grammar expectedString]-        listToMaybe actualSyntax `shouldBe` Just expectedSyntax-      it ("should unparse to " <> expectedString <> " correctly") $ do-        let actualString = unparseG grammar expectedSyntax ""-        actualString `shouldBe` Just expectedString-      it ("should print to " <> expectedString <> " correctly") $ do-        let actualString = ($ "") <$> printG grammar expectedSyntax-        actualString `shouldBe` Just expectedString+meanderProperties :: Spec+meanderProperties =+  it "preserves left-to-right traversal effects" $ do+    let input = ["h", "e", "l", "l", "o"]+    seenRef <- newIORef []+    let visit item = modifyIORef' seenRef (item :) >> pure ()+    units <- runStar (meander traverse (Star visit)) input+    seen <- reverse <$> readIORef seenRef+    seen `shouldBe` input+    units `shouldBe` replicate (length input) ()++testGrammar :: (Show a, Eq a) => Bool -> Grammar Char a -> (a, String) -> Spec+testGrammar isLL1 grammar (expectedSyntax, expectedString) = do+  testCtxGrammar isLL1 grammar (expectedSyntax, expectedString)+  it ("should match " <> expectedString <> " correctly") $ do+    let actualMatch = expectedString =~ regbnfG grammar+    actualMatch `shouldBe` True++testCtxGrammar :: (Show a, Eq a) => Bool -> CtxGrammar Char a -> (a, String) -> Spec+testCtxGrammar isLL1 grammar (expectedSyntax, expectedString) = do+  it ("should parseG from " <> expectedString <> " correctly") $ do+    let actualSyntax = [parsed | (parsed, "") <- parseG grammar expectedString]+    actualSyntax `shouldBe` [expectedSyntax]+  it ("should unparseG to " <> expectedString <> " correctly") $ do+    let actualString = unparseG grammar expectedSyntax ""+    actualString `shouldBe` Just expectedString+  it ("should printG to " <> expectedString <> " correctly") $ do+    let actualString = ($ "") <$> printG grammar expectedSyntax+    actualString `shouldBe` Just expectedString+  when isLL1 $ do+    it ("should parsecG from " <> expectedString <> " correctly") $ do+      let actualSyntax = parsecG grammar expectedString+      let expectedLength = genericLength expectedString+      let actualLooked = parsecLooked actualSyntax+      let actualError  = parsecError  actualSyntax+      actualSyntax `shouldBe`+        (ParsecState actualLooked expectedLength "" actualError (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+      actualString `shouldBe`+        (ParsecState actualLooked expectedLength expectedString actualError (Just expectedSyntax))

@@ -0,0 +1,120 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Properties.Kleene (kleeneProperties) where++import Control.Lens.Grammar+import Test.Hspec+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck++instance Arbitrary GeneralCategory where+  arbitrary = arbitraryBoundedEnum+  shrink = shrinkBoundedEnum++instance Arbitrary (TokenClass Char) where+  arbitrary = sized go+    where+      go 0 = frequency+        [ (1, pure falseB)+        , (1, pure trueB)+        , (4, oneOf <$> (arbitrary :: Gen [Char]))+        , (4, notOneOf <$> (arbitrary :: Gen [Char]))+        , (3, asIn <$> arbitrary)+        , (3, notAsIn <$> arbitrary)+        ]+      go n = frequency+        [ (2, go 0)+        , (2, (>||<) <$> go (n `div` 2) <*> go (n `div` 2))+        , (2, (>&&<) <$> go (n `div` 2) <*> go (n `div` 2))+        , (1, notB <$> go (n - 1))+        ]++instance Arbitrary (RegEx Char) where+  arbitrary = sized go+    where+      go 0 = frequency+        [ (1, pure (zeroK :: RegEx Char))+        , (1, pure (mempty :: RegEx Char))+        , (6, tokenClass <$> (arbitrary :: Gen (TokenClass Char)))+        ]+      go n = frequency+        [ (2, go 0)+        , (2, (<>) <$> go (n `div` 2) <*> go (n `div` 2))+        , (2, (>|<) <$> go (n `div` 2) <*> go (n `div` 2))+        , (1, starK <$> go (n - 1))+        , (1, plusK <$> go (n - 1))+        , (1, optK <$> go (n - 1))+        ]++kleeneProperties :: Spec+kleeneProperties = do+  describe "KleeneStarAlgebra" $ do+    prop "starK x = optK (plusK x)" $ \(x :: RegEx Char) ->+      starK x == optK (plusK x)+    prop "plusK x = x <> starK x" $ \(x :: RegEx Char) ->+      plusK x == x <> starK x+    prop "optK x = mempty >|< x" $ \(x :: RegEx Char) ->+      optK x == (mempty >|< x)+    prop "x >|< x = x" $ \(x :: RegEx Char) ->+      (x >|< x) == x+    prop "zeroK >|< x = x" $ \(x :: RegEx Char) ->+      (zeroK >|< x) == x+    prop "x >|< zeroK = x" $ \(x :: RegEx Char) ->+      (x >|< zeroK) == x+    prop "x >|< mempty = optK x" $ \(x :: RegEx Char) ->+      (x >|< mempty) == optK x+    prop "zeroK <> x = zeroK" $ \(x :: RegEx Char) ->+      (zeroK <> x) == zeroK+    prop "x <> zeroK = zeroK" $ \(x :: RegEx Char) ->+      (x <> zeroK) == zeroK+    prop "mempty <> x = x" $ \(x :: RegEx Char) ->+      (mempty <> x) == x+    prop "x <> mempty = x" $ \(x :: RegEx Char) ->+      (x <> mempty) == x+  describe "TokenAlgebra" $ do+    it "zeroK = tokenClass falseB" $+      (zeroK :: RegEx Char) `shouldBe` tokenClass falseB+    prop "tokenClass x >|< tokenClass y = tokenClass (x >||< y)" $+      \(x :: TokenClass Char) (y :: TokenClass Char) ->+        ((tokenClass x :: RegEx Char) >|< tokenClass y)+          == tokenClass (x >||< y)+  describe "TokenAlgebra RegEx" $ do+    it "anyToken = tokenClass anyToken" $+      (anyToken :: RegEx Char) `shouldBe` tokenClass anyToken+    prop "token c = tokenClass (token c)" $+      \(c :: Char) ->+        (token c :: RegEx Char) == tokenClass (token c)+    prop "oneOf cs = tokenClass (oneOf cs)" $+      \(cs :: [Char]) ->+        (oneOf cs :: RegEx Char) == tokenClass (oneOf cs)+    prop "notOneOf cs = tokenClass (notOneOf cs)" $+      \(cs :: [Char]) ->+        (notOneOf cs :: RegEx Char) == tokenClass (notOneOf cs)+    prop "asIn cat = tokenClass (asIn cat)" $+      \(cat :: GeneralCategory) ->+        (asIn cat :: RegEx Char) == tokenClass (asIn cat)+    prop "notAsIn cat = tokenClass (notAsIn cat)" $+      \(cat :: GeneralCategory) ->+        (notAsIn cat :: RegEx Char) == tokenClass (notAsIn cat)+  describe "BooleanAlgebra TokenClass" $ do+    it "trueB = anyToken" $+      (trueB :: TokenClass Char) `shouldBe` anyToken+    it "trueB = notOneOf []" $+      (trueB :: TokenClass Char) `shouldBe` notOneOf []+    it "falseB = oneOf []" $+      (falseB :: TokenClass Char) `shouldBe` oneOf []+    prop "notB . oneOf = notOneOf" $+      \(cs :: [Char]) ->+        notB (oneOf cs :: TokenClass Char) == notOneOf cs+    prop "notB . notOneOf = oneOf" $+      \(cs :: [Char]) ->+        notB (notOneOf cs :: TokenClass Char) == oneOf cs+    prop "notB . asIn = notAsIn" $+      \(cat :: GeneralCategory) ->+        notB (asIn cat :: TokenClass Char) == notAsIn cat+    prop "notB . notAsIn = asIn" $+      \(cat :: GeneralCategory) ->+        notB (notAsIn cat :: TokenClass Char) == asIn cat+    prop "x >||< x = x" $ \(x :: TokenClass Char) ->+      (x >||< x) == x+    prop "x >&&< x = x" $ \(x :: TokenClass Char) ->+      (x >&&< x) == x