distributors 0.1.0.3 → 0.2.0.0

raw patch · 8 files changed

+657/−243 lines, 8 filesdep +template-haskelldep +th-abstractionPVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell, th-abstraction

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−6
• README.md +9/−4
• distributors.cabal +7/−2
• src/Control/Lens/Internal/NestedPrismTH.hs +320/−0
• src/Control/Lens/PartialIso.hs +4/−1
• src/Data/Profunctor/Distributor.hs +68/−29
• src/Text/Grammar/Distributor.hs +239/−198
• test/Spec.hs +5/−3

@@ -1,11 +1,10 @@ # Changelog for `distributors` -All notable changes to this project will be documented in this file.+## 0.2.0.0 - 2025-07-08 -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/).+Added some combinators for `RegEx`es. Updated documentation. -## Unreleased+## 0.1.0.0 -## 0.1.0.0 - YYYY-MM-DD+First version with profunctorial interpretation of invertible syntax.+

@@ -1,9 +1,14 @@ # 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)+[![GithubWorkflowCI](https://github.com/morphismtech/distributors/actions/workflows/ci.yml/badge.svg)](https://github.com/morphismtech/distributors/actions/workflows/ci.yml) +[Github](https://github.com/morphismtech/distributors) +[Hackage](https://hackage.haskell.org/package/distributors)++[YouTube](https://www.youtube.com/watch?v=tZErj7XYpVI)+ This library provides mathematically inspired abstractions for coders to write parsers that can also be inverted to printers.  ## introduction@@ -13,7 +18,7 @@  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.+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 language syntax design.  ## previous work @@ -23,7 +28,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 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/).+The person deserving the most credit for bringing the power of optics to programming, with his [lens library](https://github.com/ekmett/lens/), is Ed Kmett, to whom I am very grateful for teaching me a lot.  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. @@ -31,4 +36,4 @@  ## contributing -Contributors are welcome. The [Issues](https://github.com/distributors/squeal/issues) page is a good place to communicate.+Contributors are welcome. The [Issues](https://github.com/morphismtech/distributors/issues) page is a good place to communicate.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           distributors-version:        0.1.0.3+version:        0.2.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@@ -13,7 +13,7 @@ bug-reports:    https://github.com/morphismtech/distributors/issues author:         Eitan Chatav maintainer:     eitan.chatav@gmail.com-copyright:      2023 Eitan Chatav+copyright:      2025 Eitan Chatav license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple@@ -31,6 +31,7 @@       Control.Lens.Bifocal       Control.Lens.Diopter       Control.Lens.Grate+      Control.Lens.Internal.NestedPrismTH       Control.Lens.Monocle       Control.Lens.PartialIso       Control.Lens.Wither@@ -92,7 +93,9 @@     , mtl >=2.3 && <3     , profunctors >=5.6 && <6     , tagged >=0.8 && <1+    , template-haskell     , text ==2.*+    , th-abstraction     , vector >=0.13 && <1     , witherable >=0.4 && <1   default-language: Haskell2010@@ -158,7 +161,9 @@     , mtl >=2.3 && <3     , profunctors >=5.6 && <6     , tagged >=0.8 && <1+    , template-haskell     , text ==2.*+    , th-abstraction     , vector >=0.13 && <1     , witherable >=0.4 && <1   default-language: Haskell2010

@@ -0,0 +1,320 @@+{- |+Module      : Control.Lens.Internal.NestedPrismTH+Description : nested pair prisms+Copyright   : (C) 2025 - Eitan Chatav+License     : BSD-style (see the file LICENSE)+Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>+Stability   : provisional+Portability : non-portable++Code is duplicated from `Control.Lens.Internal.PrismTH`,+with small tweaks to support nested pairs.+-}++module Control.Lens.Internal.NestedPrismTH+  ( -- * Nested Prisms+    makeNestedPrisms+  ) where++import Control.Applicative+import Control.Lens.Getter+import Control.Lens.Internal.TH+import Control.Lens.Lens+import Control.Monad+import Data.Char (isUpper)+import qualified Data.List as List+import Data.Set.Lens+import Data.Traversable+import Language.Haskell.TH+import qualified Language.Haskell.TH.Datatype as D+import Language.Haskell.TH.Lens+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Set (Set)+import Prelude++-- | Generate 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.+-- 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.>?` and `Control.Lens.PartialIso.>?<`;+-- with repeated use of `Data.Profunctor.Distributor.>*<`+-- on the right-hand-side, resulting in right-nested pairs.+makeNestedPrisms :: Name -> DecsQ+makeNestedPrisms typeName =+  do info <- D.reifyDatatype typeName+     let cons = D.datatypeCons info+     makeConsPrisms (datatypeTypeKinded info) (map normalizeCon cons)++-- Generate prisms for the given type, and normalized constructors.+-- This function dispatches between Iso generation, and normal top-level+makeConsPrisms :: Type -> [NCon] -> DecsQ+-- special case: single constructor -> make iso+makeConsPrisms t [con@(NCon _ [] [] _)] = makeConIso t con+-- top-level definitions+makeConsPrisms t cons =+  fmap concat $ for cons $ \con ->+    do let conName = view nconName con+       stab <- computeOpticType t cons con+       let n = prismName conName+       sequenceA+         ( [ sigD n (return (quantifyType [] (stabToType Set.empty stab)))+           , valD (varP n) (normalB (makeConOpticExp stab cons con)) []+           ]+           ++ inlinePragma n+         )++data OpticType = PrismType | ReviewType++data Stab  = Stab Cxt OpticType Type Type Type Type++stabSimple :: Stab -> Bool+stabSimple (Stab _ _ s t a b) = s == t && a == b++stabToType :: Set Name -> Stab -> Type+stabToType clsTVBNames stab@(Stab cx ty s t a b) =+  quantifyType' clsTVBNames cx stabTy+  where+  stabTy =+    case ty of+      PrismType  | stabSimple stab -> prism'TypeName  `conAppsT` [t,b]+                 | otherwise       -> prismTypeName   `conAppsT` [s,t,a,b]+      ReviewType                   -> reviewTypeName  `conAppsT` [t,b]++stabType :: Stab -> OpticType+stabType (Stab _ o _ _ _ _) = o++computeOpticType :: Type -> [NCon] -> NCon -> Q Stab+computeOpticType t cons con =+  do let cons' = List.delete con cons+     if null (_nconVars con)+         then computePrismType t (view nconCxt con) cons' con+         else computeReviewType t (view nconCxt con) (view nconTypes con)++computeReviewType :: Type -> Cxt -> [Type] -> Q Stab+computeReviewType s' cx tys =+  do let t = s'+     s <- fmap VarT (newName "s")+     a <- fmap VarT (newName "a")+     b <- toNestedPairT (map return tys)+     return (Stab cx ReviewType s t a b)++-- Compute the full type-changing Prism type given an outer type,+-- list of constructors, and target constructor name. Additionally+-- return 'True' if the resulting type is a "simple" prism.+computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab+computePrismType t cx cons con =+  do let ts      = view nconTypes con+         unbound = setOf typeVars t Set.\\ setOf typeVars cons+     sub <- sequenceA (Map.fromSet (newName . nameBase) unbound)+     b   <- toNestedPairT (map return ts)+     a   <- toNestedPairT (map return (substTypeVars sub ts))+     let s = substTypeVars sub t+     return (Stab cx PrismType s t a b)++computeIsoType :: Type -> [Type] -> TypeQ+computeIsoType t' fields =+  do sub <- sequenceA (Map.fromSet (newName . nameBase) (setOf typeVars t'))+     let t = return                    t'+         s = return (substTypeVars sub t')+         b = toNestedPairT (map return                    fields)+         a = toNestedPairT (map return (substTypeVars sub fields))+         ty | Map.null sub = appsT (conT iso'TypeName) [t,b]+            | otherwise    = appsT (conT isoTypeName) [s,t,a,b]+     quantifyType [] <$> ty++-- Construct either a Review or Prism as appropriate+makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ+makeConOpticExp stab cons con =+  case stabType stab of+    PrismType  -> makeConPrismExp stab cons con+    ReviewType -> makeConReviewExp con++-- Construct an iso declaration+makeConIso :: Type -> NCon -> DecsQ+makeConIso s con =+  do let ty      = computeIsoType s (view nconTypes con)+         defName = prismName (view nconName con)+     sequenceA+       ( [ sigD       defName  ty+         , valD (varP defName) (normalB (makeConIsoExp con)) []+         ] +++         inlinePragma defName+       )++-- Construct prism expression+--+-- prism <<reviewer>> <<remitter>>+makeConPrismExp ::+  Stab ->+  [NCon] {- ^ constructors       -} ->+  NCon   {- ^ target constructor -} ->+  ExpQ+makeConPrismExp stab cons con = appsE [varE prismValName, reviewer, remitter]+  where+  ts = view nconTypes con+  fields  = length ts+  conName = view nconName con+  reviewer                   = makeReviewer       conName fields+  remitter | stabSimple stab = makeSimpleRemitter conName (length cons) fields+           | otherwise       = makeFullRemitter cons conName++-- Construct an Iso expression+--+-- iso <<reviewer>> <<remitter>>+makeConIsoExp :: NCon -> ExpQ+makeConIsoExp con = appsE [varE isoValName, remitter, reviewer]+  where+  conName = view nconName con+  fields  = length (view nconTypes con)+  reviewer = makeReviewer    conName fields+  remitter = makeIsoRemitter conName fields++-- Construct a Review expression+--+-- unto (\(x,y,z) -> Con x y z)+makeConReviewExp :: NCon -> ExpQ+makeConReviewExp con = appE (varE untoValName) reviewer+  where+  conName = view nconName con+  fields  = length (view nconTypes con)+  reviewer = makeReviewer conName fields++------------------------------------------------------------------------+-- Prism and Iso component builders+------------------------------------------------------------------------++-- Construct the review portion of a prism.+--+-- (\(x,y,z) -> Con x y z) :: b -> t+makeReviewer :: Name -> Int -> ExpQ+makeReviewer conName fields =+  do xs <- newNames "x" fields+     lam1E (toNestedPairP (map varP xs))+           (conE conName `appsE1` map varE xs)++-- Construct the remit portion of a prism.+-- Pattern match only target constructor, no type changing+--+-- (\x -> case s of+--          Con x y z -> Right (x,y,z)+--          _         -> Left x+-- ) :: s -> Either s a+makeSimpleRemitter ::+  Name {- The name of the constructor on which this prism focuses -} ->+  Int  {- The number of constructors the parent data type has     -} ->+  Int  {- The number of fields the constructor has                -} ->+  ExpQ+makeSimpleRemitter conName numCons fields =+  do x  <- newName "x"+     xs <- newNames "y" fields+     let matches =+           [ match (conP conName (map varP xs))+                   (normalB (appE (conE rightDataName) (toNestedPairE (map varE xs))))+                   []+           ] +++           [ match wildP (normalB (appE (conE leftDataName) (varE x))) []+           | numCons > 1 -- Only generate a catch-all case if there is at least+                         -- one constructor besides the one being focused on.+           ]+     lam1E (varP x) (caseE (varE x) matches)++-- Pattern match all constructors to enable type-changing+--+-- (\x -> case s of+--          Con x y z -> Right (x,y,z)+--          Other_n w   -> Left (Other_n w)+-- ) :: s -> Either t a+makeFullRemitter :: [NCon] -> Name -> ExpQ+makeFullRemitter cons target =+  do x <- newName "x"+     lam1E (varP x) (caseE (varE x) (map mkMatch cons))+  where+  mkMatch (NCon conName _ _ n) =+    do xs <- newNames "y" (length n)+       match (conP conName (map varP xs))+             (normalB+               (if conName == target+                  then appE (conE rightDataName) (toNestedPairE (map varE xs))+                  else appE (conE leftDataName) (conE conName `appsE1` map varE xs)))+             []++-- Construct the remitter suitable for use in an 'Iso'+--+-- (\(Con x y z) -> (x,y,z)) :: s -> a+makeIsoRemitter :: Name -> Int -> ExpQ+makeIsoRemitter conName fields =+  do xs <- newNames "x" fields+     lam1E (conP conName (map varP xs))+           (toNestedPairE (map varE xs))++------------------------------------------------------------------------+-- Utilities+------------------------------------------------------------------------++-- Normalized constructor+data NCon = NCon+  { _nconName :: Name+  , _nconVars :: [Name]+  , _nconCxt  :: Cxt+  , _nconTypes :: [Type]+  }+  deriving (Eq)+instance HasTypeVars NCon where+  typeVarsEx s f (NCon x vars y z) = NCon x vars <$> typeVarsEx s' f y <*> typeVarsEx s' f z+    where s' = List.foldl' (flip Set.insert) s vars++nconName :: Lens' NCon Name+nconName f x = fmap (\y -> x {_nconName = y}) (f (_nconName x))++nconCxt :: Lens' NCon Cxt+nconCxt f x = fmap (\y -> x {_nconCxt = y}) (f (_nconCxt x))++nconTypes :: Lens' NCon [Type]+nconTypes f x = fmap (\y -> x {_nconTypes = y}) (f (_nconTypes x))++-- Normalize a single 'Con' to its constructor name and field types.+normalizeCon :: D.ConstructorInfo -> NCon+normalizeCon info = NCon (D.constructorName info)+                         (D.tvName <$> D.constructorVars info)+                         (D.constructorContext info)+                         (D.constructorFields info)++-- Compute a prism's name by prefixing an underscore for normal+-- constructors and period for operators.+prismName ::+  Name {- type constructor        -} ->+  Name {- prism name              -}+prismName n =+  case nameBase n of+    [] -> error "prismName: empty name base?"+    nb@(x:_) | isUpper x -> mkName (prefix '_' nb)+             | otherwise -> mkName (prefix '.' nb) -- operator+  where+    prefix :: Char -> String -> String+    prefix char str = char:str++-- Construct a tuple type given a list of types.+toNestedPairT :: [TypeQ] -> TypeQ+toNestedPairT [] = appsT (tupleT 0) []+toNestedPairT [x] = x+toNestedPairT (x:xs) = appsT (tupleT 2) [x, toNestedPairT xs]++-- Construct a tuple value given a list of expressions.+toNestedPairE :: [ExpQ] -> ExpQ+toNestedPairE [] = tupE []+toNestedPairE [x] = x+toNestedPairE (x:xs) = tupE [x, toNestedPairE xs]++-- Construct a tuple pattern given a list of patterns.+toNestedPairP :: [PatQ] -> PatQ+toNestedPairP [] = tupP []+toNestedPairP [x] = x+toNestedPairP (x:xs) = tupP [x, toNestedPairP xs]

@@ -48,9 +48,12 @@   , difoldr   , difoldl'   , difoldr'+    -- * Template Haskell+  , makeNestedPrisms   ) where  import Control.Lens+import Control.Lens.Internal.NestedPrismTH import Control.Lens.Internal.Profunctor import Control.Monad import Data.Functor.Compose@@ -76,7 +79,7 @@  {- | `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.+by combining `Control.Lens.Prism.Prism`s and `coPrism`s.  Every `Control.Lens.Iso.Iso` & `Control.Lens.Prism.Prism` is `APartialIso`. 

@@ -38,19 +38,26 @@ import Data.Bifunctor.Clown import Data.Bifunctor.Joker import Data.Bifunctor.Product+import Data.Complex 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 qualified Data.Monoid as Monoid 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.Proxy+import Data.Sequence (Seq) import Data.String+import Data.Tagged+import Data.Tree (Tree (..))+import Data.Vector (Vector) import Data.Void import GHC.Generics import Witherable@@ -67,6 +74,7 @@ >>> 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@@ -94,7 +102,7 @@ x >* y = lmap (const ()) x *> y infixl 5 >* -{- | `*<` sequences actions, discarding the value of the first argument;+{- | `*<` sequences actions, discarding the value of the second argument; analagous to `<*`, extending it to `Monoidal`.  prop> p *< oneP = p@@ -132,13 +140,11 @@   => p a b -> p (t a) (t b) replicateP p = traverse (\f -> lmap f p) (distribute id) -{- | `meander` gives a default implementation for the+{- | For any `Monoidal`, `Choice` & `Strong` `Profunctor`,+`meander` is invertible and 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.+method of `Data.Profunctor.Traversing.Traversing`,+though `Strong` is not needed for its definition.  See Pickering, Gibbons & Wu, [Profunctor Optics - Modular Data Accessors](https://arxiv.org/abs/1703.10857)@@ -180,6 +186,7 @@       (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@@ -188,12 +195,22 @@ -} class Monoidal p => Distributor p where -  {- | The zero structure morphism of a `Distributor`. -}+  {- | The zero structure morphism of a `Distributor`.++  `zeroP` has a default for `Alternator`.++  prop> zeroP = empty+  -}   zeroP :: p Void Void   default zeroP :: Alternator p => p Void Void   zeroP = empty -  {- | The sum structure morphism of a `Distributor`. -}+  {- | The sum structure morphism of a `Distributor`.+  +  `>+<` has a default for `Alternator`.++  prop> x >+< y = alternate (Left x) <|> alternate (Right y)+  -}   (>+<) :: p a b -> p c d -> p (Either a c) (Either b d)   default (>+<)     :: Alternator p@@ -316,6 +333,22 @@   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@@ -326,12 +359,6 @@     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@@ -350,6 +377,10 @@       (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@@ -368,11 +399,21 @@       (homogeneously p) instance Homogeneous t   => Homogeneous (M1 i c t) where-    homogeneously p = dimap unM1 M1 (homogeneously p)+    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 = mapIso listEot (oneP >+< p >*< homogeneously p)+instance Homogeneous Seq where+  homogeneously p = mapIso listEot (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/Filtrator -- @@ -393,7 +434,7 @@     prop> zeroP = empty     prop> x >+< y = alternate (Left x) <|> alternate (Right y) -    `alternate` has a default when `Cochoice`.+    `alternate` has a default for `Cochoice`.     -}     alternate       :: Either (p a b) (p c d)@@ -451,7 +492,7 @@      `filtrate` is a distant relative to `Data.Either.partitionEithers`. -    `filtrate` has a default when `Choice`.+    `filtrate` has a default for `Choice`.     -}     filtrate       :: p (Either a c) (Either b d)@@ -510,17 +551,20 @@   , separateBy :: p () ()   } -{- | A default `SepBy` constructor which can be modified-by updating `beginBy`, or `endBy` fields -}+{- | 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 -{- | No separator, beginning or ending delimiters. -}+{- | A `SepBy` smart constructor for no separator,+beginning or ending delimiters. -} noSep :: Monoidal p => SepBy p noSep = sepBy oneP  {- |-prop> zeroOrMore (sepBy noSep) = manyP+prop> zeroOrMore noSep = manyP -} zeroOrMore   :: Distributor p@@ -529,7 +573,7 @@   beginBy sep >* oneP >+< p >*< manyP (separateBy sep >* p) *< endBy sep  {- |-prop> oneOrMore (sepBy noSep) = someP+prop> oneOrMore noSep = someP -} oneOrMore   :: Alternator p@@ -697,12 +741,7 @@ 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) => Distributor (Parsor s f) instance (Monad f, Alternative f) => Alternator (Parsor s f) where   alternate = \case     Left (Parsor p) -> Parsor (fmap (\(b, str) -> (Left b, str)) . p)

@@ -16,8 +16,6 @@ module Text.Grammar.Distributor   ( -- * Grammar     Grammar, Grammarr, Grammatical (..)-    -- * RegEx-  , RegEx (..), regexString, regexGrammar     -- * Generators   , genReadS   , readGrammar@@ -26,6 +24,12 @@   , genRegEx   , genGrammar   , printGrammar+    -- * RegEx+  , RegEx (..)+  , regexNorm+  , regexParse+  , regexString+  , regexGrammar   ) where  import Control.Applicative@@ -44,33 +48,45 @@  {- | `Grammar` is a Backus-Naur form grammar, extended by regular expressions,-embedded in Haskell.+embedded in Haskell, with combinators: -To see an example of a `Grammar`, look at `regexGrammar`.+* pattern matching `>?`, `>?<`+* alternation `<|>`+* sequencing `>*<`, `>*`, `*<`+* Kleene quantifiers `optionalP`, `manyP`, `someP`+* any character `anyToken`+* regular predicates `inClass`, `notInClass`, `inCategory`, `notInCategory`+* nonregular predicate `satisfy`+* terminal strings `tokens`, `fromString` and -XOverloadedStrings+* nonterminal rules `rule`, `ruleRec`+* and more.++To see an example of a `Grammar`, look at the source of `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`.+The arr is for arrow; and it should be pronounced like a pirate. -} 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+{- | 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.++A `Grammatical` `Profunctor` is a partial distributor,+being an `Alternator` & `Filtrator`.+It is also `Tokenized` with `Char` input & output tokens,+and `IsString` with the property:++prop> fromString = tokens++`Grammatical` has defaults for methods+`inClass`, `notInClass`, `inCategory`, `notInCategory`+in terms of `satisfy`;+and `rule` & `ruleRec` in terms of `id` & `fix`. -} class   ( Alternator p@@ -96,11 +112,11 @@     notInCategory cat = satisfy $ \ch -> cat /= generalCategory ch      {- | A nonterminal rule. -}-    rule :: String -> p a b -> p a b+    rule :: String -> p a a -> p a a     rule _ = id      {- | A recursive, nonterminal rule. -}-    ruleRec :: String -> (p a b -> p a b) -> p a b+    ruleRec :: String -> (p a a -> p a a) -> p a a     ruleRec name = rule name . fix  instance (Alternative f, Cons s s Char Char)@@ -126,172 +142,8 @@   | 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+makeNestedPrisms ''RegEx+makeNestedPrisms ''GeneralCategory  (-*-), (|||) :: RegEx -> RegEx -> RegEx @@ -328,8 +180,48 @@ plusK (Terminal "") = Terminal "" plusK rex = KleenePlus rex --- RegEx generator+{- | Normalize a `RegEx`. +>>> regexNorm (Sequence (Terminal "abc") (Terminal "xyz"))+Terminal "abcxyz"+-}+regexNorm :: RegEx -> RegEx+regexNorm = \case+  Sequence rex0 rex1 -> regexNorm rex0 -*- regexNorm rex1+  Alternate rex0 rex1 -> regexNorm rex0 ||| regexNorm rex1+  KleeneOpt rex -> optK (regexNorm rex)+  KleeneStar rex -> starK (regexNorm rex)+  KleenePlus rex -> plusK (regexNorm rex)+  otherRegEx -> otherRegEx++{- | Parse a `RegEx` from a `String`.++>>> let str = "xy|z+"+>>> regexParse str+Alternate (Terminal "xy") (KleenePlus (Terminal "z"))++`Fail` if the `String` is not a valid regular expression.++>>> let bad = ")("+>>> regexParse bad+Fail+-}+regexParse :: String -> RegEx+regexParse str = case readGrammar regexGrammar str of+  [] -> Fail+  rex:_ -> regexNorm rex++{- | The `RegEx` `String`.++>>> let rex = Alternate (Terminal "xy") (KleenePlus (Terminal "z"))+>>> putStrLn (regexString rex)+xy|z++-}+regexString :: RegEx -> String+regexString rex = maybe "\\q" id (showGrammar regexGrammar rex)++-- RegEx Generator --+ newtype DiRegEx a b = DiRegEx RegEx instance Functor (DiRegEx a) where fmap = rmap instance Applicative (DiRegEx a) where@@ -368,7 +260,7 @@   inCategory cat = DiRegEx (InCategory cat)   notInCategory cat = DiRegEx (NotInCategory cat) --- Grammar generator+-- Grammar Generator --  data DiGrammar a b = DiGrammar   { grammarStart :: DiRegEx a b@@ -435,7 +327,7 @@  -- Generators -- -{- | Generate a `ReadS` from a `Grammar`. -}+{- | Generate a `ReadS` parser from a `Grammar`. -} genReadS :: Grammar a -> ReadS a genReadS = runParsor @@ -447,7 +339,7 @@   , remaining == []   ] -{- | Generate `ShowS`s from a `Grammar`. -}+{- | Generate `ShowS` printers from a `Grammar`. -} genShowS :: Alternative f => Grammar a -> a -> f ShowS genShowS = runPrintor @@ -455,26 +347,175 @@ 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.+{- | Generate a `RegEx` from a `Grammar`.+This will infinite loop if your `Grammar` includes a `ruleRec`,+otherwise it will inline all rules and produce a regular expression. -} genRegEx :: Grammar a -> RegEx genRegEx (DiRegEx rex) = rex -{- | Generate a Backus-Naur form grammar,-extended by regular expressions, from a `Grammar`.+{- | Generate a context free grammar,+consisting of @"start"@ & named `RegEx` rules, 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`.--}+{- | Print a `Grammar`.-} printGrammar :: Grammar a -> IO () printGrammar gram = for_ (genGrammar gram) $ \(name_i, rule_i) -> do   putStr name_i   putStr " = "   putStrLn (regexString rule_i)++-- RegEx Grammar --++{- | `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" $+  nonterminalG+  <|> failG+  <|> classInG+  <|> classNotInG+  <|> categoryInG+  <|> categoryNotInG+  <|> _Terminal >?< charG >:< pure ""+  <|> anyG+  <|> parenG rex++categoryG :: Grammar GeneralCategory+categoryG = rule "category" $+  _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" $+  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 a a+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

@@ -2,6 +2,7 @@  import Data.Char import Data.Foldable+import Data.List (nub) import Text.Grammar.Distributor import Test.Hspec @@ -57,6 +58,7 @@     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+      it ("should parse " <> str <> " correctly") $ do+        let parses = readGrammar regexGrammar str+        parses `shouldSatisfy` elem rex+        length (nub (map regexNorm parses)) `shouldBe` 1