diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/distributors.cabal b/distributors.cabal --- a/distributors.cabal +++ b/distributors.cabal @@ -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 diff --git a/src/Control/Lens/Internal/NestedPrismTH.hs b/src/Control/Lens/Internal/NestedPrismTH.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/NestedPrismTH.hs @@ -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 +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 <> <> +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 <> <> +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] diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -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`. diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -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) diff --git a/src/Text/Grammar/Distributor.hs b/src/Text/Grammar/Distributor.hs --- a/src/Text/Grammar/Distributor.hs +++ b/src/Text/Grammar/Distributor.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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