distributors (empty) → 0.1.0.0

raw patch · 14 files changed

+2660/−0 lines, 14 filesdep +adjunctionsdep +basedep +bifunctorssetup-changed

Dependencies added: adjunctions, base, bifunctors, bytestring, containers, contravariant, distributive, distributors, hspec, lens, mtl, profunctors, tagged, text, vector, witherable

Files

• CHANGELOG.md +11/−0
• LICENSE +30/−0
• README.md +35/−0
• Setup.hs +2/−0
• distributors.cabal +161/−0
• src/Control/Lens/Bifocal.hs +195/−0
• src/Control/Lens/Diopter.hs +127/−0
• src/Control/Lens/Grate.hs +119/−0
• src/Control/Lens/Monocle.hs +97/−0
• src/Control/Lens/PartialIso.hs +405/−0
• src/Control/Lens/Wither.hs +111/−0
• src/Data/Profunctor/Distributor.hs +825/−0
• src/Text/Grammar/Distributor.hs +480/−0
• test/Spec.hs +62/−0

@@ -0,0 +1,11 @@+# Changelog for `distributors`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD

@@ -0,0 +1,30 @@+Copyright Eitan Chatav (c) 2024++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Eitan Chatav nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,35 @@+# Distributors+## Unifying Parsers, Printers & Grammars++[![GithubWorkflowCI](https://github.com/morphismtech/squeal/actions/workflows/ci.yml/badge.svg)](https://github.com/morphismtech/squeal/actions/workflows/ci.yml)+++This library provides mathematically inspired abstractions for coders to write parsers that can also be inverted to printers.++## introduction+The term "distributor" is a synonym for "[profunctor](https://ncatlab.org/nlab/show/profunctor)". Jean Bénabou who invented the term and originally used “profunctor,” then preferred “[distributor](http://www.entretemps.asso.fr/maths/Distributors.pdf)”, which is supposed to carry the intuition that a distributor generalizes a functor in a similar way to how a distribution generalizes a function.++[Bénabou](http://cahierstgdc.com/wp-content/uploads/2022/07/F.-BORCEUX-LXIII-3.pdf) in his time introduced the notions of enriched categories, bicategories as well as distributors and invented the term monad. He was lost to us on 11, February 2022 and this library is dedicated to his memory.++Since "profunctor" became the standard nomenclature, we reappropriate "distributor" to describe a profunctor on a [distributive category](https://ncatlab.org/nlab/show/distributive+category).++This library provides a study of `Monoidal` profunctors, `Distributor`s, `Alternator`s and `Filtrator`s. These profunctor constraints are analogous to `Applicative`, `Alternative` and `Filterable` functors. Examples of `Distributor`s will include printers and parsers, and it is demonstrated how to write a single term for both. Profunctors naturally give rise to optics and this library also studies some previously discovered optics, `PartialIso`s, `Monocle`s, `Grate`s and `Wither`s and also defines new optics, `Diopter`s and `Bifocal`s. Finally, an application of distributors is demonstrated by unifying Backus-Naur form grammars with invertible parsers, giving users a powerful playground for front-end language design.++## previous work++The results concerning invertible parsers are a profunctorial interpretation of [Invertible Syntax Descriptions](https://www.mathematik.uni-marburg.de/~rendel/rendel10invertible.pdf) by Tillman Rendel & Klaus Ostermann.++While `Distributor`s in the library are lax distributive endoprofunctors, a mathematical treatment of strong (i.e. with invertible structure morphisms) distributors is given by Travis Squires in [Profunctors and Distributive Categories](https://central.bac-lac.gc.ca/.item?id=MR31635).++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 person deserving the most credit for bringing the power of optics to programming is Ed Kmett, to whom I am very grateful for teaching me a lot, with his [lens library](https://github.com/ekmett/lens/).++None of the ideas in this library are particularly original and a lot of related ideas have been explored, in Tom Ellis' [product-profunctors](https://github.com/tomjaguarpaw/product-profunctors) as well as Sjoerd Visscher's [one-liner](https://github.com/sjoerdvisscher/one-liner) and more. Such explorations are _not_ limited to Haskell. Brandon Williams and Stephen Celis' excellent [swift-parsing](https://github.com/pointfreeco/swift-parsing) was also influenced by invertible parser theory.++Some optics in this library are [grates, a new kind of optic](https://r6research.livejournal.com/28050.html), discovered by Russel O'Connor and James Deikun; monocles which are studied by Alexandre Garcia de Oliveira, Mauro Jaskelioff, and Ana Cristina Vieira de Melo in [On Structuring Functional Programs with Monoidal Profunctors](https://arxiv.org/abs/2207.00852); and withers, discovered by Chris Penner in [Composable filters using Witherable optics](https://chrispenner.ca/posts/witherable-optics).++## contributing++Contributors are welcome. The [Issues](https://github.com/morphismtech/squeal/issues) page is a good place to communicate.+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,161 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name:           distributors+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/morphismtech/distributors#readme>+homepage:       https://github.com/morphismtech/distributors#readme+bug-reports:    https://github.com/morphismtech/distributors/issues+author:         Eitan Chatav+maintainer:     eitan.chatav@gmail.com+copyright:      2023 Eitan Chatav+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/morphismtech/distributors++library+  exposed-modules:+      Control.Lens.Bifocal+      Control.Lens.Diopter+      Control.Lens.Grate+      Control.Lens.Monocle+      Control.Lens.PartialIso+      Control.Lens.Wither+      Data.Profunctor.Distributor+      Text.Grammar.Distributor+  other-modules:+      Paths_distributors+  autogen-modules:+      Paths_distributors+  hs-source-dirs:+      src+  default-extensions:+      AllowAmbiguousTypes+      Arrows+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveFunctor+      DeriveGeneric+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      ImpredicativeTypes+      InstanceSigs+      KindSignatures+      LambdaCase+      MagicHash+      MonoLocalBinds+      OverloadedStrings+      QuantifiedConstraints+      RankNTypes+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      UndecidableSuperClasses+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      adjunctions+    , base >=4.7 && <5+    , bifunctors+    , bytestring+    , containers+    , contravariant+    , distributive+    , lens+    , mtl+    , profunctors+    , tagged+    , text+    , vector+    , witherable+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_distributors+  autogen-modules:+      Paths_distributors+  hs-source-dirs:+      test+  default-extensions:+      AllowAmbiguousTypes+      Arrows+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveFunctor+      DeriveGeneric+      DerivingStrategies+      DerivingVia+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      ImpredicativeTypes+      InstanceSigs+      KindSignatures+      LambdaCase+      MagicHash+      MonoLocalBinds+      OverloadedStrings+      QuantifiedConstraints+      RankNTypes+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      UndecidableInstances+      UndecidableSuperClasses+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      adjunctions+    , base >=4.7 && <5+    , bifunctors+    , bytestring+    , containers+    , contravariant+    , distributive+    , distributors+    , hspec+    , lens+    , mtl+    , profunctors+    , tagged+    , text+    , vector+    , witherable+  default-language: Haskell2010

@@ -0,0 +1,195 @@+{- |+Module      : Control.Lens.Bifocal+Description : bifocals+Copyright   : (C) 2025 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable+-}++module Control.Lens.Bifocal+  ( -- * Bifocal+    Bifocal+  , ABifocal+    -- * Combinators+  , bifocal+  , mapBifocal+  , cloneBifocal+  , withBifocal+  , chainedl1+  , chainedr1+  , chainedl+  , chainedr+    -- * Binocular+  , Binocular (..), runBinocular+    -- * Prismoid+  , Prismoid+  , somed+  , lefted+  , righted+    -- * Filtroid+  , Filtroid+  , unlefted+  , unrighted+  ) where++import Control.Applicative+import Control.Lens+import Control.Lens.Internal.Profunctor+import Control.Lens.PartialIso+import Data.Profunctor+import Data.Profunctor.Distributor+import Witherable++{- | `Bifocal`s are bidirectional parser optics.++Every one of the following is a `Bifocal`.++* `Control.Lens.Iso.Iso`+* `Control.Lens.Prism.Prism`+* `Control.Lens.Monocle.Monocle`+* `Control.Lens.Diopter.Diopter`+* `Prismoid` & `Filtroid`++`Bifocal`s are isomorphic to `Binocular`s.+-}+type Bifocal s t a b = forall p f.+  (Alternator p, Filtrator p, Alternative f, Filterable f)+    => p a (f b) -> p s (f t)++{- | If you see `ABifocal` in a signature for a function,+the function is expecting a `Bifocal`. -}+type ABifocal s t a b =+  Binocular a b a (Maybe b) -> Binocular a b s (Maybe t)++{- | `Prismoid`s generalize `Bifocal`s, combining+`Control.Lens.Prism.Prism`s and `Control.Lens.Diopter.Diopter`s. -}+type Prismoid s t a b = forall p f.+  (Alternator p, Alternative f)+    => p a (f b) -> p s (f t)++{- | An optic for `Filtrator`s, `Filtroid`s generalize `Bifocal`s. -}+type Filtroid s t a b = forall p f.+  (Filtrator p, Filterable f)+    => p a (f b) -> p s (f t)++{- | Build a `Bifocal` from a concrete `Binocular`. -}+bifocal :: Binocular a b s t -> Bifocal s t a b+bifocal bif = unwrapPafb . runBinocular bif . WrapPafb++{- | Action of `ABifocal` on partial `Distributor`s. -}+mapBifocal+  :: (Alternator p, Filtrator p)+  => ABifocal s t a b -> p a b -> p s t+mapBifocal bif p = withBifocal bif $ \f -> dimapMaybe f Just p++{- | Clone `ABifocal` so that you can reuse the same+monomorphically typed `Bifocal` for different purposes.+-}+cloneBifocal :: ABifocal s t a b -> Bifocal s t a b+cloneBifocal bif = unwrapPafb . mapBifocal bif . WrapPafb++{- | One or more. -}+somed :: Prismoid [a] [b] a b+somed = unwrapPafb . someP . WrapPafb++{- | `lefted` is like `_Left`, except+with heterogeneous `Right` parameters. -}+lefted :: Prismoid (Either a c) (Either b d) a b+lefted = unwrapPafb . alternate . Left . WrapPafb+++{- | `righted` is like `_Right`, except+with heterogeneous `Left` parameters. -}+righted :: Prismoid (Either c a) (Either d b) a b+righted = unwrapPafb . alternate . Right . WrapPafb++{- | Dual to `lefted`. -}+unlefted :: Filtroid a b (Either a c) (Either b d)+unlefted = unwrapPafb . fst . filtrate . WrapPafb++{- | Dual to `righted`. -}+unrighted :: Filtroid a b (Either c a) (Either d b)+unrighted = unwrapPafb . snd . filtrate . WrapPafb++{- |+Left associate a binary constructor pattern to sequence one or more times.+-}+chainedl1 :: APartialIso a b (a,a) (b,b) -> Bifocal a b a b+chainedl1 pat = unwrapPafb . chainl1 pat noSep . WrapPafb+++{- |+Right associate a binary constructor pattern to sequence one or more times.+-}+chainedr1 :: APartialIso a b (a,a) (b,b) -> Bifocal a b a b+chainedr1 pat = unwrapPafb . chainr1 pat noSep . WrapPafb++{- |+Left associate a binary constructor pattern to sequence one or more times,+or use a nilary constructor pattern to sequence zero times.+-}+chainedl :: APartialIso a b (a,a) (b,b) -> APartialIso a b () () -> Bifocal a b a b+chainedl c2 c0 = unwrapPafb . chainl c2 c0 noSep . WrapPafb++{- |+Right associate a binary constructor pattern to sequence one or more times,+or use a nilary constructor pattern to sequence zero times.+-}+chainedr :: APartialIso a b (a,a) (b,b) -> APartialIso a b () () -> Bifocal a b a b+chainedr c2 c0 = unwrapPafb . chainr c2 c0 noSep . WrapPafb++{- | Run `ABifocal` over an `Alternative` & `Filterable`. -}+withBifocal+  :: (Alternative f, Filterable f)+  => ABifocal s t a b -> ((s -> Maybe a) -> f b) -> f t+withBifocal bif = unBinocular (catMaybes (bif (Just <$> anyToken)))++{- | `Binocular` provides an efficient+concrete representation of `Bifocal`s. -}+newtype Binocular a b s t = Binocular+  { unBinocular+      :: forall f. (Alternative f, Filterable f)+      => ((s -> Maybe a) -> f b) -> f t+  }+instance Tokenized a b (Binocular a b) where+  anyToken = Binocular ($ Just)+instance Profunctor (Binocular a b) where+  dimap f g (Binocular k) = Binocular $ fmap g . k . (. (. f))+instance Functor (Binocular a b s) where fmap = rmap+instance Applicative (Binocular a b s) where+  pure t = Binocular (pure (pure t))+  Binocular x <*> Binocular y = Binocular (liftA2 (<*>) x y)+instance Alternative (Binocular a b s) where+  empty = Binocular (pure empty)+  Binocular x <|> Binocular y = Binocular (liftA2 (<|>) x y)+instance Filterable (Binocular a b s) where+  mapMaybe f (Binocular k) = Binocular (mapMaybe f . k)+  catMaybes (Binocular k) = Binocular (catMaybes . k)+instance Choice (Binocular a b) where+  left' (Binocular k)+    = Binocular $ fmap Left+    . k . (. (\f -> either f (const Nothing)))+  right' (Binocular k)+    = Binocular $ fmap Right+    . k . (. (\f -> either (const Nothing) f))+instance Cochoice (Binocular a b) where+  unleft (Binocular k)+    = Binocular $ catMaybes+    . fmap (either Just (const Nothing))+    . k . (. (. Left))+  unright (Binocular k)+    = Binocular $ catMaybes+    . fmap (either (const Nothing) Just)+    . k . (. (. Right))+instance Distributor (Binocular a b)+instance Alternator (Binocular a b)+instance Filtrator (Binocular a b)++{- | Run a `Binocular` on a partial `Distributor`. -}+runBinocular+  :: (Alternator p, Filtrator p)+  => Binocular a b s t+  -> p a b -> p s t+runBinocular (Binocular k) p = k $ \f -> dimapMaybe f Just p

@@ -0,0 +1,127 @@+{- |+Module      : Control.Lens.Diopter+Description : diopters+Copyright   : (C) 2025 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable+-}++module Control.Lens.Diopter+  ( -- * Diopter+    Diopter+  , ADiopter+    -- * Combinators+  , diopter+  , withDiopter+  , cloneDiopter+  , mapDiopter+  , optioned+  , manied+  , homogenized+    -- * Dioptrice+  , Dioptrice (..), runDioptrice+  ) where++import Control.Lens+import Control.Lens.Internal.Profunctor+import Data.Profunctor.Distributor+import Data.Void+import GHC.Generics++{- | `Diopter`s are an optic that generalizes+`Control.Lens.Bifocal.Bifocal`s and `Control.Lens.Traversal.Traversal`s.++Every `Control.Lens.Iso.Iso` and `Control.Lens.Monocle` is a `Diopter`.++`Diopter`s are isomorphic to `Dioptrice`s.+-}+type Diopter s t a b = forall p f.+  (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`. -}+type ADiopter s t a b =+  Dioptrice a b a (Identity b) -> Dioptrice a b s (Identity t)++{- | Build a `Diopter`. -}+diopter :: Homogeneous h => (s -> h a) -> (h b -> t) -> Diopter s t a b+diopter f g = unwrapPafb . runDioptrice (Dioptrice f g) . WrapPafb++{- | Convert `ADiopter` to the pair of functions that characterize it. -}+withDiopter+  :: ADiopter s t a b+  -> (forall h. Homogeneous h => (s -> h a) -> (h b -> t) -> r)+  -> r+withDiopter dio k = case (runIdentity <$> dio (Identity <$> anyToken)) of+  Dioptrice f g -> k f g++{- | Action of `ADiopter` on `Distributor`s. -}+mapDiopter :: Distributor p => ADiopter s t a b -> p a b -> p s t+mapDiopter dio = withDiopter dio $ \f g -> dimap f g . homogeneously++{- | Clone `ADiopter` so that you can reuse the same+monomorphically typed `Diopter` for different purposes.+-}+cloneDiopter :: ADiopter s t a b -> Diopter s t a b+cloneDiopter dio = withDiopter dio diopter++{- | One or none. -}+optioned :: Diopter (Maybe a) (Maybe b) a b+optioned = unwrapPafb . optionalP . WrapPafb++{- | Zero or more. -}+manied :: Diopter [a] [b] a b+manied = unwrapPafb . manyP . WrapPafb++{- | Build a `Diopter` from a `Homogeneous`+countable sum of countable products.++prop> traverse = homogenized+prop> homogenized = ditraversed+-}+homogenized :: Homogeneous t => Diopter (t a) (t b) a b+homogenized = unwrapPafb . homogeneously . WrapPafb++{- | A `Dioptrice` provides efficient access+to some pair of functions that make up a `Diopter`.+-}+data Dioptrice a b s t where+  Dioptrice+    :: Homogeneous h+    => (s -> h a)+    -> (h b -> t)+    -> Dioptrice a b s t+instance Tokenized a b (Dioptrice a b) where+  anyToken = Dioptrice Par1 unPar1+instance Profunctor (Dioptrice a b) where+  dimap f g (Dioptrice sa bt) = Dioptrice (sa . f) (g . bt)+instance Functor (Dioptrice a b s) where fmap = rmap+instance Applicative (Dioptrice a b s) where+  pure t = Dioptrice (const U1) (const t)+  Dioptrice fx gx <*> Dioptrice fy gy = Dioptrice+    (\s -> fx s :*: fy s)+    (\(h :*: g) -> gx h (gy g))+instance Distributor (Dioptrice a b) where+  zeroP = Dioptrice absurd ridiculous+    where+      ridiculous :: V1 b -> x+      ridiculous = (\case)+  Dioptrice fx gx >+< Dioptrice fy gy = Dioptrice+    (either (L1 . fx) (R1 . fy))+    (\case {L1 h -> Left (gx h); R1 j -> Right (gy j)})+  optionalP (Dioptrice f g) = Dioptrice+    (Comp1 . fmap f)+    (fmap g . unComp1)+  manyP (Dioptrice f g) = Dioptrice+    (Comp1 . fmap f)+    (fmap g . unComp1)++{- | Run a `Dioptrice` on a `Distributor`. -}+runDioptrice+  :: Distributor p+  => Dioptrice a b s t+  -> p a b -> p s t+runDioptrice (Dioptrice f g) = dimap f g . homogeneously

@@ -0,0 +1,119 @@+{- |+Module      : Control.Lens.Grate+Description : grates+Copyright   : (C) 2025 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable++See O'Connor, [Grate: A new kind of Optic]+(https://r6research.livejournal.com/28050.html)+-}++module Control.Lens.Grate+  ( -- * Grate+    Grate+  , AGrate+    -- * Combinators+  , grate+  , withGrate+  , cloneGrate+  , mapGrate+  , cotraversed+  , represented+  , cotraverseOf+  , distributeOf+  , collectOf+  , distributing+    -- * Grating+  , Grating (..)+  ) where++import Data.Distributive+import Data.Function+import Data.Functor.Identity+import Data.Functor.Rep+import Data.Profunctor+import Data.Profunctor.Distributor++{- | `Grate`s are an optic that are dual to+`Control.Lens.Traversal.Traversal`s, as `Distributive` is `Traversable`.++Every `Control.Lens.Monocle.Monocle` is a `Grate`.++`Grate`s are isomorphic to `Grating`s.+-}+type Grate s t a b = forall p f.+  (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`. -}+type AGrate s t a b =+  Grating a b a (Identity b) -> Grating a b s (Identity t)++{- | Build a `Grate`. -}+grate :: (((s -> a) -> b) -> t) -> Grate s t a b+grate f = dimap (&) (cotraverse f) . closed++{- | Build a `Grate` from a `Distributive`. -}+cotraversed :: Distributive g => Grate (g a) (g b) a b+cotraversed = grate $ flip cotraverse id++{- | Build a `Grate` from a `Representable`. -}+represented :: Representable g => Grate (g a) (g b) a b+represented = grate $ tabulate . (. flip index)++{- | Action of `AGrate` on `Closed` `Profunctor`s. -}+mapGrate :: Closed p => AGrate s t a b -> p a b -> p s t+mapGrate grt = dimap (&) (withGrate grt) . closed++{- | Clone `AGrate` so that you can reuse the same+monomorphically typed `Grate` for different purposes.+-}+cloneGrate :: AGrate s t a b -> Grate s t a b+cloneGrate = grate . withGrate++{- | Run `AGrate`. -}+withGrate :: AGrate s t a b -> ((s -> a) -> b) -> t+withGrate grt = runGrating $ runIdentity <$> grt (Identity <$> anyToken)++{- | Distribute over a `Closed` `Profunctor`. -}+distributing+  :: (Closed p, forall x. Functor (p x), Distributive g)+  => AGrate s t a b -> p a (g b) -> g (p s t)+distributing grt+  = distribute+  . dimap (&) (cotraverse (withGrate grt))+  . closed++{- | Dual to `Control.Lens.Combinators.traverseOf`. -}+cotraverseOf :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t+cotraverseOf grt = runCostar . mapGrate grt . Costar++{- | Dual to `Control.Lens.Combinators.sequenceAOf`. -}+distributeOf :: Functor f => AGrate s t b (f b) -> f s -> t+distributeOf grt = cotraverseOf grt id++{- | `collect` with `AGrate`. -}+collectOf :: Functor f => AGrate s t b (f b) -> (a -> s) -> f a -> t+collectOf grt f = distributeOf grt . fmap f++{- | `Grating` provides an efficient+concrete representation of `Grate`s. -}+newtype Grating a b s t = Grating+  {runGrating :: ((s -> a) -> b) -> t}+instance Functor (Grating a b s) where fmap = fmapRep+instance Applicative (Grating a b s) where+  pure = pureRep+  (<*>) = apRep+instance Tokenized a b (Grating a b) where+  anyToken = Grating ($ id)+instance Distributive (Grating a b s) where+  distribute = distributeRep+  collect = collectRep+instance Representable (Grating a b s) where+  type Rep (Grating a b s) = (s -> a) -> b+  index (Grating k) f = k f+  tabulate = Grating

@@ -0,0 +1,97 @@+{- |+Module      : Control.Lens.Monocle+Description : monocles+Copyright   : (C) 2025 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable++See Oliveira, Jaskelioff & de Melo,+[On Structuring Functional Programs with Monoidal Profunctors](https://arxiv.org/abs/2207.00852)+-}++module Control.Lens.Monocle+  ( -- * Monocle+    Monocle+  , AMonocle+    -- * Combinators+  , monocle+  , withMonocle+  , cloneMonocle+  , mapMonocle+  , ditraversed+  , forevered+    -- * Monocular+  , Monocular (..), runMonocular+  ) where++import Control.Lens hiding (Traversing)+import Control.Lens.Internal.Profunctor+import Data.Distributive+import Data.Profunctor.Distributor++{- | `Monocle`s are an optic that generalizes+`Control.Lens.Traversal.Traversal`s & `Control.Lens.Grate.Grate`s.++Every `Control.Lens.Iso.Iso` is a `Monocle`.++`Monocle`s are isomorphic to `Monocular`s.+-}+type Monocle s t a b = forall p f.+  (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`. -}+type AMonocle s t a b =+  Monocular a b a (Identity b) -> Monocular a b s (Identity t)++{- | Build a `Monocle` from a concrete `Monocular`. -}+monocle :: Monocular a b s t -> Monocle s t a b+monocle mon = unwrapPafb . runMonocular mon . WrapPafb++{- | Action of `AMonocle` on `Monoidal` `Profunctor`s. -}+mapMonocle :: Monoidal p => AMonocle s t a b -> p a b -> p s t+mapMonocle mon p = withMonocle mon $ \f -> lmap f p++{- | Clone `AMonocle` so that you can reuse the same+monomorphically typed `Monocle` for different purposes.+-}+cloneMonocle :: AMonocle s t a b -> Monocle s t a b+cloneMonocle mon = unwrapPafb . mapMonocle mon . WrapPafb++{- | Build a `Monocle` from a `Traversable` & `Distributive`,+homogeneous, countable product.++prop> traverse = ditraversed+prop> cotraversed = ditraversed+-}+ditraversed :: (Traversable g, Distributive g) => Monocle (g a) (g b) a b+ditraversed = unwrapPafb . replicateP . WrapPafb++{- | Repeat action indefinitely. -}+forevered :: Monocle s t () b+forevered = unwrapPafb . foreverP . WrapPafb++{- | Run `AMonocle` over an `Applicative`. -}+withMonocle :: Applicative f => AMonocle s t a b -> ((s -> a) -> f b) -> f t+withMonocle mon = unMonocular (runIdentity <$> mon (Identity <$> anyToken))++{- | `Monocular` provides an efficient+concrete representation of `Monocle`s. -}+newtype Monocular a b s t = Monocular+  {unMonocular :: forall f. Applicative f => ((s -> a) -> f b) -> f t}+instance Tokenized a b (Monocular a b) where+  anyToken = Monocular ($ id)+instance Profunctor (Monocular a b) where+  dimap f g (Monocular k) =+    Monocular (fmap g . k . (. (. f)))+instance Functor (Monocular a b s) where fmap = rmap+instance Applicative (Monocular a b s) where+  pure t = Monocular (pure (pure t))+  Monocular x <*> Monocular y = Monocular (liftA2 (<*>) x y)++{- | Run a `Monocular` on a `Monoidal` `Profunctor`. -}+runMonocular :: Monoidal p => Monocular a b s t -> p a b -> p s t+runMonocular (Monocular k) p = k $ \f -> lmap f p

@@ -0,0 +1,405 @@+{- |+Module      : Control.Lens.PartialIso+Description : partial isomorphisms+Copyright   : (C) 2025 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable++See Rendel & Ostermann,+[Invertible syntax descriptions](https://www.informatik.uni-marburg.de/~rendel/unparse/)+-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Control.Lens.PartialIso+  ( -- * PartialIso+    dimapMaybe+  , PartialIso+  , PartialIso'+  , APartialIso+  , PartialExchange (PartialExchange)+    -- Combinators+  , partialIso+  , withPartialIso+  , clonePartialIso+  , coPartialIso+  , crossPartialIso+  , altPartialIso+    -- * Actions+  , (>?)+  , (?<)+  , (>?<)+  , mapIso+  , coPrism+    -- * Patterns+  , satisfied+  , nulled+  , notNulled+  , streamed+  , maybeEot+  , listEot+    -- * Iterations+  , iterating+  , difoldl1+  , difoldr1+  , difoldl+  , difoldr+  , difoldl'+  , difoldr'+  ) where++import Control.Lens+import Control.Lens.Internal.Profunctor+import Control.Monad+import Data.Functor.Compose+import Data.Profunctor+import Data.Profunctor.Monad+import Data.Profunctor.Yoneda+import Witherable++{- | The `dimapMaybe` function endows+`Choice` & `Cochoice` "partial profunctors"+with an action `>?<` of `PartialIso`s.+-}+dimapMaybe+  :: (Choice p, Cochoice p)+  => (s -> Maybe a) -> (b -> Maybe t)+  -> p a b -> p s t+dimapMaybe f g =+  let+    m2e h = maybe (Left ()) Right . h+    fg = dimap (>>= m2e f) (>>= m2e g)+  in+    unright . fg . right'++{- | `PartialIso` is a first class inexhaustive pattern,+similar to how `Control.Lens.Prism.Prism` is a first class exhaustive pattern,+by combining `Control.Lens.Prism.Prism`s and coPrisms.++Every `Control.Lens.Iso.Iso` & `Control.Lens.Prism.Prism` is `APartialIso`.++`PartialIso`s are isomorphic to `PartialExchange`s.+-}+type PartialIso s t a b = forall p f.+  (Choice p, Cochoice p, Applicative f, Filterable f)+    => p a (f b) -> p s (f t)++{- |+A simple `PartialIso'` @s a@ is an identification of+a subset of @s@ with a subset of @a@.++Given a simple `PartialIso'`, @partialIso f g@, has properties:++prop> Just = f <=< g+prop> Just = g <=< f++These are left and right inverse laws for proper `PartialIso'`s.+However, sometimes an improper `PartialIso'` will be useful.+For an improper `PartialIso'`, only the left inverse law holds.++prop> Just = f <=< g++For an improper `PartialIso'`, @norm = g <=< f@ is an idempotent++prop> norm = norm <=< norm++and can be regarded as a normalization within+some equivalence class of terms.+-}+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`. -}+type APartialIso s t a b =+  PartialExchange a b a (Maybe b) -> PartialExchange a b s (Maybe t)++{- | A `PartialExchange` provides efficient access+to the two functions that make up a `PartialIso`.+-}+data PartialExchange a b s t =+  PartialExchange (s -> Maybe a) (b -> Maybe t)+instance Functor (PartialExchange a b s) where fmap = rmap+instance Filterable (PartialExchange a b s) where+  mapMaybe = dimapMaybe Just+instance Profunctor (PartialExchange a b) where+  dimap f' g' (PartialExchange f g) =+    PartialExchange (f . f') (fmap g' . g)+instance Choice (PartialExchange a b) where+  left' (PartialExchange f g) =+    PartialExchange (either f (pure Nothing)) ((Left <$>) . g)+  right' (PartialExchange f g) =+    PartialExchange (either (pure Nothing) f) ((Right <$>) . g)+instance Cochoice (PartialExchange a b) where+  unleft (PartialExchange f g) =+    PartialExchange (f . Left) (either Just (pure Nothing) <=< g)+  unright (PartialExchange f g) =+    PartialExchange (f . Right) (either (pure Nothing) Just <=< g)++{- | Build a `PartialIso`. -}+partialIso :: (s -> Maybe a) -> (b -> Maybe t) -> PartialIso s t a b+partialIso f g =+  unright . iso (maybe (Left ()) Right . f =<<) (mapMaybe g) . right'++{- | Convert `APartialIso` to the pair of functions that characterize it. -}+withPartialIso+  :: APartialIso s t a b+  -> ((s -> Maybe a) -> (b -> Maybe t) -> r)+  -> r+withPartialIso i k =+  case i (PartialExchange Just (Just . Just)) of+    PartialExchange f g -> k f (join . g)++{- | Clone `APartialIso` so that you can reuse the same+monomorphically typed partial isomorphism for different purposes.+-}+clonePartialIso+  :: APartialIso s t a b+  -> PartialIso s t a b+clonePartialIso i = withPartialIso i $ \f g -> partialIso f g++{- | Clone and invert `APartialIso`. -}+coPartialIso+  :: APartialIso b a t s+  -> PartialIso s t a b+coPartialIso i =+  withPartialIso i $ \f g -> partialIso g f++{- | Construct a `PartialIso` on pairs from components. -}+crossPartialIso+  :: APartialIso s t a b+  -> APartialIso u v c d+  -> PartialIso (s,u) (t,v) (a,c) (b,d)+crossPartialIso x y =+  withPartialIso x $ \e f ->+  withPartialIso y $ \g h ->+    partialIso+      (\(s,u) -> (,) <$> e s <*> g u)+      (\(t,v) -> (,) <$> f t <*> h v)++{- | Construct a `PartialIso` on `Either`s from components. -}+altPartialIso+  :: APartialIso s t a b+  -> APartialIso u v c d+  -> PartialIso+      (Either s u) (Either t v)+      (Either a c) (Either b d)+altPartialIso x y =+  withPartialIso x $ \e f ->+  withPartialIso y $ \g h ->+    partialIso+      (either ((Left <$>) . e) ((Right <$>) . g))+      (either ((Left <$>) . f) ((Right <$>) . h))++{- | Action of `APrism` on `Choice` `Profunctor`s. -}+(>?)+  :: Choice p+  => APrism s t a b+  -> p a b+  -> p s t+(>?) pat = withPrism pat $ \f g -> dimap g (either id f) . right'+infixl 4 >?++{- | Action of a coPrism on `Cochoice` `Profunctor`s. -}+(?<)+  :: Cochoice p+  => APrism b a t s+  -> p a b+  -> p s t+(?<) pat = withPrism pat $ \f g -> unright . dimap (either id f) g+infixl 4 ?<++{- | Action of `APartialIso` on `Choice` and `Cochoice` `Profunctor`s. -}+(>?<)+  :: (Choice p, Cochoice p)+  => APartialIso s t a b+  -> p a b+  -> p s t+(>?<) pat = withPartialIso pat dimapMaybe+infixl 4 >?<++{- | Action of `AnIso` on `Profunctor`s. -}+mapIso :: Profunctor p => AnIso s t a b -> p a b -> p s t+mapIso i = withIso i dimap++{- | Action of a `coPrism`+on the composition of a `Profunctor` and `Filterable`.+-}+coPrism :: (Profunctor p, Filterable f) => APrism b a t s -> p a (f b) -> p s (f t)+coPrism p = unwrapPafb . (?<) p . WrapPafb++{- | `satisfied` is the prototypical proper partial isomorphism,+identifying a subset which satisfies a predicate. -}+satisfied :: (a -> Bool) -> PartialIso' a a+satisfied f = partialIso satiate satiate where+  satiate a = if f a then Just a else Nothing++{- | `nulled` matches an `Empty` pattern, like `_Empty`. -}+nulled :: (AsEmpty s, AsEmpty t) => PartialIso s t () ()+nulled = partialIso empA empB where+  empA s = if isn't _Empty s then Nothing else Just ()+  empB _ = Just Empty++{- | `notNulled` matches a non-`Empty` pattern. -}+notNulled :: (AsEmpty s, AsEmpty t) => PartialIso s t s t+notNulled = partialIso nonEmp nonEmp where+  nonEmp s = if isn't _Empty s then Just s else Nothing++{- | `streamed` is an isomorphism between+two stream types with the same token type. -}+streamed+  :: (AsEmpty s, AsEmpty t, Cons s s c c, Cons t t c c)+  => Iso' s t+streamed = iso convertStream convertStream+  where+    convertStream s =+      maybe+        Empty+        (\(h,t) -> cons h (convertStream t))+        (uncons s)++{- | The either-of-tuples representation of `Maybe`. -}+maybeEot :: Iso (Maybe a) (Maybe b) (Either () a) (Either () b)+maybeEot = iso+  (maybe (Left ()) Right)+  (either (pure Nothing) Just)++{- | The either-of-tuples representation of list-like streams. -}+listEot+  :: (Cons s s a a, AsEmpty t, Cons t t b b)+  => Iso s t (Either () (a,s)) (Either () (b,t))+listEot = iso+  (maybe (Left ()) Right . uncons)+  (either (const Empty) (review _Cons))++{- | Iterate the application of a partial isomorphism,+useful for constructing fold/unfold isomorphisms. -}+iterating :: APartialIso a b a b -> Iso a b a b+iterating i = withPartialIso i $ \f g ->+  iso (iter f) (iter g) where+    iter h state = maybe state (iter h) (h state)++{- | Left fold & unfold `APartialIso` to an `Control.Lens.Iso.Iso`. -}+difoldl1+  :: Cons s t a b+  => APartialIso (c,a) (d,b) c d+  -> Iso (c,s) (d,t) (c,s) (d,t)+difoldl1 i =+  let+    associate = iso+      (\(c,(a,s)) -> ((c,a),s))+      (\((d,b),t) -> (d,(b,t)))+    step+      = crossPartialIso id _Cons+      . associate+      . crossPartialIso i id+  in iterating step++{- | Right fold & unfold `APartialIso` to an `Control.Lens.Iso.Iso`. -}+difoldr1+  :: Cons s t a b+  => APartialIso (a,c) (b,d) c d+  -> Iso (s,c) (t,d) (s,c) (t,d)+difoldr1 i =+  let+    reorder = iso+      (\((a,s),c) -> (s,(a,c)))+      (\(t,(b,d)) -> ((b,t),d))+    step+      = crossPartialIso _Cons id+      . reorder+      . crossPartialIso id i+  in iterating step++{- | Left fold & unfold `APartialIso` to a `PartialIso`. -}+difoldl+  :: (AsEmpty s, AsEmpty t, Cons s t a b)+  => APartialIso (c,a) (d,b) c d+  -> PartialIso (c,s) (d,t) c d+difoldl i =+  let+    unit' = iso+      (\(a,()) -> a)+      (\a -> (a,()))+  in+    difoldl1 i+    . crossPartialIso id nulled+    . unit'++{- | Right fold & unfold `APartialIso` to a `PartialIso`. -}+difoldr+  :: (AsEmpty s, AsEmpty t, Cons s t a b)+  => APartialIso (a,c) (b,d) c d+  -> PartialIso (s,c) (t,d) c d+difoldr i =+  let+    unit' = iso+      (\((),c) -> c)+      (\d -> ((),d))+  in+    difoldr1 i+    . crossPartialIso nulled id+    . unit'++{- | Left fold & unfold `Control.Lens.Prism.APrism'`+to a `Control.Lens.Prism.Prism'`. -}+difoldl'+  :: (AsEmpty s, Cons s s a a)+  => APrism' (c,a) c+  -> Prism' (c,s) c+difoldl' i =+  let+    unit' = iso+      (\(a,()) -> a)+      (\a -> (a,()))+  in+    difoldl1 (clonePrism i)+    . aside _Empty+    . unit'++{- | Right fold & unfold `Control.Lens.Prism.APrism'`+to a `Control.Lens.Prism.Prism'`. -}+difoldr'+  :: (AsEmpty s, Cons s s a a)+  => APrism' (a,c) c+  -> Prism' (s,c) c+difoldr' i =+  let+    unit' = iso+      (\((),c) -> c)+      (\c -> ((),c))+    asideFst k =+      withPrism k $ \bt seta ->+        prism (first' bt) $ \(s,e) ->+          case seta s of+            Left t -> Left  (t,e)+            Right a -> Right (a,e)+  in+    difoldr1 (clonePrism i)+    . asideFst _Empty+    . unit'++-- Orphanage --++instance (Profunctor p, Functor f)+  => Functor (WrappedPafb f p a) where fmap = rmap+deriving via Compose (p a) f instance+  (Profunctor p, Functor (p a), Filterable f)+    => Filterable (WrappedPafb f p a)+instance (Profunctor p, Filterable f)+  => Cochoice (WrappedPafb f p) where+    unleft (WrapPafb p) = WrapPafb $+      dimap Left (mapMaybe (either Just (const Nothing))) p+    unright (WrapPafb p) = WrapPafb $+      dimap Right (mapMaybe (either (const Nothing) Just)) p+instance (Profunctor p, Filterable (p a))+  => Filterable (Yoneda p a) where+    catMaybes = proreturn . catMaybes . proextract+instance (Profunctor p, Filterable (p a))+  => Filterable (Coyoneda p a) where+    catMaybes = proreturn . catMaybes . proextract+instance Filterable (Forget r a) where+  catMaybes (Forget f) = Forget f+instance Filterable f => Filterable (Star f a) where+  catMaybes (Star f) = Star (catMaybes . f)

@@ -0,0 +1,111 @@+{- |+Module      : Control.Lens.Wither+Description : withers+Copyright   : (C) 2025 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable++See Chris Penner,+[Composable Filters Using Witherable Optics](https://chrispenner.ca/posts/witherable-optics)+-}++module Control.Lens.Wither+  ( -- * Wither+    Wither+  , AWither+    -- * Combinators+  , cloneWither+  , withered+  , filtraversed+  , filterOf+    -- * Witheroid+  , Witheroid+  , witherPrism+    -- * Altar+  , Altar (..)+  ) where++import Control.Applicative+import Control.Lens+import Control.Lens.Internal.Context+import Data.Profunctor.Rep+import Data.Profunctor.Sieve+import Prelude hiding (filter)+import Witherable++{- | `Wither`s extends `Control.Lens.Traversal.Traversal`s by filtering.+++Every one of the following is a `Wither`.++* `Control.Lens.Iso.Iso`+* `Control.Lens.Lens.Lens`+* `Control.Lens.Prism.Prism`+* `Control.Lens.Traversal.Traversal`+* `Witheroid`+-}+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`. -}+type AWither s t a b = (a -> Altar a b b) -> s -> Altar a b t++{- | `Witheroid`s generalize `Wither`s.+Every `Control.Lens.Prism.Prism` is a `Witheroid`.+-}+type Witheroid s t a b = forall p f.+  (Choice p, Alternative f)+    => p a (f b) -> p s (f t)++{- | Clone `AWither` so that you can reuse the same+monomorphically typed `Wither` for different purposes.+-}+cloneWither :: AWither s t a b -> Wither s t a b+cloneWither w f = (\g z -> runAltar z g) f . w sell++{- | Construct a `Wither` for a `Witherable`. -}+withered :: Witherable t => Wither (t a) (t b) a b+withered f = wither (optional . f)++{- |+prop> withered = filtraversed+-}+filtraversed :: (Filterable t, Traversable t) => Wither (t a) (t b) a b+filtraversed f = fmap catMaybes . traverse (optional . f)++{- | Filter a traversed structure based on a predicate. -}+filterOf :: Alternative m => Wither s t a a -> (a -> Bool) -> s -> m t+filterOf w p s = w guardingp s where+  guardingp a+    | p a = pure a+    | otherwise = empty++{- |+`Control.Lens.Prism.Prism`s already capture the idea of success and failure,+but they simply skip the traversal if the prism doesn't match.+Lift prisms into withers such that they'll fail in a way that wither can catch.+-}+witherPrism :: APrism s t a b -> Witheroid s t a b+witherPrism prsm =+  withPrism prsm $ \embed match ->+    dimap match (either (const empty) (fmap embed)) . right'++{- | This is used to characterize `Wither`s. -}+newtype Altar a b t = Altar+  { runAltar :: forall f. Alternative f => (a -> f b) -> f t }+instance Functor (Altar a b) where+  fmap f (Altar k) = Altar (fmap f . k)+instance Applicative (Altar a b) where+  pure a = Altar $ const (pure a)+  Altar mf <*> Altar ma = Altar $ liftA2 (<*>) mf ma+instance Alternative (Altar a b) where+  empty = Altar $ const empty+  Altar mx <|> Altar my = Altar $ liftA2 (<|>) mx my+instance Sellable (->) Altar where+  sell+    = cotabulate+    $ \w -> Altar+    $ tabulate+    $ \k -> pure (cosieve k w)

@@ -0,0 +1,825 @@+{-|+Module      : Data.Profunctor.Distributor+Description : distributors+Copyright   : (C) 2025 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable+-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Data.Profunctor.Distributor+  ( -- * Monoidal+    Monoidal, oneP, (>*<), (>*), (*<), dimap2, foreverP, replicateP, meander, (>:<)+    -- * Distributor+  , Distributor (zeroP, (>+<), optionalP, manyP), dialt, Homogeneous (homogeneously)+    -- * Alternator/Filtrator+  , Alternator (alternate, someP), Filtrator (filtrate)+    -- * SepBy+  , SepBy (..), sepBy, noSep, zeroOrMore, oneOrMore, chainl1, chainr1, chainl, chainr+    -- * Tokenized+  , Tokenized (anyToken), satisfy, token, tokens+    -- * Printor/Parsor+  , Printor (..), Parsor (..)+  ) where++import Control.Applicative hiding (WrappedArrow)+import Control.Applicative qualified as Ap (WrappedArrow)+import Control.Arrow+import Control.Lens hiding (chosen)+import Control.Lens.Internal.Context+import Control.Lens.Internal.Iso+import Control.Lens.Internal.Prism+import Control.Lens.Internal.Profunctor+import Control.Lens.PartialIso+import Control.Monad+import Data.Bifunctor.Clown+import Data.Bifunctor.Joker+import Data.Bifunctor.Product+import Data.Distributive+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 Data.Profunctor hiding (WrappedArrow)+import Data.Profunctor qualified as Pro (WrappedArrow)+import Data.Profunctor.Cayley+import Data.Profunctor.Composition+import Data.Profunctor.Monad+import Data.Profunctor.Yoneda+import Data.String+import Data.Void+import GHC.Generics+import Witherable++-- Monoidal --++{- | A lax `Monoidal` product `Profunctor` has unit `oneP`+and product `>*<` lax monoidal structure morphisms.+This is equivalent to the `Profunctor` also being `Applicative`.++Laws:++>>> let (f >< g) (a,c) = (f a, g c)+>>> let lunit = dimap (\((),a) -> a) (\a -> ((),a))+>>> let runit = dimap (\(a,()) -> a) (\a -> (a,()))+>>> let assoc = dimap (\(a,(b,c)) -> ((a,b),c)) (\((a,b),c) -> (a,(b,c)))+prop> dimap (f >< g) (h >< i) (p >*< q) = dimap f h p >*< dimap g i q+prop> oneP >*< p = lunit p+prop> p >*< oneP = runit p+prop> p >*< q >*< r = assoc ((p >*< q) >*< r)++-}+type Monoidal p = (Profunctor p, forall x. Applicative (p x))++{- | `oneP` is the unit of a `Monoidal` `Profunctor`. -}+oneP :: Monoidal p => p () ()+oneP = pure ()++{- | `>*<` is the product of a `Monoidal` `Profunctor`. -}+(>*<) :: Monoidal p => p a b -> p c d -> p (a,c) (b,d)+(>*<) = dimap2 fst snd (,)+infixr 6 >*<++{- | `>*` sequences actions, discarding the value of the first argument;+analagous to `*>`, extending it to `Monoidal`.++prop> oneP >* p = p++-}+(>*) :: Monoidal p => p () c -> p a b -> p a b+x >* y = lmap (const ()) x *> y+infixl 5 >*++{- | `*<` sequences actions, discarding the value of the first argument;+analagous to `<*`, extending it to `Monoidal`.++prop> p *< oneP = p++-}+(*<) :: Monoidal p => p a b -> p () c -> p a b+x *< y = x <* lmap (const ()) y+infixl 5 *<++{- | `dimap2` is a curried, functionalized form of `>*<`,+analagous to `liftA2`. -}+dimap2+  :: Monoidal p+  => (s -> a)+  -> (s -> c)+  -> (b -> d -> t)+  -> 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;+analagous to `forever`, extending it to `Monoidal`. -}+foreverP :: Monoidal p => p () c -> p a b+foreverP a = let a' = a >* a' in a'++{- | Thanks to Fy on Monoidal Café Discord.++`replicateP` is roughly analagous to `replicateM`,+repeating an action a number of times.+However, instead of an `Int` term, it expects+a `Traversable` & `Distributive` type. Such a+type is a homogeneous countable product.+-}+replicateP+  :: (Traversable t, Distributive t, Monoidal p)+  => p a b -> p (t a) (t b)+replicateP p = traverse (\f -> lmap f p) (distribute id)++{- | `meander` gives a default implementation for the+`Data.Profunctor.Traversing.wander`+method of `Data.Profunctor.Traversing.Traversing`+for any `Monoidal`, `Choice` & `Strong` `Profunctor`.++It is invertible when @p@ is `Strong`,+though it's not needed for its definition.++See Pickering, Gibbons & Wu,+[Profunctor Optics - Modular Data Accessors](https://arxiv.org/abs/1703.10857)+-}+meander+  :: (Monoidal p, Choice p)+  => ATraversal s t a b -> p a b -> p s t+meander f = dimap (f sell) iextract . trav+  where+    trav+      :: (Monoidal q, Choice q)+      => q u v -> q (Bazaar (->) u w x) (Bazaar (->) v w x)+    trav q = mapIso funListEot $ right' (q >*< trav q)++{- | A `Monoidal` `Cons` operator. -}+(>:<) :: (Monoidal p, Choice p, Cons s t a b) => p a b -> p s t -> p s t+x >:< xs = _Cons >? x >*< xs+infixr 5 >:<++-- Distributor --++{- | A `Distributor`, or lax distributive profunctor,+respects [distributive category]+(https://ncatlab.org/nlab/show/distributive+category)+structure, that is nilary and binary products and coproducts,+@()@, @(,)@, `Void` and `Either`. It has zero `zeroP`+and sum `>+<` lax monoidal structure morphisms.++In addition to the product laws for `Monoidal`, we have+sum laws for `Distributor`.++Laws:++>>> :{+let f |+| g = either (Left . f) (Right . g)+    lunit = dimap (either absurd id) Right+    runit = dimap (either id absurd) Left+    assoc = dimap+      (either (Left . Left) (either (Left . Right) Right))+      (either (either Left (Right . Left)) (Right . Right))+:}+prop> dimap (f |+| g) (h |+| i) (p >+< q) = dimap f h p >+< dimap g i q+prop> zeroP >+< p = lunit p+prop> p >+< zeroP = runit p+prop> p >+< q >+< r = assoc ((p >+< q) >+< r)++-}+class Monoidal p => Distributor p where++  {- | The zero structure morphism of a `Distributor`. -}+  zeroP :: p Void Void+  default zeroP :: Alternator p => p Void Void+  zeroP = empty++  {- | The sum structure morphism of a `Distributor`. -}+  (>+<) :: p a b -> p c d -> p (Either a c) (Either b d)+  default (>+<)+    :: Alternator p+    => p a b -> p c d -> p (Either a c) (Either b d)+  x >+< y = alternate (Left x) <|> alternate (Right y)+  infixr 3 >+<++  {- | One or none. -}+  optionalP :: p a b -> p (Maybe a) (Maybe b)+  optionalP p = mapIso maybeEot (oneP >+< p)++  {- | Zero or more. -}+  manyP :: p a b -> p [a] [b]+  manyP p = mapIso listEot (oneP >+< p >*< manyP p)++instance Distributor (->) where+  zeroP = id+  (>+<) = (+++)+instance Monoid s => Distributor (Forget s) where+  zeroP = Forget absurd+  Forget kL >+< Forget kR = Forget (either kL kR)+instance Decidable f => Distributor (Clown f) where+  zeroP = Clown lost+  Clown x >+< Clown y = Clown (chosen x y)+instance Alternative f => Distributor (Joker f) where+  zeroP = Joker empty+  Joker x >+< Joker y = Joker (Left <$> x <|> Right <$> y)+  optionalP (Joker x) = Joker (optional x)+  manyP (Joker x) = Joker (many x)+instance (Distributor p, Applicative f)+  => Distributor (WrappedPafb f p) where+    zeroP = WrapPafb (rmap pure zeroP)+    WrapPafb x >+< WrapPafb y = WrapPafb $+      dialt id (fmap Left) (fmap Right) x y+    manyP (WrapPafb x) = WrapPafb (rmap sequenceA (manyP x))+    optionalP (WrapPafb x) = WrapPafb (rmap sequenceA (optionalP x))+instance Applicative f => Distributor (Star f) where+  zeroP = Star absurd+  Star f >+< Star g =+    Star (either (fmap Left . f) (fmap Right . g))+  optionalP (Star f) = Star (traverse f)+  manyP (Star f) = Star (traverse f)+deriving via (Star m) instance Monad m => Distributor (Kleisli m)+instance Adjunction f u => Distributor (Costar f) where+  zeroP = Costar unabsurdL+  Costar f >+< Costar g = Costar (bimap f g . cozipL)+instance (Applicative f, Distributor p)+  => Distributor (Cayley f p) where+    zeroP = Cayley (pure zeroP)+    Cayley x >+< Cayley y = Cayley ((>+<) <$> x <*> y)+    optionalP (Cayley x) = Cayley (optionalP <$> x)+    manyP (Cayley x) = Cayley (manyP <$> x)+instance (ArrowZero p, ArrowChoice p)+  => Distributor (Pro.WrappedArrow p) where+    zeroP = zeroArrow+    (>+<) = (+++)+deriving via (Pro.WrappedArrow p)+  instance (ArrowZero p, ArrowChoice p)+    => Distributor (Ap.WrappedArrow p)+instance (Distributor p, Distributor q)+  => Distributor (Procompose p q) where+    zeroP = Procompose zeroP zeroP+    Procompose xL yL >+< Procompose xR yR =+      Procompose (xL >+< xR) (yL >+< yR)+    optionalP (Procompose f g) =+      Procompose (optionalP f) (optionalP g)+    manyP (Procompose f g) =+      Procompose (manyP f) (manyP g)+instance (Distributor p, Distributor q)+  => Distributor (Product p q) where+    zeroP = Pair zeroP zeroP+    Pair x0 y0 >+< Pair x1 y1 = Pair (x0 >+< x1) (y0 >+< y1)+    optionalP (Pair f g) =+      Pair (optionalP f) (optionalP g)+    manyP (Pair f g) =+      Pair (manyP f) (manyP g)+instance Distributor p => Distributor (Yoneda p) where+  zeroP = proreturn zeroP+  ab >+< cd = proreturn (proextract ab >+< proextract cd)+  optionalP = proreturn . optionalP . proextract+  manyP = proreturn . manyP . proextract+instance Distributor p => Distributor (Coyoneda p) where+  zeroP = proreturn zeroP+  ab >+< cd = proreturn (proextract ab >+< proextract cd)+  optionalP = proreturn . optionalP . proextract+  manyP = proreturn . manyP . proextract++{- | `dialt` is a functionalized form of `>+<`. -}+dialt+  :: Distributor p+  => (s -> Either a c)+  -> (b -> t)+  -> (d -> t)+  -> 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` & `Distributive` countable product+  can be given a default implementation for the `homogeneously` method.++  prop> homogeneously = replicateP++  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 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 U1 where+  homogeneously _ = dimap (const ()) (const U1) oneP+instance Homogeneous (K1 i ()) where+  homogeneously _ = dimap (const ()) (const (K1 ())) oneP+instance Homogeneous (Const ()) where+  homogeneously _ = dimap (const ()) (const (Const ())) oneP+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 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 p = dimap unM1 M1 (homogeneously p)+instance Homogeneous Maybe where+  homogeneously = optionalP+instance Homogeneous [] where+  homogeneously = manyP++-- Alternator/Filtrator --++{- | 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.++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.+-}+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 when `Cochoice`.+    -}+    alternate+      :: Either (p a b) (p c d)+      -> p (Either a c) (Either b d)+    default alternate+      :: Cochoice p+      => Either (p a b) (p c d)+      -> p (Either a c) (Either b d)+    alternate =+      dimapMaybe (either Just (pure Nothing)) (Just . Left)+      |||+      dimapMaybe (either (pure Nothing) Just) (Just . Right)++    {- | One or more. -}+    someP :: p a b -> p [a] [b]+    someP p = _Cons >? p >*< manyP p++instance (Alternator p, Alternative f)+  => Alternator (WrappedPafb f p) where+    alternate =+      let+        f = WrapPafb+          . rmap (either (fmap Left) pure)+          . alternate+          . Left+          . unwrapPafb+        g = WrapPafb+          . rmap (either pure (fmap Right))+          . alternate+          . Right+          . unwrapPafb+      in+        either f g++    someP (WrapPafb x) = WrapPafb (rmap sequenceA (someP 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+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++{- | The `Filtrator` class extends `Cochoice`,+as well as `Filterable`, adding the `filtrate` method,+which is an oplax monoidal structure morphism dual to `>+<`.+-}+class (Cochoice p, forall x. Filterable (p x))+  => Filtrator p where++    {- |+    prop> unleft = fst . filtrate+    prop> unright = snd . filtrate++    `filtrate` is a distant relative to `Data.Either.partitionEithers`.++    `filtrate` has a default when `Choice`.+    -}+    filtrate+      :: p (Either a c) (Either b d)+      -> (p a b, p c d)+    default filtrate+      :: Choice p+      => p (Either a c) (Either b d)+      -> (p a b, p c d)+    filtrate =+      dimapMaybe (Just . Left) (either Just (pure Nothing))+      &&&+      dimapMaybe (Just . Right) (either (pure Nothing) Just)++instance (Filtrator p, Filterable f)+  => Filtrator (WrappedPafb f p) where+    filtrate (WrapPafb p) =+      let+        fL = Left . mapMaybe (either Just (const Nothing))+        fR = Right . mapMaybe (either (const Nothing) Just)+        (pL,_) = filtrate (rmap fL p)+        (_,pR) = filtrate (rmap fR p)+      in+        ( WrapPafb pL+        , WrapPafb pR+        )+instance Filtrator p => Filtrator (Coyoneda p) where+  filtrate p =+    let (q,r) = filtrate (proextract p)+    in (proreturn q, proreturn r)+instance Filtrator p => Filtrator (Yoneda p) where+  filtrate p =+    let (q,r) = filtrate (proextract p)+    in (proreturn q, proreturn r)+instance Filtrator (Forget r) where+  filtrate (Forget f) = (Forget (f . Left), Forget (f . Right))+instance (Filterable f, Traversable f) => Filtrator (Star f) where+  filtrate (Star f) =+    ( Star (mapMaybe (either Just (const Nothing)) . f . Left)+    , Star (mapMaybe (either (const Nothing) Just) . f . Right)+    )+instance Filtrator (PartialExchange a b) where+  filtrate (PartialExchange f g) =+    ( PartialExchange (f . Left) (either Just (pure Nothing) <=< g)+    , PartialExchange (f . Right) (either (pure Nothing) Just <=< g)+    )++-- SepBy --++{- | 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 () ()+  }++{- | A default `SepBy` constructor which can be modified+by updating `beginBy`, or `endBy` fields -}+sepBy :: Monoidal p => p () () -> SepBy p+sepBy = SepBy oneP oneP++{- | No separator, beginning or ending delimiters. -}+noSep :: Monoidal p => SepBy p+noSep = sepBy oneP++{- |+prop> zeroOrMore (sepBy noSep) = manyP+-}+zeroOrMore+  :: Distributor p+  => SepBy p -> p a b -> p [a] [b]+zeroOrMore sep p = mapIso listEot $+  beginBy sep >* oneP >+< p >*< manyP (separateBy sep >* p) *< endBy sep++{- |+prop> oneOrMore (sepBy noSep) = someP+-}+oneOrMore+  :: Alternator p+  => SepBy p -> p a b -> p [a] [b]+oneOrMore sep p = _Cons >?+  beginBy sep >* p >*< manyP (separateBy sep >* p) *< endBy sep++{- |+Left associate a binary constructor pattern to sequence one or more times.+-}+chainl1+  :: (Choice p, Cochoice p, Distributor p)+  => APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern+  -> SepBy p -> p a b -> p a b+chainl1 pat sep p =+  coPartialIso (difoldl (coPartialIso pat)) >?<+    beginBy sep >* p >*< manyP (separateBy sep >* p) *< endBy sep++{- |+Right associate a binary constructor pattern to sequence one or more times.+-}+chainr1+  :: (Choice p, Cochoice p, Distributor p)+  => APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern+  -> SepBy p -> p a b -> p a b+chainr1 c2 sep p =+  coPartialIso (difoldr (coPartialIso c2)) >?<+    beginBy sep >* manyP (p *< separateBy sep) >*< p *< endBy sep++{- |+Left associate a binary constructor pattern to sequence one or more times,+or use a nilary constructor pattern to sequence zero times.+-}+chainl+  :: (Alternator p, Filtrator p)+  => APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern+  -> APartialIso a b () () -- ^ nilary constructor pattern+  -> SepBy p -> p a b -> p a b+chainl c2 c0 sep p =+  beginBy sep >*+  (c0 >?< oneP <|> chainl1 c2 (sepBy (separateBy sep)) p)+  *< endBy sep++{- |+Right associate a binary constructor pattern to sequence one or more times,+or use a nilary constructor pattern to sequence zero times.+-}+chainr+  :: (Alternator p, Filtrator p)+  => APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern+  -> APartialIso a b () () -- ^ nilary constructor pattern+  -> SepBy p -> p a b -> p a b+chainr c2 c0 sep p =+  beginBy sep >*+  (c0 >?< oneP <|> chainr1 c2 (sepBy (separateBy sep)) p)+  *< endBy sep++-- Tokenized --++{- | `Tokenized` serves two different purposes.+The `anyToken` method is used++* by token-stream printer/parsers, to sequence a single token;+* and for concrete optics, as an identity morphism.++In the former case the associated input and output token types+are same. In the latter case, observe that `Identical` is+a free `Tokenized`.+-}+class Tokenized a b p | p -> a, p -> b where+  anyToken :: p a b+instance Tokenized a b (Identical a b) where+  anyToken = Identical+instance Tokenized a b (Exchange a b) where+  anyToken = Exchange id id+instance Tokenized a b (Market a b) where+  anyToken = Market id Right+instance Tokenized a b (PartialExchange a b) where+  anyToken = PartialExchange Just Just++{- | Sequences a single token that satisfies a predicate. -}+satisfy :: (Choice p, Cochoice p, Tokenized c c p) => (c -> Bool) -> p c c+satisfy f = satisfied f >?< anyToken++{- | Sequences a single specified `token`. -}+token :: (Cochoice p, Eq c, Tokenized c c p) => c -> p () ()+token c = only c ?< anyToken++{- | Sequences a specified stream of `tokens`.+It can be used as a default definition for the `fromString`+method of `IsString` when `Tokenized` `Char` `Char`.+-}+tokens :: (Cochoice p, Monoidal p, Eq c, Tokenized c c p) => [c] -> p () ()+tokens [] = oneP+tokens (c:cs) = token c *> tokens cs++-- Printor/Parsor --++{- | A function from things to containers of+functions of strings to strings.+`Printor` is a degenerate `Profunctor` which+is constant in its covariant argument.+-}+newtype Printor s f a b = Printor {runPrintor :: a -> f (s -> s)}+  deriving Functor+instance Contravariant (Printor s f a) where+  contramap _ (Printor p) = Printor p+instance Applicative f => Applicative (Printor s f a) where+  pure _ = Printor (\_ -> pure id)+  Printor p <*> Printor q = Printor (\a -> (.) <$> p a <*> q a)+instance Alternative f => Alternative (Printor s f a) where+  empty = Printor (\_ -> empty)+  Printor p <|> Printor q = Printor (\a -> p a <|> q a)+instance Filterable (Printor s f a) where+  mapMaybe _ (Printor p) = Printor p+instance Profunctor (Printor s f) where+  dimap f _ (Printor p) = Printor (p . f)+instance Alternative f => Choice (Printor s f) where+  left' = alternate . Left+  right' = alternate . Right+instance Cochoice (Printor s f) where+  unleft = fst . filtrate+  unright = snd . filtrate+instance Applicative f => Distributor (Printor s f) where+  zeroP = Printor absurd+  Printor p >+< Printor q = Printor (either p q)+instance Alternative f => Alternator (Printor s f) where+  alternate = \case+    Left (Printor p) -> Printor (either p (\_ -> empty))+    Right (Printor p) -> Printor (either (\_ -> empty) p)+instance Filtrator (Printor s f) where+  filtrate (Printor p) = (Printor (p . Left), Printor (p . Right))+instance (Applicative f, Cons s s c c)+  => Tokenized c c (Printor s f) where+    anyToken = Printor (pure . cons)+instance (Applicative f, Cons s s Char Char)+  => IsString (Printor s f () ()) where+    fromString = tokens++{- | A function from strings to containers of+pairs of things and strings.+`Parsor` is a degenerate `Profunctor` which+is constant in its contravariant argument.+-}+newtype Parsor s f a b = Parsor {runParsor :: s -> f (b,s)}+  deriving Functor+instance Monad f => Applicative (Parsor s f a) where+  pure b = Parsor (\str -> return (b,str))+  Parsor x <*> Parsor y = Parsor $ \str -> do+    (f, str') <- x str+    (a, str'') <- y str'+    return (f a, str'')+instance (Alternative f, Monad f) => Alternative (Parsor s f a) where+  empty = Parsor (\_ -> empty)+  Parsor p <|> Parsor q = Parsor (\str -> p str <|> q str)+instance Filterable f => Filterable (Parsor s f a) where+  mapMaybe f (Parsor p) = Parsor (mapMaybe (\(a,str) -> (,str) <$> f a) . p)+instance Functor f => Bifunctor (Parsor s f) where+  bimap _ g (Parsor p) = Parsor (fmap (\(c,str) -> (g c, str)) . p)+instance Functor f => Profunctor (Parsor s f) where+  dimap _ g (Parsor p) = Parsor (fmap (\(c,str) -> (g c, str)) . p)+instance (Monad f, Alternative f) => Choice (Parsor s f) where+  left' = alternate . Left+  right' = alternate . Right+instance Filterable f => Cochoice (Parsor s f) where+  unleft = fst . filtrate+  unright = snd . filtrate+instance (Monad f, Alternative f) => Distributor (Parsor s f) where+  zeroP = Parsor (\_ -> empty)+  Parsor p >+< Parsor q = Parsor $ \str ->+    (\(b,str') -> (Left b, str')) <$> p str+    <|>+    (\(d,str') -> (Right d, str')) <$> q str+instance (Monad f, Alternative f) => Alternator (Parsor s f) where+  alternate = \case+    Left (Parsor p) -> Parsor (fmap (\(b, str) -> (Left b, str)) . p)+    Right (Parsor p) -> Parsor (fmap (\(b, str) -> (Right b, str)) . p)+instance Filterable f => Filtrator (Parsor s f) where+  filtrate (Parsor p) =+    ( Parsor (mapMaybe leftMay . p)+    , Parsor (mapMaybe rightMay . p)+    ) where+      leftMay (e, str) = either (\b -> Just (b, str)) (\_ -> Nothing) e+      rightMay (e, str) = either (\_ -> Nothing) (\b -> Just (b, str)) e+instance (Alternative f, Cons s s c c)+  => Tokenized c c (Parsor s f) where+    anyToken = Parsor (\str -> maybe empty pure (uncons str))+instance (Alternative f, Filterable f, Monad f, Cons s s Char Char)+  => IsString (Parsor s f () ()) where+    fromString = tokens++-- FunList --++{- |+`FunList` is isomorphic to `Bazaar` @(->)@.+It's needed to define `meander`.++See van Laarhoven, A non-regular data type challenge+[https://twanvl.nl/blog/haskell/non-regular1]+-}+data FunList a b t+  = DoneFun t+  | MoreFun a (Bazaar (->) a b (b -> t))+instance Functor (FunList a b) where+  fmap f = \case+    DoneFun t -> DoneFun (f t)+    MoreFun a h -> MoreFun a (fmap (f .) h)+instance Applicative (FunList a b) where+  pure = DoneFun+  (<*>) = \case+    DoneFun t -> fmap t+    MoreFun a h -> \l ->+      MoreFun a (flip <$> h <*> fromFun l)+instance Sellable (->) FunList where sell b = MoreFun b (pure id)++toFun :: Bazaar (->) a b t -> FunList a b t+toFun (Bazaar f) = f sell++fromFun :: FunList a b t -> Bazaar (->) a b t+fromFun = \case+  DoneFun t -> pure t+  MoreFun a f -> ($) <$> f <*> sell a++funListEot :: Iso+  (Bazaar (->) a1 b1 t1) (Bazaar (->) a2 b2 t2)+  (Either t1 (a1, Bazaar (->) a1 b1 (b1 -> t1)))+  (Either t2 (a2, Bazaar (->) a2 b2 (b2 -> t2)))+funListEot = iso toFun fromFun . iso f g where+  f = \case+    DoneFun t -> Left t+    MoreFun a baz -> Right (a, baz)+  g = \case+    Left t -> DoneFun t+    Right (a, baz) -> MoreFun a baz++-- Orphanage --++instance Monoid r => Applicative (Forget r a) where+  pure _ = Forget mempty+  Forget f <*> Forget g = Forget (f <> g)+instance Decidable f => Applicative (Clown f a) where+  pure _ = Clown conquer+  Clown x <*> Clown y = Clown (divide (id &&& id) x y)+deriving newtype instance Applicative f => Applicative (Joker f a)+deriving via Compose (p a) f instance+  (Profunctor p, Applicative (p a), Applicative f)+    => Applicative (WrappedPafb f p a)+deriving via Compose (p a) f instance+  (Profunctor p, Alternative (p a), Applicative f)+    => Alternative (WrappedPafb f p a)+instance (Closed p, Distributive f)+  => Closed (WrappedPafb f p) where+    closed (WrapPafb p) = WrapPafb (rmap distribute (closed p))+deriving via (Ap.WrappedArrow p a) instance Arrow p+  => Functor (Pro.WrappedArrow p a)+deriving via (Ap.WrappedArrow p a) instance Arrow p+  => Applicative (Pro.WrappedArrow p a)+deriving via (Pro.WrappedArrow p) instance Arrow p+  => Profunctor (Ap.WrappedArrow p)+instance (Monoidal p, Applicative (q a))+  => Applicative (Procompose p q a) where+    pure b = Procompose (pure b) (pure b)+    Procompose wb aw <*> Procompose vb av = Procompose+      (dimap2 fst snd ($) wb vb)+      (liftA2 (,) aw av)+instance (Monoidal p, Monoidal q)+  => Applicative (Product p q a) where+    pure b = Pair (pure b) (pure b)+    Pair x0 y0 <*> Pair x1 y1 = Pair (x0 <*> x1) (y0 <*> y1)+instance (Functor f, Functor (p a)) => Functor (Cayley f p a) where+  fmap f (Cayley x) = Cayley (fmap (fmap f) x)+instance (Applicative f, Applicative (p a)) => Applicative (Cayley f p a) where+  pure b = Cayley (pure (pure b))+  Cayley x <*> Cayley y = Cayley ((<*>) <$> x <*> y)+instance (Profunctor p, Applicative (p a))+  => Applicative (Yoneda p a) where+    pure = proreturn . pure+    ab <*> cd = proreturn (proextract ab <*> proextract cd)+instance (Profunctor p, Applicative (p a))+  => Applicative (Coyoneda p a) where+    pure = proreturn . pure+    ab <*> cd = proreturn (proextract ab <*> proextract cd)++instance (Profunctor p, Alternative (p a))+  => Alternative (Yoneda p a) where+    empty = proreturn empty+    ab <|> cd = proreturn (proextract ab <|> proextract cd)+    many = proreturn . many . proextract+instance (Profunctor p, Alternative (p a))+  => Alternative (Coyoneda p a) where+    empty = proreturn empty+    ab <|> cd = proreturn (proextract ab <|> proextract cd)+    many = proreturn . many . proextract

@@ -0,0 +1,480 @@+{-|+Module      : Text.Grammar.Distributor+Description : grammars+Copyright   : (C) 2025 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable++See Joachim Breitner,+[Showcasing Applicative]+(https://www.joachim-breitner.de/blog/710-Showcasing_Applicative)+for idea to unify grammars.+-}++module Text.Grammar.Distributor+  ( -- * Grammar+    Grammar, Grammarr, Grammatical (..)+    -- * RegEx+  , RegEx (..), regexString, regexGrammar+    -- * Generators+  , genReadS+  , readGrammar+  , genShowS+  , showGrammar+  , genRegEx+  , genGrammar+  , printGrammar+  ) where++import Control.Applicative+import Control.Lens+import Control.Lens.PartialIso+import Data.Char+import Data.Coerce+import Data.Foldable+import Data.Function+import Data.Profunctor+import Data.Profunctor.Distributor+import Data.Set (Set, insert)+import Data.String+import GHC.Generics+import Witherable++{- | `Grammar` is a Backus-Naur form grammar,+extended by regular expressions,+embedded in Haskell.++To see an example of a `Grammar`, look at `regexGrammar`.+-}+type Grammar a = forall p. Grammatical p => p a a++{- | A `Grammarr` is just a function of `Grammar`s,+useful for expressing one in terms of another `Grammar`.+-}+type Grammarr a b = forall p. Grammatical p => p a a -> p b b++{- | The `Grammatical` class extends `Alternator` & `Filtrator`+which gives it Kleene's regular expression combinators. It also has+`rule` and `ruleRec` for defining grammar rules and+recursive grammar rules, i.e. nonterminal expressions. Finally,+terminal expressions can be expressed as string literals since+`Grammatical` also implies `IsString`.++`Control.Lens.Prism.Prism`s and `PartialIso`s can act+on `Grammatical` terms via the `>?<` combinator,+analogously to how constructors act on `Applicative` parsers+with `<$>`.++One can create new "generators" from a `Grammar` by defining+instances of `Grammatical`. For instance, one could create+generators for Parsec style parsers, and use `rule` for+labeling of parse errors.+-}+class+  ( Alternator p+  , Filtrator p+  , Tokenized Char Char p+  , forall t. t ~ p () () => IsString t+  ) => Grammatical p where++    {- | Only characters which are in the given `String`.-}+    inClass :: String -> p Char Char+    inClass str = satisfy $ \ch -> elem ch str++    {- | Only characters which are not in the given `String`.-}+    notInClass :: String -> p Char Char+    notInClass str = satisfy $ \ch -> notElem ch str++    {- | Only characters which are in the given `GeneralCategory`.-}+    inCategory :: GeneralCategory -> p Char Char+    inCategory cat = satisfy $ \ch -> cat == generalCategory ch++    {- | Only characters which are not in the given `GeneralCategory`.-}+    notInCategory :: GeneralCategory -> p Char Char+    notInCategory cat = satisfy $ \ch -> cat /= generalCategory ch++    {- | A nonterminal rule. -}+    rule :: String -> p a b -> p a b+    rule _ = id++    {- | A recursive, nonterminal rule. -}+    ruleRec :: String -> (p a b -> p a b) -> p a b+    ruleRec name = rule name . fix++instance (Alternative f, Cons s s Char Char)+  => Grammatical (Printor s f)+instance (Monad f, Alternative f, Filterable f, Cons s s Char Char)+  => Grammatical (Parsor s f)++-- RegEx --++{- | A version of regular expressions extended by nonterminals. -}+data RegEx+  = Terminal String -- ^ @abc123etc\\.@+  | Sequence RegEx RegEx -- ^ @xy@+  | Fail -- ^ @\\q@+  | Alternate RegEx RegEx -- ^ @x|y@+  | KleeneOpt RegEx -- ^ @x?@+  | KleeneStar RegEx -- ^ @x*@+  | KleenePlus RegEx -- ^ @x+@+  | AnyChar -- ^ @.@+  | InClass String -- ^ @[abc]@+  | NotInClass String -- ^ @[^abc]@+  | InCategory GeneralCategory -- ^ @\\p{Lu}@+  | NotInCategory GeneralCategory -- ^ @\\P{Ll}@+  | NonTerminal String -- ^ @\\q{rule-name}@+  deriving stock (Eq, Ord, Show, Generic)+makePrisms ''RegEx+makePrisms ''GeneralCategory++{- | The `RegEx` `String`.++>>> let rex = Terminal "xy" `Alternate` KleenePlus (Terminal "z")+>>> putStrLn (regexString rex)+xy|z++-}+regexString :: RegEx -> String+regexString rex = maybe "\\q" id (showGrammar regexGrammar rex)++{- | `regexGrammar` provides an important example of a `Grammar`.+Take a look at the source to see its definition.++>>> printGrammar regexGrammar+start = \q{regex}+alternate = \q{sequence}(\|\q{sequence})*+any = \.+atom = \q{nonterminal}|\q{fail}|\q{class-in}|\q{class-not-in}|\q{category-in}|\q{category-not-in}|\q{char}|\q{any}|\q{parenthesized}+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-in = \\p\{\q{category}\}+category-not-in = \\P\{\q{category}\}+char = \q{char-literal}|\q{char-escaped}+char-escaped = \\[\$\(\)\*\+\.\?\[\\\]\^\{\|\}]+char-literal = [^\$\(\)\*\+\.\?\[\\\]\^\{\|\}]+class-in = \[\q{char}*\]+class-not-in = \[\^\q{char}*\]+expression = \q{terminal}|\q{kleene-optional}|\q{kleene-star}|\q{kleene-plus}|\q{atom}+fail = \\q+kleene-optional = \q{atom}\?+kleene-plus = \q{atom}\++kleene-star = \q{atom}\*+nonterminal = \\q\{\q{char}*\}+parenthesized = \(\q{regex}\)+regex = \q{alternate}+sequence = \q{expression}*+terminal = \q{char}+++-}+regexGrammar :: Grammar RegEx+regexGrammar = ruleRec "regex" $ \rex -> altG rex++altG :: Grammarr RegEx RegEx+altG rex = rule "alternate" $+  chainl1 _Alternate (sepBy "|") (seqG rex)++anyG :: Grammar RegEx+anyG = rule "any" $ _AnyChar >?< "."++atomG :: Grammarr RegEx RegEx+atomG rex = rule "atom" $ foldl (<|>) empty+  [ nonterminalG+  , failG+  , classInG+  , classNotInG+  , categoryInG+  , categoryNotInG+  , _Terminal >?< charG >:< pure ""+  , anyG+  , parenG rex+  ]++categoryG :: Grammar GeneralCategory+categoryG = rule "category" $ foldl (<|>) empty+  [ _LowercaseLetter >?< "Ll"+  , _UppercaseLetter >?< "Lu"+  , _TitlecaseLetter >?< "Lt"+  , _ModifierLetter >?< "Lm"+  , _OtherLetter >?< "Lo"+  , _NonSpacingMark >?< "Mn"+  , _SpacingCombiningMark >?< "Mc"+  , _EnclosingMark >?< "Me"+  , _DecimalNumber >?< "Nd"+  , _LetterNumber >?< "Nl"+  , _OtherNumber >?< "No"+  , _ConnectorPunctuation >?< "Pc"+  , _DashPunctuation >?< "Pd"+  , _OpenPunctuation >?< "Ps"+  , _ClosePunctuation >?< "Pe"+  , _InitialQuote >?< "Pi"+  , _FinalQuote >?< "Pf"+  , _OtherPunctuation >?< "Po"+  , _MathSymbol >?< "Sm"+  , _CurrencySymbol >?< "Sc"+  , _ModifierSymbol >?< "Sk"+  , _OtherSymbol >?< "So"+  , _Space >?< "Zs"+  , _LineSeparator >?< "Zl"+  , _ParagraphSeparator >?< "Zp"+  , _Control >?< "Cc"+  , _Format >?< "Cf"+  , _Surrogate >?< "Cs"+  , _PrivateUse >?< "Co"+  , _NotAssigned >?< "Cn"+  ]++categoryInG :: Grammar RegEx+categoryInG = rule "category-in" $+  _InCategory >?< "\\p{" >* categoryG *< "}"++categoryNotInG :: Grammar RegEx+categoryNotInG = rule "category-not-in" $+  _NotInCategory >?< "\\P{" >* categoryG *< "}"++charG :: Grammar Char+charG = rule "char" $ charLiteralG <|> charEscapedG++charEscapedG :: Grammar Char+charEscapedG = rule "char-escaped" $ "\\" >* inClass charsReserved++charLiteralG :: Grammar Char+charLiteralG = rule "char-literal" $ notInClass charsReserved++charsReserved :: String+charsReserved = "$()*+.?[\\]^{|}"++classInG :: Grammar RegEx+classInG = rule "class-in" $+  _InClass >?< "[" >* manyP charG *< "]"++classNotInG :: Grammar RegEx+classNotInG = rule "class-not-in" $+  _NotInClass >?< "[^" >* manyP charG *< "]"++exprG :: Grammarr RegEx RegEx+exprG rex = rule "expression" $ foldl (<|>) empty+  [ terminalG+  , kleeneOptG rex+  , kleeneStarG rex+  , kleenePlusG rex+  , atomG rex+  ]++failG :: Grammar RegEx+failG = rule "fail" $ _Fail >?< "\\q"++nonterminalG :: Grammar RegEx+nonterminalG = rule "nonterminal" $+  _NonTerminal >?< "\\q{" >* manyP charG *< "}"++parenG :: Grammarr RegEx RegEx+parenG rex = rule "parenthesized" $+  "(" >* rex *< ")"++kleeneOptG :: Grammarr RegEx RegEx+kleeneOptG rex = rule "kleene-optional" $+  _KleeneOpt >?< atomG rex *< "?"++kleeneStarG :: Grammarr RegEx RegEx+kleeneStarG rex = rule "kleene-star" $+  _KleeneStar >?< atomG rex *< "*"++kleenePlusG :: Grammarr RegEx RegEx+kleenePlusG rex = rule "kleene-plus" $+  _KleenePlus >?< atomG rex *< "+"++seqG :: Grammarr RegEx RegEx+seqG rex = rule "sequence" $+  chainl _Sequence (_Terminal . _Empty) noSep (exprG rex)++terminalG :: Grammar RegEx+terminalG = rule "terminal" $+  _Terminal >?< someP charG++-- Kleene Star Algebra Operators++(-*-), (|||) :: RegEx -> RegEx -> RegEx++Terminal "" -*- rex = rex+rex -*- Terminal "" = rex+Fail -*- _ = Fail+_ -*- Fail = Fail+Terminal str0 -*- Terminal str1 = Terminal (str0 <> str1)+KleeneStar rex0 -*- rex1 | rex0 == rex1 = plusK rex0+rex0 -*- KleeneStar rex1 | rex0 == rex1 = plusK rex0+rex0 -*- rex1 = Sequence rex0 rex1++KleenePlus rex ||| Terminal "" = starK rex+Terminal "" ||| KleenePlus rex = starK rex+rex ||| Terminal "" = optK rex+Terminal "" ||| rex = optK rex+rex ||| Fail = rex+Fail ||| rex = rex+rex0 ||| rex1 | rex0 == rex1 = rex0+rex0 ||| rex1 = Alternate rex0 rex1++optK, starK, plusK :: RegEx -> RegEx++optK Fail = Terminal ""+optK (Terminal "") = Terminal ""+optK (KleenePlus rex) = starK rex+optK rex = KleeneOpt rex++starK Fail = Terminal ""+starK (Terminal "") = Terminal ""+starK rex = KleeneStar rex++plusK Fail = Fail+plusK (Terminal "") = Terminal ""+plusK rex = KleenePlus rex++-- RegEx generator++newtype DiRegEx a b = DiRegEx RegEx+instance Functor (DiRegEx a) where fmap = rmap+instance Applicative (DiRegEx a) where+  pure _ = DiRegEx (Terminal [])+  DiRegEx rex1 <*> DiRegEx rex2 = DiRegEx (rex1 -*- rex2)+instance Alternative (DiRegEx a) where+  empty = DiRegEx Fail+  DiRegEx rex1 <|> DiRegEx rex2 = DiRegEx (rex1 ||| rex2)+  many (DiRegEx rex) = DiRegEx (KleeneStar rex)+  some (DiRegEx rex) = DiRegEx (KleenePlus rex)+instance Filterable (DiRegEx a) where+  mapMaybe _ = coerce+instance Profunctor DiRegEx where+  dimap _ _ = coerce+instance Distributor DiRegEx where+  zeroP = DiRegEx Fail+  DiRegEx rex1 >+< DiRegEx rex2 = DiRegEx (rex1 ||| rex2)+  optionalP (DiRegEx rex) = DiRegEx (optK rex)+  manyP (DiRegEx rex) = DiRegEx (starK rex)+instance Choice DiRegEx where+  left' = coerce+  right' = coerce+instance Cochoice DiRegEx where+  unleft = coerce+  unright = coerce+instance Alternator DiRegEx where+  someP (DiRegEx rex) = DiRegEx (plusK rex)+instance Filtrator DiRegEx+instance IsString (DiRegEx () ()) where+  fromString str = DiRegEx (Terminal str)+instance Tokenized Char Char DiRegEx where+  anyToken = DiRegEx AnyChar+instance Grammatical DiRegEx where+  inClass str = DiRegEx (InClass str)+  notInClass str = DiRegEx (NotInClass str)+  inCategory cat = DiRegEx (InCategory cat)+  notInCategory cat = DiRegEx (NotInCategory cat)++-- Grammar generator++data DiGrammar a b = DiGrammar+  { grammarStart :: DiRegEx a b+  , grammarRules :: Set (String, RegEx)+  }+instance Functor (DiGrammar a) where fmap = rmap+instance Applicative (DiGrammar a) where+  pure b = DiGrammar (pure b) mempty+  DiGrammar start1 rules1 <*> DiGrammar start2 rules2 =+    DiGrammar (start1 <*> start2) (rules1 <> rules2)+instance Alternative (DiGrammar a) where+  empty = DiGrammar empty mempty+  DiGrammar start1 rules1 <|> DiGrammar start2 rules2 =+    DiGrammar (start1 <|> start2) (rules1 <> rules2)+  many (DiGrammar start rules) = DiGrammar (many start) rules+  some (DiGrammar start rules) = DiGrammar (some start) rules+instance Filterable (DiGrammar a) where+  mapMaybe f (DiGrammar start rules) =+    DiGrammar (mapMaybe f start) rules+instance Profunctor DiGrammar where+  dimap f g (DiGrammar start rules) =+    DiGrammar (dimap f g start) rules+instance Distributor DiGrammar where+  zeroP = DiGrammar zeroP mempty+  DiGrammar start1 rules1 >+< DiGrammar start2 rules2 =+    DiGrammar (start1 >+< start2) (rules1 <> rules2)+  optionalP (DiGrammar start rules) =+    DiGrammar (optionalP start) rules+  manyP (DiGrammar start rules) =+    DiGrammar (manyP start) rules+instance Choice DiGrammar where+  left' = coerce+  right' = coerce+instance Cochoice DiGrammar where+  unleft = coerce+  unright = coerce+instance Alternator DiGrammar where+  someP (DiGrammar start rules) =+    DiGrammar (someP start) rules+instance Filtrator DiGrammar+instance IsString (DiGrammar () ()) where+  fromString str = DiGrammar (fromString str) mempty+instance Tokenized Char Char DiGrammar where+  anyToken = DiGrammar anyToken mempty+instance Grammatical DiGrammar where+  inClass str = DiGrammar (inClass str) mempty+  notInClass str = DiGrammar (notInClass str) mempty+  inCategory str = DiGrammar (inCategory str) mempty+  rule name gram = +    let+      start = DiRegEx (NonTerminal name)+      DiRegEx newRule = grammarStart gram+      rules = insert (name, newRule) (grammarRules gram)+    in+      DiGrammar start rules+  ruleRec name f =+    let+      start = DiRegEx (NonTerminal name)+      gram = f (DiGrammar start mempty)+      DiRegEx newRule = grammarStart gram+      rules = insert (name, newRule) (grammarRules gram)+    in+      DiGrammar start rules++-- Generators --++{- | Generate a `ReadS` from a `Grammar`. -}+genReadS :: Grammar a -> ReadS a+genReadS = runParsor++{- | Use a `Grammar` to parse a `String`. -}+readGrammar :: Grammar a -> String -> [a]+readGrammar grammar str =+  [ a+  | (a, remaining) <- genReadS grammar str+  , remaining == []+  ]++{- | Generate `ShowS`s from a `Grammar`. -}+genShowS :: Alternative f => Grammar a -> a -> f ShowS+genShowS = runPrintor++{- | Use a `Grammar` to print `String`s. -}+showGrammar :: Alternative f => Grammar a -> a -> f String+showGrammar grammar a = ($ "") <$> genShowS grammar a++{- | Generate `RegEx`es from a `Grammar`.+This will infinite loop if you your `Grammar` includes a `ruleRec`,+otherwise it will inline all rules and produce a valid+regular expression.+-}+genRegEx :: Grammar a -> RegEx+genRegEx (DiRegEx rex) = rex++{- | Generate a Backus-Naur form grammar,+extended by regular expressions, from a `Grammar`.+-}+genGrammar :: Grammar a -> [(String, RegEx)]+genGrammar (DiGrammar (DiRegEx start) rules) =+  ("start", start) : toList rules++{- | Print a Backus-Naur form grammar,+extended by regular expressions, from a `Grammar`.+-}+printGrammar :: Grammar a -> IO ()+printGrammar gram = for_ (genGrammar gram) $ \(name_i, rule_i) -> do+  putStr name_i+  putStr " = "+  putStrLn (regexString rule_i)

@@ -0,0 +1,62 @@+module Main (main) where++import Data.Char+import Data.Foldable+import Text.Grammar.Distributor+import Test.Hspec++expectedRegexGrammar :: [(String, RegEx)]+expectedRegexGrammar =+  [("start",NonTerminal "regex")+  ,("alternate",Sequence (NonTerminal "sequence") (KleeneStar (Sequence (Terminal "|") (NonTerminal "sequence"))))+  ,("any",Terminal ".")+  ,("atom",Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (NonTerminal "nonterminal") (NonTerminal "fail")) (NonTerminal "class-in")) (NonTerminal "class-not-in")) (NonTerminal "category-in")) (NonTerminal "category-not-in")) (NonTerminal "char")) (NonTerminal "any")) (NonTerminal "parenthesized"))+  ,("category",Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Alternate (Terminal "Ll") (Terminal "Lu")) (Terminal "Lt")) (Terminal "Lm")) (Terminal "Lo")) (Terminal "Mn")) (Terminal "Mc")) (Terminal "Me")) (Terminal "Nd")) (Terminal "Nl")) (Terminal "No")) (Terminal "Pc")) (Terminal "Pd")) (Terminal "Ps")) (Terminal "Pe")) (Terminal "Pi")) (Terminal "Pf")) (Terminal "Po")) (Terminal "Sm")) (Terminal "Sc")) (Terminal "Sk")) (Terminal "So")) (Terminal "Zs")) (Terminal "Zl")) (Terminal "Zp")) (Terminal "Cc")) (Terminal "Cf")) (Terminal "Cs")) (Terminal "Co")) (Terminal "Cn"))+  ,("category-in",Sequence (Sequence (Terminal "\\p{") (NonTerminal "category")) (Terminal "}"))+  ,("category-not-in",Sequence (Sequence (Terminal "\\P{") (NonTerminal "category")) (Terminal "}"))+  ,("char",Alternate (NonTerminal "char-literal") (NonTerminal "char-escaped"))+  ,("char-escaped",Sequence (Terminal "\\") (InClass "$()*+.?[\\]^{|}"))+  ,("char-literal",NotInClass "$()*+.?[\\]^{|}")+  ,("class-in",Sequence (Sequence (Terminal "[") (KleeneStar (NonTerminal "char"))) (Terminal "]"))+  ,("class-not-in",Sequence (Sequence (Terminal "[^") (KleeneStar (NonTerminal "char"))) (Terminal "]"))+  ,("expression",Alternate (Alternate (Alternate (Alternate (NonTerminal "terminal") (NonTerminal "kleene-optional")) (NonTerminal "kleene-star")) (NonTerminal "kleene-plus")) (NonTerminal "atom"))+  ,("fail",Terminal "\\q")+  ,("kleene-optional",Sequence (NonTerminal "atom") (Terminal "?"))+  ,("kleene-plus",Sequence (NonTerminal "atom") (Terminal "+"))+  ,("kleene-star",Sequence (NonTerminal "atom") (Terminal "*"))+  ,("nonterminal",Sequence (Sequence (Terminal "\\q{") (KleeneStar (NonTerminal "char"))) (Terminal "}"))+  ,("parenthesized",Sequence (Sequence (Terminal "(") (NonTerminal "regex")) (Terminal ")"))+  ,("regex",NonTerminal "alternate")+  ,("sequence",KleeneStar (NonTerminal "expression"))+  ,("terminal",KleenePlus (NonTerminal "char"))+  ]++regexExamples :: [(RegEx, String)]+regexExamples =+  [ (Terminal "abc123etc.", "abc123etc\\.")+  , (Sequence (Terminal "x") (Terminal "y"), "xy")+  , (Fail, "\\q")+  , (Alternate (Terminal "x") (Terminal "y"), "x|y")+  , (KleeneOpt (Terminal "x"), "x?")+  , (KleeneStar (Terminal "x"), "x*")+  , (KleenePlus (Terminal "x"), "x+")+  , (AnyChar, ".")+  , (InClass "abc", "[abc]")+  , (NotInClass "abc", "[^abc]")+  , (InCategory UppercaseLetter, "\\p{Lu}")+  , (NotInCategory LowercaseLetter, "\\P{Ll}")+  , (NonTerminal "rule-name", "\\q{rule-name}")+  , (Terminal "", "")+  ]++main :: IO ()+main = hspec $ do+  describe "regexGrammar" $ do+    it "should generate a correct grammar" $+      genGrammar regexGrammar `shouldBe` expectedRegexGrammar+    for_ regexExamples $ \(rex, str) -> do+      it ("should print " <> show rex <> " correctly") $+        showGrammar regexGrammar rex `shouldBe` Just str+    for_ regexExamples $ \(rex, str) -> do+      it ("should parse " <> str <> " correctly") $+        readGrammar regexGrammar str `shouldSatisfy` elem rex