From a2a3c5b90e35d58d73c625841ccf545cf97b29ec Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 19 Oct 2025 06:24:42 -0700 Subject: [PATCH 001/282] skeleton --- distributors.cabal | 8 +++++++- src/Control/Lens/Grammar.hs | 18 +++++++++++++++++ src/Control/Lens/Grammar/Char.hs | 10 ++++++++++ src/Control/Lens/Internal/Equator.hs | 8 ++++++++ src/Data/Profunctor/Monadic/Do.hs | 6 ++++++ src/Data/Profunctor/Parsor.hs | 25 +++++++++++++++++++++++ src/Data/Profunctor/Polyadic/Do.hs | 30 ++++++++++++++++++++++++++++ 7 files changed, 104 insertions(+), 1 deletion(-) create mode 100644 src/Control/Lens/Grammar.hs create mode 100644 src/Control/Lens/Grammar/Char.hs create mode 100644 src/Control/Lens/Internal/Equator.hs create mode 100644 src/Data/Profunctor/Monadic/Do.hs create mode 100644 src/Data/Profunctor/Parsor.hs create mode 100644 src/Data/Profunctor/Polyadic/Do.hs diff --git a/distributors.cabal b/distributors.cabal index b442c11..6285020 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack @@ -30,12 +30,18 @@ library exposed-modules: Control.Lens.Bifocal Control.Lens.Diopter + Control.Lens.Grammar + Control.Lens.Grammar.Char Control.Lens.Grate + Control.Lens.Internal.Equator Control.Lens.Internal.NestedPrismTH Control.Lens.Monocle Control.Lens.PartialIso Control.Lens.Wither Data.Profunctor.Distributor + Data.Profunctor.Monadic.Do + Data.Profunctor.Parsor + Data.Profunctor.Polyadic.Do Text.Grammar.Distributor other-modules: Paths_distributors diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs new file mode 100644 index 0000000..b023bcd --- /dev/null +++ b/src/Control/Lens/Grammar.hs @@ -0,0 +1,18 @@ +module Control.Lens.Grammar + ( -- * Grammar +-- RegGrammar +-- , Grammar +-- , CtxGrammar + -- * Invariant +-- , RegEx +-- , Gram +-- , InvariantP + -- * Generator +-- , genShow +-- , genRead +-- , genRegEx +-- , genGram + -- * Combinator +-- , NonTerminal (..) +-- , Terminal (..) + ) where diff --git a/src/Control/Lens/Grammar/Char.hs b/src/Control/Lens/Grammar/Char.hs new file mode 100644 index 0000000..1714e18 --- /dev/null +++ b/src/Control/Lens/Grammar/Char.hs @@ -0,0 +1,10 @@ +module Control.Lens.Grammar.Char + ( -- * + -- CharReg + -- , CharGrammar + -- , CharCtx + -- , regexGrammar + -- , gramGrammar + -- , dataGrammar + -- , Char1 + ) where diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs new file mode 100644 index 0000000..0eed47d --- /dev/null +++ b/src/Control/Lens/Internal/Equator.hs @@ -0,0 +1,8 @@ +module Control.Lens.Internal.Equator + ( -- * + -- Equator + ) where + + +-- class Equator a b p | p -> a, p -> b where equate :: p a b +-- instance Equator a b (Identical a b) where equate = Identical diff --git a/src/Data/Profunctor/Monadic/Do.hs b/src/Data/Profunctor/Monadic/Do.hs new file mode 100644 index 0000000..c81e50a --- /dev/null +++ b/src/Data/Profunctor/Monadic/Do.hs @@ -0,0 +1,6 @@ +module Data.Profunctor.Monadic.Do + ( -- * + (>>=) + , (>>) + , return + ) where diff --git a/src/Data/Profunctor/Parsor.hs b/src/Data/Profunctor/Parsor.hs new file mode 100644 index 0000000..0d89fb1 --- /dev/null +++ b/src/Data/Profunctor/Parsor.hs @@ -0,0 +1,25 @@ +module Data.Profunctor.Parsor + ( -- * +-- Parsor +-- , Printor +-- , PP +-- , toParsor +-- , toPrintor +-- , pp +-- , Separator (..) +-- , SepBy (..) +-- , Stream1 (..) +-- , Stream (..) +-- , Tokenized (..) +-- , satisfy +-- , Categorized (..) + ) where + + +-- newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} +-- newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} +-- newtype PP s t f a b = PP {runPP :: a -> s -> f (b, s -> t)} + +-- toParsor :: Functor f => PP a b f s t -> Parsor s t f a b -- s -> a -> f (t, s -> b) +-- toPrintor :: Functor f => PP s t f a b -> Printor s t f a b +-- pp :: Applicative f => Parsor s t f a b -> Printor s t f a b -> PP s t f a b diff --git a/src/Data/Profunctor/Polyadic/Do.hs b/src/Data/Profunctor/Polyadic/Do.hs new file mode 100644 index 0000000..2374d69 --- /dev/null +++ b/src/Data/Profunctor/Polyadic/Do.hs @@ -0,0 +1,30 @@ +{-| +Module : Data.Profunctor.Polyadic.Do +Description : polyadic do-notation +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + +module Data.Profunctor.Polyadic.Do + ( -- * + (>>=) + , (>>) + , return + , fail + ) where + +-- import Data.Profunctor.Monadic +-- import Prelude hiding ((>>), (>>=)) + +-- (>>=) +-- :: (Polyadic p, Monad m) +-- => p i j m a b -> (b -> p j k m a c) -> p i k m a c +-- x >>= f = composeP (fmap f x) + +-- (>>) +-- :: (Polyadic p, Monad m) +-- => p i j m a b -> p j k m a c -> p i k m a c +-- x >> y = x >>= (\_ -> y) From 094b02911bac75b29a290a2679be81c2f6a8ad6c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 19 Oct 2025 06:30:50 -0700 Subject: [PATCH 002/282] monadic --- distributors.cabal | 3 + package.yaml | 1 + src/Data/Profunctor/Monadic.hs | 159 +++++++++++++++++++++++++++++ src/Data/Profunctor/Polyadic/Do.hs | 20 ++-- stack.yaml | 2 + 5 files changed, 175 insertions(+), 10 deletions(-) create mode 100644 src/Data/Profunctor/Monadic.hs diff --git a/distributors.cabal b/distributors.cabal index 6285020..a809b19 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -39,6 +39,7 @@ library Control.Lens.PartialIso Control.Lens.Wither Data.Profunctor.Distributor + Data.Profunctor.Monadic Data.Profunctor.Monadic.Do Data.Profunctor.Parsor Data.Profunctor.Polyadic.Do @@ -93,6 +94,7 @@ library , containers >=0.6 && <1 , contravariant >=1.5 && <2 , distributive >=0.6 && <1 + , indexed-transformers >=0.1.0.4 && <1 , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 @@ -159,6 +161,7 @@ test-suite spec , distributive >=0.6 && <1 , distributors , hspec + , indexed-transformers >=0.1.0.4 && <1 , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 diff --git a/package.yaml b/package.yaml index aee12c3..73b0374 100644 --- a/package.yaml +++ b/package.yaml @@ -28,6 +28,7 @@ dependencies: - distributive >= 0.6 && < 1 - lens >= 5.2 && < 6 - mtl >= 2.3 && < 3 +- indexed-transformers >= 0.1.0.4 && < 1 - profunctors >= 5.6 && < 6 - tagged >= 0.8 && < 1 - template-haskell diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs new file mode 100644 index 0000000..b01d0d3 --- /dev/null +++ b/src/Data/Profunctor/Monadic.hs @@ -0,0 +1,159 @@ +{-| +Module : Data.Profunctor.Monadic +Description : monadic profunctors +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + +{-# LANGUAGE PolyKinds #-} + +module Data.Profunctor.Monadic + ( Monadic (..) + , Polyadic (..) + , Tetradic (..) + , WrappedMonadic (..) + , WrappedPolyadic (..) + , TaggedP (..) + , UntaggedT (..) + , UntaggedC (..) + ) where + +import Control.Category +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Indexed +import Data.Profunctor +import Prelude hiding (id, (.)) + +class + ( forall m. Monad m => Profunctor (p m) + , forall m x. Monad m => Monad (p m x) + ) => Monadic p where + + joinP :: Monad m => p m a (m b) -> p m a b + joinP = join . fmap liftP + + liftP :: Monad m => m b -> p m a b + liftP = joinP . return + +-- instance Monadic (Parsor s s) where +-- joinP (Parsor p) = Parsor $ \s -> do +-- (mb, s') <- p s +-- b <- mb +-- return (b, s') +-- instance Monadic (CtxPrintor s s) where +-- joinP (CtxPrintor p) = CtxPrintor $ \a -> do +-- (mb, q) <- p a +-- b <- mb +-- return (b, q) + +class + ( forall i j. i ~ j => Monadic (p i j) + , forall i j m. Monad m => Profunctor (p i j m) + , forall i j m a. Monad m => Functor (p i j m a) + ) => Polyadic p where + composeP :: Monad m => p i j m a (p j k m a b) -> p i k m a b + +-- instance Polyadic Parsor where +-- composeP (Parsor p) = Parsor $ \s -> do +-- (mb, s') <- p s +-- runParsor mb s' +-- instance Polyadic CtxPrintor where +-- composeP (CtxPrintor p) = CtxPrintor $ \ctx -> do +-- (CtxPrintor p', ij) <- p ctx +-- (b, jk) <- p' ctx +-- return (b, jk . ij) + +class (forall f i j. Functor f => Profunctor (p i j f)) + => Tetradic p where + + tetramap + :: Functor f + => (h -> i) -> (j -> k) + -> (s -> a) -> (b -> t) + -> p i j f a b -> p h k f s t + tetramap f1 f2 f3 f4 = dimapT f1 f2 . dimap f3 f4 + + dimapT + :: Functor f + => (h -> i) -> (j -> k) + -> p i j f a b -> p h k f a b + dimapT f1 f2 = tetramap f1 f2 id id + +-- instance Tetradic Printor where +-- dimapT f g (Printor p) = Printor (fmap (dimap f g) . p) +-- instance Tetradic Parsor where +-- dimapT f g (Parsor p) = Parsor (fmap (fmap g) . p . f) +-- instance Tetradic CtxPrintor where +-- dimapT f g (CtxPrintor p) = CtxPrintor (fmap (second' (dimap f g)) . p) + +newtype WrappedMonadic p m a b = WrapMonadic {unwrapMonadic :: p m a (m b)} +instance (Monadic p, Monad m) => Functor (WrappedMonadic p m a) where + fmap = rmap +instance (Monadic p, Monad m) => Applicative (WrappedMonadic p m a) where + pure x = WrapMonadic $ pure (pure x) + WrapMonadic p1 <*> WrapMonadic p2 = WrapMonadic $ liftA2 (<*>) p1 p2 +instance (Monadic p, Monad m) => Monad (WrappedMonadic p m a) where + return = pure + WrapMonadic p >>= f = WrapMonadic $ do + b <- joinP p + unwrapMonadic (f b) +instance (Monadic p, Monad m) => Profunctor (WrappedMonadic p m) where + dimap f g (WrapMonadic p) = WrapMonadic $ dimap f (fmap g) p +instance Monadic p => Monadic (WrappedMonadic p) where + joinP (WrapMonadic p) = WrapMonadic (joinP p) + +newtype WrappedPolyadic p i j m a b = WrapPolyadic {unwrapPolyadic :: p i j m a (m b)} +instance (Polyadic p, Monad m) => Functor (WrappedPolyadic p i j m a) where + fmap = rmap +instance (Polyadic p, Monad m, i ~ j) => Applicative (WrappedPolyadic p i j m a) where + pure x = WrapPolyadic $ pure (pure x) + WrapPolyadic p1 <*> WrapPolyadic p2 = WrapPolyadic $ liftA2 (<*>) p1 p2 +instance (Polyadic p, Monad m, i ~ j) => Monad (WrappedPolyadic p i j m a) where + return = pure + WrapPolyadic p >>= f = WrapPolyadic $ do + b <- joinP p + unwrapPolyadic (f b) +instance (Polyadic p, Monad m) => Profunctor (WrappedPolyadic p i j m) where + dimap f g = WrapPolyadic . dimap f (fmap g) . unwrapPolyadic +instance (Polyadic p, i ~ j) => Monadic (WrappedPolyadic p i j) where + joinP = WrapPolyadic . joinP . unwrapPolyadic +instance Polyadic p => Polyadic (WrappedPolyadic p) where + composeP + = WrapPolyadic . composeP + . fmap unwrapPolyadic . composeP + . fmap liftP . unwrapPolyadic + +newtype TaggedP t i j f a b = TagP {untagP :: t i j f b} + deriving newtype (Functor, Applicative, Monad) +instance Functor (t i j f) => Profunctor (TaggedP t i j f) where + dimap _ f = TagP . fmap f . untagP +instance MonadTrans (t i j) => Monadic (TaggedP t i j) where + liftP = TagP . lift +instance IxMonadTrans t => Polyadic (TaggedP t) where + composeP = TagP . joinIx . fmap untagP . untagP + +newtype UntaggedT p a i j f b = UntagT {tagT :: p i j f a b} + deriving newtype (Functor, Applicative, Monad) +instance Monadic (p i j) => MonadTrans (UntaggedT p a i j) where + lift = UntagT . liftP +instance Polyadic p => IxMonadTrans (UntaggedT p a) where + joinIx = UntagT . composeP . fmap tagT . tagT + +newtype UntaggedC p a b f i j = UntagC {tagC :: p i j f a b} +instance Tetradic p => Tetradic (UntaggedC p) where + tetramap f1 f2 f3 f4 = UntagC . tetramap f3 f4 f1 f2 . tagC +instance (Tetradic p, Functor f) => Profunctor (UntaggedC p a b f) where + dimap f g = UntagC . dimapT f g . tagC +instance (Tetradic p, Functor f) => Functor (UntaggedC p a b f i) where + fmap = rmap +instance (Polyadic p, Monad m, Monoid b) => Category (UntaggedC p a b m) where + id = UntagC (pure mempty) + UntagC g . UntagC f = UntagC (composeP (fmap (\b -> fmap (<> b) g) f)) +instance (Polyadic p, Monad m, Monoid b, i ~ j) + => Semigroup (UntaggedC p a b m i j) where (<>) = (>>>) +instance (Polyadic p, Monad m, Monoid b, i ~ j) + => Monoid (UntaggedC p a b m i j) where mempty = id diff --git a/src/Data/Profunctor/Polyadic/Do.hs b/src/Data/Profunctor/Polyadic/Do.hs index 2374d69..f3b62b0 100644 --- a/src/Data/Profunctor/Polyadic/Do.hs +++ b/src/Data/Profunctor/Polyadic/Do.hs @@ -16,15 +16,15 @@ module Data.Profunctor.Polyadic.Do , fail ) where --- import Data.Profunctor.Monadic --- import Prelude hiding ((>>), (>>=)) +import Data.Profunctor.Monadic +import Prelude hiding ((>>), (>>=)) --- (>>=) --- :: (Polyadic p, Monad m) --- => p i j m a b -> (b -> p j k m a c) -> p i k m a c --- x >>= f = composeP (fmap f x) +(>>=) + :: (Polyadic p, Monad m) + => p i j m a b -> (b -> p j k m a c) -> p i k m a c +x >>= f = composeP (fmap f x) --- (>>) --- :: (Polyadic p, Monad m) --- => p i j m a b -> p j k m a c -> p i k m a c --- x >> y = x >>= (\_ -> y) +(>>) + :: (Polyadic p, Monad m) + => p i j m a b -> p j k m a c -> p i k m a c +x >> y = x >>= (\_ -> y) diff --git a/stack.yaml b/stack.yaml index 6cb3778..74f6bc6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,5 @@ resolver: lts-22.6 packages: - . +extra-deps: +- indexed-transformers-0.1.0.4 From fab5a95fd18d4eaf3b441d47e726db47412dc023 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 19 Oct 2025 06:45:32 -0700 Subject: [PATCH 003/282] Update Equator.hs --- src/Control/Lens/Internal/Equator.hs | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index 0eed47d..ed4d371 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -1,8 +1,21 @@ module Control.Lens.Internal.Equator ( -- * - -- Equator + Equator (..) ) where +import Control.Lens +import Control.Lens.Internal.Iso +import Control.Lens.Internal.Prism +import Control.Lens.Internal.Profunctor --- class Equator a b p | p -> a, p -> b where equate :: p a b --- instance Equator a b (Identical a b) where equate = Identical +class Equator a b p | p -> a, p -> b where equate :: p a b +instance Equator a b (Identical a b) where equate = Identical +instance Equator a b (Exchange a b) where + equate = Exchange id id +instance Equator a b (Market a b) where + equate = Market id Right +-- instance Equator a b (PartialExchange a b) where +-- equate = PartialExchange Just Just +instance (Equator a b p, Profunctor p, Applicative f) + => Equator a b (WrappedPafb f p) where + equate = WrapPafb (rmap pure equate) From d52d686bdc1e84832187cdd6ff910f3d3cb19c6b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 19 Oct 2025 06:46:43 -0700 Subject: [PATCH 004/282] drop Profunctor.Polyadic --- distributors.cabal | 1 - src/Data/Profunctor/Monadic/Do.hs | 24 ++++++++++++++++++++++++ src/Data/Profunctor/Polyadic/Do.hs | 30 ------------------------------ 3 files changed, 24 insertions(+), 31 deletions(-) delete mode 100644 src/Data/Profunctor/Polyadic/Do.hs diff --git a/distributors.cabal b/distributors.cabal index a809b19..b5d4345 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -42,7 +42,6 @@ library Data.Profunctor.Monadic Data.Profunctor.Monadic.Do Data.Profunctor.Parsor - Data.Profunctor.Polyadic.Do Text.Grammar.Distributor other-modules: Paths_distributors diff --git a/src/Data/Profunctor/Monadic/Do.hs b/src/Data/Profunctor/Monadic/Do.hs index c81e50a..057c2ae 100644 --- a/src/Data/Profunctor/Monadic/Do.hs +++ b/src/Data/Profunctor/Monadic/Do.hs @@ -1,6 +1,30 @@ +{-| +Module : Data.Profunctor.Monadic.Do +Description : overloaded do-notation +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + module Data.Profunctor.Monadic.Do ( -- * (>>=) , (>>) , return + , fail ) where + +import Data.Profunctor.Monadic +import Prelude hiding ((>>), (>>=)) + +(>>=) + :: (Polyadic p, Monad m) + => p i j m a b -> (b -> p j k m a c) -> p i k m a c +x >>= f = composeP (fmap f x) + +(>>) + :: (Polyadic p, Monad m) + => p i j m a b -> p j k m a c -> p i k m a c +x >> y = x >>= (\_ -> y) diff --git a/src/Data/Profunctor/Polyadic/Do.hs b/src/Data/Profunctor/Polyadic/Do.hs deleted file mode 100644 index f3b62b0..0000000 --- a/src/Data/Profunctor/Polyadic/Do.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-| -Module : Data.Profunctor.Polyadic.Do -Description : polyadic do-notation -Copyright : (C) 2025 - Eitan Chatav -License : BSD-style (see the file LICENSE) -Maintainer : Eitan Chatav -Stability : provisional -Portability : non-portable --} - -module Data.Profunctor.Polyadic.Do - ( -- * - (>>=) - , (>>) - , return - , fail - ) where - -import Data.Profunctor.Monadic -import Prelude hiding ((>>), (>>=)) - -(>>=) - :: (Polyadic p, Monad m) - => p i j m a b -> (b -> p j k m a c) -> p i k m a c -x >>= f = composeP (fmap f x) - -(>>) - :: (Polyadic p, Monad m) - => p i j m a b -> p j k m a c -> p i k m a c -x >> y = x >>= (\_ -> y) From 3c215c18552779ca64397d872ae9c2b9b4318aa9 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 19 Oct 2025 07:31:58 -0700 Subject: [PATCH 005/282] Update Parsor.hs --- src/Data/Profunctor/Parsor.hs | 47 ++++++++++++++++++++++++++++++----- 1 file changed, 41 insertions(+), 6 deletions(-) diff --git a/src/Data/Profunctor/Parsor.hs b/src/Data/Profunctor/Parsor.hs index 0d89fb1..086172f 100644 --- a/src/Data/Profunctor/Parsor.hs +++ b/src/Data/Profunctor/Parsor.hs @@ -1,8 +1,8 @@ module Data.Profunctor.Parsor ( -- * --- Parsor --- , Printor --- , PP + Parsor (..) + , Printor (..) + , PP (..) -- , toParsor -- , toPrintor -- , pp @@ -15,10 +15,45 @@ module Data.Profunctor.Parsor -- , Categorized (..) ) where +import Control.Applicative +import Control.Category +import Control.Monad +import Data.Bifunctor +import Data.Coerce +import Data.Profunctor +import Prelude hiding ((.), id) --- newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} --- newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} --- newtype PP s t f a b = PP {runPP :: a -> s -> f (b, s -> t)} +newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} + +instance Functor f => Functor (Parsor s t f a) where + fmap f = Parsor . (fmap (first' f) .) . runParsor +instance Functor f => Bifunctor (Parsor s t f) where + bimap _ = (>>>) coerce . fmap + first _ = coerce + second = fmap +instance Functor f => Profunctor (Parsor s t f) where + dimap _ = (<<<) coerce . fmap + lmap _ = coerce + rmap = fmap + +instance Monad m => Applicative (Parsor s s m a) where + pure b = Parsor (\s -> return (b,s)) + Parsor x <*> Parsor y = Parsor $ \s -> do + (f, t) <- x s + (a, u) <- y t + return (f a, u) +instance Monad m => Monad (Parsor s s m a) where + Parsor p >>= f = Parsor $ \s -> do + (a, t) <- p s + runParsor (f a) t +instance (Alternative m, Monad m) => Alternative (Parsor s s m a) where + empty = Parsor (\_ -> empty) + Parsor p <|> Parsor q = Parsor (\str -> p str <|> q str) +instance (Alternative m, Monad m) => MonadPlus (Parsor s s m a) + +newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} + +newtype PP s t f a b = PP {runPP :: a -> s -> f (b, s -> t)} -- toParsor :: Functor f => PP a b f s t -> Parsor s t f a b -- s -> a -> f (t, s -> b) -- toPrintor :: Functor f => PP s t f a b -> Printor s t f a b From 5f6edfa0088722d248e54ab640b01850167662c4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 19 Oct 2025 09:23:43 -0700 Subject: [PATCH 006/282] listed --- src/Control/Lens/PartialIso.hs | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index 08ff4e4..8411e17 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -38,6 +38,7 @@ module Control.Lens.PartialIso , nulled , notNulled , streamed + , listed , maybeEot , listEot -- * Iterations @@ -254,13 +255,22 @@ 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 +streamed = iso thither thither + +{- | `listed` is an isomorphism between +a stream type and a list. -} +listed :: (AsEmpty s, Cons s s c c) => Iso' [c] s +listed = iso hither thither where - convertStream s = - maybe - Empty - (\(h,t) -> cons h (convertStream t)) - (uncons s) + hither [] = Empty + hither (h:t) = cons h (hither t) + +thither :: (Cons s s c c, AsEmpty t, Cons t t c c) => s -> t +thither s = + maybe + Empty + (\(h,t) -> cons h (thither t)) + (uncons s) {- | The either-of-tuples representation of `Maybe`. -} maybeEot :: Iso (Maybe a) (Maybe b) (Either () a) (Either () b) From 381e2149f7086c90241c22aa53ce53fe23588057 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 19 Oct 2025 09:23:49 -0700 Subject: [PATCH 007/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index b01d0d3..944ae97 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -39,11 +39,6 @@ class liftP :: Monad m => m b -> p m a b liftP = joinP . return --- instance Monadic (Parsor s s) where --- joinP (Parsor p) = Parsor $ \s -> do --- (mb, s') <- p s --- b <- mb --- return (b, s') -- instance Monadic (CtxPrintor s s) where -- joinP (CtxPrintor p) = CtxPrintor $ \a -> do -- (mb, q) <- p a @@ -57,10 +52,6 @@ class ) => Polyadic p where composeP :: Monad m => p i j m a (p j k m a b) -> p i k m a b --- instance Polyadic Parsor where --- composeP (Parsor p) = Parsor $ \s -> do --- (mb, s') <- p s --- runParsor mb s' -- instance Polyadic CtxPrintor where -- composeP (CtxPrintor p) = CtxPrintor $ \ctx -> do -- (CtxPrintor p', ij) <- p ctx @@ -85,8 +76,6 @@ class (forall f i j. Functor f => Profunctor (p i j f)) -- instance Tetradic Printor where -- dimapT f g (Printor p) = Printor (fmap (dimap f g) . p) --- instance Tetradic Parsor where --- dimapT f g (Parsor p) = Parsor (fmap (fmap g) . p . f) -- instance Tetradic CtxPrintor where -- dimapT f g (CtxPrintor p) = CtxPrintor (fmap (second' (dimap f g)) . p) From be17fb15974e7097b4f41ac7ffa81a6ec83e0288 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 19 Oct 2025 09:24:05 -0700 Subject: [PATCH 008/282] Update Parsor.hs --- src/Data/Profunctor/Parsor.hs | 48 +++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/src/Data/Profunctor/Parsor.hs b/src/Data/Profunctor/Parsor.hs index 086172f..cbda8dd 100644 --- a/src/Data/Profunctor/Parsor.hs +++ b/src/Data/Profunctor/Parsor.hs @@ -17,11 +17,19 @@ module Data.Profunctor.Parsor import Control.Applicative import Control.Category +import Control.Lens +import Control.Lens.Internal.Equator +-- import Control.Lens.PartialIso import Control.Monad import Data.Bifunctor import Data.Coerce +import Data.List (stripPrefix) import Data.Profunctor +import Data.Profunctor.Distributor (Distributor (..), Alternator (..), Filtrator (..)) +import Data.Profunctor.Monadic +import Data.String import Prelude hiding ((.), id) +import Witherable newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} @@ -50,6 +58,46 @@ instance (Alternative m, Monad m) => Alternative (Parsor s s m a) where empty = Parsor (\_ -> empty) Parsor p <|> Parsor q = Parsor (\str -> p str <|> q str) instance (Alternative m, Monad m) => MonadPlus (Parsor s s m a) +instance (Alternative m, Monad m) => Choice (Parsor s s m) where + left' = alternate . Left + right' = alternate . Right +instance (Alternative m, Monad m) => Distributor (Parsor s s m) +instance (Alternative m, Monad m) => Alternator (Parsor s s m) 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 => Filterable (Parsor s t f a) where + mapMaybe f (Parsor p) = Parsor (mapMaybe (\(a,str) -> (,str) <$> f a) . p) +instance Filterable f => Cochoice (Parsor s t f) where + unleft = fst . filtrate + unright = snd . filtrate +instance Filterable f => Filtrator (Parsor s t 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 a a) + => Equator a a (Parsor s s f) where + equate = Parsor (\str -> maybe empty pure (uncons str)) +instance Alternative m => IsString (Parsor String String m () ()) where + fromString str = id $ + Parsor (maybe empty (pure . pure) . stripPrefix str) + +instance Monadic (Parsor s s) where + joinP (Parsor p) = Parsor $ \s -> do + (mb, s') <- p s + b <- mb + return (b, s') +instance Polyadic Parsor where + composeP (Parsor p) = Parsor $ \s -> do + (mb, s') <- p s + runParsor mb s' +instance Tetradic Parsor where + dimapT f g (Parsor p) = Parsor (fmap (fmap g) . p . f) newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} From 406fd3c33791150e73208e917075aed9d3b7cb42 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 19 Oct 2025 16:43:27 -0700 Subject: [PATCH 009/282] Update Parsor.hs --- src/Data/Profunctor/Parsor.hs | 62 +++++++++++++++++++++++++++-------- 1 file changed, 49 insertions(+), 13 deletions(-) diff --git a/src/Data/Profunctor/Parsor.hs b/src/Data/Profunctor/Parsor.hs index cbda8dd..b8d0cbc 100644 --- a/src/Data/Profunctor/Parsor.hs +++ b/src/Data/Profunctor/Parsor.hs @@ -3,9 +3,9 @@ module Data.Profunctor.Parsor Parsor (..) , Printor (..) , PP (..) --- , toParsor --- , toPrintor --- , pp + , pp + , pParsor + , pPrintor -- , Separator (..) -- , SepBy (..) -- , Stream1 (..) @@ -19,7 +19,7 @@ import Control.Applicative import Control.Category import Control.Lens import Control.Lens.Internal.Equator --- import Control.Lens.PartialIso +import Control.Lens.PartialIso import Control.Monad import Data.Bifunctor import Data.Coerce @@ -32,6 +32,22 @@ import Prelude hiding ((.), id) import Witherable newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} +newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} +newtype PP s t f a b = PP {runPP :: s -> f (t, a -> b)} + +pp + :: Applicative f + => Printor a b f s t + -> Parsor s t f a b + -> PP s t f a b +pp (Printor g) (Parsor f) = + PP (liftA2 (liftA2 (,)) (fmap snd . f) g) + +pParsor :: Functor f => PP s t f a b -> a -> Parsor s t f a b +pParsor (PP f) a = Parsor (fmap (\(t, g) -> (g a, t)) . f) + +pPrintor :: Functor f => PP s t f a b -> Printor a b f s t +pPrintor (PP f) = Printor (fmap snd . f) instance Functor f => Functor (Parsor s t f a) where fmap f = Parsor . (fmap (first' f) .) . runParsor @@ -83,10 +99,26 @@ instance Filterable f => Filtrator (Parsor s t f) where instance (Alternative f, Cons s s a a) => Equator a a (Parsor s s f) where equate = Parsor (\str -> maybe empty pure (uncons str)) -instance Alternative m => IsString (Parsor String String m () ()) where - fromString str = id $ + +instance + ( Alternative m + , AsEmpty s, Cons s s Char Char + , AsEmpty t, Cons t t Char Char + ) => IsString (Parsor s t m () ()) where + fromString str = dimapT (review listed) (view listed) $ Parsor (maybe empty (pure . pure) . stripPrefix str) +instance + ( Alternative m + , AsEmpty s, AsEmpty t + , Cons s s Char Char, Cons t t Char Char + ) => IsString (Parsor s t m s t) where + fromString s + = Parsor + $ maybe empty (\t -> pure (view listed s, view listed t)) + . stripPrefix s + . review listed + instance Monadic (Parsor s s) where joinP (Parsor p) = Parsor $ \s -> do (mb, s') <- p s @@ -99,10 +131,14 @@ instance Polyadic Parsor where instance Tetradic Parsor where dimapT f g (Parsor p) = Parsor (fmap (fmap g) . p . f) -newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} - -newtype PP s t f a b = PP {runPP :: a -> s -> f (b, s -> t)} - --- toParsor :: Functor f => PP a b f s t -> Parsor s t f a b -- s -> a -> f (t, s -> b) --- toPrintor :: Functor f => PP s t f a b -> Printor s t f a b --- pp :: Applicative f => Parsor s t f a b -> Printor s t f a b -> PP s t f a b +instance Functor f => Functor (Printor s t f a) where + fmap _ = coerce +instance Functor f => Contravariant (Printor s t f a) where + contramap _ = coerce +instance Functor f => Profunctor (Printor s t f) where + dimap f _ = Printor . (. f) . runPrintor + lmap f = Printor . (. f) . runPrintor + rmap _ = coerce +instance Tetradic Printor where + dimapT h i = Printor . (fmap (dimap h i) .) . runPrintor + tetramap h i f _ = Printor . (fmap (dimap h i) .) . (. f) . runPrintor From 02d488e68de117cbbfc0b28ad84c354cb971d2f2 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 22 Oct 2025 22:24:24 -0700 Subject: [PATCH 010/282] almost there --- distributors.cabal | 11 +- package.yaml | 2 + src/Control/Lens/Bifocal.hs | 40 +- src/Control/Lens/Diopter.hs | 7 +- src/Control/Lens/Grammar.hs | 130 ++++++- src/Control/Lens/Grammar/Char.hs | 10 - src/Control/Lens/Grate.hs | 7 +- src/Control/Lens/Internal/Equator.hs | 5 +- src/Control/Lens/Monocle.hs | 7 +- src/Control/Lens/RegEx.hs | 119 ++++++ src/Control/Lens/Stream.hs | 91 +++++ src/Control/Lens/Token.hs | 134 +++++++ src/Data/Profunctor/Distributor.hs | 254 +------------ src/Data/Profunctor/Monadic.hs | 33 +- src/Data/Profunctor/Parsor.hs | 144 -------- src/Data/Profunctor/Syntax.hs | 345 ++++++++++++++++++ src/Text/Grammar/Distributor.hs | 521 --------------------------- 17 files changed, 858 insertions(+), 1002 deletions(-) delete mode 100644 src/Control/Lens/Grammar/Char.hs create mode 100644 src/Control/Lens/RegEx.hs create mode 100644 src/Control/Lens/Stream.hs create mode 100644 src/Control/Lens/Token.hs delete mode 100644 src/Data/Profunctor/Parsor.hs create mode 100644 src/Data/Profunctor/Syntax.hs delete mode 100644 src/Text/Grammar/Distributor.hs diff --git a/distributors.cabal b/distributors.cabal index b5d4345..58996e4 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -31,18 +31,19 @@ library Control.Lens.Bifocal Control.Lens.Diopter Control.Lens.Grammar - Control.Lens.Grammar.Char Control.Lens.Grate Control.Lens.Internal.Equator Control.Lens.Internal.NestedPrismTH Control.Lens.Monocle Control.Lens.PartialIso + Control.Lens.RegEx + Control.Lens.Stream + Control.Lens.Token Control.Lens.Wither Data.Profunctor.Distributor Data.Profunctor.Monadic Data.Profunctor.Monadic.Do - Data.Profunctor.Parsor - Text.Grammar.Distributor + Data.Profunctor.Syntax other-modules: Paths_distributors autogen-modules: @@ -55,7 +56,9 @@ library ConstraintKinds DataKinds DefaultSignatures + DeriveFoldable DeriveFunctor + DeriveTraversable DeriveGeneric DerivingStrategies DerivingVia @@ -120,7 +123,9 @@ test-suite spec ConstraintKinds DataKinds DefaultSignatures + DeriveFoldable DeriveFunctor + DeriveTraversable DeriveGeneric DerivingStrategies DerivingVia diff --git a/package.yaml b/package.yaml index 73b0374..face8f9 100644 --- a/package.yaml +++ b/package.yaml @@ -57,7 +57,9 @@ default-extensions: - ConstraintKinds - DataKinds - DefaultSignatures +- DeriveFoldable - DeriveFunctor +- DeriveTraversable - DeriveGeneric - DerivingStrategies - DerivingVia diff --git a/src/Control/Lens/Bifocal.hs b/src/Control/Lens/Bifocal.hs index de62f16..35e6909 100644 --- a/src/Control/Lens/Bifocal.hs +++ b/src/Control/Lens/Bifocal.hs @@ -17,10 +17,8 @@ module Control.Lens.Bifocal , mapBifocal , cloneBifocal , withBifocal - , chainedl1 - , chainedr1 - , chainedl - , chainedr + , chained1 + , chained -- * Binocular , Binocular (..), runBinocular -- * Prismoid @@ -36,8 +34,10 @@ module Control.Lens.Bifocal import Control.Applicative import Control.Lens +import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso +import Control.Lens.Stream import Data.Profunctor import Data.Profunctor.Distributor import Witherable @@ -114,37 +114,23 @@ 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. +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 +chained1 :: (forall x. x -> Either x x) -> APartialIso a b (a,a) (b,b) -> Bifocal a b a b +chained1 assoc binPat = unwrapPafb . chain1 assoc binPat noSep . WrapPafb {- | -Right associate a binary constructor pattern to sequence one or more times, +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 +chained :: (forall x. x -> Either x x) -> APartialIso a b (a,a) (b,b) -> APartialIso a b () () -> Bifocal a b a b +chained assoc binPat nilPat = unwrapPafb . chain assoc binPat nilPat 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))) +withBifocal bif = unBinocular (catMaybes (bif (Just <$> equate))) {- | `Binocular` provides an efficient concrete representation of `Bifocal`s. -} @@ -153,8 +139,8 @@ newtype Binocular a b s t = Binocular :: 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 Equator a b (Binocular a b) where + equate = 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 diff --git a/src/Control/Lens/Diopter.hs b/src/Control/Lens/Diopter.hs index 266e2b5..e487c3c 100644 --- a/src/Control/Lens/Diopter.hs +++ b/src/Control/Lens/Diopter.hs @@ -25,6 +25,7 @@ module Control.Lens.Diopter ) where import Control.Lens +import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Data.Profunctor.Distributor import Data.Void @@ -55,7 +56,7 @@ 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 +withDiopter dio k = case runIdentity <$> dio (Identity <$> equate) of Dioptrice f g -> k f g {- | Action of `ADiopter` on `Distributor`s. -} @@ -94,8 +95,8 @@ data Dioptrice a b s t where => (s -> h a) -> (h b -> t) -> Dioptrice a b s t -instance Tokenized a b (Dioptrice a b) where - anyToken = Dioptrice Par1 unPar1 +instance Equator a b (Dioptrice a b) where + equate = 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 diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index b023bcd..612dbc8 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -1,18 +1,116 @@ module Control.Lens.Grammar - ( -- * Grammar --- RegGrammar --- , Grammar --- , CtxGrammar - -- * Invariant --- , RegEx --- , Gram --- , InvariantP - -- * Generator --- , genShow --- , genRead --- , genRegEx --- , genGram - -- * Combinator --- , NonTerminal (..) --- , Terminal (..) + ( -- * + RegGrammar + , Grammar + , CtxGrammar + , Gram (..) + , genRegEx + , genGram + , genShowS + , genReadS + , Grammatical (..) + , Regular + , Grammaticator + , Contextual + , NonTerminalSymbol (..) ) where + +import Control.Applicative +import Control.Lens.RegEx +import Control.Lens.Token +import Control.Lens.Stream +import Control.Monad +import Data.Function +import Data.Monoid +import Data.Profunctor +import Data.Profunctor.Distributor +import Data.Profunctor.Monadic +import Data.Profunctor.Syntax +import Data.Set (insert, Set) +import GHC.Exts +import Type.Reflection +import Witherable + +type RegGrammar c a = forall p. Regular c p => p a a +type Grammar c a = forall p. Grammaticator c p => p a a +type CtxGrammar s a = forall p m. Contextual s m p => p s s m a a + +data Gram c = Gram + { startGram :: (All, RegEx c) + , rulesGram :: Set (String, (All, RegEx c)) + } + +genGram + :: (Categorized c, Ord c, Ord (Categorize c)) + => Grammar c a + -> Gram c +genGram gram = case runInvariantP gram of (rules, start) -> Gram start rules + +genRegEx :: Categorized c => RegGrammar c a -> RegEx c +genRegEx = runInvariantP + +genShowS + :: (Filterable m, MonadPlus m) + => CtxGrammar String a -> a -> m ShowS +genShowS = runPrintor . toPrintor + +genReadS :: CtxGrammar String a -> ReadS a +genReadS = runParsor + +type Regular c p = + ( Terminator c p + , Tokenizor c p + , Alternator p + ) + +type Grammaticator c p = + ( Regular c p + , Filtrator p + , forall x. Grammatical (p x x) + ) + +type Contextual s m p = + ( IsStream s, Grammaticator (Item s) (p s s m) + , Alternative m, Filterable m, MonadPlus m + , Polyadic p, Tetradic m p + ) + +class Grammatical a where + rule :: String -> a -> a + rule _ = id + ruleRec :: String -> (a -> a) -> a + ruleRec _ = fix +instance Grammatical (Parsor s t m a b) +instance Grammatical (Printor s t m a b) +instance Grammatical (Lintor s t m a b) +instance (NonTerminalSymbol a, Ord a) + => Grammatical (Set (String, a), a) where + rule name = ruleRec name . const + ruleRec name f = + let + start = nonTerminal name + (oldRules, newRule) = f (mempty, start) + rules = insert (name, newRule) oldRules + in + (rules, start) +instance Grammatical p => Grammatical (InvariantP p a b) where + rule name = InvariantP . rule name . runInvariantP + ruleRec name + = InvariantP + . ruleRec name + . dimap InvariantP runInvariantP + +class NonTerminalSymbol a where + nonTerminal :: String -> a + default nonTerminal :: Typeable a => String -> a + nonTerminal q = error (thetype ??? rexrule ??? function) + where + x ??? y = x <> " ??? " <> y + thetype = show (typeRep @a) + rexrule = "\\q{" <> q <> "}" + function = "Control.Lens.Grammar.nonTerminal" +instance NonTerminalSymbol (RegEx c) where + nonTerminal = NonTerminal +instance (Monoid a, NonTerminalSymbol b) + => NonTerminalSymbol (a,b) where + nonTerminal = pure . nonTerminal diff --git a/src/Control/Lens/Grammar/Char.hs b/src/Control/Lens/Grammar/Char.hs deleted file mode 100644 index 1714e18..0000000 --- a/src/Control/Lens/Grammar/Char.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Control.Lens.Grammar.Char - ( -- * - -- CharReg - -- , CharGrammar - -- , CharCtx - -- , regexGrammar - -- , gramGrammar - -- , dataGrammar - -- , Char1 - ) where diff --git a/src/Control/Lens/Grate.hs b/src/Control/Lens/Grate.hs index 7c9266f..7a743a1 100644 --- a/src/Control/Lens/Grate.hs +++ b/src/Control/Lens/Grate.hs @@ -30,6 +30,7 @@ module Control.Lens.Grate , Grating (..) ) where +import Control.Lens.Internal.Equator import Data.Distributive import Data.Function import Data.Functor.Identity @@ -77,7 +78,7 @@ cloneGrate = grate . withGrate {- | Run `AGrate`. -} withGrate :: AGrate s t a b -> ((s -> a) -> b) -> t -withGrate grt = runGrating $ runIdentity <$> grt (Identity <$> anyToken) +withGrate grt = runGrating $ runIdentity <$> grt (Identity <$> equate) {- | Distribute over a `Closed` `Profunctor`. -} distributing @@ -108,8 +109,8 @@ 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 Equator a b (Grating a b) where + equate = Grating ($ id) instance Distributive (Grating a b s) where distribute = distributeRep collect = collectRep diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index ed4d371..e916cf2 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -7,6 +7,7 @@ import Control.Lens import Control.Lens.Internal.Iso import Control.Lens.Internal.Prism import Control.Lens.Internal.Profunctor +import Control.Lens.PartialIso class Equator a b p | p -> a, p -> b where equate :: p a b instance Equator a b (Identical a b) where equate = Identical @@ -14,8 +15,8 @@ instance Equator a b (Exchange a b) where equate = Exchange id id instance Equator a b (Market a b) where equate = Market id Right --- instance Equator a b (PartialExchange a b) where --- equate = PartialExchange Just Just +instance Equator a b (PartialExchange a b) where + equate = PartialExchange Just Just instance (Equator a b p, Profunctor p, Applicative f) => Equator a b (WrappedPafb f p) where equate = WrapPafb (rmap pure equate) diff --git a/src/Control/Lens/Monocle.hs b/src/Control/Lens/Monocle.hs index 211b7fd..2ca1ce1 100644 --- a/src/Control/Lens/Monocle.hs +++ b/src/Control/Lens/Monocle.hs @@ -27,6 +27,7 @@ module Control.Lens.Monocle ) where import Control.Lens hiding (Traversing) +import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Data.Distributive import Data.Profunctor.Distributor @@ -76,14 +77,14 @@ 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)) +withMonocle mon = unMonocular (runIdentity <$> mon (Identity <$> equate)) {- | `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 Equator a b (Monocular a b) where + equate = Monocular ($ id) instance Profunctor (Monocular a b) where dimap f g (Monocular k) = Monocular (fmap g . k . (. (. f))) diff --git a/src/Control/Lens/RegEx.hs b/src/Control/Lens/RegEx.hs new file mode 100644 index 0000000..6fa8c21 --- /dev/null +++ b/src/Control/Lens/RegEx.hs @@ -0,0 +1,119 @@ +module Control.Lens.RegEx + ( -- * + RegEx (..) + , TerminalSymbol (..) + , KleeneStarAlgebra (..) + , normRegEx + , Terminator + ) where + +import Control.Lens +import Control.Lens.PartialIso +import Control.Lens.Token +import Data.Profunctor +import Data.Profunctor.Distributor + +data RegEx c + = Terminal [c] + | Sequence (RegEx c) (RegEx c) + | Fail + | Alternate (RegEx c) (RegEx c) + | KleeneOpt (RegEx c) + | KleeneStar (RegEx c) + | KleenePlus (RegEx c) + | AnyToken + | InClass [c] + | NotInClass [c] + | InCategory (Categorize c) + | NotInCategory (Categorize c) + | NonTerminal String + +class TerminalSymbol s where + type Alphabet s + terminal :: [Alphabet s] -> s + default terminal :: (s ~ p () (), Monoidal p, Cochoice p, Tokenizor c p, c ~ Alphabet s) => [Alphabet s] -> s + terminal [] = oneP + terminal (a:as) = only a ?< anyToken *> terminal as + +class Monoid a => KleeneStarAlgebra a where + starK :: a -> a + plusK :: a -> a + optK :: a -> a + altK :: a -> a -> a + failK :: a + +normRegEx :: Categorized c => RegEx c -> RegEx c +normRegEx = \case + Sequence rex1 rex2 -> normRegEx rex1 <> normRegEx rex2 + Alternate rex1 rex2 -> normRegEx rex1 `altK` normRegEx rex2 + KleeneOpt rex -> optK (normRegEx rex) + KleeneStar rex -> starK (normRegEx rex) + KleenePlus rex -> plusK (normRegEx rex) + rex -> rex + +type Terminator c p = + ( TerminalSymbol (p () ()) + , Alphabet (p () ()) ~ c + ) + +deriving stock instance Categorized c => Eq (RegEx c) +deriving stock instance + (Categorized c, Ord c, Ord (Categorize c)) => Ord (RegEx c) +deriving stock instance + (Categorized c, Read c, Read (Categorize c)) => Read (RegEx c) +deriving stock instance + (Categorized c, Show c, Show (Categorize c)) => Show (RegEx c) +instance TerminalSymbol (RegEx c) where + type Alphabet (RegEx c) = c + terminal = Terminal +instance Monoid a => TerminalSymbol (a, RegEx c) where + type Alphabet (a, RegEx c) = c + terminal = pure . terminal +instance Categorized c => Tokenized (RegEx c) where + type Token (RegEx c) = c + anyToken = AnyToken + token c = Terminal [c] + inClass = InClass + notInClass = NotInClass + inCategory = InCategory + notInCategory = NotInCategory +instance Categorized c => Semigroup (RegEx c) where + Terminal [] <> rex = rex + rex <> Terminal [] = rex + Fail <> _ = failK + _ <> Fail = failK + Terminal str0 <> Terminal str1 = Terminal (str0 <> str1) + KleeneStar rex0 <> rex1 + | rex0 == rex1 = plusK rex0 + rex0 <> KleeneStar rex1 + | rex0 == rex1 = plusK rex1 + rex0 <> rex1 = Sequence rex0 rex1 +instance Categorized c => Monoid (RegEx c) where + mempty = Terminal [] +instance Categorized c => KleeneStarAlgebra (RegEx c) where + failK = Fail + optK Fail = mempty + optK (Terminal []) = mempty + optK (KleenePlus rex) = starK rex + optK rex = KleeneOpt rex + starK Fail = mempty + starK (Terminal []) = mempty + starK rex = KleeneStar rex + plusK Fail = failK + plusK (Terminal []) = mempty + plusK rex = KleenePlus rex + KleenePlus rex `altK` Terminal [] = starK rex + Terminal [] `altK` KleenePlus rex = starK rex + rex `altK` Terminal [] = optK rex + Terminal [] `altK` rex = optK rex + rex `altK` Fail = rex + Fail `altK` rex = rex + rex0 `altK` rex1 | rex0 == rex1 = rex0 + rex0 `altK` rex1 = Alternate rex0 rex1 +instance (Monoid a, KleeneStarAlgebra b) + => KleeneStarAlgebra (a,b) where + starK = fmap starK + plusK = fmap plusK + optK = fmap optK + failK = pure failK + altK = liftA2 altK diff --git a/src/Control/Lens/Stream.hs b/src/Control/Lens/Stream.hs new file mode 100644 index 0000000..7a80595 --- /dev/null +++ b/src/Control/Lens/Stream.hs @@ -0,0 +1,91 @@ +module Control.Lens.Stream + ( -- * + SepBy (..) + , sepBy + , noSep + , chain + , chain1 + , IsStream + , stream + , stream1 + ) where + +import Control.Applicative +import Control.Lens +import Control.Lens.PartialIso +import Data.Profunctor.Distributor +import GHC.Exts + +{- | Used to sequence multiple times, +separated by a `separateBy`, +begun by a `beginBy`, +and ended by an `endBy`. -} +data SepBy p = SepBy + { beginBy :: p + , endBy :: p + , separateBy :: p + } deriving stock + ( Functor, Foldable, Traversable + , Eq, Ord, Show, Read + ) + +{- | A `SepBy` smart constructor, +setting the `separateBy` field, +with no beginning or ending delimitors, +except by updating `beginBy` or `endBy` fields. -} +sepBy :: Monoidal p => p () () -> SepBy (p () ()) +sepBy = SepBy oneP oneP + +{- | A `SepBy` smart constructor for no separator, +beginning or ending delimiters. -} +noSep :: Monoidal p => SepBy (p () ()) +noSep = sepBy oneP + +chain + :: (Alternator p, Filtrator p) + => (forall x. x -> Either x x) -- `Left` or `Right` associate + -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern + -> APartialIso a b () () -- ^ nilary constructor pattern + -> SepBy (p () ()) -> p a b -> p a b +chain assoc c2 c0 sep p = + beginBy sep >* + (c0 >?< oneP <|> chain1 assoc c2 (sepBy (separateBy sep)) p) + *< endBy sep + +chain1 + :: (Alternator p, Filtrator p) + => (forall x. x -> Either x x) -- `Left` or `Right` associate + -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern + -> SepBy (p () ()) -> p a b -> p a b +chain1 = leftOrRight chainl1 chainr1 + where + leftOrRight a b f = case f () of Left _ -> a; Right _ -> b + chainl1 pat sep p = + coPartialIso (difoldl (coPartialIso pat)) >?< + beginBy sep >* p >*< manyP (separateBy sep >* p) *< endBy sep + chainr1 pat sep p = + coPartialIso (difoldr (coPartialIso pat)) >?< + beginBy sep >* manyP (p *< separateBy sep) >*< p *< endBy sep + +type IsStream s = (IsList s, AsEmpty s, Cons s s (Item s) (Item s)) + +{- | +prop> stream noSep = manyP +-} +stream + :: (Distributor p, IsStream s, IsStream t) + => SepBy (p () ()) + -> p (Item s) (Item t) -> p s t +stream (SepBy beg end sep) p = mapIso listEot $ + beg >* oneP >+< stream1 (sepBy sep) p *< end + +{- | +prop> stream1 noSep p = p >*< manyP p +prop> _Cons >? stream1 noSep p = someP p +-} +stream1 + :: (Distributor p, IsStream s, IsStream t) + => SepBy (p () ()) + -> p (Item s) (Item t) -> p (Item s, s) (Item t, t) +stream1 (SepBy beg end sep) p = + beg >* p >*< stream (sepBy sep) p *< end diff --git a/src/Control/Lens/Token.hs b/src/Control/Lens/Token.hs new file mode 100644 index 0000000..cf3c7e8 --- /dev/null +++ b/src/Control/Lens/Token.hs @@ -0,0 +1,134 @@ +module Control.Lens.Token + ( -- * + Categorized (..) + , Tokenized (..) + , satisfy + , tokens + , Tokenizor + ) where + +import Control.Lens +import Control.Lens.PartialIso +import Data.Char +import Data.Profunctor +import Data.Profunctor.Distributor +import Data.Word + +class (Eq a, Eq (Categorize a)) => Categorized a where + type Categorize a + type Categorize a = () + categorize :: a -> Categorize a + default categorize :: Categorize a ~ () => a -> Categorize a + categorize _ = () + decategorize :: Categorize a -> [a] + decategorize _ = [] +instance Categorized Char where + type Categorize Char = GeneralCategory + categorize = generalCategory + decategorize = \case + 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" +instance Categorized Word8 +instance Categorized () + +class Categorized (Token p) => Tokenized p where + type Token p + + anyToken :: p + + token :: Token p -> p + default token + :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) + => Token p -> p + token = satisfy . token + + inClass :: [Token p] -> p + default inClass + :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) + => [Token p] -> p + inClass = satisfy . inClass + + notInClass :: [Token p] -> p + default notInClass + :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) + => [Token p] -> p + notInClass = satisfy . notInClass + + inCategory :: Categorize (Token p) -> p + default inCategory + :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) + => Categorize (Token p) -> p + inCategory = satisfy . inCategory + + notInCategory :: Categorize (Token p) -> p + default notInCategory + :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) + => Categorize (Token p) -> p + notInCategory = satisfy . notInCategory + +instance Categorized c => Tokenized (c -> Bool) where + type Token (c -> Bool) = c + anyToken _ = True + token = (==) + inClass = flip elem + notInClass = flip notElem + inCategory = lmap categorize . (==) + notInCategory = lmap categorize . (/=) + +instance (Monoid a, Tokenized b) => Tokenized (a,b) where + type Token (a,b) = Token b + anyToken = pure anyToken + token = pure . token + inClass = pure . inClass + notInClass = pure . notInClass + inCategory = pure . inCategory + notInCategory = pure . notInCategory + +satisfy + :: ( Choice q, Cochoice q + , Tokenized p, p ~ q (Token p) (Token p) + ) + => (Token p -> Bool) -> p +satisfy f = satisfied f >?< anyToken + +type Tokenizor a p = (Tokenized (p a a), Token (p a a) ~ a) + +tokens + :: ( AsEmpty s + , Cons s s a a + , Monoidal p + , Choice p + , Tokenizor a p + ) + => [a] + -> p s s +tokens [] = asEmpty +tokens (a:as) = token a >:< tokens as diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index f6abdc3..a5eff88 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -12,17 +12,12 @@ Portability : non-portable module Data.Profunctor.Distributor ( -- * Monoidal - Monoidal, oneP, (>*<), (>*), (*<), dimap2, foreverP, replicateP, meander, (>:<) + Monoidal, oneP, (>*<), (>*), (*<), dimap2, foreverP, replicateP + , meander, (>:<), asEmpty -- * Distributor - , Distributor (zeroP, (>+<), optionalP, manyP), dialt, Homogeneous (homogeneously) + , Distributor (..), 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 (..) + , Alternator (..), Filtrator (filtrate) ) where import Control.Applicative hiding (WrappedArrow) @@ -30,8 +25,6 @@ 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 @@ -54,7 +47,6 @@ 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) @@ -159,8 +151,12 @@ meander f = dimap (f sell) iextract . trav => 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 +{- | A `Monoidal` nil operator. -} +asEmpty :: (AsEmpty s, Monoidal p, Choice p) => p s s +asEmpty = _Empty >? oneP + +{- | A `Monoidal` cons operator. -} +(>:<) :: (Cons s t a b, Monoidal p, Choice p) => p a b -> p s t -> p s t x >:< xs = _Cons >? x >*< xs infixr 5 >:< @@ -533,235 +529,6 @@ instance Filtrator (PartialExchange a b) where , 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 `SepBy` smart constructor, -setting the `separateBy` field, -with no beginning or ending delimitors, -except by updating `beginBy` or `endBy` fields. -} -sepBy :: Monoidal p => p () () -> SepBy p -sepBy = SepBy oneP oneP - -{- | A `SepBy` smart constructor for no separator, -beginning or ending delimiters. -} -noSep :: Monoidal p => SepBy p -noSep = sepBy oneP - -{- | -prop> zeroOrMore 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 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 -instance (Tokenized a b p, Profunctor p, Applicative f) - => Tokenized a b (WrappedPafb f p) where - anyToken = WrapPafb (rmap pure anyToken) - -{- | 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 t a b, s ~ t, a ~ b) - => Tokenized a b (Printor s f) where - anyToken = Printor (pure . cons) -instance (Applicative f, Cons s s Char Char, a ~ (), b ~ ()) - => IsString (Printor s f a b) 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 Monad f => Monad (Parsor s f a) where - Parsor p >>= f = Parsor $ \s -> do - (a, s') <- p s - runParsor (f a) s' -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 (Alternative f, Monad f) => MonadPlus (Parsor s f a) -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) -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 t a b, s ~ t, a ~ b) - => Tokenized a b (Parsor s f) where - anyToken = Parsor (\str -> maybe empty pure (uncons str)) -instance (Alternative f, Filterable f, Monad f, Cons s s Char Char, a ~ (), b ~ ()) - => IsString (Parsor s f a b) where - fromString = tokens - -- FunList -- {- | @@ -853,7 +620,6 @@ 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 diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 944ae97..8883f58 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -17,6 +17,7 @@ module Data.Profunctor.Monadic , WrappedMonadic (..) , WrappedPolyadic (..) , TaggedP (..) + -- , TaggedCtx (..) , UntaggedT (..) , UntaggedC (..) ) where @@ -39,12 +40,6 @@ class liftP :: Monad m => m b -> p m a b liftP = joinP . return --- instance Monadic (CtxPrintor s s) where --- joinP (CtxPrintor p) = CtxPrintor $ \a -> do --- (mb, q) <- p a --- b <- mb --- return (b, q) - class ( forall i j. i ~ j => Monadic (p i j) , forall i j m. Monad m => Profunctor (p i j m) @@ -52,33 +47,19 @@ class ) => Polyadic p where composeP :: Monad m => p i j m a (p j k m a b) -> p i k m a b --- instance Polyadic CtxPrintor where --- composeP (CtxPrintor p) = CtxPrintor $ \ctx -> do --- (CtxPrintor p', ij) <- p ctx --- (b, jk) <- p' ctx --- return (b, jk . ij) - -class (forall f i j. Functor f => Profunctor (p i j f)) - => Tetradic p where +class (forall i j. Profunctor (p i j f)) => Tetradic f p where tetramap - :: Functor f - => (h -> i) -> (j -> k) + :: (h -> i) -> (j -> k) -> (s -> a) -> (b -> t) -> p i j f a b -> p h k f s t tetramap f1 f2 f3 f4 = dimapT f1 f2 . dimap f3 f4 dimapT - :: Functor f - => (h -> i) -> (j -> k) + :: (h -> i) -> (j -> k) -> p i j f a b -> p h k f a b dimapT f1 f2 = tetramap f1 f2 id id --- instance Tetradic Printor where --- dimapT f g (Printor p) = Printor (fmap (dimap f g) . p) --- instance Tetradic CtxPrintor where --- dimapT f g (CtxPrintor p) = CtxPrintor (fmap (second' (dimap f g)) . p) - newtype WrappedMonadic p m a b = WrapMonadic {unwrapMonadic :: p m a (m b)} instance (Monadic p, Monad m) => Functor (WrappedMonadic p m a) where fmap = rmap @@ -133,11 +114,11 @@ instance Polyadic p => IxMonadTrans (UntaggedT p a) where joinIx = UntagT . composeP . fmap tagT . tagT newtype UntaggedC p a b f i j = UntagC {tagC :: p i j f a b} -instance Tetradic p => Tetradic (UntaggedC p) where +instance (Tetradic f p, Functor f) => Tetradic f (UntaggedC p) where tetramap f1 f2 f3 f4 = UntagC . tetramap f3 f4 f1 f2 . tagC -instance (Tetradic p, Functor f) => Profunctor (UntaggedC p a b f) where +instance (Tetradic f p, Functor f) => Profunctor (UntaggedC p a b f) where dimap f g = UntagC . dimapT f g . tagC -instance (Tetradic p, Functor f) => Functor (UntaggedC p a b f i) where +instance (Tetradic f p, Functor f) => Functor (UntaggedC p a b f i) where fmap = rmap instance (Polyadic p, Monad m, Monoid b) => Category (UntaggedC p a b m) where id = UntagC (pure mempty) diff --git a/src/Data/Profunctor/Parsor.hs b/src/Data/Profunctor/Parsor.hs deleted file mode 100644 index b8d0cbc..0000000 --- a/src/Data/Profunctor/Parsor.hs +++ /dev/null @@ -1,144 +0,0 @@ -module Data.Profunctor.Parsor - ( -- * - Parsor (..) - , Printor (..) - , PP (..) - , pp - , pParsor - , pPrintor --- , Separator (..) --- , SepBy (..) --- , Stream1 (..) --- , Stream (..) --- , Tokenized (..) --- , satisfy --- , Categorized (..) - ) where - -import Control.Applicative -import Control.Category -import Control.Lens -import Control.Lens.Internal.Equator -import Control.Lens.PartialIso -import Control.Monad -import Data.Bifunctor -import Data.Coerce -import Data.List (stripPrefix) -import Data.Profunctor -import Data.Profunctor.Distributor (Distributor (..), Alternator (..), Filtrator (..)) -import Data.Profunctor.Monadic -import Data.String -import Prelude hiding ((.), id) -import Witherable - -newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} -newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} -newtype PP s t f a b = PP {runPP :: s -> f (t, a -> b)} - -pp - :: Applicative f - => Printor a b f s t - -> Parsor s t f a b - -> PP s t f a b -pp (Printor g) (Parsor f) = - PP (liftA2 (liftA2 (,)) (fmap snd . f) g) - -pParsor :: Functor f => PP s t f a b -> a -> Parsor s t f a b -pParsor (PP f) a = Parsor (fmap (\(t, g) -> (g a, t)) . f) - -pPrintor :: Functor f => PP s t f a b -> Printor a b f s t -pPrintor (PP f) = Printor (fmap snd . f) - -instance Functor f => Functor (Parsor s t f a) where - fmap f = Parsor . (fmap (first' f) .) . runParsor -instance Functor f => Bifunctor (Parsor s t f) where - bimap _ = (>>>) coerce . fmap - first _ = coerce - second = fmap -instance Functor f => Profunctor (Parsor s t f) where - dimap _ = (<<<) coerce . fmap - lmap _ = coerce - rmap = fmap - -instance Monad m => Applicative (Parsor s s m a) where - pure b = Parsor (\s -> return (b,s)) - Parsor x <*> Parsor y = Parsor $ \s -> do - (f, t) <- x s - (a, u) <- y t - return (f a, u) -instance Monad m => Monad (Parsor s s m a) where - Parsor p >>= f = Parsor $ \s -> do - (a, t) <- p s - runParsor (f a) t -instance (Alternative m, Monad m) => Alternative (Parsor s s m a) where - empty = Parsor (\_ -> empty) - Parsor p <|> Parsor q = Parsor (\str -> p str <|> q str) -instance (Alternative m, Monad m) => MonadPlus (Parsor s s m a) -instance (Alternative m, Monad m) => Choice (Parsor s s m) where - left' = alternate . Left - right' = alternate . Right -instance (Alternative m, Monad m) => Distributor (Parsor s s m) -instance (Alternative m, Monad m) => Alternator (Parsor s s m) 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 => Filterable (Parsor s t f a) where - mapMaybe f (Parsor p) = Parsor (mapMaybe (\(a,str) -> (,str) <$> f a) . p) -instance Filterable f => Cochoice (Parsor s t f) where - unleft = fst . filtrate - unright = snd . filtrate -instance Filterable f => Filtrator (Parsor s t 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 a a) - => Equator a a (Parsor s s f) where - equate = Parsor (\str -> maybe empty pure (uncons str)) - -instance - ( Alternative m - , AsEmpty s, Cons s s Char Char - , AsEmpty t, Cons t t Char Char - ) => IsString (Parsor s t m () ()) where - fromString str = dimapT (review listed) (view listed) $ - Parsor (maybe empty (pure . pure) . stripPrefix str) - -instance - ( Alternative m - , AsEmpty s, AsEmpty t - , Cons s s Char Char, Cons t t Char Char - ) => IsString (Parsor s t m s t) where - fromString s - = Parsor - $ maybe empty (\t -> pure (view listed s, view listed t)) - . stripPrefix s - . review listed - -instance Monadic (Parsor s s) where - joinP (Parsor p) = Parsor $ \s -> do - (mb, s') <- p s - b <- mb - return (b, s') -instance Polyadic Parsor where - composeP (Parsor p) = Parsor $ \s -> do - (mb, s') <- p s - runParsor mb s' -instance Tetradic Parsor where - dimapT f g (Parsor p) = Parsor (fmap (fmap g) . p . f) - -instance Functor f => Functor (Printor s t f a) where - fmap _ = coerce -instance Functor f => Contravariant (Printor s t f a) where - contramap _ = coerce -instance Functor f => Profunctor (Printor s t f) where - dimap f _ = Printor . (. f) . runPrintor - lmap f = Printor . (. f) . runPrintor - rmap _ = coerce -instance Tetradic Printor where - dimapT h i = Printor . (fmap (dimap h i) .) . runPrintor - tetramap h i f _ = Printor . (fmap (dimap h i) .) . (. f) . runPrintor diff --git a/src/Data/Profunctor/Syntax.hs b/src/Data/Profunctor/Syntax.hs new file mode 100644 index 0000000..78c8a4b --- /dev/null +++ b/src/Data/Profunctor/Syntax.hs @@ -0,0 +1,345 @@ +module Data.Profunctor.Syntax + ( InvariantP (..) + , Parsor (..) + , Printor (..) + , Lintor (..) + , toPrintor + , fromPrintor + , Stream + ) where + +import Control.Applicative +import Control.Arrow +import Control.Category +import Control.Lens +import Control.Lens.Internal.Equator +import Control.Lens.RegEx +import Control.Lens.Stream +import Control.Lens.Token +import Control.Monad +import Data.Bifunctor +import Data.Coerce +import Data.Monoid +import Data.Profunctor +import Data.Profunctor.Distributor +import Data.Profunctor.Monadic +import Data.Void +import Prelude hiding (id, (.)) +import GHC.Exts +import Witherable + +newtype InvariantP r a b = InvariantP {runInvariantP :: r} +newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} +newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} +newtype Lintor s t f a b = Lintor {runLintor :: a -> f (b, s -> t)} + +toPrintor :: Functor f => Lintor s t f a b -> Printor s t f a b +toPrintor (Lintor f) = Printor (fmap snd . f) + +fromPrintor :: Functor f => Printor s t f a a -> Lintor s t f a a +fromPrintor (Printor f) = Lintor (\a -> fmap (a,) (f a)) + +type Stream s a = (IsStream s, Item s ~ a, Categorized a) + +instance Functor (InvariantP r a) where fmap _ = coerce +instance Contravariant (InvariantP r a) where contramap _ = coerce +instance Profunctor (InvariantP r) where dimap _ _ = coerce +instance Bifunctor (InvariantP r) where bimap _ _ = coerce +instance Choice (InvariantP r) where + left' = coerce + right' = coerce +subsetOf + :: InvariantP (rules, (All, start)) a b + -> InvariantP (rules, (All, start)) s t +subsetOf (InvariantP (rules, (_, start))) = + InvariantP (rules, ((All False), start)) +instance Filterable (InvariantP (rules, (All, start)) x) where + mapMaybe _ = subsetOf +instance Cochoice (InvariantP (rules, (All, start))) where + unleft = subsetOf +instance Filtrator (InvariantP (rules, (All, start))) where + filtrate p = (subsetOf p, subsetOf p) +instance KleeneStarAlgebra r => Applicative (InvariantP r a) where + pure _ = InvariantP mempty + InvariantP rex1 <*> InvariantP rex2 = + InvariantP (rex1 <> rex2) +instance KleeneStarAlgebra r => Alternative (InvariantP r a) where + empty = InvariantP failK + InvariantP rex1 <|> InvariantP rex2 = + InvariantP (rex1 `altK` rex2) + many (InvariantP rex) = InvariantP (starK rex) + some (InvariantP rex) = InvariantP (plusK rex) +instance KleeneStarAlgebra r => Distributor (InvariantP r) where + zeroP = InvariantP failK + InvariantP rex1 >+< InvariantP rex2 = + InvariantP (rex1 `altK` rex2) + manyP (InvariantP rex) = InvariantP (starK rex) + optionalP (InvariantP rex) = InvariantP (optK rex) +instance KleeneStarAlgebra r => Alternator (InvariantP r) where + alternate = either coerce coerce + someP (InvariantP rex) = InvariantP (plusK rex) +instance (Tokenized r, Categorized c, Token r ~ c) + => Tokenized (InvariantP r c c) where + type Token (InvariantP r c c) = Token r + anyToken = InvariantP anyToken + token = InvariantP . token + inClass = InvariantP . inClass + notInClass = InvariantP . notInClass + inCategory = InvariantP . inCategory + notInCategory = InvariantP . notInCategory +instance TerminalSymbol (InvariantP (RegEx c) () ()) where + type Alphabet (InvariantP (RegEx c) () ()) = c + terminal = InvariantP . terminal +instance + ( Monoid a + , TerminalSymbol b + ) => TerminalSymbol (InvariantP (a,b) () ()) where + type Alphabet (InvariantP (a,b) () ()) = Alphabet b + terminal = InvariantP . pure . terminal + +instance Functor f => Functor (Parsor s t f a) where + fmap f = Parsor . fmap (fmap (first' f)) . runParsor +instance Functor f => Bifunctor (Parsor s t f) where + bimap _ = lmap coerce . fmap + first _ = coerce + second = fmap +instance Functor f => Profunctor (Parsor s t f) where + dimap _ = rmap coerce . fmap + lmap _ = coerce + rmap = fmap +instance Functor f => Tetradic f Parsor where + dimapT f g (Parsor p) = Parsor (fmap (fmap g) . p . f) + tetramap f g _ i (Parsor p) = Parsor (fmap (i >*< g) . p . f) + +instance Monad m => Applicative (Parsor s s m a) where + pure b = Parsor (\s -> return (b,s)) + Parsor x <*> Parsor y = Parsor $ \s -> do + (f, t) <- x s + (a, u) <- y t + return (f a, u) +instance Monad m => Monad (Parsor s s m a) where + Parsor p >>= f = Parsor $ \s -> do + (a, t) <- p s + runParsor (f a) t +instance (Alternative m, Monad m) => Alternative (Parsor s s m a) where + empty = Parsor (\_ -> empty) + Parsor p <|> Parsor q = Parsor (\str -> p str <|> q str) +instance (Alternative m, Monad m) => MonadPlus (Parsor s s m a) +instance (Alternative m, Monad m) => Choice (Parsor s s m) where + left' = alternate . Left + right' = alternate . Right +instance (Alternative m, Monad m) => Distributor (Parsor s s m) +instance (Alternative m, Monad m) => Alternator (Parsor s s m) 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 Monadic (Parsor s s) where + joinP (Parsor p) = Parsor $ \s -> do + (mb, s') <- p s + b <- mb + return (b, s') +instance Polyadic Parsor where + composeP (Parsor p) = Parsor $ \s -> do + (mb, s') <- p s + runParsor mb s' + +instance Filterable f => Filterable (Parsor s t f a) where + mapMaybe f (Parsor p) = Parsor (mapMaybe (\(a,str) -> (,str) <$> f a) . p) +instance Filterable f => Cochoice (Parsor s t f) where + unleft = fst . filtrate + unright = snd . filtrate +instance Filterable f => Filtrator (Parsor s t 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 + ( Stream s a + , Alternative m, Filterable m, Monad m + ) => Tokenized (Parsor s s m a a) where + type Token (Parsor s s m a a) = a + anyToken = Parsor (\str -> maybe empty pure (uncons str)) +instance + ( Stream s a + , Alternative m, Filterable m, Monad m + ) => Equator a a (Parsor s s m) where + equate = anyToken +instance + ( Stream s a + , Alternative m, Filterable m, Monad m + ) => TerminalSymbol (Parsor s s m () ()) where + type Alphabet (Parsor s s m () ()) = Item s +instance + ( Stream s Char + , Alternative m, Filterable m, Monad m + ) => IsString (Parsor s s m () ()) where + fromString = terminal +instance + ( Stream s Char + , Alternative m, Filterable m, Monad m + ) => IsString (Parsor s s m s s) where + fromString = tokens + +instance Functor (Printor s t f a) where + fmap _ = coerce +instance Contravariant (Printor s t f a) where + contramap _ = coerce +instance Profunctor (Printor s t f) where + dimap f _ = Printor . lmap f . runPrintor + lmap f = Printor . lmap f . runPrintor + rmap _ = coerce +instance Functor f => Tetradic f Printor where + dimapT h i = Printor . (fmap (fmap (dimap h i))) . runPrintor + tetramap h i f _ = Printor . dimap f (fmap (dimap h i)) . runPrintor + +instance Filterable (Printor s t f a) where + mapMaybe _ (Printor p) = Printor p +instance Cochoice (Printor s t f) where + unleft = fst . filtrate + unright = snd . filtrate +instance Filtrator (Printor s t f) where + filtrate (Printor p) = (Printor (p . Left), Printor (p . Right)) + +instance Applicative f => Applicative (Printor s s f a) where + pure _ = Printor (\_ -> pure id) + Printor p <*> Printor q = Printor (\a -> (.) <$> p a <*> q a) +instance Alternative f => Alternative (Printor s s f a) where + empty = Printor (\_ -> empty) + Printor p <|> Printor q = Printor (\a -> p a <|> q a) +instance Alternative f => Choice (Printor s s f) where + left' = alternate . Left + right' = alternate . Right +instance Applicative f => Distributor (Printor s s f) where + zeroP = Printor absurd + Printor p >+< Printor q = Printor (either p q) +instance Alternative f => Alternator (Printor s s f) where + alternate = \case + Left (Printor p) -> Printor (either p (\_ -> empty)) + Right (Printor p) -> Printor (either (\_ -> empty) p) + +instance + ( Stream s a + , Alternative m, Filterable m, Monad m + ) => Tokenized (Printor s s m a a) where + type Token (Printor s s m a a) = a + anyToken = Printor (pure . cons) +instance + ( Stream s a + , Alternative m, Filterable m, Monad m + ) => Equator a a (Printor s s m) where + equate = anyToken +instance + ( Stream s a + , Alternative m, Filterable m, Monad m + ) => TerminalSymbol (Printor s s m () ()) where + type Alphabet (Printor s s m () ()) = Item s +instance + ( Stream s Char + , Alternative m, Filterable m, Monad m + ) => IsString (Printor s s m () ()) where + fromString = terminal +instance + ( Stream s Char + , Alternative m, Filterable m, Monad m + ) => IsString (Printor s s m s s) where + fromString = tokens + +instance Functor f => Functor (Lintor s t f a) where + fmap f = Lintor . fmap (fmap (first' f)) . runLintor +instance Functor f => Profunctor (Lintor s t f) where + dimap f g = Lintor . dimap f (fmap (first' g)) . runLintor +instance Functor f => Tetradic f Lintor where + dimapT f g = Lintor . rmap (fmap (second' (dimap f g))) . runLintor + tetramap f g h i = Lintor . dimap h (fmap (i >*< dimap f g)) . runLintor +instance Applicative f => Applicative (Lintor s s f a) where + pure b = Lintor (\_ -> pure (b, id)) + Lintor f <*> Lintor x = Lintor $ \c -> + liftA2 (\(g, p) (a, q) -> (g a, p . q)) (f c) (x c) +instance Alternative f => Alternative (Lintor s s f a) where + empty = Lintor (\_ -> empty) + Lintor p <|> Lintor q = Lintor (\a -> p a <|> q a) +instance Filterable f => Filterable (Lintor s s f a) where + mapMaybe f (Lintor p) = Lintor $ + mapMaybe (\(a,q) -> fmap (, q) (f a)) . p +instance Monad f => Monad (Lintor s s f a) where + return = pure + mx >>= f = Lintor $ \ctx -> do + (x, p) <- runLintor mx ctx + (y, q) <- runLintor (f x) ctx + return (y, p . q) +instance (Alternative f, Monad f) => MonadPlus (Lintor s s f a) +instance Monadic (Lintor s s) where + joinP (Lintor mf) = Lintor $ \a -> do + (mb, f) <- mf a + b <- mb + return (b, f) +instance Polyadic Lintor where + composeP (Lintor mf) = Lintor $ \a -> do + (Lintor mg, f) <- mf a + (b, g) <- mg a + return (b, g . f) +instance Applicative f => Distributor (Lintor s s f) where + zeroP = Lintor absurd + Lintor p >+< Lintor q = Lintor $ + either (fmap (first' Left) . p) (fmap (first' Right) . q) +instance Alternative f => Alternator (Lintor s s f) where + alternate = \case + Left (Lintor p) -> Lintor $ + either (fmap (first' Left) . p) (\_ -> empty) + Right (Lintor p) -> Lintor $ + either (\_ -> empty) (fmap (first' Right) . p) +instance Filterable f => Filtrator (Lintor s s f) where + filtrate (Lintor p) = + ( Lintor (mapMaybe (\case{(Left b, q) -> Just (b, q); _ -> Nothing}) . p . Left) + , Lintor (mapMaybe (\case{(Right b, q) -> Just (b, q); _ -> Nothing}) . p . Right) + ) +instance Alternative f => Choice (Lintor s s f) where + left' = alternate . Left + right' = alternate . Right +instance Filterable f => Cochoice (Lintor s s f) where + unleft = fst . filtrate + unright = snd . filtrate +instance Functor f => Strong (Lintor s s f) where + first' (Lintor p) = Lintor (\(a,c) -> fmap (\(b,q) -> ((b,c),q)) (p a)) + second' (Lintor p) = Lintor (\(c,a) -> fmap (\(b,q) -> ((c,b),q)) (p a)) +instance Monad f => Category (Lintor s s f) where + id = Lintor $ \a -> return (a, id) + Lintor q . Lintor p = Lintor $ \a -> do + (b, p') <- p a + (c, q') <- q b + return (c, q' . p') +instance Monad f => Arrow (Lintor s s f) where + arr f = Lintor (return . (, id) . f) + (***) = (>*<) + first = first' + second = second' + +instance + ( Stream s a + , Alternative m, Filterable m, Monad m + ) => Tokenized (Lintor s s m a a) where + type Token (Lintor s s m a a) = a + anyToken = Lintor (\b -> pure (b, cons b)) +instance + ( Stream s a + , Alternative m, Filterable m, Monad m + ) => Equator a a (Lintor s s m) where + equate = anyToken +instance + ( Stream s a + , Alternative m, Filterable m, Monad m + ) => TerminalSymbol (Lintor s s m () ()) where + type Alphabet (Lintor s s m () ()) = Item s +instance + ( Stream s Char + , Alternative m, Filterable m, Monad m + ) => IsString (Lintor s s m () ()) where + fromString = terminal +instance + ( Stream s Char + , Alternative m, Filterable m, Monad m + ) => IsString (Lintor s s m s s) where + fromString = tokens diff --git a/src/Text/Grammar/Distributor.hs b/src/Text/Grammar/Distributor.hs deleted file mode 100644 index e5a5222..0000000 --- a/src/Text/Grammar/Distributor.hs +++ /dev/null @@ -1,521 +0,0 @@ -{-| -Module : Text.Grammar.Distributor -Description : grammars -Copyright : (C) 2025 - Eitan Chatav -License : BSD-style (see the file LICENSE) -Maintainer : Eitan Chatav -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 (..) - -- * Generators - , genReadS - , readGrammar - , genShowS - , showGrammar - , genRegEx - , genGrammar - , printGrammar - -- * RegEx - , RegEx (..) - , regexNorm - , regexParse - , regexString - , regexGrammar - ) 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, with combinators: - -* 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 - -{- | 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 - , 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 a -> p a a - rule _ = id - - {- | A recursive, nonterminal rule. -} - ruleRec :: String -> (p a a -> p a a) -> p a a - 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) -makeNestedPrisms ''RegEx -makeNestedPrisms ''GeneralCategory - -(-*-), (|||) :: 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 - -{- | 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 - 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` parser 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` printers 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 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 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 `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 From 453caaff4678d070c92d3b69227ebfdd207a2d3a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 23 Oct 2025 14:33:25 -0700 Subject: [PATCH 011/282] stream & token stuff --- src/Control/Lens/PartialIso.hs | 24 ------------ src/Control/Lens/RegEx.hs | 6 ++- src/Control/Lens/Stream.hs | 71 ++++++++++++++++++++-------------- src/Control/Lens/Token.hs | 44 ++++++++++++++++++++- 4 files changed, 91 insertions(+), 54 deletions(-) diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index 8411e17..5a78fdb 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -37,8 +37,6 @@ module Control.Lens.PartialIso , satisfied , nulled , notNulled - , streamed - , listed , maybeEot , listEot -- * Iterations @@ -250,28 +248,6 @@ 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 thither thither - -{- | `listed` is an isomorphism between -a stream type and a list. -} -listed :: (AsEmpty s, Cons s s c c) => Iso' [c] s -listed = iso hither thither - where - hither [] = Empty - hither (h:t) = cons h (hither t) - -thither :: (Cons s s c c, AsEmpty t, Cons t t c c) => s -> t -thither s = - maybe - Empty - (\(h,t) -> cons h (thither t)) - (uncons s) - {- | The either-of-tuples representation of `Maybe`. -} maybeEot :: Iso (Maybe a) (Maybe b) (Either () a) (Either () b) maybeEot = iso diff --git a/src/Control/Lens/RegEx.hs b/src/Control/Lens/RegEx.hs index 6fa8c21..bc9d4bd 100644 --- a/src/Control/Lens/RegEx.hs +++ b/src/Control/Lens/RegEx.hs @@ -31,7 +31,11 @@ data RegEx c class TerminalSymbol s where type Alphabet s terminal :: [Alphabet s] -> s - default terminal :: (s ~ p () (), Monoidal p, Cochoice p, Tokenizor c p, c ~ Alphabet s) => [Alphabet s] -> s + default terminal + :: ( Monoidal p, Cochoice p, Tokenizor c p + , Alphabet s ~ c, p () () ~ s + ) + => [Alphabet s] -> s terminal [] = oneP terminal (a:as) = only a ?< anyToken *> terminal as diff --git a/src/Control/Lens/Stream.hs b/src/Control/Lens/Stream.hs index 7a80595..1f3b8ef 100644 --- a/src/Control/Lens/Stream.hs +++ b/src/Control/Lens/Stream.hs @@ -1,21 +1,59 @@ module Control.Lens.Stream ( -- * - SepBy (..) + IsStream + , listed + , streamed + , stream + , stream1 + , SepBy (..) , sepBy , noSep , chain , chain1 - , IsStream - , stream - , stream1 ) where import Control.Applicative import Control.Lens import Control.Lens.PartialIso +import Data.Profunctor import Data.Profunctor.Distributor import GHC.Exts +type IsStream s = (IsList s, AsEmpty s, Cons s s (Item s) (Item s)) + +listed :: (IsList s, IsList t, Item s ~ Item t) => Iso' s t +listed = iso (fromList . toList) (fromList . toList) + +streamed :: (IsStream s, IsStream t, Item s ~ Item t) => Iso' s t +streamed = iso convertStream convertStream + where + convertStream s = + maybe + Empty + (\(h,t) -> cons h (convertStream t)) + (uncons s) + +{- | +prop> stream noSep = manyP +-} +stream + :: (Distributor p, IsStream s, IsStream t) + => SepBy (p () ()) + -> p (Item s) (Item t) -> p s t +stream (SepBy beg end sep) p = mapIso listEot $ + beg >* oneP >+< stream1 (sepBy sep) p *< end + +{- | +prop> stream1 noSep p = p >*< manyP p +prop> _Cons >? stream1 noSep p = someP p +-} +stream1 + :: (Distributor p, IsStream s, IsStream t) + => SepBy (p () ()) + -> p (Item s) (Item t) -> p (Item s, s) (Item t, t) +stream1 (SepBy beg end sep) p = + beg >* p >*< stream (sepBy sep) p *< end + {- | Used to sequence multiple times, separated by a `separateBy`, begun by a `beginBy`, @@ -53,7 +91,7 @@ chain assoc c2 c0 sep p = *< endBy sep chain1 - :: (Alternator p, Filtrator p) + :: (Distributor p, Choice p, Cochoice p) => (forall x. x -> Either x x) -- `Left` or `Right` associate -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern -> SepBy (p () ()) -> p a b -> p a b @@ -66,26 +104,3 @@ chain1 = leftOrRight chainl1 chainr1 chainr1 pat sep p = coPartialIso (difoldr (coPartialIso pat)) >?< beginBy sep >* manyP (p *< separateBy sep) >*< p *< endBy sep - -type IsStream s = (IsList s, AsEmpty s, Cons s s (Item s) (Item s)) - -{- | -prop> stream noSep = manyP --} -stream - :: (Distributor p, IsStream s, IsStream t) - => SepBy (p () ()) - -> p (Item s) (Item t) -> p s t -stream (SepBy beg end sep) p = mapIso listEot $ - beg >* oneP >+< stream1 (sepBy sep) p *< end - -{- | -prop> stream1 noSep p = p >*< manyP p -prop> _Cons >? stream1 noSep p = someP p --} -stream1 - :: (Distributor p, IsStream s, IsStream t) - => SepBy (p () ()) - -> p (Item s) (Item t) -> p (Item s, s) (Item t, t) -stream1 (SepBy beg end sep) p = - beg >* p >*< stream (sepBy sep) p *< end diff --git a/src/Control/Lens/Token.hs b/src/Control/Lens/Token.hs index cf3c7e8..6cd29bb 100644 --- a/src/Control/Lens/Token.hs +++ b/src/Control/Lens/Token.hs @@ -1,10 +1,17 @@ module Control.Lens.Token - ( -- * + ( -- * Token Categorized (..) , Tokenized (..) , satisfy , tokens , Tokenizor + -- * Like + , oneLike + , anyLike + , optLike + , reqLike + -- * Unicode + , GeneralCategory (..) ) where import Control.Lens @@ -132,3 +139,38 @@ tokens -> p s s tokens [] = asEmpty tokens (a:as) = token a >:< tokens as + +{- | +`oneLike` consumes one token +of a given token's category while parsing, +and produces the given token while printing. +-} +oneLike :: forall c p. (Profunctor p, Tokenizor c p) => c -> p () () +oneLike c = dimap (\_ -> c) (\(_::c) -> ()) (inCategory (categorize c)) + +{- | +`anyLike` consumes tokens +of a given token's category while parsing, +and produces no tokens printing. +-} +anyLike :: forall c p. (Distributor p, Tokenizor c p) => c -> p () () +anyLike c = dimap (\_ -> []::[c]) (\(_::[c]) -> ()) + (manyP (inCategory (categorize c))) + +{- | +`optLike` consumes tokens +of a given token's category while parsing, +and produces the given token while printing. +-} +optLike :: forall c p. (Distributor p, Tokenizor c p) => c -> p () () +optLike c = dimap (\_ -> [c]::[c]) (\(_::[c]) -> ()) + (manyP (inCategory (categorize c))) + +{- | +`reqLike` accepts one or more tokens, +of a given token's category while parsing, +and produces the given token while printing. +-} +reqLike :: forall c p. (Distributor p, Tokenizor c p) => c -> p () () +reqLike c = dimap (\_ -> (c,[]::[c])) (\(_::c, _::[c]) -> ()) + (inCategory (categorize c) >*< manyP (inCategory (categorize c))) From e6c2db0ee8bcaf38f62f95dd7b242bdd9e2b4cc5 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 23 Oct 2025 15:10:26 -0700 Subject: [PATCH 012/282] subtextual --- src/Data/Profunctor/Syntax.hs | 89 ++++++++++------------------------- 1 file changed, 25 insertions(+), 64 deletions(-) diff --git a/src/Data/Profunctor/Syntax.hs b/src/Data/Profunctor/Syntax.hs index 78c8a4b..bff7bc3 100644 --- a/src/Data/Profunctor/Syntax.hs +++ b/src/Data/Profunctor/Syntax.hs @@ -5,7 +5,7 @@ module Data.Profunctor.Syntax , Lintor (..) , toPrintor , fromPrintor - , Stream + , Subtextual ) where import Control.Applicative @@ -32,6 +32,7 @@ newtype InvariantP r a b = InvariantP {runInvariantP :: r} newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} newtype Lintor s t f a b = Lintor {runLintor :: a -> f (b, s -> t)} +-- newtype Larsor s t f a b = Parsor {runParsor :: s -> f (a -> b, t)} toPrintor :: Functor f => Lintor s t f a b -> Printor s t f a b toPrintor (Lintor f) = Printor (fmap snd . f) @@ -39,8 +40,6 @@ toPrintor (Lintor f) = Printor (fmap snd . f) fromPrintor :: Functor f => Printor s t f a a -> Lintor s t f a a fromPrintor (Printor f) = Lintor (\a -> fmap (a,) (f a)) -type Stream s a = (IsStream s, Item s ~ a, Categorized a) - instance Functor (InvariantP r a) where fmap _ = coerce instance Contravariant (InvariantP r a) where contramap _ = coerce instance Profunctor (InvariantP r) where dimap _ _ = coerce @@ -59,7 +58,7 @@ instance Cochoice (InvariantP (rules, (All, start))) where unleft = subsetOf instance Filtrator (InvariantP (rules, (All, start))) where filtrate p = (subsetOf p, subsetOf p) -instance KleeneStarAlgebra r => Applicative (InvariantP r a) where +instance Monoid r => Applicative (InvariantP r a) where pure _ = InvariantP mempty InvariantP rex1 <*> InvariantP rex2 = InvariantP (rex1 <> rex2) @@ -156,31 +155,16 @@ instance Filterable f => Filtrator (Parsor s t f) where leftMay (e, str) = either (\b -> Just (b, str)) (\_ -> Nothing) e rightMay (e, str) = either (\_ -> Nothing) (\b -> Just (b, str)) e -instance - ( Stream s a - , Alternative m, Filterable m, Monad m - ) => Tokenized (Parsor s s m a a) where +instance (Subtextual s m, a ~ Item s) => Tokenized (Parsor s s m a a) where type Token (Parsor s s m a a) = a anyToken = Parsor (\str -> maybe empty pure (uncons str)) -instance - ( Stream s a - , Alternative m, Filterable m, Monad m - ) => Equator a a (Parsor s s m) where +instance (Subtextual s m, a ~ Item s) => Equator a a (Parsor s s m) where equate = anyToken -instance - ( Stream s a - , Alternative m, Filterable m, Monad m - ) => TerminalSymbol (Parsor s s m () ()) where +instance Subtextual s m => TerminalSymbol (Parsor s s m () ()) where type Alphabet (Parsor s s m () ()) = Item s -instance - ( Stream s Char - , Alternative m, Filterable m, Monad m - ) => IsString (Parsor s s m () ()) where +instance (Subtextual s m, Item s ~ Char) => IsString (Parsor s s m () ()) where fromString = terminal -instance - ( Stream s Char - , Alternative m, Filterable m, Monad m - ) => IsString (Parsor s s m s s) where +instance (Subtextual s m, Item s ~ Char) => IsString (Parsor s s m s s) where fromString = tokens instance Functor (Printor s t f a) where @@ -220,31 +204,18 @@ instance Alternative f => Alternator (Printor s s f) where Left (Printor p) -> Printor (either p (\_ -> empty)) Right (Printor p) -> Printor (either (\_ -> empty) p) -instance - ( Stream s a - , Alternative m, Filterable m, Monad m - ) => Tokenized (Printor s s m a a) where +instance (Subtextual s m, Item s ~ a) => Tokenized (Printor s s m a a) where type Token (Printor s s m a a) = a anyToken = Printor (pure . cons) -instance - ( Stream s a - , Alternative m, Filterable m, Monad m - ) => Equator a a (Printor s s m) where +instance (Subtextual s m, Item s ~ a) => Equator a a (Printor s s m) where equate = anyToken -instance - ( Stream s a - , Alternative m, Filterable m, Monad m - ) => TerminalSymbol (Printor s s m () ()) where +instance Subtextual s m => TerminalSymbol (Printor s s m () ()) where type Alphabet (Printor s s m () ()) = Item s -instance - ( Stream s Char - , Alternative m, Filterable m, Monad m - ) => IsString (Printor s s m () ()) where +instance (Subtextual s m, Item s ~ Char) + => IsString (Printor s s m () ()) where fromString = terminal -instance - ( Stream s Char - , Alternative m, Filterable m, Monad m - ) => IsString (Printor s s m s s) where +instance (Subtextual s m, Item s ~ Char) + => IsString (Printor s s m s s) where fromString = tokens instance Functor f => Functor (Lintor s t f a) where @@ -317,29 +288,19 @@ instance Monad f => Arrow (Lintor s s f) where first = first' second = second' -instance - ( Stream s a - , Alternative m, Filterable m, Monad m - ) => Tokenized (Lintor s s m a a) where +instance (Subtextual s m, Item s ~ a) => Tokenized (Lintor s s m a a) where type Token (Lintor s s m a a) = a anyToken = Lintor (\b -> pure (b, cons b)) -instance - ( Stream s a - , Alternative m, Filterable m, Monad m - ) => Equator a a (Lintor s s m) where +instance (Subtextual s m, Item s ~ a) => Equator a a (Lintor s s m) where equate = anyToken -instance - ( Stream s a - , Alternative m, Filterable m, Monad m - ) => TerminalSymbol (Lintor s s m () ()) where +instance Subtextual s m => TerminalSymbol (Lintor s s m () ()) where type Alphabet (Lintor s s m () ()) = Item s -instance - ( Stream s Char - , Alternative m, Filterable m, Monad m - ) => IsString (Lintor s s m () ()) where +instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m () ()) where fromString = terminal -instance - ( Stream s Char - , Alternative m, Filterable m, Monad m - ) => IsString (Lintor s s m s s) where +instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m s s) where fromString = tokens + +type Subtextual s m = + ( IsStream s, Categorized (Item s) + , Alternative m, Filterable m, Monad m + ) From 5d8882c26dd454314f5c517f3ecf74f9525f43dc Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 23 Oct 2025 16:27:32 -0700 Subject: [PATCH 013/282] stuff --- distributors.cabal | 2 ++ package.yaml | 1 + src/Control/Lens/RegEx.hs | 4 +++- src/Data/Profunctor/Monadic.hs | 1 - 4 files changed, 6 insertions(+), 2 deletions(-) diff --git a/distributors.cabal b/distributors.cabal index 58996e4..372584d 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -80,6 +80,7 @@ library RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures TemplateHaskell TupleSections TypeApplications @@ -147,6 +148,7 @@ test-suite spec RecursiveDo ScopedTypeVariables StandaloneDeriving + StandaloneKindSignatures TemplateHaskell TupleSections TypeApplications diff --git a/package.yaml b/package.yaml index face8f9..234d0b1 100644 --- a/package.yaml +++ b/package.yaml @@ -81,6 +81,7 @@ default-extensions: - RecursiveDo - ScopedTypeVariables - StandaloneDeriving +- StandaloneKindSignatures - TemplateHaskell - TupleSections - TypeApplications diff --git a/src/Control/Lens/RegEx.hs b/src/Control/Lens/RegEx.hs index bc9d4bd..765897c 100644 --- a/src/Control/Lens/RegEx.hs +++ b/src/Control/Lens/RegEx.hs @@ -12,6 +12,7 @@ import Control.Lens.PartialIso import Control.Lens.Token import Data.Profunctor import Data.Profunctor.Distributor +import Data.Kind data RegEx c = Terminal [c] @@ -55,8 +56,9 @@ normRegEx = \case KleenePlus rex -> plusK (normRegEx rex) rex -> rex +type Terminator :: Type -> (Type -> Type -> Type) -> Constraint type Terminator c p = - ( TerminalSymbol (p () ()) + ( forall a b. (a ~ (), b ~ ()) => TerminalSymbol (p a b) , Alphabet (p () ()) ~ c ) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 8883f58..db1c969 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -17,7 +17,6 @@ module Data.Profunctor.Monadic , WrappedMonadic (..) , WrappedPolyadic (..) , TaggedP (..) - -- , TaggedCtx (..) , UntaggedT (..) , UntaggedC (..) ) where From c6db189b4132474e4ba091dba266e1569aa0541e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 23 Oct 2025 16:34:56 -0700 Subject: [PATCH 014/282] regexGrammar --- src/Control/Lens/Grammar.hs | 146 ++++++++++++++++++++++++++++++++---- 1 file changed, 130 insertions(+), 16 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 612dbc8..0b2e8c3 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -3,26 +3,29 @@ module Control.Lens.Grammar RegGrammar , Grammar , CtxGrammar + , Grammarr , Gram (..) , genRegEx , genGram , genShowS , genReadS - , Grammatical (..) + , Rules (..) , Regular - , Grammaticator + , Grammatical , Contextual , NonTerminalSymbol (..) + , regexGrammar ) where import Control.Applicative +import Control.Lens +import Control.Lens.PartialIso import Control.Lens.RegEx import Control.Lens.Token import Control.Lens.Stream import Control.Monad import Data.Function import Data.Monoid -import Data.Profunctor import Data.Profunctor.Distributor import Data.Profunctor.Monadic import Data.Profunctor.Syntax @@ -32,19 +35,23 @@ import Type.Reflection import Witherable type RegGrammar c a = forall p. Regular c p => p a a -type Grammar c a = forall p. Grammaticator c p => p a a +type Grammar c a = forall p. Grammatical c p => p a a type CtxGrammar s a = forall p m. Contextual s m p => p s s m a a +type Grammarr c a b = forall p. Grammatical c p => p a a -> p b b + data Gram c = Gram { startGram :: (All, RegEx c) , rulesGram :: Set (String, (All, RegEx c)) } +deriving stock instance + (Show c, Categorized c, Show (Categorize c)) => Show (Gram c) genGram :: (Categorized c, Ord c, Ord (Categorize c)) => Grammar c a -> Gram c -genGram gram = case runInvariantP gram of (rules, start) -> Gram start rules +genGram = (\(rules, start) -> Gram start rules) . runInvariantP genRegEx :: Categorized c => RegGrammar c a -> RegEx c genRegEx = runInvariantP @@ -63,28 +70,29 @@ type Regular c p = , Alternator p ) -type Grammaticator c p = +type Grammatical c p = ( Regular c p , Filtrator p - , forall x. Grammatical (p x x) + , forall x. Rules (p x x) ) type Contextual s m p = - ( IsStream s, Grammaticator (Item s) (p s s m) - , Alternative m, Filterable m, MonadPlus m - , Polyadic p, Tetradic m p + ( Subtextual s m + , Grammatical (Item s) (p s s m) + , Polyadic p + , Tetradic m p ) -class Grammatical a where +class Rules a where rule :: String -> a -> a rule _ = id ruleRec :: String -> (a -> a) -> a ruleRec _ = fix -instance Grammatical (Parsor s t m a b) -instance Grammatical (Printor s t m a b) -instance Grammatical (Lintor s t m a b) +instance Rules (Parsor s t m a b) +instance Rules (Printor s t m a b) +instance Rules (Lintor s t m a b) instance (NonTerminalSymbol a, Ord a) - => Grammatical (Set (String, a), a) where + => Rules (Set (String, a), a) where rule name = ruleRec name . const ruleRec name f = let @@ -93,7 +101,7 @@ instance (NonTerminalSymbol a, Ord a) rules = insert (name, newRule) oldRules in (rules, start) -instance Grammatical p => Grammatical (InvariantP p a b) where +instance Rules p => Rules (InvariantP p a b) where rule name = InvariantP . rule name . runInvariantP ruleRec name = InvariantP @@ -114,3 +122,109 @@ instance NonTerminalSymbol (RegEx c) where instance (Monoid a, NonTerminalSymbol b) => NonTerminalSymbol (a,b) where nonTerminal = pure . nonTerminal + +makeNestedPrisms ''RegEx +makeNestedPrisms ''GeneralCategory + +regexGrammar :: Grammar Char (RegEx Char) +regexGrammar = ruleRec "regex" $ \rex -> altG rex + where + + altG rex = rule "alternate" $ + chain1 Left _Alternate (sepBy (terminal "|")) (seqG rex) + + anyG = rule "any" $ _AnyToken >?< terminal "." + + atomG rex = rule "atom" $ + nonterminalG + <|> failG + <|> classInG + <|> classNotInG + <|> categoryInG + <|> categoryNotInG + <|> _Terminal >?< charG >:< pure "" + <|> anyG + <|> parenG rex + + categoryG = rule "category" $ + _LowercaseLetter >?< terminal "Ll" + <|> _UppercaseLetter >?< terminal "Lu" + <|> _TitlecaseLetter >?< terminal "Lt" + <|> _ModifierLetter >?< terminal "Lm" + <|> _OtherLetter >?< terminal "Lo" + <|> _NonSpacingMark >?< terminal "Mn" + <|> _SpacingCombiningMark >?< terminal "Mc" + <|> _EnclosingMark >?< terminal "Me" + <|> _DecimalNumber >?< terminal "Nd" + <|> _LetterNumber >?< terminal "Nl" + <|> _OtherNumber >?< terminal "No" + <|> _ConnectorPunctuation >?< terminal "Pc" + <|> _DashPunctuation >?< terminal "Pd" + <|> _OpenPunctuation >?< terminal "Ps" + <|> _ClosePunctuation >?< terminal "Pe" + <|> _InitialQuote >?< terminal "Pi" + <|> _FinalQuote >?< terminal "Pf" + <|> _OtherPunctuation >?< terminal "Po" + <|> _MathSymbol >?< terminal "Sm" + <|> _CurrencySymbol >?< terminal "Sc" + <|> _ModifierSymbol >?< terminal "Sk" + <|> _OtherSymbol >?< terminal "So" + <|> _Space >?< terminal "Zs" + <|> _LineSeparator >?< terminal "Zl" + <|> _ParagraphSeparator >?< terminal "Zp" + <|> _Control >?< terminal "Cc" + <|> _Format >?< terminal "Cf" + <|> _Surrogate >?< terminal "Cs" + <|> _PrivateUse >?< terminal "Co" + <|> _NotAssigned >?< terminal "Cn" + + categoryInG = rule "category-in" $ + _InCategory >?< terminal "\\p{" >* categoryG *< terminal "}" + + categoryNotInG = rule "category-not-in" $ + _NotInCategory >?< terminal "\\P{" >* categoryG *< terminal "}" + + charG = rule "char" $ charLiteralG <|> charEscapedG + + charEscapedG = rule "char-escaped" $ terminal "\\" >* inClass charsReserved + + charLiteralG = rule "char-literal" $ notInClass charsReserved + + charsReserved = "$()*+.?[\\]^{|}" + + classInG = rule "class-in" $ + _InClass >?< terminal "[" >* manyP charG *< terminal "]" + + classNotInG = rule "class-not-in" $ + _NotInClass >?< terminal "[^" >* manyP charG *< terminal "]" + + exprG rex = rule "expression" $ + terminalG + <|> kleeneOptG rex + <|> kleeneStarG rex + <|> kleenePlusG rex + <|> atomG rex + + failG = rule "fail" $ _Fail >?< terminal "\\q" + + nonterminalG = rule "nonterminal" $ + _NonTerminal >?< terminal "\\q{" >* manyP charG *< terminal "}" + + parenG :: Grammarr Char x x + parenG ex = rule "parenthesized" $ + terminal "(" >* ex *< terminal ")" + + kleeneOptG rex = rule "kleene-optional" $ + _KleeneOpt >?< atomG rex *< terminal "?" + + kleeneStarG rex = rule "kleene-star" $ + _KleeneStar >?< atomG rex *< terminal "*" + + kleenePlusG rex = rule "kleene-plus" $ + _KleenePlus >?< atomG rex *< terminal "+" + + seqG rex = rule "sequence" $ + chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) + + terminalG = rule "terminal" $ + _Terminal >?< someP charG From 8c2a2ee218329ffe4cff114a5b3005551b611cab Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 23 Oct 2025 17:35:36 -0700 Subject: [PATCH 015/282] Update Syntax.hs --- src/Data/Profunctor/Syntax.hs | 54 +++++++++++++++++++++++++++++++---- 1 file changed, 49 insertions(+), 5 deletions(-) diff --git a/src/Data/Profunctor/Syntax.hs b/src/Data/Profunctor/Syntax.hs index bff7bc3..5de8463 100644 --- a/src/Data/Profunctor/Syntax.hs +++ b/src/Data/Profunctor/Syntax.hs @@ -3,6 +3,7 @@ module Data.Profunctor.Syntax , Parsor (..) , Printor (..) , Lintor (..) + , SyntaxP (..) , toPrintor , fromPrintor , Subtextual @@ -32,7 +33,7 @@ newtype InvariantP r a b = InvariantP {runInvariantP :: r} newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} newtype Lintor s t f a b = Lintor {runLintor :: a -> f (b, s -> t)} --- newtype Larsor s t f a b = Parsor {runParsor :: s -> f (a -> b, t)} +newtype SyntaxP s t f a b = SyntaxP {runSyntaxP :: f t} toPrintor :: Functor f => Lintor s t f a b -> Printor s t f a b toPrintor (Lintor f) = Printor (fmap snd . f) @@ -40,6 +41,11 @@ toPrintor (Lintor f) = Printor (fmap snd . f) fromPrintor :: Functor f => Printor s t f a a -> Lintor s t f a a fromPrintor (Printor f) = Lintor (\a -> fmap (a,) (f a)) +type Subtextual s m = + ( IsStream s, Categorized (Item s) + , Alternative m, Filterable m, Monad m + ) + instance Functor (InvariantP r a) where fmap _ = coerce instance Contravariant (InvariantP r a) where contramap _ = coerce instance Profunctor (InvariantP r) where dimap _ _ = coerce @@ -300,7 +306,45 @@ instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m () ()) where instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m s s) where fromString = tokens -type Subtextual s m = - ( IsStream s, Categorized (Item s) - , Alternative m, Filterable m, Monad m - ) +instance Functor (SyntaxP s t f a) where fmap _ = coerce +instance Contravariant (SyntaxP s t f a) where contramap _ = coerce +instance Profunctor (SyntaxP s t f) where dimap _ _ = coerce +instance Bifunctor (SyntaxP s t f) where bimap _ _ = coerce +instance Functor f => Tetradic f SyntaxP where + dimapT _ g = SyntaxP . fmap g . runSyntaxP + tetramap _ g _ _ = SyntaxP . fmap g . runSyntaxP +instance Choice (SyntaxP s t f) where + left' = coerce + right' = coerce +instance (Monoid t, Applicative f) + => Applicative (SyntaxP s t f a) where + pure _ = SyntaxP (pure mempty) + SyntaxP rex1 <*> SyntaxP rex2 = + SyntaxP (liftA2 (<>) rex1 rex2) +instance (KleeneStarAlgebra t, Applicative f) => Alternative (SyntaxP s t f a) where + empty = SyntaxP (pure failK) + SyntaxP rex1 <|> SyntaxP rex2 = + SyntaxP (liftA2 altK rex1 rex2) + many (SyntaxP rex) = SyntaxP (fmap starK rex) + some (SyntaxP rex) = SyntaxP (fmap plusK rex) +instance (KleeneStarAlgebra t, Applicative f) => Distributor (SyntaxP s t f) where + zeroP = SyntaxP (pure failK) + SyntaxP rex1 >+< SyntaxP rex2 = + SyntaxP (liftA2 altK rex1 rex2) + manyP (SyntaxP rex) = SyntaxP (fmap starK rex) + optionalP (SyntaxP rex) = SyntaxP (fmap optK rex) +instance (KleeneStarAlgebra t, Applicative f) => Alternator (SyntaxP s t f) where + alternate = either coerce coerce + someP (SyntaxP rex) = SyntaxP (fmap plusK rex) +instance (Tokenized t, Categorized c, Token t ~ c, Applicative f) + => Tokenized (SyntaxP s t f c c) where + type Token (SyntaxP s t f c c) = Token t + anyToken = SyntaxP (pure anyToken) + token = SyntaxP . pure . token + inClass = SyntaxP . pure . inClass + notInClass = SyntaxP . pure . notInClass + inCategory = SyntaxP . pure . inCategory + notInCategory = SyntaxP . pure . notInCategory +instance Applicative f => TerminalSymbol (SyntaxP s (RegEx c) f () ()) where + type Alphabet (SyntaxP s (RegEx c) f () ()) = c + terminal = SyntaxP . pure . terminal From ae41b27f3a24558613e0bddacdaf6e34f333811e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 23 Oct 2025 17:49:34 -0700 Subject: [PATCH 016/282] Update Syntax.hs --- src/Data/Profunctor/Syntax.hs | 42 +++++++++++++++++------------------ 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Data/Profunctor/Syntax.hs b/src/Data/Profunctor/Syntax.hs index 5de8463..2c16c34 100644 --- a/src/Data/Profunctor/Syntax.hs +++ b/src/Data/Profunctor/Syntax.hs @@ -33,7 +33,7 @@ newtype InvariantP r a b = InvariantP {runInvariantP :: r} newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} newtype Lintor s t f a b = Lintor {runLintor :: a -> f (b, s -> t)} -newtype SyntaxP s t f a b = SyntaxP {runSyntaxP :: f t} +newtype SyntaxP s t f a b = SyntaxP {runSyntaxP :: s -> f t} toPrintor :: Functor f => Lintor s t f a b -> Printor s t f a b toPrintor (Lintor f) = Printor (fmap snd . f) @@ -311,40 +311,40 @@ instance Contravariant (SyntaxP s t f a) where contramap _ = coerce instance Profunctor (SyntaxP s t f) where dimap _ _ = coerce instance Bifunctor (SyntaxP s t f) where bimap _ _ = coerce instance Functor f => Tetradic f SyntaxP where - dimapT _ g = SyntaxP . fmap g . runSyntaxP - tetramap _ g _ _ = SyntaxP . fmap g . runSyntaxP + dimapT f g = SyntaxP . dimap f (fmap g) . runSyntaxP + tetramap f g _ _ = SyntaxP . dimap f (fmap g) . runSyntaxP instance Choice (SyntaxP s t f) where left' = coerce right' = coerce instance (Monoid t, Applicative f) => Applicative (SyntaxP s t f a) where - pure _ = SyntaxP (pure mempty) + pure _ = SyntaxP (pure (pure mempty)) SyntaxP rex1 <*> SyntaxP rex2 = - SyntaxP (liftA2 (<>) rex1 rex2) + SyntaxP (liftA2 (liftA2 (<>)) rex1 rex2) instance (KleeneStarAlgebra t, Applicative f) => Alternative (SyntaxP s t f a) where - empty = SyntaxP (pure failK) + empty = SyntaxP (pure (pure failK)) SyntaxP rex1 <|> SyntaxP rex2 = - SyntaxP (liftA2 altK rex1 rex2) - many (SyntaxP rex) = SyntaxP (fmap starK rex) - some (SyntaxP rex) = SyntaxP (fmap plusK rex) + SyntaxP (liftA2 (liftA2 altK) rex1 rex2) + many (SyntaxP rex) = SyntaxP (fmap (fmap starK) rex) + some (SyntaxP rex) = SyntaxP (fmap (fmap plusK) rex) instance (KleeneStarAlgebra t, Applicative f) => Distributor (SyntaxP s t f) where - zeroP = SyntaxP (pure failK) + zeroP = SyntaxP (pure (pure failK)) SyntaxP rex1 >+< SyntaxP rex2 = - SyntaxP (liftA2 altK rex1 rex2) - manyP (SyntaxP rex) = SyntaxP (fmap starK rex) - optionalP (SyntaxP rex) = SyntaxP (fmap optK rex) + SyntaxP (liftA2 (liftA2 altK) rex1 rex2) + manyP (SyntaxP rex) = SyntaxP (fmap (fmap starK) rex) + optionalP (SyntaxP rex) = SyntaxP (fmap (fmap optK) rex) instance (KleeneStarAlgebra t, Applicative f) => Alternator (SyntaxP s t f) where alternate = either coerce coerce - someP (SyntaxP rex) = SyntaxP (fmap plusK rex) + someP (SyntaxP rex) = SyntaxP (fmap (fmap plusK) rex) instance (Tokenized t, Categorized c, Token t ~ c, Applicative f) => Tokenized (SyntaxP s t f c c) where type Token (SyntaxP s t f c c) = Token t - anyToken = SyntaxP (pure anyToken) - token = SyntaxP . pure . token - inClass = SyntaxP . pure . inClass - notInClass = SyntaxP . pure . notInClass - inCategory = SyntaxP . pure . inCategory - notInCategory = SyntaxP . pure . notInCategory + anyToken = SyntaxP (pure (pure anyToken)) + token = SyntaxP . pure . pure . token + inClass = SyntaxP . pure . pure . inClass + notInClass = SyntaxP . pure . pure . notInClass + inCategory = SyntaxP . pure . pure . inCategory + notInCategory = SyntaxP . pure . pure . notInCategory instance Applicative f => TerminalSymbol (SyntaxP s (RegEx c) f () ()) where type Alphabet (SyntaxP s (RegEx c) f () ()) = c - terminal = SyntaxP . pure . terminal + terminal = SyntaxP . pure . pure . terminal From 9bda6ee45e10807b507de16c190e0f20e125ad33 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 24 Oct 2025 22:01:19 -0700 Subject: [PATCH 017/282] what we got so far --- distributors.cabal | 8 +- src/Control/Lens/Bifocal.hs | 2 +- src/Control/Lens/Grammar.hs | 175 ++++++++++++++--------- src/Control/Lens/Grammar/BackusNaur.hs | 66 +++++++++ src/Control/Lens/Grammar/Kleene.hs | 10 ++ src/Control/Lens/{ => Grammar}/Stream.hs | 2 +- src/Control/Lens/Grammar/Symbol.hs | 44 ++++++ src/Control/Lens/{ => Grammar}/Token.hs | 62 ++------ src/Control/Lens/Internal/Equator.hs | 9 ++ src/Control/Lens/RegEx.hs | 125 ---------------- src/Data/Profunctor/Syntax.hs | 47 +++--- 11 files changed, 281 insertions(+), 269 deletions(-) create mode 100644 src/Control/Lens/Grammar/BackusNaur.hs create mode 100644 src/Control/Lens/Grammar/Kleene.hs rename src/Control/Lens/{ => Grammar}/Stream.hs (98%) create mode 100644 src/Control/Lens/Grammar/Symbol.hs rename src/Control/Lens/{ => Grammar}/Token.hs (67%) delete mode 100644 src/Control/Lens/RegEx.hs diff --git a/distributors.cabal b/distributors.cabal index 372584d..b1e3f7d 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -31,14 +31,16 @@ library Control.Lens.Bifocal Control.Lens.Diopter Control.Lens.Grammar + Control.Lens.Grammar.BackusNaur + Control.Lens.Grammar.Kleene + Control.Lens.Grammar.Stream + Control.Lens.Grammar.Symbol + Control.Lens.Grammar.Token Control.Lens.Grate Control.Lens.Internal.Equator Control.Lens.Internal.NestedPrismTH Control.Lens.Monocle Control.Lens.PartialIso - Control.Lens.RegEx - Control.Lens.Stream - Control.Lens.Token Control.Lens.Wither Data.Profunctor.Distributor Data.Profunctor.Monadic diff --git a/src/Control/Lens/Bifocal.hs b/src/Control/Lens/Bifocal.hs index 35e6909..14e9699 100644 --- a/src/Control/Lens/Bifocal.hs +++ b/src/Control/Lens/Bifocal.hs @@ -37,7 +37,7 @@ import Control.Lens import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso -import Control.Lens.Stream +import Control.Lens.Grammar.Stream import Data.Profunctor import Data.Profunctor.Distributor import Witherable diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 0b2e8c3..bd12c99 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -3,35 +3,33 @@ module Control.Lens.Grammar RegGrammar , Grammar , CtxGrammar - , Grammarr - , Gram (..) - , genRegEx - , genGram + -- , genRegEx + -- , genGram , genShowS , genReadS - , Rules (..) + , BackusNaurForm (..) , Regular , Grammatical , Contextual , NonTerminalSymbol (..) + , RegEx (..) , regexGrammar + , normRegEx ) where import Control.Applicative import Control.Lens import Control.Lens.PartialIso -import Control.Lens.RegEx -import Control.Lens.Token -import Control.Lens.Stream +import Control.Lens.Grammar.BackusNaur +import Control.Lens.Grammar.Kleene +import Control.Lens.Grammar.Token +import Control.Lens.Grammar.Stream +import Control.Lens.Grammar.Symbol import Control.Monad -import Data.Function -import Data.Monoid import Data.Profunctor.Distributor import Data.Profunctor.Monadic import Data.Profunctor.Syntax -import Data.Set (insert, Set) import GHC.Exts -import Type.Reflection import Witherable type RegGrammar c a = forall p. Regular c p => p a a @@ -40,21 +38,14 @@ type CtxGrammar s a = forall p m. Contextual s m p => p s s m a a type Grammarr c a b = forall p. Grammatical c p => p a a -> p b b -data Gram c = Gram - { startGram :: (All, RegEx c) - , rulesGram :: Set (String, (All, RegEx c)) - } -deriving stock instance - (Show c, Categorized c, Show (Categorize c)) => Show (Gram c) - -genGram - :: (Categorized c, Ord c, Ord (Categorize c)) - => Grammar c a - -> Gram c -genGram = (\(rules, start) -> Gram start rules) . runInvariantP +-- genGram +-- :: (Categorized c, Ord c, Ord (Categorize c)) +-- => Grammar c a +-- -> Gram (RegEx c) +-- genGram = runInvariantP -genRegEx :: Categorized c => RegGrammar c a -> RegEx c -genRegEx = runInvariantP +-- genRegEx :: Categorized c => RegGrammar c a -> RegEx c +-- genRegEx = runInvariantP genShowS :: (Filterable m, MonadPlus m) @@ -73,55 +64,103 @@ type Regular c p = type Grammatical c p = ( Regular c p , Filtrator p - , forall x. Rules (p x x) + , forall x. BackusNaurForm (p x x) ) type Contextual s m p = - ( Subtextual s m - , Grammatical (Item s) (p s s m) - , Polyadic p - , Tetradic m p + ( Grammatical (Item s) (p s s m) + , Monadic (p s s) + , Subtextual s m ) -class Rules a where - rule :: String -> a -> a - rule _ = id - ruleRec :: String -> (a -> a) -> a - ruleRec _ = fix -instance Rules (Parsor s t m a b) -instance Rules (Printor s t m a b) -instance Rules (Lintor s t m a b) -instance (NonTerminalSymbol a, Ord a) - => Rules (Set (String, a), a) where - rule name = ruleRec name . const - ruleRec name f = - let - start = nonTerminal name - (oldRules, newRule) = f (mempty, start) - rules = insert (name, newRule) oldRules - in - (rules, start) -instance Rules p => Rules (InvariantP p a b) where - rule name = InvariantP . rule name . runInvariantP - ruleRec name - = InvariantP - . ruleRec name - . dimap InvariantP runInvariantP - -class NonTerminalSymbol a where - nonTerminal :: String -> a - default nonTerminal :: Typeable a => String -> a - nonTerminal q = error (thetype ??? rexrule ??? function) - where - x ??? y = x <> " ??? " <> y - thetype = show (typeRep @a) - rexrule = "\\q{" <> q <> "}" - function = "Control.Lens.Grammar.nonTerminal" +data RegEx c + = Terminal [c] + | Sequence (RegEx c) (RegEx c) + | Fail + | Alternate (RegEx c) (RegEx c) + | KleeneOpt (RegEx c) + | KleeneStar (RegEx c) + | KleenePlus (RegEx c) + | AnyToken + | InClass [c] + | NotInClass [c] + | InCategory (Categorize c) + | NotInCategory (Categorize c) + | NonTerminal String + +normRegEx :: Categorized c => RegEx c -> RegEx c +normRegEx = \case + Sequence rex1 rex2 -> normRegEx rex1 <> normRegEx rex2 + Alternate rex1 rex2 -> normRegEx rex1 `altK` normRegEx rex2 + KleeneOpt rex -> optK (normRegEx rex) + KleeneStar rex -> starK (normRegEx rex) + KleenePlus rex -> plusK (normRegEx rex) + rex -> rex + +deriving stock instance Categorized c => Eq (RegEx c) +deriving stock instance + (Categorized c, Ord c, Ord (Categorize c)) => Ord (RegEx c) +deriving stock instance + (Categorized c, Read c, Read (Categorize c)) => Read (RegEx c) +deriving stock instance + (Categorized c, Show c, Show (Categorize c)) => Show (RegEx c) +instance TerminalSymbol (RegEx c) where + type Alphabet (RegEx c) = c + terminal = Terminal +instance Monoid a => TerminalSymbol (a, RegEx c) where + type Alphabet (a, RegEx c) = c + terminal = pure . terminal +instance Categorized c => Tokenized (RegEx c) where + type Token (RegEx c) = c + anyToken = AnyToken + token c = Terminal [c] + inClass = InClass + notInClass = NotInClass + inCategory = InCategory + notInCategory = NotInCategory +instance Categorized c => Semigroup (RegEx c) where + Terminal [] <> rex = rex + rex <> Terminal [] = rex + Fail <> _ = empK + _ <> Fail = empK + Terminal str0 <> Terminal str1 = Terminal (str0 <> str1) + KleeneStar rex0 <> rex1 + | rex0 == rex1 = plusK rex0 + rex0 <> KleeneStar rex1 + | rex0 == rex1 = plusK rex1 + rex0 <> rex1 = Sequence rex0 rex1 +instance Categorized c => Monoid (RegEx c) where + mempty = Terminal [] +instance Categorized c => KleeneStarAlgebra (RegEx c) where + empK = Fail + optK Fail = mempty + optK (Terminal []) = mempty + optK (KleenePlus rex) = starK rex + optK rex = KleeneOpt rex + starK Fail = mempty + starK (Terminal []) = mempty + starK rex = KleeneStar rex + plusK Fail = empK + plusK (Terminal []) = mempty + plusK rex = KleenePlus rex + KleenePlus rex `altK` Terminal [] = starK rex + Terminal [] `altK` KleenePlus rex = starK rex + rex `altK` Terminal [] = optK rex + Terminal [] `altK` rex = optK rex + rex `altK` Fail = rex + Fail `altK` rex = rex + rex0 `altK` rex1 | rex0 == rex1 = rex0 + rex0 `altK` rex1 = Alternate rex0 rex1 instance NonTerminalSymbol (RegEx c) where nonTerminal = NonTerminal -instance (Monoid a, NonTerminalSymbol b) - => NonTerminalSymbol (a,b) where - nonTerminal = pure . nonTerminal + +instance Applicative f + => TerminalSymbol (SyntaxP s (RegEx c) f () ()) where + type Alphabet (SyntaxP s (RegEx c) f () ()) = c + terminal = SyntaxP . pure . pure . terminal +instance TerminalSymbol (InvariantP (RegEx c) () ()) where + type Alphabet (InvariantP (RegEx c) () ()) = c + terminal = InvariantP . terminal makeNestedPrisms ''RegEx makeNestedPrisms ''GeneralCategory diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs new file mode 100644 index 0000000..af32ba6 --- /dev/null +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -0,0 +1,66 @@ +module Control.Lens.Grammar.BackusNaur + ( BackusNaurForm (..) + , Gram (..) + ) where + +import Control.Lens.Grammar.Kleene +import Control.Lens.Grammar.Token +import Control.Lens.Grammar.Symbol +import Data.Function +import Data.Set as Set + +class BackusNaurForm a where + rule :: String -> a -> a + rule _ = id + ruleRec :: String -> (a -> a) -> a + ruleRec _ = fix + +data Gram a = Gram + { startGram :: a + , rulesGram :: Set (String, a) + } deriving stock (Eq, Ord) + +instance (Ord a, NonTerminalSymbol a) + => BackusNaurForm (Gram a) where + rule name = ruleRec name . const + ruleRec name f = + let + start = nonTerminal name + Gram newRule oldRules = f (Gram start mempty) + rules = insert (name, newRule) oldRules + in + Gram start rules + +instance (Ord a, TerminalSymbol a) => TerminalSymbol (Gram a) where + type Alphabet (Gram a) = Alphabet a + terminal = liftGram0 . terminal + +liftGram0 :: Ord a => a -> Gram a +liftGram0 a = Gram a mempty + +liftGram1 :: (a -> a) -> Gram a -> Gram a +liftGram1 f (Gram start rules) = Gram (f start) rules + +liftGram2 :: Ord a => (a -> a -> a) -> Gram a -> Gram a -> Gram a +liftGram2 f (Gram start0 rules0) (Gram start1 rules1) = + Gram (f start0 start1) (rules0 <> rules1) + +instance (Ord a, Tokenized a) => Tokenized (Gram a) where + type Token (Gram a) = Token a + anyToken = liftGram0 anyToken + token = liftGram0 . token + inClass = liftGram0 . inClass + notInClass = liftGram0 . notInClass + inCategory = liftGram0 . inCategory + notInCategory = liftGram0 . notInCategory + +instance (Ord a, KleeneStarAlgebra a) => KleeneStarAlgebra (Gram a) where + starK = liftGram1 starK + plusK = liftGram1 plusK + optK = liftGram1 optK + empK = liftGram0 empK + altK = liftGram2 altK +instance (Ord a, Monoid a) => Monoid (Gram a) where + mempty = liftGram0 mempty +instance (Ord a, Semigroup a) => Semigroup (Gram a) where + (<>) = liftGram2 (<>) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs new file mode 100644 index 0000000..b7f6e1e --- /dev/null +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -0,0 +1,10 @@ +module Control.Lens.Grammar.Kleene + ( KleeneStarAlgebra (..) + ) where + +class Monoid a => KleeneStarAlgebra a where + starK :: a -> a + plusK :: a -> a + optK :: a -> a + altK :: a -> a -> a + empK :: a diff --git a/src/Control/Lens/Stream.hs b/src/Control/Lens/Grammar/Stream.hs similarity index 98% rename from src/Control/Lens/Stream.hs rename to src/Control/Lens/Grammar/Stream.hs index 1f3b8ef..7b39a7b 100644 --- a/src/Control/Lens/Stream.hs +++ b/src/Control/Lens/Grammar/Stream.hs @@ -1,4 +1,4 @@ -module Control.Lens.Stream +module Control.Lens.Grammar.Stream ( -- * IsStream , listed diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs new file mode 100644 index 0000000..56ee2e4 --- /dev/null +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -0,0 +1,44 @@ +module Control.Lens.Grammar.Symbol + ( Terminator + , TerminalSymbol (..) + , NonTerminalSymbol (..) + ) where + +import Control.Lens +import Control.Lens.Internal.Equator +import Control.Lens.PartialIso +import Data.Kind +import Data.Profunctor +import Data.Profunctor.Distributor +import Type.Reflection + +type Terminator :: Type -> (Type -> Type -> Type) -> Constraint +type Terminator a p = + ( a ~ Alphabet (p () ()) + , forall x y. (x ~ (), y ~ ()) => TerminalSymbol (p x y) + ) + +class TerminalSymbol p where + type Alphabet p + terminal :: [Alphabet p] -> p + default terminal + :: ( Monoidal q, Cochoice q, Equator c c q + , q () () ~ p, Alphabet p ~ c, Eq c + ) + => [Alphabet p] -> p + terminal [] = oneP + terminal (a:as) = only a ?< equate *> terminal as + +instance TerminalSymbol [a] where + type Alphabet [a] = a + terminal = id + +class NonTerminalSymbol a where + nonTerminal :: String -> a + default nonTerminal :: Typeable a => String -> a + nonTerminal q = error (thetype ??? rexrule ??? function) + where + x ??? y = x <> " ??? " <> y + thetype = show (typeRep @a) + rexrule = "\\q{" <> q <> "}" + function = "Control.Lens.Grammar.nonTerminal" diff --git a/src/Control/Lens/Token.hs b/src/Control/Lens/Grammar/Token.hs similarity index 67% rename from src/Control/Lens/Token.hs rename to src/Control/Lens/Grammar/Token.hs index 6cd29bb..72841b0 100644 --- a/src/Control/Lens/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -1,4 +1,4 @@ -module Control.Lens.Token +module Control.Lens.Grammar.Token ( -- * Token Categorized (..) , Tokenized (..) @@ -7,9 +7,9 @@ module Control.Lens.Token , Tokenizor -- * Like , oneLike - , anyLike + , manyLike , optLike - , reqLike + , someLike -- * Unicode , GeneralCategory (..) ) where @@ -27,42 +27,9 @@ class (Eq a, Eq (Categorize a)) => Categorized a where categorize :: a -> Categorize a default categorize :: Categorize a ~ () => a -> Categorize a categorize _ = () - decategorize :: Categorize a -> [a] - decategorize _ = [] instance Categorized Char where type Categorize Char = GeneralCategory categorize = generalCategory - decategorize = \case - 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" instance Categorized Word8 instance Categorized () @@ -110,15 +77,6 @@ instance Categorized c => Tokenized (c -> Bool) where inCategory = lmap categorize . (==) notInCategory = lmap categorize . (/=) -instance (Monoid a, Tokenized b) => Tokenized (a,b) where - type Token (a,b) = Token b - anyToken = pure anyToken - token = pure . token - inClass = pure . inClass - notInClass = pure . notInClass - inCategory = pure . inCategory - notInCategory = pure . notInCategory - satisfy :: ( Choice q, Cochoice q , Tokenized p, p ~ q (Token p) (Token p) @@ -149,16 +107,16 @@ oneLike :: forall c p. (Profunctor p, Tokenizor c p) => c -> p () () oneLike c = dimap (\_ -> c) (\(_::c) -> ()) (inCategory (categorize c)) {- | -`anyLike` consumes tokens +`manyLike` consumes zero or more tokens of a given token's category while parsing, and produces no tokens printing. -} -anyLike :: forall c p. (Distributor p, Tokenizor c p) => c -> p () () -anyLike c = dimap (\_ -> []::[c]) (\(_::[c]) -> ()) +manyLike :: forall c p. (Distributor p, Tokenizor c p) => c -> p () () +manyLike c = dimap (\_ -> []::[c]) (\(_::[c]) -> ()) (manyP (inCategory (categorize c))) {- | -`optLike` consumes tokens +`optLike` consumes zero or more tokens of a given token's category while parsing, and produces the given token while printing. -} @@ -167,10 +125,10 @@ optLike c = dimap (\_ -> [c]::[c]) (\(_::[c]) -> ()) (manyP (inCategory (categorize c))) {- | -`reqLike` accepts one or more tokens, +`someLike` accepts one or more tokens of a given token's category while parsing, and produces the given token while printing. -} -reqLike :: forall c p. (Distributor p, Tokenizor c p) => c -> p () () -reqLike c = dimap (\_ -> (c,[]::[c])) (\(_::c, _::[c]) -> ()) +someLike :: forall c p. (Distributor p, Tokenizor c p) => c -> p () () +someLike c = dimap (\_ -> (c,[]::[c])) (\(_::c, _::[c]) -> ()) (inCategory (categorize c) >*< manyP (inCategory (categorize c))) diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index e916cf2..c656584 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -1,6 +1,7 @@ module Control.Lens.Internal.Equator ( -- * Equator (..) + , equator ) where import Control.Lens @@ -8,6 +9,8 @@ import Control.Lens.Internal.Iso import Control.Lens.Internal.Prism import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso +import Data.Profunctor +import Data.Profunctor.Distributor class Equator a b p | p -> a, p -> b where equate :: p a b instance Equator a b (Identical a b) where equate = Identical @@ -20,3 +23,9 @@ instance Equator a b (PartialExchange a b) where instance (Equator a b p, Profunctor p, Applicative f) => Equator a b (WrappedPafb f p) where equate = WrapPafb (rmap pure equate) + +equator + :: (Monoidal p, Cochoice p, Equator a a p, Eq a) + => [a] -> p () () +equator [] = oneP +equator (a:as) = only a ?< equate *> equator as diff --git a/src/Control/Lens/RegEx.hs b/src/Control/Lens/RegEx.hs deleted file mode 100644 index 765897c..0000000 --- a/src/Control/Lens/RegEx.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Control.Lens.RegEx - ( -- * - RegEx (..) - , TerminalSymbol (..) - , KleeneStarAlgebra (..) - , normRegEx - , Terminator - ) where - -import Control.Lens -import Control.Lens.PartialIso -import Control.Lens.Token -import Data.Profunctor -import Data.Profunctor.Distributor -import Data.Kind - -data RegEx c - = Terminal [c] - | Sequence (RegEx c) (RegEx c) - | Fail - | Alternate (RegEx c) (RegEx c) - | KleeneOpt (RegEx c) - | KleeneStar (RegEx c) - | KleenePlus (RegEx c) - | AnyToken - | InClass [c] - | NotInClass [c] - | InCategory (Categorize c) - | NotInCategory (Categorize c) - | NonTerminal String - -class TerminalSymbol s where - type Alphabet s - terminal :: [Alphabet s] -> s - default terminal - :: ( Monoidal p, Cochoice p, Tokenizor c p - , Alphabet s ~ c, p () () ~ s - ) - => [Alphabet s] -> s - terminal [] = oneP - terminal (a:as) = only a ?< anyToken *> terminal as - -class Monoid a => KleeneStarAlgebra a where - starK :: a -> a - plusK :: a -> a - optK :: a -> a - altK :: a -> a -> a - failK :: a - -normRegEx :: Categorized c => RegEx c -> RegEx c -normRegEx = \case - Sequence rex1 rex2 -> normRegEx rex1 <> normRegEx rex2 - Alternate rex1 rex2 -> normRegEx rex1 `altK` normRegEx rex2 - KleeneOpt rex -> optK (normRegEx rex) - KleeneStar rex -> starK (normRegEx rex) - KleenePlus rex -> plusK (normRegEx rex) - rex -> rex - -type Terminator :: Type -> (Type -> Type -> Type) -> Constraint -type Terminator c p = - ( forall a b. (a ~ (), b ~ ()) => TerminalSymbol (p a b) - , Alphabet (p () ()) ~ c - ) - -deriving stock instance Categorized c => Eq (RegEx c) -deriving stock instance - (Categorized c, Ord c, Ord (Categorize c)) => Ord (RegEx c) -deriving stock instance - (Categorized c, Read c, Read (Categorize c)) => Read (RegEx c) -deriving stock instance - (Categorized c, Show c, Show (Categorize c)) => Show (RegEx c) -instance TerminalSymbol (RegEx c) where - type Alphabet (RegEx c) = c - terminal = Terminal -instance Monoid a => TerminalSymbol (a, RegEx c) where - type Alphabet (a, RegEx c) = c - terminal = pure . terminal -instance Categorized c => Tokenized (RegEx c) where - type Token (RegEx c) = c - anyToken = AnyToken - token c = Terminal [c] - inClass = InClass - notInClass = NotInClass - inCategory = InCategory - notInCategory = NotInCategory -instance Categorized c => Semigroup (RegEx c) where - Terminal [] <> rex = rex - rex <> Terminal [] = rex - Fail <> _ = failK - _ <> Fail = failK - Terminal str0 <> Terminal str1 = Terminal (str0 <> str1) - KleeneStar rex0 <> rex1 - | rex0 == rex1 = plusK rex0 - rex0 <> KleeneStar rex1 - | rex0 == rex1 = plusK rex1 - rex0 <> rex1 = Sequence rex0 rex1 -instance Categorized c => Monoid (RegEx c) where - mempty = Terminal [] -instance Categorized c => KleeneStarAlgebra (RegEx c) where - failK = Fail - optK Fail = mempty - optK (Terminal []) = mempty - optK (KleenePlus rex) = starK rex - optK rex = KleeneOpt rex - starK Fail = mempty - starK (Terminal []) = mempty - starK rex = KleeneStar rex - plusK Fail = failK - plusK (Terminal []) = mempty - plusK rex = KleenePlus rex - KleenePlus rex `altK` Terminal [] = starK rex - Terminal [] `altK` KleenePlus rex = starK rex - rex `altK` Terminal [] = optK rex - Terminal [] `altK` rex = optK rex - rex `altK` Fail = rex - Fail `altK` rex = rex - rex0 `altK` rex1 | rex0 == rex1 = rex0 - rex0 `altK` rex1 = Alternate rex0 rex1 -instance (Monoid a, KleeneStarAlgebra b) - => KleeneStarAlgebra (a,b) where - starK = fmap starK - plusK = fmap plusK - optK = fmap optK - failK = pure failK - altK = liftA2 altK diff --git a/src/Data/Profunctor/Syntax.hs b/src/Data/Profunctor/Syntax.hs index 2c16c34..2eb28b6 100644 --- a/src/Data/Profunctor/Syntax.hs +++ b/src/Data/Profunctor/Syntax.hs @@ -14,9 +14,11 @@ import Control.Arrow import Control.Category import Control.Lens import Control.Lens.Internal.Equator -import Control.Lens.RegEx -import Control.Lens.Stream -import Control.Lens.Token +import Control.Lens.Grammar.BackusNaur +import Control.Lens.Grammar.Kleene +import Control.Lens.Grammar.Stream +import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token import Control.Monad import Data.Bifunctor import Data.Coerce @@ -69,13 +71,13 @@ instance Monoid r => Applicative (InvariantP r a) where InvariantP rex1 <*> InvariantP rex2 = InvariantP (rex1 <> rex2) instance KleeneStarAlgebra r => Alternative (InvariantP r a) where - empty = InvariantP failK + empty = InvariantP empK InvariantP rex1 <|> InvariantP rex2 = InvariantP (rex1 `altK` rex2) many (InvariantP rex) = InvariantP (starK rex) some (InvariantP rex) = InvariantP (plusK rex) instance KleeneStarAlgebra r => Distributor (InvariantP r) where - zeroP = InvariantP failK + zeroP = InvariantP empK InvariantP rex1 >+< InvariantP rex2 = InvariantP (rex1 `altK` rex2) manyP (InvariantP rex) = InvariantP (starK rex) @@ -92,15 +94,12 @@ instance (Tokenized r, Categorized c, Token r ~ c) notInClass = InvariantP . notInClass inCategory = InvariantP . inCategory notInCategory = InvariantP . notInCategory -instance TerminalSymbol (InvariantP (RegEx c) () ()) where - type Alphabet (InvariantP (RegEx c) () ()) = c - terminal = InvariantP . terminal -instance - ( Monoid a - , TerminalSymbol b - ) => TerminalSymbol (InvariantP (a,b) () ()) where - type Alphabet (InvariantP (a,b) () ()) = Alphabet b - terminal = InvariantP . pure . terminal +instance BackusNaurForm p => BackusNaurForm (InvariantP p a b) where + rule name = InvariantP . rule name . runInvariantP + ruleRec name + = InvariantP + . ruleRec name + . dimap InvariantP runInvariantP instance Functor f => Functor (Parsor s t f a) where fmap f = Parsor . fmap (fmap (first' f)) . runParsor @@ -172,6 +171,7 @@ instance (Subtextual s m, Item s ~ Char) => IsString (Parsor s s m () ()) where fromString = terminal instance (Subtextual s m, Item s ~ Char) => IsString (Parsor s s m s s) where fromString = tokens +instance BackusNaurForm (Parsor s t m a b) instance Functor (Printor s t f a) where fmap _ = coerce @@ -223,6 +223,7 @@ instance (Subtextual s m, Item s ~ Char) instance (Subtextual s m, Item s ~ Char) => IsString (Printor s s m s s) where fromString = tokens +instance BackusNaurForm (Printor s t m a b) instance Functor f => Functor (Lintor s t f a) where fmap f = Lintor . fmap (fmap (first' f)) . runLintor @@ -305,6 +306,7 @@ instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m () ()) where fromString = terminal instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m s s) where fromString = tokens +instance BackusNaurForm (Lintor s t m a b) instance Functor (SyntaxP s t f a) where fmap _ = coerce instance Contravariant (SyntaxP s t f a) where contramap _ = coerce @@ -316,19 +318,29 @@ instance Functor f => Tetradic f SyntaxP where instance Choice (SyntaxP s t f) where left' = coerce right' = coerce +instance Functor f => Filterable (SyntaxP s All f a) where + mapMaybe _ = SyntaxP . fmap (fmap (pure (All False))) . runSyntaxP +instance Functor f => Cochoice (SyntaxP s All f) where + unleft = SyntaxP . fmap (fmap (pure (All False))) . runSyntaxP + unright = SyntaxP . fmap (fmap (pure (All False))) . runSyntaxP +instance Functor f => Filtrator (SyntaxP s All f) where + filtrate (SyntaxP p) = + ( SyntaxP (fmap (fmap (pure (All False))) p) + , SyntaxP (fmap (fmap (pure (All False))) p) + ) instance (Monoid t, Applicative f) => Applicative (SyntaxP s t f a) where pure _ = SyntaxP (pure (pure mempty)) SyntaxP rex1 <*> SyntaxP rex2 = SyntaxP (liftA2 (liftA2 (<>)) rex1 rex2) instance (KleeneStarAlgebra t, Applicative f) => Alternative (SyntaxP s t f a) where - empty = SyntaxP (pure (pure failK)) + empty = SyntaxP (pure (pure empK)) SyntaxP rex1 <|> SyntaxP rex2 = SyntaxP (liftA2 (liftA2 altK) rex1 rex2) many (SyntaxP rex) = SyntaxP (fmap (fmap starK) rex) some (SyntaxP rex) = SyntaxP (fmap (fmap plusK) rex) instance (KleeneStarAlgebra t, Applicative f) => Distributor (SyntaxP s t f) where - zeroP = SyntaxP (pure (pure failK)) + zeroP = SyntaxP (pure (pure empK)) SyntaxP rex1 >+< SyntaxP rex2 = SyntaxP (liftA2 (liftA2 altK) rex1 rex2) manyP (SyntaxP rex) = SyntaxP (fmap (fmap starK) rex) @@ -345,6 +357,3 @@ instance (Tokenized t, Categorized c, Token t ~ c, Applicative f) notInClass = SyntaxP . pure . pure . notInClass inCategory = SyntaxP . pure . pure . inCategory notInCategory = SyntaxP . pure . pure . notInCategory -instance Applicative f => TerminalSymbol (SyntaxP s (RegEx c) f () ()) where - type Alphabet (SyntaxP s (RegEx c) f () ()) = c - terminal = SyntaxP . pure . pure . terminal From f7cf21a680dbf0bea35ca77a2d1d9c0ca74c4720 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 24 Oct 2025 22:15:13 -0700 Subject: [PATCH 018/282] default equate --- src/Control/Lens/Grammar/Symbol.hs | 5 +---- src/Control/Lens/Internal/Equator.hs | 6 +++++- src/Data/Profunctor/Syntax.hs | 11 ++++------- 3 files changed, 10 insertions(+), 12 deletions(-) diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index 56ee2e4..797c486 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -4,9 +4,7 @@ module Control.Lens.Grammar.Symbol , NonTerminalSymbol (..) ) where -import Control.Lens import Control.Lens.Internal.Equator -import Control.Lens.PartialIso import Data.Kind import Data.Profunctor import Data.Profunctor.Distributor @@ -26,8 +24,7 @@ class TerminalSymbol p where , q () () ~ p, Alphabet p ~ c, Eq c ) => [Alphabet p] -> p - terminal [] = oneP - terminal (a:as) = only a ?< equate *> terminal as + terminal = equator instance TerminalSymbol [a] where type Alphabet [a] = a diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index c656584..8bff4eb 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -5,6 +5,7 @@ module Control.Lens.Internal.Equator ) where import Control.Lens +import Control.Lens.Grammar.Token import Control.Lens.Internal.Iso import Control.Lens.Internal.Prism import Control.Lens.Internal.Profunctor @@ -12,7 +13,10 @@ import Control.Lens.PartialIso import Data.Profunctor import Data.Profunctor.Distributor -class Equator a b p | p -> a, p -> b where equate :: p a b +class Equator a b p | p -> a, p -> b where + equate :: p a b + default equate :: (Tokenizor c p, a ~ c, b ~ c) => p a b + equate = anyToken instance Equator a b (Identical a b) where equate = Identical instance Equator a b (Exchange a b) where equate = Exchange id id diff --git a/src/Data/Profunctor/Syntax.hs b/src/Data/Profunctor/Syntax.hs index 2eb28b6..61b5da9 100644 --- a/src/Data/Profunctor/Syntax.hs +++ b/src/Data/Profunctor/Syntax.hs @@ -162,16 +162,15 @@ instance Filterable f => Filtrator (Parsor s t f) where instance (Subtextual s m, a ~ Item s) => Tokenized (Parsor s s m a a) where type Token (Parsor s s m a a) = a - anyToken = Parsor (\str -> maybe empty pure (uncons str)) + anyToken = Parsor (maybe empty pure . uncons) instance (Subtextual s m, a ~ Item s) => Equator a a (Parsor s s m) where - equate = anyToken instance Subtextual s m => TerminalSymbol (Parsor s s m () ()) where type Alphabet (Parsor s s m () ()) = Item s +instance BackusNaurForm (Parsor s t m a b) instance (Subtextual s m, Item s ~ Char) => IsString (Parsor s s m () ()) where fromString = terminal instance (Subtextual s m, Item s ~ Char) => IsString (Parsor s s m s s) where fromString = tokens -instance BackusNaurForm (Parsor s t m a b) instance Functor (Printor s t f a) where fmap _ = coerce @@ -214,16 +213,15 @@ instance (Subtextual s m, Item s ~ a) => Tokenized (Printor s s m a a) where type Token (Printor s s m a a) = a anyToken = Printor (pure . cons) instance (Subtextual s m, Item s ~ a) => Equator a a (Printor s s m) where - equate = anyToken instance Subtextual s m => TerminalSymbol (Printor s s m () ()) where type Alphabet (Printor s s m () ()) = Item s +instance BackusNaurForm (Printor s t m a b) instance (Subtextual s m, Item s ~ Char) => IsString (Printor s s m () ()) where fromString = terminal instance (Subtextual s m, Item s ~ Char) => IsString (Printor s s m s s) where fromString = tokens -instance BackusNaurForm (Printor s t m a b) instance Functor f => Functor (Lintor s t f a) where fmap f = Lintor . fmap (fmap (first' f)) . runLintor @@ -299,14 +297,13 @@ instance (Subtextual s m, Item s ~ a) => Tokenized (Lintor s s m a a) where type Token (Lintor s s m a a) = a anyToken = Lintor (\b -> pure (b, cons b)) instance (Subtextual s m, Item s ~ a) => Equator a a (Lintor s s m) where - equate = anyToken instance Subtextual s m => TerminalSymbol (Lintor s s m () ()) where type Alphabet (Lintor s s m () ()) = Item s +instance BackusNaurForm (Lintor s t m a b) instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m () ()) where fromString = terminal instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m s s) where fromString = tokens -instance BackusNaurForm (Lintor s t m a b) instance Functor (SyntaxP s t f a) where fmap _ = coerce instance Contravariant (SyntaxP s t f a) where contramap _ = coerce From e99eff864ee5a66b0298eda1cec0e2b657d9f14c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 24 Oct 2025 23:03:34 -0700 Subject: [PATCH 019/282] is --- src/Control/Lens/Grammar/Symbol.hs | 23 ++++++++--------------- src/Control/Lens/Grammar/Token.hs | 28 +++++++++++++--------------- src/Control/Lens/Internal/Equator.hs | 13 +++++++------ 3 files changed, 28 insertions(+), 36 deletions(-) diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index 797c486..7d737b1 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -8,7 +8,6 @@ import Control.Lens.Internal.Equator import Data.Kind import Data.Profunctor import Data.Profunctor.Distributor -import Type.Reflection type Terminator :: Type -> (Type -> Type -> Type) -> Constraint type Terminator a p = @@ -16,15 +15,16 @@ type Terminator a p = , forall x y. (x ~ (), y ~ ()) => TerminalSymbol (p x y) ) -class TerminalSymbol p where - type Alphabet p - terminal :: [Alphabet p] -> p +class TerminalSymbol s where + type Alphabet s + terminal :: [Alphabet s] -> s default terminal - :: ( Monoidal q, Cochoice q, Equator c c q - , q () () ~ p, Alphabet p ~ c, Eq c + :: ( Monoidal p, Cochoice p, p () () ~ s + , Equator (Alphabet s) (Alphabet s) p + , Eq (Alphabet s) ) - => [Alphabet p] -> p - terminal = equator + => [Alphabet s] -> s + terminal = is instance TerminalSymbol [a] where type Alphabet [a] = a @@ -32,10 +32,3 @@ instance TerminalSymbol [a] where class NonTerminalSymbol a where nonTerminal :: String -> a - default nonTerminal :: Typeable a => String -> a - nonTerminal q = error (thetype ??? rexrule ??? function) - where - x ??? y = x <> " ??? " <> y - thetype = show (typeRep @a) - rexrule = "\\q{" <> q <> "}" - function = "Control.Lens.Grammar.nonTerminal" diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 72841b0..7be0fa5 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -78,10 +78,8 @@ instance Categorized c => Tokenized (c -> Bool) where notInCategory = lmap categorize . (/=) satisfy - :: ( Choice q, Cochoice q - , Tokenized p, p ~ q (Token p) (Token p) - ) - => (Token p -> Bool) -> p + :: (Choice p, Cochoice p, Tokenizor a p) + => (a -> Bool) -> p a a satisfy f = satisfied f >?< anyToken type Tokenizor a p = (Tokenized (p a a), Token (p a a) ~ a) @@ -103,32 +101,32 @@ tokens (a:as) = token a >:< tokens as of a given token's category while parsing, and produces the given token while printing. -} -oneLike :: forall c p. (Profunctor p, Tokenizor c p) => c -> p () () -oneLike c = dimap (\_ -> c) (\(_::c) -> ()) (inCategory (categorize c)) +oneLike :: forall a p. (Profunctor p, Tokenizor a p) => a -> p () () +oneLike a = dimap (\_ -> a) (\(_::a) -> ()) (inCategory (categorize a)) {- | `manyLike` consumes zero or more tokens of a given token's category while parsing, and produces no tokens printing. -} -manyLike :: forall c p. (Distributor p, Tokenizor c p) => c -> p () () -manyLike c = dimap (\_ -> []::[c]) (\(_::[c]) -> ()) - (manyP (inCategory (categorize c))) +manyLike :: forall a p. (Distributor p, Tokenizor a p) => a -> p () () +manyLike a = dimap (\_ -> []::[a]) (\(_::[a]) -> ()) + (manyP (inCategory (categorize a))) {- | `optLike` consumes zero or more tokens of a given token's category while parsing, and produces the given token while printing. -} -optLike :: forall c p. (Distributor p, Tokenizor c p) => c -> p () () -optLike c = dimap (\_ -> [c]::[c]) (\(_::[c]) -> ()) - (manyP (inCategory (categorize c))) +optLike :: forall a p. (Distributor p, Tokenizor a p) => a -> p () () +optLike a = dimap (\_ -> [a]::[a]) (\(_::[a]) -> ()) + (manyP (inCategory (categorize a))) {- | `someLike` accepts one or more tokens of a given token's category while parsing, and produces the given token while printing. -} -someLike :: forall c p. (Distributor p, Tokenizor c p) => c -> p () () -someLike c = dimap (\_ -> (c,[]::[c])) (\(_::c, _::[c]) -> ()) - (inCategory (categorize c) >*< manyP (inCategory (categorize c))) +someLike :: forall a p. (Distributor p, Tokenizor a p) => a -> p () () +someLike a = dimap (\_ -> (a,[]::[a])) (\(_::a, _::[a]) -> ()) + (inCategory (categorize a) >*< manyP (inCategory (categorize a))) diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index 8bff4eb..8acd15c 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -1,7 +1,8 @@ module Control.Lens.Internal.Equator ( -- * Equator (..) - , equator + , is + , Identical ) where import Control.Lens @@ -28,8 +29,8 @@ instance (Equator a b p, Profunctor p, Applicative f) => Equator a b (WrappedPafb f p) where equate = WrapPafb (rmap pure equate) -equator - :: (Monoidal p, Cochoice p, Equator a a p, Eq a) - => [a] -> p () () -equator [] = oneP -equator (a:as) = only a ?< equate *> equator as +is + :: (Monoidal p, Cochoice p, Equator a a p, Eq a) + => [a] -> p () () +is [] = oneP +is (a:as) = only a ?< equate *> is as From 2b7e61c29317566d8a7433d489c5ca9a9c5b437a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 01:20:21 -0700 Subject: [PATCH 020/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index bd12c99..0c11e9a 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -7,7 +7,6 @@ module Control.Lens.Grammar -- , genGram , genShowS , genReadS - , BackusNaurForm (..) , Regular , Grammatical , Contextual From 596ee8b0a2dec20d2940d12eb4250082933e0d3b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 01:20:55 -0700 Subject: [PATCH 021/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 0c11e9a..cd39a8f 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -10,7 +10,6 @@ module Control.Lens.Grammar , Regular , Grammatical , Contextual - , NonTerminalSymbol (..) , RegEx (..) , regexGrammar , normRegEx From 8b31f858693abc397a6c143d8e26c0be2b520c6c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 11:12:47 -0700 Subject: [PATCH 022/282] more yet --- distributors.cabal | 2 +- src/Control/Lens/Bifocal.hs | 2 +- src/Control/Lens/Diopter.hs | 2 +- src/Control/Lens/Grammar/BackusNaur.hs | 8 ++-- .../Lens/{Internal => Grammar}/Equator.hs | 10 ++--- src/Control/Lens/Grammar/Symbol.hs | 2 +- src/Control/Lens/Grammar/Token.hs | 44 +++++++++---------- src/Control/Lens/Grate.hs | 2 +- src/Control/Lens/Monocle.hs | 2 +- src/Data/Profunctor/Syntax.hs | 18 ++++---- test/Spec.hs | 12 ++--- 11 files changed, 52 insertions(+), 52 deletions(-) rename src/Control/Lens/{Internal => Grammar}/Equator.hs (83%) diff --git a/distributors.cabal b/distributors.cabal index b1e3f7d..231c90a 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -32,12 +32,12 @@ library Control.Lens.Diopter Control.Lens.Grammar Control.Lens.Grammar.BackusNaur + Control.Lens.Grammar.Equator Control.Lens.Grammar.Kleene Control.Lens.Grammar.Stream Control.Lens.Grammar.Symbol Control.Lens.Grammar.Token Control.Lens.Grate - Control.Lens.Internal.Equator Control.Lens.Internal.NestedPrismTH Control.Lens.Monocle Control.Lens.PartialIso diff --git a/src/Control/Lens/Bifocal.hs b/src/Control/Lens/Bifocal.hs index 14e9699..18ccc76 100644 --- a/src/Control/Lens/Bifocal.hs +++ b/src/Control/Lens/Bifocal.hs @@ -34,7 +34,7 @@ module Control.Lens.Bifocal import Control.Applicative import Control.Lens -import Control.Lens.Internal.Equator +import Control.Lens.Grammar.Equator import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso import Control.Lens.Grammar.Stream diff --git a/src/Control/Lens/Diopter.hs b/src/Control/Lens/Diopter.hs index e487c3c..fdd92d8 100644 --- a/src/Control/Lens/Diopter.hs +++ b/src/Control/Lens/Diopter.hs @@ -25,7 +25,7 @@ module Control.Lens.Diopter ) where import Control.Lens -import Control.Lens.Internal.Equator +import Control.Lens.Grammar.Equator import Control.Lens.Internal.Profunctor import Data.Profunctor.Distributor import Data.Void diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index af32ba6..8395f3d 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -49,10 +49,10 @@ instance (Ord a, Tokenized a) => Tokenized (Gram a) where type Token (Gram a) = Token a anyToken = liftGram0 anyToken token = liftGram0 . token - inClass = liftGram0 . inClass - notInClass = liftGram0 . notInClass - inCategory = liftGram0 . inCategory - notInCategory = liftGram0 . notInCategory + oneOf = liftGram0 . oneOf + notOneOf = liftGram0 . notOneOf + asIn = liftGram0 . asIn + notAsIn = liftGram0 . notAsIn instance (Ord a, KleeneStarAlgebra a) => KleeneStarAlgebra (Gram a) where starK = liftGram1 starK diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Grammar/Equator.hs similarity index 83% rename from src/Control/Lens/Internal/Equator.hs rename to src/Control/Lens/Grammar/Equator.hs index 8acd15c..e84f49d 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Grammar/Equator.hs @@ -1,8 +1,8 @@ -module Control.Lens.Internal.Equator +module Control.Lens.Grammar.Equator ( -- * Equator (..) , is - , Identical + , Identical (..) ) where import Control.Lens @@ -14,9 +14,9 @@ import Control.Lens.PartialIso import Data.Profunctor import Data.Profunctor.Distributor -class Equator a b p | p -> a, p -> b where - equate :: p a b - default equate :: (Tokenizor c p, a ~ c, b ~ c) => p a b +class Equator i j p | p -> i, p -> i where + equate :: p i j + default equate :: (Tokenizor a p, i ~ a, j ~ a) => p i j equate = anyToken instance Equator a b (Identical a b) where equate = Identical instance Equator a b (Exchange a b) where diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index 7d737b1..470349f 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -4,7 +4,7 @@ module Control.Lens.Grammar.Symbol , NonTerminalSymbol (..) ) where -import Control.Lens.Internal.Equator +import Control.Lens.Grammar.Equator import Data.Kind import Data.Profunctor import Data.Profunctor.Distributor diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 7be0fa5..560ded5 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -44,38 +44,38 @@ class Categorized (Token p) => Tokenized p where => Token p -> p token = satisfy . token - inClass :: [Token p] -> p - default inClass + oneOf :: Foldable f => f (Token p) -> p + default oneOf :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) - => [Token p] -> p - inClass = satisfy . inClass + => Foldable f => f (Token p) -> p + oneOf = satisfy . oneOf - notInClass :: [Token p] -> p - default notInClass + notOneOf :: Foldable f => f (Token p) -> p + default notOneOf :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) - => [Token p] -> p - notInClass = satisfy . notInClass + => Foldable f => f (Token p) -> p + notOneOf = satisfy . notOneOf - inCategory :: Categorize (Token p) -> p - default inCategory + asIn :: Categorize (Token p) -> p + default asIn :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) => Categorize (Token p) -> p - inCategory = satisfy . inCategory + asIn = satisfy . asIn - notInCategory :: Categorize (Token p) -> p - default notInCategory + notAsIn :: Categorize (Token p) -> p + default notAsIn :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) => Categorize (Token p) -> p - notInCategory = satisfy . notInCategory + notAsIn = satisfy . notAsIn instance Categorized c => Tokenized (c -> Bool) where type Token (c -> Bool) = c anyToken _ = True token = (==) - inClass = flip elem - notInClass = flip notElem - inCategory = lmap categorize . (==) - notInCategory = lmap categorize . (/=) + oneOf = flip elem + notOneOf = flip notElem + asIn = lmap categorize . (==) + notAsIn = lmap categorize . (/=) satisfy :: (Choice p, Cochoice p, Tokenizor a p) @@ -102,7 +102,7 @@ of a given token's category while parsing, and produces the given token while printing. -} oneLike :: forall a p. (Profunctor p, Tokenizor a p) => a -> p () () -oneLike a = dimap (\_ -> a) (\(_::a) -> ()) (inCategory (categorize a)) +oneLike a = dimap (\_ -> a) (\(_::a) -> ()) (asIn (categorize a)) {- | `manyLike` consumes zero or more tokens @@ -111,7 +111,7 @@ and produces no tokens printing. -} manyLike :: forall a p. (Distributor p, Tokenizor a p) => a -> p () () manyLike a = dimap (\_ -> []::[a]) (\(_::[a]) -> ()) - (manyP (inCategory (categorize a))) + (manyP (asIn (categorize a))) {- | `optLike` consumes zero or more tokens @@ -120,7 +120,7 @@ and produces the given token while printing. -} optLike :: forall a p. (Distributor p, Tokenizor a p) => a -> p () () optLike a = dimap (\_ -> [a]::[a]) (\(_::[a]) -> ()) - (manyP (inCategory (categorize a))) + (manyP (asIn (categorize a))) {- | `someLike` accepts one or more tokens @@ -129,4 +129,4 @@ and produces the given token while printing. -} someLike :: forall a p. (Distributor p, Tokenizor a p) => a -> p () () someLike a = dimap (\_ -> (a,[]::[a])) (\(_::a, _::[a]) -> ()) - (inCategory (categorize a) >*< manyP (inCategory (categorize a))) + (asIn (categorize a) >*< manyP (asIn (categorize a))) diff --git a/src/Control/Lens/Grate.hs b/src/Control/Lens/Grate.hs index 7a743a1..56bc9ca 100644 --- a/src/Control/Lens/Grate.hs +++ b/src/Control/Lens/Grate.hs @@ -30,7 +30,7 @@ module Control.Lens.Grate , Grating (..) ) where -import Control.Lens.Internal.Equator +import Control.Lens.Grammar.Equator import Data.Distributive import Data.Function import Data.Functor.Identity diff --git a/src/Control/Lens/Monocle.hs b/src/Control/Lens/Monocle.hs index 2ca1ce1..ad76b18 100644 --- a/src/Control/Lens/Monocle.hs +++ b/src/Control/Lens/Monocle.hs @@ -27,7 +27,7 @@ module Control.Lens.Monocle ) where import Control.Lens hiding (Traversing) -import Control.Lens.Internal.Equator +import Control.Lens.Grammar.Equator import Control.Lens.Internal.Profunctor import Data.Distributive import Data.Profunctor.Distributor diff --git a/src/Data/Profunctor/Syntax.hs b/src/Data/Profunctor/Syntax.hs index 61b5da9..22ed971 100644 --- a/src/Data/Profunctor/Syntax.hs +++ b/src/Data/Profunctor/Syntax.hs @@ -13,7 +13,7 @@ import Control.Applicative import Control.Arrow import Control.Category import Control.Lens -import Control.Lens.Internal.Equator +import Control.Lens.Grammar.Equator import Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Stream @@ -90,10 +90,10 @@ instance (Tokenized r, Categorized c, Token r ~ c) type Token (InvariantP r c c) = Token r anyToken = InvariantP anyToken token = InvariantP . token - inClass = InvariantP . inClass - notInClass = InvariantP . notInClass - inCategory = InvariantP . inCategory - notInCategory = InvariantP . notInCategory + oneOf = InvariantP . oneOf + notOneOf = InvariantP . notOneOf + asIn = InvariantP . asIn + notAsIn = InvariantP . notAsIn instance BackusNaurForm p => BackusNaurForm (InvariantP p a b) where rule name = InvariantP . rule name . runInvariantP ruleRec name @@ -350,7 +350,7 @@ instance (Tokenized t, Categorized c, Token t ~ c, Applicative f) type Token (SyntaxP s t f c c) = Token t anyToken = SyntaxP (pure (pure anyToken)) token = SyntaxP . pure . pure . token - inClass = SyntaxP . pure . pure . inClass - notInClass = SyntaxP . pure . pure . notInClass - inCategory = SyntaxP . pure . pure . inCategory - notInCategory = SyntaxP . pure . pure . notInCategory + oneOf = SyntaxP . pure . pure . oneOf + notOneOf = SyntaxP . pure . pure . notOneOf + asIn = SyntaxP . pure . pure . asIn + notAsIn = SyntaxP . pure . pure . notAsIn diff --git a/test/Spec.hs b/test/Spec.hs index 311c6cf..7012295 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -16,8 +16,8 @@ expectedRegexGrammar = ,("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 "$()*+.?[\\]^{|}") + ,("char-escaped",Sequence (Terminal "\\") (OneOf "$()*+.?[\\]^{|}")) + ,("char-literal",NotOneOf "$()*+.?[\\]^{|}") ,("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")) @@ -42,10 +42,10 @@ regexExamples = , (KleeneStar (Terminal "x"), "x*") , (KleenePlus (Terminal "x"), "x+") , (AnyChar, ".") - , (InClass "abc", "[abc]") - , (NotInClass "abc", "[^abc]") - , (InCategory UppercaseLetter, "\\p{Lu}") - , (NotInCategory LowercaseLetter, "\\P{Ll}") + , (OneOf "abc", "[abc]") + , (NotOneOf "abc", "[^abc]") + , (AsIn UppercaseLetter, "\\p{Lu}") + , (NotAsIn LowercaseLetter, "\\P{Ll}") , (NonTerminal "rule-name", "\\q{rule-name}") , (Terminal "", "") ] From 9ff670aceffb69e3989d10c456a9a68a114f0eee Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 13:25:45 -0700 Subject: [PATCH 023/282] more granulation --- blog.md | 4 +- distributors.cabal | 6 +- src/Control/Lens/Bifocal.hs | 1 + src/Control/Lens/Grammar.hs | 120 +++---- src/Control/Lens/Grammar/Equator.hs | 2 +- src/Control/Lens/Grammar/Stream.hs | 4 +- src/Control/Lens/Grammar/Symbol.hs | 2 +- src/Control/Lens/Grammar/Token.hs | 1 + src/Control/Lens/Grate.hs | 2 +- src/Control/Lens/Monocle.hs | 2 +- src/Control/Lens/PartialIso.hs | 12 +- src/Data/Profunctor/Distributor.hs | 292 +----------------- src/Data/Profunctor/{Monadic => }/Do.hs | 4 +- src/Data/Profunctor/Filtrator.hs | 66 ++++ src/Data/Profunctor/{Syntax.hs => Grammar.hs} | 151 +++------ src/Data/Profunctor/Monoidal.hs | 237 ++++++++++++++ 16 files changed, 453 insertions(+), 453 deletions(-) rename src/Data/Profunctor/{Monadic => }/Do.hs (88%) create mode 100644 src/Data/Profunctor/Filtrator.hs rename src/Data/Profunctor/{Syntax.hs => Grammar.hs} (68%) create mode 100644 src/Data/Profunctor/Monoidal.hs diff --git a/blog.md b/blog.md index 30caca7..e4c6a40 100644 --- a/blog.md +++ b/blog.md @@ -368,12 +368,12 @@ Just as `Alternative` has 0-or-more `many` and 0-or-1 `optional` combinators, we ```Haskell optionalP :: Distributor p => p a b -> p (Maybe a) (Maybe b) -optionalP p = mapIso maybeEot (oneP >+< p) +optionalP p = mapIso eotMaybe (oneP >+< p) manyP :: p a b -> p [a] [b] manyP p = mapIso listEot (oneP >+< p >*< manyP p) -maybeEot :: Iso (Maybe a) (Maybe b) (Either () a) (Either () b) +eotMaybe :: Iso (Maybe a) (Maybe b) (Either () a) (Either () b) listEot :: (Cons s s a a, AsEmpty t, Cons t t b b) diff --git a/distributors.cabal b/distributors.cabal index 231c90a..d89da68 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -43,9 +43,11 @@ library Control.Lens.PartialIso Control.Lens.Wither Data.Profunctor.Distributor + Data.Profunctor.Do + Data.Profunctor.Filtrator + Data.Profunctor.Grammar Data.Profunctor.Monadic - Data.Profunctor.Monadic.Do - Data.Profunctor.Syntax + Data.Profunctor.Monoidal other-modules: Paths_distributors autogen-modules: diff --git a/src/Control/Lens/Bifocal.hs b/src/Control/Lens/Bifocal.hs index 18ccc76..887f39f 100644 --- a/src/Control/Lens/Bifocal.hs +++ b/src/Control/Lens/Bifocal.hs @@ -40,6 +40,7 @@ import Control.Lens.PartialIso import Control.Lens.Grammar.Stream import Data.Profunctor import Data.Profunctor.Distributor +import Data.Profunctor.Filtrator import Witherable {- | `Bifocal`s are bidirectional parser optics. diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index cd39a8f..f307eab 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -3,8 +3,13 @@ module Control.Lens.Grammar RegGrammar , Grammar , CtxGrammar - -- , genRegEx - -- , genGram + , opticGrammar + , grammarOptic + , RegGrammarr + , Grammarr + , CtxGrammarr + , opticGrammarr + , grammarrOptic , genShowS , genReadS , Regular @@ -24,9 +29,12 @@ import Control.Lens.Grammar.Token import Control.Lens.Grammar.Stream import Control.Lens.Grammar.Symbol import Control.Monad +import qualified Data.Foldable as F import Data.Profunctor.Distributor +import Data.Profunctor.Filtrator import Data.Profunctor.Monadic -import Data.Profunctor.Syntax +import Data.Profunctor.Monoidal +import Data.Profunctor.Grammar import GHC.Exts import Witherable @@ -34,16 +42,21 @@ type RegGrammar c a = forall p. Regular c p => p a a type Grammar c a = forall p. Grammatical c p => p a a type CtxGrammar s a = forall p m. Contextual s m p => p s s m a a +opticGrammar :: Monoidal p => Optic' p Identity a () -> p a a +opticGrammar = ($ oneP) . opticGrammarr + +grammarOptic :: Monoidal p => p a a -> Optic' p Identity a () +grammarOptic = grammarrOptic . (*<) + +type RegGrammarr c a b = forall p. Regular c p => p a a -> p b b type Grammarr c a b = forall p. Grammatical c p => p a a -> p b b +type CtxGrammarr s a b = forall p m. Contextual s m p => p s s m a a -> p s s m b b --- genGram --- :: (Categorized c, Ord c, Ord (Categorize c)) --- => Grammar c a --- -> Gram (RegEx c) --- genGram = runInvariantP +opticGrammarr :: Profunctor p => Optic' p Identity b a -> p a a -> p b b +opticGrammarr = dimap (rmap Identity) (rmap runIdentity) --- genRegEx :: Categorized c => RegGrammar c a -> RegEx c --- genRegEx = runInvariantP +grammarrOptic :: Profunctor p => (p a a -> p b b) -> Optic' p Identity b a +grammarrOptic = dimap (rmap runIdentity) (rmap Identity) genShowS :: (Filterable m, MonadPlus m) @@ -71,52 +84,53 @@ type Contextual s m p = , Subtextual s m ) -data RegEx c - = Terminal [c] - | Sequence (RegEx c) (RegEx c) +data RegEx a + = Terminal [a] + | Sequence (RegEx a) (RegEx a) | Fail - | Alternate (RegEx c) (RegEx c) - | KleeneOpt (RegEx c) - | KleeneStar (RegEx c) - | KleenePlus (RegEx c) + | Alternate (RegEx a) (RegEx a) + | KleeneOpt (RegEx a) + | KleeneStar (RegEx a) + | KleenePlus (RegEx a) | AnyToken - | InClass [c] - | NotInClass [c] - | InCategory (Categorize c) - | NotInCategory (Categorize c) + | OneOf [a] + | NotOneOf [a] + | AsIn (Categorize a) + | NotAsIn (Categorize a) | NonTerminal String -normRegEx :: Categorized c => RegEx c -> RegEx c +normRegEx :: Categorized a => RegEx a -> RegEx a normRegEx = \case Sequence rex1 rex2 -> normRegEx rex1 <> normRegEx rex2 Alternate rex1 rex2 -> normRegEx rex1 `altK` normRegEx rex2 KleeneOpt rex -> optK (normRegEx rex) KleeneStar rex -> starK (normRegEx rex) KleenePlus rex -> plusK (normRegEx rex) + OneOf [a] -> token a rex -> rex -deriving stock instance Categorized c => Eq (RegEx c) +deriving stock instance Categorized a => Eq (RegEx a) deriving stock instance - (Categorized c, Ord c, Ord (Categorize c)) => Ord (RegEx c) + (Categorized a, Ord a, Ord (Categorize a)) => Ord (RegEx a) deriving stock instance - (Categorized c, Read c, Read (Categorize c)) => Read (RegEx c) + (Categorized a, Read a, Read (Categorize a)) => Read (RegEx a) deriving stock instance - (Categorized c, Show c, Show (Categorize c)) => Show (RegEx c) -instance TerminalSymbol (RegEx c) where - type Alphabet (RegEx c) = c - terminal = Terminal -instance Monoid a => TerminalSymbol (a, RegEx c) where - type Alphabet (a, RegEx c) = c + (Categorized a, Show a, Show (Categorize a)) => Show (RegEx a) +instance TerminalSymbol (RegEx a) where + type Alphabet (RegEx a) = a + terminal = Terminal . F.toList +instance Monoid a => TerminalSymbol (a, RegEx a) where + type Alphabet (a, RegEx a) = a terminal = pure . terminal -instance Categorized c => Tokenized (RegEx c) where - type Token (RegEx c) = c +instance Categorized a => Tokenized (RegEx a) where + type Token (RegEx a) = a anyToken = AnyToken - token c = Terminal [c] - inClass = InClass - notInClass = NotInClass - inCategory = InCategory - notInCategory = NotInCategory -instance Categorized c => Semigroup (RegEx c) where + token a = Terminal [a] + oneOf = OneOf . F.toList + notOneOf = NotOneOf . F.toList + asIn = AsIn + notAsIn = NotAsIn +instance Categorized a => Semigroup (RegEx a) where Terminal [] <> rex = rex rex <> Terminal [] = rex Fail <> _ = empK @@ -127,9 +141,9 @@ instance Categorized c => Semigroup (RegEx c) where rex0 <> KleeneStar rex1 | rex0 == rex1 = plusK rex1 rex0 <> rex1 = Sequence rex0 rex1 -instance Categorized c => Monoid (RegEx c) where +instance Categorized a => Monoid (RegEx a) where mempty = Terminal [] -instance Categorized c => KleeneStarAlgebra (RegEx c) where +instance Categorized a => KleeneStarAlgebra (RegEx a) where empK = Fail optK Fail = mempty optK (Terminal []) = mempty @@ -149,16 +163,13 @@ instance Categorized c => KleeneStarAlgebra (RegEx c) where Fail `altK` rex = rex rex0 `altK` rex1 | rex0 == rex1 = rex0 rex0 `altK` rex1 = Alternate rex0 rex1 -instance NonTerminalSymbol (RegEx c) where +instance NonTerminalSymbol (RegEx a) where nonTerminal = NonTerminal instance Applicative f - => TerminalSymbol (SyntaxP s (RegEx c) f () ()) where - type Alphabet (SyntaxP s (RegEx c) f () ()) = c - terminal = SyntaxP . pure . pure . terminal -instance TerminalSymbol (InvariantP (RegEx c) () ()) where - type Alphabet (InvariantP (RegEx c) () ()) = c - terminal = InvariantP . terminal + => TerminalSymbol (Grammor s (RegEx a) f () ()) where + type Alphabet (Grammor s (RegEx a) f () ()) = a + terminal = Grammor . pure . pure . terminal makeNestedPrisms ''RegEx makeNestedPrisms ''GeneralCategory @@ -216,24 +227,25 @@ regexGrammar = ruleRec "regex" $ \rex -> altG rex <|> _NotAssigned >?< terminal "Cn" categoryInG = rule "category-in" $ - _InCategory >?< terminal "\\p{" >* categoryG *< terminal "}" + _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" categoryNotInG = rule "category-not-in" $ - _NotInCategory >?< terminal "\\P{" >* categoryG *< terminal "}" + _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" charG = rule "char" $ charLiteralG <|> charEscapedG - charEscapedG = rule "char-escaped" $ terminal "\\" >* inClass charsReserved + charEscapedG = rule "char-escaped" $ terminal "\\" >* oneOf charsReserved - charLiteralG = rule "char-literal" $ notInClass charsReserved + charLiteralG = rule "char-literal" $ notOneOf charsReserved + charsReserved :: String charsReserved = "$()*+.?[\\]^{|}" classInG = rule "class-in" $ - _InClass >?< terminal "[" >* manyP charG *< terminal "]" + _OneOf >?< terminal "[" >* manyP charG *< terminal "]" classNotInG = rule "class-not-in" $ - _NotInClass >?< terminal "[^" >* manyP charG *< terminal "]" + _NotOneOf >?< terminal "[^" >* manyP charG *< terminal "]" exprG rex = rule "expression" $ terminalG diff --git a/src/Control/Lens/Grammar/Equator.hs b/src/Control/Lens/Grammar/Equator.hs index e84f49d..7a14dcb 100644 --- a/src/Control/Lens/Grammar/Equator.hs +++ b/src/Control/Lens/Grammar/Equator.hs @@ -12,7 +12,7 @@ import Control.Lens.Internal.Prism import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso import Data.Profunctor -import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal class Equator i j p | p -> i, p -> i where equate :: p i j diff --git a/src/Control/Lens/Grammar/Stream.hs b/src/Control/Lens/Grammar/Stream.hs index 7b39a7b..0d8e4a2 100644 --- a/src/Control/Lens/Grammar/Stream.hs +++ b/src/Control/Lens/Grammar/Stream.hs @@ -17,6 +17,8 @@ import Control.Lens import Control.Lens.PartialIso import Data.Profunctor import Data.Profunctor.Distributor +import Data.Profunctor.Filtrator +import Data.Profunctor.Monoidal import GHC.Exts type IsStream s = (IsList s, AsEmpty s, Cons s s (Item s) (Item s)) @@ -40,7 +42,7 @@ stream :: (Distributor p, IsStream s, IsStream t) => SepBy (p () ()) -> p (Item s) (Item t) -> p s t -stream (SepBy beg end sep) p = mapIso listEot $ +stream (SepBy beg end sep) p = mapIso eotList $ beg >* oneP >+< stream1 (sepBy sep) p *< end {- | diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index 470349f..d014335 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -7,7 +7,7 @@ module Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Equator import Data.Kind import Data.Profunctor -import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal type Terminator :: Type -> (Type -> Type -> Type) -> Constraint type Terminator a p = diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 560ded5..7692e17 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -19,6 +19,7 @@ import Control.Lens.PartialIso import Data.Char import Data.Profunctor import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal import Data.Word class (Eq a, Eq (Categorize a)) => Categorized a where diff --git a/src/Control/Lens/Grate.hs b/src/Control/Lens/Grate.hs index 56bc9ca..c1d42d4 100644 --- a/src/Control/Lens/Grate.hs +++ b/src/Control/Lens/Grate.hs @@ -36,7 +36,7 @@ import Data.Function import Data.Functor.Identity import Data.Functor.Rep import Data.Profunctor -import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal {- | `Grate`s are an optic that are dual to `Control.Lens.Traversal.Traversal`s, as `Distributive` is `Traversable`. diff --git a/src/Control/Lens/Monocle.hs b/src/Control/Lens/Monocle.hs index ad76b18..a76896f 100644 --- a/src/Control/Lens/Monocle.hs +++ b/src/Control/Lens/Monocle.hs @@ -30,7 +30,7 @@ import Control.Lens hiding (Traversing) import Control.Lens.Grammar.Equator import Control.Lens.Internal.Profunctor import Data.Distributive -import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal {- | `Monocle`s are an optic that generalizes `Control.Lens.Traversal.Traversal`s & `Control.Lens.Grate.Grate`s. diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index 5a78fdb..9fbeb7a 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -37,8 +37,8 @@ module Control.Lens.PartialIso , satisfied , nulled , notNulled - , maybeEot - , listEot + , eotMaybe + , eotList -- * Iterations , iterating , difoldl1 @@ -249,16 +249,16 @@ notNulled = partialIso nonEmp nonEmp where nonEmp s = if isn't _Empty s then Just s else Nothing {- | The either-of-tuples representation of `Maybe`. -} -maybeEot :: Iso (Maybe a) (Maybe b) (Either () a) (Either () b) -maybeEot = iso +eotMaybe :: Iso (Maybe a) (Maybe b) (Either () a) (Either () b) +eotMaybe = iso (maybe (Left ()) Right) (either (pure Nothing) Just) {- | The either-of-tuples representation of list-like streams. -} -listEot +eotList :: (Cons s s a a, AsEmpty t, Cons t t b b) => Iso s t (Either () (a,s)) (Either () (b,t)) -listEot = iso +eotList = iso (maybe (Left ()) Right . uncons) (either (const Empty) (review _Cons)) diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index a5eff88..3293e70 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -8,31 +8,25 @@ Stability : provisional Portability : non-portable -} -{-# OPTIONS_GHC -Wno-orphans #-} - module Data.Profunctor.Distributor - ( -- * Monoidal - Monoidal, oneP, (>*<), (>*), (*<), dimap2, foreverP, replicateP - , meander, (>:<), asEmpty - -- * Distributor - , Distributor (..), dialt, Homogeneous (homogeneously) - -- * Alternator/Filtrator - , Alternator (..), Filtrator (filtrate) + ( -- * Distributor + Distributor (..), dialt + -- * Alternator + , Alternator (..) + -- * Homogeneous + , Homogeneous (..) ) 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.Profunctor import Control.Lens.PartialIso -import Control.Monad 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 @@ -44,6 +38,7 @@ import Data.Profunctor qualified as Pro (WrappedArrow) import Data.Profunctor.Cayley import Data.Profunctor.Composition import Data.Profunctor.Monad +import Data.Profunctor.Monoidal import Data.Profunctor.Yoneda import Data.Proxy import Data.Sequence (Seq) @@ -52,113 +47,6 @@ import Data.Tree (Tree (..)) import Data.Vector (Vector) 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 second 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) - -{- | 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`, -though `Strong` is 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` nil operator. -} -asEmpty :: (AsEmpty s, Monoidal p, Choice p) => p s s -asEmpty = _Empty >? oneP - -{- | A `Monoidal` cons operator. -} -(>:<) :: (Cons s t a b, Monoidal p, Choice p) => p a b -> p s t -> p s t -x >:< xs = _Cons >? x >*< xs -infixr 5 >:< -- Distributor -- @@ -216,11 +104,11 @@ class Monoidal p => Distributor p where {- | One or none. -} optionalP :: p a b -> p (Maybe a) (Maybe b) - optionalP p = mapIso maybeEot (oneP >+< p) + optionalP p = mapIso eotMaybe (oneP >+< p) {- | Zero or more. -} manyP :: p a b -> p [a] [b] - manyP p = mapIso listEot (oneP >+< p >*< manyP p) + manyP p = mapIso eotList (oneP >+< p >*< manyP p) instance Distributor (->) where zeroP = id @@ -403,15 +291,15 @@ instance Homogeneous Maybe where instance Homogeneous [] where homogeneously = manyP instance Homogeneous Vector where - homogeneously p = mapIso listEot (oneP >+< p >*< homogeneously p) + homogeneously p = mapIso eotList (oneP >+< p >*< homogeneously p) instance Homogeneous Seq where - homogeneously p = mapIso listEot (oneP >+< p >*< homogeneously p) + homogeneously p = mapIso eotList (oneP >+< p >*< homogeneously p) instance Homogeneous Complex where homogeneously p = dimap2 realPart imagPart (:+) p p instance Homogeneous Tree where homogeneously p = dimap2 rootLabel subForest Node p (manyP (homogeneously p)) --- Alternator/Filtrator -- +-- Alternator -- {- | The `Alternator` class co-extends `Choice` and `Distributor`, as well as `Alternative`, adding the `alternate` method, @@ -474,159 +362,3 @@ 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 for `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 (Profunctor p, forall x. Functor (p x), Filterable f) - => Filtrator (WrappedPafb f p) where - filtrate (WrapPafb p) = - ( WrapPafb $ dimap Left (mapMaybe (either Just (const Nothing))) p - , WrapPafb $ dimap Right (mapMaybe (either (const Nothing) Just)) p - ) -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) - ) - --- 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 diff --git a/src/Data/Profunctor/Monadic/Do.hs b/src/Data/Profunctor/Do.hs similarity index 88% rename from src/Data/Profunctor/Monadic/Do.hs rename to src/Data/Profunctor/Do.hs index 057c2ae..6e288af 100644 --- a/src/Data/Profunctor/Monadic/Do.hs +++ b/src/Data/Profunctor/Do.hs @@ -1,5 +1,5 @@ {-| -Module : Data.Profunctor.Monadic.Do +Module : Data.Profunctor.Do Description : overloaded do-notation Copyright : (C) 2025 - Eitan Chatav License : BSD-style (see the file LICENSE) @@ -8,7 +8,7 @@ Stability : provisional Portability : non-portable -} -module Data.Profunctor.Monadic.Do +module Data.Profunctor.Do ( -- * (>>=) , (>>) diff --git a/src/Data/Profunctor/Filtrator.hs b/src/Data/Profunctor/Filtrator.hs new file mode 100644 index 0000000..86a32b6 --- /dev/null +++ b/src/Data/Profunctor/Filtrator.hs @@ -0,0 +1,66 @@ +module Data.Profunctor.Filtrator + ( Filtrator (filtrate) + ) where + +import Control.Arrow +import Control.Lens.PartialIso +import Control.Lens.Internal.Profunctor +import Control.Monad +import Data.Profunctor +import Data.Profunctor.Monad +import Data.Profunctor.Yoneda +import Witherable + +{- | 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 for `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 (Profunctor p, forall x. Functor (p x), Filterable f) + => Filtrator (WrappedPafb f p) where + filtrate (WrapPafb p) = + ( WrapPafb $ dimap Left (mapMaybe (either Just (const Nothing))) p + , WrapPafb $ dimap Right (mapMaybe (either (const Nothing) Just)) p + ) +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) + ) diff --git a/src/Data/Profunctor/Syntax.hs b/src/Data/Profunctor/Grammar.hs similarity index 68% rename from src/Data/Profunctor/Syntax.hs rename to src/Data/Profunctor/Grammar.hs index 22ed971..4cbda74 100644 --- a/src/Data/Profunctor/Syntax.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -1,9 +1,8 @@ -module Data.Profunctor.Syntax - ( InvariantP (..) - , Parsor (..) +module Data.Profunctor.Grammar + ( Parsor (..) , Printor (..) , Lintor (..) - , SyntaxP (..) + , Grammor (..) , toPrintor , fromPrintor , Subtextual @@ -25,17 +24,18 @@ import Data.Coerce import Data.Monoid import Data.Profunctor import Data.Profunctor.Distributor +import Data.Profunctor.Filtrator import Data.Profunctor.Monadic +import Data.Profunctor.Monoidal import Data.Void import Prelude hiding (id, (.)) import GHC.Exts import Witherable -newtype InvariantP r a b = InvariantP {runInvariantP :: r} newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} newtype Lintor s t f a b = Lintor {runLintor :: a -> f (b, s -> t)} -newtype SyntaxP s t f a b = SyntaxP {runSyntaxP :: s -> f t} +newtype Grammor s t f a b = Grammor {runGrammor :: s -> f t} toPrintor :: Functor f => Lintor s t f a b -> Printor s t f a b toPrintor (Lintor f) = Printor (fmap snd . f) @@ -48,59 +48,6 @@ type Subtextual s m = , Alternative m, Filterable m, Monad m ) -instance Functor (InvariantP r a) where fmap _ = coerce -instance Contravariant (InvariantP r a) where contramap _ = coerce -instance Profunctor (InvariantP r) where dimap _ _ = coerce -instance Bifunctor (InvariantP r) where bimap _ _ = coerce -instance Choice (InvariantP r) where - left' = coerce - right' = coerce -subsetOf - :: InvariantP (rules, (All, start)) a b - -> InvariantP (rules, (All, start)) s t -subsetOf (InvariantP (rules, (_, start))) = - InvariantP (rules, ((All False), start)) -instance Filterable (InvariantP (rules, (All, start)) x) where - mapMaybe _ = subsetOf -instance Cochoice (InvariantP (rules, (All, start))) where - unleft = subsetOf -instance Filtrator (InvariantP (rules, (All, start))) where - filtrate p = (subsetOf p, subsetOf p) -instance Monoid r => Applicative (InvariantP r a) where - pure _ = InvariantP mempty - InvariantP rex1 <*> InvariantP rex2 = - InvariantP (rex1 <> rex2) -instance KleeneStarAlgebra r => Alternative (InvariantP r a) where - empty = InvariantP empK - InvariantP rex1 <|> InvariantP rex2 = - InvariantP (rex1 `altK` rex2) - many (InvariantP rex) = InvariantP (starK rex) - some (InvariantP rex) = InvariantP (plusK rex) -instance KleeneStarAlgebra r => Distributor (InvariantP r) where - zeroP = InvariantP empK - InvariantP rex1 >+< InvariantP rex2 = - InvariantP (rex1 `altK` rex2) - manyP (InvariantP rex) = InvariantP (starK rex) - optionalP (InvariantP rex) = InvariantP (optK rex) -instance KleeneStarAlgebra r => Alternator (InvariantP r) where - alternate = either coerce coerce - someP (InvariantP rex) = InvariantP (plusK rex) -instance (Tokenized r, Categorized c, Token r ~ c) - => Tokenized (InvariantP r c c) where - type Token (InvariantP r c c) = Token r - anyToken = InvariantP anyToken - token = InvariantP . token - oneOf = InvariantP . oneOf - notOneOf = InvariantP . notOneOf - asIn = InvariantP . asIn - notAsIn = InvariantP . notAsIn -instance BackusNaurForm p => BackusNaurForm (InvariantP p a b) where - rule name = InvariantP . rule name . runInvariantP - ruleRec name - = InvariantP - . ruleRec name - . dimap InvariantP runInvariantP - instance Functor f => Functor (Parsor s t f a) where fmap f = Parsor . fmap (fmap (first' f)) . runParsor instance Functor f => Bifunctor (Parsor s t f) where @@ -305,52 +252,52 @@ instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m () ()) where instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m s s) where fromString = tokens -instance Functor (SyntaxP s t f a) where fmap _ = coerce -instance Contravariant (SyntaxP s t f a) where contramap _ = coerce -instance Profunctor (SyntaxP s t f) where dimap _ _ = coerce -instance Bifunctor (SyntaxP s t f) where bimap _ _ = coerce -instance Functor f => Tetradic f SyntaxP where - dimapT f g = SyntaxP . dimap f (fmap g) . runSyntaxP - tetramap f g _ _ = SyntaxP . dimap f (fmap g) . runSyntaxP -instance Choice (SyntaxP s t f) where +instance Functor (Grammor s t f a) where fmap _ = coerce +instance Contravariant (Grammor s t f a) where contramap _ = coerce +instance Profunctor (Grammor s t f) where dimap _ _ = coerce +instance Bifunctor (Grammor s t f) where bimap _ _ = coerce +instance Functor f => Tetradic f Grammor where + dimapT f g = Grammor . dimap f (fmap g) . runGrammor + tetramap f g _ _ = Grammor . dimap f (fmap g) . runGrammor +instance Choice (Grammor s t f) where left' = coerce right' = coerce -instance Functor f => Filterable (SyntaxP s All f a) where - mapMaybe _ = SyntaxP . fmap (fmap (pure (All False))) . runSyntaxP -instance Functor f => Cochoice (SyntaxP s All f) where - unleft = SyntaxP . fmap (fmap (pure (All False))) . runSyntaxP - unright = SyntaxP . fmap (fmap (pure (All False))) . runSyntaxP -instance Functor f => Filtrator (SyntaxP s All f) where - filtrate (SyntaxP p) = - ( SyntaxP (fmap (fmap (pure (All False))) p) - , SyntaxP (fmap (fmap (pure (All False))) p) +instance Functor f => Filterable (Grammor s All f a) where + mapMaybe _ = Grammor . fmap (fmap (pure (All False))) . runGrammor +instance Functor f => Cochoice (Grammor s All f) where + unleft = Grammor . fmap (fmap (pure (All False))) . runGrammor + unright = Grammor . fmap (fmap (pure (All False))) . runGrammor +instance Functor f => Filtrator (Grammor s All f) where + filtrate (Grammor p) = + ( Grammor (fmap (fmap (pure (All False))) p) + , Grammor (fmap (fmap (pure (All False))) p) ) instance (Monoid t, Applicative f) - => Applicative (SyntaxP s t f a) where - pure _ = SyntaxP (pure (pure mempty)) - SyntaxP rex1 <*> SyntaxP rex2 = - SyntaxP (liftA2 (liftA2 (<>)) rex1 rex2) -instance (KleeneStarAlgebra t, Applicative f) => Alternative (SyntaxP s t f a) where - empty = SyntaxP (pure (pure empK)) - SyntaxP rex1 <|> SyntaxP rex2 = - SyntaxP (liftA2 (liftA2 altK) rex1 rex2) - many (SyntaxP rex) = SyntaxP (fmap (fmap starK) rex) - some (SyntaxP rex) = SyntaxP (fmap (fmap plusK) rex) -instance (KleeneStarAlgebra t, Applicative f) => Distributor (SyntaxP s t f) where - zeroP = SyntaxP (pure (pure empK)) - SyntaxP rex1 >+< SyntaxP rex2 = - SyntaxP (liftA2 (liftA2 altK) rex1 rex2) - manyP (SyntaxP rex) = SyntaxP (fmap (fmap starK) rex) - optionalP (SyntaxP rex) = SyntaxP (fmap (fmap optK) rex) -instance (KleeneStarAlgebra t, Applicative f) => Alternator (SyntaxP s t f) where + => Applicative (Grammor s t f a) where + pure _ = Grammor (pure (pure mempty)) + Grammor rex1 <*> Grammor rex2 = + Grammor (liftA2 (liftA2 (<>)) rex1 rex2) +instance (KleeneStarAlgebra t, Applicative f) => Alternative (Grammor s t f a) where + empty = Grammor (pure (pure empK)) + Grammor rex1 <|> Grammor rex2 = + Grammor (liftA2 (liftA2 altK) rex1 rex2) + many (Grammor rex) = Grammor (fmap (fmap starK) rex) + some (Grammor rex) = Grammor (fmap (fmap plusK) rex) +instance (KleeneStarAlgebra t, Applicative f) => Distributor (Grammor s t f) where + zeroP = Grammor (pure (pure empK)) + Grammor rex1 >+< Grammor rex2 = + Grammor (liftA2 (liftA2 altK) rex1 rex2) + manyP (Grammor rex) = Grammor (fmap (fmap starK) rex) + optionalP (Grammor rex) = Grammor (fmap (fmap optK) rex) +instance (KleeneStarAlgebra t, Applicative f) => Alternator (Grammor s t f) where alternate = either coerce coerce - someP (SyntaxP rex) = SyntaxP (fmap (fmap plusK) rex) + someP (Grammor rex) = Grammor (fmap (fmap plusK) rex) instance (Tokenized t, Categorized c, Token t ~ c, Applicative f) - => Tokenized (SyntaxP s t f c c) where - type Token (SyntaxP s t f c c) = Token t - anyToken = SyntaxP (pure (pure anyToken)) - token = SyntaxP . pure . pure . token - oneOf = SyntaxP . pure . pure . oneOf - notOneOf = SyntaxP . pure . pure . notOneOf - asIn = SyntaxP . pure . pure . asIn - notAsIn = SyntaxP . pure . pure . notAsIn + => Tokenized (Grammor s t f c c) where + type Token (Grammor s t f c c) = Token t + anyToken = Grammor (pure (pure anyToken)) + token = Grammor . pure . pure . token + oneOf = Grammor . pure . pure . oneOf + notOneOf = Grammor . pure . pure . notOneOf + asIn = Grammor . pure . pure . asIn + notAsIn = Grammor . pure . pure . notAsIn diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs new file mode 100644 index 0000000..6156715 --- /dev/null +++ b/src/Data/Profunctor/Monoidal.hs @@ -0,0 +1,237 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Data.Profunctor.Monoidal + ( -- * Monoidal + Monoidal + , oneP, (>*<), (>*), (*<) + , dimap2, foreverP, replicateP + , meander, (>:<), asEmpty + ) 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.Profunctor +import Control.Lens.PartialIso +import Data.Bifunctor.Clown +import Data.Bifunctor.Joker +import Data.Bifunctor.Product +import Data.Distributive +import Data.Functor.Compose +import Data.Functor.Contravariant.Divisible +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 + +-- 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 second 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) + +{- | 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`, +though `Strong` is 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` nil operator. -} +asEmpty :: (AsEmpty s, Monoidal p, Choice p) => p s s +asEmpty = _Empty >? oneP + +{- | A `Monoidal` cons operator. -} +(>:<) :: (Cons s t a b, Monoidal p, Choice p) => p a b -> p s t -> p s t +x >:< xs = _Cons >? x >*< xs +infixr 5 >:< + +-- 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 From 379e4609aff1ab7b791b04966c27e83f90a19718 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 14:14:06 -0700 Subject: [PATCH 024/282] golf --- src/Control/Lens/Grammar.hs | 21 --------------------- src/Control/Lens/Grammar/Symbol.hs | 3 +-- 2 files changed, 1 insertion(+), 23 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index f307eab..7027ac6 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -177,12 +177,9 @@ makeNestedPrisms ''GeneralCategory regexGrammar :: Grammar Char (RegEx Char) regexGrammar = ruleRec "regex" $ \rex -> altG rex where - altG rex = rule "alternate" $ chain1 Left _Alternate (sepBy (terminal "|")) (seqG rex) - anyG = rule "any" $ _AnyToken >?< terminal "." - atomG rex = rule "atom" $ nonterminalG <|> failG @@ -193,7 +190,6 @@ regexGrammar = ruleRec "regex" $ \rex -> altG rex <|> _Terminal >?< charG >:< pure "" <|> anyG <|> parenG rex - categoryG = rule "category" $ _LowercaseLetter >?< terminal "Ll" <|> _UppercaseLetter >?< terminal "Lu" @@ -225,55 +221,38 @@ regexGrammar = ruleRec "regex" $ \rex -> altG rex <|> _Surrogate >?< terminal "Cs" <|> _PrivateUse >?< terminal "Co" <|> _NotAssigned >?< terminal "Cn" - categoryInG = rule "category-in" $ _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" - categoryNotInG = rule "category-not-in" $ _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" - charG = rule "char" $ charLiteralG <|> charEscapedG - charEscapedG = rule "char-escaped" $ terminal "\\" >* oneOf charsReserved - charLiteralG = rule "char-literal" $ notOneOf charsReserved - charsReserved :: String charsReserved = "$()*+.?[\\]^{|}" - classInG = rule "class-in" $ _OneOf >?< terminal "[" >* manyP charG *< terminal "]" - classNotInG = rule "class-not-in" $ _NotOneOf >?< terminal "[^" >* manyP charG *< terminal "]" - exprG rex = rule "expression" $ terminalG <|> kleeneOptG rex <|> kleeneStarG rex <|> kleenePlusG rex <|> atomG rex - failG = rule "fail" $ _Fail >?< terminal "\\q" - nonterminalG = rule "nonterminal" $ _NonTerminal >?< terminal "\\q{" >* manyP charG *< terminal "}" - parenG :: Grammarr Char x x parenG ex = rule "parenthesized" $ terminal "(" >* ex *< terminal ")" - kleeneOptG rex = rule "kleene-optional" $ _KleeneOpt >?< atomG rex *< terminal "?" - kleeneStarG rex = rule "kleene-star" $ _KleeneStar >?< atomG rex *< terminal "*" - kleenePlusG rex = rule "kleene-plus" $ _KleenePlus >?< atomG rex *< terminal "+" - seqG rex = rule "sequence" $ chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) - terminalG = rule "terminal" $ _Terminal >?< someP charG diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index d014335..ab7abb0 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -9,11 +9,10 @@ import Data.Kind import Data.Profunctor import Data.Profunctor.Monoidal -type Terminator :: Type -> (Type -> Type -> Type) -> Constraint type Terminator a p = ( a ~ Alphabet (p () ()) , forall x y. (x ~ (), y ~ ()) => TerminalSymbol (p x y) - ) + ) :: Constraint class TerminalSymbol s where type Alphabet s From bbeca57e5c4b6e8e554fc377abf33989bb122c2b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 14:31:19 -0700 Subject: [PATCH 025/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 27 +++++++++------------------ 1 file changed, 9 insertions(+), 18 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 7027ac6..3e76573 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -17,7 +17,6 @@ module Control.Lens.Grammar , Contextual , RegEx (..) , regexGrammar - , normRegEx ) where import Control.Applicative @@ -29,6 +28,7 @@ import Control.Lens.Grammar.Token import Control.Lens.Grammar.Stream import Control.Lens.Grammar.Symbol import Control.Monad +import Data.Maybe import qualified Data.Foldable as F import Data.Profunctor.Distributor import Data.Profunctor.Filtrator @@ -99,23 +99,9 @@ data RegEx a | NotAsIn (Categorize a) | NonTerminal String -normRegEx :: Categorized a => RegEx a -> RegEx a -normRegEx = \case - Sequence rex1 rex2 -> normRegEx rex1 <> normRegEx rex2 - Alternate rex1 rex2 -> normRegEx rex1 `altK` normRegEx rex2 - KleeneOpt rex -> optK (normRegEx rex) - KleeneStar rex -> starK (normRegEx rex) - KleenePlus rex -> plusK (normRegEx rex) - OneOf [a] -> token a - rex -> rex - deriving stock instance Categorized a => Eq (RegEx a) deriving stock instance (Categorized a, Ord a, Ord (Categorize a)) => Ord (RegEx a) -deriving stock instance - (Categorized a, Read a, Read (Categorize a)) => Read (RegEx a) -deriving stock instance - (Categorized a, Show a, Show (Categorize a)) => Show (RegEx a) instance TerminalSymbol (RegEx a) where type Alphabet (RegEx a) = a terminal = Terminal . F.toList @@ -226,7 +212,8 @@ regexGrammar = ruleRec "regex" $ \rex -> altG rex categoryNotInG = rule "category-not-in" $ _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" charG = rule "char" $ charLiteralG <|> charEscapedG - charEscapedG = rule "char-escaped" $ terminal "\\" >* oneOf charsReserved + charEscapedG = rule "char-escaped" $ + terminal "\\" >* oneOf charsReserved charLiteralG = rule "char-literal" $ notOneOf charsReserved charsReserved :: String charsReserved = "$()*+.?[\\]^{|}" @@ -254,5 +241,9 @@ regexGrammar = ruleRec "regex" $ \rex -> altG rex _KleenePlus >?< atomG rex *< terminal "+" seqG rex = rule "sequence" $ chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) - terminalG = rule "terminal" $ - _Terminal >?< someP charG + terminalG = rule "terminal" $ _Terminal >?< someP charG + +instance Show (RegEx Char) where + showsPrec _ = fromMaybe ("\\q" <>) . genShowS regexGrammar +instance Read (RegEx Char) where + readsPrec _ = genReadS regexGrammar From 6de288f89acd8c5235c5e95144e02cfb9a1b0219 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 14:39:09 -0700 Subject: [PATCH 026/282] Update Monoidal.hs --- src/Data/Profunctor/Monoidal.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index 6156715..cd4468d 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -36,15 +36,14 @@ 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) +prop> dimap (f >*< g) (h >*< i) (p >*< q) = dimap f h p >*< dimap g i q -} type Monoidal p = (Profunctor p, forall x. Applicative (p x)) From 94657f8dff86327a59e0406ce364896ed19af63c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 14:42:40 -0700 Subject: [PATCH 027/282] Update Distributor.hs --- src/Data/Profunctor/Distributor.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index 3293e70..9559b14 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -62,19 +62,18 @@ sum laws for `Distributor`. Laws: +>>> let lunit = dimap (either absurd id) Right +>>> let runit = dimap (either id absurd) Left >>> :{ -let f |+| g = either (Left . f) (Right . g) - lunit = dimap (either absurd id) Right - runit = dimap (either id absurd) Left - assoc = dimap +let 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) +prop> dimap (f >+< g) (h >+< i) (p >+< q) = dimap f h p >+< dimap g i q -} class Monoidal p => Distributor p where From 0e973ff61b275ff6aa053e7d2c191516fec27c65 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 14:57:31 -0700 Subject: [PATCH 028/282] >|< --- src/Control/Lens/Grammar.hs | 16 ++++++++-------- src/Control/Lens/Grammar/BackusNaur.hs | 2 +- src/Control/Lens/Grammar/Kleene.hs | 2 +- src/Data/Profunctor/Grammar.hs | 4 ++-- 4 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 3e76573..fd3ce22 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -141,14 +141,14 @@ instance Categorized a => KleeneStarAlgebra (RegEx a) where plusK Fail = empK plusK (Terminal []) = mempty plusK rex = KleenePlus rex - KleenePlus rex `altK` Terminal [] = starK rex - Terminal [] `altK` KleenePlus rex = starK rex - rex `altK` Terminal [] = optK rex - Terminal [] `altK` rex = optK rex - rex `altK` Fail = rex - Fail `altK` rex = rex - rex0 `altK` rex1 | rex0 == rex1 = rex0 - rex0 `altK` rex1 = Alternate 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 instance NonTerminalSymbol (RegEx a) where nonTerminal = NonTerminal diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 8395f3d..dbc67ea 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -59,7 +59,7 @@ instance (Ord a, KleeneStarAlgebra a) => KleeneStarAlgebra (Gram a) where plusK = liftGram1 plusK optK = liftGram1 optK empK = liftGram0 empK - altK = liftGram2 altK + (>|<) = liftGram2 (>|<) instance (Ord a, Monoid a) => Monoid (Gram a) where mempty = liftGram0 mempty instance (Ord a, Semigroup a) => Semigroup (Gram a) where diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index b7f6e1e..53fc616 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -6,5 +6,5 @@ class Monoid a => KleeneStarAlgebra a where starK :: a -> a plusK :: a -> a optK :: a -> a - altK :: a -> a -> a + (>|<) :: a -> a -> a empK :: a diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 4cbda74..3d04ab2 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -280,13 +280,13 @@ instance (Monoid t, Applicative f) instance (KleeneStarAlgebra t, Applicative f) => Alternative (Grammor s t f a) where empty = Grammor (pure (pure empK)) Grammor rex1 <|> Grammor rex2 = - Grammor (liftA2 (liftA2 altK) rex1 rex2) + Grammor (liftA2 (liftA2 (>|<)) rex1 rex2) many (Grammor rex) = Grammor (fmap (fmap starK) rex) some (Grammor rex) = Grammor (fmap (fmap plusK) rex) instance (KleeneStarAlgebra t, Applicative f) => Distributor (Grammor s t f) where zeroP = Grammor (pure (pure empK)) Grammor rex1 >+< Grammor rex2 = - Grammor (liftA2 (liftA2 altK) rex1 rex2) + Grammor (liftA2 (liftA2 (>|<)) rex1 rex2) manyP (Grammor rex) = Grammor (fmap (fmap starK) rex) optionalP (Grammor rex) = Grammor (fmap (fmap optK) rex) instance (KleeneStarAlgebra t, Applicative f) => Alternator (Grammor s t f) where From b5418caac0037788bf0a41a3c1c079a92e0162ff Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 14:59:50 -0700 Subject: [PATCH 029/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 7692e17..19aaea1 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -45,16 +45,16 @@ class Categorized (Token p) => Tokenized p where => Token p -> p token = satisfy . token - oneOf :: Foldable f => f (Token p) -> p + oneOf :: [Token p] -> p default oneOf :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) - => Foldable f => f (Token p) -> p + => [Token p] -> p oneOf = satisfy . oneOf - notOneOf :: Foldable f => f (Token p) -> p + notOneOf :: [Token p] -> p default notOneOf :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) - => Foldable f => f (Token p) -> p + => [Token p] -> p notOneOf = satisfy . notOneOf asIn :: Categorize (Token p) -> p From 5e26c76d84890dd994d58234688da674205fbb4a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 15:04:00 -0700 Subject: [PATCH 030/282] choiceP --- src/Data/Profunctor/Distributor.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index 9559b14..eebc6ce 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -13,6 +13,7 @@ module Data.Profunctor.Distributor Distributor (..), dialt -- * Alternator , Alternator (..) + , choiceP -- * Homogeneous , Homogeneous (..) ) where @@ -27,6 +28,7 @@ import Data.Bifunctor.Clown import Data.Bifunctor.Joker import Data.Bifunctor.Product import Data.Complex +import Data.Foldable import Data.Functor.Adjunction import Data.Functor.Compose import Data.Functor.Contravariant.Divisible @@ -335,6 +337,9 @@ class (Choice p, Distributor p, forall x. Alternative (p x)) someP :: p a b -> p [a] [b] someP p = _Cons >? p >*< manyP p +choiceP :: (Foldable f, Alternator p) => f (p a b) -> p a b +choiceP = foldl' (<|>) empty + instance (Alternator p, Applicative f) => Alternator (WrappedPafb f p) where alternate = From 4087b9426b8d01b9bc33207357e9794ead7cae9e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 16:43:26 -0700 Subject: [PATCH 031/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 112 ++++++++++++++++++++---------------- 1 file changed, 63 insertions(+), 49 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index fd3ce22..115fab5 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -35,7 +35,9 @@ import Data.Profunctor.Filtrator import Data.Profunctor.Monadic import Data.Profunctor.Monoidal import Data.Profunctor.Grammar +import Data.String import GHC.Exts +import Prelude hiding (filter) import Witherable type RegGrammar c a = forall p. Regular c p => p a a @@ -166,47 +168,49 @@ regexGrammar = ruleRec "regex" $ \rex -> altG rex altG rex = rule "alternate" $ chain1 Left _Alternate (sepBy (terminal "|")) (seqG rex) anyG = rule "any" $ _AnyToken >?< terminal "." - atomG rex = rule "atom" $ - nonterminalG - <|> failG - <|> classInG - <|> classNotInG - <|> categoryInG - <|> categoryNotInG - <|> _Terminal >?< charG >:< pure "" - <|> anyG - <|> parenG rex - categoryG = rule "category" $ - _LowercaseLetter >?< terminal "Ll" - <|> _UppercaseLetter >?< terminal "Lu" - <|> _TitlecaseLetter >?< terminal "Lt" - <|> _ModifierLetter >?< terminal "Lm" - <|> _OtherLetter >?< terminal "Lo" - <|> _NonSpacingMark >?< terminal "Mn" - <|> _SpacingCombiningMark >?< terminal "Mc" - <|> _EnclosingMark >?< terminal "Me" - <|> _DecimalNumber >?< terminal "Nd" - <|> _LetterNumber >?< terminal "Nl" - <|> _OtherNumber >?< terminal "No" - <|> _ConnectorPunctuation >?< terminal "Pc" - <|> _DashPunctuation >?< terminal "Pd" - <|> _OpenPunctuation >?< terminal "Ps" - <|> _ClosePunctuation >?< terminal "Pe" - <|> _InitialQuote >?< terminal "Pi" - <|> _FinalQuote >?< terminal "Pf" - <|> _OtherPunctuation >?< terminal "Po" - <|> _MathSymbol >?< terminal "Sm" - <|> _CurrencySymbol >?< terminal "Sc" - <|> _ModifierSymbol >?< terminal "Sk" - <|> _OtherSymbol >?< terminal "So" - <|> _Space >?< terminal "Zs" - <|> _LineSeparator >?< terminal "Zl" - <|> _ParagraphSeparator >?< terminal "Zp" - <|> _Control >?< terminal "Cc" - <|> _Format >?< terminal "Cf" - <|> _Surrogate >?< terminal "Cs" - <|> _PrivateUse >?< terminal "Co" - <|> _NotAssigned >?< terminal "Cn" + atomG rex = rule "atom" $ choiceP + [ nonterminalG + , failG + , classInG + , classNotInG + , categoryInG + , categoryNotInG + , _Terminal >?< charG >:< pure "" + , anyG + , parenG rex + ] + categoryG = rule "category" $ choiceP + [ _LowercaseLetter >?< terminal "Ll" + , _UppercaseLetter >?< terminal "Lu" + , _TitlecaseLetter >?< terminal "Lt" + , _ModifierLetter >?< terminal "Lm" + , _OtherLetter >?< terminal "Lo" + , _NonSpacingMark >?< terminal "Mn" + , _SpacingCombiningMark >?< terminal "Mc" + , _EnclosingMark >?< terminal "Me" + , _DecimalNumber >?< terminal "Nd" + , _LetterNumber >?< terminal "Nl" + , _OtherNumber >?< terminal "No" + , _ConnectorPunctuation >?< terminal "Pc" + , _DashPunctuation >?< terminal "Pd" + , _OpenPunctuation >?< terminal "Ps" + , _ClosePunctuation >?< terminal "Pe" + , _InitialQuote >?< terminal "Pi" + , _FinalQuote >?< terminal "Pf" + , _OtherPunctuation >?< terminal "Po" + , _MathSymbol >?< terminal "Sm" + , _CurrencySymbol >?< terminal "Sc" + , _ModifierSymbol >?< terminal "Sk" + , _OtherSymbol >?< terminal "So" + , _Space >?< terminal "Zs" + , _LineSeparator >?< terminal "Zl" + , _ParagraphSeparator >?< terminal "Zp" + , _Control >?< terminal "Cc" + , _Format >?< terminal "Cf" + , _Surrogate >?< terminal "Cs" + , _PrivateUse >?< terminal "Co" + , _NotAssigned >?< terminal "Cn" + ] categoryInG = rule "category-in" $ _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" categoryNotInG = rule "category-not-in" $ @@ -221,12 +225,13 @@ regexGrammar = ruleRec "regex" $ \rex -> altG rex _OneOf >?< terminal "[" >* manyP charG *< terminal "]" classNotInG = rule "class-not-in" $ _NotOneOf >?< terminal "[^" >* manyP charG *< terminal "]" - exprG rex = rule "expression" $ - terminalG - <|> kleeneOptG rex - <|> kleeneStarG rex - <|> kleenePlusG rex - <|> atomG rex + exprG rex = rule "expression" $ choiceP + [ terminalG + , kleeneOptG rex + , kleeneStarG rex + , kleenePlusG rex + , atomG rex + ] failG = rule "fail" $ _Fail >?< terminal "\\q" nonterminalG = rule "nonterminal" $ _NonTerminal >?< terminal "\\q{" >* manyP charG *< terminal "}" @@ -243,7 +248,16 @@ regexGrammar = ruleRec "regex" $ \rex -> altG rex chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) terminalG = rule "terminal" $ _Terminal >?< someP charG +instance IsList (RegEx Char) where + type Item (RegEx Char) = Char + fromList str = maybe Fail fst (listToMaybe (filter (\(_,remaining) -> remaining == "") (genReadS regexGrammar str))) + toList = maybe "\\q" ($ "") . genShowS regexGrammar + +instance IsString (RegEx Char) where + fromString = fromList + instance Show (RegEx Char) where - showsPrec _ = fromMaybe ("\\q" <>) . genShowS regexGrammar + showsPrec precision = showsPrec precision . toList + instance Read (RegEx Char) where - readsPrec _ = genReadS regexGrammar + readsPrec _ str = [(fromList str, "")] From 49cd8f55ef04787d80774dd5f4fa56b2eee81335 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 18:07:02 -0700 Subject: [PATCH 032/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 83 +++++++++++++++++++++++++++++++------ 1 file changed, 70 insertions(+), 13 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 115fab5..c7aa3d5 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -1,7 +1,58 @@ module Control.Lens.Grammar - ( -- * - RegGrammar + ( -- * RegEx + RegExString + , RegEx (..) + , mempty + , token + , terminal + , (<>) + , anyToken + , oneOf + , notOneOf + , asIn + , notAsIn + , starK + , plusK + , optK + , (>|<) + , empK + , nonTerminal + -- * RegGrammar + , RegGrammar + , runPrintor + , runParsor + , runGrammor + , oneP + , (>*<) + , (>*) + , (*<) + , (>+<) + , (<|>) + , zeroP + , empty + , manyP + , someP + , optionalP + , stream + , stream1 + , chain + , chain1 + , SepBy (..) + , sepBy + , noSep + , tokens + , oneLike + , manyLike + , optLike + , someLike + -- * Grammar , Grammar + , regexString + , runLintor + , satisfy + , rule + , ruleRec + -- * CtxGrammar , CtxGrammar , opticGrammar , grammarOptic @@ -15,8 +66,6 @@ module Control.Lens.Grammar , Regular , Grammatical , Contextual - , RegEx (..) - , regexGrammar ) where import Control.Applicative @@ -162,8 +211,8 @@ instance Applicative f makeNestedPrisms ''RegEx makeNestedPrisms ''GeneralCategory -regexGrammar :: Grammar Char (RegEx Char) -regexGrammar = ruleRec "regex" $ \rex -> altG rex +regexString :: Grammar Char RegExString +regexString = ruleRec "regex" $ \rex -> altG rex where altG rex = rule "alternate" $ chain1 Left _Alternate (sepBy (terminal "|")) (seqG rex) @@ -248,16 +297,24 @@ regexGrammar = ruleRec "regex" $ \rex -> altG rex chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) terminalG = rule "terminal" $ _Terminal >?< someP charG -instance IsList (RegEx Char) where - type Item (RegEx Char) = Char - fromList str = maybe Fail fst (listToMaybe (filter (\(_,remaining) -> remaining == "") (genReadS regexGrammar str))) - toList = maybe "\\q" ($ "") . genShowS regexGrammar +type RegExString = RegEx Char + +instance IsList RegExString where + type Item RegExString = Char + fromList + = maybe Fail fst + . listToMaybe + . filter (\(_, remaining) -> remaining == "") + . genReadS regexString + toList + = maybe "\\q" ($ "") + . genShowS regexString -instance IsString (RegEx Char) where +instance IsString RegExString where fromString = fromList -instance Show (RegEx Char) where +instance Show RegExString where showsPrec precision = showsPrec precision . toList -instance Read (RegEx Char) where +instance Read RegExString where readsPrec _ str = [(fromList str, "")] From 1de051855f96efe7603a295414e22e51bac43ece Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 25 Oct 2025 19:44:53 -0700 Subject: [PATCH 033/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index c7aa3d5..6656e18 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -26,10 +26,11 @@ module Control.Lens.Grammar , (>*<) , (>*) , (*<) - , (>+<) + , (>?) , (<|>) - , zeroP + , (>+<) , empty + , zeroP , manyP , someP , optionalP @@ -49,6 +50,9 @@ module Control.Lens.Grammar , Grammar , regexString , runLintor + , (>?<) + , only + , satisfied , satisfy , rule , ruleRec From e0c8635e6ffa2111cc878314edc2a04ccf8d9793 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 10:17:53 -0700 Subject: [PATCH 034/282] instance move --- src/Control/Lens/Grammar.hs | 5 ----- src/Data/Profunctor/Grammar.hs | 16 +++++++++++++--- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 6656e18..1ac59e8 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -207,11 +207,6 @@ instance Categorized a => KleeneStarAlgebra (RegEx a) where instance NonTerminalSymbol (RegEx a) where nonTerminal = NonTerminal -instance Applicative f - => TerminalSymbol (Grammor s (RegEx a) f () ()) where - type Alphabet (Grammor s (RegEx a) f () ()) = a - terminal = Grammor . pure . pure . terminal - makeNestedPrisms ''RegEx makeNestedPrisms ''GeneralCategory diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 3d04ab2..f08a4e5 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -292,12 +292,22 @@ instance (KleeneStarAlgebra t, Applicative f) => Distributor (Grammor s t f) whe instance (KleeneStarAlgebra t, Applicative f) => Alternator (Grammor s t f) where alternate = either coerce coerce someP (Grammor rex) = Grammor (fmap (fmap plusK) rex) -instance (Tokenized t, Categorized c, Token t ~ c, Applicative f) - => Tokenized (Grammor s t f c c) where - type Token (Grammor s t f c c) = Token t +instance (Tokenized t, Applicative f) + => Tokenized (Grammor s t f a b) where + type Token (Grammor s t f a b) = Token t anyToken = Grammor (pure (pure anyToken)) token = Grammor . pure . pure . token oneOf = Grammor . pure . pure . oneOf notOneOf = Grammor . pure . pure . notOneOf asIn = Grammor . pure . pure . asIn notAsIn = Grammor . pure . pure . notAsIn +instance (TerminalSymbol t, Applicative f) + => TerminalSymbol (Grammor s t f a b) where + type Alphabet (Grammor s t f a b) = Alphabet t + terminal = Grammor . pure . pure . terminal +instance (Tokenized t, Applicative f, Token t ~ a) + => Equator a a (Grammor s t f) +-- instance (Applicative f, Ord a, NonTerminalSymbol a) +-- => BackusNaurForm (Grammor s (Gram a) f x y) where +-- rule name = Grammor . fmap (fmap (rule name)) . runGrammor +-- ruleRec name = Grammor . _ . dimap Grammor runGrammor From 88fc57a18ee4a7822e50c75238351f7f1a32dbee Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 11:06:41 -0700 Subject: [PATCH 035/282] comonad --- distributors.cabal | 2 ++ package.yaml | 1 + src/Data/Profunctor/Grammar.hs | 28 ++++++++++++++++------------ 3 files changed, 19 insertions(+), 12 deletions(-) diff --git a/distributors.cabal b/distributors.cabal index d89da68..d5da334 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -98,6 +98,7 @@ library , base >=4.7 && <5 , bifunctors >=5.6 && <6 , bytestring >=0.11 && <1 + , comonad , containers >=0.6 && <1 , contravariant >=1.5 && <2 , distributive >=0.6 && <1 @@ -166,6 +167,7 @@ test-suite spec , base >=4.7 && <5 , bifunctors >=5.6 && <6 , bytestring >=0.11 && <1 + , comonad , containers >=0.6 && <1 , contravariant >=1.5 && <2 , distributive >=0.6 && <1 diff --git a/package.yaml b/package.yaml index 234d0b1..280a889 100644 --- a/package.yaml +++ b/package.yaml @@ -23,6 +23,7 @@ dependencies: - adjunctions >= 4.4 && < 5 - bifunctors >= 5.6 && < 6 - bytestring >= 0.11 && < 1 +- comonad - containers >= 0.6 && < 1 - contravariant >= 1.5 && < 2 - distributive >= 0.6 && < 1 diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index f08a4e5..fd5c16e 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -11,6 +11,7 @@ module Data.Profunctor.Grammar import Control.Applicative import Control.Arrow import Control.Category +import Control.Comonad import Control.Lens import Control.Lens.Grammar.Equator import Control.Lens.Grammar.BackusNaur @@ -262,15 +263,15 @@ instance Functor f => Tetradic f Grammor where instance Choice (Grammor s t f) where left' = coerce right' = coerce -instance Functor f => Filterable (Grammor s All f a) where - mapMaybe _ = Grammor . fmap (fmap (pure (All False))) . runGrammor -instance Functor f => Cochoice (Grammor s All f) where - unleft = Grammor . fmap (fmap (pure (All False))) . runGrammor - unright = Grammor . fmap (fmap (pure (All False))) . runGrammor -instance Functor f => Filtrator (Grammor s All f) where +instance Filterable (Grammor s t ((,) All) a) where + mapMaybe _ = Grammor . fmap (\(_, t) -> (All False, t)) . runGrammor +instance Cochoice (Grammor s t ((,) All)) where + unleft = Grammor . fmap (\(_, t) -> (All False, t)) . runGrammor + unright = Grammor . fmap (\(_, t) -> (All False, t)) . runGrammor +instance Filtrator (Grammor s t ((,) All)) where filtrate (Grammor p) = - ( Grammor (fmap (fmap (pure (All False))) p) - , Grammor (fmap (fmap (pure (All False))) p) + ( Grammor (fmap (\(_, t) -> (All False, t)) p) + , Grammor (fmap (\(_, t) -> (All False, t)) p) ) instance (Monoid t, Applicative f) => Applicative (Grammor s t f a) where @@ -307,7 +308,10 @@ instance (TerminalSymbol t, Applicative f) terminal = Grammor . pure . pure . terminal instance (Tokenized t, Applicative f, Token t ~ a) => Equator a a (Grammor s t f) --- instance (Applicative f, Ord a, NonTerminalSymbol a) --- => BackusNaurForm (Grammor s (Gram a) f x y) where --- rule name = Grammor . fmap (fmap (rule name)) . runGrammor --- ruleRec name = Grammor . _ . dimap Grammor runGrammor +instance (Comonad f, Applicative f, Monoid s, BackusNaurForm t) + => BackusNaurForm (Grammor s t f a b) where + rule name = Grammor . fmap (fmap (rule name)) . runGrammor + ruleRec name = pureG . ruleRec name . dimap pureG extractG + where + pureG = Grammor . pure . pure + extractG = extract . extract . runGrammor From e3c20013fd3bacae0cf5f42a37e407d85ae8b3a8 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 12:08:31 -0700 Subject: [PATCH 036/282] trichotomy restored --- src/Control/Lens/Grammar.hs | 12 +- src/Data/Profunctor/Grammar.hs | 249 ++++++++++++++------------------- 2 files changed, 115 insertions(+), 146 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 1ac59e8..9048453 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -19,9 +19,9 @@ module Control.Lens.Grammar , nonTerminal -- * RegGrammar , RegGrammar - , runPrintor , runParsor - , runGrammor + , evalPrintor + , evalGrammor , oneP , (>*<) , (>*) @@ -49,7 +49,6 @@ module Control.Lens.Grammar -- * Grammar , Grammar , regexString - , runLintor , (>?<) , only , satisfied @@ -116,7 +115,7 @@ grammarrOptic = dimap (rmap runIdentity) (rmap Identity) genShowS :: (Filterable m, MonadPlus m) => CtxGrammar String a -> a -> m ShowS -genShowS = runPrintor . toPrintor +genShowS = evalPrintor genReadS :: CtxGrammar String a -> ReadS a genReadS = runParsor @@ -136,7 +135,10 @@ type Grammatical c p = type Contextual s m p = ( Grammatical (Item s) (p s s m) , Monadic (p s s) - , Subtextual s m + , Categorized (Item s) + , IsStream s + , Filterable m + , MonadPlus m ) data RegEx a diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index fd5c16e..ab02ea9 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -1,11 +1,14 @@ module Data.Profunctor.Grammar - ( Parsor (..) + ( -- * Parsor + Parsor (..) + -- * Printor , Printor (..) - , Lintor (..) + , printor + , evalPrintor + -- * Grammor , Grammor (..) - , toPrintor - , fromPrintor - , Subtextual + , grammor + , evalGrammor ) where import Control.Applicative @@ -34,21 +37,20 @@ import GHC.Exts import Witherable newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} -newtype Printor s t f a b = Printor {runPrintor :: a -> f (s -> t)} -newtype Lintor s t f a b = Lintor {runLintor :: a -> f (b, s -> t)} -newtype Grammor s t f a b = Grammor {runGrammor :: s -> f t} - -toPrintor :: Functor f => Lintor s t f a b -> Printor s t f a b -toPrintor (Lintor f) = Printor (fmap snd . f) -fromPrintor :: Functor f => Printor s t f a a -> Lintor s t f a a -fromPrintor (Printor f) = Lintor (\a -> fmap (a,) (f a)) +newtype Printor s t f a b = Printor {runPrintor :: a -> f (b, s -> t)} +printor :: Functor f => (a -> f (s -> t)) -> Printor s t f a a +printor f = Printor (\a -> fmap (a,) (f a)) +evalPrintor :: Functor f => Printor s t f a b -> a -> f (s -> t) +evalPrintor (Printor f) = fmap snd . f -type Subtextual s m = - ( IsStream s, Categorized (Item s) - , Alternative m, Filterable m, Monad m - ) +newtype Grammor s t f a b = Grammor {runGrammor :: s -> f t} +grammor :: Applicative f => t -> Grammor s t f a b +grammor = Grammor . pure . pure +evalGrammor :: (Monoid s, Comonad f) => Grammor s t f a b -> t +evalGrammor = extract . extract . runGrammor +-- Parsor instances instance Functor f => Functor (Parsor s t f a) where fmap f = Parsor . fmap (fmap (first' f)) . runParsor instance Functor f => Bifunctor (Parsor s t f) where @@ -62,7 +64,6 @@ instance Functor f => Profunctor (Parsor s t f) where instance Functor f => Tetradic f Parsor where dimapT f g (Parsor p) = Parsor (fmap (fmap g) . p . f) tetramap f g _ i (Parsor p) = Parsor (fmap (i >*< g) . p . f) - instance Monad m => Applicative (Parsor s s m a) where pure b = Parsor (\s -> return (b,s)) Parsor x <*> Parsor y = Parsor $ \s -> do @@ -94,7 +95,6 @@ instance Polyadic Parsor where composeP (Parsor p) = Parsor $ \s -> do (mb, s') <- p s runParsor mb s' - instance Filterable f => Filterable (Parsor s t f a) where mapMaybe f (Parsor p) = Parsor (mapMaybe (\(a,str) -> (,str) <$> f a) . p) instance Filterable f => Cochoice (Parsor s t f) where @@ -107,152 +107,119 @@ instance Filterable f => Filtrator (Parsor s t f) where ) where leftMay (e, str) = either (\b -> Just (b, str)) (\_ -> Nothing) e rightMay (e, str) = either (\_ -> Nothing) (\b -> Just (b, str)) e - -instance (Subtextual s m, a ~ Item s) => Tokenized (Parsor s s m a a) where +instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) + => Tokenized (Parsor s s m a a) where type Token (Parsor s s m a a) = a anyToken = Parsor (maybe empty pure . uncons) -instance (Subtextual s m, a ~ Item s) => Equator a a (Parsor s s m) where -instance Subtextual s m => TerminalSymbol (Parsor s s m () ()) where +instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) + => Equator a a (Parsor s s m) where +instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) + => TerminalSymbol (Parsor s s m () ()) where type Alphabet (Parsor s s m () ()) = Item s -instance BackusNaurForm (Parsor s t m a b) -instance (Subtextual s m, Item s ~ Char) => IsString (Parsor s s m () ()) where +instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) + => IsString (Parsor s s m () ()) where fromString = terminal -instance (Subtextual s m, Item s ~ Char) => IsString (Parsor s s m s s) where +instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) + => IsString (Parsor s s m s s) where fromString = tokens +instance BackusNaurForm (Parsor s t m a b) -instance Functor (Printor s t f a) where - fmap _ = coerce -instance Contravariant (Printor s t f a) where - contramap _ = coerce -instance Profunctor (Printor s t f) where - dimap f _ = Printor . lmap f . runPrintor - lmap f = Printor . lmap f . runPrintor - rmap _ = coerce +-- Printor instances +instance Functor f => Functor (Printor s t f a) where + fmap f = Printor . fmap (fmap (first' f)) . runPrintor +instance Functor f => Profunctor (Printor s t f) where + dimap f g = Printor . dimap f (fmap (first' g)) . runPrintor instance Functor f => Tetradic f Printor where - dimapT h i = Printor . (fmap (fmap (dimap h i))) . runPrintor - tetramap h i f _ = Printor . dimap f (fmap (dimap h i)) . runPrintor - -instance Filterable (Printor s t f a) where - mapMaybe _ (Printor p) = Printor p -instance Cochoice (Printor s t f) where - unleft = fst . filtrate - unright = snd . filtrate -instance Filtrator (Printor s t f) where - filtrate (Printor p) = (Printor (p . Left), Printor (p . Right)) - + dimapT f g = Printor . rmap (fmap (second' (dimap f g))) . runPrintor + tetramap f g h i = Printor . dimap h (fmap (i >*< dimap f g)) . runPrintor instance Applicative f => Applicative (Printor s s f a) where - pure _ = Printor (\_ -> pure id) - Printor p <*> Printor q = Printor (\a -> (.) <$> p a <*> q a) + pure b = Printor (\_ -> pure (b, id)) + Printor f <*> Printor x = Printor $ \c -> + liftA2 (\(g, p) (a, q) -> (g a, p . q)) (f c) (x c) instance Alternative f => Alternative (Printor s s f a) where empty = Printor (\_ -> empty) Printor p <|> Printor q = Printor (\a -> p a <|> q a) -instance Alternative f => Choice (Printor s s f) where - left' = alternate . Left - right' = alternate . Right -instance Applicative f => Distributor (Printor s s f) where - zeroP = Printor absurd - Printor p >+< Printor q = Printor (either p q) -instance Alternative f => Alternator (Printor s s f) where - alternate = \case - Left (Printor p) -> Printor (either p (\_ -> empty)) - Right (Printor p) -> Printor (either (\_ -> empty) p) - -instance (Subtextual s m, Item s ~ a) => Tokenized (Printor s s m a a) where - type Token (Printor s s m a a) = a - anyToken = Printor (pure . cons) -instance (Subtextual s m, Item s ~ a) => Equator a a (Printor s s m) where -instance Subtextual s m => TerminalSymbol (Printor s s m () ()) where - type Alphabet (Printor s s m () ()) = Item s -instance BackusNaurForm (Printor s t m a b) -instance (Subtextual s m, Item s ~ Char) - => IsString (Printor s s m () ()) where - fromString = terminal -instance (Subtextual s m, Item s ~ Char) - => IsString (Printor s s m s s) where - fromString = tokens - -instance Functor f => Functor (Lintor s t f a) where - fmap f = Lintor . fmap (fmap (first' f)) . runLintor -instance Functor f => Profunctor (Lintor s t f) where - dimap f g = Lintor . dimap f (fmap (first' g)) . runLintor -instance Functor f => Tetradic f Lintor where - dimapT f g = Lintor . rmap (fmap (second' (dimap f g))) . runLintor - tetramap f g h i = Lintor . dimap h (fmap (i >*< dimap f g)) . runLintor -instance Applicative f => Applicative (Lintor s s f a) where - pure b = Lintor (\_ -> pure (b, id)) - Lintor f <*> Lintor x = Lintor $ \c -> - liftA2 (\(g, p) (a, q) -> (g a, p . q)) (f c) (x c) -instance Alternative f => Alternative (Lintor s s f a) where - empty = Lintor (\_ -> empty) - Lintor p <|> Lintor q = Lintor (\a -> p a <|> q a) -instance Filterable f => Filterable (Lintor s s f a) where - mapMaybe f (Lintor p) = Lintor $ +instance Filterable f => Filterable (Printor s s f a) where + mapMaybe f (Printor p) = Printor $ mapMaybe (\(a,q) -> fmap (, q) (f a)) . p -instance Monad f => Monad (Lintor s s f a) where +instance Monad f => Monad (Printor s s f a) where return = pure - mx >>= f = Lintor $ \ctx -> do - (x, p) <- runLintor mx ctx - (y, q) <- runLintor (f x) ctx + mx >>= f = Printor $ \ctx -> do + (x, p) <- runPrintor mx ctx + (y, q) <- runPrintor (f x) ctx return (y, p . q) -instance (Alternative f, Monad f) => MonadPlus (Lintor s s f a) -instance Monadic (Lintor s s) where - joinP (Lintor mf) = Lintor $ \a -> do +instance (Alternative f, Monad f) => MonadPlus (Printor s s f a) +instance Monadic (Printor s s) where + joinP (Printor mf) = Printor $ \a -> do (mb, f) <- mf a b <- mb return (b, f) -instance Polyadic Lintor where - composeP (Lintor mf) = Lintor $ \a -> do - (Lintor mg, f) <- mf a +instance Polyadic Printor where + composeP (Printor mf) = Printor $ \a -> do + (Printor mg, f) <- mf a (b, g) <- mg a return (b, g . f) -instance Applicative f => Distributor (Lintor s s f) where - zeroP = Lintor absurd - Lintor p >+< Lintor q = Lintor $ +instance Applicative f => Distributor (Printor s s f) where + zeroP = Printor absurd + Printor p >+< Printor q = Printor $ either (fmap (first' Left) . p) (fmap (first' Right) . q) -instance Alternative f => Alternator (Lintor s s f) where +instance Alternative f => Alternator (Printor s s f) where alternate = \case - Left (Lintor p) -> Lintor $ + Left (Printor p) -> Printor $ either (fmap (first' Left) . p) (\_ -> empty) - Right (Lintor p) -> Lintor $ + Right (Printor p) -> Printor $ either (\_ -> empty) (fmap (first' Right) . p) -instance Filterable f => Filtrator (Lintor s s f) where - filtrate (Lintor p) = - ( Lintor (mapMaybe (\case{(Left b, q) -> Just (b, q); _ -> Nothing}) . p . Left) - , Lintor (mapMaybe (\case{(Right b, q) -> Just (b, q); _ -> Nothing}) . p . Right) +instance Filterable f => Filtrator (Printor s s f) where + filtrate (Printor p) = + ( Printor (mapMaybe (\case{(Left b, q) -> Just (b, q); _ -> Nothing}) . p . Left) + , Printor (mapMaybe (\case{(Right b, q) -> Just (b, q); _ -> Nothing}) . p . Right) ) -instance Alternative f => Choice (Lintor s s f) where +instance Alternative f => Choice (Printor s s f) where left' = alternate . Left right' = alternate . Right -instance Filterable f => Cochoice (Lintor s s f) where +instance Filterable f => Cochoice (Printor s s f) where unleft = fst . filtrate unright = snd . filtrate -instance Functor f => Strong (Lintor s s f) where - first' (Lintor p) = Lintor (\(a,c) -> fmap (\(b,q) -> ((b,c),q)) (p a)) - second' (Lintor p) = Lintor (\(c,a) -> fmap (\(b,q) -> ((c,b),q)) (p a)) -instance Monad f => Category (Lintor s s f) where - id = Lintor $ \a -> return (a, id) - Lintor q . Lintor p = Lintor $ \a -> do +instance Functor f => Strong (Printor s s f) where + first' (Printor p) = Printor (\(a,c) -> fmap (\(b,q) -> ((b,c),q)) (p a)) + second' (Printor p) = Printor (\(c,a) -> fmap (\(b,q) -> ((c,b),q)) (p a)) +instance Monad f => Category (Printor s s f) where + id = Printor $ \a -> return (a, id) + Printor q . Printor p = Printor $ \a -> do (b, p') <- p a (c, q') <- q b return (c, q' . p') -instance Monad f => Arrow (Lintor s s f) where - arr f = Lintor (return . (, id) . f) +instance Monad f => Arrow (Printor s s f) where + arr f = Printor (return . (, id) . f) (***) = (>*<) first = first' second = second' - -instance (Subtextual s m, Item s ~ a) => Tokenized (Lintor s s m a a) where - type Token (Lintor s s m a a) = a - anyToken = Lintor (\b -> pure (b, cons b)) -instance (Subtextual s m, Item s ~ a) => Equator a a (Lintor s s m) where -instance Subtextual s m => TerminalSymbol (Lintor s s m () ()) where - type Alphabet (Lintor s s m () ()) = Item s -instance BackusNaurForm (Lintor s t m a b) -instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m () ()) where +instance MonadPlus f => ArrowZero (Printor s s f) where + zeroArrow = empty +instance MonadPlus f => ArrowPlus (Printor s s f) where + (<+>) = (<|>) +instance MonadPlus f => ArrowChoice (Printor s s f) where + (+++) = (>+<) + left = left' + right = right' +instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) + => Tokenized (Printor s s m a a) where + type Token (Printor s s m a a) = a + anyToken = Printor (\b -> pure (b, cons b)) +instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) + => Equator a a (Printor s s m) where +instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) + => TerminalSymbol (Printor s s m () ()) where + type Alphabet (Printor s s m () ()) = Item s +instance BackusNaurForm (Printor s t m a b) +instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) + => IsString (Printor s s m () ()) where fromString = terminal -instance (Subtextual s m, Item s ~ Char) => IsString (Lintor s s m s s) where +instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) + => IsString (Printor s s m s s) where fromString = tokens +-- Grammor instances instance Functor (Grammor s t f a) where fmap _ = coerce instance Contravariant (Grammor s t f a) where contramap _ = coerce instance Profunctor (Grammor s t f) where dimap _ _ = coerce @@ -278,40 +245,40 @@ instance (Monoid t, Applicative f) pure _ = Grammor (pure (pure mempty)) Grammor rex1 <*> Grammor rex2 = Grammor (liftA2 (liftA2 (<>)) rex1 rex2) -instance (KleeneStarAlgebra t, Applicative f) => Alternative (Grammor s t f a) where +instance (KleeneStarAlgebra t, Applicative f) + => Alternative (Grammor s t f a) where empty = Grammor (pure (pure empK)) Grammor rex1 <|> Grammor rex2 = Grammor (liftA2 (liftA2 (>|<)) rex1 rex2) many (Grammor rex) = Grammor (fmap (fmap starK) rex) some (Grammor rex) = Grammor (fmap (fmap plusK) rex) -instance (KleeneStarAlgebra t, Applicative f) => Distributor (Grammor s t f) where +instance (KleeneStarAlgebra t, Applicative f) + => Distributor (Grammor s t f) where zeroP = Grammor (pure (pure empK)) Grammor rex1 >+< Grammor rex2 = Grammor (liftA2 (liftA2 (>|<)) rex1 rex2) manyP (Grammor rex) = Grammor (fmap (fmap starK) rex) optionalP (Grammor rex) = Grammor (fmap (fmap optK) rex) -instance (KleeneStarAlgebra t, Applicative f) => Alternator (Grammor s t f) where +instance (KleeneStarAlgebra t, Applicative f) + => Alternator (Grammor s t f) where alternate = either coerce coerce someP (Grammor rex) = Grammor (fmap (fmap plusK) rex) instance (Tokenized t, Applicative f) => Tokenized (Grammor s t f a b) where type Token (Grammor s t f a b) = Token t anyToken = Grammor (pure (pure anyToken)) - token = Grammor . pure . pure . token - oneOf = Grammor . pure . pure . oneOf - notOneOf = Grammor . pure . pure . notOneOf - asIn = Grammor . pure . pure . asIn - notAsIn = Grammor . pure . pure . notAsIn + token = grammor . token + oneOf = grammor . oneOf + notOneOf = grammor . notOneOf + asIn = grammor . asIn + notAsIn = grammor . notAsIn instance (TerminalSymbol t, Applicative f) => TerminalSymbol (Grammor s t f a b) where type Alphabet (Grammor s t f a b) = Alphabet t - terminal = Grammor . pure . pure . terminal + terminal = grammor . terminal instance (Tokenized t, Applicative f, Token t ~ a) => Equator a a (Grammor s t f) instance (Comonad f, Applicative f, Monoid s, BackusNaurForm t) => BackusNaurForm (Grammor s t f a b) where rule name = Grammor . fmap (fmap (rule name)) . runGrammor - ruleRec name = pureG . ruleRec name . dimap pureG extractG - where - pureG = Grammor . pure . pure - extractG = extract . extract . runGrammor + ruleRec name = grammor . ruleRec name . dimap grammor evalGrammor From 2d1a04646e150e62b9991143bbe52dc2038c525e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 12:22:49 -0700 Subject: [PATCH 037/282] genRegEx --- src/Control/Lens/Grammar.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 9048453..e85ecee 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -21,7 +21,7 @@ module Control.Lens.Grammar , RegGrammar , runParsor , evalPrintor - , evalGrammor + , genRegEx , oneP , (>*<) , (>*) @@ -120,6 +120,9 @@ genShowS = evalPrintor genReadS :: CtxGrammar String a -> ReadS a genReadS = runParsor +genRegEx :: forall token a. Categorized token => RegGrammar token a -> RegEx token +genRegEx = evalGrammor @[token] @Identity + type Regular c p = ( Terminator c p , Tokenizor c p From c74e8fcfd1e58b465d4d1e6f7a0564b252f55994 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 12:32:27 -0700 Subject: [PATCH 038/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index e85ecee..a50a9de 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -57,6 +57,8 @@ module Control.Lens.Grammar , ruleRec -- * CtxGrammar , CtxGrammar + , genShowS + , genReadS , opticGrammar , grammarOptic , RegGrammarr @@ -64,8 +66,7 @@ module Control.Lens.Grammar , CtxGrammarr , opticGrammarr , grammarrOptic - , genShowS - , genReadS + -- * Constraints , Regular , Grammatical , Contextual From 24530a3a4d97c7b26730ed56265e571f8931e29f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 12:48:46 -0700 Subject: [PATCH 039/282] noToken, notToken --- src/Control/Lens/Grammar.hs | 2 ++ src/Control/Lens/Grammar/BackusNaur.hs | 2 ++ src/Control/Lens/Grammar/Token.hs | 13 +++++++++++++ src/Data/Profunctor/Grammar.hs | 4 +++- 4 files changed, 20 insertions(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index a50a9de..20897ae 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -172,7 +172,9 @@ instance Monoid a => TerminalSymbol (a, RegEx a) where instance Categorized a => Tokenized (RegEx a) where type Token (RegEx a) = a anyToken = AnyToken + noToken = Fail token a = Terminal [a] + notToken a = notOneOf [a] oneOf = OneOf . F.toList notOneOf = NotOneOf . F.toList asIn = AsIn diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index dbc67ea..86953cd 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -48,7 +48,9 @@ liftGram2 f (Gram start0 rules0) (Gram start1 rules1) = instance (Ord a, Tokenized a) => Tokenized (Gram a) where type Token (Gram a) = Token a anyToken = liftGram0 anyToken + noToken = liftGram0 noToken token = liftGram0 . token + notToken = liftGram0 . notToken oneOf = liftGram0 . oneOf notOneOf = liftGram0 . notOneOf asIn = liftGram0 . asIn diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 19aaea1..b8730c5 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -14,6 +14,7 @@ module Control.Lens.Grammar.Token , GeneralCategory (..) ) where +import Control.Applicative import Control.Lens import Control.Lens.PartialIso import Data.Char @@ -39,12 +40,22 @@ class Categorized (Token p) => Tokenized p where anyToken :: p + noToken :: p + default noToken :: (p ~ f (Token p), Alternative f) => p + noToken = empty + token :: Token p -> p default token :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) => Token p -> p token = satisfy . token + notToken :: Token p -> p + default notToken + :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) + => Token p -> p + notToken = satisfy . notToken + oneOf :: [Token p] -> p default oneOf :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) @@ -72,7 +83,9 @@ class Categorized (Token p) => Tokenized p where instance Categorized c => Tokenized (c -> Bool) where type Token (c -> Bool) = c anyToken _ = True + noToken _ = False token = (==) + notToken = (/=) oneOf = flip elem notOneOf = flip notElem asIn = lmap categorize . (==) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index ab02ea9..9169847 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -266,8 +266,10 @@ instance (KleeneStarAlgebra t, Applicative f) instance (Tokenized t, Applicative f) => Tokenized (Grammor s t f a b) where type Token (Grammor s t f a b) = Token t - anyToken = Grammor (pure (pure anyToken)) + anyToken = grammor anyToken + noToken = grammor noToken token = grammor . token + notToken = grammor . notToken oneOf = grammor . oneOf notOneOf = grammor . notOneOf asIn = grammor . asIn From 8e69c334a866f5130a54e41ea5dcd7214a26fb11 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 13:05:41 -0700 Subject: [PATCH 040/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 52 +++---------------------------------- 1 file changed, 3 insertions(+), 49 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 20897ae..0a1ad9f 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -2,70 +2,24 @@ module Control.Lens.Grammar ( -- * RegEx RegExString , RegEx (..) - , mempty - , token - , terminal - , (<>) - , anyToken - , oneOf - , notOneOf - , asIn - , notAsIn - , starK - , plusK - , optK - , (>|<) - , empK - , nonTerminal -- * RegGrammar , RegGrammar - , runParsor - , evalPrintor , genRegEx - , oneP - , (>*<) - , (>*) - , (*<) - , (>?) - , (<|>) - , (>+<) - , empty - , zeroP - , manyP - , someP - , optionalP - , stream - , stream1 - , chain - , chain1 - , SepBy (..) - , sepBy - , noSep - , tokens - , oneLike - , manyLike - , optLike - , someLike -- * Grammar , Grammar , regexString - , (>?<) - , only - , satisfied - , satisfy - , rule - , ruleRec -- * CtxGrammar , CtxGrammar , genShowS , genReadS - , opticGrammar - , grammarOptic + -- * Optics , RegGrammarr , Grammarr , CtxGrammarr , opticGrammarr , grammarrOptic + , opticGrammar + , grammarOptic -- * Constraints , Regular , Grammatical From e444b05a03ed9db158319919dae0c616c359e997 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 13:27:03 -0700 Subject: [PATCH 041/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 9169847..b162d7d 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -211,13 +211,13 @@ instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) => TerminalSymbol (Printor s s m () ()) where type Alphabet (Printor s s m () ()) = Item s -instance BackusNaurForm (Printor s t m a b) instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) => IsString (Printor s s m () ()) where fromString = terminal instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) => IsString (Printor s s m s s) where fromString = tokens +instance BackusNaurForm (Printor s t m a b) -- Grammor instances instance Functor (Grammor s t f a) where fmap _ = coerce From 6cae1d033cc40be5af4725e258b697671f8d5242 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 13:27:14 -0700 Subject: [PATCH 042/282] genGram --- src/Control/Lens/Grammar.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 0a1ad9f..0c05636 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -7,6 +7,7 @@ module Control.Lens.Grammar , genRegEx -- * Grammar , Grammar + , genGram , regexString -- * CtxGrammar , CtxGrammar @@ -36,6 +37,7 @@ import Control.Lens.Grammar.Stream import Control.Lens.Grammar.Symbol import Control.Monad import Data.Maybe +import Data.Monoid import qualified Data.Foldable as F import Data.Profunctor.Distributor import Data.Profunctor.Filtrator @@ -75,8 +77,13 @@ genShowS = evalPrintor genReadS :: CtxGrammar String a -> ReadS a genReadS = runParsor -genRegEx :: forall token a. Categorized token => RegGrammar token a -> RegEx token -genRegEx = evalGrammor @[token] @Identity +genRegEx :: Categorized token => RegGrammar token a -> RegEx token +genRegEx = evalGrammor @() @Identity + +genGram + :: (Categorized token, Ord token, Ord (Categorize token)) + => Grammar token a -> Gram (RegEx token) +genGram = evalGrammor @() @((,) All) type Regular c p = ( Terminator c p From 38ae9f4422a1d4ff09ae36e52a219a792043f691 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 13:42:17 -0700 Subject: [PATCH 043/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 0c05636..933bef2 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -133,8 +133,8 @@ instance Monoid a => TerminalSymbol (a, RegEx a) where instance Categorized a => Tokenized (RegEx a) where type Token (RegEx a) = a anyToken = AnyToken - noToken = Fail - token a = Terminal [a] + noToken = empK + token a = terminal [a] notToken a = notOneOf [a] oneOf = OneOf . F.toList notOneOf = NotOneOf . F.toList From 0580f6e8ba9f6edebae1cb837e0183b87c4fb2d6 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 14:09:54 -0700 Subject: [PATCH 044/282] move RegEx --- src/Control/Lens/Grammar.hs | 103 +++++------------------------ src/Control/Lens/Grammar/Kleene.hs | 78 ++++++++++++++++++++++ 2 files changed, 96 insertions(+), 85 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 933bef2..3d72c09 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -1,18 +1,16 @@ module Control.Lens.Grammar ( -- * RegEx - RegExString - , RegEx (..) - -- * RegGrammar + RegExStr , RegGrammar , genRegEx + , genShowS + , genReadS -- * Grammar , Grammar , genGram , regexString -- * CtxGrammar , CtxGrammar - , genShowS - , genReadS -- * Optics , RegGrammarr , Grammarr @@ -25,6 +23,12 @@ module Control.Lens.Grammar , Regular , Grammatical , Contextual + -- * Re-exports + , module Control.Lens.Grammar.BackusNaur + , module Control.Lens.Grammar.Kleene + , module Control.Lens.Grammar.Token + , module Control.Lens.Grammar.Stream + , module Control.Lens.Grammar.Symbol ) where import Control.Applicative @@ -38,7 +42,6 @@ import Control.Lens.Grammar.Symbol import Control.Monad import Data.Maybe import Data.Monoid -import qualified Data.Foldable as F import Data.Profunctor.Distributor import Data.Profunctor.Filtrator import Data.Profunctor.Monadic @@ -106,81 +109,11 @@ type Contextual s m p = , MonadPlus m ) -data RegEx a - = Terminal [a] - | Sequence (RegEx a) (RegEx a) - | Fail - | Alternate (RegEx a) (RegEx a) - | KleeneOpt (RegEx a) - | KleeneStar (RegEx a) - | KleenePlus (RegEx a) - | AnyToken - | OneOf [a] - | NotOneOf [a] - | AsIn (Categorize a) - | NotAsIn (Categorize a) - | NonTerminal String - -deriving stock instance Categorized a => Eq (RegEx a) -deriving stock instance - (Categorized a, Ord a, Ord (Categorize a)) => Ord (RegEx a) -instance TerminalSymbol (RegEx a) where - type Alphabet (RegEx a) = a - terminal = Terminal . F.toList -instance Monoid a => TerminalSymbol (a, RegEx a) where - type Alphabet (a, RegEx a) = a - terminal = pure . terminal -instance Categorized a => Tokenized (RegEx a) where - type Token (RegEx a) = a - anyToken = AnyToken - noToken = empK - token a = terminal [a] - notToken a = notOneOf [a] - oneOf = OneOf . F.toList - notOneOf = NotOneOf . F.toList - asIn = AsIn - notAsIn = NotAsIn -instance Categorized a => Semigroup (RegEx a) where - Terminal [] <> rex = rex - rex <> Terminal [] = rex - Fail <> _ = empK - _ <> Fail = empK - Terminal str0 <> Terminal str1 = Terminal (str0 <> str1) - KleeneStar rex0 <> rex1 - | rex0 == rex1 = plusK rex0 - rex0 <> KleeneStar rex1 - | rex0 == rex1 = plusK rex1 - rex0 <> rex1 = Sequence rex0 rex1 -instance Categorized a => Monoid (RegEx a) where - mempty = Terminal [] -instance Categorized a => KleeneStarAlgebra (RegEx a) where - empK = Fail - optK Fail = mempty - optK (Terminal []) = mempty - optK (KleenePlus rex) = starK rex - optK rex = KleeneOpt rex - starK Fail = mempty - starK (Terminal []) = mempty - starK rex = KleeneStar rex - plusK Fail = empK - plusK (Terminal []) = mempty - plusK rex = KleenePlus rex - 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 -instance NonTerminalSymbol (RegEx a) where - nonTerminal = NonTerminal - makeNestedPrisms ''RegEx makeNestedPrisms ''GeneralCategory -regexString :: Grammar Char RegExString -regexString = ruleRec "regex" $ \rex -> altG rex +regexString :: Grammar Char RegExStr +regexString = dimap runRegExStr RegExStr . ruleRec "regex" $ \rex -> altG rex where altG rex = rule "alternate" $ chain1 Left _Alternate (sepBy (terminal "|")) (seqG rex) @@ -265,12 +198,12 @@ regexString = ruleRec "regex" $ \rex -> altG rex chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) terminalG = rule "terminal" $ _Terminal >?< someP charG -type RegExString = RegEx Char +newtype RegExStr = RegExStr {runRegExStr :: RegEx Char} -instance IsList RegExString where - type Item RegExString = Char +instance IsList RegExStr where + type Item RegExStr = Char fromList - = maybe Fail fst + = maybe (RegExStr Fail) fst . listToMaybe . filter (\(_, remaining) -> remaining == "") . genReadS regexString @@ -278,11 +211,11 @@ instance IsList RegExString where = maybe "\\q" ($ "") . genShowS regexString -instance IsString RegExString where +instance IsString RegExStr where fromString = fromList -instance Show RegExString where +instance Show RegExStr where showsPrec precision = showsPrec precision . toList -instance Read RegExString where +instance Read RegExStr where readsPrec _ str = [(fromList str, "")] diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 53fc616..aacfb8b 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -1,10 +1,88 @@ module Control.Lens.Grammar.Kleene ( KleeneStarAlgebra (..) + , RegEx (..) ) where +import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token +import Data.Foldable + class Monoid a => KleeneStarAlgebra a where starK :: a -> a plusK :: a -> a optK :: a -> a (>|<) :: a -> a -> a empK :: a + +data RegEx token + = Terminal [token] + | Sequence (RegEx token) (RegEx token) + | Fail + | Alternate (RegEx token) (RegEx token) + | KleeneOpt (RegEx token) + | KleeneStar (RegEx token) + | KleenePlus (RegEx token) + | AnyToken + | OneOf [token] + | NotOneOf [token] + | AsIn (Categorize token) + | NotAsIn (Categorize token) + | NonTerminal String +deriving stock instance Categorized token => Eq (RegEx token) +deriving stock instance + (Categorized token, Ord token, Ord (Categorize token)) + => Ord (RegEx token) +deriving stock instance + (Categorized token, Read token, Read (Categorize token)) + => Read (RegEx token) +deriving stock instance + (Categorized token, Show token, Show (Categorize token)) + => Show (RegEx token) +instance TerminalSymbol (RegEx token) where + type Alphabet (RegEx token) = token + terminal = Terminal . toList +instance Categorized token => Tokenized (RegEx token) where + type Token (RegEx token) = token + anyToken = AnyToken + noToken = empK + token a = terminal [a] + notToken a = notOneOf [a] + oneOf = OneOf . toList + notOneOf = NotOneOf . toList + asIn = AsIn + notAsIn = NotAsIn +instance Categorized token => Semigroup (RegEx token) where + Terminal [] <> rex = rex + rex <> Terminal [] = rex + Fail <> _ = empK + _ <> Fail = empK + Terminal str0 <> Terminal str1 = Terminal (str0 <> str1) + KleeneStar rex0 <> rex1 + | rex0 == rex1 = plusK rex0 + rex0 <> KleeneStar rex1 + | rex0 == rex1 = plusK rex1 + rex0 <> rex1 = Sequence rex0 rex1 +instance Categorized token => Monoid (RegEx token) where + mempty = Terminal [] +instance Categorized token => KleeneStarAlgebra (RegEx token) where + empK = Fail + optK Fail = mempty + optK (Terminal []) = mempty + optK (KleenePlus rex) = starK rex + optK rex = KleeneOpt rex + starK Fail = mempty + starK (Terminal []) = mempty + starK rex = KleeneStar rex + plusK Fail = empK + plusK (Terminal []) = mempty + plusK rex = KleenePlus rex + 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 +instance NonTerminalSymbol (RegEx token) where + nonTerminal = NonTerminal From 806affb2c83599007c132a0edc959feb746894f9 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 15:57:11 -0700 Subject: [PATCH 045/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 46 ++++++++++++++++--------------------- 1 file changed, 20 insertions(+), 26 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 3d72c09..199a5b4 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -8,7 +8,7 @@ module Control.Lens.Grammar -- * Grammar , Grammar , genGram - , regexString + , regexGrammar -- * CtxGrammar , CtxGrammar -- * Optics @@ -111,23 +111,21 @@ type Contextual s m p = makeNestedPrisms ''RegEx makeNestedPrisms ''GeneralCategory - -regexString :: Grammar Char RegExStr -regexString = dimap runRegExStr RegExStr . ruleRec "regex" $ \rex -> altG rex +regexGrammar :: Grammar Char (RegEx Char) +regexGrammar = ruleRec "regex" altG where altG rex = rule "alternate" $ chain1 Left _Alternate (sepBy (terminal "|")) (seqG rex) anyG = rule "any" $ _AnyToken >?< terminal "." atomG rex = rule "atom" $ choiceP [ nonterminalG - , failG , classInG , classNotInG , categoryInG , categoryNotInG , _Terminal >?< charG >:< pure "" , anyG - , parenG rex + , terminal "(" >* rex *< terminal ")" ] categoryG = rule "category" $ choiceP [ _LowercaseLetter >?< terminal "Ll" @@ -165,57 +163,53 @@ regexString = dimap runRegExStr RegExStr . ruleRec "regex" $ \rex -> altG rex _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" categoryNotInG = rule "category-not-in" $ _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" - charG = rule "char" $ charLiteralG <|> charEscapedG - charEscapedG = rule "char-escaped" $ - terminal "\\" >* oneOf charsReserved - charLiteralG = rule "char-literal" $ notOneOf charsReserved - charsReserved :: String - charsReserved = "$()*+.?[\\]^{|}" + charG = rule "char" $ escapeG "\t\n$()*+.?[\\]^{|}" classInG = rule "class-in" $ _OneOf >?< terminal "[" >* manyP charG *< terminal "]" classNotInG = rule "class-not-in" $ _NotOneOf >?< terminal "[^" >* manyP charG *< terminal "]" exprG rex = rule "expression" $ choiceP - [ terminalG + [ _Terminal >?< someP charG , kleeneOptG rex , kleeneStarG rex , kleenePlusG rex , atomG rex ] - failG = rule "fail" $ _Fail >?< terminal "\\q" - nonterminalG = rule "nonterminal" $ - _NonTerminal >?< terminal "\\q{" >* manyP charG *< terminal "}" - parenG :: Grammarr Char x x - parenG ex = rule "parenthesized" $ - terminal "(" >* ex *< terminal ")" kleeneOptG rex = rule "kleene-optional" $ _KleeneOpt >?< atomG rex *< terminal "?" kleeneStarG rex = rule "kleene-star" $ _KleeneStar >?< atomG rex *< terminal "*" kleenePlusG rex = rule "kleene-plus" $ _KleenePlus >?< atomG rex *< terminal "+" + nonterminalG = rule "nonterminal" $ terminal "\\q" >* + (_NonTerminal >?< ruleG charG <|> _Fail >?< oneP) seqG rex = rule "sequence" $ chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) - terminalG = rule "terminal" $ _Terminal >?< someP charG -newtype RegExStr = RegExStr {runRegExStr :: RegEx Char} +escapeG :: String -> RegGrammar Char Char +escapeG charsReserved = + notOneOf charsReserved <|> terminal "\\" >* oneOf charsReserved + +ruleG :: RegGrammarr Char c [c] +ruleG p = terminal "{" >* manyP p *< terminal "}" + +-- bnfGrammarr :: RegGrammarr Char rule (rule, [(String,rule)]) +-- bnfGrammarr p = terminal "{start} = " >* p >*< manyP (terminal "\n{" >* manyP (notOneOf)) +newtype RegExStr = RegExStr {runRegExStr :: RegEx Char} instance IsList RegExStr where type Item RegExStr = Char fromList = maybe (RegExStr Fail) fst . listToMaybe . filter (\(_, remaining) -> remaining == "") - . genReadS regexString + . genReadS (dimap runRegExStr RegExStr regexGrammar) toList = maybe "\\q" ($ "") - . genShowS regexString - + . genShowS (dimap runRegExStr RegExStr regexGrammar) instance IsString RegExStr where fromString = fromList - instance Show RegExStr where showsPrec precision = showsPrec precision . toList - instance Read RegExStr where readsPrec _ str = [(fromList str, "")] From 09401312468497f6fa0f9ea1682f8fb580dda3d0 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 17:02:39 -0700 Subject: [PATCH 046/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 55 +++++++++++++++++-------------- 1 file changed, 30 insertions(+), 25 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index b8730c5..f3b7e13 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -23,11 +23,11 @@ import Data.Profunctor.Distributor import Data.Profunctor.Monoidal import Data.Word -class (Eq a, Eq (Categorize a)) => Categorized a where - type Categorize a - type Categorize a = () - categorize :: a -> Categorize a - default categorize :: Categorize a ~ () => a -> Categorize a +class (Eq token, Eq (Categorize token)) => Categorized token where + type Categorize token + type Categorize token = () + categorize :: token -> Categorize token + default categorize :: Categorize token ~ () => token -> Categorize token categorize _ = () instance Categorized Char where type Categorize Char = GeneralCategory @@ -80,8 +80,8 @@ class Categorized (Token p) => Tokenized p where => Categorize (Token p) -> p notAsIn = satisfy . notAsIn -instance Categorized c => Tokenized (c -> Bool) where - type Token (c -> Bool) = c +instance Categorized token => Tokenized (token -> Bool) where + type Token (token -> Bool) = token anyToken _ = True noToken _ = False token = (==) @@ -92,21 +92,18 @@ instance Categorized c => Tokenized (c -> Bool) where notAsIn = lmap categorize . (/=) satisfy - :: (Choice p, Cochoice p, Tokenizor a p) - => (a -> Bool) -> p a a + :: (Choice p, Cochoice p, Tokenizor token p) + => (token -> Bool) -> p token token satisfy f = satisfied f >?< anyToken -type Tokenizor a p = (Tokenized (p a a), Token (p a a) ~ a) +type Tokenizor token p = + (Tokenized (p token token), Token (p token token) ~ token) tokens - :: ( AsEmpty s - , Cons s s a a - , Monoidal p - , Choice p - , Tokenizor a p + :: ( AsEmpty s, Cons s s token token + , Monoidal p, Choice p, Tokenizor token p ) - => [a] - -> p s s + => [token] -> p s s tokens [] = asEmpty tokens (a:as) = token a >:< tokens as @@ -115,16 +112,20 @@ tokens (a:as) = token a >:< tokens as of a given token's category while parsing, and produces the given token while printing. -} -oneLike :: forall a p. (Profunctor p, Tokenizor a p) => a -> p () () -oneLike a = dimap (\_ -> a) (\(_::a) -> ()) (asIn (categorize a)) +oneLike + :: forall token p. (Profunctor p, Tokenizor token p) + => token -> p () () +oneLike a = dimap (\_ -> a) (\(_::token) -> ()) (asIn (categorize a)) {- | `manyLike` consumes zero or more tokens of a given token's category while parsing, and produces no tokens printing. -} -manyLike :: forall a p. (Distributor p, Tokenizor a p) => a -> p () () -manyLike a = dimap (\_ -> []::[a]) (\(_::[a]) -> ()) +manyLike + :: forall token p. (Distributor p, Tokenizor token p) + => token -> p () () +manyLike a = dimap (\_ -> []::[token]) (\(_::[token]) -> ()) (manyP (asIn (categorize a))) {- | @@ -132,8 +133,10 @@ manyLike a = dimap (\_ -> []::[a]) (\(_::[a]) -> ()) of a given token's category while parsing, and produces the given token while printing. -} -optLike :: forall a p. (Distributor p, Tokenizor a p) => a -> p () () -optLike a = dimap (\_ -> [a]::[a]) (\(_::[a]) -> ()) +optLike + :: forall token p. (Distributor p, Tokenizor token p) + => token -> p () () +optLike a = dimap (\_ -> [a]::[token]) (\(_::[token]) -> ()) (manyP (asIn (categorize a))) {- | @@ -141,6 +144,8 @@ optLike a = dimap (\_ -> [a]::[a]) (\(_::[a]) -> ()) of a given token's category while parsing, and produces the given token while printing. -} -someLike :: forall a p. (Distributor p, Tokenizor a p) => a -> p () () -someLike a = dimap (\_ -> (a,[]::[a])) (\(_::a, _::[a]) -> ()) +someLike + :: forall token p. (Distributor p, Tokenizor token p) + => token -> p () () +someLike a = dimap (\_ -> (a,[]::[token])) (\(_::token, _::[token]) -> ()) (asIn (categorize a) >*< manyP (asIn (categorize a))) From 0a6872df7db0b785c862a5cef0cdbb0813ce49f4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 17:09:41 -0700 Subject: [PATCH 047/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index aacfb8b..574e941 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -7,12 +7,12 @@ import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Data.Foldable -class Monoid a => KleeneStarAlgebra a where - starK :: a -> a - plusK :: a -> a - optK :: a -> a - (>|<) :: a -> a -> a - empK :: a +class Monoid t => KleeneStarAlgebra t where + starK :: t -> t + plusK :: t -> t + optK :: t -> t + (>|<) :: t -> t -> t + empK :: t data RegEx token = Terminal [token] From 8cd2724a572d0b3f428920963cf2d656aaf764b9 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 17:09:49 -0700 Subject: [PATCH 048/282] Update BackusNaur.hs --- src/Control/Lens/Grammar/BackusNaur.hs | 31 +++++++++++++------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 86953cd..2ed7ed5 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -9,19 +9,19 @@ import Control.Lens.Grammar.Symbol import Data.Function import Data.Set as Set -class BackusNaurForm a where - rule :: String -> a -> a +class BackusNaurForm gram where + rule :: String -> gram -> gram rule _ = id - ruleRec :: String -> (a -> a) -> a + ruleRec :: String -> (gram -> gram) -> gram ruleRec _ = fix -data Gram a = Gram - { startGram :: a - , rulesGram :: Set (String, a) +data Gram rule = Gram + { startGram :: rule + , rulesGram :: Set (String, rule) } deriving stock (Eq, Ord) -instance (Ord a, NonTerminalSymbol a) - => BackusNaurForm (Gram a) where +instance (Ord rule, NonTerminalSymbol rule) + => BackusNaurForm (Gram rule) where rule name = ruleRec name . const ruleRec name f = let @@ -31,8 +31,9 @@ instance (Ord a, NonTerminalSymbol a) in Gram start rules -instance (Ord a, TerminalSymbol a) => TerminalSymbol (Gram a) where - type Alphabet (Gram a) = Alphabet a +instance (Ord t, TerminalSymbol t) + => TerminalSymbol (Gram t) where + type Alphabet (Gram t) = Alphabet t terminal = liftGram0 . terminal liftGram0 :: Ord a => a -> Gram a @@ -45,8 +46,8 @@ liftGram2 :: Ord a => (a -> a -> a) -> Gram a -> Gram a -> Gram a liftGram2 f (Gram start0 rules0) (Gram start1 rules1) = Gram (f start0 start1) (rules0 <> rules1) -instance (Ord a, Tokenized a) => Tokenized (Gram a) where - type Token (Gram a) = Token a +instance (Ord p, Tokenized p) => Tokenized (Gram p) where + type Token (Gram p) = Token p anyToken = liftGram0 anyToken noToken = liftGram0 noToken token = liftGram0 . token @@ -56,13 +57,13 @@ instance (Ord a, Tokenized a) => Tokenized (Gram a) where asIn = liftGram0 . asIn notAsIn = liftGram0 . notAsIn -instance (Ord a, KleeneStarAlgebra a) => KleeneStarAlgebra (Gram a) where +instance (Ord t, KleeneStarAlgebra t) => KleeneStarAlgebra (Gram t) where starK = liftGram1 starK plusK = liftGram1 plusK optK = liftGram1 optK empK = liftGram0 empK (>|<) = liftGram2 (>|<) -instance (Ord a, Monoid a) => Monoid (Gram a) where +instance (Ord t, Monoid t) => Monoid (Gram t) where mempty = liftGram0 mempty -instance (Ord a, Semigroup a) => Semigroup (Gram a) where +instance (Ord t, Semigroup t) => Semigroup (Gram t) where (<>) = liftGram2 (<>) From 9538fc539a83879f2bf1eebcc37a89eb7058f235 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 17:58:11 -0700 Subject: [PATCH 049/282] Update BackusNaur.hs --- src/Control/Lens/Grammar/BackusNaur.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 2ed7ed5..b95109c 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -1,6 +1,9 @@ module Control.Lens.Grammar.BackusNaur ( BackusNaurForm (..) , Gram (..) + , liftGram0 + , liftGram1 + , liftGram2 ) where import Control.Lens.Grammar.Kleene From 008672037f25307e5e9d094b2c9b3d5974c05f7f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 17:58:24 -0700 Subject: [PATCH 050/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 94 +++++++++++++++++++++++++++---------- 1 file changed, 70 insertions(+), 24 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 199a5b4..0ebfe8c 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -2,6 +2,8 @@ module Control.Lens.Grammar ( -- * RegEx RegExStr , RegGrammar + , RegGrammarr + , bnfGrammarr , genRegEx , genShowS , genReadS @@ -9,12 +11,11 @@ module Control.Lens.Grammar , Grammar , genGram , regexGrammar - -- * CtxGrammar - , CtxGrammar - -- * Optics - , RegGrammarr + , ebnfGrammar , Grammarr + , CtxGrammar , CtxGrammarr + -- * Optics , opticGrammarr , grammarrOptic , opticGrammar @@ -32,6 +33,7 @@ module Control.Lens.Grammar ) where import Control.Applicative +import Control.Comonad import Control.Lens import Control.Lens.PartialIso import Control.Lens.Grammar.BackusNaur @@ -40,7 +42,7 @@ import Control.Lens.Grammar.Token import Control.Lens.Grammar.Stream import Control.Lens.Grammar.Symbol import Control.Monad -import Data.Maybe +import Data.Maybe hiding (mapMaybe) import Data.Monoid import Data.Profunctor.Distributor import Data.Profunctor.Filtrator @@ -52,6 +54,9 @@ import GHC.Exts import Prelude hiding (filter) import Witherable +makeNestedPrisms ''RegEx +makeNestedPrisms ''GeneralCategory + type RegGrammar c a = forall p. Regular c p => p a a type Grammar c a = forall p. Grammatical c p => p a a type CtxGrammar s a = forall p m. Contextual s m p => p s s m a a @@ -59,18 +64,25 @@ type CtxGrammar s a = forall p m. Contextual s m p => p s s m a a opticGrammar :: Monoidal p => Optic' p Identity a () -> p a a opticGrammar = ($ oneP) . opticGrammarr -grammarOptic :: Monoidal p => p a a -> Optic' p Identity a () +grammarOptic + :: (Monoidal p, Comonad f, Applicative f) + => p a a -> Optic' p f a () grammarOptic = grammarrOptic . (*<) -type RegGrammarr c a b = forall p. Regular c p => p a a -> p b b -type Grammarr c a b = forall p. Grammatical c p => p a a -> p b b -type CtxGrammarr s a b = forall p m. Contextual s m p => p s s m a a -> p s s m b b +type RegGrammarr c a b = forall p. + Regular c p => p a a -> p b b +type Grammarr c a b = forall p. + Grammatical c p => p a a -> p b b +type CtxGrammarr s a b = forall p m. + Contextual s m p => p s s m a a -> p s s m b b opticGrammarr :: Profunctor p => Optic' p Identity b a -> p a a -> p b b opticGrammarr = dimap (rmap Identity) (rmap runIdentity) -grammarrOptic :: Profunctor p => (p a a -> p b b) -> Optic' p Identity b a -grammarrOptic = dimap (rmap runIdentity) (rmap Identity) +grammarrOptic + :: (Profunctor p, Comonad f, Applicative f) + => (p a a -> p b b) -> Optic' p f b a +grammarrOptic = dimap (rmap extract) (rmap pure) genShowS :: (Filterable m, MonadPlus m) @@ -109,8 +121,6 @@ type Contextual s m p = , MonadPlus m ) -makeNestedPrisms ''RegEx -makeNestedPrisms ''GeneralCategory regexGrammar :: Grammar Char (RegEx Char) regexGrammar = ruleRec "regex" altG where @@ -163,7 +173,7 @@ regexGrammar = ruleRec "regex" altG _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" categoryNotInG = rule "category-not-in" $ _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" - charG = rule "char" $ escapeG "\t\n$()*+.?[\\]^{|}" + charG = rule "char" $ escapedG classInG = rule "class-in" $ _OneOf >?< terminal "[" >* manyP charG *< terminal "]" classNotInG = rule "class-not-in" $ @@ -182,27 +192,47 @@ regexGrammar = ruleRec "regex" altG kleenePlusG rex = rule "kleene-plus" $ _KleenePlus >?< atomG rex *< terminal "+" nonterminalG = rule "nonterminal" $ terminal "\\q" >* - (_NonTerminal >?< ruleG charG <|> _Fail >?< oneP) + (_NonTerminal >?< nameG charG <|> _Fail >?< oneP) seqG rex = rule "sequence" $ chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) -escapeG :: String -> RegGrammar Char Char -escapeG charsReserved = - notOneOf charsReserved <|> terminal "\\" >* oneOf charsReserved +escapedG :: RegGrammar Char Char +escapedG = notOneOf reservedChars + <|> terminal "\\" >* oneOf reservedChars -ruleG :: RegGrammarr Char c [c] -ruleG p = terminal "{" >* manyP p *< terminal "}" +nameG :: RegGrammarr Char c [c] +nameG p = terminal "{" >* manyP p *< terminal "}" --- bnfGrammarr :: RegGrammarr Char rule (rule, [(String,rule)]) --- bnfGrammarr p = terminal "{start} = " >* p >*< manyP (terminal "\n{" >* manyP (notOneOf)) +reservedChars :: String +reservedChars = "\t\n$()*+.?[\\]^{|}" + +bnfGrammarr :: Ord rule => RegGrammarr Char rule (Gram rule) +bnfGrammarr p = dimap hither thither $ startG >*< rulesG + where + hither (Gram start rules) = (start, toList rules) + thither (start, rules) = Gram start (fromList rules) + ruleG = terminal " = " >* p + startG = terminal "{start}" >* ruleG + rulesG = manyP (terminal "\n" >* nameG escapedG >*< ruleG) + +ebnfGrammar :: Grammar Char (Gram (RegEx Char)) +ebnfGrammar = bnfGrammarr regexGrammar newtype RegExStr = RegExStr {runRegExStr :: RegEx Char} +newtype EBNF = EBNF {runEBNF :: Gram (RegEx Char)} + +printRegEx :: RegGrammar Char a -> IO () +printRegEx = putStrLn . toList . RegExStr . genRegEx @Char + +printEBNF :: Grammar Char a -> IO () +printEBNF = putStrLn . toList . EBNF . genGram @Char + instance IsList RegExStr where type Item RegExStr = Char fromList - = maybe (RegExStr Fail) fst + = fromMaybe (RegExStr Fail) . listToMaybe - . filter (\(_, remaining) -> remaining == "") + . mapMaybe (\(rex, remaining) -> if remaining == "" then Just rex else Nothing) . genReadS (dimap runRegExStr RegExStr regexGrammar) toList = maybe "\\q" ($ "") @@ -213,3 +243,19 @@ instance Show RegExStr where showsPrec precision = showsPrec precision . toList instance Read RegExStr where readsPrec _ str = [(fromList str, "")] +instance IsList EBNF where + type Item EBNF = Char + fromList + = fromMaybe (EBNF (Gram Fail mempty)) + . listToMaybe + . mapMaybe (\(ebnf, remaining) -> if remaining == "" then Just ebnf else Nothing) + . genReadS (dimap runEBNF EBNF ebnfGrammar) + toList + = maybe "{start} = \\q" ($ "") + . genShowS (dimap runEBNF EBNF ebnfGrammar) +instance IsString EBNF where + fromString = fromList +instance Show EBNF where + showsPrec precision = showsPrec precision . toList +instance Read EBNF where + readsPrec _ str = [(fromList str, "")] From c5c4f36420bf96d849e52a647836117939d583e0 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 19:41:42 -0700 Subject: [PATCH 051/282] escaped --- src/Control/Lens/Grammar/Token.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index f3b7e13..c65210e 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -2,6 +2,7 @@ module Control.Lens.Grammar.Token ( -- * Token Categorized (..) , Tokenized (..) + , escaped , satisfy , tokens , Tokenizor @@ -91,6 +92,13 @@ instance Categorized token => Tokenized (token -> Bool) where asIn = lmap categorize . (==) notAsIn = lmap categorize . (/=) +escaped + :: (Alternator p, Tokenizor token p) + => (p token token -> p token token) -- ^ escape function + -> [token] -- ^ reserved tokens + -> p token token +escaped escape reserved = escape (oneOf reserved) <|> notOneOf reserved + satisfy :: (Choice p, Cochoice p, Tokenizor token p) => (token -> Bool) -> p token token From 753ec45ac4f4561fe4f2680d086faa9e831d4cba Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 19:41:52 -0700 Subject: [PATCH 052/282] Update BackusNaur.hs --- src/Control/Lens/Grammar/BackusNaur.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index b95109c..f67f0d4 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -9,6 +9,7 @@ module Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Token import Control.Lens.Grammar.Symbol +import Data.Coerce import Data.Function import Data.Set as Set @@ -42,12 +43,14 @@ instance (Ord t, TerminalSymbol t) liftGram0 :: Ord a => a -> Gram a liftGram0 a = Gram a mempty -liftGram1 :: (a -> a) -> Gram a -> Gram a -liftGram1 f (Gram start rules) = Gram (f start) rules +liftGram1 :: (Coercible a b, Ord b) => (a -> b) -> Gram a -> Gram b +liftGram1 f (Gram start rules) = Gram (f start) (Set.map coerce rules) -liftGram2 :: Ord a => (a -> a -> a) -> Gram a -> Gram a -> Gram a +liftGram2 + :: (Coercible a c, Coercible b c, Ord c) + => (a -> b -> c) -> Gram a -> Gram b -> Gram c liftGram2 f (Gram start0 rules0) (Gram start1 rules1) = - Gram (f start0 start1) (rules0 <> rules1) + Gram (f start0 start1) (Set.map coerce rules0 <> Set.map coerce rules1) instance (Ord p, Tokenized p) => Tokenized (Gram p) where type Token (Gram p) = Token p From dac613b2a2dbf5613ec21278f18fcb2ed32e0f88 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 19:42:02 -0700 Subject: [PATCH 053/282] EBNF --- src/Control/Lens/Grammar.hs | 57 ++++++++++++++++++------------------- 1 file changed, 28 insertions(+), 29 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 0ebfe8c..e1b0389 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -1,15 +1,18 @@ module Control.Lens.Grammar ( -- * RegEx RegExStr + , EBNF , RegGrammar , RegGrammarr , bnfGrammarr , genRegEx + , printRegEx , genShowS , genReadS -- * Grammar , Grammar , genGram + , printEBNF , regexGrammar , ebnfGrammar , Grammarr @@ -44,6 +47,7 @@ import Control.Lens.Grammar.Symbol import Control.Monad import Data.Maybe hiding (mapMaybe) import Data.Monoid +import Data.Profunctor import Data.Profunctor.Distributor import Data.Profunctor.Filtrator import Data.Profunctor.Monadic @@ -126,7 +130,15 @@ regexGrammar = ruleRec "regex" altG where altG rex = rule "alternate" $ chain1 Left _Alternate (sepBy (terminal "|")) (seqG rex) - anyG = rule "any" $ _AnyToken >?< terminal "." + seqG rex = rule "sequence" $ + chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) + exprG rex = rule "expression" $ choiceP + [ _Terminal >?< someP charG + , kleeneOptG rex + , kleeneStarG rex + , kleenePlusG rex + , atomG rex + ] atomG rex = rule "atom" $ choiceP [ nonterminalG , classInG @@ -137,6 +149,7 @@ regexGrammar = ruleRec "regex" altG , anyG , terminal "(" >* rex *< terminal ")" ] + anyG = rule "any" $ _AnyToken >?< terminal "." categoryG = rule "category" $ choiceP [ _LowercaseLetter >?< terminal "Ll" , _UppercaseLetter >?< terminal "Lu" @@ -173,18 +186,11 @@ regexGrammar = ruleRec "regex" altG _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" categoryNotInG = rule "category-not-in" $ _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" - charG = rule "char" $ escapedG + charG = rule "char" $ escaped (terminal "\\" >*) "$()*+.?[\\]^{|}" classInG = rule "class-in" $ _OneOf >?< terminal "[" >* manyP charG *< terminal "]" classNotInG = rule "class-not-in" $ _NotOneOf >?< terminal "[^" >* manyP charG *< terminal "]" - exprG rex = rule "expression" $ choiceP - [ _Terminal >?< someP charG - , kleeneOptG rex - , kleeneStarG rex - , kleenePlusG rex - , atomG rex - ] kleeneOptG rex = rule "kleene-optional" $ _KleeneOpt >?< atomG rex *< terminal "?" kleeneStarG rex = rule "kleene-star" $ @@ -192,19 +198,7 @@ regexGrammar = ruleRec "regex" altG kleenePlusG rex = rule "kleene-plus" $ _KleenePlus >?< atomG rex *< terminal "+" nonterminalG = rule "nonterminal" $ terminal "\\q" >* - (_NonTerminal >?< nameG charG <|> _Fail >?< oneP) - seqG rex = rule "sequence" $ - chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) - -escapedG :: RegGrammar Char Char -escapedG = notOneOf reservedChars - <|> terminal "\\" >* oneOf reservedChars - -nameG :: RegGrammarr Char c [c] -nameG p = terminal "{" >* manyP p *< terminal "}" - -reservedChars :: String -reservedChars = "\t\n$()*+.?[\\]^{|}" + (_NonTerminal >?< terminal "{" >* manyP charG *< terminal "}" <|> _Fail >?< oneP) bnfGrammarr :: Ord rule => RegGrammarr Char rule (Gram rule) bnfGrammarr p = dimap hither thither $ startG >*< rulesG @@ -212,20 +206,22 @@ bnfGrammarr p = dimap hither thither $ startG >*< rulesG hither (Gram start rules) = (start, toList rules) thither (start, rules) = Gram start (fromList rules) ruleG = terminal " = " >* p - startG = terminal "{start}" >* ruleG - rulesG = manyP (terminal "\n" >* nameG escapedG >*< ruleG) + startG = terminal "start" >* ruleG + rulesG = manyP (terminal "\n" >* manyP (escaped (terminal "\\" >*) "\\=") >*< ruleG) ebnfGrammar :: Grammar Char (Gram (RegEx Char)) ebnfGrammar = bnfGrammarr regexGrammar newtype RegExStr = RegExStr {runRegExStr :: RegEx Char} -newtype EBNF = EBNF {runEBNF :: Gram (RegEx Char)} + deriving newtype (Eq, Ord) +newtype EBNF = EBNF {runEBNF :: Gram RegExStr} + deriving newtype (Eq, Ord) printRegEx :: RegGrammar Char a -> IO () printRegEx = putStrLn . toList . RegExStr . genRegEx @Char printEBNF :: Grammar Char a -> IO () -printEBNF = putStrLn . toList . EBNF . genGram @Char +printEBNF = putStrLn . toList . EBNF . liftGram1 RegExStr . genGram @Char instance IsList RegExStr where type Item RegExStr = Char @@ -246,13 +242,16 @@ instance Read RegExStr where instance IsList EBNF where type Item EBNF = Char fromList - = fromMaybe (EBNF (Gram Fail mempty)) + = fromMaybe (EBNF (Gram (RegExStr Fail) mempty)) . listToMaybe . mapMaybe (\(ebnf, remaining) -> if remaining == "" then Just ebnf else Nothing) - . genReadS (dimap runEBNF EBNF ebnfGrammar) + . fmap (first' (EBNF . liftGram1 RegExStr)) + . genReadS ebnfGrammar toList = maybe "{start} = \\q" ($ "") - . genShowS (dimap runEBNF EBNF ebnfGrammar) + . genShowS ebnfGrammar + . liftGram1 runRegExStr + . runEBNF instance IsString EBNF where fromString = fromList instance Show EBNF where From 7b64860f3d33c59e4c3aabbe12fc470c194b5739 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 20:22:18 -0700 Subject: [PATCH 054/282] move equator --- distributors.cabal | 2 +- src/Control/Lens/Bifocal.hs | 2 +- src/Control/Lens/Diopter.hs | 2 +- src/Control/Lens/Grammar/Symbol.hs | 2 +- src/Control/Lens/Grate.hs | 2 +- src/Control/Lens/{Grammar => Internal}/Equator.hs | 2 +- src/Control/Lens/Monocle.hs | 2 +- src/Data/Profunctor/Grammar.hs | 8 +++----- 8 files changed, 10 insertions(+), 12 deletions(-) rename src/Control/Lens/{Grammar => Internal}/Equator.hs (96%) diff --git a/distributors.cabal b/distributors.cabal index d5da334..9cf2bf3 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -32,12 +32,12 @@ library Control.Lens.Diopter Control.Lens.Grammar Control.Lens.Grammar.BackusNaur - Control.Lens.Grammar.Equator Control.Lens.Grammar.Kleene Control.Lens.Grammar.Stream Control.Lens.Grammar.Symbol Control.Lens.Grammar.Token Control.Lens.Grate + Control.Lens.Internal.Equator Control.Lens.Internal.NestedPrismTH Control.Lens.Monocle Control.Lens.PartialIso diff --git a/src/Control/Lens/Bifocal.hs b/src/Control/Lens/Bifocal.hs index 887f39f..2fb03c5 100644 --- a/src/Control/Lens/Bifocal.hs +++ b/src/Control/Lens/Bifocal.hs @@ -34,7 +34,7 @@ module Control.Lens.Bifocal import Control.Applicative import Control.Lens -import Control.Lens.Grammar.Equator +import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso import Control.Lens.Grammar.Stream diff --git a/src/Control/Lens/Diopter.hs b/src/Control/Lens/Diopter.hs index fdd92d8..e487c3c 100644 --- a/src/Control/Lens/Diopter.hs +++ b/src/Control/Lens/Diopter.hs @@ -25,7 +25,7 @@ module Control.Lens.Diopter ) where import Control.Lens -import Control.Lens.Grammar.Equator +import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Data.Profunctor.Distributor import Data.Void diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index ab7abb0..e56802c 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -4,7 +4,7 @@ module Control.Lens.Grammar.Symbol , NonTerminalSymbol (..) ) where -import Control.Lens.Grammar.Equator +import Control.Lens.Internal.Equator import Data.Kind import Data.Profunctor import Data.Profunctor.Monoidal diff --git a/src/Control/Lens/Grate.hs b/src/Control/Lens/Grate.hs index c1d42d4..9e27926 100644 --- a/src/Control/Lens/Grate.hs +++ b/src/Control/Lens/Grate.hs @@ -30,7 +30,7 @@ module Control.Lens.Grate , Grating (..) ) where -import Control.Lens.Grammar.Equator +import Control.Lens.Internal.Equator import Data.Distributive import Data.Function import Data.Functor.Identity diff --git a/src/Control/Lens/Grammar/Equator.hs b/src/Control/Lens/Internal/Equator.hs similarity index 96% rename from src/Control/Lens/Grammar/Equator.hs rename to src/Control/Lens/Internal/Equator.hs index 7a14dcb..6eef131 100644 --- a/src/Control/Lens/Grammar/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -1,4 +1,4 @@ -module Control.Lens.Grammar.Equator +module Control.Lens.Internal.Equator ( -- * Equator (..) , is diff --git a/src/Control/Lens/Monocle.hs b/src/Control/Lens/Monocle.hs index a76896f..166d468 100644 --- a/src/Control/Lens/Monocle.hs +++ b/src/Control/Lens/Monocle.hs @@ -27,7 +27,7 @@ module Control.Lens.Monocle ) where import Control.Lens hiding (Traversing) -import Control.Lens.Grammar.Equator +import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Data.Distributive import Data.Profunctor.Monoidal diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index b162d7d..7232fd8 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -16,7 +16,7 @@ import Control.Arrow import Control.Category import Control.Comonad import Control.Lens -import Control.Lens.Grammar.Equator +import Control.Lens.Internal.Equator import Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Stream @@ -112,7 +112,7 @@ instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) type Token (Parsor s s m a a) = a anyToken = Parsor (maybe empty pure . uncons) instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => Equator a a (Parsor s s m) where + => Equator a a (Parsor s s m) instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) => TerminalSymbol (Parsor s s m () ()) where type Alphabet (Parsor s s m () ()) = Item s @@ -207,7 +207,7 @@ instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) type Token (Printor s s m a a) = a anyToken = Printor (\b -> pure (b, cons b)) instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => Equator a a (Printor s s m) where + => Equator a a (Printor s s m) instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) => TerminalSymbol (Printor s s m () ()) where type Alphabet (Printor s s m () ()) = Item s @@ -278,8 +278,6 @@ instance (TerminalSymbol t, Applicative f) => TerminalSymbol (Grammor s t f a b) where type Alphabet (Grammor s t f a b) = Alphabet t terminal = grammor . terminal -instance (Tokenized t, Applicative f, Token t ~ a) - => Equator a a (Grammor s t f) instance (Comonad f, Applicative f, Monoid s, BackusNaurForm t) => BackusNaurForm (Grammor s t f a b) where rule name = Grammor . fmap (fmap (rule name)) . runGrammor From 11f5bf29f743d0bf58488045a9c21cd6823711ae Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 20:40:45 -0700 Subject: [PATCH 055/282] equator --- src/Control/Lens/Grammar/Symbol.hs | 2 +- src/Control/Lens/Internal/Equator.hs | 21 +++++++++++---------- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index e56802c..aee3d4b 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -23,7 +23,7 @@ class TerminalSymbol s where , Eq (Alphabet s) ) => [Alphabet s] -> s - terminal = is + terminal = equator instance TerminalSymbol [a] where type Alphabet [a] = a diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index 6eef131..2f0c552 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -1,7 +1,8 @@ module Control.Lens.Internal.Equator ( -- * - Equator (..) - , is + Equator (..) + , Equated + , equator , Identical (..) ) where @@ -14,9 +15,9 @@ import Control.Lens.PartialIso import Data.Profunctor import Data.Profunctor.Monoidal -class Equator i j p | p -> i, p -> i where - equate :: p i j - default equate :: (Tokenizor a p, i ~ a, j ~ a) => p i j +class Equator a b p | p -> a, p -> b where + equate :: p a b + default equate :: (Tokenizor token p, a ~ token, b ~ token) => p a b equate = anyToken instance Equator a b (Identical a b) where equate = Identical instance Equator a b (Exchange a b) where @@ -29,8 +30,8 @@ instance (Equator a b p, Profunctor p, Applicative f) => Equator a b (WrappedPafb f p) where equate = WrapPafb (rmap pure equate) -is - :: (Monoidal p, Cochoice p, Equator a a p, Eq a) - => [a] -> p () () -is [] = oneP -is (a:as) = only a ?< equate *> is as +type Equated a p = (Eq a, Equator a a p, Monoidal p, Cochoice p) + +equator :: Equated a p => [a] -> p () () +equator [] = oneP +equator (a:as) = only a ?< equate *> equator as From bdddcb90c0af40acbd1f245dbcb05aa174c3c757 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 20:47:40 -0700 Subject: [PATCH 056/282] Equator' --- src/Control/Lens/Grammar/Symbol.hs | 11 +++-------- src/Control/Lens/Internal/Equator.hs | 6 +++--- 2 files changed, 6 insertions(+), 11 deletions(-) diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index aee3d4b..7f29ceb 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -6,22 +6,17 @@ module Control.Lens.Grammar.Symbol import Control.Lens.Internal.Equator import Data.Kind -import Data.Profunctor -import Data.Profunctor.Monoidal type Terminator a p = ( a ~ Alphabet (p () ()) - , forall x y. (x ~ (), y ~ ()) => TerminalSymbol (p x y) - ) :: Constraint + , forall x y. (x ~ (), y ~ ()) => TerminalSymbol (p x y) :: Constraint + ) class TerminalSymbol s where type Alphabet s terminal :: [Alphabet s] -> s default terminal - :: ( Monoidal p, Cochoice p, p () () ~ s - , Equator (Alphabet s) (Alphabet s) p - , Eq (Alphabet s) - ) + :: (p () () ~ s, Equator' (Alphabet s) p) => [Alphabet s] -> s terminal = equator diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index 2f0c552..1587abe 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -1,7 +1,7 @@ module Control.Lens.Internal.Equator ( -- * Equator (..) - , Equated + , Equator' , equator , Identical (..) ) where @@ -30,8 +30,8 @@ instance (Equator a b p, Profunctor p, Applicative f) => Equator a b (WrappedPafb f p) where equate = WrapPafb (rmap pure equate) -type Equated a p = (Eq a, Equator a a p, Monoidal p, Cochoice p) +type Equator' a p = (Eq a, Equator a a p, Monoidal p, Cochoice p) -equator :: Equated a p => [a] -> p () () +equator :: Equator' a p => [a] -> p () () equator [] = oneP equator (a:as) = only a ?< equate *> equator as From a31a45b02aa13a5229cac3ca3ef874f76276858e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 21:07:43 -0700 Subject: [PATCH 057/282] Update Symbol.hs --- src/Control/Lens/Grammar/Symbol.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index 7f29ceb..ff720d6 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -9,8 +9,8 @@ import Data.Kind type Terminator a p = ( a ~ Alphabet (p () ()) - , forall x y. (x ~ (), y ~ ()) => TerminalSymbol (p x y) :: Constraint - ) + , forall x y. (x ~ (), y ~ ()) => TerminalSymbol (p x y) + ) :: Constraint class TerminalSymbol s where type Alphabet s @@ -24,5 +24,5 @@ instance TerminalSymbol [a] where type Alphabet [a] = a terminal = id -class NonTerminalSymbol a where - nonTerminal :: String -> a +class NonTerminalSymbol s where + nonTerminal :: String -> s From bd6ca57bd9e61cb772f98be7d4530dc07288b96d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 21:51:25 -0700 Subject: [PATCH 058/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 574e941..8759de0 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -3,16 +3,25 @@ module Control.Lens.Grammar.Kleene , RegEx (..) ) where +import Control.Applicative import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Data.Foldable +import Data.Monoid +import Prelude hiding ((*), (+)) class Monoid t => KleeneStarAlgebra t where - starK :: t -> t - plusK :: t -> t - optK :: t -> t + starK, plusK, optK :: t -> t + starK t = optK (starK t) + plusK t = t <> starK t + optK t = mempty >|< t (>|<) :: t -> t -> t + default (>|<) :: (t ~ f a, Alternative f) => t -> t -> t + (>|<) = (<|>) empK :: t + default empK :: (t ~ f a, Alternative f) => t + empK = empty +instance (Alternative f, Monoid t) => KleeneStarAlgebra (Ap f t) data RegEx token = Terminal [token] From b5c9d8771dde8fb09f88e8469c660ba403711f76 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 21:55:09 -0700 Subject: [PATCH 059/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 8759de0..c11642b 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -15,6 +15,7 @@ class Monoid t => KleeneStarAlgebra t where starK t = optK (starK t) plusK t = t <> starK t optK t = mempty >|< t + infixl 3 >|< (>|<) :: t -> t -> t default (>|<) :: (t ~ f a, Alternative f) => t -> t -> t (>|<) = (<|>) From 3a6bb1d26ce7e659eab20702232cf23ea082a2be Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 22:01:06 -0700 Subject: [PATCH 060/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index c11642b..da6ad8d 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -17,10 +17,10 @@ class Monoid t => KleeneStarAlgebra t where optK t = mempty >|< t infixl 3 >|< (>|<) :: t -> t -> t - default (>|<) :: (t ~ f a, Alternative f) => t -> t -> t - (>|<) = (<|>) empK :: t + default (>|<) :: (t ~ f a, Alternative f) => t -> t -> t default empK :: (t ~ f a, Alternative f) => t + (>|<) = (<|>) empK = empty instance (Alternative f, Monoid t) => KleeneStarAlgebra (Ap f t) From f9c40d9d95aed55d4fd435a97cef29ee622370fb Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 22:57:30 -0700 Subject: [PATCH 061/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index e1b0389..2203d30 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -134,9 +134,9 @@ regexGrammar = ruleRec "regex" altG chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) exprG rex = rule "expression" $ choiceP [ _Terminal >?< someP charG - , kleeneOptG rex - , kleeneStarG rex - , kleenePlusG rex + , _KleeneOpt >?< atomG rex *< terminal "?" + , _KleeneStar >?< atomG rex *< terminal "*" + , _KleenePlus >?< atomG rex *< terminal "+" , atomG rex ] atomG rex = rule "atom" $ choiceP @@ -191,12 +191,6 @@ regexGrammar = ruleRec "regex" altG _OneOf >?< terminal "[" >* manyP charG *< terminal "]" classNotInG = rule "class-not-in" $ _NotOneOf >?< terminal "[^" >* manyP charG *< terminal "]" - kleeneOptG rex = rule "kleene-optional" $ - _KleeneOpt >?< atomG rex *< terminal "?" - kleeneStarG rex = rule "kleene-star" $ - _KleeneStar >?< atomG rex *< terminal "*" - kleenePlusG rex = rule "kleene-plus" $ - _KleenePlus >?< atomG rex *< terminal "+" nonterminalG = rule "nonterminal" $ terminal "\\q" >* (_NonTerminal >?< terminal "{" >* manyP charG *< terminal "}" <|> _Fail >?< oneP) From 4018cb4a5db8f9bf865aa68a0412887d43f29d0e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 23:05:53 -0700 Subject: [PATCH 062/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 33 +++++++++++++-------------------- 1 file changed, 13 insertions(+), 20 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 2203d30..98f1ae4 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -134,22 +134,22 @@ regexGrammar = ruleRec "regex" altG chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) exprG rex = rule "expression" $ choiceP [ _Terminal >?< someP charG - , _KleeneOpt >?< atomG rex *< terminal "?" - , _KleeneStar >?< atomG rex *< terminal "*" - , _KleenePlus >?< atomG rex *< terminal "+" + , _KleeneOpt >? atomG rex *< terminal "?" + , _KleeneStar >? atomG rex *< terminal "*" + , _KleenePlus >? atomG rex *< terminal "+" , atomG rex ] atomG rex = rule "atom" $ choiceP [ nonterminalG - , classInG - , classNotInG - , categoryInG - , categoryNotInG + , _OneOf >?< terminal "[" >* manyP charG *< terminal "]" + , _NotOneOf >?< terminal "[^" >* manyP charG *< terminal "]" + , _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" + , _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" , _Terminal >?< charG >:< pure "" - , anyG + , _AnyToken >?< terminal "." , terminal "(" >* rex *< terminal ")" ] - anyG = rule "any" $ _AnyToken >?< terminal "." + charG = rule "char" $ escaped (terminal "\\" >*) "$()*+.?[\\]^{|}" categoryG = rule "category" $ choiceP [ _LowercaseLetter >?< terminal "Ll" , _UppercaseLetter >?< terminal "Lu" @@ -182,17 +182,10 @@ regexGrammar = ruleRec "regex" altG , _PrivateUse >?< terminal "Co" , _NotAssigned >?< terminal "Cn" ] - categoryInG = rule "category-in" $ - _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" - categoryNotInG = rule "category-not-in" $ - _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" - charG = rule "char" $ escaped (terminal "\\" >*) "$()*+.?[\\]^{|}" - classInG = rule "class-in" $ - _OneOf >?< terminal "[" >* manyP charG *< terminal "]" - classNotInG = rule "class-not-in" $ - _NotOneOf >?< terminal "[^" >* manyP charG *< terminal "]" - nonterminalG = rule "nonterminal" $ terminal "\\q" >* - (_NonTerminal >?< terminal "{" >* manyP charG *< terminal "}" <|> _Fail >?< oneP) + nonterminalG = rule "nonterminal" $ terminal "\\q" >* choiceP + [ _NonTerminal >?< terminal "{" >* manyP charG *< terminal "}" + , _Fail >?< oneP + ] bnfGrammarr :: Ord rule => RegGrammarr Char rule (Gram rule) bnfGrammarr p = dimap hither thither $ startG >*< rulesG From 49a955c331dc53b6c2547dd757607612f4433fa9 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 23:14:52 -0700 Subject: [PATCH 063/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 98f1ae4..3aa53d7 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -141,12 +141,12 @@ regexGrammar = ruleRec "regex" altG ] atomG rex = rule "atom" $ choiceP [ nonterminalG - , _OneOf >?< terminal "[" >* manyP charG *< terminal "]" - , _NotOneOf >?< terminal "[^" >* manyP charG *< terminal "]" - , _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" - , _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" , _Terminal >?< charG >:< pure "" , _AnyToken >?< terminal "." + , _OneOf >?< terminal "[" >* someP charG *< terminal "]" + , _NotOneOf >?< terminal "[^" >* someP charG *< terminal "]" + , _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" + , _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" , terminal "(" >* rex *< terminal ")" ] charG = rule "char" $ escaped (terminal "\\" >*) "$()*+.?[\\]^{|}" From 35233bb1ceb6c8710268da7201f0ecb6e1103c89 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 26 Oct 2025 23:32:53 -0700 Subject: [PATCH 064/282] escape --- src/Control/Lens/Grammar.hs | 9 +++++---- src/Control/Lens/Grammar/Token.hs | 10 +++++----- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 3aa53d7..38818ab 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -149,7 +149,7 @@ regexGrammar = ruleRec "regex" altG , _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" , terminal "(" >* rex *< terminal ")" ] - charG = rule "char" $ escaped (terminal "\\" >*) "$()*+.?[\\]^{|}" + charG = rule "char" $ escape "$()*+.?[\\]^{|}" (terminal "\\" >*) categoryG = rule "category" $ choiceP [ _LowercaseLetter >?< terminal "Ll" , _UppercaseLetter >?< terminal "Lu" @@ -184,7 +184,7 @@ regexGrammar = ruleRec "regex" altG ] nonterminalG = rule "nonterminal" $ terminal "\\q" >* choiceP [ _NonTerminal >?< terminal "{" >* manyP charG *< terminal "}" - , _Fail >?< oneP + , opticGrammar _Fail ] bnfGrammarr :: Ord rule => RegGrammarr Char rule (Gram rule) @@ -192,9 +192,10 @@ bnfGrammarr p = dimap hither thither $ startG >*< rulesG where hither (Gram start rules) = (start, toList rules) thither (start, rules) = Gram start (fromList rules) - ruleG = terminal " = " >* p startG = terminal "start" >* ruleG - rulesG = manyP (terminal "\n" >* manyP (escaped (terminal "\\" >*) "\\=") >*< ruleG) + rulesG = manyP (terminal "\n" >* nameG >*< ruleG) + ruleG = terminal " = " >* p + nameG = manyP (escape "\\= " (terminal "\\" >*)) ebnfGrammar :: Grammar Char (Gram (RegEx Char)) ebnfGrammar = bnfGrammarr regexGrammar diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index c65210e..d727d07 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -2,7 +2,7 @@ module Control.Lens.Grammar.Token ( -- * Token Categorized (..) , Tokenized (..) - , escaped + , escape , satisfy , tokens , Tokenizor @@ -92,12 +92,12 @@ instance Categorized token => Tokenized (token -> Bool) where asIn = lmap categorize . (==) notAsIn = lmap categorize . (/=) -escaped +escape :: (Alternator p, Tokenizor token p) - => (p token token -> p token token) -- ^ escape function - -> [token] -- ^ reserved tokens + => [token] -- ^ tokens to escape + -> (p token token -> p token token) -- ^ how to escape a token -> p token token -escaped escape reserved = escape (oneOf reserved) <|> notOneOf reserved +escape as f = f (oneOf as) <|> notOneOf as satisfy :: (Choice p, Cochoice p, Tokenizor token p) From 70bcf93d9fac1ef05d1aa5daa50a77f7a88c78df Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 12:14:57 -0700 Subject: [PATCH 065/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index da6ad8d..7001c97 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -57,8 +57,11 @@ instance Categorized token => Tokenized (RegEx token) where noToken = empK token a = terminal [a] notToken a = notOneOf [a] - oneOf = OneOf . toList - notOneOf = NotOneOf . toList + oneOf [] = noToken + oneOf [a] = token a + oneOf as = OneOf (toList as) + notOneOf [] = anyToken + notOneOf as = NotOneOf (toList as) asIn = AsIn notAsIn = NotAsIn instance Categorized token => Semigroup (RegEx token) where From 4d2227ef77fb8a241e29336fe060d079f61c579b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 14:59:11 -0700 Subject: [PATCH 066/282] escapes --- src/Control/Lens/Grammar/Token.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index d727d07..f17b494 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -3,6 +3,7 @@ module Control.Lens.Grammar.Token Categorized (..) , Tokenized (..) , escape + , escapes , satisfy , tokens , Tokenizor @@ -97,7 +98,16 @@ escape => [token] -- ^ tokens to escape -> (p token token -> p token token) -- ^ how to escape a token -> p token token -escape as f = f (oneOf as) <|> notOneOf as +escape toEsc f = escapes [(toEsc, f)] + +escapes + :: (Alternator p, Tokenizor token p) + => [([token], p token token -> p token token)] + -- ^ how to escape different token classes + -> p token token +escapes escs = choiceP $ + notOneOf (do (toEsc, _) <- escs; toEsc) + : [f (oneOf toEsc) | (toEsc, f) <- escs] satisfy :: (Choice p, Cochoice p, Tokenizor token p) From bc681ac2c2dd7645fd9a35c10752060fb60b9b79 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 15:04:08 -0700 Subject: [PATCH 067/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 7001c97..cb83a45 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -8,7 +8,6 @@ import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Data.Foldable import Data.Monoid -import Prelude hiding ((*), (+)) class Monoid t => KleeneStarAlgebra t where starK, plusK, optK :: t -> t From 47a060caa75244c4359018c59fb6b16bdd6488b4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 15:21:07 -0700 Subject: [PATCH 068/282] Update BackusNaur.hs --- src/Control/Lens/Grammar/BackusNaur.hs | 28 +++++++++++++++----------- 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index f67f0d4..1d38abb 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -22,7 +22,19 @@ class BackusNaurForm gram where data Gram rule = Gram { startGram :: rule , rulesGram :: Set (String, rule) - } deriving stock (Eq, Ord) + } deriving stock (Eq, Ord, Show, Read) + +liftGram0 :: Ord a => a -> Gram a +liftGram0 a = Gram a mempty + +liftGram1 :: (Coercible a b, Ord b) => (a -> b) -> Gram a -> Gram b +liftGram1 f (Gram start rules) = Gram (f start) (Set.map coerce rules) + +liftGram2 + :: (Coercible a c, Coercible b c, Ord c) + => (a -> b -> c) -> Gram a -> Gram b -> Gram c +liftGram2 f (Gram start0 rules0) (Gram start1 rules1) = + Gram (f start0 start1) (Set.map coerce rules0 <> Set.map coerce rules1) instance (Ord rule, NonTerminalSymbol rule) => BackusNaurForm (Gram rule) where @@ -40,17 +52,9 @@ instance (Ord t, TerminalSymbol t) type Alphabet (Gram t) = Alphabet t terminal = liftGram0 . terminal -liftGram0 :: Ord a => a -> Gram a -liftGram0 a = Gram a mempty - -liftGram1 :: (Coercible a b, Ord b) => (a -> b) -> Gram a -> Gram b -liftGram1 f (Gram start rules) = Gram (f start) (Set.map coerce rules) - -liftGram2 - :: (Coercible a c, Coercible b c, Ord c) - => (a -> b -> c) -> Gram a -> Gram b -> Gram c -liftGram2 f (Gram start0 rules0) (Gram start1 rules1) = - Gram (f start0 start1) (Set.map coerce rules0 <> Set.map coerce rules1) +instance (Ord t, NonTerminalSymbol t) + => NonTerminalSymbol (Gram t) where + nonTerminal = liftGram0 . nonTerminal instance (Ord p, Tokenized p) => Tokenized (Gram p) where type Token (Gram p) = Token p From cc03e8aadb35c184a9d2df7053a660f2b4ae041b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 15:21:10 -0700 Subject: [PATCH 069/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 38818ab..cecee19 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -201,9 +201,18 @@ ebnfGrammar :: Grammar Char (Gram (RegEx Char)) ebnfGrammar = bnfGrammarr regexGrammar newtype RegExStr = RegExStr {runRegExStr :: RegEx Char} - deriving newtype (Eq, Ord) + deriving newtype + ( Eq, Ord + , Semigroup, Monoid, KleeneStarAlgebra + , Tokenized, TerminalSymbol, NonTerminalSymbol + ) newtype EBNF = EBNF {runEBNF :: Gram RegExStr} - deriving newtype (Eq, Ord) + deriving newtype + ( Eq, Ord + , Semigroup, Monoid, KleeneStarAlgebra + , Tokenized, TerminalSymbol, NonTerminalSymbol + , BackusNaurForm + ) printRegEx :: RegGrammar Char a -> IO () printRegEx = putStrLn . toList . RegExStr . genRegEx @Char From 44f7dd6bf2b67ead1005b6902018d3d5b2deaaaf Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 16:06:30 -0700 Subject: [PATCH 070/282] streamLine --- src/Control/Lens/Grammar.hs | 4 ++-- src/Control/Lens/Grammar/Stream.hs | 13 ++++++++++--- 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index cecee19..40820a4 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -215,10 +215,10 @@ newtype EBNF = EBNF {runEBNF :: Gram RegExStr} ) printRegEx :: RegGrammar Char a -> IO () -printRegEx = putStrLn . toList . RegExStr . genRegEx @Char +printRegEx = streamLine . RegExStr . genRegEx @Char printEBNF :: Grammar Char a -> IO () -printEBNF = putStrLn . toList . EBNF . liftGram1 RegExStr . genGram @Char +printEBNF = streamLine . EBNF . liftGram1 RegExStr . genGram @Char instance IsList RegExStr where type Item RegExStr = Char diff --git a/src/Control/Lens/Grammar/Stream.hs b/src/Control/Lens/Grammar/Stream.hs index 0d8e4a2..7eb58b7 100644 --- a/src/Control/Lens/Grammar/Stream.hs +++ b/src/Control/Lens/Grammar/Stream.hs @@ -1,15 +1,19 @@ module Control.Lens.Grammar.Stream - ( -- * + ( -- * Stream IsStream - , listed - , streamed , stream , stream1 + -- * SepBy , SepBy (..) , sepBy , noSep + -- * Chain , chain , chain1 + -- Utilities + , listed + , streamed + , streamLine ) where import Control.Applicative @@ -23,6 +27,9 @@ import GHC.Exts type IsStream s = (IsList s, AsEmpty s, Cons s s (Item s) (Item s)) +streamLine :: (IsList s, Item s ~ Char) => s -> IO () +streamLine = putStrLn . toList + listed :: (IsList s, IsList t, Item s ~ Item t) => Iso' s t listed = iso (fromList . toList) (fromList . toList) From f34898aeaf81f3b161ae030887180933e76b8648 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 16:09:19 -0700 Subject: [PATCH 071/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index cb83a45..60882e9 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -11,7 +11,7 @@ import Data.Monoid class Monoid t => KleeneStarAlgebra t where starK, plusK, optK :: t -> t - starK t = optK (starK t) + starK t = optK (plusK t) plusK t = t <> starK t optK t = mempty >|< t infixl 3 >|< From a7d3db6c90c7607c88321abebc22a2edffc1e94c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 16:34:14 -0700 Subject: [PATCH 072/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 60882e9..405b5b6 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -25,18 +25,18 @@ instance (Alternative f, Monoid t) => KleeneStarAlgebra (Ap f t) data RegEx token = Terminal [token] + | NonTerminal String | Sequence (RegEx token) (RegEx token) - | Fail - | Alternate (RegEx token) (RegEx token) - | KleeneOpt (RegEx token) | KleeneStar (RegEx token) + | KleeneOpt (RegEx token) | KleenePlus (RegEx token) + | Alternate (RegEx token) (RegEx token) + | Fail | AnyToken | OneOf [token] | NotOneOf [token] | AsIn (Categorize token) | NotAsIn (Categorize token) - | NonTerminal String deriving stock instance Categorized token => Eq (RegEx token) deriving stock instance (Categorized token, Ord token, Ord (Categorize token)) @@ -53,13 +53,13 @@ instance TerminalSymbol (RegEx token) where instance Categorized token => Tokenized (RegEx token) where type Token (RegEx token) = token anyToken = AnyToken - noToken = empK - token a = terminal [a] - notToken a = notOneOf [a] - oneOf [] = noToken - oneOf [a] = token a + noToken = Fail + token a = Terminal [a] + notToken a = NotOneOf [a] + oneOf [] = Fail + oneOf [a] = Terminal [a] oneOf as = OneOf (toList as) - notOneOf [] = anyToken + notOneOf [] = AnyToken notOneOf as = NotOneOf (toList as) asIn = AsIn notAsIn = NotAsIn From 4165ada9f2bac23e1a0c692c1f9ad57b09b35f58 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 16:44:31 -0700 Subject: [PATCH 073/282] Update Equator.hs --- src/Control/Lens/Internal/Equator.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index 1587abe..ffd3767 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -32,6 +32,5 @@ instance (Equator a b p, Profunctor p, Applicative f) type Equator' a p = (Eq a, Equator a a p, Monoidal p, Cochoice p) -equator :: Equator' a p => [a] -> p () () -equator [] = oneP -equator (a:as) = only a ?< equate *> equator as +equator :: (Foldable f, Equator' a p) => f a -> p () () +equator = foldr (\a p -> only a ?< equate *> p) oneP From 83e441fb091ee24fb76302a1863df963a246733c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 18:21:54 -0700 Subject: [PATCH 074/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index f17b494..798abcf 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -118,10 +118,10 @@ type Tokenizor token p = (Tokenized (p token token), Token (p token token) ~ token) tokens - :: ( AsEmpty s, Cons s s token token - , Monoidal p, Choice p, Tokenizor token p + :: ( AsEmpty s, Cons s s a a + , Monoidal p, Choice p, Tokenizor a p ) - => [token] -> p s s + => [a] -> p s s tokens [] = asEmpty tokens (a:as) = token a >:< tokens as @@ -158,7 +158,7 @@ optLike a = dimap (\_ -> [a]::[token]) (\(_::[token]) -> ()) (manyP (asIn (categorize a))) {- | -`someLike` accepts one or more tokens +`someLike` consumes one or more tokens of a given token's category while parsing, and produces the given token while printing. -} From 5423b81a51012466af0afbaadfa6bbc6badc2270 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 18:21:58 -0700 Subject: [PATCH 075/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 40820a4..9d7b0cd 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -1,7 +1,7 @@ module Control.Lens.Grammar ( -- * RegEx - RegExStr - , EBNF + RegExStr (..) + , EBNF (..) , RegGrammar , RegGrammarr , bnfGrammarr @@ -33,6 +33,14 @@ module Control.Lens.Grammar , module Control.Lens.Grammar.Token , module Control.Lens.Grammar.Stream , module Control.Lens.Grammar.Symbol + , module Control.Lens.PartialIso + , module Control.Lens + , module Data.Profunctor + , module Data.Profunctor.Distributor + , module Data.Profunctor.Filtrator + , module Data.Profunctor.Grammar + , module Data.Profunctor.Monadic + , module Data.Profunctor.Monoidal ) where import Control.Applicative From e48c2f6320b730f8be19381a67a6186c050a075f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 27 Oct 2025 18:22:03 -0700 Subject: [PATCH 076/282] Update Stream.hs --- src/Control/Lens/Grammar/Stream.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Lens/Grammar/Stream.hs b/src/Control/Lens/Grammar/Stream.hs index 7eb58b7..e5c6b02 100644 --- a/src/Control/Lens/Grammar/Stream.hs +++ b/src/Control/Lens/Grammar/Stream.hs @@ -10,7 +10,7 @@ module Control.Lens.Grammar.Stream -- * Chain , chain , chain1 - -- Utilities + -- * Utilities , listed , streamed , streamLine @@ -90,7 +90,7 @@ noSep = sepBy oneP chain :: (Alternator p, Filtrator p) - => (forall x. x -> Either x x) -- `Left` or `Right` associate + => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern -> APartialIso a b () () -- ^ nilary constructor pattern -> SepBy (p () ()) -> p a b -> p a b @@ -101,7 +101,7 @@ chain assoc c2 c0 sep p = chain1 :: (Distributor p, Choice p, Cochoice p) - => (forall x. x -> Either x x) -- `Left` or `Right` associate + => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern -> SepBy (p () ()) -> p a b -> p a b chain1 = leftOrRight chainl1 chainr1 From a90fa197a944cde82b73523b9c2ce16a3501dba1 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 28 Oct 2025 07:11:04 -0700 Subject: [PATCH 077/282] Update Symbol.hs --- src/Control/Lens/Grammar/Symbol.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index ff720d6..dc9f9b4 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -7,8 +7,8 @@ module Control.Lens.Grammar.Symbol import Control.Lens.Internal.Equator import Data.Kind -type Terminator a p = - ( a ~ Alphabet (p () ()) +type Terminator token p = + ( token ~ Alphabet (p () ()) , forall x y. (x ~ (), y ~ ()) => TerminalSymbol (p x y) ) :: Constraint From 5f0b54339539fb2ff46cfd6b555f32f99abcaa94 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 28 Oct 2025 07:18:03 -0700 Subject: [PATCH 078/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 70 ++++++++++++++++--------------------- 1 file changed, 31 insertions(+), 39 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 9d7b0cd..08983df 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -28,19 +28,15 @@ module Control.Lens.Grammar , Grammatical , Contextual -- * Re-exports + , oneP, (>*), (*<), (>*<), replicateP + , empty, (<|>), manyP, someP, optionalP , module Control.Lens.Grammar.BackusNaur , module Control.Lens.Grammar.Kleene , module Control.Lens.Grammar.Token , module Control.Lens.Grammar.Stream , module Control.Lens.Grammar.Symbol , module Control.Lens.PartialIso - , module Control.Lens - , module Data.Profunctor - , module Data.Profunctor.Distributor - , module Data.Profunctor.Filtrator , module Data.Profunctor.Grammar - , module Data.Profunctor.Monadic - , module Data.Profunctor.Monoidal ) where import Control.Applicative @@ -69,9 +65,33 @@ import Witherable makeNestedPrisms ''RegEx makeNestedPrisms ''GeneralCategory -type RegGrammar c a = forall p. Regular c p => p a a -type Grammar c a = forall p. Grammatical c p => p a a -type CtxGrammar s a = forall p m. Contextual s m p => p s s m a a +type RegGrammar token a = forall p. Regular token p => p a a +type Grammar token a = forall p. Grammatical token p => p a a +type CtxGrammar token a = forall p m. Contextual token m p => p m a a + +type RegGrammarr token a b = + forall p. Regular token p => p a a -> p b b +type Grammarr token a b = + forall p. Grammatical token p => p a a -> p b b +type CtxGrammarr token a b = + forall p m. Contextual token m p => p m a a -> p m b b + +type Regular token p = + ( Terminator token p + , Tokenizor token p + , Alternator p + ) +type Grammatical token p = + ( Regular token p + , Filtrator p + , forall x. BackusNaurForm (p x x) + ) +type Contextual token m p = + ( Grammatical token (p m) + , Monadic p + , Filterable m + , MonadPlus m + ) opticGrammar :: Monoidal p => Optic' p Identity a () -> p a a opticGrammar = ($ oneP) . opticGrammarr @@ -81,13 +101,6 @@ grammarOptic => p a a -> Optic' p f a () grammarOptic = grammarrOptic . (*<) -type RegGrammarr c a b = forall p. - Regular c p => p a a -> p b b -type Grammarr c a b = forall p. - Grammatical c p => p a a -> p b b -type CtxGrammarr s a b = forall p m. - Contextual s m p => p s s m a a -> p s s m b b - opticGrammarr :: Profunctor p => Optic' p Identity b a -> p a a -> p b b opticGrammarr = dimap (rmap Identity) (rmap runIdentity) @@ -98,10 +111,10 @@ grammarrOptic = dimap (rmap extract) (rmap pure) genShowS :: (Filterable m, MonadPlus m) - => CtxGrammar String a -> a -> m ShowS + => CtxGrammar Char a -> a -> m ShowS genShowS = evalPrintor -genReadS :: CtxGrammar String a -> ReadS a +genReadS :: CtxGrammar Char a -> ReadS a genReadS = runParsor genRegEx :: Categorized token => RegGrammar token a -> RegEx token @@ -112,27 +125,6 @@ genGram => Grammar token a -> Gram (RegEx token) genGram = evalGrammor @() @((,) All) -type Regular c p = - ( Terminator c p - , Tokenizor c p - , Alternator p - ) - -type Grammatical c p = - ( Regular c p - , Filtrator p - , forall x. BackusNaurForm (p x x) - ) - -type Contextual s m p = - ( Grammatical (Item s) (p s s m) - , Monadic (p s s) - , Categorized (Item s) - , IsStream s - , Filterable m - , MonadPlus m - ) - regexGrammar :: Grammar Char (RegEx Char) regexGrammar = ruleRec "regex" altG where From c275baad2927e31bdf0df1dee7d85f633e78abd4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 28 Oct 2025 07:18:06 -0700 Subject: [PATCH 079/282] Update PartialIso.hs --- src/Control/Lens/PartialIso.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index 9fbeb7a..77ca8e9 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -49,11 +49,16 @@ module Control.Lens.PartialIso , difoldr' -- * Template Haskell , makeNestedPrisms + -- * Re-exports + , module Control.Lens.Iso + , module Control.Lens.Prism ) where import Control.Lens import Control.Lens.Internal.NestedPrismTH import Control.Lens.Internal.Profunctor +import Control.Lens.Iso +import Control.Lens.Prism import Control.Monad import Data.Functor.Compose import Data.Profunctor From 6bb961ad7d2a6634d6a67bdda434279a16abf90d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 28 Oct 2025 07:29:29 -0700 Subject: [PATCH 080/282] Gram ~> BNF --- src/Control/Lens/Grammar.hs | 36 +++++------ src/Control/Lens/Grammar/BackusNaur.hs | 86 +++++++++++++------------- 2 files changed, 61 insertions(+), 61 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 08983df..5e26288 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -11,7 +11,7 @@ module Control.Lens.Grammar , genReadS -- * Grammar , Grammar - , genGram + , genBNF , printEBNF , regexGrammar , ebnfGrammar @@ -25,7 +25,7 @@ module Control.Lens.Grammar , grammarOptic -- * Constraints , Regular - , Grammatical + , BNFmatical , Contextual -- * Re-exports , oneP, (>*), (*<), (>*<), replicateP @@ -66,13 +66,13 @@ makeNestedPrisms ''RegEx makeNestedPrisms ''GeneralCategory type RegGrammar token a = forall p. Regular token p => p a a -type Grammar token a = forall p. Grammatical token p => p a a +type Grammar token a = forall p. BNFmatical token p => p a a type CtxGrammar token a = forall p m. Contextual token m p => p m a a type RegGrammarr token a b = forall p. Regular token p => p a a -> p b b type Grammarr token a b = - forall p. Grammatical token p => p a a -> p b b + forall p. BNFmatical token p => p a a -> p b b type CtxGrammarr token a b = forall p m. Contextual token m p => p m a a -> p m b b @@ -81,13 +81,13 @@ type Regular token p = , Tokenizor token p , Alternator p ) -type Grammatical token p = +type BNFmatical token p = ( Regular token p , Filtrator p , forall x. BackusNaurForm (p x x) ) type Contextual token m p = - ( Grammatical token (p m) + ( BNFmatical token (p m) , Monadic p , Filterable m , MonadPlus m @@ -120,10 +120,10 @@ genReadS = runParsor genRegEx :: Categorized token => RegGrammar token a -> RegEx token genRegEx = evalGrammor @() @Identity -genGram +genBNF :: (Categorized token, Ord token, Ord (Categorize token)) - => Grammar token a -> Gram (RegEx token) -genGram = evalGrammor @() @((,) All) + => Grammar token a -> BNF (RegEx token) +genBNF = evalGrammor @() @((,) All) regexGrammar :: Grammar Char (RegEx Char) regexGrammar = ruleRec "regex" altG @@ -187,17 +187,17 @@ regexGrammar = ruleRec "regex" altG , opticGrammar _Fail ] -bnfGrammarr :: Ord rule => RegGrammarr Char rule (Gram rule) +bnfGrammarr :: Ord rule => RegGrammarr Char rule (BNF rule) bnfGrammarr p = dimap hither thither $ startG >*< rulesG where - hither (Gram start rules) = (start, toList rules) - thither (start, rules) = Gram start (fromList rules) + hither (BNF start rules) = (start, toList rules) + thither (start, rules) = BNF start (fromList rules) startG = terminal "start" >* ruleG rulesG = manyP (terminal "\n" >* nameG >*< ruleG) ruleG = terminal " = " >* p nameG = manyP (escape "\\= " (terminal "\\" >*)) -ebnfGrammar :: Grammar Char (Gram (RegEx Char)) +ebnfGrammar :: Grammar Char (BNF (RegEx Char)) ebnfGrammar = bnfGrammarr regexGrammar newtype RegExStr = RegExStr {runRegExStr :: RegEx Char} @@ -206,7 +206,7 @@ newtype RegExStr = RegExStr {runRegExStr :: RegEx Char} , Semigroup, Monoid, KleeneStarAlgebra , Tokenized, TerminalSymbol, NonTerminalSymbol ) -newtype EBNF = EBNF {runEBNF :: Gram RegExStr} +newtype EBNF = EBNF {runEBNF :: BNF RegExStr} deriving newtype ( Eq, Ord , Semigroup, Monoid, KleeneStarAlgebra @@ -218,7 +218,7 @@ printRegEx :: RegGrammar Char a -> IO () printRegEx = streamLine . RegExStr . genRegEx @Char printEBNF :: Grammar Char a -> IO () -printEBNF = streamLine . EBNF . liftGram1 RegExStr . genGram @Char +printEBNF = streamLine . EBNF . liftBNF1 RegExStr . genBNF @Char instance IsList RegExStr where type Item RegExStr = Char @@ -239,15 +239,15 @@ instance Read RegExStr where instance IsList EBNF where type Item EBNF = Char fromList - = fromMaybe (EBNF (Gram (RegExStr Fail) mempty)) + = fromMaybe (EBNF (BNF (RegExStr Fail) mempty)) . listToMaybe . mapMaybe (\(ebnf, remaining) -> if remaining == "" then Just ebnf else Nothing) - . fmap (first' (EBNF . liftGram1 RegExStr)) + . fmap (first' (EBNF . liftBNF1 RegExStr)) . genReadS ebnfGrammar toList = maybe "{start} = \\q" ($ "") . genShowS ebnfGrammar - . liftGram1 runRegExStr + . liftBNF1 runRegExStr . runEBNF instance IsString EBNF where fromString = fromList diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 1d38abb..c33ca4d 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -1,9 +1,9 @@ module Control.Lens.Grammar.BackusNaur ( BackusNaurForm (..) - , Gram (..) - , liftGram0 - , liftGram1 - , liftGram2 + , BNF (..) + , liftBNF0 + , liftBNF1 + , liftBNF2 ) where import Control.Lens.Grammar.Kleene @@ -19,61 +19,61 @@ class BackusNaurForm gram where ruleRec :: String -> (gram -> gram) -> gram ruleRec _ = fix -data Gram rule = Gram - { startGram :: rule - , rulesGram :: Set (String, rule) +data BNF rule = BNF + { startBNF :: rule + , rulesBNF :: Set (String, rule) } deriving stock (Eq, Ord, Show, Read) -liftGram0 :: Ord a => a -> Gram a -liftGram0 a = Gram a mempty +liftBNF0 :: Ord a => a -> BNF a +liftBNF0 a = BNF a mempty -liftGram1 :: (Coercible a b, Ord b) => (a -> b) -> Gram a -> Gram b -liftGram1 f (Gram start rules) = Gram (f start) (Set.map coerce rules) +liftBNF1 :: (Coercible a b, Ord b) => (a -> b) -> BNF a -> BNF b +liftBNF1 f (BNF start rules) = BNF (f start) (Set.map coerce rules) -liftGram2 +liftBNF2 :: (Coercible a c, Coercible b c, Ord c) - => (a -> b -> c) -> Gram a -> Gram b -> Gram c -liftGram2 f (Gram start0 rules0) (Gram start1 rules1) = - Gram (f start0 start1) (Set.map coerce rules0 <> Set.map coerce rules1) + => (a -> b -> c) -> BNF a -> BNF b -> BNF c +liftBNF2 f (BNF start0 rules0) (BNF start1 rules1) = + BNF (f start0 start1) (Set.map coerce rules0 <> Set.map coerce rules1) instance (Ord rule, NonTerminalSymbol rule) - => BackusNaurForm (Gram rule) where + => BackusNaurForm (BNF rule) where rule name = ruleRec name . const ruleRec name f = let start = nonTerminal name - Gram newRule oldRules = f (Gram start mempty) + BNF newRule oldRules = f (BNF start mempty) rules = insert (name, newRule) oldRules in - Gram start rules + BNF start rules instance (Ord t, TerminalSymbol t) - => TerminalSymbol (Gram t) where - type Alphabet (Gram t) = Alphabet t - terminal = liftGram0 . terminal + => TerminalSymbol (BNF t) where + type Alphabet (BNF t) = Alphabet t + terminal = liftBNF0 . terminal instance (Ord t, NonTerminalSymbol t) - => NonTerminalSymbol (Gram t) where - nonTerminal = liftGram0 . nonTerminal + => NonTerminalSymbol (BNF t) where + nonTerminal = liftBNF0 . nonTerminal -instance (Ord p, Tokenized p) => Tokenized (Gram p) where - type Token (Gram p) = Token p - anyToken = liftGram0 anyToken - noToken = liftGram0 noToken - token = liftGram0 . token - notToken = liftGram0 . notToken - oneOf = liftGram0 . oneOf - notOneOf = liftGram0 . notOneOf - asIn = liftGram0 . asIn - notAsIn = liftGram0 . notAsIn +instance (Ord p, Tokenized p) => Tokenized (BNF p) where + type Token (BNF p) = Token p + anyToken = liftBNF0 anyToken + noToken = liftBNF0 noToken + token = liftBNF0 . token + notToken = liftBNF0 . notToken + oneOf = liftBNF0 . oneOf + notOneOf = liftBNF0 . notOneOf + asIn = liftBNF0 . asIn + notAsIn = liftBNF0 . notAsIn -instance (Ord t, KleeneStarAlgebra t) => KleeneStarAlgebra (Gram t) where - starK = liftGram1 starK - plusK = liftGram1 plusK - optK = liftGram1 optK - empK = liftGram0 empK - (>|<) = liftGram2 (>|<) -instance (Ord t, Monoid t) => Monoid (Gram t) where - mempty = liftGram0 mempty -instance (Ord t, Semigroup t) => Semigroup (Gram t) where - (<>) = liftGram2 (<>) +instance (Ord t, KleeneStarAlgebra t) => KleeneStarAlgebra (BNF t) where + starK = liftBNF1 starK + plusK = liftBNF1 plusK + optK = liftBNF1 optK + empK = liftBNF0 empK + (>|<) = liftBNF2 (>|<) +instance (Ord t, Monoid t) => Monoid (BNF t) where + mempty = liftBNF0 mempty +instance (Ord t, Semigroup t) => Semigroup (BNF t) where + (<>) = liftBNF2 (<>) From 75088249beeabf329d7d0dd2c60a042f42f7e0c8 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 28 Oct 2025 07:42:47 -0700 Subject: [PATCH 081/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 44 ++++++++++++++++--------------------- 1 file changed, 19 insertions(+), 25 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 5e26288..031ff01 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -5,13 +5,13 @@ module Control.Lens.Grammar , RegGrammar , RegGrammarr , bnfGrammarr - , genRegEx + , genRegExStr , printRegEx , genShowS , genReadS -- * Grammar , Grammar - , genBNF + , genEBNF , printEBNF , regexGrammar , ebnfGrammar @@ -25,7 +25,7 @@ module Control.Lens.Grammar , grammarOptic -- * Constraints , Regular - , BNFmatical + , Grammatical , Contextual -- * Re-exports , oneP, (>*), (*<), (>*<), replicateP @@ -51,7 +51,6 @@ import Control.Lens.Grammar.Symbol import Control.Monad import Data.Maybe hiding (mapMaybe) import Data.Monoid -import Data.Profunctor import Data.Profunctor.Distributor import Data.Profunctor.Filtrator import Data.Profunctor.Monadic @@ -66,13 +65,13 @@ makeNestedPrisms ''RegEx makeNestedPrisms ''GeneralCategory type RegGrammar token a = forall p. Regular token p => p a a -type Grammar token a = forall p. BNFmatical token p => p a a +type Grammar token a = forall p. Grammatical token p => p a a type CtxGrammar token a = forall p m. Contextual token m p => p m a a type RegGrammarr token a b = forall p. Regular token p => p a a -> p b b type Grammarr token a b = - forall p. BNFmatical token p => p a a -> p b b + forall p. Grammatical token p => p a a -> p b b type CtxGrammarr token a b = forall p m. Contextual token m p => p m a a -> p m b b @@ -81,13 +80,13 @@ type Regular token p = , Tokenizor token p , Alternator p ) -type BNFmatical token p = +type Grammatical token p = ( Regular token p , Filtrator p , forall x. BackusNaurForm (p x x) ) type Contextual token m p = - ( BNFmatical token (p m) + ( Grammatical token (p m) , Monadic p , Filterable m , MonadPlus m @@ -117,16 +116,14 @@ genShowS = evalPrintor genReadS :: CtxGrammar Char a -> ReadS a genReadS = runParsor -genRegEx :: Categorized token => RegGrammar token a -> RegEx token -genRegEx = evalGrammor @() @Identity +genRegExStr :: RegGrammar Char a -> RegExStr +genRegExStr = evalGrammor @() @Identity -genBNF - :: (Categorized token, Ord token, Ord (Categorize token)) - => Grammar token a -> BNF (RegEx token) -genBNF = evalGrammor @() @((,) All) +genEBNF :: Grammar Char a -> EBNF +genEBNF = evalGrammor @() @((,) All) -regexGrammar :: Grammar Char (RegEx Char) -regexGrammar = ruleRec "regex" altG +regexGrammar :: Grammar Char RegExStr +regexGrammar = dimap runRegExStr RegExStr $ ruleRec "regex" altG where altG rex = rule "alternate" $ chain1 Left _Alternate (sepBy (terminal "|")) (seqG rex) @@ -197,8 +194,8 @@ bnfGrammarr p = dimap hither thither $ startG >*< rulesG ruleG = terminal " = " >* p nameG = manyP (escape "\\= " (terminal "\\" >*)) -ebnfGrammar :: Grammar Char (BNF (RegEx Char)) -ebnfGrammar = bnfGrammarr regexGrammar +ebnfGrammar :: Grammar Char EBNF +ebnfGrammar = dimap runEBNF EBNF (bnfGrammarr regexGrammar) newtype RegExStr = RegExStr {runRegExStr :: RegEx Char} deriving newtype @@ -215,10 +212,10 @@ newtype EBNF = EBNF {runEBNF :: BNF RegExStr} ) printRegEx :: RegGrammar Char a -> IO () -printRegEx = streamLine . RegExStr . genRegEx @Char +printRegEx = streamLine . genRegExStr printEBNF :: Grammar Char a -> IO () -printEBNF = streamLine . EBNF . liftBNF1 RegExStr . genBNF @Char +printEBNF = streamLine . genEBNF instance IsList RegExStr where type Item RegExStr = Char @@ -226,10 +223,10 @@ instance IsList RegExStr where = fromMaybe (RegExStr Fail) . listToMaybe . mapMaybe (\(rex, remaining) -> if remaining == "" then Just rex else Nothing) - . genReadS (dimap runRegExStr RegExStr regexGrammar) + . genReadS regexGrammar toList = maybe "\\q" ($ "") - . genShowS (dimap runRegExStr RegExStr regexGrammar) + . genShowS regexGrammar instance IsString RegExStr where fromString = fromList instance Show RegExStr where @@ -242,13 +239,10 @@ instance IsList EBNF where = fromMaybe (EBNF (BNF (RegExStr Fail) mempty)) . listToMaybe . mapMaybe (\(ebnf, remaining) -> if remaining == "" then Just ebnf else Nothing) - . fmap (first' (EBNF . liftBNF1 RegExStr)) . genReadS ebnfGrammar toList = maybe "{start} = \\q" ($ "") . genShowS ebnfGrammar - . liftBNF1 runRegExStr - . runEBNF instance IsString EBNF where fromString = fromList instance Show EBNF where From 34ce8f870ca1c8342e3c1fb4615f20d21108cb8d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 28 Oct 2025 13:59:52 -0700 Subject: [PATCH 082/282] MonadicError --- src/Control/Lens/Grammar.hs | 22 +++++++++++++--------- src/Data/Profunctor/Grammar.hs | 18 ++++++++++++++++++ src/Data/Profunctor/Monadic.hs | 19 ++++++++++++++++++- 3 files changed, 49 insertions(+), 10 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 031ff01..e97675e 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -19,9 +19,9 @@ module Control.Lens.Grammar , CtxGrammar , CtxGrammarr -- * Optics - , opticGrammarr + , prismGrammar + , coPrismGrammar , grammarrOptic - , opticGrammar , grammarOptic -- * Constraints , Regular @@ -49,8 +49,10 @@ import Control.Lens.Grammar.Token import Control.Lens.Grammar.Stream import Control.Lens.Grammar.Symbol import Control.Monad +-- import Control.Monad.Except import Data.Maybe hiding (mapMaybe) import Data.Monoid +import Data.Profunctor import Data.Profunctor.Distributor import Data.Profunctor.Filtrator import Data.Profunctor.Monadic @@ -87,22 +89,24 @@ type Grammatical token p = ) type Contextual token m p = ( Grammatical token (p m) - , Monadic p + , MonadicPlus p + -- , MonadicError String p , Filterable m , MonadPlus m + -- , MonadError String m ) -opticGrammar :: Monoidal p => Optic' p Identity a () -> p a a -opticGrammar = ($ oneP) . opticGrammarr +prismGrammar :: (Monoidal p, Choice p) => Prism' a () -> p a a +prismGrammar = (>? oneP) + +coPrismGrammar :: (Monoidal p, Cochoice p) => Prism' () a -> p a a +coPrismGrammar = (?< oneP) grammarOptic :: (Monoidal p, Comonad f, Applicative f) => p a a -> Optic' p f a () grammarOptic = grammarrOptic . (*<) -opticGrammarr :: Profunctor p => Optic' p Identity b a -> p a a -> p b b -opticGrammarr = dimap (rmap Identity) (rmap runIdentity) - grammarrOptic :: (Profunctor p, Comonad f, Applicative f) => (p a a -> p b b) -> Optic' p f b a @@ -181,7 +185,7 @@ regexGrammar = dimap runRegExStr RegExStr $ ruleRec "regex" altG ] nonterminalG = rule "nonterminal" $ terminal "\\q" >* choiceP [ _NonTerminal >?< terminal "{" >* manyP charG *< terminal "}" - , opticGrammar _Fail + , prismGrammar _Fail ] bnfGrammarr :: Ord rule => RegGrammarr Char rule (BNF rule) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 7232fd8..842205c 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -15,6 +15,9 @@ import Control.Applicative import Control.Arrow import Control.Category import Control.Comonad +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State import Control.Lens import Control.Lens.Internal.Equator import Control.Lens.Grammar.BackusNaur @@ -78,6 +81,13 @@ instance (Alternative m, Monad m) => Alternative (Parsor s s m a) where empty = Parsor (\_ -> empty) Parsor p <|> Parsor q = Parsor (\str -> p str <|> q str) instance (Alternative m, Monad m) => MonadPlus (Parsor s s m a) +instance MonadError e m => MonadError e (Parsor s s m a) where + throwError = liftP . throwError + catchError p f = Parsor $ \s -> + catchError (runParsor p s) (\e -> runParsor (f e) s) +instance Monad m => MonadState s (Parsor s s m a) where + get = Parsor (\s -> pure (s,s)) + put = Parsor . (pure (pure . ((),))) instance (Alternative m, Monad m) => Choice (Parsor s s m) where left' = alternate . Left right' = alternate . Right @@ -149,6 +159,14 @@ instance Monad f => Monad (Printor s s f a) where (y, q) <- runPrintor (f x) ctx return (y, p . q) instance (Alternative f, Monad f) => MonadPlus (Printor s s f a) +instance MonadError e m => MonadError e (Printor s s m a) where + throwError = liftP . throwError + catchError p f = Printor $ \s -> + catchError (runPrintor p s) (\e -> runPrintor (f e) s) +instance Monad m => MonadReader a (Printor s s m a) where + ask = Printor (\a -> return (a, id)) + reader f = (Printor (\a -> return (f a, id))) + local f = Printor . (\m -> m . f) . runPrintor instance Monadic (Printor s s) where joinP (Printor mf) = Printor $ \a -> do (mb, f) <- mf a diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index db1c969..1a19657 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -14,6 +14,8 @@ module Data.Profunctor.Monadic ( Monadic (..) , Polyadic (..) , Tetradic (..) + , MonadicPlus + , MonadicError , WrappedMonadic (..) , WrappedPolyadic (..) , TaggedP (..) @@ -23,10 +25,14 @@ module Data.Profunctor.Monadic import Control.Category import Control.Monad -import Control.Monad.Trans +import Control.Monad.Except +import Control.Monad.State import Control.Monad.Trans.Indexed import Data.Profunctor +import Data.Profunctor.Filtrator +import Data.Kind import Prelude hiding (id, (.)) +import Witherable class ( forall m. Monad m => Profunctor (p m) @@ -59,6 +65,17 @@ class (forall i j. Profunctor (p i j f)) => Tetradic f p where -> p i j f a b -> p h k f a b dimapT f1 f2 = tetramap f1 f2 id id +type MonadicPlus p = + ( Monadic p + , forall m. (Filterable m, MonadPlus m) => Filtrator (p m) + , forall m x. (Filterable m, MonadPlus m) => MonadPlus (p m x) + ) :: Constraint + +type MonadicError e p = + ( Monadic p + , forall m x. MonadError e m => MonadError e (p m x) + ) :: Constraint + newtype WrappedMonadic p m a b = WrapMonadic {unwrapMonadic :: p m a (m b)} instance (Monadic p, Monad m) => Functor (WrappedMonadic p m a) where fmap = rmap From 187ddba9a4cddc7f018d0eff2c0998f8bfa72b57 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 28 Oct 2025 15:58:44 -0700 Subject: [PATCH 083/282] Update PartialIso.hs --- src/Control/Lens/PartialIso.hs | 38 +++++++++++++++++----------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index 77ca8e9..115e22a 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -154,8 +154,8 @@ withPartialIso :: APartialIso s t a b -> ((s -> Maybe a) -> (b -> Maybe t) -> r) -> r -withPartialIso i k = - case i (PartialExchange Just (Just . Just)) of +withPartialIso pattern k = + case pattern (PartialExchange Just (Just . Just)) of PartialExchange f g -> k f (join . g) {- | Clone `APartialIso` so that you can reuse the same @@ -164,14 +164,14 @@ 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 +clonePartialIso pattern = withPartialIso pattern $ \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 +coPartialIso pattern = + withPartialIso pattern $ \f g -> partialIso g f {- | Construct a `PartialIso` on pairs from components. -} crossPartialIso @@ -228,7 +228,7 @@ 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 +mapIso pattern = withIso pattern dimap {- | Action of a `coPrism` on the composition of a `Profunctor` and `Filterable`. @@ -270,7 +270,7 @@ eotList = iso {- | 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 -> +iterating pattern = withPartialIso pattern $ \f g -> iso (iter f) (iter g) where iter h state = maybe state (iter h) (h state) @@ -279,7 +279,7 @@ difoldl1 :: Cons s t a b => APartialIso (c,a) (d,b) c d -> Iso (c,s) (d,t) (c,s) (d,t) -difoldl1 i = +difoldl1 pattern = let associate = iso (\(c,(a,s)) -> ((c,a),s)) @@ -287,7 +287,7 @@ difoldl1 i = step = crossPartialIso id _Cons . associate - . crossPartialIso i id + . crossPartialIso pattern id in iterating step {- | Right fold & unfold `APartialIso` to an `Control.Lens.Iso.Iso`. -} @@ -295,7 +295,7 @@ difoldr1 :: Cons s t a b => APartialIso (a,c) (b,d) c d -> Iso (s,c) (t,d) (s,c) (t,d) -difoldr1 i = +difoldr1 pattern = let reorder = iso (\((a,s),c) -> (s,(a,c))) @@ -303,7 +303,7 @@ difoldr1 i = step = crossPartialIso _Cons id . reorder - . crossPartialIso id i + . crossPartialIso id pattern in iterating step {- | Left fold & unfold `APartialIso` to a `PartialIso`. -} @@ -311,13 +311,13 @@ 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 = +difoldl pattern = let unit' = iso (\(a,()) -> a) (\a -> (a,())) in - difoldl1 i + difoldl1 pattern . crossPartialIso id nulled . unit' @@ -326,13 +326,13 @@ 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 = +difoldr pattern = let unit' = iso (\((),c) -> c) (\d -> ((),d)) in - difoldr1 i + difoldr1 pattern . crossPartialIso nulled id . unit' @@ -342,13 +342,13 @@ difoldl' :: (AsEmpty s, Cons s s a a) => APrism' (c,a) c -> Prism' (c,s) c -difoldl' i = +difoldl' pattern = let unit' = iso (\(a,()) -> a) (\a -> (a,())) in - difoldl1 (clonePrism i) + difoldl1 (clonePrism pattern) . aside _Empty . unit' @@ -358,7 +358,7 @@ difoldr' :: (AsEmpty s, Cons s s a a) => APrism' (a,c) c -> Prism' (s,c) c -difoldr' i = +difoldr' pattern = let unit' = iso (\((),c) -> c) @@ -370,7 +370,7 @@ difoldr' i = Left t -> Left (t,e) Right a -> Right (a,e) in - difoldr1 (clonePrism i) + difoldr1 (clonePrism pattern) . asideFst _Empty . unit' From 32f1d41663d7993c2447884ddff192eb144b814d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 28 Oct 2025 17:19:57 -0700 Subject: [PATCH 084/282] chain work --- src/Control/Lens/Bifocal.hs | 15 +++-- src/Control/Lens/Grammar/Stream.hs | 24 ++++---- src/Control/Lens/PartialIso.hs | 96 +++++++----------------------- 3 files changed, 44 insertions(+), 91 deletions(-) diff --git a/src/Control/Lens/Bifocal.hs b/src/Control/Lens/Bifocal.hs index 2fb03c5..5df3862 100644 --- a/src/Control/Lens/Bifocal.hs +++ b/src/Control/Lens/Bifocal.hs @@ -17,8 +17,6 @@ module Control.Lens.Bifocal , mapBifocal , cloneBifocal , withBifocal - , chained1 - , chained -- * Binocular , Binocular (..), runBinocular -- * Prismoid @@ -26,6 +24,8 @@ module Control.Lens.Bifocal , somed , lefted , righted + , chained1 + , chained -- * Filtroid , Filtroid , unlefted @@ -117,14 +117,21 @@ unrighted = unwrapPafb . snd . filtrate . WrapPafb {- | Associate a binary constructor pattern to sequence one or more times. -} -chained1 :: (forall x. x -> Either x x) -> APartialIso a b (a,a) (b,b) -> Bifocal a b a b +chained1 + :: (forall x. x -> Either x x) + -> APartialIso a b (a,a) (b,b) + -> Prismoid a b a b chained1 assoc binPat = unwrapPafb . chain1 assoc binPat noSep . WrapPafb {- | Associate a binary constructor pattern to sequence one or more times, or use a nilary constructor pattern to sequence zero times. -} -chained :: (forall x. x -> Either x x) -> APartialIso a b (a,a) (b,b) -> APartialIso a b () () -> Bifocal a b a b +chained + :: (forall x. x -> Either x x) + -> APartialIso a b (a,a) (b,b) + -> APrism a b () () + -> Prismoid a b a b chained assoc binPat nilPat = unwrapPafb . chain assoc binPat nilPat noSep . WrapPafb {- | Run `ABifocal` over an `Alternative` & `Filterable`. -} diff --git a/src/Control/Lens/Grammar/Stream.hs b/src/Control/Lens/Grammar/Stream.hs index e5c6b02..6788ae4 100644 --- a/src/Control/Lens/Grammar/Stream.hs +++ b/src/Control/Lens/Grammar/Stream.hs @@ -19,9 +19,7 @@ module Control.Lens.Grammar.Stream import Control.Applicative import Control.Lens import Control.Lens.PartialIso -import Data.Profunctor import Data.Profunctor.Distributor -import Data.Profunctor.Filtrator import Data.Profunctor.Monoidal import GHC.Exts @@ -89,27 +87,27 @@ noSep :: Monoidal p => SepBy (p () ()) noSep = sepBy oneP chain - :: (Alternator p, Filtrator p) + :: Alternator p => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern - -> APartialIso a b () () -- ^ nilary constructor pattern + -> APrism a b () () -- ^ nilary constructor pattern -> SepBy (p () ()) -> p a b -> p a b -chain assoc c2 c0 sep p = +chain assoc pat2 pat0 sep p = beginBy sep >* - (c0 >?< oneP <|> chain1 assoc c2 (sepBy (separateBy sep)) p) + (pat0 >? oneP <|> chain1 assoc pat2 (sepBy (separateBy sep)) p) *< endBy sep chain1 - :: (Distributor p, Choice p, Cochoice p) + :: (Distributor p, Choice p) => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern -> SepBy (p () ()) -> p a b -> p a b -chain1 = leftOrRight chainl1 chainr1 +chain1 assoc pat sep = leftOrRight chainl1 chainr1 where - leftOrRight a b f = case f () of Left _ -> a; Right _ -> b - chainl1 pat sep p = - coPartialIso (difoldl (coPartialIso pat)) >?< + leftOrRight a b = case assoc () of Left _ -> a; Right _ -> b + chainl1 p = + difoldl pat >? beginBy sep >* p >*< manyP (separateBy sep >* p) *< endBy sep - chainr1 pat sep p = - coPartialIso (difoldr (coPartialIso pat)) >?< + chainr1 p = + difoldr pat >? beginBy sep >* manyP (p *< separateBy sep) >*< p *< endBy sep diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index 115e22a..aa6fa88 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -45,8 +45,6 @@ module Control.Lens.PartialIso , difoldr1 , difoldl , difoldr - , difoldl' - , difoldr' -- * Template Haskell , makeNestedPrisms -- * Re-exports @@ -274,11 +272,11 @@ iterating pattern = withPartialIso pattern $ \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`. -} +{- | Left fold & unfold `PartialIso` 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) + => APartialIso d c (d,b) (c,a) + -> Iso (d,t) (c,s) (d,t) (c,s) difoldl1 pattern = let associate = iso @@ -287,14 +285,14 @@ difoldl1 pattern = step = crossPartialIso id _Cons . associate - . crossPartialIso pattern id - in iterating step + . crossPartialIso (coPartialIso pattern) id + in from (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) + => APartialIso d c (b,d) (a,c) + -> Iso (t,d) (s,c) (t,d) (s,c) difoldr1 pattern = let reorder = iso @@ -303,76 +301,26 @@ difoldr1 pattern = step = crossPartialIso _Cons id . reorder - . crossPartialIso id pattern - in iterating step + . crossPartialIso id (coPartialIso pattern) + in from (iterating step) -{- | Left fold & unfold `APartialIso` to a `PartialIso`. -} +{- | Left fold & unfold `PartialIso` 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 pattern = - let - unit' = iso - (\(a,()) -> a) - (\a -> (a,())) - in - difoldl1 pattern - . crossPartialIso id nulled - . unit' + :: (AsEmpty t, Cons s t a b) + => APartialIso d c (d,b) (c,a) + -> Prism d c (d,t) (c,s) +difoldl pattern + = dimap (, Empty) (fmap fst) + . difoldl1 pattern {- | 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 pattern = - let - unit' = iso - (\((),c) -> c) - (\d -> ((),d)) - in - difoldr1 pattern - . 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' pattern = - let - unit' = iso - (\(a,()) -> a) - (\a -> (a,())) - in - difoldl1 (clonePrism pattern) - . 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' pattern = - 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 pattern) - . asideFst _Empty - . unit' + :: (AsEmpty t, Cons s t a b) + => APartialIso d c (b,d) (a,c) + -> Prism d c (t,d) (s,c) +difoldr pattern + = dimap (Empty, ) (fmap snd) + . difoldr1 pattern -- Orphanage -- From 9994e1c9393b9c7b75d026ecaeca02d3cb6cb075 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 28 Oct 2025 22:16:47 -0700 Subject: [PATCH 085/282] Update BackusNaur.hs --- src/Control/Lens/Grammar/BackusNaur.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index c33ca4d..feeb4cb 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -13,10 +13,10 @@ import Data.Coerce import Data.Function import Data.Set as Set -class BackusNaurForm gram where - rule :: String -> gram -> gram +class BackusNaurForm bnf where + rule :: String -> bnf -> bnf rule _ = id - ruleRec :: String -> (gram -> gram) -> gram + ruleRec :: String -> (bnf -> bnf) -> bnf ruleRec _ = fix data BNF rule = BNF From f49e11001feeec7f2e79813e90ae058a1e08d39e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 28 Oct 2025 22:34:27 -0700 Subject: [PATCH 086/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index e97675e..39dfe6b 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -194,7 +194,7 @@ bnfGrammarr p = dimap hither thither $ startG >*< rulesG hither (BNF start rules) = (start, toList rules) thither (start, rules) = BNF start (fromList rules) startG = terminal "start" >* ruleG - rulesG = manyP (terminal "\n" >* nameG >*< ruleG) + rulesG = manyP (someLike '\n' >* nameG >*< ruleG) ruleG = terminal " = " >* p nameG = manyP (escape "\\= " (terminal "\\" >*)) From ec459b4a84790622fae36999fc0b82077ecc0bce Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 29 Oct 2025 07:59:25 -0700 Subject: [PATCH 087/282] Update Stream.hs --- src/Control/Lens/Grammar/Stream.hs | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/src/Control/Lens/Grammar/Stream.hs b/src/Control/Lens/Grammar/Stream.hs index 6788ae4..b7ebb70 100644 --- a/src/Control/Lens/Grammar/Stream.hs +++ b/src/Control/Lens/Grammar/Stream.hs @@ -87,27 +87,21 @@ noSep :: Monoidal p => SepBy (p () ()) noSep = sepBy oneP chain - :: Alternator p + :: (Distributor p, Choice p, Alternative (p a)) => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern -> APrism a b () () -- ^ nilary constructor pattern -> SepBy (p () ()) -> p a b -> p a b -chain assoc pat2 pat0 sep p = - beginBy sep >* - (pat0 >? oneP <|> chain1 assoc pat2 (sepBy (separateBy sep)) p) - *< endBy sep +chain assoc pat2 pat0 (SepBy beg end sep) p = + beg >* (pat0 >? oneP <|> chain1 assoc pat2 (sepBy sep) p) *< end chain1 :: (Distributor p, Choice p) => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern -> SepBy (p () ()) -> p a b -> p a b -chain1 assoc pat sep = leftOrRight chainl1 chainr1 +chain1 assoc pat (SepBy beg end sep) = leftOrRight chainl1 chainr1 where leftOrRight a b = case assoc () of Left _ -> a; Right _ -> b - chainl1 p = - difoldl pat >? - beginBy sep >* p >*< manyP (separateBy sep >* p) *< endBy sep - chainr1 p = - difoldr pat >? - beginBy sep >* manyP (p *< separateBy sep) >*< p *< endBy sep + chainl1 p = difoldl pat >? beg >* p >*< manyP (sep >* p) *< end + chainr1 p = difoldr pat >? beg >* manyP (p *< sep) >*< p *< end From f30f437664108b27f287d8f8687f9d9868ce1d82 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 29 Oct 2025 08:07:22 -0700 Subject: [PATCH 088/282] Update BackusNaur.hs --- src/Control/Lens/Grammar/BackusNaur.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index feeb4cb..18fae0b 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -47,17 +47,17 @@ instance (Ord rule, NonTerminalSymbol rule) in BNF start rules -instance (Ord t, TerminalSymbol t) - => TerminalSymbol (BNF t) where - type Alphabet (BNF t) = Alphabet t +instance (Ord rule, TerminalSymbol rule) + => TerminalSymbol (BNF rule) where + type Alphabet (BNF rule) = Alphabet rule terminal = liftBNF0 . terminal -instance (Ord t, NonTerminalSymbol t) - => NonTerminalSymbol (BNF t) where +instance (Ord rule, NonTerminalSymbol rule) + => NonTerminalSymbol (BNF rule) where nonTerminal = liftBNF0 . nonTerminal -instance (Ord p, Tokenized p) => Tokenized (BNF p) where - type Token (BNF p) = Token p +instance (Ord rule, Tokenized rule) => Tokenized (BNF rule) where + type Token (BNF rule) = Token rule anyToken = liftBNF0 anyToken noToken = liftBNF0 noToken token = liftBNF0 . token @@ -67,13 +67,13 @@ instance (Ord p, Tokenized p) => Tokenized (BNF p) where asIn = liftBNF0 . asIn notAsIn = liftBNF0 . notAsIn -instance (Ord t, KleeneStarAlgebra t) => KleeneStarAlgebra (BNF t) where +instance (Ord rule, KleeneStarAlgebra rule) => KleeneStarAlgebra (BNF rule) where starK = liftBNF1 starK plusK = liftBNF1 plusK optK = liftBNF1 optK empK = liftBNF0 empK (>|<) = liftBNF2 (>|<) -instance (Ord t, Monoid t) => Monoid (BNF t) where +instance (Ord rule, Monoid rule) => Monoid (BNF rule) where mempty = liftBNF0 mempty -instance (Ord t, Semigroup t) => Semigroup (BNF t) where +instance (Ord rule, Semigroup rule) => Semigroup (BNF rule) where (<>) = liftBNF2 (<>) From cab1967c9f04d1507852e220b465928cdc232d12 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 29 Oct 2025 12:50:27 -0700 Subject: [PATCH 089/282] notAny --- src/Control/Lens/Grammar.hs | 8 ++++++-- src/Control/Lens/Grammar/BackusNaur.hs | 2 +- src/Control/Lens/Grammar/Kleene.hs | 2 +- src/Control/Lens/Grammar/Token.hs | 8 ++++---- src/Data/Profunctor/Grammar.hs | 2 +- 5 files changed, 13 insertions(+), 9 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 39dfe6b..61ec8a1 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -150,7 +150,11 @@ regexGrammar = dimap runRegExStr RegExStr $ ruleRec "regex" altG , _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" , terminal "(" >* rex *< terminal ")" ] - charG = rule "char" $ escape "$()*+.?[\\]^{|}" (terminal "\\" >*) + charG = rule "char" $ escapes + [ ("$()*+.?[\\]^{|}", (terminal "\\" >*)) + , ("\n", \_ -> (terminal "\\n" <|> terminal "\n") >* pure '\n') + , ("\t", \_ -> (terminal "\\t" <|> terminal "\t") >* pure '\t') + ] categoryG = rule "category" $ choiceP [ _LowercaseLetter >?< terminal "Ll" , _UppercaseLetter >?< terminal "Lu" @@ -194,7 +198,7 @@ bnfGrammarr p = dimap hither thither $ startG >*< rulesG hither (BNF start rules) = (start, toList rules) thither (start, rules) = BNF start (fromList rules) startG = terminal "start" >* ruleG - rulesG = manyP (someLike '\n' >* nameG >*< ruleG) + rulesG = manyP (terminal ['\n'] >* nameG >*< ruleG) ruleG = terminal " = " >* p nameG = manyP (escape "\\= " (terminal "\\" >*)) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 18fae0b..77faeec 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -59,7 +59,7 @@ instance (Ord rule, NonTerminalSymbol rule) instance (Ord rule, Tokenized rule) => Tokenized (BNF rule) where type Token (BNF rule) = Token rule anyToken = liftBNF0 anyToken - noToken = liftBNF0 noToken + notAnyToken = liftBNF0 notAnyToken token = liftBNF0 . token notToken = liftBNF0 . notToken oneOf = liftBNF0 . oneOf diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 405b5b6..48e0a1e 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -53,7 +53,7 @@ instance TerminalSymbol (RegEx token) where instance Categorized token => Tokenized (RegEx token) where type Token (RegEx token) = token anyToken = AnyToken - noToken = Fail + notAnyToken = Fail token a = Terminal [a] notToken a = NotOneOf [a] oneOf [] = Fail diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 798abcf..6c5bd0a 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -42,9 +42,9 @@ class Categorized (Token p) => Tokenized p where anyToken :: p - noToken :: p - default noToken :: (p ~ f (Token p), Alternative f) => p - noToken = empty + notAnyToken :: p + default notAnyToken :: (p ~ f (Token p), Alternative f) => p + notAnyToken = empty token :: Token p -> p default token @@ -85,7 +85,7 @@ class Categorized (Token p) => Tokenized p where instance Categorized token => Tokenized (token -> Bool) where type Token (token -> Bool) = token anyToken _ = True - noToken _ = False + notAnyToken _ = False token = (==) notToken = (/=) oneOf = flip elem diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 842205c..914c0e1 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -285,7 +285,7 @@ instance (Tokenized t, Applicative f) => Tokenized (Grammor s t f a b) where type Token (Grammor s t f a b) = Token t anyToken = grammor anyToken - noToken = grammor noToken + notAnyToken = grammor notAnyToken token = grammor . token notToken = grammor . notToken oneOf = grammor . oneOf From 0bd86f98d5cf8237ba64a9136b3132478edfcf3b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 29 Oct 2025 14:27:24 -0700 Subject: [PATCH 090/282] Update BackusNaur.hs --- src/Control/Lens/Grammar/BackusNaur.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 77faeec..1016c55 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -41,11 +41,11 @@ instance (Ord rule, NonTerminalSymbol rule) rule name = ruleRec name . const ruleRec name f = let - start = nonTerminal name - BNF newRule oldRules = f (BNF start mempty) - rules = insert (name, newRule) oldRules + newStart = nonTerminal name + BNF newRule oldRules = f (BNF newStart mempty) + newRules = insert (name, newRule) oldRules in - BNF start rules + BNF newStart newRules instance (Ord rule, TerminalSymbol rule) => TerminalSymbol (BNF rule) where From a0ec5823af3bdad18e6b35cba20e67d259014eec Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 30 Oct 2025 20:14:33 -0700 Subject: [PATCH 091/282] Context --- distributors.cabal | 3 ++ package.yaml | 1 + src/Control/Lens/Grammar/BackusNaur.hs | 3 +- src/Control/Lens/Grammar/Context.hs | 75 ++++++++++++++++++++++++++ 4 files changed, 81 insertions(+), 1 deletion(-) create mode 100644 src/Control/Lens/Grammar/Context.hs diff --git a/distributors.cabal b/distributors.cabal index 9cf2bf3..7d97697 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -32,6 +32,7 @@ library Control.Lens.Diopter Control.Lens.Grammar Control.Lens.Grammar.BackusNaur + Control.Lens.Grammar.Context Control.Lens.Grammar.Kleene Control.Lens.Grammar.Stream Control.Lens.Grammar.Symbol @@ -103,6 +104,7 @@ library , contravariant >=1.5 && <2 , distributive >=0.6 && <1 , indexed-transformers >=0.1.0.4 && <1 + , kan-extensions , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 @@ -174,6 +176,7 @@ test-suite spec , distributors , hspec , indexed-transformers >=0.1.0.4 && <1 + , kan-extensions , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 diff --git a/package.yaml b/package.yaml index 280a889..6c15687 100644 --- a/package.yaml +++ b/package.yaml @@ -30,6 +30,7 @@ dependencies: - lens >= 5.2 && < 6 - mtl >= 2.3 && < 3 - indexed-transformers >= 0.1.0.4 && < 1 +- kan-extensions - profunctors >= 5.6 && < 6 - tagged >= 0.8 && < 1 - template-haskell diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 1016c55..456a6ef 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -67,7 +67,8 @@ instance (Ord rule, Tokenized rule) => Tokenized (BNF rule) where asIn = liftBNF0 . asIn notAsIn = liftBNF0 . notAsIn -instance (Ord rule, KleeneStarAlgebra rule) => KleeneStarAlgebra (BNF rule) where +instance (Ord rule, KleeneStarAlgebra rule) + => KleeneStarAlgebra (BNF rule) where starK = liftBNF1 starK plusK = liftBNF1 plusK optK = liftBNF1 optK diff --git a/src/Control/Lens/Grammar/Context.hs b/src/Control/Lens/Grammar/Context.hs new file mode 100644 index 0000000..84ba20f --- /dev/null +++ b/src/Control/Lens/Grammar/Context.hs @@ -0,0 +1,75 @@ +module Control.Lens.Grammar.Context + ( Subtextual (..) + , ReadIx (..) + , Ctx (..) + ) where + +import Control.Applicative +import Control.Lens (uncons) +import Control.Lens.Grammar.Stream +import Control.Monad +import Control.Monad.Codensity +import GHC.Exts +import Text.ParserCombinators.ReadP (ReadP) +import qualified Text.ParserCombinators.ReadP as Text + +class (IsStream s, MonadPlus m) => Subtextual s m where + getItem :: m (Item s) + lookStream :: m s + +instance Subtextual String ReadP where + getItem = Text.get + lookStream = Text.look + + + + + +----------------------- + +newtype ReadIx s t a = ReadIx (Codensity (Ctx s t) a) + +data Ctx s t a + = Get (Item s -> Ctx s t a) + | Look (s -> Ctx s t a) + | Result a (Ctx s t a) + | Final [(a,t)] + deriving Functor +instance IsStream s => Applicative (Ctx s s) where + pure x = Result x (Final empty) + (<*>) = ap +instance IsStream s => MonadPlus (Ctx s s) +instance IsStream s => Monad (Ctx s s) where + (Get f) >>= k = Get (\c -> f c >>= k) + (Look f) >>= k = Look (\s -> f s >>= k) + (Result x p) >>= k = k x <|> (p >>= k) + (Final rs) >>= k = Final (rs >>= \(x,s) -> run (k x) s) +instance IsStream s => MonadFail (Ctx s s) where + fail _ = Final [] +instance IsStream s => Alternative (Ctx s s) where + empty = Final [] + Get f1 <|> Get f2 = Get (\c -> f1 c <|> f2 c) + Result x p <|> q = Result x (p <|> q) + p <|> Result x q = Result x (p <|> q) + -- TODO: uncons + Final [] <|> p = p + p <|> Final [] = p + Final r <|> Final t = Final (r <|> t) + Final (r:rs) <|> Look f = Look (\s -> Final (pure r <|> (rs <|> run (f s) s))) + Final (r:rs) <|> p = Look (\s -> Final (pure r <|> (rs <|> run p s))) + Look f <|> Final r = Look (\s -> Final (case run (f s) s of + [] -> r + (x:xs) -> (pure x <|> xs) <|> r)) + p <|> Final r = Look (\s -> Final (case run p s of + [] -> r + (x:xs) -> (pure x <|> xs) <|> r)) + Look f <|> Look g = Look (\s -> f s <|> g s) + Look f <|> p = Look (\s -> f s <|> p) + p <|> Look f = Look (\s -> p <|> f s) +run :: (IsStream s, Alternative f) => Ctx s s a -> s -> f (a, s) +run (Get f) cs = case uncons cs of + Nothing -> empty + Just (c,s) -> run (f c) s +run (Look f) s = run (f s) s +run (Result x p) s = pure (x,s) <|> run p s +run (Final rs) _ = foldr (<|>) empty (map pure rs) From fea99369e3ffb5ac5591d7a54ab0c6c9be3cf59b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 30 Oct 2025 22:18:22 -0700 Subject: [PATCH 092/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 914c0e1..6ef192b 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -85,6 +85,12 @@ instance MonadError e m => MonadError e (Parsor s s m a) where throwError = liftP . throwError catchError p f = Parsor $ \s -> catchError (runParsor p s) (\e -> runParsor (f e) s) +instance Monad m => MonadReader s (Parsor s s m a) where + ask = get + local f (Parsor p) = do + s <- get + (a,_s) <- liftP (p (f s)) + return a instance Monad m => MonadState s (Parsor s s m a) where get = Parsor (\s -> pure (s,s)) put = Parsor . (pure (pure . ((),))) From 8abd66ff1d48885376f4eec366d0de30d81cd99e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 30 Oct 2025 22:18:49 -0700 Subject: [PATCH 093/282] Update Context.hs --- src/Control/Lens/Grammar/Context.hs | 97 +++++++++++++---------------- 1 file changed, 45 insertions(+), 52 deletions(-) diff --git a/src/Control/Lens/Grammar/Context.hs b/src/Control/Lens/Grammar/Context.hs index 84ba20f..280e8b9 100644 --- a/src/Control/Lens/Grammar/Context.hs +++ b/src/Control/Lens/Grammar/Context.hs @@ -1,75 +1,68 @@ module Control.Lens.Grammar.Context - ( Subtextual (..) - , ReadIx (..) - , Ctx (..) + ( ReadIx (..) + , Subtext (..) ) where import Control.Applicative -import Control.Lens (uncons) +import Control.Lens import Control.Lens.Grammar.Stream import Control.Monad import Control.Monad.Codensity +import Control.Monad.Reader +-- import Control.Monad.Trans +-- import Control.Monad.Trans.Indexed +import Data.Profunctor import GHC.Exts -import Text.ParserCombinators.ReadP (ReadP) -import qualified Text.ParserCombinators.ReadP as Text -class (IsStream s, MonadPlus m) => Subtextual s m where - getItem :: m (Item s) - lookStream :: m s +newtype ReadIx s t m a = ReadIx (Codensity (Subtext s t m) a) -instance Subtextual String ReadP where - getItem = Text.get - lookStream = Text.look +data Subtext s t m a + = Get (Item s -> Subtext s t m a) + | Look (s -> Subtext s t m a) + | Result a (Subtext s t m a) + | Final (m (a,t)) - - - - ------------------------ - -newtype ReadIx s t a = ReadIx (Codensity (Ctx s t) a) - -data Ctx s t a - = Get (Item s -> Ctx s t a) - | Look (s -> Ctx s t a) - | Result a (Ctx s t a) - | Final [(a,t)] - deriving Functor -instance IsStream s => Applicative (Ctx s s) where +-- instances +deriving stock instance Functor m => Functor (Subtext s t m) +instance (IsStream s, MonadPlus m) => Applicative (Subtext s s m) where pure x = Result x (Final empty) (<*>) = ap -instance IsStream s => MonadPlus (Ctx s s) -instance IsStream s => Monad (Ctx s s) where - (Get f) >>= k = Get (\c -> f c >>= k) - (Look f) >>= k = Look (\s -> f s >>= k) +instance (IsStream s, MonadPlus m) => MonadPlus (Subtext s s m) +instance (IsStream s, MonadPlus m) => Monad (Subtext s s m) where + (Get f) >>= k = Get (\c -> f c >>= k) + (Look f) >>= k = Look (\s -> f s >>= k) (Result x p) >>= k = k x <|> (p >>= k) (Final rs) >>= k = Final (rs >>= \(x,s) -> run (k x) s) -instance IsStream s => MonadFail (Ctx s s) where - fail _ = Final [] -instance IsStream s => Alternative (Ctx s s) where - empty = Final [] +instance (IsStream s, MonadPlus m) => Alternative (Subtext s s m) where + empty = Final empty + -- most common case: two gets are combined Get f1 <|> Get f2 = Get (\c -> f1 c <|> f2 c) + -- results are delivered as soon as possible Result x p <|> q = Result x (p <|> q) p <|> Result x q = Result x (p <|> q) - -- TODO: uncons - Final [] <|> p = p - p <|> Final [] = p - Final r <|> Final t = Final (r <|> t) - Final (r:rs) <|> Look f = Look (\s -> Final (pure r <|> (rs <|> run (f s) s))) - Final (r:rs) <|> p = Look (\s -> Final (pure r <|> (rs <|> run p s))) - Look f <|> Final r = Look (\s -> Final (case run (f s) s of - [] -> r - (x:xs) -> (pure x <|> xs) <|> r)) - p <|> Final r = Look (\s -> Final (case run p s of - [] -> r - (x:xs) -> (pure x <|> xs) <|> r)) + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + Final r <|> Final t = Final (r <|> t) + Final r <|> Look f = Look (\s -> Final (r <|> run (f s) s)) + Final r <|> p = Look (\s -> Final (r <|> run p s)) + Look f <|> Final r = Look (\s -> Final (run (f s) s <|> r)) + p <|> Final r = Look (\s -> Final (run p s <|> r)) + -- two looks are combined (=optimization) + -- look + sthg else floats upwards Look f <|> Look g = Look (\s -> f s <|> g s) Look f <|> p = Look (\s -> f s <|> p) p <|> Look f = Look (\s -> p <|> f s) -run :: (IsStream s, Alternative f) => Ctx s s a -> s -> f (a, s) -run (Get f) cs = case uncons cs of - Nothing -> empty - Just (c,s) -> run (f c) s +run :: (IsStream s, Alternative f) => Subtext s s f a -> s -> f (a, s) +run (Get f) cs = maybe empty (\(c,s) -> run (f c) s) (uncons cs) run (Look f) s = run (f s) s run (Result x p) s = pure (x,s) <|> run p s -run (Final rs) _ = foldr (<|>) empty (map pure rs) +run (Final rs) _ = rs +instance (IsStream s, MonadPlus m) => MonadReader s (Subtext s s m) where + ask = Look return + local g = \case + Get f -> Get (local g . f) + Look f -> Look (f . g) + Result x p -> Result x (local g p) + Final r -> Final (fmap (second' g) r) + reader f = Look (return . f) From d2422a027ccb45df345e65d8dfdebcde43ea228e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 1 Nov 2025 13:34:29 -0700 Subject: [PATCH 094/282] Reador --- src/Control/Lens/Grammar.hs | 5 +- src/Control/Lens/Grammar/Context.hs | 92 +++++++++++++------------ src/Data/Profunctor/Do.hs | 4 +- src/Data/Profunctor/Grammar.hs | 102 +++++++++++++++++++++++++--- src/Data/Profunctor/Monadic.hs | 92 ++++++++++++------------- 5 files changed, 187 insertions(+), 108 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 61ec8a1..b2790f9 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -89,11 +89,10 @@ type Grammatical token p = ) type Contextual token m p = ( Grammatical token (p m) - , MonadicPlus p - -- , MonadicError String p + , Monadic m p + , forall a. MonadPlus (p m a) , Filterable m , MonadPlus m - -- , MonadError String m ) prismGrammar :: (Monoidal p, Choice p) => Prism' a () -> p a a diff --git a/src/Control/Lens/Grammar/Context.hs b/src/Control/Lens/Grammar/Context.hs index 280e8b9..c33a44c 100644 --- a/src/Control/Lens/Grammar/Context.hs +++ b/src/Control/Lens/Grammar/Context.hs @@ -1,68 +1,72 @@ module Control.Lens.Grammar.Context - ( ReadIx (..) + ( Reador (..) + , Showor (..) , Subtext (..) + , Context (..) ) where import Control.Applicative -import Control.Lens -import Control.Lens.Grammar.Stream import Control.Monad import Control.Monad.Codensity import Control.Monad.Reader +import Control.Monad.State -- import Control.Monad.Trans -- import Control.Monad.Trans.Indexed -import Data.Profunctor -import GHC.Exts +-- import Data.Profunctor -newtype ReadIx s t m a = ReadIx (Codensity (Subtext s t m) a) +newtype Reador s t m a b = Reador (Codensity (Subtext s t m) a) + +newtype Showor s t w a b = Showor (Codensity (Context s t w a) b) data Subtext s t m a - = Get (Item s -> Subtext s t m a) - | Look (s -> Subtext s t m a) - | Result a (Subtext s t m a) - | Final (m (a,t)) + = Get (s -> Subtext s t m a) + | Put (m (a,t)) + | Subtext a (Subtext s t m a) + +data Context s t w a b + = Ask (a -> Context s t w a b) + | Local (w (b, s -> t)) + | Context b (Context s t w a b) -- instances + +-- ReadIx deriving stock instance Functor m => Functor (Subtext s t m) -instance (IsStream s, MonadPlus m) => Applicative (Subtext s s m) where - pure x = Result x (Final empty) +instance (MonadPlus m) => Applicative (Subtext s s m) where + pure x = Subtext x (Put empty) (<*>) = ap -instance (IsStream s, MonadPlus m) => MonadPlus (Subtext s s m) -instance (IsStream s, MonadPlus m) => Monad (Subtext s s m) where - (Get f) >>= k = Get (\c -> f c >>= k) - (Look f) >>= k = Look (\s -> f s >>= k) - (Result x p) >>= k = k x <|> (p >>= k) - (Final rs) >>= k = Final (rs >>= \(x,s) -> run (k x) s) -instance (IsStream s, MonadPlus m) => Alternative (Subtext s s m) where - empty = Final empty +instance (MonadPlus m) => MonadPlus (Subtext s s m) +instance (MonadPlus m) => Monad (Subtext s s m) where + (Get f) >>= k = Get (\s -> f s >>= k) + (Subtext x p) >>= k = k x <|> (p >>= k) + (Put r) >>= k = Put (r >>= \(x,s) -> run (k x) s) +instance (MonadPlus m) => Alternative (Subtext s s m) where + empty = Put empty -- most common case: two gets are combined - Get f1 <|> Get f2 = Get (\c -> f1 c <|> f2 c) -- results are delivered as soon as possible - Result x p <|> q = Result x (p <|> q) - p <|> Result x q = Result x (p <|> q) + Subtext x p <|> q = Subtext x (p <|> q) + p <|> Subtext x q = Subtext x (p <|> q) -- two finals are combined -- final + look becomes one look and one final (=optimization) -- final + sthg else becomes one look and one final - Final r <|> Final t = Final (r <|> t) - Final r <|> Look f = Look (\s -> Final (r <|> run (f s) s)) - Final r <|> p = Look (\s -> Final (r <|> run p s)) - Look f <|> Final r = Look (\s -> Final (run (f s) s <|> r)) - p <|> Final r = Look (\s -> Final (run p s <|> r)) + Put r <|> Put t = Put (r <|> t) + Put r <|> Get f = Get (\s -> Put (r <|> run (f s) s)) + Get f <|> Put r = Get (\s -> Put (run (f s) s <|> r)) -- two looks are combined (=optimization) -- look + sthg else floats upwards - Look f <|> Look g = Look (\s -> f s <|> g s) - Look f <|> p = Look (\s -> f s <|> p) - p <|> Look f = Look (\s -> p <|> f s) -run :: (IsStream s, Alternative f) => Subtext s s f a -> s -> f (a, s) -run (Get f) cs = maybe empty (\(c,s) -> run (f c) s) (uncons cs) -run (Look f) s = run (f s) s -run (Result x p) s = pure (x,s) <|> run p s -run (Final rs) _ = rs -instance (IsStream s, MonadPlus m) => MonadReader s (Subtext s s m) where - ask = Look return - local g = \case - Get f -> Get (local g . f) - Look f -> Look (f . g) - Result x p -> Result x (local g p) - Final r -> Final (fmap (second' g) r) - reader f = Look (return . f) + Get f <|> Get g = Get (\s -> f s <|> g s) +run :: (Alternative f) => Subtext s s f a -> s -> f (a, s) +run (Get f) s = run (f s) s +run (Subtext x p) s = pure (x,s) <|> run p s +run (Put rs) _ = rs +instance (MonadPlus m) => MonadReader s (Subtext s s m) where + ask = get + local f subtext = do + s <- get + modify f + a <- subtext + put s + return a +instance (MonadPlus m) => MonadState s (Subtext s s m) where + get = Get pure + put s = Put (pure (pure s)) diff --git a/src/Data/Profunctor/Do.hs b/src/Data/Profunctor/Do.hs index 6e288af..e850899 100644 --- a/src/Data/Profunctor/Do.hs +++ b/src/Data/Profunctor/Do.hs @@ -20,11 +20,11 @@ import Data.Profunctor.Monadic import Prelude hiding ((>>), (>>=)) (>>=) - :: (Polyadic p, Monad m) + :: Polyadic m p => p i j m a b -> (b -> p j k m a c) -> p i k m a c x >>= f = composeP (fmap f x) (>>) - :: (Polyadic p, Monad m) + :: Polyadic m p => p i j m a b -> p j k m a c -> p i k m a c x >> y = x >>= (\_ -> y) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 6ef192b..690dfa5 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -9,12 +9,15 @@ module Data.Profunctor.Grammar , Grammor (..) , grammor , evalGrammor + -- * Reador + , Reador (..) ) where import Control.Applicative import Control.Arrow import Control.Category import Control.Comonad +import Control.Monad.Codensity import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State @@ -53,6 +56,91 @@ grammor = Grammor . pure . pure evalGrammor :: (Monoid s, Comonad f) => Grammor s t f a b -> t evalGrammor = extract . extract . runGrammor +newtype Reador s f a b = Reador (Codensity (Stx s f) b) +data Stx s f b + = Stx (f b) (Stx s f b) + | Get (s -> Stx s f b) + | Put (f (b,s)) +runStx :: Alternative f => Stx s f a -> s -> f (a, s) +runStx (Get f) s = runStx (f s) s +runStx (Stx x p) s = (,s) <$> x <|> runStx p s +runStx (Put rs) _ = rs +liftStx :: MonadPlus m => m b -> Stx s m b +liftStx b = Stx b empty + +-- Reador instances +deriving newtype instance Functor (Reador s f a) +deriving newtype instance Applicative (Reador s f a) +deriving newtype instance Monad (Reador s f a) +deriving newtype instance MonadPlus m => MonadState s (Reador s m a) +deriving newtype instance MonadPlus m => Alternative (Reador s m a) +deriving newtype instance MonadPlus m => MonadPlus (Reador s m a) +instance (Filterable m, MonadPlus m) => Filterable (Reador s m a) where + mapMaybe f (Reador p) = Reador (lift (mapMaybe f (lowerCodensity p))) +instance Profunctor (Reador s f) where + dimap _ f (Reador p) = fmap f (Reador p) + rmap = fmap + lmap _ (Reador p) = Reador p +instance Choice (Reador s f) where + left' (Reador p) = Reador (fmap Left p) + right' (Reador p) = Reador (fmap Right p) +instance MonadPlus m => Distributor (Reador s m) +instance MonadPlus m => Alternator (Reador s m) where + alternate = \case + Left (Reador p) -> Reador (fmap Left p) + Right (Reador p) -> Reador (fmap Right p) +instance (Filterable m, MonadPlus m) => Cochoice (Reador s m) where + unleft = fst . filtrate + unright = snd . filtrate +instance (Filterable m, MonadPlus m) => Filtrator (Reador s m) where + filtrate (Reador p) = + ( Reador + . lift . mapMaybe (either Just (const Nothing)) + . lowerCodensity $ p + , Reador + . lift . mapMaybe (either (const Nothing) Just) + . lowerCodensity $ p + ) +instance MonadPlus m => Monadic m (Reador s) where + liftP = Reador . lift . liftStx +-- Stx instances +instance Filterable f => Filterable (Stx s f) where + mapMaybe f = \case + Stx b p -> Stx (mapMaybe f b) (mapMaybe f p) + Get g -> Get (mapMaybe f . g) + Put bt -> Put (mapMaybe (\(b,t) -> (,t) <$> f b) bt) +deriving stock instance Functor f => Functor (Stx s f) +instance MonadPlus m => Applicative (Stx s m) where + pure b = Stx (pure b) (Put empty) + (<*>) = ap +instance MonadPlus m => MonadPlus (Stx s m) +instance MonadPlus m => Monad (Stx s m) where + (Stx x p) >>= k = (liftStx x >>= k) <|> (p >>= k) + (Get f) >>= k = Get (\s -> f s >>= k) + (Put r) >>= k = Put (r >>= \(x,s) -> runStx (k x) s) +instance MonadPlus m => Alternative (Stx s m) where + empty = Put empty + -- results are delivered as soon as possible + Stx x p <|> q = Stx x (p <|> q) + p <|> Stx x q = Stx x (p <|> q) + -- two puts are combined + -- put + get becomes one get and one final (=optimization) + Put r <|> Put t = Put (r <|> t) + Put r <|> Get f = Get (\s -> Put (r <|> runStx (f s) s)) + Get f <|> Put r = Get (\s -> Put (runStx (f s) s <|> r)) + -- two looks are combined (=optimization) + -- look + sthg else floats upwards + Get f <|> Get g = Get (\s -> f s <|> g s) +instance MonadPlus m => MonadReader s (Stx s m) where + ask = Get pure + local f = \case + Stx x p -> Stx x (local f p) + Get g -> Get (g . f) + Put r -> Put r +instance MonadPlus m => MonadState s (Stx s m) where + get = Get pure + put s = Put (pure (pure s)) + -- Parsor instances instance Functor f => Functor (Parsor s t f a) where fmap f = Parsor . fmap (fmap (first' f)) . runParsor @@ -85,12 +173,6 @@ instance MonadError e m => MonadError e (Parsor s s m a) where throwError = liftP . throwError catchError p f = Parsor $ \s -> catchError (runParsor p s) (\e -> runParsor (f e) s) -instance Monad m => MonadReader s (Parsor s s m a) where - ask = get - local f (Parsor p) = do - s <- get - (a,_s) <- liftP (p (f s)) - return a instance Monad m => MonadState s (Parsor s s m a) where get = Parsor (\s -> pure (s,s)) put = Parsor . (pure (pure . ((),))) @@ -102,12 +184,12 @@ instance (Alternative m, Monad m) => Alternator (Parsor s s m) 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 Monadic (Parsor s s) where +instance Monad m => Monadic m (Parsor s s) where joinP (Parsor p) = Parsor $ \s -> do (mb, s') <- p s b <- mb return (b, s') -instance Polyadic Parsor where +instance Monad m => Polyadic m Parsor where composeP (Parsor p) = Parsor $ \s -> do (mb, s') <- p s runParsor mb s' @@ -173,12 +255,12 @@ instance Monad m => MonadReader a (Printor s s m a) where ask = Printor (\a -> return (a, id)) reader f = (Printor (\a -> return (f a, id))) local f = Printor . (\m -> m . f) . runPrintor -instance Monadic (Printor s s) where +instance Monad m => Monadic m (Printor s s) where joinP (Printor mf) = Printor $ \a -> do (mb, f) <- mf a b <- mb return (b, f) -instance Polyadic Printor where +instance Monad m => Polyadic m Printor where composeP (Printor mf) = Printor $ \a -> do (Printor mg, f) <- mf a (b, g) <- mg a diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 1a19657..c9e1ed4 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -14,8 +14,6 @@ module Data.Profunctor.Monadic ( Monadic (..) , Polyadic (..) , Tetradic (..) - , MonadicPlus - , MonadicError , WrappedMonadic (..) , WrappedPolyadic (..) , TaggedP (..) @@ -25,32 +23,28 @@ module Data.Profunctor.Monadic import Control.Category import Control.Monad -import Control.Monad.Except import Control.Monad.State import Control.Monad.Trans.Indexed import Data.Profunctor -import Data.Profunctor.Filtrator -import Data.Kind import Prelude hiding (id, (.)) -import Witherable class - ( forall m. Monad m => Profunctor (p m) - , forall m x. Monad m => Monad (p m x) - ) => Monadic p where + ( Profunctor (p m) + , forall x. Monad (p m x) + ) => Monadic m p where - joinP :: Monad m => p m a (m b) -> p m a b + joinP :: p m a (m b) -> p m a b joinP = join . fmap liftP - liftP :: Monad m => m b -> p m a b + liftP :: m b -> p m a b liftP = joinP . return class - ( forall i j. i ~ j => Monadic (p i j) - , forall i j m. Monad m => Profunctor (p i j m) - , forall i j m a. Monad m => Functor (p i j m a) - ) => Polyadic p where - composeP :: Monad m => p i j m a (p j k m a b) -> p i k m a b + ( forall i j. Profunctor (p i j m) + , forall i j a. Functor (p i j m a) + , forall i. Monadic m (p i i) + ) => Polyadic m p where + composeP :: p i j m a (p j k m a b) -> p i k m a b class (forall i j. Profunctor (p i j f)) => Tetradic f p where @@ -65,49 +59,45 @@ class (forall i j. Profunctor (p i j f)) => Tetradic f p where -> p i j f a b -> p h k f a b dimapT f1 f2 = tetramap f1 f2 id id -type MonadicPlus p = - ( Monadic p - , forall m. (Filterable m, MonadPlus m) => Filtrator (p m) - , forall m x. (Filterable m, MonadPlus m) => MonadPlus (p m x) - ) :: Constraint - -type MonadicError e p = - ( Monadic p - , forall m x. MonadError e m => MonadError e (p m x) - ) :: Constraint - newtype WrappedMonadic p m a b = WrapMonadic {unwrapMonadic :: p m a (m b)} -instance (Monadic p, Monad m) => Functor (WrappedMonadic p m a) where +instance (Monadic m p, Monad m) => Functor (WrappedMonadic p m a) where fmap = rmap -instance (Monadic p, Monad m) => Applicative (WrappedMonadic p m a) where +instance (Monadic m p, Monad m) => Applicative (WrappedMonadic p m a) where pure x = WrapMonadic $ pure (pure x) WrapMonadic p1 <*> WrapMonadic p2 = WrapMonadic $ liftA2 (<*>) p1 p2 -instance (Monadic p, Monad m) => Monad (WrappedMonadic p m a) where +instance (Monadic m p, Monad m) => Monad (WrappedMonadic p m a) where return = pure WrapMonadic p >>= f = WrapMonadic $ do b <- joinP p unwrapMonadic (f b) -instance (Monadic p, Monad m) => Profunctor (WrappedMonadic p m) where +instance (Monadic m p, Monad m) => Profunctor (WrappedMonadic p m) where dimap f g (WrapMonadic p) = WrapMonadic $ dimap f (fmap g) p -instance Monadic p => Monadic (WrappedMonadic p) where +instance (Monad m, Monadic m p) => Monadic m (WrappedMonadic p) where joinP (WrapMonadic p) = WrapMonadic (joinP p) -newtype WrappedPolyadic p i j m a b = WrapPolyadic {unwrapPolyadic :: p i j m a (m b)} -instance (Polyadic p, Monad m) => Functor (WrappedPolyadic p i j m a) where +newtype WrappedPolyadic p i j m a b = + WrapPolyadic {unwrapPolyadic :: p i j m a (m b)} +instance (Polyadic m p, Monad m) + => Functor (WrappedPolyadic p i j m a) where fmap = rmap -instance (Polyadic p, Monad m, i ~ j) => Applicative (WrappedPolyadic p i j m a) where +instance (Polyadic m p, Monad m) + => Applicative (WrappedPolyadic p i i m a) where pure x = WrapPolyadic $ pure (pure x) - WrapPolyadic p1 <*> WrapPolyadic p2 = WrapPolyadic $ liftA2 (<*>) p1 p2 -instance (Polyadic p, Monad m, i ~ j) => Monad (WrappedPolyadic p i j m a) where + WrapPolyadic p1 <*> WrapPolyadic p2 = + WrapPolyadic $ liftA2 (<*>) p1 p2 +instance (Polyadic m p, Monad m) + => Monad (WrappedPolyadic p i i m a) where return = pure WrapPolyadic p >>= f = WrapPolyadic $ do b <- joinP p unwrapPolyadic (f b) -instance (Polyadic p, Monad m) => Profunctor (WrappedPolyadic p i j m) where +instance (Polyadic m p, Monad m) + => Profunctor (WrappedPolyadic p i j m) where dimap f g = WrapPolyadic . dimap f (fmap g) . unwrapPolyadic -instance (Polyadic p, i ~ j) => Monadic (WrappedPolyadic p i j) where +instance (Monad m, Polyadic m p) + => Monadic m (WrappedPolyadic p i i) where joinP = WrapPolyadic . joinP . unwrapPolyadic -instance Polyadic p => Polyadic (WrappedPolyadic p) where +instance (Monad m, Polyadic m p) => Polyadic m (WrappedPolyadic p) where composeP = WrapPolyadic . composeP . fmap unwrapPolyadic . composeP @@ -117,16 +107,20 @@ newtype TaggedP t i j f a b = TagP {untagP :: t i j f b} deriving newtype (Functor, Applicative, Monad) instance Functor (t i j f) => Profunctor (TaggedP t i j f) where dimap _ f = TagP . fmap f . untagP -instance MonadTrans (t i j) => Monadic (TaggedP t i j) where +instance (Monad m, MonadTrans (t i j)) + => Monadic m (TaggedP t i j) where liftP = TagP . lift -instance IxMonadTrans t => Polyadic (TaggedP t) where +instance (Monad m, IxMonadTrans t) + => Polyadic m (TaggedP t) where composeP = TagP . joinIx . fmap untagP . untagP newtype UntaggedT p a i j f b = UntagT {tagT :: p i j f a b} deriving newtype (Functor, Applicative, Monad) -instance Monadic (p i j) => MonadTrans (UntaggedT p a i j) where +instance (forall m. Monad m => Monadic m (p i j)) + => MonadTrans (UntaggedT p a i j) where lift = UntagT . liftP -instance Polyadic p => IxMonadTrans (UntaggedT p a) where +instance (forall m. Monad m => Polyadic m p) + => IxMonadTrans (UntaggedT p a) where joinIx = UntagT . composeP . fmap tagT . tagT newtype UntaggedC p a b f i j = UntagC {tagC :: p i j f a b} @@ -136,10 +130,10 @@ instance (Tetradic f p, Functor f) => Profunctor (UntaggedC p a b f) where dimap f g = UntagC . dimapT f g . tagC instance (Tetradic f p, Functor f) => Functor (UntaggedC p a b f i) where fmap = rmap -instance (Polyadic p, Monad m, Monoid b) => Category (UntaggedC p a b m) where +instance (Polyadic m p, Monoid b) => Category (UntaggedC p a b m) where id = UntagC (pure mempty) UntagC g . UntagC f = UntagC (composeP (fmap (\b -> fmap (<> b) g) f)) -instance (Polyadic p, Monad m, Monoid b, i ~ j) - => Semigroup (UntaggedC p a b m i j) where (<>) = (>>>) -instance (Polyadic p, Monad m, Monoid b, i ~ j) - => Monoid (UntaggedC p a b m i j) where mempty = id +instance (Polyadic m p, Monad m, Monoid b) + => Semigroup (UntaggedC p a b m i i) where (<>) = (>>>) +instance (Polyadic m p, Monad m, Monoid b) + => Monoid (UntaggedC p a b m i i) where mempty = id From d3fd1c4622ccb9c5e8bcf8de2f392ef4ce969794 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 1 Nov 2025 20:42:59 -0700 Subject: [PATCH 095/282] StreamM --- src/Control/Lens/Grammar/Stream.hs | 9 ++ src/Data/Profunctor/Grammar.hs | 134 +++++++++++++---------------- 2 files changed, 71 insertions(+), 72 deletions(-) diff --git a/src/Control/Lens/Grammar/Stream.hs b/src/Control/Lens/Grammar/Stream.hs index b7ebb70..702f99d 100644 --- a/src/Control/Lens/Grammar/Stream.hs +++ b/src/Control/Lens/Grammar/Stream.hs @@ -1,6 +1,7 @@ module Control.Lens.Grammar.Stream ( -- * Stream IsStream + , IsStreamM , stream , stream1 -- * SepBy @@ -25,6 +26,14 @@ import GHC.Exts type IsStream s = (IsList s, AsEmpty s, Cons s s (Item s) (Item s)) +type IsStreamM f = + ( forall x. IsList (f x) + , forall x. AsEmpty (f x) + , forall x. Cons (f x) (f x) x x + , Alternative f + , Monad f + ) + streamLine :: (IsList s, Item s ~ Char) => s -> IO () streamLine = putStrLn . toList diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 690dfa5..3a435bf 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -57,89 +57,79 @@ evalGrammor :: (Monoid s, Comonad f) => Grammor s t f a b -> t evalGrammor = extract . extract . runGrammor newtype Reador s f a b = Reador (Codensity (Stx s f) b) -data Stx s f b - = Stx (f b) (Stx s f b) - | Get (s -> Stx s f b) - | Put (f (b,s)) -runStx :: Alternative f => Stx s f a -> s -> f (a, s) -runStx (Get f) s = runStx (f s) s -runStx (Stx x p) s = (,s) <$> x <|> runStx p s -runStx (Put rs) _ = rs -liftStx :: MonadPlus m => m b -> Stx s m b -liftStx b = Stx b empty -- Reador instances deriving newtype instance Functor (Reador s f a) deriving newtype instance Applicative (Reador s f a) deriving newtype instance Monad (Reador s f a) -deriving newtype instance MonadPlus m => MonadState s (Reador s m a) -deriving newtype instance MonadPlus m => Alternative (Reador s m a) -deriving newtype instance MonadPlus m => MonadPlus (Reador s m a) -instance (Filterable m, MonadPlus m) => Filterable (Reador s m a) where - mapMaybe f (Reador p) = Reador (lift (mapMaybe f (lowerCodensity p))) -instance Profunctor (Reador s f) where - dimap _ f (Reador p) = fmap f (Reador p) - rmap = fmap - lmap _ (Reador p) = Reador p -instance Choice (Reador s f) where - left' (Reador p) = Reador (fmap Left p) - right' (Reador p) = Reador (fmap Right p) -instance MonadPlus m => Distributor (Reador s m) -instance MonadPlus m => Alternator (Reador s m) where - alternate = \case - Left (Reador p) -> Reador (fmap Left p) - Right (Reador p) -> Reador (fmap Right p) -instance (Filterable m, MonadPlus m) => Cochoice (Reador s m) where - unleft = fst . filtrate - unright = snd . filtrate -instance (Filterable m, MonadPlus m) => Filtrator (Reador s m) where - filtrate (Reador p) = - ( Reador - . lift . mapMaybe (either Just (const Nothing)) - . lowerCodensity $ p - , Reador - . lift . mapMaybe (either (const Nothing) Just) - . lowerCodensity $ p - ) -instance MonadPlus m => Monadic m (Reador s) where - liftP = Reador . lift . liftStx --- Stx instances +deriving newtype instance (IsStream s, IsStreamM m) => Alternative (Reador s m a) +deriving newtype instance (IsStream s, IsStreamM m) => MonadPlus (Reador s m a) +deriving newtype instance (IsStream s, IsStreamM m) => MonadReader s (Reador s m a) +deriving newtype instance (IsStream s, IsStreamM m) => MonadState s (Reador s m a) + +-- The Stx type +data Stx s f a + = LookStx (s -> Stx s f a) + | ResultStx a (Stx s f a) + | FailStx + | FinalStx (a,s) (f (a,s)) + deriving Functor instance Filterable f => Filterable (Stx s f) where mapMaybe f = \case - Stx b p -> Stx (mapMaybe f b) (mapMaybe f p) - Get g -> Get (mapMaybe f . g) - Put bt -> Put (mapMaybe (\(b,t) -> (,t) <$> f b) bt) -deriving stock instance Functor f => Functor (Stx s f) -instance MonadPlus m => Applicative (Stx s m) where - pure b = Stx (pure b) (Put empty) + LookStx g -> LookStx (mapMaybe f . g) + FailStx -> FailStx + ResultStx a stx -> case f a of + Nothing -> FailStx + Just b -> ResultStx b (mapMaybe f stx) + FinalStx (a,s) rs -> case f a of + Nothing -> FailStx + Just b -> FinalStx (b,s) + (mapMaybe (\(a',s') -> (,s') <$> f a') rs) +runStx :: (IsStream s, Alternative f) => Stx s f a -> s -> f (a,s) +runStx (LookStx f) s = runStx (f s) s +runStx (ResultStx x p) s = pure (x,s) <|> runStx p s +runStx (FinalStx r rs) _ = pure r <|> rs +runStx _ _ = empty +instance (IsStream s, IsStreamM f) => Applicative (Stx s f) where + pure x = ResultStx x FailStx (<*>) = ap -instance MonadPlus m => MonadPlus (Stx s m) -instance MonadPlus m => Monad (Stx s m) where - (Stx x p) >>= k = (liftStx x >>= k) <|> (p >>= k) - (Get f) >>= k = Get (\s -> f s >>= k) - (Put r) >>= k = Put (r >>= \(x,s) -> runStx (k x) s) -instance MonadPlus m => Alternative (Stx s m) where - empty = Put empty +instance (IsStream s, IsStreamM f) => MonadPlus (Stx s f) +instance (IsStream s, IsStreamM f) => Monad (Stx s f) where + LookStx f >>= k = LookStx (\s -> f s >>= k) + FailStx >>= _ = FailStx + ResultStx x p >>= k = k x <|> (p >>= k) + FinalStx r rs >>= k = + maybe FailStx (\(r',rs') -> FinalStx r' rs') . uncons $ do + (x,s) <- pure r <|> rs + runStx (k x) s +instance (IsStream s, IsStreamM f) => Alternative (Stx s f) where + empty = FailStx -- results are delivered as soon as possible - Stx x p <|> q = Stx x (p <|> q) - p <|> Stx x q = Stx x (p <|> q) - -- two puts are combined - -- put + get becomes one get and one final (=optimization) - Put r <|> Put t = Put (r <|> t) - Put r <|> Get f = Get (\s -> Put (r <|> runStx (f s) s)) - Get f <|> Put r = Get (\s -> Put (runStx (f s) s <|> r)) + ResultStx x p <|> q = ResultStx x (p <|> q) + p <|> ResultStx x q = ResultStx x (p <|> q) + -- fail disappears + FailStx <|> p = p + p <|> FailStx = p + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + FinalStx r rs <|> FinalStx t ts = + FinalStx r (rs <|> pure t <|> ts) + FinalStx r rs <|> LookStx f = + LookStx (\s -> FinalStx r (rs <|> runStx (f s) s)) + LookStx f <|> FinalStx y ys = LookStx $ \s -> + maybe (FinalStx y ys) + (\(x,xs) -> FinalStx x (xs <|> pure y <|> ys)) + (uncons (runStx (f s) s)) -- two looks are combined (=optimization) - -- look + sthg else floats upwards - Get f <|> Get g = Get (\s -> f s <|> g s) -instance MonadPlus m => MonadReader s (Stx s m) where - ask = Get pure + LookStx f <|> LookStx g = LookStx (\s -> f s <|> g s) +instance (IsStream s, IsStreamM m) => MonadReader s (Stx s m) where + ask = LookStx pure local f = \case - Stx x p -> Stx x (local f p) - Get g -> Get (g . f) - Put r -> Put r -instance MonadPlus m => MonadState s (Stx s m) where - get = Get pure - put s = Put (pure (pure s)) + LookStx g -> LookStx (g . f) + FailStx -> FailStx + ResultStx a stx -> ResultStx a stx + FinalStx r rs -> FinalStx r rs -- Parsor instances instance Functor f => Functor (Parsor s t f a) where From cdb0190a0c8bda0a37fc97115724e5a783cbf58f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 1 Nov 2025 21:10:55 -0700 Subject: [PATCH 096/282] simplify Stx --- src/Control/Lens/Grammar/Stream.hs | 9 ---- src/Data/Profunctor/Grammar.hs | 76 ++++++++++++++---------------- 2 files changed, 35 insertions(+), 50 deletions(-) diff --git a/src/Control/Lens/Grammar/Stream.hs b/src/Control/Lens/Grammar/Stream.hs index 702f99d..b7ebb70 100644 --- a/src/Control/Lens/Grammar/Stream.hs +++ b/src/Control/Lens/Grammar/Stream.hs @@ -1,7 +1,6 @@ module Control.Lens.Grammar.Stream ( -- * Stream IsStream - , IsStreamM , stream , stream1 -- * SepBy @@ -26,14 +25,6 @@ import GHC.Exts type IsStream s = (IsList s, AsEmpty s, Cons s s (Item s) (Item s)) -type IsStreamM f = - ( forall x. IsList (f x) - , forall x. AsEmpty (f x) - , forall x. Cons (f x) (f x) x x - , Alternative f - , Monad f - ) - streamLine :: (IsList s, Item s ~ Char) => s -> IO () streamLine = putStrLn . toList diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 3a435bf..4f3be92 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -62,74 +62,68 @@ newtype Reador s f a b = Reador (Codensity (Stx s f) b) deriving newtype instance Functor (Reador s f a) deriving newtype instance Applicative (Reador s f a) deriving newtype instance Monad (Reador s f a) -deriving newtype instance (IsStream s, IsStreamM m) => Alternative (Reador s m a) -deriving newtype instance (IsStream s, IsStreamM m) => MonadPlus (Reador s m a) -deriving newtype instance (IsStream s, IsStreamM m) => MonadReader s (Reador s m a) -deriving newtype instance (IsStream s, IsStreamM m) => MonadState s (Reador s m a) +deriving newtype instance (Alternative m, Monad m) + => Alternative (Reador s m a) +deriving newtype instance (Alternative m, Monad m) + => MonadPlus (Reador s m a) +deriving newtype instance (Alternative m, Monad m) + => MonadReader s (Reador s m a) +deriving newtype instance (Alternative m, Monad m) + => MonadState s (Reador s m a) +instance (Alternative m, Monad m, Filterable m) + => Filterable (Reador s m a) where + mapMaybe f (Reador p) = + Reador (lift (mapMaybe f (lowerCodensity p))) -- The Stx type data Stx s f a = LookStx (s -> Stx s f a) | ResultStx a (Stx s f a) - | FailStx - | FinalStx (a,s) (f (a,s)) + | FinalStx (f (a,s)) deriving Functor -instance Filterable f => Filterable (Stx s f) where +instance (Alternative f, Monad f, Filterable f) + => Filterable (Stx s f) where mapMaybe f = \case LookStx g -> LookStx (mapMaybe f . g) - FailStx -> FailStx ResultStx a stx -> case f a of - Nothing -> FailStx + Nothing -> empty Just b -> ResultStx b (mapMaybe f stx) - FinalStx (a,s) rs -> case f a of - Nothing -> FailStx - Just b -> FinalStx (b,s) - (mapMaybe (\(a',s') -> (,s') <$> f a') rs) -runStx :: (IsStream s, Alternative f) => Stx s f a -> s -> f (a,s) + FinalStx r -> FinalStx (mapMaybe (\(a,s) -> (,s) <$> f a) r) +runStx :: Alternative f => Stx s f a -> s -> f (a,s) runStx (LookStx f) s = runStx (f s) s runStx (ResultStx x p) s = pure (x,s) <|> runStx p s -runStx (FinalStx r rs) _ = pure r <|> rs -runStx _ _ = empty -instance (IsStream s, IsStreamM f) => Applicative (Stx s f) where - pure x = ResultStx x FailStx +runStx (FinalStx rs) _ = rs +instance (Alternative f, Monad f) => Applicative (Stx s f) where + pure x = ResultStx x empty (<*>) = ap -instance (IsStream s, IsStreamM f) => MonadPlus (Stx s f) -instance (IsStream s, IsStreamM f) => Monad (Stx s f) where +instance (Alternative f, Monad f) => MonadPlus (Stx s f) +instance (Alternative f, Monad f) => Monad (Stx s f) where LookStx f >>= k = LookStx (\s -> f s >>= k) - FailStx >>= _ = FailStx ResultStx x p >>= k = k x <|> (p >>= k) - FinalStx r rs >>= k = - maybe FailStx (\(r',rs') -> FinalStx r' rs') . uncons $ do - (x,s) <- pure r <|> rs - runStx (k x) s -instance (IsStream s, IsStreamM f) => Alternative (Stx s f) where - empty = FailStx + FinalStx rs >>= k = FinalStx $ do + (x,s) <- rs + runStx (k x) s +instance (Alternative f, Monad f) => Alternative (Stx s f) where + empty = FinalStx empty -- results are delivered as soon as possible ResultStx x p <|> q = ResultStx x (p <|> q) p <|> ResultStx x q = ResultStx x (p <|> q) - -- fail disappears - FailStx <|> p = p - p <|> FailStx = p -- two finals are combined -- final + look becomes one look and one final (=optimization) -- final + sthg else becomes one look and one final - FinalStx r rs <|> FinalStx t ts = - FinalStx r (rs <|> pure t <|> ts) - FinalStx r rs <|> LookStx f = - LookStx (\s -> FinalStx r (rs <|> runStx (f s) s)) - LookStx f <|> FinalStx y ys = LookStx $ \s -> - maybe (FinalStx y ys) - (\(x,xs) -> FinalStx x (xs <|> pure y <|> ys)) - (uncons (runStx (f s) s)) + FinalStx rs <|> FinalStx ts = FinalStx (rs <|> ts) + FinalStx rs <|> LookStx f = + LookStx (\s -> FinalStx (rs <|> runStx (f s) s)) + LookStx f <|> FinalStx rs = + LookStx (\s -> FinalStx (runStx (f s) s <|> rs)) -- two looks are combined (=optimization) LookStx f <|> LookStx g = LookStx (\s -> f s <|> g s) -instance (IsStream s, IsStreamM m) => MonadReader s (Stx s m) where +instance (Alternative m, Monad m) => MonadReader s (Stx s m) where ask = LookStx pure local f = \case LookStx g -> LookStx (g . f) - FailStx -> FailStx ResultStx a stx -> ResultStx a stx - FinalStx r rs -> FinalStx r rs + FinalStx rs -> FinalStx rs -- Parsor instances instance Functor f => Functor (Parsor s t f a) where From 32da2421eed012360fd60d929fee6529ef8fb695 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 1 Nov 2025 21:31:27 -0700 Subject: [PATCH 097/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 4f3be92..4c3c590 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -74,6 +74,40 @@ instance (Alternative m, Monad m, Filterable m) => Filterable (Reador s m a) where mapMaybe f (Reador p) = Reador (lift (mapMaybe f (lowerCodensity p))) +instance Profunctor (Reador s f) where + dimap _ f (Reador p) = Reador (fmap f p) +instance Choice (Reador s f) where + left' (Reador p) = Reador (fmap Left p) + right' (Reador p) = Reador (fmap Right p) +instance (Alternative f, Monad f) => Distributor (Reador s f) +instance (Alternative f, Monad f) + => Alternator (Reador s f) where + alternate = \case + Left (Reador p) -> Reador (fmap Left p) + Right (Reador p) -> Reador (fmap Right p) +instance (Alternative f, Monad f, Filterable f) + => Cochoice (Reador s f) where + unleft (Reador p) + = Reador . lift + . mapMaybe (either Just (const Nothing)) + . lowerCodensity $ p + unright (Reador p) + = Reador . lift + . mapMaybe (either (const Nothing) Just) + . lowerCodensity $ p +instance (Alternative f, Monad f, Filterable f) + => Filtrator (Reador s f) where + filtrate (Reador p) = + ( Reador . lift + . mapMaybe (either Just (const Nothing)) + . lowerCodensity $ p + + , Reador . lift + . mapMaybe (either (const Nothing) Just) + . lowerCodensity $ p + ) +instance (Alternative m, Monad m) => Monadic m (Reador s) where + liftP m = Reador (lift (LookStx (\s -> FinalStx ((,s) <$> m)))) -- The Stx type data Stx s f a From 75dc18d6b6a8648ddec2af58dc6924f919996b33 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 1 Nov 2025 21:51:43 -0700 Subject: [PATCH 098/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 222 ++++++++++++++++++--------------- 1 file changed, 121 insertions(+), 101 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 4c3c590..bcc6299 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -57,107 +57,10 @@ evalGrammor :: (Monoid s, Comonad f) => Grammor s t f a b -> t evalGrammor = extract . extract . runGrammor newtype Reador s f a b = Reador (Codensity (Stx s f) b) - --- Reador instances -deriving newtype instance Functor (Reador s f a) -deriving newtype instance Applicative (Reador s f a) -deriving newtype instance Monad (Reador s f a) -deriving newtype instance (Alternative m, Monad m) - => Alternative (Reador s m a) -deriving newtype instance (Alternative m, Monad m) - => MonadPlus (Reador s m a) -deriving newtype instance (Alternative m, Monad m) - => MonadReader s (Reador s m a) -deriving newtype instance (Alternative m, Monad m) - => MonadState s (Reador s m a) -instance (Alternative m, Monad m, Filterable m) - => Filterable (Reador s m a) where - mapMaybe f (Reador p) = - Reador (lift (mapMaybe f (lowerCodensity p))) -instance Profunctor (Reador s f) where - dimap _ f (Reador p) = Reador (fmap f p) -instance Choice (Reador s f) where - left' (Reador p) = Reador (fmap Left p) - right' (Reador p) = Reador (fmap Right p) -instance (Alternative f, Monad f) => Distributor (Reador s f) -instance (Alternative f, Monad f) - => Alternator (Reador s f) where - alternate = \case - Left (Reador p) -> Reador (fmap Left p) - Right (Reador p) -> Reador (fmap Right p) -instance (Alternative f, Monad f, Filterable f) - => Cochoice (Reador s f) where - unleft (Reador p) - = Reador . lift - . mapMaybe (either Just (const Nothing)) - . lowerCodensity $ p - unright (Reador p) - = Reador . lift - . mapMaybe (either (const Nothing) Just) - . lowerCodensity $ p -instance (Alternative f, Monad f, Filterable f) - => Filtrator (Reador s f) where - filtrate (Reador p) = - ( Reador . lift - . mapMaybe (either Just (const Nothing)) - . lowerCodensity $ p - - , Reador . lift - . mapMaybe (either (const Nothing) Just) - . lowerCodensity $ p - ) -instance (Alternative m, Monad m) => Monadic m (Reador s) where - liftP m = Reador (lift (LookStx (\s -> FinalStx ((,s) <$> m)))) - --- The Stx type -data Stx s f a - = LookStx (s -> Stx s f a) - | ResultStx a (Stx s f a) - | FinalStx (f (a,s)) - deriving Functor -instance (Alternative f, Monad f, Filterable f) - => Filterable (Stx s f) where - mapMaybe f = \case - LookStx g -> LookStx (mapMaybe f . g) - ResultStx a stx -> case f a of - Nothing -> empty - Just b -> ResultStx b (mapMaybe f stx) - FinalStx r -> FinalStx (mapMaybe (\(a,s) -> (,s) <$> f a) r) -runStx :: Alternative f => Stx s f a -> s -> f (a,s) -runStx (LookStx f) s = runStx (f s) s -runStx (ResultStx x p) s = pure (x,s) <|> runStx p s -runStx (FinalStx rs) _ = rs -instance (Alternative f, Monad f) => Applicative (Stx s f) where - pure x = ResultStx x empty - (<*>) = ap -instance (Alternative f, Monad f) => MonadPlus (Stx s f) -instance (Alternative f, Monad f) => Monad (Stx s f) where - LookStx f >>= k = LookStx (\s -> f s >>= k) - ResultStx x p >>= k = k x <|> (p >>= k) - FinalStx rs >>= k = FinalStx $ do - (x,s) <- rs - runStx (k x) s -instance (Alternative f, Monad f) => Alternative (Stx s f) where - empty = FinalStx empty - -- results are delivered as soon as possible - ResultStx x p <|> q = ResultStx x (p <|> q) - p <|> ResultStx x q = ResultStx x (p <|> q) - -- two finals are combined - -- final + look becomes one look and one final (=optimization) - -- final + sthg else becomes one look and one final - FinalStx rs <|> FinalStx ts = FinalStx (rs <|> ts) - FinalStx rs <|> LookStx f = - LookStx (\s -> FinalStx (rs <|> runStx (f s) s)) - LookStx f <|> FinalStx rs = - LookStx (\s -> FinalStx (runStx (f s) s <|> rs)) - -- two looks are combined (=optimization) - LookStx f <|> LookStx g = LookStx (\s -> f s <|> g s) -instance (Alternative m, Monad m) => MonadReader s (Stx s m) where - ask = LookStx pure - local f = \case - LookStx g -> LookStx (g . f) - ResultStx a stx -> ResultStx a stx - FinalStx rs -> FinalStx rs +data Stx s f x + = LookStx (s -> Stx s f x) + | ResultStx x (Stx s f x) + | FinalStx (f (x,s)) -- Parsor instances instance Functor f => Functor (Parsor s t f a) where @@ -406,3 +309,120 @@ instance (Comonad f, Applicative f, Monoid s, BackusNaurForm t) => BackusNaurForm (Grammor s t f a b) where rule name = Grammor . fmap (fmap (rule name)) . runGrammor ruleRec name = grammor . ruleRec name . dimap grammor evalGrammor + +-- Reador instances +deriving newtype instance Functor (Reador s f a) +deriving newtype instance Applicative (Reador s f a) +deriving newtype instance Monad (Reador s f a) +deriving newtype instance (Alternative m, Monad m) + => Alternative (Reador s m a) +deriving newtype instance (Alternative m, Monad m) + => MonadPlus (Reador s m a) +deriving newtype instance (Alternative m, Monad m) + => MonadReader s (Reador s m a) +deriving newtype instance (Alternative m, Monad m) + => MonadState s (Reador s m a) +instance (Alternative m, Monad m, Filterable m) + => Filterable (Reador s m a) where + mapMaybe f (Reador p) = + Reador (lift (mapMaybe f (lowerCodensity p))) +instance Profunctor (Reador s f) where + dimap _ f (Reador p) = Reador (fmap f p) +instance Choice (Reador s f) where + left' (Reador p) = Reador (fmap Left p) + right' (Reador p) = Reador (fmap Right p) +instance (Alternative f, Monad f) => Distributor (Reador s f) +instance (Alternative f, Monad f) + => Alternator (Reador s f) where + alternate = \case + Left (Reador p) -> Reador (fmap Left p) + Right (Reador p) -> Reador (fmap Right p) +instance (Alternative f, Monad f, Filterable f) + => Cochoice (Reador s f) where + unleft (Reador p) + = Reador . lift + . mapMaybe (either Just (const Nothing)) + . lowerCodensity $ p + unright (Reador p) + = Reador . lift + . mapMaybe (either (const Nothing) Just) + . lowerCodensity $ p +instance (Alternative f, Monad f, Filterable f) + => Filtrator (Reador s f) where + filtrate (Reador p) = + ( Reador . lift + . mapMaybe (either Just (const Nothing)) + . lowerCodensity $ p + + , Reador . lift + . mapMaybe (either (const Nothing) Just) + . lowerCodensity $ p + ) +instance (Alternative m, Monad m) => Monadic m (Reador s) where + liftP m = Reador (lift (LookStx (\s -> FinalStx ((,s) <$> m)))) +instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) + => Tokenized (Reador s m a a) where + type Token (Reador s m a a) = a + anyToken = do + s <- get + case uncons s of + Nothing -> empty + Just (c,cs) -> put cs >> return c +instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) + => Equator a a (Reador s m) +instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) + => TerminalSymbol (Reador s m () ()) where + type Alphabet (Reador s m () ()) = Item s +instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) + => IsString (Reador s m () ()) where + fromString = terminal +instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) + => IsString (Reador s m s s) where + fromString = tokens +instance BackusNaurForm (Reador s f a b) + +-- Stx instances +runStx :: Alternative f => Stx s f a -> s -> f (a,s) +runStx (LookStx f) s = runStx (f s) s +runStx (ResultStx x p) s = pure (x,s) <|> runStx p s +runStx (FinalStx rs) _ = rs +deriving stock instance Functor f => Functor (Stx s f) +instance (Alternative f, Monad f) => Applicative (Stx s f) where + pure x = ResultStx x empty + (<*>) = ap +instance (Alternative f, Monad f) => MonadPlus (Stx s f) +instance (Alternative f, Monad f) => Monad (Stx s f) where + LookStx f >>= k = LookStx (\s -> f s >>= k) + ResultStx x p >>= k = k x <|> (p >>= k) + FinalStx rs >>= k = FinalStx $ do + (x,s) <- rs + runStx (k x) s +instance (Alternative f, Monad f) => Alternative (Stx s f) where + empty = FinalStx empty + -- results are delivered as soon as possible + ResultStx x p <|> q = ResultStx x (p <|> q) + p <|> ResultStx x q = ResultStx x (p <|> q) + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + FinalStx rs <|> FinalStx ts = FinalStx (rs <|> ts) + FinalStx rs <|> LookStx f = + LookStx (\s -> FinalStx (rs <|> runStx (f s) s)) + LookStx f <|> FinalStx rs = + LookStx (\s -> FinalStx (runStx (f s) s <|> rs)) + -- two looks are combined (=optimization) + LookStx f <|> LookStx g = LookStx (\s -> f s <|> g s) +instance (Alternative f, Monad f, Filterable f) + => Filterable (Stx s f) where + mapMaybe f = \case + LookStx g -> LookStx (mapMaybe f . g) + ResultStx a stx -> case f a of + Nothing -> mapMaybe f stx + Just b -> ResultStx b (mapMaybe f stx) + FinalStx r -> FinalStx (mapMaybe (\(a,s) -> (,s) <$> f a) r) +instance (Alternative m, Monad m) => MonadReader s (Stx s m) where + ask = LookStx pure + local f = \case + LookStx g -> LookStx (g . f) + ResultStx a stx -> ResultStx a stx + FinalStx rs -> FinalStx rs From 07db4cac9b2e9b07efde3000fb16972b0805016f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 1 Nov 2025 21:58:00 -0700 Subject: [PATCH 099/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index bcc6299..41d1629 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -11,6 +11,7 @@ module Data.Profunctor.Grammar , evalGrammor -- * Reador , Reador (..) + , runReador ) where import Control.Applicative @@ -61,6 +62,8 @@ data Stx s f x = LookStx (s -> Stx s f x) | ResultStx x (Stx s f x) | FinalStx (f (x,s)) +runReador :: (Alternative m, Monad m) => Reador s m a b -> s -> m (b,s) +runReador (Reador p) = runStx (lowerCodensity p) -- Parsor instances instance Functor f => Functor (Parsor s t f a) where From 8d8e7b1990bc15ec5d70a76021e0b17863186e34 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 1 Nov 2025 22:29:35 -0700 Subject: [PATCH 100/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 41d1629..251c513 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -406,9 +406,8 @@ instance (Alternative f, Monad f) => Alternative (Stx s f) where ResultStx x p <|> q = ResultStx x (p <|> q) p <|> ResultStx x q = ResultStx x (p <|> q) -- two finals are combined - -- final + look becomes one look and one final (=optimization) - -- final + sthg else becomes one look and one final FinalStx rs <|> FinalStx ts = FinalStx (rs <|> ts) + -- final + look becomes one look and one final (=optimization) FinalStx rs <|> LookStx f = LookStx (\s -> FinalStx (rs <|> runStx (f s) s)) LookStx f <|> FinalStx rs = From ff5cf40c2001bc4e6e516ee922263f8137b66454 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 1 Nov 2025 22:31:46 -0700 Subject: [PATCH 101/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 251c513..0c1e9d5 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -58,12 +58,17 @@ evalGrammor :: (Monoid s, Comonad f) => Grammor s t f a b -> t evalGrammor = extract . extract . runGrammor newtype Reador s f a b = Reador (Codensity (Stx s f) b) +runReador :: (Alternative m, Monad m) => Reador s m a b -> s -> m (b,s) +runReador (Reador p) = runStx (lowerCodensity p) + data Stx s f x = LookStx (s -> Stx s f x) | ResultStx x (Stx s f x) | FinalStx (f (x,s)) -runReador :: (Alternative m, Monad m) => Reador s m a b -> s -> m (b,s) -runReador (Reador p) = runStx (lowerCodensity p) +runStx :: Alternative f => Stx s f a -> s -> f (a,s) +runStx (LookStx f) s = runStx (f s) s +runStx (ResultStx x p) s = pure (x,s) <|> runStx p s +runStx (FinalStx rs) _ = rs -- Parsor instances instance Functor f => Functor (Parsor s t f a) where @@ -385,10 +390,6 @@ instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) instance BackusNaurForm (Reador s f a b) -- Stx instances -runStx :: Alternative f => Stx s f a -> s -> f (a,s) -runStx (LookStx f) s = runStx (f s) s -runStx (ResultStx x p) s = pure (x,s) <|> runStx p s -runStx (FinalStx rs) _ = rs deriving stock instance Functor f => Functor (Stx s f) instance (Alternative f, Monad f) => Applicative (Stx s f) where pure x = ResultStx x empty From f4d648e4d4bb880997ce20d7fb92412acc235636 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 2 Nov 2025 00:10:07 -0700 Subject: [PATCH 102/282] Update Context.hs --- src/Control/Lens/Grammar/Context.hs | 72 +++-------------------------- 1 file changed, 7 insertions(+), 65 deletions(-) diff --git a/src/Control/Lens/Grammar/Context.hs b/src/Control/Lens/Grammar/Context.hs index c33a44c..a58ce1a 100644 --- a/src/Control/Lens/Grammar/Context.hs +++ b/src/Control/Lens/Grammar/Context.hs @@ -1,72 +1,14 @@ module Control.Lens.Grammar.Context - ( Reador (..) - , Showor (..) - , Subtext (..) - , Context (..) + ( eof + , ask ) where import Control.Applicative +import Control.Lens import Control.Monad -import Control.Monad.Codensity import Control.Monad.Reader -import Control.Monad.State --- import Control.Monad.Trans --- import Control.Monad.Trans.Indexed --- import Data.Profunctor -newtype Reador s t m a b = Reador (Codensity (Subtext s t m) a) - -newtype Showor s t w a b = Showor (Codensity (Context s t w a) b) - -data Subtext s t m a - = Get (s -> Subtext s t m a) - | Put (m (a,t)) - | Subtext a (Subtext s t m a) - -data Context s t w a b - = Ask (a -> Context s t w a b) - | Local (w (b, s -> t)) - | Context b (Context s t w a b) - --- instances - --- ReadIx -deriving stock instance Functor m => Functor (Subtext s t m) -instance (MonadPlus m) => Applicative (Subtext s s m) where - pure x = Subtext x (Put empty) - (<*>) = ap -instance (MonadPlus m) => MonadPlus (Subtext s s m) -instance (MonadPlus m) => Monad (Subtext s s m) where - (Get f) >>= k = Get (\s -> f s >>= k) - (Subtext x p) >>= k = k x <|> (p >>= k) - (Put r) >>= k = Put (r >>= \(x,s) -> run (k x) s) -instance (MonadPlus m) => Alternative (Subtext s s m) where - empty = Put empty - -- most common case: two gets are combined - -- results are delivered as soon as possible - Subtext x p <|> q = Subtext x (p <|> q) - p <|> Subtext x q = Subtext x (p <|> q) - -- two finals are combined - -- final + look becomes one look and one final (=optimization) - -- final + sthg else becomes one look and one final - Put r <|> Put t = Put (r <|> t) - Put r <|> Get f = Get (\s -> Put (r <|> run (f s) s)) - Get f <|> Put r = Get (\s -> Put (run (f s) s <|> r)) - -- two looks are combined (=optimization) - -- look + sthg else floats upwards - Get f <|> Get g = Get (\s -> f s <|> g s) -run :: (Alternative f) => Subtext s s f a -> s -> f (a, s) -run (Get f) s = run (f s) s -run (Subtext x p) s = pure (x,s) <|> run p s -run (Put rs) _ = rs -instance (MonadPlus m) => MonadReader s (Subtext s s m) where - ask = get - local f subtext = do - s <- get - modify f - a <- subtext - put s - return a -instance (MonadPlus m) => MonadState s (Subtext s s m) where - get = Get pure - put s = Put (pure (pure s)) +eof :: (AsEmpty s, MonadReader s m, Alternative m) => m () +eof = do + s <- ask + when (isn't _Empty s) empty From 12741f0afe35a5b22e30377ec522d66dcc346592 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 2 Nov 2025 11:40:41 -0800 Subject: [PATCH 103/282] - MonadPlus --- src/Control/Lens/Grammar.hs | 6 +-- src/Data/Profunctor/Grammar.hs | 96 ++++++++++++++++++++++------------ 2 files changed, 66 insertions(+), 36 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index b2790f9..5df7075 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -90,9 +90,9 @@ type Grammatical token p = type Contextual token m p = ( Grammatical token (p m) , Monadic m p - , forall a. MonadPlus (p m a) , Filterable m - , MonadPlus m + , Alternative m + , Monad m ) prismGrammar :: (Monoidal p, Choice p) => Prism' a () -> p a a @@ -112,7 +112,7 @@ grammarrOptic grammarrOptic = dimap (rmap extract) (rmap pure) genShowS - :: (Filterable m, MonadPlus m) + :: (Filterable m, Alternative m, Monad m) => CtxGrammar Char a -> a -> m ShowS genShowS = evalPrintor diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 0c1e9d5..232441e 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -134,20 +134,30 @@ instance Filterable f => Filtrator (Parsor s t f) where ) where leftMay (e, str) = either (\b -> Just (b, str)) (\_ -> Nothing) e rightMay (e, str) = either (\_ -> Nothing) (\b -> Just (b, str)) e -instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => Tokenized (Parsor s s m a a) where +instance + ( Categorized a, a ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => Tokenized (Parsor s s m a a) where type Token (Parsor s s m a a) = a anyToken = Parsor (maybe empty pure . uncons) -instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => Equator a a (Parsor s s m) -instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => TerminalSymbol (Parsor s s m () ()) where +instance + ( Categorized a, a ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => Equator a a (Parsor s s m) +instance + ( Categorized a, a ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => TerminalSymbol (Parsor s s m () ()) where type Alphabet (Parsor s s m () ()) = Item s -instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) - => IsString (Parsor s s m () ()) where +instance + ( Char ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => IsString (Parsor s s m () ()) where fromString = terminal -instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) - => IsString (Parsor s s m s s) where +instance + ( Char ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => IsString (Parsor s s m s s) where fromString = tokens instance BackusNaurForm (Parsor s t m a b) @@ -229,28 +239,38 @@ instance Monad f => Arrow (Printor s s f) where (***) = (>*<) first = first' second = second' -instance MonadPlus f => ArrowZero (Printor s s f) where +instance (Alternative f, Monad f) => ArrowZero (Printor s s f) where zeroArrow = empty -instance MonadPlus f => ArrowPlus (Printor s s f) where +instance (Alternative f, Monad f) => ArrowPlus (Printor s s f) where (<+>) = (<|>) -instance MonadPlus f => ArrowChoice (Printor s s f) where +instance (Alternative f, Monad f) => ArrowChoice (Printor s s f) where (+++) = (>+<) left = left' right = right' -instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => Tokenized (Printor s s m a a) where +instance + ( Categorized a, a ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => Tokenized (Printor s s m a a) where type Token (Printor s s m a a) = a anyToken = Printor (\b -> pure (b, cons b)) -instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => Equator a a (Printor s s m) -instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => TerminalSymbol (Printor s s m () ()) where +instance + ( Categorized a, a ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => Equator a a (Printor s s m) +instance + ( Categorized a, a ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => TerminalSymbol (Printor s s m () ()) where type Alphabet (Printor s s m () ()) = Item s -instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) - => IsString (Printor s s m () ()) where +instance + ( Char ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => IsString (Printor s s m () ()) where fromString = terminal -instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) - => IsString (Printor s s m s s) where +instance + ( Char ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => IsString (Printor s s m s s) where fromString = tokens instance BackusNaurForm (Printor s t m a b) @@ -368,24 +388,34 @@ instance (Alternative f, Monad f, Filterable f) ) instance (Alternative m, Monad m) => Monadic m (Reador s) where liftP m = Reador (lift (LookStx (\s -> FinalStx ((,s) <$> m)))) -instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => Tokenized (Reador s m a a) where +instance + ( Categorized a, a ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => Tokenized (Reador s m a a) where type Token (Reador s m a a) = a anyToken = do s <- get case uncons s of Nothing -> empty Just (c,cs) -> put cs >> return c -instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => Equator a a (Reador s m) -instance (Categorized a, a ~ Item s, IsStream s, Filterable m, MonadPlus m) - => TerminalSymbol (Reador s m () ()) where +instance + ( Categorized a, a ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => Equator a a (Reador s m) +instance + ( Categorized a, a ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => TerminalSymbol (Reador s m () ()) where type Alphabet (Reador s m () ()) = Item s -instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) - => IsString (Reador s m () ()) where +instance + ( Char ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => IsString (Reador s m () ()) where fromString = terminal -instance (Char ~ Item s, IsStream s, Filterable m, MonadPlus m) - => IsString (Reador s m s s) where +instance + ( Char ~ Item s, IsStream s + , Filterable m, Alternative m, Monad m + ) => IsString (Reador s m s s) where fromString = tokens instance BackusNaurForm (Reador s f a b) From 3c1b16f8175d00fbc94c0379ae8193049b376454 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 5 Nov 2025 18:06:23 -0800 Subject: [PATCH 104/282] Test --- distributors.cabal | 1 + src/Control/Lens/Grammar/Test.hs | 162 +++++++++++++++++++++++++++++++ 2 files changed, 163 insertions(+) create mode 100644 src/Control/Lens/Grammar/Test.hs diff --git a/distributors.cabal b/distributors.cabal index 7d97697..b58f891 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -36,6 +36,7 @@ library Control.Lens.Grammar.Kleene Control.Lens.Grammar.Stream Control.Lens.Grammar.Symbol + Control.Lens.Grammar.Test Control.Lens.Grammar.Token Control.Lens.Grate Control.Lens.Internal.Equator diff --git a/src/Control/Lens/Grammar/Test.hs b/src/Control/Lens/Grammar/Test.hs new file mode 100644 index 0000000..3f79f23 --- /dev/null +++ b/src/Control/Lens/Grammar/Test.hs @@ -0,0 +1,162 @@ +module Control.Lens.Grammar.Test + ( BooleanAlgebra (..) + , TestAlgebra (..) + , TokenTest (..) + , RegExam (..) + , CategoryExam (..) + ) where + +import Control.Lens.Grammar.Token +import Data.Foldable (foldl') +import Data.Function (on) +import Data.Monoid +import Data.Set (Set) +import qualified Data.Set as Set + +class BooleanAlgebra b where + falseB, trueB :: b + notB :: b -> b + (>&&<), (>||<) :: b -> b -> b + default falseB + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) + => b + default trueB + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) + => b + default notB + :: (b ~ f bool, BooleanAlgebra bool, Functor f) + => b -> b + default (>||<) + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) + => b -> b -> b + default (>&&<) + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) + => b -> b -> b + trueB = pure trueB + falseB = pure falseB + notB = fmap notB + (>&&<) = liftA2 (>&&<) + (>||<) = liftA2 (>||<) + +class BooleanAlgebra (Test alg) => TestAlgebra alg where + type Test alg + test :: Test alg -> alg + +newtype TokenTest token = TokenTest (RegExam token (TokenTest token)) + +data RegExam token alg + = Fail + | Pass + | OneOf (Set token) + | NotOneOf (Set token) (CategoryExam token) + | Alternate alg alg + +data CategoryExam token + = AsIn (Categorize token) + | NotAsIn (Set (Categorize token)) + +--instances +instance BooleanAlgebra Bool where + falseB = False + trueB = True + notB = not + (>&&<) = (&&) + (>||<) = (||) +instance BooleanAlgebra (x -> Bool) +instance (Applicative f, BooleanAlgebra bool) + => BooleanAlgebra (Ap f bool) +deriving newtype instance + (Categorized token, Ord token, Ord (Categorize token)) + => BooleanAlgebra (TokenTest token) +instance (Categorized token, Ord token, Ord (Categorize token)) + => BooleanAlgebra (RegExam token (TokenTest token)) where + + falseB = Fail + trueB = Pass + + notB Fail = Pass + notB Pass = Fail + notB (Alternate (TokenTest x) (TokenTest y)) = x >&&< y + notB (OneOf xs) = NotOneOf xs (NotAsIn Set.empty) + notB (NotOneOf xs (AsIn y)) = + (Alternate `on` TokenTest) + (OneOf xs) + (NotOneOf Set.empty (NotAsIn (Set.singleton y))) + notB (NotOneOf xs (NotAsIn ys)) = + foldl' + (Alternate `on` TokenTest) + (OneOf xs) + (Set.map (NotOneOf Set.empty . AsIn) ys) + + _ >&&< Fail = Fail + Fail >&&< _ = Fail + x >&&< Pass = x + Pass >&&< y = y + x >&&< Alternate (TokenTest y) (TokenTest z) = (x >&&< y) >||< (x >&&< z) + Alternate (TokenTest x) (TokenTest y) >&&< z = (x >&&< z) >||< (y >&&< z) + OneOf xs >&&< OneOf ys = OneOf (Set.intersection xs ys) + OneOf xs >&&< NotOneOf ys (AsIn z) = OneOf + (Set.filter (\x -> categorize x == z) (Set.difference xs ys)) + NotOneOf xs (AsIn y) >&&< OneOf zs = OneOf + (Set.filter (\z -> categorize z == y) (Set.difference zs xs)) + OneOf xs >&&< NotOneOf ys (NotAsIn zs) = OneOf + (Set.filter (\x -> notElem (categorize x) zs) (Set.difference xs ys)) + NotOneOf xs (NotAsIn ys) >&&< OneOf zs = OneOf + (Set.filter (\z -> notElem (categorize z) ys) (Set.difference zs xs)) + NotOneOf xs (AsIn y) >&&< NotOneOf ws (AsIn z) = + if y /= z then Fail else + NotOneOf (Set.filter (\x -> categorize x == y) (Set.union xs ws)) (AsIn y) + NotOneOf xs (AsIn y) >&&< NotOneOf ws (NotAsIn zs) = + if elem y zs then Fail else + NotOneOf (Set.filter (\x -> categorize x == y) (Set.union xs ws)) (AsIn y) + NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (AsIn z) = + if elem z ys then Fail else + NotOneOf (Set.filter (\x -> categorize x == z) (Set.union xs ws)) (AsIn z) + NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (NotAsIn zs) = + NotOneOf (Set.filter (\x -> notElem (categorize x) yzs) xws) (NotAsIn yzs) + where + xws = Set.union xs ws + yzs = Set.union ys zs + + x >||< Fail = x + Fail >||< y = y + _ >||< Pass = Pass + Pass >||< _ = Pass + x >||< Alternate y z = Alternate (TokenTest x) (TokenTest (Alternate y z)) + Alternate x y >||< z = Alternate (TokenTest (Alternate x y)) (TokenTest z) + OneOf xs >||< OneOf ys = OneOf (Set.union xs ys) + OneOf xs >||< NotOneOf ys z = + Alternate (TokenTest (OneOf xs)) (TokenTest (NotOneOf ys z)) + NotOneOf xs y >||< OneOf zs = + Alternate (TokenTest (NotOneOf xs y)) (TokenTest (OneOf zs)) + NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (NotAsIn zs) = + NotOneOf (Set.intersection xs ws) (NotAsIn (Set.intersection ys zs)) + NotOneOf xs (AsIn y) >||< NotOneOf ws (AsIn z) = + if y == z then NotOneOf (Set.intersection xs ws) (AsIn y) + else Alternate + (TokenTest (NotOneOf xs (AsIn y))) + (TokenTest (NotOneOf ws (AsIn z))) + NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (AsIn z) = Alternate + (TokenTest (NotOneOf xs (NotAsIn ys))) + (TokenTest (NotOneOf ws (AsIn z))) + NotOneOf xs (AsIn y) >||< NotOneOf ws (NotAsIn zs) = Alternate + (TokenTest (NotOneOf xs (AsIn y))) + (TokenTest (NotOneOf ws (NotAsIn zs))) + +deriving stock instance Functor (RegExam token) +deriving stock instance Foldable (RegExam token) +deriving stock instance Traversable (RegExam token) +deriving stock instance (Categorized token, Eq alg) => Eq (RegExam token alg) +deriving stock instance + (Categorized token, Ord token, Ord (Categorize token), Ord alg) + => Ord (RegExam token alg) + +deriving stock instance Categorized token => Eq (CategoryExam token) +deriving stock instance + (Categorized token, Ord token, Ord (Categorize token)) + => Ord (CategoryExam token) + +deriving newtype instance Categorized token => Eq (TokenTest token) +deriving newtype instance + (Categorized token, Ord token, Ord (Categorize token)) + => Ord (TokenTest token) From fd61d0b4d40a4e2ecc1237cd20bcbe113c7afea6 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 5 Nov 2025 18:23:45 -0800 Subject: [PATCH 105/282] golfing --- src/Control/Lens/Grammar/Kleene.hs | 4 +-- src/Control/Lens/Grammar/Test.hs | 48 +++++++++++++----------------- src/Control/Lens/Grammar/Token.hs | 2 +- 3 files changed, 23 insertions(+), 31 deletions(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 48e0a1e..9379710 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -38,9 +38,7 @@ data RegEx token | AsIn (Categorize token) | NotAsIn (Categorize token) deriving stock instance Categorized token => Eq (RegEx token) -deriving stock instance - (Categorized token, Ord token, Ord (Categorize token)) - => Ord (RegEx token) +deriving stock instance Categorized token => Ord (RegEx token) deriving stock instance (Categorized token, Read token, Read (Categorize token)) => Read (RegEx token) diff --git a/src/Control/Lens/Grammar/Test.hs b/src/Control/Lens/Grammar/Test.hs index 3f79f23..95e2bdb 100644 --- a/src/Control/Lens/Grammar/Test.hs +++ b/src/Control/Lens/Grammar/Test.hs @@ -65,15 +65,12 @@ instance BooleanAlgebra Bool where instance BooleanAlgebra (x -> Bool) instance (Applicative f, BooleanAlgebra bool) => BooleanAlgebra (Ap f bool) -deriving newtype instance - (Categorized token, Ord token, Ord (Categorize token)) +deriving newtype instance Categorized token => BooleanAlgebra (TokenTest token) -instance (Categorized token, Ord token, Ord (Categorize token)) +instance Categorized token => BooleanAlgebra (RegExam token (TokenTest token)) where - falseB = Fail trueB = Pass - notB Fail = Pass notB Pass = Fail notB (Alternate (TokenTest x) (TokenTest y)) = x >&&< y @@ -87,7 +84,6 @@ instance (Categorized token, Ord token, Ord (Categorize token)) (Alternate `on` TokenTest) (OneOf xs) (Set.map (NotOneOf Set.empty . AsIn) ys) - _ >&&< Fail = Fail Fail >&&< _ = Fail x >&&< Pass = x @@ -104,20 +100,25 @@ instance (Categorized token, Ord token, Ord (Categorize token)) NotOneOf xs (NotAsIn ys) >&&< OneOf zs = OneOf (Set.filter (\z -> notElem (categorize z) ys) (Set.difference zs xs)) NotOneOf xs (AsIn y) >&&< NotOneOf ws (AsIn z) = - if y /= z then Fail else - NotOneOf (Set.filter (\x -> categorize x == y) (Set.union xs ws)) (AsIn y) + if y /= z then Fail else NotOneOf + (Set.filter (\x -> categorize x == y) + (Set.union xs ws)) (AsIn y) NotOneOf xs (AsIn y) >&&< NotOneOf ws (NotAsIn zs) = - if elem y zs then Fail else - NotOneOf (Set.filter (\x -> categorize x == y) (Set.union xs ws)) (AsIn y) + if elem y zs then Fail else NotOneOf + (Set.filter (\x -> categorize x == y) + (Set.union xs ws)) (AsIn y) NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (AsIn z) = - if elem z ys then Fail else - NotOneOf (Set.filter (\x -> categorize x == z) (Set.union xs ws)) (AsIn z) + if elem z ys then Fail else NotOneOf + (Set.filter (\x -> categorize x == z) (Set.union xs ws)) + (AsIn z) NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (NotAsIn zs) = - NotOneOf (Set.filter (\x -> notElem (categorize x) yzs) xws) (NotAsIn yzs) - where + let xws = Set.union xs ws yzs = Set.union ys zs - + in + NotOneOf + (Set.filter (\x -> notElem (categorize x) yzs) xws) + (NotAsIn yzs) x >||< Fail = x Fail >||< y = y _ >||< Pass = Pass @@ -142,21 +143,14 @@ instance (Categorized token, Ord token, Ord (Categorize token)) NotOneOf xs (AsIn y) >||< NotOneOf ws (NotAsIn zs) = Alternate (TokenTest (NotOneOf xs (AsIn y))) (TokenTest (NotOneOf ws (NotAsIn zs))) - deriving stock instance Functor (RegExam token) deriving stock instance Foldable (RegExam token) deriving stock instance Traversable (RegExam token) -deriving stock instance (Categorized token, Eq alg) => Eq (RegExam token alg) -deriving stock instance - (Categorized token, Ord token, Ord (Categorize token), Ord alg) +deriving stock instance (Categorized token, Eq alg) + => Eq (RegExam token alg) +deriving stock instance (Categorized token, Ord alg) => Ord (RegExam token alg) - deriving stock instance Categorized token => Eq (CategoryExam token) -deriving stock instance - (Categorized token, Ord token, Ord (Categorize token)) - => Ord (CategoryExam token) - +deriving stock instance Categorized token => Ord (CategoryExam token) deriving newtype instance Categorized token => Eq (TokenTest token) -deriving newtype instance - (Categorized token, Ord token, Ord (Categorize token)) - => Ord (TokenTest token) +deriving newtype instance Categorized token => Ord (TokenTest token) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 6c5bd0a..738bd08 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -25,7 +25,7 @@ import Data.Profunctor.Distributor import Data.Profunctor.Monoidal import Data.Word -class (Eq token, Eq (Categorize token)) => Categorized token where +class (Ord token, Ord (Categorize token)) => Categorized token where type Categorize token type Categorize token = () categorize :: token -> Categorize token From 04a2a4df784008dc4a88147f655e29578077b748 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 5 Nov 2025 19:09:46 -0800 Subject: [PATCH 106/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 76 ++++++++++++++++++------------------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 5df7075..78a956b 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -133,7 +133,7 @@ regexGrammar = dimap runRegExStr RegExStr $ ruleRec "regex" altG seqG rex = rule "sequence" $ chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) exprG rex = rule "expression" $ choiceP - [ _Terminal >?< someP charG + [ _Terminal >? someP charG , _KleeneOpt >? atomG rex *< terminal "?" , _KleeneStar >? atomG rex *< terminal "*" , _KleenePlus >? atomG rex *< terminal "+" @@ -141,12 +141,12 @@ regexGrammar = dimap runRegExStr RegExStr $ ruleRec "regex" altG ] atomG rex = rule "atom" $ choiceP [ nonterminalG - , _Terminal >?< charG >:< pure "" - , _AnyToken >?< terminal "." - , _OneOf >?< terminal "[" >* someP charG *< terminal "]" - , _NotOneOf >?< terminal "[^" >* someP charG *< terminal "]" - , _AsIn >?< terminal "\\p{" >* categoryG *< terminal "}" - , _NotAsIn >?< terminal "\\P{" >* categoryG *< terminal "}" + , _Terminal >? charG >:< pure "" + , _AnyToken >? terminal "." + , _OneOf >? terminal "[" >* someP charG *< terminal "]" + , _NotOneOf >? terminal "[^" >* someP charG *< terminal "]" + , _AsIn >? terminal "\\p{" >* categoryG *< terminal "}" + , _NotAsIn >? terminal "\\P{" >* categoryG *< terminal "}" , terminal "(" >* rex *< terminal ")" ] charG = rule "char" $ escapes @@ -155,39 +155,39 @@ regexGrammar = dimap runRegExStr RegExStr $ ruleRec "regex" altG , ("\t", \_ -> (terminal "\\t" <|> terminal "\t") >* pure '\t') ] categoryG = rule "category" $ choiceP - [ _LowercaseLetter >?< terminal "Ll" - , _UppercaseLetter >?< terminal "Lu" - , _TitlecaseLetter >?< terminal "Lt" - , _ModifierLetter >?< terminal "Lm" - , _OtherLetter >?< terminal "Lo" - , _NonSpacingMark >?< terminal "Mn" - , _SpacingCombiningMark >?< terminal "Mc" - , _EnclosingMark >?< terminal "Me" - , _DecimalNumber >?< terminal "Nd" - , _LetterNumber >?< terminal "Nl" - , _OtherNumber >?< terminal "No" - , _ConnectorPunctuation >?< terminal "Pc" - , _DashPunctuation >?< terminal "Pd" - , _OpenPunctuation >?< terminal "Ps" - , _ClosePunctuation >?< terminal "Pe" - , _InitialQuote >?< terminal "Pi" - , _FinalQuote >?< terminal "Pf" - , _OtherPunctuation >?< terminal "Po" - , _MathSymbol >?< terminal "Sm" - , _CurrencySymbol >?< terminal "Sc" - , _ModifierSymbol >?< terminal "Sk" - , _OtherSymbol >?< terminal "So" - , _Space >?< terminal "Zs" - , _LineSeparator >?< terminal "Zl" - , _ParagraphSeparator >?< terminal "Zp" - , _Control >?< terminal "Cc" - , _Format >?< terminal "Cf" - , _Surrogate >?< terminal "Cs" - , _PrivateUse >?< terminal "Co" - , _NotAssigned >?< terminal "Cn" + [ _LowercaseLetter >? terminal "Ll" + , _UppercaseLetter >? terminal "Lu" + , _TitlecaseLetter >? terminal "Lt" + , _ModifierLetter >? terminal "Lm" + , _OtherLetter >? terminal "Lo" + , _NonSpacingMark >? terminal "Mn" + , _SpacingCombiningMark >? terminal "Mc" + , _EnclosingMark >? terminal "Me" + , _DecimalNumber >? terminal "Nd" + , _LetterNumber >? terminal "Nl" + , _OtherNumber >? terminal "No" + , _ConnectorPunctuation >? terminal "Pc" + , _DashPunctuation >? terminal "Pd" + , _OpenPunctuation >? terminal "Ps" + , _ClosePunctuation >? terminal "Pe" + , _InitialQuote >? terminal "Pi" + , _FinalQuote >? terminal "Pf" + , _OtherPunctuation >? terminal "Po" + , _MathSymbol >? terminal "Sm" + , _CurrencySymbol >? terminal "Sc" + , _ModifierSymbol >? terminal "Sk" + , _OtherSymbol >? terminal "So" + , _Space >? terminal "Zs" + , _LineSeparator >? terminal "Zl" + , _ParagraphSeparator >? terminal "Zp" + , _Control >? terminal "Cc" + , _Format >? terminal "Cf" + , _Surrogate >? terminal "Cs" + , _PrivateUse >? terminal "Co" + , _NotAssigned >? terminal "Cn" ] nonterminalG = rule "nonterminal" $ terminal "\\q" >* choiceP - [ _NonTerminal >?< terminal "{" >* manyP charG *< terminal "}" + [ _NonTerminal >? terminal "{" >* manyP charG *< terminal "}" , prismGrammar _Fail ] From f86fd1caed3d80b0f1b93cecc6115685b216abdf Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 11 Nov 2025 15:01:53 -0800 Subject: [PATCH 107/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index c9e1ed4..9e5fa2c 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -22,6 +22,7 @@ module Data.Profunctor.Monadic ) where import Control.Category +import Control.Arrow import Control.Monad import Control.Monad.State import Control.Monad.Trans.Indexed @@ -32,12 +33,14 @@ class ( Profunctor (p m) , forall x. Monad (p m x) ) => Monadic m p where - joinP :: p m a (m b) -> p m a b joinP = join . fmap liftP - liftP :: m b -> p m a b liftP = joinP . return +instance Monad m => Monadic m Kleisli where + liftP = Kleisli . return +instance Monad m => Monadic m Star where + liftP = Star . return class ( forall i j. Profunctor (p i j m) From 14f3da8f0456b019d8c55733f2d15ea4f987f91b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 11 Nov 2025 15:09:36 -0800 Subject: [PATCH 108/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 9e5fa2c..73b5a63 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -22,6 +22,7 @@ module Data.Profunctor.Monadic ) where import Control.Category +import Control.Comonad import Control.Arrow import Control.Monad import Control.Monad.State @@ -41,6 +42,8 @@ instance Monad m => Monadic m Kleisli where liftP = Kleisli . return instance Monad m => Monadic m Star where liftP = Star . return +instance Comonad w => Monadic w Costar where + liftP = Costar . return . extract class ( forall i j. Profunctor (p i j m) From 7f57c36af6bfe286867f9eb4c1e831a324a48bbb Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 11 Nov 2025 15:12:55 -0800 Subject: [PATCH 109/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 73b5a63..b98daf7 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -54,16 +54,16 @@ class class (forall i j. Profunctor (p i j f)) => Tetradic f p where - tetramap - :: (h -> i) -> (j -> k) - -> (s -> a) -> (b -> t) - -> p i j f a b -> p h k f s t - tetramap f1 f2 f3 f4 = dimapT f1 f2 . dimap f3 f4 + tetramap + :: (h -> i) -> (j -> k) + -> (s -> a) -> (b -> t) + -> p i j f a b -> p h k f s t + tetramap f1 f2 f3 f4 = dimapT f1 f2 . dimap f3 f4 - dimapT - :: (h -> i) -> (j -> k) - -> p i j f a b -> p h k f a b - dimapT f1 f2 = tetramap f1 f2 id id + dimapT + :: (h -> i) -> (j -> k) + -> p i j f a b -> p h k f a b + dimapT f1 f2 = tetramap f1 f2 id id newtype WrappedMonadic p m a b = WrapMonadic {unwrapMonadic :: p m a (m b)} instance (Monadic m p, Monad m) => Functor (WrappedMonadic p m a) where From ec40af147b4261d899be473979ed3fe608818302 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 11 Nov 2025 15:14:07 -0800 Subject: [PATCH 110/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index b98daf7..88447b6 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -47,7 +47,7 @@ instance Comonad w => Monadic w Costar where class ( forall i j. Profunctor (p i j m) - , forall i j a. Functor (p i j m a) + , forall i j x. Functor (p i j m x) , forall i. Monadic m (p i i) ) => Polyadic m p where composeP :: p i j m a (p j k m a b) -> p i k m a b From d45464612efc9e64590da76402916917006e9d75 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 15 Nov 2025 14:04:40 -0800 Subject: [PATCH 111/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 139 --------------------------------- 1 file changed, 139 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 232441e..e6a5560 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -9,16 +9,12 @@ module Data.Profunctor.Grammar , Grammor (..) , grammor , evalGrammor - -- * Reador - , Reador (..) - , runReador ) where import Control.Applicative import Control.Arrow import Control.Category import Control.Comonad -import Control.Monad.Codensity import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State @@ -57,19 +53,6 @@ grammor = Grammor . pure . pure evalGrammor :: (Monoid s, Comonad f) => Grammor s t f a b -> t evalGrammor = extract . extract . runGrammor -newtype Reador s f a b = Reador (Codensity (Stx s f) b) -runReador :: (Alternative m, Monad m) => Reador s m a b -> s -> m (b,s) -runReador (Reador p) = runStx (lowerCodensity p) - -data Stx s f x - = LookStx (s -> Stx s f x) - | ResultStx x (Stx s f x) - | FinalStx (f (x,s)) -runStx :: Alternative f => Stx s f a -> s -> f (a,s) -runStx (LookStx f) s = runStx (f s) s -runStx (ResultStx x p) s = pure (x,s) <|> runStx p s -runStx (FinalStx rs) _ = rs - -- Parsor instances instance Functor f => Functor (Parsor s t f a) where fmap f = Parsor . fmap (fmap (first' f)) . runParsor @@ -337,125 +320,3 @@ instance (Comonad f, Applicative f, Monoid s, BackusNaurForm t) => BackusNaurForm (Grammor s t f a b) where rule name = Grammor . fmap (fmap (rule name)) . runGrammor ruleRec name = grammor . ruleRec name . dimap grammor evalGrammor - --- Reador instances -deriving newtype instance Functor (Reador s f a) -deriving newtype instance Applicative (Reador s f a) -deriving newtype instance Monad (Reador s f a) -deriving newtype instance (Alternative m, Monad m) - => Alternative (Reador s m a) -deriving newtype instance (Alternative m, Monad m) - => MonadPlus (Reador s m a) -deriving newtype instance (Alternative m, Monad m) - => MonadReader s (Reador s m a) -deriving newtype instance (Alternative m, Monad m) - => MonadState s (Reador s m a) -instance (Alternative m, Monad m, Filterable m) - => Filterable (Reador s m a) where - mapMaybe f (Reador p) = - Reador (lift (mapMaybe f (lowerCodensity p))) -instance Profunctor (Reador s f) where - dimap _ f (Reador p) = Reador (fmap f p) -instance Choice (Reador s f) where - left' (Reador p) = Reador (fmap Left p) - right' (Reador p) = Reador (fmap Right p) -instance (Alternative f, Monad f) => Distributor (Reador s f) -instance (Alternative f, Monad f) - => Alternator (Reador s f) where - alternate = \case - Left (Reador p) -> Reador (fmap Left p) - Right (Reador p) -> Reador (fmap Right p) -instance (Alternative f, Monad f, Filterable f) - => Cochoice (Reador s f) where - unleft (Reador p) - = Reador . lift - . mapMaybe (either Just (const Nothing)) - . lowerCodensity $ p - unright (Reador p) - = Reador . lift - . mapMaybe (either (const Nothing) Just) - . lowerCodensity $ p -instance (Alternative f, Monad f, Filterable f) - => Filtrator (Reador s f) where - filtrate (Reador p) = - ( Reador . lift - . mapMaybe (either Just (const Nothing)) - . lowerCodensity $ p - - , Reador . lift - . mapMaybe (either (const Nothing) Just) - . lowerCodensity $ p - ) -instance (Alternative m, Monad m) => Monadic m (Reador s) where - liftP m = Reador (lift (LookStx (\s -> FinalStx ((,s) <$> m)))) -instance - ( Categorized a, a ~ Item s, IsStream s - , Filterable m, Alternative m, Monad m - ) => Tokenized (Reador s m a a) where - type Token (Reador s m a a) = a - anyToken = do - s <- get - case uncons s of - Nothing -> empty - Just (c,cs) -> put cs >> return c -instance - ( Categorized a, a ~ Item s, IsStream s - , Filterable m, Alternative m, Monad m - ) => Equator a a (Reador s m) -instance - ( Categorized a, a ~ Item s, IsStream s - , Filterable m, Alternative m, Monad m - ) => TerminalSymbol (Reador s m () ()) where - type Alphabet (Reador s m () ()) = Item s -instance - ( Char ~ Item s, IsStream s - , Filterable m, Alternative m, Monad m - ) => IsString (Reador s m () ()) where - fromString = terminal -instance - ( Char ~ Item s, IsStream s - , Filterable m, Alternative m, Monad m - ) => IsString (Reador s m s s) where - fromString = tokens -instance BackusNaurForm (Reador s f a b) - --- Stx instances -deriving stock instance Functor f => Functor (Stx s f) -instance (Alternative f, Monad f) => Applicative (Stx s f) where - pure x = ResultStx x empty - (<*>) = ap -instance (Alternative f, Monad f) => MonadPlus (Stx s f) -instance (Alternative f, Monad f) => Monad (Stx s f) where - LookStx f >>= k = LookStx (\s -> f s >>= k) - ResultStx x p >>= k = k x <|> (p >>= k) - FinalStx rs >>= k = FinalStx $ do - (x,s) <- rs - runStx (k x) s -instance (Alternative f, Monad f) => Alternative (Stx s f) where - empty = FinalStx empty - -- results are delivered as soon as possible - ResultStx x p <|> q = ResultStx x (p <|> q) - p <|> ResultStx x q = ResultStx x (p <|> q) - -- two finals are combined - FinalStx rs <|> FinalStx ts = FinalStx (rs <|> ts) - -- final + look becomes one look and one final (=optimization) - FinalStx rs <|> LookStx f = - LookStx (\s -> FinalStx (rs <|> runStx (f s) s)) - LookStx f <|> FinalStx rs = - LookStx (\s -> FinalStx (runStx (f s) s <|> rs)) - -- two looks are combined (=optimization) - LookStx f <|> LookStx g = LookStx (\s -> f s <|> g s) -instance (Alternative f, Monad f, Filterable f) - => Filterable (Stx s f) where - mapMaybe f = \case - LookStx g -> LookStx (mapMaybe f . g) - ResultStx a stx -> case f a of - Nothing -> mapMaybe f stx - Just b -> ResultStx b (mapMaybe f stx) - FinalStx r -> FinalStx (mapMaybe (\(a,s) -> (,s) <$> f a) r) -instance (Alternative m, Monad m) => MonadReader s (Stx s m) where - ask = LookStx pure - local f = \case - LookStx g -> LookStx (g . f) - ResultStx a stx -> ResultStx a stx - FinalStx rs -> FinalStx rs From 5170c451df798494056c29e0e8a169ee7bd24141 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 07:07:45 -0800 Subject: [PATCH 112/282] lots --- distributors.cabal | 17 +- package.yaml | 5 +- src/Control/Lens/Bifocal.hs | 1 - src/Control/Lens/Grammar.hs | 367 +++++++++++++---------- src/Control/Lens/Grammar/BackusNaur.hs | 175 +++++++---- src/Control/Lens/Grammar/Context.hs | 14 - src/Control/Lens/Grammar/Kleene.hs | 393 ++++++++++++++++++++++--- src/Control/Lens/Grammar/Stream.hs | 107 ------- src/Control/Lens/Grammar/Symbol.hs | 23 +- src/Control/Lens/Grammar/Test.hs | 156 ---------- src/Control/Lens/Grammar/Token.hs | 100 ++----- src/Control/Lens/Internal/Equator.hs | 12 +- src/Control/Lens/PartialIso.hs | 19 +- src/Data/Profunctor/Distributor.hs | 82 +++++- src/Data/Profunctor/Grammar.hs | 65 ++-- src/Data/Profunctor/Monoidal.hs | 75 +++-- test/Spec.hs | 52 ++-- 17 files changed, 920 insertions(+), 743 deletions(-) delete mode 100644 src/Control/Lens/Grammar/Context.hs delete mode 100644 src/Control/Lens/Grammar/Stream.hs delete mode 100644 src/Control/Lens/Grammar/Test.hs diff --git a/distributors.cabal b/distributors.cabal index b58f891..2a25eed 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -32,11 +32,8 @@ library Control.Lens.Diopter Control.Lens.Grammar Control.Lens.Grammar.BackusNaur - Control.Lens.Grammar.Context Control.Lens.Grammar.Kleene - Control.Lens.Grammar.Stream Control.Lens.Grammar.Symbol - Control.Lens.Grammar.Test Control.Lens.Grammar.Token Control.Lens.Grate Control.Lens.Internal.Equator @@ -80,7 +77,6 @@ library LambdaCase MagicHash MonoLocalBinds - OverloadedStrings QuantifiedConstraints RankNTypes RecursiveDo @@ -96,16 +92,16 @@ library 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 >=4.4 && <5 + MemoTrie >=0.6.11 && <1 + , adjunctions >=4.4 && <5 , base >=4.7 && <5 , bifunctors >=5.6 && <6 , bytestring >=0.11 && <1 - , comonad + , comonad >=5.0.8 && <6 , containers >=0.6 && <1 , contravariant >=1.5 && <2 , distributive >=0.6 && <1 , indexed-transformers >=0.1.0.4 && <1 - , kan-extensions , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 @@ -150,7 +146,6 @@ test-suite spec LambdaCase MagicHash MonoLocalBinds - OverloadedStrings QuantifiedConstraints RankNTypes RecursiveDo @@ -166,18 +161,18 @@ test-suite spec 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 >=4.4 && <5 + MemoTrie >=0.6.11 && <1 + , adjunctions >=4.4 && <5 , base >=4.7 && <5 , bifunctors >=5.6 && <6 , bytestring >=0.11 && <1 - , comonad + , comonad >=5.0.8 && <6 , containers >=0.6 && <1 , contravariant >=1.5 && <2 , distributive >=0.6 && <1 , distributors , hspec , indexed-transformers >=0.1.0.4 && <1 - , kan-extensions , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 diff --git a/package.yaml b/package.yaml index 6c15687..2046ea5 100644 --- a/package.yaml +++ b/package.yaml @@ -23,14 +23,14 @@ dependencies: - adjunctions >= 4.4 && < 5 - bifunctors >= 5.6 && < 6 - bytestring >= 0.11 && < 1 -- comonad +- comonad >= 5.0.8 && < 6 - containers >= 0.6 && < 1 - contravariant >= 1.5 && < 2 - distributive >= 0.6 && < 1 - lens >= 5.2 && < 6 +- MemoTrie >= 0.6.11 && < 1 - mtl >= 2.3 && < 3 - indexed-transformers >= 0.1.0.4 && < 1 -- kan-extensions - profunctors >= 5.6 && < 6 - tagged >= 0.8 && < 1 - template-haskell @@ -77,7 +77,6 @@ default-extensions: - LambdaCase - MagicHash - MonoLocalBinds -- OverloadedStrings - QuantifiedConstraints - RankNTypes - RecursiveDo diff --git a/src/Control/Lens/Bifocal.hs b/src/Control/Lens/Bifocal.hs index 5df3862..4149cfc 100644 --- a/src/Control/Lens/Bifocal.hs +++ b/src/Control/Lens/Bifocal.hs @@ -37,7 +37,6 @@ import Control.Lens import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso -import Control.Lens.Grammar.Stream import Data.Profunctor import Data.Profunctor.Distributor import Data.Profunctor.Filtrator diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 78a956b..d15385c 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -1,42 +1,20 @@ module Control.Lens.Grammar ( -- * RegEx - RegExStr (..) - , EBNF (..) + RegString (..) + , RegBnfString (..) , RegGrammar , RegGrammarr , bnfGrammarr - , genRegExStr - , printRegEx - , genShowS - , genReadS - -- * Grammar , Grammar - , genEBNF - , printEBNF - , regexGrammar - , ebnfGrammar , Grammarr + , regexGrammar , CtxGrammar , CtxGrammarr - -- * Optics , prismGrammar , coPrismGrammar , grammarrOptic , grammarOptic - -- * Constraints - , Regular - , Grammatical - , Contextual - -- * Re-exports - , oneP, (>*), (*<), (>*<), replicateP - , empty, (<|>), manyP, someP, optionalP - , module Control.Lens.Grammar.BackusNaur - , module Control.Lens.Grammar.Kleene - , module Control.Lens.Grammar.Token - , module Control.Lens.Grammar.Stream - , module Control.Lens.Grammar.Symbol - , module Control.Lens.PartialIso - , module Data.Profunctor.Grammar + , Tokenizor ) where import Control.Applicative @@ -46,10 +24,8 @@ import Control.Lens.PartialIso import Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Token -import Control.Lens.Grammar.Stream import Control.Lens.Grammar.Symbol import Control.Monad --- import Control.Monad.Except import Data.Maybe hiding (mapMaybe) import Data.Monoid import Data.Profunctor @@ -58,42 +34,65 @@ import Data.Profunctor.Filtrator import Data.Profunctor.Monadic import Data.Profunctor.Monoidal import Data.Profunctor.Grammar +import qualified Data.Set as Set import Data.String import GHC.Exts import Prelude hiding (filter) import Witherable makeNestedPrisms ''RegEx +makeNestedPrisms ''RegExam +makeNestedPrisms ''CategoryTest makeNestedPrisms ''GeneralCategory -type RegGrammar token a = forall p. Regular token p => p a a -type Grammar token a = forall p. Grammatical token p => p a a -type CtxGrammar token a = forall p m. Contextual token m p => p m a a - -type RegGrammarr token a b = - forall p. Regular token p => p a a -> p b b -type Grammarr token a b = - forall p. Grammatical token p => p a a -> p b b -type CtxGrammarr token a b = - forall p m. Contextual token m p => p m a a -> p m b b - -type Regular token p = - ( Terminator token p - , Tokenizor token p +type RegGrammar token a = forall p. + ( Tokenizor token p , Alternator p - ) -type Grammatical token p = - ( Regular token p - , Filtrator p + ) => p a a +type Grammar token a = forall p. + ( Tokenizor token p , forall x. BackusNaurForm (p x x) - ) -type Contextual token m p = - ( Grammatical token (p m) + , Alternator p + ) => p a a +type CtxGrammar token a = forall p m. + ( Tokenizor token (p m) + , forall x. BackusNaurForm (p m x x) + , Alternator (p m) + , Filtrator (p m) , Monadic m p + , Alternative m , Filterable m + , Monad m + ) => p m a a + +type RegGrammarr token a b = forall p. + ( Tokenizor token p + , Alternator p + ) => p a a -> p b b +type Grammarr token a b = forall p. + ( Tokenizor token p + , forall x. BackusNaurForm (p x x) + , Alternator p + ) => p a a -> p b b +type CtxGrammarr token a b = forall p m. + ( Tokenizor token (p m) + , forall x. BackusNaurForm (p m x x) + , Alternator (p m) + , Filtrator (p m) + , Monadic m p , Alternative m + , Filterable m , Monad m - ) + ) => p m a a -> p m b b + +type Tokenizor token p = + ( forall x y. (x ~ (), y ~ ()) + => TerminalSymbol token (p x y) + , forall x y. (x ~ token, y ~ token) + => Tokenized token (p x y) + , forall x y test. (x ~ token, y ~ token, test ~ TokenTest token) + => TestAlgebra test (p x y) + ) :: Constraint prismGrammar :: (Monoidal p, Choice p) => Prism' a () -> p a a prismGrammar = (>? oneP) @@ -111,148 +110,192 @@ grammarrOptic => (p a a -> p b b) -> Optic' p f b a grammarrOptic = dimap (rmap extract) (rmap pure) -genShowS - :: (Filterable m, Alternative m, Monad m) - => CtxGrammar Char a -> a -> m ShowS -genShowS = evalPrintor +regexGrammar :: Grammar Char (RegEx Char) +regexGrammar = ruleRec "regex" altG -genReadS :: CtxGrammar Char a -> ReadS a -genReadS = runParsor +altG :: Grammarr Char (RegEx Char) (RegEx Char) +altG rex = rule "alternate" $ + chain1 Left (_RegExam . _Alternate) (sepBy (terminal "|")) (seqG rex) -genRegExStr :: RegGrammar Char a -> RegExStr -genRegExStr = evalGrammor @() @Identity +seqG :: Grammarr Char (RegEx Char) (RegEx Char) +seqG rex = rule "sequence" $ + chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) -genEBNF :: Grammar Char a -> EBNF -genEBNF = evalGrammor @() @((,) All) +exprG :: Grammarr Char (RegEx Char) (RegEx Char) +exprG rex = rule "expression" $ choiceP + [ _Terminal >? someP charG + , _KleeneOpt >? atomG rex *< terminal "?" + , _KleeneStar >? atomG rex *< terminal "*" + , _KleenePlus >? atomG rex *< terminal "+" + , atomG rex + ] -regexGrammar :: Grammar Char RegExStr -regexGrammar = dimap runRegExStr RegExStr $ ruleRec "regex" altG - where - altG rex = rule "alternate" $ - chain1 Left _Alternate (sepBy (terminal "|")) (seqG rex) - seqG rex = rule "sequence" $ - chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) - exprG rex = rule "expression" $ choiceP - [ _Terminal >? someP charG - , _KleeneOpt >? atomG rex *< terminal "?" - , _KleeneStar >? atomG rex *< terminal "*" - , _KleenePlus >? atomG rex *< terminal "+" - , atomG rex - ] - atomG rex = rule "atom" $ choiceP - [ nonterminalG - , _Terminal >? charG >:< pure "" - , _AnyToken >? terminal "." - , _OneOf >? terminal "[" >* someP charG *< terminal "]" - , _NotOneOf >? terminal "[^" >* someP charG *< terminal "]" - , _AsIn >? terminal "\\p{" >* categoryG *< terminal "}" - , _NotAsIn >? terminal "\\P{" >* categoryG *< terminal "}" - , terminal "(" >* rex *< terminal ")" - ] - charG = rule "char" $ escapes - [ ("$()*+.?[\\]^{|}", (terminal "\\" >*)) - , ("\n", \_ -> (terminal "\\n" <|> terminal "\n") >* pure '\n') - , ("\t", \_ -> (terminal "\\t" <|> terminal "\t") >* pure '\t') - ] - categoryG = rule "category" $ choiceP - [ _LowercaseLetter >? terminal "Ll" - , _UppercaseLetter >? terminal "Lu" - , _TitlecaseLetter >? terminal "Lt" - , _ModifierLetter >? terminal "Lm" - , _OtherLetter >? terminal "Lo" - , _NonSpacingMark >? terminal "Mn" - , _SpacingCombiningMark >? terminal "Mc" - , _EnclosingMark >? terminal "Me" - , _DecimalNumber >? terminal "Nd" - , _LetterNumber >? terminal "Nl" - , _OtherNumber >? terminal "No" - , _ConnectorPunctuation >? terminal "Pc" - , _DashPunctuation >? terminal "Pd" - , _OpenPunctuation >? terminal "Ps" - , _ClosePunctuation >? terminal "Pe" - , _InitialQuote >? terminal "Pi" - , _FinalQuote >? terminal "Pf" - , _OtherPunctuation >? terminal "Po" - , _MathSymbol >? terminal "Sm" - , _CurrencySymbol >? terminal "Sc" - , _ModifierSymbol >? terminal "Sk" - , _OtherSymbol >? terminal "So" - , _Space >? terminal "Zs" - , _LineSeparator >? terminal "Zl" - , _ParagraphSeparator >? terminal "Zp" - , _Control >? terminal "Cc" - , _Format >? terminal "Cf" - , _Surrogate >? terminal "Cs" - , _PrivateUse >? terminal "Co" - , _NotAssigned >? terminal "Cn" - ] - nonterminalG = rule "nonterminal" $ terminal "\\q" >* choiceP - [ _NonTerminal >? terminal "{" >* manyP charG *< terminal "}" - , prismGrammar _Fail - ] +atomG :: Grammarr Char (RegEx Char) (RegEx Char) +atomG rex = rule "atom" $ choiceP + [ nonterminalG + , _Terminal >? charG >:< pure "" + , _RegExam . _Pass >? terminal "." + , _RegExam . _OneOf >? + terminal "[" >* several noSep charG *< terminal "]" + , _RegExam . _NotOneOf >? + terminal "[^" >* several noSep charG + >*< (catTestG <|> pure (NotAsIn Set.empty)) + *< terminal "]" + , _RegExam . _NotOneOf >? pure Set.empty >*< catTestG + , terminal "(" >* rex *< terminal ")" + ] + +catTestG :: Grammar Char (CategoryTest Char) +catTestG = rule "category-test" $ choiceP + [ _AsIn >? terminal "\\p{" >* categoryG *< terminal "}" + , _NotAsIn >? terminal "\\P{" >* + several (sepBy (terminal "|")) categoryG + *< terminal "}" + ] + +categoryG :: Grammar Char GeneralCategory +categoryG = rule "category" $ choiceP + [ _LowercaseLetter >? terminal "Ll" + , _UppercaseLetter >? terminal "Lu" + , _TitlecaseLetter >? terminal "Lt" + , _ModifierLetter >? terminal "Lm" + , _OtherLetter >? terminal "Lo" + , _NonSpacingMark >? terminal "Mn" + , _SpacingCombiningMark >? terminal "Mc" + , _EnclosingMark >? terminal "Me" + , _DecimalNumber >? terminal "Nd" + , _LetterNumber >? terminal "Nl" + , _OtherNumber >? terminal "No" + , _ConnectorPunctuation >? terminal "Pc" + , _DashPunctuation >? terminal "Pd" + , _OpenPunctuation >? terminal "Ps" + , _ClosePunctuation >? terminal "Pe" + , _InitialQuote >? terminal "Pi" + , _FinalQuote >? terminal "Pf" + , _OtherPunctuation >? terminal "Po" + , _MathSymbol >? terminal "Sm" + , _CurrencySymbol >? terminal "Sc" + , _ModifierSymbol >? terminal "Sk" + , _OtherSymbol >? terminal "So" + , _Space >? terminal "Zs" + , _LineSeparator >? terminal "Zl" + , _ParagraphSeparator >? terminal "Zp" + , _Control >? terminal "Cc" + , _Format >? terminal "Cf" + , _Surrogate >? terminal "Cs" + , _PrivateUse >? terminal "Co" + , _NotAssigned >? terminal "Cn" + ] + +charG :: Grammar Char Char +charG = rule "char" $ testB (notOneOf charsReserved >&&< notAsIn Control) + <|> terminal "\\" >* charEscapedG + +charEscapedG :: Grammar Char Char +charEscapedG = rule "char-escaped" $ + oneOf charsReserved <|> charControlG + +charControlG :: Grammar Char Char +charControlG = rule "char-control-abbrev" $ choiceP + [ terminal abbreviation >* pure charControl + | (abbreviation, charControl) <- charsControl + ] + +charsReserved :: [Char] +charsReserved = "$()*+.?[\\]^{|}" -bnfGrammarr :: Ord rule => RegGrammarr Char rule (BNF rule) +charsControl :: [(String, Char)] +charsControl = + [ ("NUL", '\NUL'), ("SOH", '\SOH'), ("STX", '\STX'), ("ETX", '\ETX') + , ("EOT", '\EOT'), ("ENQ", '\ENQ'), ("ACK", '\ACK'), ("BEL", '\BEL') + , ("BS", '\BS'), ("HT", '\HT'), ("LF", '\LF'), ("VT", '\VT') + , ("FF", '\FF'), ("CR", '\CR'), ("SO", '\SO'), ("SI", '\SI') + , ("DLE", '\DLE'), ("DC1", '\DC1'), ("DC2", '\DC2'), ("DC3", '\DC3') + , ("DC4", '\DC4'), ("NAK", '\NAK'), ("SYN", '\SYN'), ("ETB", '\ETB') + , ("CAN", '\CAN'), ("EM", '\EM'), ("SUB", '\SUB'), ("ESC", '\ESC') + , ("FS", '\FS'), ("GS", '\GS'), ("RS", '\RS'), ("US", '\US') + , ("DEL", '\DEL') + , ("PAD", '\x80'), ("HOP", '\x81'), ("BPH", '\x82'), ("NBH", '\x83') + , ("IND", '\x84'), ("NEL", '\x85'), ("SSA", '\x86'), ("ESA", '\x87') + , ("HTS", '\x88'), ("HTJ", '\x89'), ("VTS", '\x8A'), ("PLD", '\x8B') + , ("PLU", '\x8C'), ("RI", '\x8D'), ("SS2", '\x8E'), ("SS3", '\x8F') + , ("DCS", '\x90'), ("PU1", '\x91'), ("PU2", '\x92'), ("STS", '\x93') + , ("CCH", '\x94'), ("MW", '\x95'), ("SPA", '\x96'), ("EPA", '\x97') + , ("SOS", '\x98'), ("SGCI",'\x99'), ("SCI", '\x9A'), ("CSI", '\x9B') + , ("ST", '\x9C'), ("OSC", '\x9D'), ("PM", '\x9E'), ("APC", '\x9F') + ] + +nonterminalG :: Grammar Char (RegEx Char) +nonterminalG = rule "nonterminal" $ terminal "\\q" >* choiceP + [ _NonTerminal >? terminal "{" >* manyP charG *< terminal "}" + , prismGrammar (_RegExam . _Fail) + ] + +bnfGrammarr :: Ord rule => RegGrammarr Char rule (Bnf rule) bnfGrammarr p = dimap hither thither $ startG >*< rulesG where - hither (BNF start rules) = (start, toList rules) - thither (start, rules) = BNF start (fromList rules) + hither (Bnf start rules) = (start, toList rules) + thither (start, rules) = Bnf start (fromList rules) startG = terminal "start" >* ruleG - rulesG = manyP (terminal ['\n'] >* nameG >*< ruleG) + rulesG = manyP (terminal "\n" >* nameG >*< ruleG) ruleG = terminal " = " >* p - nameG = manyP (escape "\\= " (terminal "\\" >*)) - -ebnfGrammar :: Grammar Char EBNF -ebnfGrammar = dimap runEBNF EBNF (bnfGrammarr regexGrammar) + nameG = manyP (notOneOf ['='] <|> (terminal "\\=" >* pure '=')) -newtype RegExStr = RegExStr {runRegExStr :: RegEx Char} +newtype RegString = RegString {runRegString :: RegEx Char} deriving newtype ( Eq, Ord , Semigroup, Monoid, KleeneStarAlgebra - , Tokenized, TerminalSymbol, NonTerminalSymbol + , Tokenized Char, TestAlgebra (TokenTest Char) + , TerminalSymbol Char, NonTerminalSymbol + , Matching String ) -newtype EBNF = EBNF {runEBNF :: BNF RegExStr} + +newtype RegBnfString = RegBnfString {runRegBnfString :: Bnf (RegEx Char)} deriving newtype ( Eq, Ord , Semigroup, Monoid, KleeneStarAlgebra - , Tokenized, TerminalSymbol, NonTerminalSymbol - , BackusNaurForm + , Tokenized Char, TestAlgebra (TokenTest Char) + , TerminalSymbol Char, NonTerminalSymbol + , BackusNaurForm, Matching String ) -printRegEx :: RegGrammar Char a -> IO () -printRegEx = streamLine . genRegExStr - -printEBNF :: Grammar Char a -> IO () -printEBNF = streamLine . genEBNF - -instance IsList RegExStr where - type Item RegExStr = Char +instance IsList RegString where + type Item RegString = Char fromList - = fromMaybe (RegExStr Fail) + = fromMaybe zeroK . listToMaybe - . mapMaybe (\(rex, remaining) -> if remaining == "" then Just rex else Nothing) - . genReadS regexGrammar + . mapMaybe prsF + . runParsor regexGrammar + where + prsF (rex,"") = Just (RegString rex) + prsF _ = Nothing toList = maybe "\\q" ($ "") - . genShowS regexGrammar -instance IsString RegExStr where + . evalPrintor regexGrammar + . runRegString +instance IsString RegString where fromString = fromList -instance Show RegExStr where +instance Show RegString where showsPrec precision = showsPrec precision . toList -instance Read RegExStr where +instance Read RegString where readsPrec _ str = [(fromList str, "")] -instance IsList EBNF where - type Item EBNF = Char +instance IsList RegBnfString where + type Item RegBnfString = Char fromList - = fromMaybe (EBNF (BNF (RegExStr Fail) mempty)) + = fromMaybe zeroK . listToMaybe - . mapMaybe (\(ebnf, remaining) -> if remaining == "" then Just ebnf else Nothing) - . genReadS ebnfGrammar + . mapMaybe prsF + . runParsor (bnfGrammarr regexGrammar) + where + prsF (ebnf,"") = Just (RegBnfString ebnf) + prsF _ = Nothing toList = maybe "{start} = \\q" ($ "") - . genShowS ebnfGrammar -instance IsString EBNF where + . evalPrintor (bnfGrammarr regexGrammar) + . runRegBnfString +instance IsString RegBnfString where fromString = fromList -instance Show EBNF where +instance Show RegBnfString where showsPrec precision = showsPrec precision . toList -instance Read EBNF where +instance Read RegBnfString where readsPrec _ str = [(fromList str, "")] diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 456a6ef..0e39a38 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -1,17 +1,24 @@ module Control.Lens.Grammar.BackusNaur ( BackusNaurForm (..) - , BNF (..) - , liftBNF0 - , liftBNF1 - , liftBNF2 + , Bnf (..) + , Matching (..) + , diffB + , liftBnf0 + , liftBnf1 + , liftBnf2 ) where +import Control.Lens +import Control.Lens.Extras import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Token import Control.Lens.Grammar.Symbol import Data.Coerce +import Data.Foldable import Data.Function -import Data.Set as Set +import Data.MemoTrie +import qualified Data.Set as Set +import Data.Set (Set) class BackusNaurForm bnf where rule :: String -> bnf -> bnf @@ -19,62 +26,130 @@ class BackusNaurForm bnf where ruleRec :: String -> (bnf -> bnf) -> bnf ruleRec _ = fix -data BNF rule = BNF - { startBNF :: rule - , rulesBNF :: Set (String, rule) +data Bnf rule = Bnf + { startBnf :: rule + , rulesBnf :: Set (String, rule) } deriving stock (Eq, Ord, Show, Read) -liftBNF0 :: Ord a => a -> BNF a -liftBNF0 a = BNF a mempty +liftBnf0 :: Ord a => a -> Bnf a +liftBnf0 a = Bnf a mempty -liftBNF1 :: (Coercible a b, Ord b) => (a -> b) -> BNF a -> BNF b -liftBNF1 f (BNF start rules) = BNF (f start) (Set.map coerce rules) +liftBnf1 :: (Coercible a b, Ord b) => (a -> b) -> Bnf a -> Bnf b +liftBnf1 f (Bnf start rules) = Bnf (f start) (Set.map coerce rules) -liftBNF2 +liftBnf2 :: (Coercible a c, Coercible b c, Ord c) - => (a -> b -> c) -> BNF a -> BNF b -> BNF c -liftBNF2 f (BNF start0 rules0) (BNF start1 rules1) = - BNF (f start0 start1) (Set.map coerce rules0 <> Set.map coerce rules1) + => (a -> b -> c) -> Bnf a -> Bnf b -> Bnf c +liftBnf2 f (Bnf start0 rules0) (Bnf start1 rules1) = + Bnf (f start0 start1) (Set.map coerce rules0 <> Set.map coerce rules1) +-- | Does a word match a pattern? +class Matching word pattern | pattern -> word where + (=~) :: word -> pattern -> Bool + infix 2 =~ + +{- | +The [Brzozowski derivative] +(https://dl.acm.org/doi/pdf/10.1145/321239.321249) of a +`RegEx`tended `Bnf`, with memoization. + +prop> word =~ diffB prefix pattern = prefix <> word =~ pattern +-} +diffB + :: (Categorized token, Enum (Categorize token), HasTrie token) + => [token] -> Bnf (RegEx token) -> Bnf (RegEx token) +diffB prefix (Bnf start rules) = + Bnf (foldl' (flip diff1B) start prefix) rules + where + -- derivative wrt 1 token, memoized + diff1B = memo2 $ \x -> \case + Terminal [] -> zeroK + Terminal (tokenY:streamY) -> + if x == tokenY then terminal streamY else zeroK + NonTerminal nameY -> anyK (diff1B x) (rulesNamed nameY rules) + Sequence y1 y2 -> + if δ (Bnf y1 rules) then y1'y2 >|< y1y2' else y1'y2 + where + y1'y2 = diff1B x y1 <> y2 + y1y2' = y1 <> diff1B x y2 + KleeneStar y -> diff1B x y <> starK y + KleeneOpt y -> diff1B x y + KleenePlus y -> diff1B x y <> starK y + RegExam Fail -> zeroK + RegExam Pass -> mempty + RegExam (OneOf chars) -> + if x `elem` chars then mempty else zeroK + RegExam (NotOneOf chars (AsIn cat)) -> + if elem x chars || categorize x /= cat + then zeroK else mempty + RegExam (NotOneOf chars (NotAsIn cats)) -> + if elem x chars || elem (categorize x) cats + then zeroK else mempty + RegExam (Alternate y1 y2) -> diff1B x y1 >|< diff1B x y2 + +-- | Does a pattern match the empty word? +δ :: (Categorized token, Enum (Categorize token), HasTrie token) + => Bnf (RegEx token) -> Bool +δ (Bnf start rules) = ν start where + ν = memo $ \case + Terminal [] -> True + KleeneStar _ -> True + KleeneOpt _ -> True + KleenePlus y -> ν y + Sequence y1 y2 -> ν y1 && ν y2 + RegExam (Alternate y1 y2) -> ν y1 || ν y2 + NonTerminal nameY -> any ν (rulesNamed nameY rules) + _ -> False + +rulesNamed :: Ord rule => String -> Set (String, rule) -> Set rule +rulesNamed nameX = foldl' (flip inserter) Set.empty where + inserter (nameY,y) = + if nameX == nameY then Set.insert y else id + +-- instances instance (Ord rule, NonTerminalSymbol rule) - => BackusNaurForm (BNF rule) where + => BackusNaurForm (Bnf rule) where rule name = ruleRec name . const ruleRec name f = let newStart = nonTerminal name - BNF newRule oldRules = f (BNF newStart mempty) - newRules = insert (name, newRule) oldRules + Bnf newRule oldRules = f (Bnf newStart mempty) + newRules = Set.insert (name, newRule) oldRules in - BNF newStart newRules - -instance (Ord rule, TerminalSymbol rule) - => TerminalSymbol (BNF rule) where - type Alphabet (BNF rule) = Alphabet rule - terminal = liftBNF0 . terminal - + Bnf newStart newRules +instance (Ord rule, TerminalSymbol token rule) + => TerminalSymbol token (Bnf rule) where + terminal = liftBnf0 . terminal instance (Ord rule, NonTerminalSymbol rule) - => NonTerminalSymbol (BNF rule) where - nonTerminal = liftBNF0 . nonTerminal - -instance (Ord rule, Tokenized rule) => Tokenized (BNF rule) where - type Token (BNF rule) = Token rule - anyToken = liftBNF0 anyToken - notAnyToken = liftBNF0 notAnyToken - token = liftBNF0 . token - notToken = liftBNF0 . notToken - oneOf = liftBNF0 . oneOf - notOneOf = liftBNF0 . notOneOf - asIn = liftBNF0 . asIn - notAsIn = liftBNF0 . notAsIn - + => NonTerminalSymbol (Bnf rule) where + nonTerminal = liftBnf0 . nonTerminal +instance (Ord rule, Tokenized token rule) + => Tokenized token (Bnf rule) where + anyToken = liftBnf0 anyToken + token = liftBnf0 . token + oneOf = liftBnf0 . oneOf + notOneOf = liftBnf0 . notOneOf + asIn = liftBnf0 . asIn + notAsIn = liftBnf0 . notAsIn +instance (Ord rule, TestAlgebra bool rule) + => TestAlgebra bool (Bnf rule) where + testB = liftBnf0 . testB instance (Ord rule, KleeneStarAlgebra rule) - => KleeneStarAlgebra (BNF rule) where - starK = liftBNF1 starK - plusK = liftBNF1 plusK - optK = liftBNF1 optK - empK = liftBNF0 empK - (>|<) = liftBNF2 (>|<) -instance (Ord rule, Monoid rule) => Monoid (BNF rule) where - mempty = liftBNF0 mempty -instance (Ord rule, Semigroup rule) => Semigroup (BNF rule) where - (<>) = liftBNF2 (<>) + => KleeneStarAlgebra (Bnf rule) where + starK = liftBnf1 starK + plusK = liftBnf1 plusK + optK = liftBnf1 optK + zeroK = liftBnf0 zeroK + (>|<) = liftBnf2 (>|<) +instance (Ord rule, Monoid rule) => Monoid (Bnf rule) where + mempty = liftBnf0 mempty +instance (Ord rule, Semigroup rule) => Semigroup (Bnf rule) where + (<>) = liftBnf2 (<>) +instance (Categorized token, Enum (Categorize token), HasTrie token) + => Matching [token] (Bnf (RegEx token)) where + (=~) word = δ . diffB word +instance (Categorized token, Enum (Categorize token), HasTrie token) + => Matching [token] (RegEx token) where + word =~ pattern = word =~ liftBnf0 pattern +instance Matching s (APrism s t a b) where + word =~ pattern = is pattern word diff --git a/src/Control/Lens/Grammar/Context.hs b/src/Control/Lens/Grammar/Context.hs deleted file mode 100644 index a58ce1a..0000000 --- a/src/Control/Lens/Grammar/Context.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Control.Lens.Grammar.Context - ( eof - , ask - ) where - -import Control.Applicative -import Control.Lens -import Control.Monad -import Control.Monad.Reader - -eof :: (AsEmpty s, MonadReader s m, Alternative m) => m () -eof = do - s <- ask - when (isn't _Empty s) empty diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 9379710..3910793 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -1,27 +1,47 @@ module Control.Lens.Grammar.Kleene ( KleeneStarAlgebra (..) + , orK, anyK , RegEx (..) + , RegExam (..) + , CategoryTest (..) + , BooleanAlgebra (..) + , fromBool + , andB, orB, allB, anyB + , TokenTest (..) + , TestAlgebra (..) ) where import Control.Applicative import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Data.Foldable +import Data.Function (on) +import Data.MemoTrie import Data.Monoid +import Data.Profunctor +import Data.Profunctor.Distributor +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics -class Monoid t => KleeneStarAlgebra t where - starK, plusK, optK :: t -> t - starK t = optK (plusK t) - plusK t = t <> starK t - optK t = mempty >|< t +class Monoid k => KleeneStarAlgebra k where + starK, plusK, optK :: k -> k + starK x = optK (plusK x) + plusK x = x <> starK x + optK x = mempty >|< x infixl 3 >|< - (>|<) :: t -> t -> t - empK :: t - default (>|<) :: (t ~ f a, Alternative f) => t -> t -> t - default empK :: (t ~ f a, Alternative f) => t + (>|<) :: k -> k -> k + zeroK :: k + default (>|<) :: (k ~ f a, Alternative f) => k -> k -> k + default zeroK :: (k ~ f a, Alternative f) => k (>|<) = (<|>) - empK = empty -instance (Alternative f, Monoid t) => KleeneStarAlgebra (Ap f t) + zeroK = empty + +orK :: (Foldable f, KleeneStarAlgebra k) => f k -> k +orK = foldl' (>|<) zeroK + +anyK :: (Foldable f, KleeneStarAlgebra k) => (a -> k) -> f a -> k +anyK f = foldl' (\b a -> b >|< f a) zeroK data RegEx token = Terminal [token] @@ -30,13 +50,101 @@ data RegEx token | KleeneStar (RegEx token) | KleeneOpt (RegEx token) | KleenePlus (RegEx token) - | Alternate (RegEx token) (RegEx token) - | Fail - | AnyToken - | OneOf [token] - | NotOneOf [token] - | AsIn (Categorize token) - | NotAsIn (Categorize token) + | RegExam (RegExam token (RegEx token)) + +-- newtype RegEx token = RegEx (RegExtend token (RegEx token)) + +-- data RegExtend token alg +-- = Terminal [token] +-- | NonTerminal String +-- | Sequence (RegExtend token alg) (RegExtend token alg) +-- | KleeneStar (RegExtend token alg) +-- | KleeneOpt (RegExtend token alg) +-- | KleenePlus (RegExtend token alg) +-- | RegExam (RegExam token (RegExtend token alg)) + +data RegExam token alg + = Fail + | Pass + | OneOf (Set token) + | NotOneOf (Set token) (CategoryTest token) + | Alternate alg alg + +data CategoryTest token + = AsIn (Categorize token) + | NotAsIn (Set (Categorize token)) + +class BooleanAlgebra b where + + falseB :: b + default falseB + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b + falseB = pure falseB + + trueB :: b + default trueB + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b + trueB = pure trueB + + notB :: b -> b + default notB + :: (b ~ f bool, BooleanAlgebra bool, Functor f) => b -> b + notB = fmap notB + + (>||<) :: b -> b -> b + default (>||<) + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b + (>||<) = liftA2 (>||<) + + (>&&<) :: b -> b -> b + default (>&&<) + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b + (>&&<) = liftA2 (>&&<) + +fromBool :: BooleanAlgebra b => Bool -> b +fromBool = \case + True -> trueB + False -> falseB + +andB :: (Foldable f, BooleanAlgebra b) => f b -> b +andB = foldl' (>&&<) trueB + +orB :: (Foldable f, BooleanAlgebra b) => f b -> b +orB = foldl' (>||<) falseB + +allB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b +allB f = foldl' (\b a -> b >&&< f a) trueB + +anyB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b +anyB f = foldl' (\b a -> b >||< f a) falseB + +newtype TokenTest token = TokenTest (RegExam token (TokenTest token)) + +class BooleanAlgebra bool => TestAlgebra bool alg | alg -> bool where + testB :: bool -> alg + default testB + :: ( alg ~ p token token + , bool ~ TokenTest token + , Tokenized token (p token token) + , Alternator p, Cochoice p + ) + => bool -> alg + testB (TokenTest exam) = case exam of + Fail -> empty + Pass -> anyToken + OneOf chars -> oneOf chars + NotOneOf chars (AsIn cat) -> + satisfy (notOneOf chars >&&< asIn cat) + NotOneOf chars (NotAsIn cats) -> + satisfy (notOneOf chars >&&< allB notAsIn cats) + Alternate exam1 exam2 -> testB exam1 <|> testB exam2 + +--instances +instance (Alternative f, Monoid k) => KleeneStarAlgebra (Ap f k) +deriving stock instance Generic (RegEx token) +deriving stock instance Generic (RegExam token alg) +deriving stock instance Generic (TokenTest token) +deriving stock instance Generic (CategoryTest token) deriving stock instance Categorized token => Eq (RegEx token) deriving stock instance Categorized token => Ord (RegEx token) deriving stock instance @@ -45,27 +153,27 @@ deriving stock instance deriving stock instance (Categorized token, Show token, Show (Categorize token)) => Show (RegEx token) -instance TerminalSymbol (RegEx token) where - type Alphabet (RegEx token) = token +instance TerminalSymbol token (RegEx token) where terminal = Terminal . toList -instance Categorized token => Tokenized (RegEx token) where - type Token (RegEx token) = token - anyToken = AnyToken - notAnyToken = Fail +instance NonTerminalSymbol (RegEx token) where + nonTerminal = NonTerminal +instance Categorized token => Tokenized token (RegEx token) where + anyToken = RegExam Pass token a = Terminal [a] - notToken a = NotOneOf [a] - oneOf [] = Fail - oneOf [a] = Terminal [a] - oneOf as = OneOf (toList as) - notOneOf [] = AnyToken - notOneOf as = NotOneOf (toList as) - asIn = AsIn - notAsIn = NotAsIn + oneOf as | null as = RegExam Fail + oneOf as | length as == 1 = Terminal (toList as) + oneOf as = RegExam (OneOf (foldr Set.insert Set.empty as)) + notOneOf as | null as = RegExam Pass + notOneOf as = RegExam + (NotOneOf (foldr Set.insert Set.empty as) (NotAsIn Set.empty)) + asIn cat = RegExam (NotOneOf Set.empty (AsIn cat)) + notAsIn cat = RegExam + (NotOneOf Set.empty (NotAsIn (Set.singleton cat))) instance Categorized token => Semigroup (RegEx token) where Terminal [] <> rex = rex rex <> Terminal [] = rex - Fail <> _ = empK - _ <> Fail = empK + RegExam Fail <> _ = zeroK + _ <> RegExam Fail = zeroK Terminal str0 <> Terminal str1 = Terminal (str0 <> str1) KleeneStar rex0 <> rex1 | rex0 == rex1 = plusK rex0 @@ -75,24 +183,223 @@ instance Categorized token => Semigroup (RegEx token) where instance Categorized token => Monoid (RegEx token) where mempty = Terminal [] instance Categorized token => KleeneStarAlgebra (RegEx token) where - empK = Fail - optK Fail = mempty + zeroK = RegExam Fail + optK (RegExam Fail) = mempty optK (Terminal []) = mempty optK (KleenePlus rex) = starK rex optK rex = KleeneOpt rex - starK Fail = mempty + starK (RegExam Fail) = mempty starK (Terminal []) = mempty starK rex = KleeneStar rex - plusK Fail = empK + plusK (RegExam Fail) = zeroK plusK (Terminal []) = mempty plusK rex = KleenePlus rex KleenePlus rex >|< Terminal [] = starK rex Terminal [] >|< KleenePlus rex = starK rex rex >|< Terminal [] = optK rex Terminal [] >|< rex = optK rex - rex >|< Fail = rex - Fail >|< rex = rex + rex >|< RegExam Fail = rex + RegExam Fail >|< rex = rex rex0 >|< rex1 | rex0 == rex1 = rex0 - rex0 >|< rex1 = Alternate rex0 rex1 -instance NonTerminalSymbol (RegEx token) where - nonTerminal = NonTerminal + rex0 >|< rex1 = RegExam (Alternate rex0 rex1) +instance Categorized token + => TestAlgebra (TokenTest token) (RegEx token) where + testB (TokenTest tokenExam) = case tokenExam of + Fail -> RegExam Fail + Pass -> RegExam Pass + OneOf as -> RegExam (OneOf as) + NotOneOf as catTest -> RegExam (NotOneOf as catTest) + Alternate exam1 exam2 -> + RegExam (Alternate (testB exam1) (testB exam2)) +instance BooleanAlgebra Bool where + falseB = False + trueB = True + notB = not + (>&&<) = (&&) + (>||<) = (||) +instance BooleanAlgebra (x -> Bool) +instance (Applicative f, BooleanAlgebra bool) + => BooleanAlgebra (Ap f bool) +deriving newtype instance Categorized token + => BooleanAlgebra (TokenTest token) +deriving newtype instance Categorized token + => Tokenized token (TokenTest token) +instance Categorized token + => Tokenized token (RegExam token alg) where + anyToken = Pass + token a = OneOf (Set.singleton a) + oneOf as | null as = Fail + oneOf as = OneOf (Set.fromList (toList as)) + notOneOf as | null as = Pass + notOneOf as = + NotOneOf (Set.fromList (toList as)) (NotAsIn Set.empty) + asIn cat = NotOneOf Set.empty (AsIn cat) + notAsIn cat = + NotOneOf Set.empty (NotAsIn (Set.singleton cat)) +instance Categorized token + => BooleanAlgebra (RegExam token (TokenTest token)) where + falseB = Fail + trueB = Pass + notB Fail = Pass + notB Pass = Fail + notB (Alternate (TokenTest x) (TokenTest y)) = x >&&< y + notB (OneOf xs) = NotOneOf xs (NotAsIn Set.empty) + notB (NotOneOf xs (AsIn y)) = + (Alternate `on` TokenTest) + (OneOf xs) + (NotOneOf Set.empty (NotAsIn (Set.singleton y))) + notB (NotOneOf xs (NotAsIn ys)) = + foldl' (Alternate `on` TokenTest) + (OneOf xs) + (Set.map (NotOneOf Set.empty . AsIn) ys) + _ >&&< Fail = Fail + Fail >&&< _ = Fail + x >&&< Pass = x + Pass >&&< y = y + x >&&< Alternate (TokenTest y) (TokenTest z) = (x >&&< y) >||< (x >&&< z) + Alternate (TokenTest x) (TokenTest y) >&&< z = (x >&&< z) >||< (y >&&< z) + OneOf xs >&&< OneOf ys = OneOf (Set.intersection xs ys) + OneOf xs >&&< NotOneOf ys (AsIn z) = OneOf + (Set.filter (\x -> categorize x == z) (Set.difference xs ys)) + NotOneOf xs (AsIn y) >&&< OneOf zs = OneOf + (Set.filter (\z -> categorize z == y) (Set.difference zs xs)) + OneOf xs >&&< NotOneOf ys (NotAsIn zs) = OneOf + (Set.filter (\x -> categorize x `notElem` zs) (Set.difference xs ys)) + NotOneOf xs (NotAsIn ys) >&&< OneOf zs = OneOf + (Set.filter (\z -> categorize z `notElem` ys) (Set.difference zs xs)) + NotOneOf xs (AsIn y) >&&< NotOneOf ws (AsIn z) = + if y /= z then Fail else NotOneOf + (Set.filter (\x -> categorize x == y) + (Set.union xs ws)) (AsIn y) + NotOneOf xs (AsIn y) >&&< NotOneOf ws (NotAsIn zs) = + if y `elem` zs then Fail else NotOneOf + (Set.filter (\x -> categorize x == y) + (Set.union xs ws)) (AsIn y) + NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (AsIn z) = + if z `elem` ys then Fail else NotOneOf + (Set.filter (\x -> categorize x == z) (Set.union xs ws)) + (AsIn z) + NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (NotAsIn zs) = + let + xws = Set.union xs ws + yzs = Set.union ys zs + in + NotOneOf + (Set.filter (\x -> categorize x `notElem` yzs) xws) + (NotAsIn yzs) + x >||< Fail = x + Fail >||< y = y + _ >||< Pass = Pass + Pass >||< _ = Pass + x >||< Alternate y z = Alternate (TokenTest x) (TokenTest (Alternate y z)) + Alternate x y >||< z = Alternate (TokenTest (Alternate x y)) (TokenTest z) + OneOf xs >||< OneOf ys = OneOf (Set.union xs ys) + OneOf xs >||< NotOneOf ys z = + Alternate (TokenTest (OneOf xs)) (TokenTest (NotOneOf ys z)) + NotOneOf xs y >||< OneOf zs = + Alternate (TokenTest (NotOneOf xs y)) (TokenTest (OneOf zs)) + NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (NotAsIn zs) = + NotOneOf (Set.intersection xs ws) (NotAsIn (Set.intersection ys zs)) + NotOneOf xs (AsIn y) >||< NotOneOf ws (AsIn z) = + if y == z then NotOneOf (Set.intersection xs ws) (AsIn y) + else Alternate + (TokenTest (NotOneOf xs (AsIn y))) + (TokenTest (NotOneOf ws (AsIn z))) + NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (AsIn z) = Alternate + (TokenTest (NotOneOf xs (NotAsIn ys))) + (TokenTest (NotOneOf ws (AsIn z))) + NotOneOf xs (AsIn y) >||< NotOneOf ws (NotAsIn zs) = Alternate + (TokenTest (NotOneOf xs (AsIn y))) + (TokenTest (NotOneOf ws (NotAsIn zs))) +deriving stock instance + (Categorized token, Read token, Read alg, Read (Categorize token)) + => Read (RegExam token alg) +deriving stock instance + (Categorized token, Show token, Show alg, Show (Categorize token)) + => Show (RegExam token alg) +deriving stock instance Functor (RegExam token) +deriving stock instance Foldable (RegExam token) +deriving stock instance Traversable (RegExam token) +deriving stock instance (Categorized token, Eq alg) + => Eq (RegExam token alg) +deriving stock instance (Categorized token, Ord alg) + => Ord (RegExam token alg) +deriving stock instance Categorized token => Eq (CategoryTest token) +deriving stock instance Categorized token => Ord (CategoryTest token) +deriving stock instance + (Categorized token, Read token, Read (Categorize token)) + => Read (CategoryTest token) +deriving stock instance + (Categorized token, Show token, Show (Categorize token)) + => Show (CategoryTest token) +deriving newtype instance Categorized token => Eq (TokenTest token) +deriving newtype instance Categorized token => Ord (TokenTest token) +deriving stock instance + (Categorized token, Read token, Read (Categorize token)) + => Read (TokenTest token) +deriving stock instance + (Categorized token, Show token, Show (Categorize token)) + => Show (TokenTest token) +instance (Categorized token, Enum (Categorize token), HasTrie token) + => HasTrie (RegEx token) where + data (RegEx token :->: b) = RegExTrie + { terminalTrie :: [token] :->: b + , nonTerminalTrie :: String :->: b + , sequenceTrie :: (RegEx token, RegEx token) :->: b + , alternateTrie :: (RegEx token, RegEx token) :->: b + , kleeneStarTrie :: RegEx token :->: b + , kleeneOptTrie :: RegEx token :->: b + , kleenePlusTrie :: RegEx token :->: b + , failTrie :: b + , passTrie :: b + , oneOfTrie :: [token] :->: b + , notOneOfTrie :: ([token], Either Int [Int]) :->: b + } + trie f = RegExTrie + { terminalTrie = trie (f . terminal) + , nonTerminalTrie = trie (f . nonTerminal) + , sequenceTrie = trie (f . uncurry (<>)) + , alternateTrie = trie (f . uncurry (>|<)) + , kleeneStarTrie = trie (f . starK) + , kleeneOptTrie = trie (f . optK) + , kleenePlusTrie = trie (f . plusK) + , failTrie = f zeroK + , passTrie = f anyToken + , oneOfTrie = trie (f . oneOf) + , notOneOfTrie = trie (f . testNotOneOf) + } + untrie rex = \case + Terminal word -> untrie (terminalTrie rex) word + NonTerminal name -> untrie (nonTerminalTrie rex) name + Sequence x1 x2 -> untrie (sequenceTrie rex) (x1,x2) + KleeneStar x -> untrie (kleeneStarTrie rex) x + KleenePlus x -> untrie (kleenePlusTrie rex) x + KleeneOpt x -> untrie (kleeneOptTrie rex) x + RegExam Fail -> failTrie rex + RegExam Pass -> passTrie rex + RegExam (OneOf chars) -> untrie (oneOfTrie rex) (Set.toList chars) + RegExam (NotOneOf chars (AsIn cat)) -> + untrie (notOneOfTrie rex) (Set.toList chars, Left (fromEnum cat)) + RegExam (NotOneOf chars (NotAsIn cats)) -> + untrie (notOneOfTrie rex) + (Set.toList chars, Right (Set.toList (Set.map fromEnum cats))) + RegExam (Alternate x1 x2) -> untrie (alternateTrie rex) (x1,x2) + enumerate rex = mconcat + [ first' terminal <$> enumerate (terminalTrie rex) + , first' nonTerminal <$> enumerate (nonTerminalTrie rex) + , first' (uncurry (<>)) <$> enumerate (sequenceTrie rex) + , first' (uncurry (>|<)) <$> enumerate (alternateTrie rex) + , first' starK <$> enumerate (kleeneStarTrie rex) + , first' optK <$> enumerate (kleeneOptTrie rex) + , first' plusK <$> enumerate (kleenePlusTrie rex) + , [(zeroK, failTrie rex)] + , [(anyToken, passTrie rex)] + , first' oneOf <$> enumerate (oneOfTrie rex) + , first' testNotOneOf <$> enumerate (notOneOfTrie rex) + ] +testNotOneOf + :: (Categorized token, Enum (Categorize token)) + => ([token], Either Int [Int]) -> RegEx token +testNotOneOf (chars, catTest) = testB $ + notOneOf chars >&&< + either (asIn . toEnum) (allB (notAsIn . toEnum)) catTest diff --git a/src/Control/Lens/Grammar/Stream.hs b/src/Control/Lens/Grammar/Stream.hs deleted file mode 100644 index b7ebb70..0000000 --- a/src/Control/Lens/Grammar/Stream.hs +++ /dev/null @@ -1,107 +0,0 @@ -module Control.Lens.Grammar.Stream - ( -- * Stream - IsStream - , stream - , stream1 - -- * SepBy - , SepBy (..) - , sepBy - , noSep - -- * Chain - , chain - , chain1 - -- * Utilities - , listed - , streamed - , streamLine - ) where - -import Control.Applicative -import Control.Lens -import Control.Lens.PartialIso -import Data.Profunctor.Distributor -import Data.Profunctor.Monoidal -import GHC.Exts - -type IsStream s = (IsList s, AsEmpty s, Cons s s (Item s) (Item s)) - -streamLine :: (IsList s, Item s ~ Char) => s -> IO () -streamLine = putStrLn . toList - -listed :: (IsList s, IsList t, Item s ~ Item t) => Iso' s t -listed = iso (fromList . toList) (fromList . toList) - -streamed :: (IsStream s, IsStream t, Item s ~ Item t) => Iso' s t -streamed = iso convertStream convertStream - where - convertStream s = - maybe - Empty - (\(h,t) -> cons h (convertStream t)) - (uncons s) - -{- | -prop> stream noSep = manyP --} -stream - :: (Distributor p, IsStream s, IsStream t) - => SepBy (p () ()) - -> p (Item s) (Item t) -> p s t -stream (SepBy beg end sep) p = mapIso eotList $ - beg >* oneP >+< stream1 (sepBy sep) p *< end - -{- | -prop> stream1 noSep p = p >*< manyP p -prop> _Cons >? stream1 noSep p = someP p --} -stream1 - :: (Distributor p, IsStream s, IsStream t) - => SepBy (p () ()) - -> p (Item s) (Item t) -> p (Item s, s) (Item t, t) -stream1 (SepBy beg end sep) p = - beg >* p >*< stream (sepBy sep) p *< end - -{- | Used to sequence multiple times, -separated by a `separateBy`, -begun by a `beginBy`, -and ended by an `endBy`. -} -data SepBy p = SepBy - { beginBy :: p - , endBy :: p - , separateBy :: p - } deriving stock - ( Functor, Foldable, Traversable - , Eq, Ord, Show, Read - ) - -{- | A `SepBy` smart constructor, -setting the `separateBy` field, -with no beginning or ending delimitors, -except by updating `beginBy` or `endBy` fields. -} -sepBy :: Monoidal p => p () () -> SepBy (p () ()) -sepBy = SepBy oneP oneP - -{- | A `SepBy` smart constructor for no separator, -beginning or ending delimiters. -} -noSep :: Monoidal p => SepBy (p () ()) -noSep = sepBy oneP - -chain - :: (Distributor p, Choice p, Alternative (p a)) - => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate - -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern - -> APrism a b () () -- ^ nilary constructor pattern - -> SepBy (p () ()) -> p a b -> p a b -chain assoc pat2 pat0 (SepBy beg end sep) p = - beg >* (pat0 >? oneP <|> chain1 assoc pat2 (sepBy sep) p) *< end - -chain1 - :: (Distributor p, Choice p) - => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate - -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern - -> SepBy (p () ()) -> p a b -> p a b -chain1 assoc pat (SepBy beg end sep) = leftOrRight chainl1 chainr1 - where - leftOrRight a b = case assoc () of Left _ -> a; Right _ -> b - chainl1 p = difoldl pat >? beg >* p >*< manyP (sep >* p) *< end - chainr1 p = difoldr pat >? beg >* manyP (p *< sep) >*< p *< end diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index dc9f9b4..281a3e8 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -1,27 +1,20 @@ module Control.Lens.Grammar.Symbol - ( Terminator - , TerminalSymbol (..) + ( TerminalSymbol (..) , NonTerminalSymbol (..) ) where import Control.Lens.Internal.Equator -import Data.Kind +import Data.Profunctor +import Data.Profunctor.Monoidal -type Terminator token p = - ( token ~ Alphabet (p () ()) - , forall x y. (x ~ (), y ~ ()) => TerminalSymbol (p x y) - ) :: Constraint - -class TerminalSymbol s where - type Alphabet s - terminal :: [Alphabet s] -> s +class TerminalSymbol token s where + terminal :: [token] -> s default terminal - :: (p () () ~ s, Equator' (Alphabet s) p) - => [Alphabet s] -> s + :: (p () () ~ s, Eq token, Equator token token p, Monoidal p, Cochoice p) + => [token] -> s terminal = equator -instance TerminalSymbol [a] where - type Alphabet [a] = a +instance TerminalSymbol a [a] where terminal = id class NonTerminalSymbol s where diff --git a/src/Control/Lens/Grammar/Test.hs b/src/Control/Lens/Grammar/Test.hs deleted file mode 100644 index 95e2bdb..0000000 --- a/src/Control/Lens/Grammar/Test.hs +++ /dev/null @@ -1,156 +0,0 @@ -module Control.Lens.Grammar.Test - ( BooleanAlgebra (..) - , TestAlgebra (..) - , TokenTest (..) - , RegExam (..) - , CategoryExam (..) - ) where - -import Control.Lens.Grammar.Token -import Data.Foldable (foldl') -import Data.Function (on) -import Data.Monoid -import Data.Set (Set) -import qualified Data.Set as Set - -class BooleanAlgebra b where - falseB, trueB :: b - notB :: b -> b - (>&&<), (>||<) :: b -> b -> b - default falseB - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) - => b - default trueB - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) - => b - default notB - :: (b ~ f bool, BooleanAlgebra bool, Functor f) - => b -> b - default (>||<) - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) - => b -> b -> b - default (>&&<) - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) - => b -> b -> b - trueB = pure trueB - falseB = pure falseB - notB = fmap notB - (>&&<) = liftA2 (>&&<) - (>||<) = liftA2 (>||<) - -class BooleanAlgebra (Test alg) => TestAlgebra alg where - type Test alg - test :: Test alg -> alg - -newtype TokenTest token = TokenTest (RegExam token (TokenTest token)) - -data RegExam token alg - = Fail - | Pass - | OneOf (Set token) - | NotOneOf (Set token) (CategoryExam token) - | Alternate alg alg - -data CategoryExam token - = AsIn (Categorize token) - | NotAsIn (Set (Categorize token)) - ---instances -instance BooleanAlgebra Bool where - falseB = False - trueB = True - notB = not - (>&&<) = (&&) - (>||<) = (||) -instance BooleanAlgebra (x -> Bool) -instance (Applicative f, BooleanAlgebra bool) - => BooleanAlgebra (Ap f bool) -deriving newtype instance Categorized token - => BooleanAlgebra (TokenTest token) -instance Categorized token - => BooleanAlgebra (RegExam token (TokenTest token)) where - falseB = Fail - trueB = Pass - notB Fail = Pass - notB Pass = Fail - notB (Alternate (TokenTest x) (TokenTest y)) = x >&&< y - notB (OneOf xs) = NotOneOf xs (NotAsIn Set.empty) - notB (NotOneOf xs (AsIn y)) = - (Alternate `on` TokenTest) - (OneOf xs) - (NotOneOf Set.empty (NotAsIn (Set.singleton y))) - notB (NotOneOf xs (NotAsIn ys)) = - foldl' - (Alternate `on` TokenTest) - (OneOf xs) - (Set.map (NotOneOf Set.empty . AsIn) ys) - _ >&&< Fail = Fail - Fail >&&< _ = Fail - x >&&< Pass = x - Pass >&&< y = y - x >&&< Alternate (TokenTest y) (TokenTest z) = (x >&&< y) >||< (x >&&< z) - Alternate (TokenTest x) (TokenTest y) >&&< z = (x >&&< z) >||< (y >&&< z) - OneOf xs >&&< OneOf ys = OneOf (Set.intersection xs ys) - OneOf xs >&&< NotOneOf ys (AsIn z) = OneOf - (Set.filter (\x -> categorize x == z) (Set.difference xs ys)) - NotOneOf xs (AsIn y) >&&< OneOf zs = OneOf - (Set.filter (\z -> categorize z == y) (Set.difference zs xs)) - OneOf xs >&&< NotOneOf ys (NotAsIn zs) = OneOf - (Set.filter (\x -> notElem (categorize x) zs) (Set.difference xs ys)) - NotOneOf xs (NotAsIn ys) >&&< OneOf zs = OneOf - (Set.filter (\z -> notElem (categorize z) ys) (Set.difference zs xs)) - NotOneOf xs (AsIn y) >&&< NotOneOf ws (AsIn z) = - if y /= z then Fail else NotOneOf - (Set.filter (\x -> categorize x == y) - (Set.union xs ws)) (AsIn y) - NotOneOf xs (AsIn y) >&&< NotOneOf ws (NotAsIn zs) = - if elem y zs then Fail else NotOneOf - (Set.filter (\x -> categorize x == y) - (Set.union xs ws)) (AsIn y) - NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (AsIn z) = - if elem z ys then Fail else NotOneOf - (Set.filter (\x -> categorize x == z) (Set.union xs ws)) - (AsIn z) - NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (NotAsIn zs) = - let - xws = Set.union xs ws - yzs = Set.union ys zs - in - NotOneOf - (Set.filter (\x -> notElem (categorize x) yzs) xws) - (NotAsIn yzs) - x >||< Fail = x - Fail >||< y = y - _ >||< Pass = Pass - Pass >||< _ = Pass - x >||< Alternate y z = Alternate (TokenTest x) (TokenTest (Alternate y z)) - Alternate x y >||< z = Alternate (TokenTest (Alternate x y)) (TokenTest z) - OneOf xs >||< OneOf ys = OneOf (Set.union xs ys) - OneOf xs >||< NotOneOf ys z = - Alternate (TokenTest (OneOf xs)) (TokenTest (NotOneOf ys z)) - NotOneOf xs y >||< OneOf zs = - Alternate (TokenTest (NotOneOf xs y)) (TokenTest (OneOf zs)) - NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (NotAsIn zs) = - NotOneOf (Set.intersection xs ws) (NotAsIn (Set.intersection ys zs)) - NotOneOf xs (AsIn y) >||< NotOneOf ws (AsIn z) = - if y == z then NotOneOf (Set.intersection xs ws) (AsIn y) - else Alternate - (TokenTest (NotOneOf xs (AsIn y))) - (TokenTest (NotOneOf ws (AsIn z))) - NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (AsIn z) = Alternate - (TokenTest (NotOneOf xs (NotAsIn ys))) - (TokenTest (NotOneOf ws (AsIn z))) - NotOneOf xs (AsIn y) >||< NotOneOf ws (NotAsIn zs) = Alternate - (TokenTest (NotOneOf xs (AsIn y))) - (TokenTest (NotOneOf ws (NotAsIn zs))) -deriving stock instance Functor (RegExam token) -deriving stock instance Foldable (RegExam token) -deriving stock instance Traversable (RegExam token) -deriving stock instance (Categorized token, Eq alg) - => Eq (RegExam token alg) -deriving stock instance (Categorized token, Ord alg) - => Ord (RegExam token alg) -deriving stock instance Categorized token => Eq (CategoryExam token) -deriving stock instance Categorized token => Ord (CategoryExam token) -deriving newtype instance Categorized token => Eq (TokenTest token) -deriving newtype instance Categorized token => Ord (TokenTest token) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 738bd08..6a76311 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -1,22 +1,18 @@ module Control.Lens.Grammar.Token - ( -- * Token - Categorized (..) - , Tokenized (..) - , escape - , escapes + ( -- * Tokenized + Tokenized (..) , satisfy , tokens - , Tokenizor -- * Like , oneLike , manyLike , optLike , someLike - -- * Unicode + -- * Categorized + , Categorized (..) , GeneralCategory (..) ) where -import Control.Applicative import Control.Lens import Control.Lens.PartialIso import Data.Char @@ -37,93 +33,59 @@ instance Categorized Char where instance Categorized Word8 instance Categorized () -class Categorized (Token p) => Tokenized p where - type Token p - +class Categorized token => Tokenized token p | p -> token where anyToken :: p - notAnyToken :: p - default notAnyToken :: (p ~ f (Token p), Alternative f) => p - notAnyToken = empty - - token :: Token p -> p + token :: token -> p default token - :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) - => Token p -> p + :: (p ~ q token token, Choice q, Cochoice q) + => token -> p token = satisfy . token - notToken :: Token p -> p - default notToken - :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) - => Token p -> p - notToken = satisfy . notToken - - oneOf :: [Token p] -> p + oneOf :: Foldable f => f token -> p default oneOf - :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) - => [Token p] -> p + :: (p ~ q token token, Choice q, Cochoice q, Foldable f) + => f token -> p oneOf = satisfy . oneOf - notOneOf :: [Token p] -> p + notOneOf :: Foldable f => f token -> p default notOneOf - :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) - => [Token p] -> p + :: (p ~ q token token, Choice q, Cochoice q, Foldable f) + => f token -> p notOneOf = satisfy . notOneOf - asIn :: Categorize (Token p) -> p + asIn :: Categorize token -> p default asIn - :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) - => Categorize (Token p) -> p + :: (p ~ q token token, Choice q, Cochoice q) + => Categorize token -> p asIn = satisfy . asIn - notAsIn :: Categorize (Token p) -> p + notAsIn :: Categorize token -> p default notAsIn - :: (p ~ q (Token p) (Token p), Choice q, Cochoice q) - => Categorize (Token p) -> p + :: (p ~ q token token, Choice q, Cochoice q) + => Categorize token -> p notAsIn = satisfy . notAsIn -instance Categorized token => Tokenized (token -> Bool) where - type Token (token -> Bool) = token +instance Categorized token => Tokenized token (token -> Bool) where anyToken _ = True - notAnyToken _ = False token = (==) - notToken = (/=) oneOf = flip elem notOneOf = flip notElem asIn = lmap categorize . (==) notAsIn = lmap categorize . (/=) -escape - :: (Alternator p, Tokenizor token p) - => [token] -- ^ tokens to escape - -> (p token token -> p token token) -- ^ how to escape a token - -> p token token -escape toEsc f = escapes [(toEsc, f)] - -escapes - :: (Alternator p, Tokenizor token p) - => [([token], p token token -> p token token)] - -- ^ how to escape different token classes - -> p token token -escapes escs = choiceP $ - notOneOf (do (toEsc, _) <- escs; toEsc) - : [f (oneOf toEsc) | (toEsc, f) <- escs] - satisfy - :: (Choice p, Cochoice p, Tokenizor token p) + :: (Choice p, Cochoice p, Tokenized token (p token token)) => (token -> Bool) -> p token token satisfy f = satisfied f >?< anyToken -type Tokenizor token p = - (Tokenized (p token token), Token (p token token) ~ token) - tokens :: ( AsEmpty s, Cons s s a a - , Monoidal p, Choice p, Tokenizor a p + , Monoidal p, Choice p + , Tokenized a (p a a) ) => [a] -> p s s -tokens [] = asEmpty -tokens (a:as) = token a >:< tokens as +tokens = foldr ((>:<) . token) asEmpty {- | `oneLike` consumes one token @@ -131,9 +93,9 @@ of a given token's category while parsing, and produces the given token while printing. -} oneLike - :: forall token p. (Profunctor p, Tokenizor token p) + :: forall token p. (Profunctor p, Tokenized token (p token token)) => token -> p () () -oneLike a = dimap (\_ -> a) (\(_::token) -> ()) (asIn (categorize a)) +oneLike a = dimap (const a) (\(_::token) -> ()) (asIn (categorize a)) {- | `manyLike` consumes zero or more tokens @@ -141,7 +103,7 @@ of a given token's category while parsing, and produces no tokens printing. -} manyLike - :: forall token p. (Distributor p, Tokenizor token p) + :: forall token p. (Distributor p, Tokenized token (p token token)) => token -> p () () manyLike a = dimap (\_ -> []::[token]) (\(_::[token]) -> ()) (manyP (asIn (categorize a))) @@ -152,7 +114,7 @@ of a given token's category while parsing, and produces the given token while printing. -} optLike - :: forall token p. (Distributor p, Tokenizor token p) + :: forall token p. (Distributor p, Tokenized token (p token token)) => token -> p () () optLike a = dimap (\_ -> [a]::[token]) (\(_::[token]) -> ()) (manyP (asIn (categorize a))) @@ -163,7 +125,7 @@ of a given token's category while parsing, and produces the given token while printing. -} someLike - :: forall token p. (Distributor p, Tokenizor token p) + :: forall token p. (Distributor p, Tokenized token (p token token)) => token -> p () () -someLike a = dimap (\_ -> (a,[]::[token])) (\(_::token, _::[token]) -> ()) +someLike a = dimap (const (a, [] :: [token])) (\(_::token, _::[token]) -> ()) (asIn (categorize a) >*< manyP (asIn (categorize a))) diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index ffd3767..7921785 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -1,9 +1,7 @@ module Control.Lens.Internal.Equator - ( -- * + ( -- * Equator Equator (..) - , Equator' , equator - , Identical (..) ) where import Control.Lens @@ -17,7 +15,7 @@ import Data.Profunctor.Monoidal class Equator a b p | p -> a, p -> b where equate :: p a b - default equate :: (Tokenizor token p, a ~ token, b ~ token) => p a b + default equate :: Tokenized token (p a b) => p a b equate = anyToken instance Equator a b (Identical a b) where equate = Identical instance Equator a b (Exchange a b) where @@ -30,7 +28,5 @@ instance (Equator a b p, Profunctor p, Applicative f) => Equator a b (WrappedPafb f p) where equate = WrapPafb (rmap pure equate) -type Equator' a p = (Eq a, Equator a a p, Monoidal p, Cochoice p) - -equator :: (Foldable f, Equator' a p) => f a -> p () () -equator = foldr (\a p -> only a ?< equate *> p) oneP +equator :: (Foldable f, Eq a, Equator a a p, Monoidal p, Cochoice p) => f a -> p () () +equator = foldr (\a -> (only a ?< equate *>)) oneP diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index aa6fa88..fbda406 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -22,6 +22,7 @@ module Control.Lens.PartialIso , PartialExchange (PartialExchange) -- Combinators , partialIso + , involutedMaybe , withPartialIso , clonePartialIso , coPartialIso @@ -31,7 +32,8 @@ module Control.Lens.PartialIso , (>?) , (?<) , (>?<) - , mapIso + , (>~) + , (~<) , coPrism -- * Patterns , satisfied @@ -147,6 +149,9 @@ partialIso :: (s -> Maybe a) -> (b -> Maybe t) -> PartialIso s t a b partialIso f g = unright . iso (maybe (Left ()) Right . f =<<) (mapMaybe g) . right' +involutedMaybe :: (a -> Maybe a) -> PartialIso' a a +involutedMaybe f = partialIso f f + {- | Convert `APartialIso` to the pair of functions that characterize it. -} withPartialIso :: APartialIso s t a b @@ -225,8 +230,14 @@ infixl 4 ?< infixl 4 >?< {- | Action of `AnIso` on `Profunctor`s. -} -mapIso :: Profunctor p => AnIso s t a b -> p a b -> p s t -mapIso pattern = withIso pattern dimap +(>~) :: Profunctor p => AnIso s t a b -> p a b -> p s t +(>~) pattern = withIso pattern dimap +infixl 2 >~ + +{- | Inverse action of `AnIso` on `Profunctor`s. -} +(~<) :: Profunctor p => AnIso b a t s -> p a b -> p s t +(~<) pattern = withIso pattern (flip dimap) +infixl 2 ~< {- | Action of a `coPrism` on the composition of a `Profunctor` and `Filterable`. @@ -237,7 +248,7 @@ 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 +satisfied f = involutedMaybe satiate where satiate a = if f a then Just a else Nothing {- | `nulled` matches an `Empty` pattern, like `_Empty`. -} diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index eebc6ce..954a93a 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -16,6 +16,14 @@ module Data.Profunctor.Distributor , choiceP -- * Homogeneous , Homogeneous (..) + -- * SepBy + , SepBy (..) + , sepBy + , noSep + , several + , several1 + , chain + , chain1 ) where import Control.Applicative hiding (WrappedArrow) @@ -28,7 +36,7 @@ import Data.Bifunctor.Clown import Data.Bifunctor.Joker import Data.Bifunctor.Product import Data.Complex -import Data.Foldable +import Data.Foldable hiding (toList) import Data.Functor.Adjunction import Data.Functor.Compose import Data.Functor.Contravariant.Divisible @@ -48,6 +56,7 @@ import Data.Tagged import Data.Tree (Tree (..)) import Data.Vector (Vector) import Data.Void +import GHC.Exts import GHC.Generics -- Distributor -- @@ -105,11 +114,11 @@ class Monoidal p => Distributor p where {- | One or none. -} optionalP :: p a b -> p (Maybe a) (Maybe b) - optionalP p = mapIso eotMaybe (oneP >+< p) + optionalP p = eotMaybe >~ oneP >+< p {- | Zero or more. -} manyP :: p a b -> p [a] [b] - manyP p = mapIso eotList (oneP >+< p >*< manyP p) + manyP p = eotList >~ oneP >+< p >*< manyP p instance Distributor (->) where zeroP = id @@ -292,9 +301,9 @@ instance Homogeneous Maybe where instance Homogeneous [] where homogeneously = manyP instance Homogeneous Vector where - homogeneously p = mapIso eotList (oneP >+< p >*< homogeneously p) + homogeneously p = eotList >~ oneP >+< p >*< homogeneously p instance Homogeneous Seq where - homogeneously p = mapIso eotList (oneP >+< p >*< homogeneously p) + homogeneously p = eotList >~ oneP >+< p >*< homogeneously p instance Homogeneous Complex where homogeneously p = dimap2 realPart imagPart (:+) p p instance Homogeneous Tree where @@ -366,3 +375,66 @@ instance Alternator p => Alternator (Yoneda p) where alternate (Left p) = proreturn (alternate (Left (proextract p))) alternate (Right p) = proreturn (alternate (Right (proextract p))) someP = proreturn . someP . proextract + +{- | Used to sequence multiple times, +separated by a `separateBy`, +begun by a `beginBy`, +and ended by an `endBy`. -} +data SepBy p = SepBy + { beginBy :: p + , endBy :: p + , separateBy :: p + } deriving stock + ( Functor, Foldable, Traversable + , Eq, Ord, Show, Read + ) + +{- | A `SepBy` smart constructor, +setting the `separateBy` field, +with no beginning or ending delimitors, +except by updating `beginBy` or `endBy` fields. -} +sepBy :: Monoidal p => p () () -> SepBy (p () ()) +sepBy = SepBy oneP oneP + +{- | A `SepBy` smart constructor for no separator, +beginning or ending delimiters. -} +noSep :: Monoidal p => SepBy (p () ()) +noSep = sepBy oneP + +{- | +prop> several noSep = manyP +-} +several + :: (IsList s, IsList t, Distributor p) + => SepBy (p () ()) -> p (Item s) (Item t) -> p s t +several (SepBy beg end sep) p = iso toList fromList . eotList >~ + beg >* (oneP >+< p >*< manyP (sep >* p)) *< end + +{- | +prop> several1 noSep p = someP p +-} +several1 + :: (IsList s, IsList t, Distributor p, Choice p) + => SepBy (p () ()) -> p (Item s) (Item t) -> p s t +several1 (SepBy beg end sep) p = iso toList fromList . _Cons >? + beg >* (p >*< manyP (sep >* p)) *< end + +chain + :: Alternator p + => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate + -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern + -> APrism a b () () -- ^ nilary constructor pattern + -> SepBy (p () ()) -> p a b -> p a b +chain association pat2 pat0 (SepBy beg end sep) p = + beg >* (pat0 >? oneP <|> chain1 association pat2 (sepBy sep) p) *< end + +chain1 + :: (Distributor p, Choice p) + => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate + -> APartialIso a b (a,a) (b,b) -- ^ binary constructor pattern + -> SepBy (p () ()) -> p a b -> p a b +chain1 association pat (SepBy beg end sep) = leftOrRight chainl1 chainr1 + where + leftOrRight a b = case association () of Left _ -> a; Right _ -> b + chainl1 p = difoldl pat >? beg >* p >*< manyP (sep >* p) *< end + chainr1 p = difoldr pat >? beg >* manyP (p *< sep) >*< p *< end diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index e6a5560..c671817 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -19,10 +19,10 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Control.Lens +import Control.Lens.Extras import Control.Lens.Internal.Equator import Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Kleene -import Control.Lens.Grammar.Stream import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Control.Monad @@ -118,31 +118,37 @@ instance Filterable f => Filtrator (Parsor s t f) where leftMay (e, str) = either (\b -> Just (b, str)) (\_ -> Nothing) e rightMay (e, str) = either (\_ -> Nothing) (\b -> Just (b, str)) e instance - ( Categorized a, a ~ Item s, IsStream s + ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => Tokenized (Parsor s s m a a) where - type Token (Parsor s s m a a) = a + ) => Tokenized a (Parsor s s m a a) where anyToken = Parsor (maybe empty pure . uncons) instance - ( Categorized a, a ~ Item s, IsStream s + ( Categorized a, a ~ Item s, IsList s, Cons s s a a + , Filterable m, Alternative m, Monad m + ) => TestAlgebra (TokenTest a) (Parsor s s m a a) +instance + ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m ) => Equator a a (Parsor s s m) instance - ( Categorized a, a ~ Item s, IsStream s + ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TerminalSymbol (Parsor s s m () ()) where - type Alphabet (Parsor s s m () ()) = Item s + ) => TerminalSymbol a (Parsor s s m () ()) instance - ( Char ~ Item s, IsStream s + ( Char ~ Item s, IsList s, Cons s s Char Char , Filterable m, Alternative m, Monad m ) => IsString (Parsor s s m () ()) where fromString = terminal instance - ( Char ~ Item s, IsStream s + ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m ) => IsString (Parsor s s m s s) where fromString = tokens instance BackusNaurForm (Parsor s t m a b) +instance AsEmpty t => Matching s (Parsor s t Maybe a b) where + word =~ parsor = case runParsor parsor word of + Nothing -> False + Just (_,t) -> is _Empty t -- Printor instances instance Functor f => Functor (Printor s t f a) where @@ -231,27 +237,29 @@ instance (Alternative f, Monad f) => ArrowChoice (Printor s s f) where left = left' right = right' instance - ( Categorized a, a ~ Item s, IsStream s + ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => Tokenized (Printor s s m a a) where - type Token (Printor s s m a a) = a + ) => Tokenized a (Printor s s m a a) where anyToken = Printor (\b -> pure (b, cons b)) instance - ( Categorized a, a ~ Item s, IsStream s + ( Categorized a, a ~ Item s, IsList s, Cons s s a a + , Filterable m, Alternative m, Monad m + ) => TestAlgebra (TokenTest a) (Printor s s m a a) +instance + ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m ) => Equator a a (Printor s s m) instance - ( Categorized a, a ~ Item s, IsStream s + ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TerminalSymbol (Printor s s m () ()) where - type Alphabet (Printor s s m () ()) = Item s + ) => TerminalSymbol a (Printor s s m () ()) where instance - ( Char ~ Item s, IsStream s + ( Char ~ Item s, IsList s, Cons s s Char Char , Filterable m, Alternative m, Monad m ) => IsString (Printor s s m () ()) where fromString = terminal instance - ( Char ~ Item s, IsStream s + ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m ) => IsString (Printor s s m s s) where fromString = tokens @@ -285,14 +293,14 @@ instance (Monoid t, Applicative f) Grammor (liftA2 (liftA2 (<>)) rex1 rex2) instance (KleeneStarAlgebra t, Applicative f) => Alternative (Grammor s t f a) where - empty = Grammor (pure (pure empK)) + empty = Grammor (pure (pure zeroK)) Grammor rex1 <|> Grammor rex2 = Grammor (liftA2 (liftA2 (>|<)) rex1 rex2) many (Grammor rex) = Grammor (fmap (fmap starK) rex) some (Grammor rex) = Grammor (fmap (fmap plusK) rex) instance (KleeneStarAlgebra t, Applicative f) => Distributor (Grammor s t f) where - zeroP = Grammor (pure (pure empK)) + zeroP = Grammor (pure (pure zeroK)) Grammor rex1 >+< Grammor rex2 = Grammor (liftA2 (liftA2 (>|<)) rex1 rex2) manyP (Grammor rex) = Grammor (fmap (fmap starK) rex) @@ -301,20 +309,19 @@ instance (KleeneStarAlgebra t, Applicative f) => Alternator (Grammor s t f) where alternate = either coerce coerce someP (Grammor rex) = Grammor (fmap (fmap plusK) rex) -instance (Tokenized t, Applicative f) - => Tokenized (Grammor s t f a b) where - type Token (Grammor s t f a b) = Token t +instance (Tokenized token t, Applicative f) + => Tokenized token (Grammor s t f a b) where anyToken = grammor anyToken - notAnyToken = grammor notAnyToken token = grammor . token - notToken = grammor . notToken oneOf = grammor . oneOf notOneOf = grammor . notOneOf asIn = grammor . asIn notAsIn = grammor . notAsIn -instance (TerminalSymbol t, Applicative f) - => TerminalSymbol (Grammor s t f a b) where - type Alphabet (Grammor s t f a b) = Alphabet t +instance (TestAlgebra bool t, Applicative f) + => TestAlgebra bool (Grammor s t f a b) where + testB = grammor . testB +instance (TerminalSymbol token t, Applicative f) + => TerminalSymbol token (Grammor s t f a b) where terminal = grammor . terminal instance (Comonad f, Applicative f, Monoid s, BackusNaurForm t) => BackusNaurForm (Grammor s t f a b) where diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index cd4468d..76f2ecb 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -5,7 +5,8 @@ module Data.Profunctor.Monoidal Monoidal , oneP, (>*<), (>*), (*<) , dimap2, foreverP, replicateP - , meander, (>:<), asEmpty + , (>:<), asEmpty + , meander, eotFunList ) where import Control.Applicative hiding (WrappedArrow) @@ -105,6 +106,15 @@ replicateP => p a b -> p (t a) (t b) replicateP p = traverse (\f -> lmap f p) (distribute id) +{- | A `Monoidal` nil operator. -} +asEmpty :: (AsEmpty s, Monoidal p, Choice p) => p s s +asEmpty = _Empty >? oneP + +{- | A `Monoidal` cons operator. -} +(>:<) :: (Cons s t a b, Monoidal p, Choice p) => p a b -> p s t -> p s t +x >:< xs = _Cons >? x >*< xs +infixr 5 >:< + {- | For any `Monoidal`, `Choice` & `Strong` `Profunctor`, `meander` is invertible and gives a default implementation for the `Data.Profunctor.Traversing.wander` @@ -117,34 +127,39 @@ See Pickering, Gibbons & Wu, meander :: (Monoidal p, Choice p) => ATraversal s t a b -> p a b -> p s t -meander f = dimap (f sell) iextract . trav +meander f = dimap (f sell) iextract . meandering where - trav + meandering :: (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` nil operator. -} -asEmpty :: (AsEmpty s, Monoidal p, Choice p) => p s s -asEmpty = _Empty >? oneP - -{- | A `Monoidal` cons operator. -} -(>:<) :: (Cons s t a b, Monoidal p, Choice p) => p a b -> p s t -> p s t -x >:< xs = _Cons >? x >*< xs -infixr 5 >:< - --- FunList -- + meandering q = eotFunList >~ right' (q >*< meandering q) {- | -`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] +`eotFunList` is used to define `meander`. +See van Laarhoven, [A non-regular data type challenge] +(https://twanvl.nl/blog/haskell/non-regular1), +both post and comments, for details. -} +eotFunList :: 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))) +eotFunList = iso (f . toFun) (fromFun . 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 data FunList a b t = DoneFun t | MoreFun a (Bazaar (->) a b (b -> t)) +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 instance Functor (FunList a b) where fmap f = \case DoneFun t -> DoneFun (f t) @@ -157,26 +172,6 @@ instance Applicative (FunList a b) where 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 diff --git a/test/Spec.hs b/test/Spec.hs index 7012295..2ab3067 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,34 +3,34 @@ module Main (main) where import Data.Char import Data.Foldable import Data.List (nub) -import Text.Grammar.Distributor +import Control.Lens.Grammar 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 "\\") (OneOf "$()*+.?[\\]^{|}")) - ,("char-literal",NotOneOf "$()*+.?[\\]^{|}") - ,("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")) - ] +-- expectedRegexGrammar :: [(String, RegExStr)] +-- 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 "\\") (OneOf "$()*+.?[\\]^{|}")) + -- ,("char-literal",NotOneOf "$()*+.?[\\]^{|}") + -- ,("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 = From 36fe23f2d457a2213bfa3fbd2eecf6027a1f6e37 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 07:26:55 -0800 Subject: [PATCH 113/282] stuff --- src/Control/Lens/Grammar/Symbol.hs | 6 +- src/Control/Lens/Grammar/Token.hs | 6 ++ src/Control/Lens/Internal/Equator.hs | 6 -- test/Spec.hs | 94 ++++++++++++++-------------- 4 files changed, 57 insertions(+), 55 deletions(-) diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index 281a3e8..d8f8cbf 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -3,16 +3,16 @@ module Control.Lens.Grammar.Symbol , NonTerminalSymbol (..) ) where -import Control.Lens.Internal.Equator +import Control.Lens.Grammar.Token import Data.Profunctor import Data.Profunctor.Monoidal class TerminalSymbol token s where terminal :: [token] -> s default terminal - :: (p () () ~ s, Eq token, Equator token token p, Monoidal p, Cochoice p) + :: (p () () ~ s, Tokenized token (p token token), Monoidal p, Cochoice p) => [token] -> s - terminal = equator + terminal = terminator instance TerminalSymbol a [a] where terminal = id diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 6a76311..273e1a4 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -3,6 +3,7 @@ module Control.Lens.Grammar.Token Tokenized (..) , satisfy , tokens + , terminator -- * Like , oneLike , manyLike @@ -87,6 +88,11 @@ tokens => [a] -> p s s tokens = foldr ((>:<) . token) asEmpty +terminator + :: (Foldable f, Eq a, Monoidal p, Cochoice p, Tokenized token (p a a)) + => f a -> p () () +terminator = foldr (\a -> (only a ?< anyToken *>)) oneP + {- | `oneLike` consumes one token of a given token's category while parsing, diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index 7921785..a8dd083 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -1,7 +1,6 @@ module Control.Lens.Internal.Equator ( -- * Equator Equator (..) - , equator ) where import Control.Lens @@ -10,8 +9,6 @@ import Control.Lens.Internal.Iso import Control.Lens.Internal.Prism import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso -import Data.Profunctor -import Data.Profunctor.Monoidal class Equator a b p | p -> a, p -> b where equate :: p a b @@ -27,6 +24,3 @@ instance Equator a b (PartialExchange a b) where instance (Equator a b p, Profunctor p, Applicative f) => Equator a b (WrappedPafb f p) where equate = WrapPafb (rmap pure equate) - -equator :: (Foldable f, Eq a, Equator a a p, Monoidal p, Cochoice p) => f a -> p () () -equator = foldr (\a -> (only a ?< equate *>)) oneP diff --git a/test/Spec.hs b/test/Spec.hs index 2ab3067..157d299 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,64 +1,66 @@ module Main (main) where import Data.Char -import Data.Foldable -import Data.List (nub) +import Data.Foldable hiding (toList) +import Data.String +import GHC.Exts import Control.Lens.Grammar +import Control.Lens.Grammar.Kleene +import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token import Test.Hspec -- expectedRegexGrammar :: [(String, RegExStr)] -- 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 "\\") (OneOf "$()*+.?[\\]^{|}")) - -- ,("char-literal",NotOneOf "$()*+.?[\\]^{|}") - -- ,("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")) + -- [("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 "\\") (oneOf "$()*+.?[\\]^{|}")) + -- ,("char-literal",notOneOf "$()*+.?[\\]^{|}") + -- ,("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",plusK (nonTerminal "char")) -- ] -regexExamples :: [(RegEx, String)] +regexExamples :: [(RegString, 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, ".") - , (OneOf "abc", "[abc]") - , (NotOneOf "abc", "[^abc]") - , (AsIn UppercaseLetter, "\\p{Lu}") - , (NotAsIn LowercaseLetter, "\\P{Ll}") - , (NonTerminal "rule-name", "\\q{rule-name}") - , (Terminal "", "") + [ (terminal "abc123etc.", "abc123etc\\.") + , (terminal "x" <> terminal "y", "xy") + , (zeroK, "\\q") + , (terminal "x" >|< terminal "y", "x|y") + , (optK (terminal "x"), "x?") + , (starK (terminal "x"), "x*") + , (plusK (terminal "x"), "x+") + , (anyToken, ".") + , (oneOf "abc", "[abc]") + , (notOneOf "abc", "[^abc]") + , (asIn UppercaseLetter, "\\p{Lu}") + , (notAsIn 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 + -- 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 + it ("should print " <> show (runRegString rex) <> " correctly") $ + toList rex `shouldBe` str it ("should parse " <> str <> " correctly") $ do - let parses = readGrammar regexGrammar str - parses `shouldSatisfy` elem rex - length (nub (map regexNorm parses)) `shouldBe` 1 + fromString str `shouldBe` rex From 0fad09316c083301d6af7af606904962e683c238 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 08:24:26 -0800 Subject: [PATCH 114/282] fix grammar & tests --- src/Control/Lens/Grammar.hs | 17 ++++++------- test/Spec.hs | 48 +++++++++++++++---------------------- 2 files changed, 28 insertions(+), 37 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index d15385c..e9716d1 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -118,13 +118,14 @@ altG rex = rule "alternate" $ chain1 Left (_RegExam . _Alternate) (sepBy (terminal "|")) (seqG rex) seqG :: Grammarr Char (RegEx Char) (RegEx Char) -seqG rex = rule "sequence" $ - chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) +seqG rex = rule "sequence" $ choiceP + [ _Terminal >? manyP charG + , chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) + ] exprG :: Grammarr Char (RegEx Char) (RegEx Char) exprG rex = rule "expression" $ choiceP - [ _Terminal >? someP charG - , _KleeneOpt >? atomG rex *< terminal "?" + [ _KleeneOpt >? atomG rex *< terminal "?" , _KleeneStar >? atomG rex *< terminal "*" , _KleenePlus >? atomG rex *< terminal "+" , atomG rex @@ -136,10 +137,10 @@ atomG rex = rule "atom" $ choiceP , _Terminal >? charG >:< pure "" , _RegExam . _Pass >? terminal "." , _RegExam . _OneOf >? - terminal "[" >* several noSep charG *< terminal "]" + terminal "[" >* several1 noSep charG *< terminal "]" , _RegExam . _NotOneOf >? - terminal "[^" >* several noSep charG - >*< (catTestG <|> pure (NotAsIn Set.empty)) + terminal "[^" >* several1 noSep charG + >*< (pure (NotAsIn Set.empty) <|> catTestG) *< terminal "]" , _RegExam . _NotOneOf >? pure Set.empty >*< catTestG , terminal "(" >* rex *< terminal ")" @@ -149,7 +150,7 @@ catTestG :: Grammar Char (CategoryTest Char) catTestG = rule "category-test" $ choiceP [ _AsIn >? terminal "\\p{" >* categoryG *< terminal "}" , _NotAsIn >? terminal "\\P{" >* - several (sepBy (terminal "|")) categoryG + several1 (sepBy (terminal "|")) categoryG *< terminal "}" ] diff --git a/test/Spec.hs b/test/Spec.hs index 157d299..0a047d7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,39 +2,28 @@ module Main (main) where import Data.Char import Data.Foldable hiding (toList) -import Data.String -import GHC.Exts +import Data.Functor.Identity import Control.Lens.Grammar import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token +import Data.Profunctor.Grammar +import GHC.Exts import Test.Hspec --- expectedRegexGrammar :: [(String, RegExStr)] --- 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 "\\") (oneOf "$()*+.?[\\]^{|}")) - -- ,("char-literal",notOneOf "$()*+.?[\\]^{|}") - -- ,("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",plusK (nonTerminal "char")) - -- ] +expectedRegexGrammar :: [String] +expectedRegexGrammar = + [ "start = \\q{regex}","alternate = \\q{sequence}(\\|\\q{sequence})*" + , "atom = \\q{nonterminal}|\\q{char}|\\.|\\[\\q{char}+\\]|\\[(\\q{char}+\\q{category-test}?)\\]|\\q{category-test}|\\(\\q{regex}\\)" + , "category = Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn" + , "category-test = \\\\\\q{category}\\}|\\\\(\\q{category}(\\|\\q{category})*)\\}" + , "char = [^\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\\\\\q{char-escaped}" + , "char-control-abbrev = NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC" + , "char-escaped = [\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control-abbrev}" + , "expression = \\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}" + , "nonterminal = \\\\(\\{\\q{char}*\\})?" + , "regex = \\q{alternate}","sequence = \\q{char}*|\\q{expression}*" + ] regexExamples :: [(RegString, String)] regexExamples = @@ -57,8 +46,9 @@ regexExamples = main :: IO () main = hspec $ do describe "regexGrammar" $ do - -- it "should generate a correct grammar" $ - -- genGrammar regexGrammar `shouldBe` expectedRegexGrammar + it "should generate a correct grammar" $ do + let gramString :: RegBnfString = evalGrammor @() @Identity regexGrammar + lines (toList gramString) `shouldBe` expectedRegexGrammar for_ regexExamples $ \(rex, str) -> do it ("should print " <> show (runRegString rex) <> " correctly") $ toList rex `shouldBe` str From f6d4ae343f3916a3ed888756217c450545f1b939 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 08:39:00 -0800 Subject: [PATCH 115/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 273e1a4..c35f3d2 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -81,11 +81,11 @@ satisfy satisfy f = satisfied f >?< anyToken tokens - :: ( AsEmpty s, Cons s s a a + :: ( Foldable f, AsEmpty s, Cons s s a a , Monoidal p, Choice p , Tokenized a (p a a) ) - => [a] -> p s s + => f a -> p s s tokens = foldr ((>:<) . token) asEmpty terminator From fe5f98f64b8184f8ba82e3d436d0ad30b19f9a20 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 08:43:37 -0800 Subject: [PATCH 116/282] names --- src/Control/Lens/Grammar/Token.hs | 6 +++--- src/Data/Profunctor/Grammar.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index c35f3d2..0ee2f91 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -2,7 +2,7 @@ module Control.Lens.Grammar.Token ( -- * Tokenized Tokenized (..) , satisfy - , tokens + , tokenizer , terminator -- * Like , oneLike @@ -80,13 +80,13 @@ satisfy => (token -> Bool) -> p token token satisfy f = satisfied f >?< anyToken -tokens +tokenizer :: ( Foldable f, AsEmpty s, Cons s s a a , Monoidal p, Choice p , Tokenized a (p a a) ) => f a -> p s s -tokens = foldr ((>:<) . token) asEmpty +tokenizer = foldr ((>:<) . token) asEmpty terminator :: (Foldable f, Eq a, Monoidal p, Cochoice p, Tokenized token (p a a)) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index c671817..7413116 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -143,7 +143,7 @@ instance ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m ) => IsString (Parsor s s m s s) where - fromString = tokens + fromString = tokenizer instance BackusNaurForm (Parsor s t m a b) instance AsEmpty t => Matching s (Parsor s t Maybe a b) where word =~ parsor = case runParsor parsor word of @@ -262,7 +262,7 @@ instance ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m ) => IsString (Printor s s m s s) where - fromString = tokens + fromString = tokenizer instance BackusNaurForm (Printor s t m a b) -- Grammor instances From 31ca6eb7473b1e571e5645277062f7f6eae21361 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 08:50:30 -0800 Subject: [PATCH 117/282] evalGrammor_ --- src/Data/Profunctor/Grammar.hs | 3 +++ test/Spec.hs | 3 +-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 7413116..5a88408 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -9,6 +9,7 @@ module Data.Profunctor.Grammar , Grammor (..) , grammor , evalGrammor + , evalGrammor_ ) where import Control.Applicative @@ -52,6 +53,8 @@ grammor :: Applicative f => t -> Grammor s t f a b grammor = Grammor . pure . pure evalGrammor :: (Monoid s, Comonad f) => Grammor s t f a b -> t evalGrammor = extract . extract . runGrammor +evalGrammor_ :: Grammor () t Identity a b -> t +evalGrammor_ = evalGrammor -- Parsor instances instance Functor f => Functor (Parsor s t f a) where diff --git a/test/Spec.hs b/test/Spec.hs index 0a047d7..3d62688 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,7 +2,6 @@ module Main (main) where import Data.Char import Data.Foldable hiding (toList) -import Data.Functor.Identity import Control.Lens.Grammar import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol @@ -47,7 +46,7 @@ main :: IO () main = hspec $ do describe "regexGrammar" $ do it "should generate a correct grammar" $ do - let gramString :: RegBnfString = evalGrammor @() @Identity regexGrammar + let gramString = evalGrammor_ regexGrammar :: RegBnfString lines (toList gramString) `shouldBe` expectedRegexGrammar for_ regexExamples $ \(rex, str) -> do it ("should print " <> show (runRegString rex) <> " correctly") $ From ec8c7dc66836efe4bd696ead5ba2cb7b140d00ce Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 11:59:00 -0800 Subject: [PATCH 118/282] fix atomG --- src/Control/Lens/Grammar.hs | 2 +- test/Spec.hs | 14 +++++++++----- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index e9716d1..4fb1ca4 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -134,7 +134,7 @@ exprG rex = rule "expression" $ choiceP atomG :: Grammarr Char (RegEx Char) (RegEx Char) atomG rex = rule "atom" $ choiceP [ nonterminalG - , _Terminal >? charG >:< pure "" + , _Terminal . _Cons >? charG >*< prismGrammar _Empty , _RegExam . _Pass >? terminal "." , _RegExam . _OneOf >? terminal "[" >* several1 noSep charG *< terminal "]" diff --git a/test/Spec.hs b/test/Spec.hs index 3d62688..6195bbe 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,16 +12,18 @@ import Test.Hspec expectedRegexGrammar :: [String] expectedRegexGrammar = - [ "start = \\q{regex}","alternate = \\q{sequence}(\\|\\q{sequence})*" - , "atom = \\q{nonterminal}|\\q{char}|\\.|\\[\\q{char}+\\]|\\[(\\q{char}+\\q{category-test}?)\\]|\\q{category-test}|\\(\\q{regex}\\)" + [ "start = \\q{regex}" + , "alternate = \\q{sequence}(\\|\\q{sequence})*" + , "atom = \\q{nonterminal}|\\q{char}|\\.|\\[\\q{char}+\\]|(\\[\\^)(\\q{char}+\\q{category-test}?)\\]|\\q{category-test}|\\(\\q{regex}\\)" , "category = Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn" - , "category-test = \\\\\\q{category}\\}|\\\\(\\q{category}(\\|\\q{category})*)\\}" + , "category-test = (\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}" , "char = [^\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\\\\\q{char-escaped}" , "char-control-abbrev = NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC" , "char-escaped = [\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control-abbrev}" , "expression = \\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}" - , "nonterminal = \\\\(\\{\\q{char}*\\})?" - , "regex = \\q{alternate}","sequence = \\q{char}*|\\q{expression}*" + , "nonterminal = (\\\\q)(\\{\\q{char}*\\})?" + , "regex = \\q{alternate}" + , "sequence = \\q{char}*|\\q{expression}*" ] regexExamples :: [(RegString, String)] @@ -40,6 +42,8 @@ regexExamples = , (notAsIn LowercaseLetter, "\\P{Ll}") , (nonTerminal "rule-name", "\\q{rule-name}") , (terminal "", "") + , (optK (terminal "abc"), "(abc)?") + , (optK (terminal "abc") <> nonTerminal "xyz", "(abc)?\\q{xyz}") ] main :: IO () From c1bd68c3363f232c13bc44a50312c2b4132d582b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 12:01:10 -0800 Subject: [PATCH 119/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 4fb1ca4..54e53ea 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -134,7 +134,7 @@ exprG rex = rule "expression" $ choiceP atomG :: Grammarr Char (RegEx Char) (RegEx Char) atomG rex = rule "atom" $ choiceP [ nonterminalG - , _Terminal . _Cons >? charG >*< prismGrammar _Empty + , _Terminal . _Cons >? charG >*< (_Empty >? oneP) , _RegExam . _Pass >? terminal "." , _RegExam . _OneOf >? terminal "[" >* several1 noSep charG *< terminal "]" @@ -229,7 +229,7 @@ charsControl = nonterminalG :: Grammar Char (RegEx Char) nonterminalG = rule "nonterminal" $ terminal "\\q" >* choiceP [ _NonTerminal >? terminal "{" >* manyP charG *< terminal "}" - , prismGrammar (_RegExam . _Fail) + , _RegExam . _Fail >? oneP ] bnfGrammarr :: Ord rule => RegGrammarr Char rule (Bnf rule) From a4440ed23d51b16cdd0f5ea3c8dc4f458683ca18 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 12:12:49 -0800 Subject: [PATCH 120/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 54e53ea..d604edd 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -134,7 +134,7 @@ exprG rex = rule "expression" $ choiceP atomG :: Grammarr Char (RegEx Char) (RegEx Char) atomG rex = rule "atom" $ choiceP [ nonterminalG - , _Terminal . _Cons >? charG >*< (_Empty >? oneP) + , _Terminal >? charG >:< asEmpty , _RegExam . _Pass >? terminal "." , _RegExam . _OneOf >? terminal "[" >* several1 noSep charG *< terminal "]" From 14cdf291b2fafc547af550e93d3d5165707aabd7 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 16:22:05 -0800 Subject: [PATCH 121/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 5a88408..65aec4e 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -173,10 +173,7 @@ instance Filterable f => Filterable (Printor s s f a) where mapMaybe (\(a,q) -> fmap (, q) (f a)) . p instance Monad f => Monad (Printor s s f a) where return = pure - mx >>= f = Printor $ \ctx -> do - (x, p) <- runPrintor mx ctx - (y, q) <- runPrintor (f x) ctx - return (y, p . q) + mx >>= f = composeP (fmap f mx) instance (Alternative f, Monad f) => MonadPlus (Printor s s f a) instance MonadError e m => MonadError e (Printor s s m a) where throwError = liftP . throwError @@ -208,9 +205,17 @@ instance Alternative f => Alternator (Printor s s f) where either (\_ -> empty) (fmap (first' Right) . p) instance Filterable f => Filtrator (Printor s s f) where filtrate (Printor p) = - ( Printor (mapMaybe (\case{(Left b, q) -> Just (b, q); _ -> Nothing}) . p . Left) - , Printor (mapMaybe (\case{(Right b, q) -> Just (b, q); _ -> Nothing}) . p . Right) - ) + let + leftMaybe = \case + (Left b, q) -> Just (b, q) + _ -> Nothing + rightMaybe = \case + (Right b, q) -> Just (b, q) + _ -> Nothing + in + ( Printor (mapMaybe leftMaybe . p . Left) + , Printor (mapMaybe rightMaybe . p . Right) + ) instance Alternative f => Choice (Printor s s f) where left' = alternate . Left right' = alternate . Right @@ -218,8 +223,10 @@ instance Filterable f => Cochoice (Printor s s f) where unleft = fst . filtrate unright = snd . filtrate instance Functor f => Strong (Printor s s f) where - first' (Printor p) = Printor (\(a,c) -> fmap (\(b,q) -> ((b,c),q)) (p a)) - second' (Printor p) = Printor (\(c,a) -> fmap (\(b,q) -> ((c,b),q)) (p a)) + first' (Printor p) = + Printor (\(a,c) -> fmap (\(b,q) -> ((b,c),q)) (p a)) + second' (Printor p) = + Printor (\(c,a) -> fmap (\(b,q) -> ((c,b),q)) (p a)) instance Monad f => Category (Printor s s f) where id = Printor $ \a -> return (a, id) Printor q . Printor p = Printor $ \a -> do From eb45edc9d79d60df024555d3b0d4d4c24f26e9de Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 18:51:04 -0800 Subject: [PATCH 122/282] fromTokens --- src/Control/Lens/Grammar/Token.hs | 8 ++++---- src/Data/Profunctor/Grammar.hs | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 0ee2f91..c520488 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -2,7 +2,7 @@ module Control.Lens.Grammar.Token ( -- * Tokenized Tokenized (..) , satisfy - , tokenizer + , fromTokens , terminator -- * Like , oneLike @@ -80,18 +80,18 @@ satisfy => (token -> Bool) -> p token token satisfy f = satisfied f >?< anyToken -tokenizer +fromTokens :: ( Foldable f, AsEmpty s, Cons s s a a , Monoidal p, Choice p , Tokenized a (p a a) ) => f a -> p s s -tokenizer = foldr ((>:<) . token) asEmpty +fromTokens = foldr ((>:<) . token) asEmpty terminator :: (Foldable f, Eq a, Monoidal p, Cochoice p, Tokenized token (p a a)) => f a -> p () () -terminator = foldr (\a -> (only a ?< anyToken *>)) oneP +terminator = foldr (\a p -> only a ?< anyToken *> p) oneP {- | `oneLike` consumes one token diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 65aec4e..8d4f773 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -146,7 +146,7 @@ instance ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m ) => IsString (Parsor s s m s s) where - fromString = tokenizer + fromString = fromTokens instance BackusNaurForm (Parsor s t m a b) instance AsEmpty t => Matching s (Parsor s t Maybe a b) where word =~ parsor = case runParsor parsor word of @@ -272,7 +272,7 @@ instance ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m ) => IsString (Printor s s m s s) where - fromString = tokenizer + fromString = fromTokens instance BackusNaurForm (Printor s t m a b) -- Grammor instances From 31ccc80ef8459c02cc00dd972fb61c5d11869bb5 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 19:04:54 -0800 Subject: [PATCH 123/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index c520488..9e63d66 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -82,14 +82,13 @@ satisfy f = satisfied f >?< anyToken fromTokens :: ( Foldable f, AsEmpty s, Cons s s a a - , Monoidal p, Choice p - , Tokenized a (p a a) + , Monoidal p, Choice p, Tokenized a (p a a) ) => f a -> p s s fromTokens = foldr ((>:<) . token) asEmpty terminator - :: (Foldable f, Eq a, Monoidal p, Cochoice p, Tokenized token (p a a)) + :: (Foldable f, Monoidal p, Cochoice p, Tokenized a (p a a)) => f a -> p () () terminator = foldr (\a p -> only a ?< anyToken *> p) oneP From 733e21a03d1b019fff5f96a7f1c2f9a932407794 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 4 Dec 2025 20:04:31 -0800 Subject: [PATCH 124/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 9e63d66..b5a7bd0 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -76,19 +76,22 @@ instance Categorized token => Tokenized token (token -> Bool) where notAsIn = lmap categorize . (/=) satisfy - :: (Choice p, Cochoice p, Tokenized token (p token token)) - => (token -> Bool) -> p token token + :: (Tokenized a (p a a), Choice p, Cochoice p) + => (a -> Bool) -> p a a satisfy f = satisfied f >?< anyToken fromTokens - :: ( Foldable f, AsEmpty s, Cons s s a a - , Monoidal p, Choice p, Tokenized a (p a a) + :: ( Foldable f, Tokenized a (p a a) + , Monoidal p, Choice p + , AsEmpty s, Cons s s a a ) => f a -> p s s fromTokens = foldr ((>:<) . token) asEmpty terminator - :: (Foldable f, Monoidal p, Cochoice p, Tokenized a (p a a)) + :: ( Foldable f, Tokenized a (p a a) + , Monoidal p, Cochoice p + ) => f a -> p () () terminator = foldr (\a p -> only a ?< anyToken *> p) oneP From aa55af2d1bd03c979bfc91ab6e4ba7d17c6aee2e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 5 Dec 2025 08:49:46 -0800 Subject: [PATCH 125/282] anyG & failG --- src/Control/Lens/Grammar.hs | 16 +++++++++------- test/Spec.hs | 5 +++-- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index d604edd..c1cdb67 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -131,11 +131,16 @@ exprG rex = rule "expression" $ choiceP , atomG rex ] +anyG :: Grammar Char () +anyG = rule "any-token" $ + terminal "." <|> terminal "[^]" <|> terminal "\\P{}" <|> terminal "[^\\P{}]" + atomG :: Grammarr Char (RegEx Char) (RegEx Char) atomG rex = rule "atom" $ choiceP - [ nonterminalG + [ _NonTerminal >? terminal "\\q{" >* manyP charG *< terminal "}" , _Terminal >? charG >:< asEmpty - , _RegExam . _Pass >? terminal "." + , _RegExam . _Fail >? failG + , _RegExam . _Pass >? anyG , _RegExam . _OneOf >? terminal "[" >* several1 noSep charG *< terminal "]" , _RegExam . _NotOneOf >? @@ -226,11 +231,8 @@ charsControl = , ("ST", '\x9C'), ("OSC", '\x9D'), ("PM", '\x9E'), ("APC", '\x9F') ] -nonterminalG :: Grammar Char (RegEx Char) -nonterminalG = rule "nonterminal" $ terminal "\\q" >* choiceP - [ _NonTerminal >? terminal "{" >* manyP charG *< terminal "}" - , _RegExam . _Fail >? oneP - ] +failG :: Grammar Char () +failG = rule "fail" $ terminal "\\q" <|> terminal "[]" bnfGrammarr :: Ord rule => RegGrammarr Char rule (Bnf rule) bnfGrammarr p = dimap hither thither $ startG >*< rulesG diff --git a/test/Spec.hs b/test/Spec.hs index 6195bbe..c2f556d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,14 +14,15 @@ expectedRegexGrammar :: [String] expectedRegexGrammar = [ "start = \\q{regex}" , "alternate = \\q{sequence}(\\|\\q{sequence})*" - , "atom = \\q{nonterminal}|\\q{char}|\\.|\\[\\q{char}+\\]|(\\[\\^)(\\q{char}+\\q{category-test}?)\\]|\\q{category-test}|\\(\\q{regex}\\)" + , "any-token = \\.|\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]" + , "atom = (\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{fail}|\\q{any-token}|\\[\\q{char}+\\]|(\\[\\^)(\\q{char}+\\q{category-test}?)\\]|\\q{category-test}|\\(\\q{regex}\\)" , "category = Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn" , "category-test = (\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}" , "char = [^\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\\\\\q{char-escaped}" , "char-control-abbrev = NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC" , "char-escaped = [\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control-abbrev}" , "expression = \\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}" - , "nonterminal = (\\\\q)(\\{\\q{char}*\\})?" + , "fail = \\\\q|\\[\\]" , "regex = \\q{alternate}" , "sequence = \\q{char}*|\\q{expression}*" ] From aa1d7caca67bfcf2a7102d30b1f2270643c5c746 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 5 Dec 2025 13:52:42 -0800 Subject: [PATCH 126/282] Reador --- distributors.cabal | 2 + package.yaml | 1 + src/Control/Lens/Grammar.hs | 4 +- src/Data/Profunctor/Grammar.hs | 133 ++++++++++++++++++++++++++++++--- 4 files changed, 129 insertions(+), 11 deletions(-) diff --git a/distributors.cabal b/distributors.cabal index 2a25eed..b900f41 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -102,6 +102,7 @@ library , contravariant >=1.5 && <2 , distributive >=0.6 && <1 , indexed-transformers >=0.1.0.4 && <1 + , kan-extensions >=5.2.5 && <6 , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 @@ -173,6 +174,7 @@ test-suite spec , distributors , hspec , indexed-transformers >=0.1.0.4 && <1 + , kan-extensions >=5.2.5 && <6 , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 diff --git a/package.yaml b/package.yaml index 2046ea5..8a609f0 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,7 @@ dependencies: - containers >= 0.6 && < 1 - contravariant >= 1.5 && < 2 - distributive >= 0.6 && < 1 +- kan-extensions >= 5.2.5 && < 6 - lens >= 5.2 && < 6 - MemoTrie >= 0.6.11 && < 1 - mtl >= 2.3 && < 3 diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index c1cdb67..c9c8a15 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -268,7 +268,7 @@ instance IsList RegString where = fromMaybe zeroK . listToMaybe . mapMaybe prsF - . runParsor regexGrammar + . runReador regexGrammar where prsF (rex,"") = Just (RegString rex) prsF _ = Nothing @@ -288,7 +288,7 @@ instance IsList RegBnfString where = fromMaybe zeroK . listToMaybe . mapMaybe prsF - . runParsor (bnfGrammarr regexGrammar) + . runReador (bnfGrammarr regexGrammar) where prsF (ebnf,"") = Just (RegBnfString ebnf) prsF _ = Nothing diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 8d4f773..f5981a5 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -10,18 +10,23 @@ module Data.Profunctor.Grammar , grammor , evalGrammor , evalGrammor_ + -- * Reador + , Reador (..) + , runReador + , LookP (..) + , runLookP ) where import Control.Applicative import Control.Arrow import Control.Category import Control.Comonad +import Control.Monad.Codensity import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Control.Lens import Control.Lens.Extras -import Control.Lens.Internal.Equator import Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol @@ -129,10 +134,6 @@ instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m ) => TestAlgebra (TokenTest a) (Parsor s s m a a) -instance - ( Categorized a, a ~ Item s, IsList s, Cons s s a a - , Filterable m, Alternative m, Monad m - ) => Equator a a (Parsor s s m) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m @@ -255,10 +256,6 @@ instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m ) => TestAlgebra (TokenTest a) (Printor s s m a a) -instance - ( Categorized a, a ~ Item s, IsList s, Cons s s a a - , Filterable m, Alternative m, Monad m - ) => Equator a a (Printor s s m) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m @@ -337,3 +334,121 @@ instance (Comonad f, Applicative f, Monoid s, BackusNaurForm t) => BackusNaurForm (Grammor s t f a b) where rule name = Grammor . fmap (fmap (rule name)) . runGrammor ruleRec name = grammor . ruleRec name . dimap grammor evalGrammor + +newtype Reador f a b = Reador {unReador :: Codensity (LookP f) b} +runReador :: (Alternative m, Monad m) => Reador m a b -> String -> m (b, String) +runReador (Reador (Codensity f)) = runLookP (f return) +deriving newtype instance Functor (Reador f a) +deriving newtype instance Applicative (Reador f a) +deriving newtype instance Monad (Reador f a) +deriving newtype instance (Alternative m, Monad m) + => Alternative (Reador m a) +deriving newtype instance (Alternative m, Monad m) + => MonadPlus (Reador m a) +instance (Alternative m, Filterable m, Monad m) + => Filterable (Reador m a) where + mapMaybe f + = Reador . lift + . mapMaybe f + . lowerCodensity . unReador +instance Profunctor (Reador f) where + dimap _ f (Reador p) = Reador (fmap f p) +instance (Alternative m, Monad m) => Choice (Reador m) where + left' = alternate . Left + right' = alternate . Right +instance (Alternative m, Monad m, Filterable m) + => Cochoice (Reador m) where + unleft = fst . filtrate + unright = snd . filtrate +instance (Alternative m, Monad m) => Distributor (Reador m) +instance (Alternative m, Monad m) => Alternator (Reador m) where + alternate (Left (Reador p)) = Reador (fmap Left p) + alternate (Right (Reador p)) = Reador (fmap Right p) +instance (Alternative m, Filterable m, Monad m) + => Filtrator (Reador m) where + filtrate + = Reador . lift + . mapMaybe (either Just (const Nothing)) + . lowerCodensity . unReador + &&& Reador . lift + . mapMaybe (either (const Nothing) Just) + . lowerCodensity . unReador +instance (Alternative m, Filterable m, Monad m) + => Tokenized Char (Reador m Char Char) where + anyToken = Reador (lift (GetP return)) +instance + ( Filterable m, Alternative m, Monad m + ) => TestAlgebra (TokenTest Char) (Reador m Char Char) +instance + ( Filterable m, Alternative m, Monad m + ) => TerminalSymbol Char (Reador m () ()) +instance + ( Filterable m, Alternative m, Monad m + ) => IsString (Reador m () ()) where + fromString = terminal +instance + ( Filterable m, Alternative m, Monad m + , AsEmpty s, Cons s s Char Char + ) => IsString (Reador m s s) where + fromString = fromTokens +instance BackusNaurForm (Reador m a b) +instance Matching String (Reador Maybe a b) where + word =~ reador = case runReador reador word of + Nothing -> False + Just (_,t) -> is _Empty t + +data LookP f a + = GetP (Char -> LookP f a) + | LookP (String -> LookP f a) + | ResultP a (LookP f a) + | FinalP (f (a, String)) +runLookP :: Alternative f => LookP f a -> String -> f (a, String) +runLookP (GetP f) s = + maybe empty (\(h,t) -> runLookP (f h) t) (uncons s) +runLookP (LookP f) s = runLookP (f s) s +runLookP (ResultP x p) s = pure (x,s) <|> runLookP p s +runLookP (FinalP r) _ = r +deriving stock instance Functor f => Functor (LookP f) +instance (Alternative m, Monad m) => Applicative (LookP m) where + pure x = ResultP x (FinalP empty) + (<*>) = ap +instance (Alternative m, Monad m) => Monad (LookP m) where + GetP f >>= k = GetP $ \c -> f c >>= k + LookP f >>= k = LookP $ \s -> f s >>= k + ResultP x p >>= k = k x <|> (p >>= k) + FinalP r >>= k = FinalP $ do + (x,s) <- r + runLookP (k x) s +instance (Alternative m, Monad m) => MonadReader String (LookP m) where + ask = LookP return + local f p = do + str <- LookP return + FinalP (runLookP p (f str)) +instance Filterable f => Filterable (LookP f) where + mapMaybe f = \case + GetP k -> GetP (mapMaybe f . k) + LookP k -> LookP (mapMaybe f . k) + ResultP x p -> mapMaybe f p & case f x of + Nothing -> id + Just y -> ResultP y + FinalP r -> FinalP (mapMaybe (\(a,s) -> (,s) <$> f a) r) +instance (Alternative m, Monad m) => Alternative (LookP m) where + empty = FinalP empty + -- most common case: two gets are combined + GetP f1 <|> GetP f2 = GetP (\c -> f1 c <|> f2 c) + -- results are delivered as soon as possible + ResultP x p <|> q = ResultP x (p <|> q) + p <|> ResultP x q = ResultP x (p <|> q) + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + FinalP r <|> FinalP t = FinalP (r <|> t) + FinalP r <|> LookP f = LookP $ \s -> FinalP (r <|> runLookP (f s) s) + FinalP r <|> p = LookP $ \s -> FinalP (r <|> runLookP p s) + LookP f <|> FinalP r = LookP $ \s -> FinalP (runLookP (f s) s <|> r) + p <|> FinalP r = LookP $ \s -> FinalP (runLookP p s <|> r) + -- two looks are combined (=optimization) + -- look + sthg else floats upwards + LookP f <|> LookP g = LookP (\s -> f s <|> g s) + LookP f <|> p = LookP (\s -> f s <|> p) + p <|> LookP f = LookP (\s -> p <|> f s) From 655cd661da59fc18e2cdbd0e4649dfafc5d657f2 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 5 Dec 2025 15:03:51 -0800 Subject: [PATCH 127/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 38 +++++++++++++++++++++------------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index f5981a5..c65ac4d 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -61,6 +61,24 @@ evalGrammor = extract . extract . runGrammor evalGrammor_ :: Grammor () t Identity a b -> t evalGrammor_ = evalGrammor +newtype Reador f a b = Reador {unReador :: Codensity (LookP f) b} +runReador + :: (Alternative m, Monad m) + => Reador m a b -> String -> m (b, String) +runReador (Reador (Codensity f)) = runLookP (f return) + +data LookP f a + = GetP (Char -> LookP f a) + | LookP (String -> LookP f a) + | ResultP a (LookP f a) + | FinalP (f (a, String)) +runLookP :: Alternative f => LookP f a -> String -> f (a, String) +runLookP (GetP f) s = + maybe empty (\(h,t) -> runLookP (f h) t) (uncons s) +runLookP (LookP f) s = runLookP (f s) s +runLookP (ResultP x p) s = pure (x,s) <|> runLookP p s +runLookP (FinalP r) _ = r + -- Parsor instances instance Functor f => Functor (Parsor s t f a) where fmap f = Parsor . fmap (fmap (first' f)) . runParsor @@ -335,9 +353,7 @@ instance (Comonad f, Applicative f, Monoid s, BackusNaurForm t) rule name = Grammor . fmap (fmap (rule name)) . runGrammor ruleRec name = grammor . ruleRec name . dimap grammor evalGrammor -newtype Reador f a b = Reador {unReador :: Codensity (LookP f) b} -runReador :: (Alternative m, Monad m) => Reador m a b -> String -> m (b, String) -runReador (Reador (Codensity f)) = runLookP (f return) +-- Reador instances deriving newtype instance Functor (Reador f a) deriving newtype instance Applicative (Reador f a) deriving newtype instance Monad (Reador f a) @@ -397,17 +413,7 @@ instance Matching String (Reador Maybe a b) where Nothing -> False Just (_,t) -> is _Empty t -data LookP f a - = GetP (Char -> LookP f a) - | LookP (String -> LookP f a) - | ResultP a (LookP f a) - | FinalP (f (a, String)) -runLookP :: Alternative f => LookP f a -> String -> f (a, String) -runLookP (GetP f) s = - maybe empty (\(h,t) -> runLookP (f h) t) (uncons s) -runLookP (LookP f) s = runLookP (f s) s -runLookP (ResultP x p) s = pure (x,s) <|> runLookP p s -runLookP (FinalP r) _ = r +-- LookP instances deriving stock instance Functor f => Functor (LookP f) instance (Alternative m, Monad m) => Applicative (LookP m) where pure x = ResultP x (FinalP empty) @@ -419,6 +425,10 @@ instance (Alternative m, Monad m) => Monad (LookP m) where FinalP r >>= k = FinalP $ do (x,s) <- r runLookP (k x) s +instance (Alternative m, Monad m) => Monadic m Reador where + liftP m = Reador $ do + s <- ask + lift $ FinalP ((,s) <$> m) instance (Alternative m, Monad m) => MonadReader String (LookP m) where ask = LookP return local f p = do From 118b13e3ea09a4682f95d8e9c0e7c1c93e6e482c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 5 Dec 2025 15:05:13 -0800 Subject: [PATCH 128/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index c65ac4d..82946b0 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -369,6 +369,10 @@ instance (Alternative m, Filterable m, Monad m) . lowerCodensity . unReador instance Profunctor (Reador f) where dimap _ f (Reador p) = Reador (fmap f p) +instance (Alternative m, Monad m) => Monadic m Reador where + liftP m = Reador $ do + s <- ask + lift $ FinalP ((,s) <$> m) instance (Alternative m, Monad m) => Choice (Reador m) where left' = alternate . Left right' = alternate . Right @@ -425,10 +429,6 @@ instance (Alternative m, Monad m) => Monad (LookP m) where FinalP r >>= k = FinalP $ do (x,s) <- r runLookP (k x) s -instance (Alternative m, Monad m) => Monadic m Reador where - liftP m = Reador $ do - s <- ask - lift $ FinalP ((,s) <$> m) instance (Alternative m, Monad m) => MonadReader String (LookP m) where ask = LookP return local f p = do From 980a5969def8bffcf25130cd15593f5b540ef5c1 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 5 Dec 2025 15:22:44 -0800 Subject: [PATCH 129/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 100 ++++++++++++++++----------------- 1 file changed, 50 insertions(+), 50 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 82946b0..e8046bf 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -13,8 +13,8 @@ module Data.Profunctor.Grammar -- * Reador , Reador (..) , runReador - , LookP (..) - , runLookP + , LookT (..) + , runLookT ) where import Control.Applicative @@ -61,23 +61,23 @@ evalGrammor = extract . extract . runGrammor evalGrammor_ :: Grammor () t Identity a b -> t evalGrammor_ = evalGrammor -newtype Reador f a b = Reador {unReador :: Codensity (LookP f) b} +newtype Reador f a b = Reador {unReador :: Codensity (LookT f) b} runReador :: (Alternative m, Monad m) => Reador m a b -> String -> m (b, String) -runReador (Reador (Codensity f)) = runLookP (f return) +runReador (Reador (Codensity f)) = runLookT (f return) -data LookP f a - = GetP (Char -> LookP f a) - | LookP (String -> LookP f a) - | ResultP a (LookP f a) - | FinalP (f (a, String)) -runLookP :: Alternative f => LookP f a -> String -> f (a, String) -runLookP (GetP f) s = - maybe empty (\(h,t) -> runLookP (f h) t) (uncons s) -runLookP (LookP f) s = runLookP (f s) s -runLookP (ResultP x p) s = pure (x,s) <|> runLookP p s -runLookP (FinalP r) _ = r +data LookT f a + = LookT (String -> LookT f a) + | GetT (Char -> LookT f a) + | ResultT a (LookT f a) + | FinalT (f (a, String)) +runLookT :: Alternative f => LookT f a -> String -> f (a, String) +runLookT (GetT f) s = + maybe empty (\(h,t) -> runLookT (f h) t) (uncons s) +runLookT (LookT f) s = runLookT (f s) s +runLookT (ResultT x p) s = pure (x,s) <|> runLookT p s +runLookT (FinalT r) _ = r -- Parsor instances instance Functor f => Functor (Parsor s t f a) where @@ -372,7 +372,7 @@ instance Profunctor (Reador f) where instance (Alternative m, Monad m) => Monadic m Reador where liftP m = Reador $ do s <- ask - lift $ FinalP ((,s) <$> m) + lift $ FinalT ((,s) <$> m) instance (Alternative m, Monad m) => Choice (Reador m) where left' = alternate . Left right' = alternate . Right @@ -395,7 +395,7 @@ instance (Alternative m, Filterable m, Monad m) . lowerCodensity . unReador instance (Alternative m, Filterable m, Monad m) => Tokenized Char (Reador m Char Char) where - anyToken = Reador (lift (GetP return)) + anyToken = Reador (lift (GetT return)) instance ( Filterable m, Alternative m, Monad m ) => TestAlgebra (TokenTest Char) (Reador m Char Char) @@ -417,48 +417,48 @@ instance Matching String (Reador Maybe a b) where Nothing -> False Just (_,t) -> is _Empty t --- LookP instances -deriving stock instance Functor f => Functor (LookP f) -instance (Alternative m, Monad m) => Applicative (LookP m) where - pure x = ResultP x (FinalP empty) +-- LookT instances +deriving stock instance Functor f => Functor (LookT f) +instance (Alternative m, Monad m) => Applicative (LookT m) where + pure x = ResultT x (FinalT empty) (<*>) = ap -instance (Alternative m, Monad m) => Monad (LookP m) where - GetP f >>= k = GetP $ \c -> f c >>= k - LookP f >>= k = LookP $ \s -> f s >>= k - ResultP x p >>= k = k x <|> (p >>= k) - FinalP r >>= k = FinalP $ do +instance (Alternative m, Monad m) => Monad (LookT m) where + GetT f >>= k = GetT $ \c -> f c >>= k + LookT f >>= k = LookT $ \s -> f s >>= k + ResultT x p >>= k = k x <|> (p >>= k) + FinalT r >>= k = FinalT $ do (x,s) <- r - runLookP (k x) s -instance (Alternative m, Monad m) => MonadReader String (LookP m) where - ask = LookP return + runLookT (k x) s +instance (Alternative m, Monad m) => MonadReader String (LookT m) where + ask = LookT return local f p = do - str <- LookP return - FinalP (runLookP p (f str)) -instance Filterable f => Filterable (LookP f) where + str <- LookT return + FinalT (runLookT p (f str)) +instance Filterable f => Filterable (LookT f) where mapMaybe f = \case - GetP k -> GetP (mapMaybe f . k) - LookP k -> LookP (mapMaybe f . k) - ResultP x p -> mapMaybe f p & case f x of + GetT k -> GetT (mapMaybe f . k) + LookT k -> LookT (mapMaybe f . k) + ResultT x p -> mapMaybe f p & case f x of Nothing -> id - Just y -> ResultP y - FinalP r -> FinalP (mapMaybe (\(a,s) -> (,s) <$> f a) r) -instance (Alternative m, Monad m) => Alternative (LookP m) where - empty = FinalP empty + Just y -> ResultT y + FinalT r -> FinalT (mapMaybe (\(a,s) -> (,s) <$> f a) r) +instance (Alternative m, Monad m) => Alternative (LookT m) where + empty = FinalT empty -- most common case: two gets are combined - GetP f1 <|> GetP f2 = GetP (\c -> f1 c <|> f2 c) + GetT f1 <|> GetT f2 = GetT (\c -> f1 c <|> f2 c) -- results are delivered as soon as possible - ResultP x p <|> q = ResultP x (p <|> q) - p <|> ResultP x q = ResultP x (p <|> q) + ResultT x p <|> q = ResultT x (p <|> q) + p <|> ResultT x q = ResultT x (p <|> q) -- two finals are combined -- final + look becomes one look and one final (=optimization) -- final + sthg else becomes one look and one final - FinalP r <|> FinalP t = FinalP (r <|> t) - FinalP r <|> LookP f = LookP $ \s -> FinalP (r <|> runLookP (f s) s) - FinalP r <|> p = LookP $ \s -> FinalP (r <|> runLookP p s) - LookP f <|> FinalP r = LookP $ \s -> FinalP (runLookP (f s) s <|> r) - p <|> FinalP r = LookP $ \s -> FinalP (runLookP p s <|> r) + FinalT r <|> FinalT t = FinalT (r <|> t) + FinalT r <|> LookT f = LookT $ \s -> FinalT (r <|> runLookT (f s) s) + FinalT r <|> p = LookT $ \s -> FinalT (r <|> runLookT p s) + LookT f <|> FinalT r = LookT $ \s -> FinalT (runLookT (f s) s <|> r) + p <|> FinalT r = LookT $ \s -> FinalT (runLookT p s <|> r) -- two looks are combined (=optimization) -- look + sthg else floats upwards - LookP f <|> LookP g = LookP (\s -> f s <|> g s) - LookP f <|> p = LookP (\s -> f s <|> p) - p <|> LookP f = LookP (\s -> p <|> f s) + LookT f <|> LookT g = LookT (\s -> f s <|> g s) + LookT f <|> p = LookT (\s -> f s <|> p) + p <|> LookT f = LookT (\s -> p <|> f s) From 669a76afd41bd6edff49dd5d3503a54d56fe9815 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 5 Dec 2025 16:23:15 -0800 Subject: [PATCH 130/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index e8046bf..8f4eaf5 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -369,6 +369,8 @@ instance (Alternative m, Filterable m, Monad m) . lowerCodensity . unReador instance Profunctor (Reador f) where dimap _ f (Reador p) = Reador (fmap f p) +instance Bifunctor (Reador f) where + bimap _ f (Reador p) = Reador (fmap f p) instance (Alternative m, Monad m) => Monadic m Reador where liftP m = Reador $ do s <- ask @@ -432,8 +434,8 @@ instance (Alternative m, Monad m) => Monad (LookT m) where instance (Alternative m, Monad m) => MonadReader String (LookT m) where ask = LookT return local f p = do - str <- LookT return - FinalT (runLookT p (f str)) + s <- ask + FinalT (runLookT p (f s)) instance Filterable f => Filterable (LookT f) where mapMaybe f = \case GetT k -> GetT (mapMaybe f . k) From cda2bf218bdaea62f00beecae45d60373924ec65 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 07:49:49 -0800 Subject: [PATCH 131/282] TokenAlgebra --- src/Control/Lens/Grammar.hs | 12 +++---- src/Control/Lens/Grammar/BackusNaur.hs | 6 ++-- src/Control/Lens/Grammar/Kleene.hs | 28 +++++++---------- src/Data/Profunctor/Grammar.hs | 12 +++---- test/Spec.hs | 43 +++++++++++++++----------- 5 files changed, 51 insertions(+), 50 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index c9c8a15..e988f4d 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -89,9 +89,7 @@ type Tokenizor token p = ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) , forall x y. (x ~ token, y ~ token) - => Tokenized token (p x y) - , forall x y test. (x ~ token, y ~ token, test ~ TokenTest token) - => TestAlgebra test (p x y) + => TokenAlgebra token (p x y) ) :: Constraint prismGrammar :: (Monoidal p, Choice p) => Prism' a () -> p a a @@ -145,7 +143,7 @@ atomG rex = rule "atom" $ choiceP terminal "[" >* several1 noSep charG *< terminal "]" , _RegExam . _NotOneOf >? terminal "[^" >* several1 noSep charG - >*< (pure (NotAsIn Set.empty) <|> catTestG) + >*< (catTestG <|> pure (NotAsIn Set.empty)) *< terminal "]" , _RegExam . _NotOneOf >? pure Set.empty >*< catTestG , terminal "(" >* rex *< terminal ")" @@ -194,7 +192,7 @@ categoryG = rule "category" $ choiceP ] charG :: Grammar Char Char -charG = rule "char" $ testB (notOneOf charsReserved >&&< notAsIn Control) +charG = rule "char" $ tokenClass (notOneOf charsReserved >&&< notAsIn Control) <|> terminal "\\" >* charEscapedG charEscapedG :: Grammar Char Char @@ -248,7 +246,7 @@ newtype RegString = RegString {runRegString :: RegEx Char} deriving newtype ( Eq, Ord , Semigroup, Monoid, KleeneStarAlgebra - , Tokenized Char, TestAlgebra (TokenTest Char) + , Tokenized Char, TokenAlgebra Char , TerminalSymbol Char, NonTerminalSymbol , Matching String ) @@ -257,7 +255,7 @@ newtype RegBnfString = RegBnfString {runRegBnfString :: Bnf (RegEx Char)} deriving newtype ( Eq, Ord , Semigroup, Monoid, KleeneStarAlgebra - , Tokenized Char, TestAlgebra (TokenTest Char) + , Tokenized Char, TokenAlgebra Char , TerminalSymbol Char, NonTerminalSymbol , BackusNaurForm, Matching String ) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 0e39a38..df6ae39 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -131,9 +131,9 @@ instance (Ord rule, Tokenized token rule) notOneOf = liftBnf0 . notOneOf asIn = liftBnf0 . asIn notAsIn = liftBnf0 . notAsIn -instance (Ord rule, TestAlgebra bool rule) - => TestAlgebra bool (Bnf rule) where - testB = liftBnf0 . testB +instance (Ord rule, TokenAlgebra token rule) + => TokenAlgebra token (Bnf rule) where + tokenClass = liftBnf0 . tokenClass instance (Ord rule, KleeneStarAlgebra rule) => KleeneStarAlgebra (Bnf rule) where starK = liftBnf1 starK diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 3910793..4870cb6 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -8,7 +8,7 @@ module Control.Lens.Grammar.Kleene , fromBool , andB, orB, allB, anyB , TokenTest (..) - , TestAlgebra (..) + , TokenAlgebra (..) ) where import Control.Applicative @@ -120,16 +120,12 @@ anyB f = foldl' (\b a -> b >||< f a) falseB newtype TokenTest token = TokenTest (RegExam token (TokenTest token)) -class BooleanAlgebra bool => TestAlgebra bool alg | alg -> bool where - testB :: bool -> alg - default testB - :: ( alg ~ p token token - , bool ~ TokenTest token - , Tokenized token (p token token) - , Alternator p, Cochoice p - ) - => bool -> alg - testB (TokenTest exam) = case exam of +class Tokenized token p => TokenAlgebra token p where + tokenClass :: TokenTest token -> p + default tokenClass + :: (p ~ q token token, Alternator q, Cochoice q) + => TokenTest token -> p + tokenClass (TokenTest exam) = case exam of Fail -> empty Pass -> anyToken OneOf chars -> oneOf chars @@ -137,7 +133,7 @@ class BooleanAlgebra bool => TestAlgebra bool alg | alg -> bool where satisfy (notOneOf chars >&&< asIn cat) NotOneOf chars (NotAsIn cats) -> satisfy (notOneOf chars >&&< allB notAsIn cats) - Alternate exam1 exam2 -> testB exam1 <|> testB exam2 + Alternate exam1 exam2 -> tokenClass exam1 <|> tokenClass exam2 --instances instance (Alternative f, Monoid k) => KleeneStarAlgebra (Ap f k) @@ -203,14 +199,14 @@ instance Categorized token => KleeneStarAlgebra (RegEx token) where rex0 >|< rex1 | rex0 == rex1 = rex0 rex0 >|< rex1 = RegExam (Alternate rex0 rex1) instance Categorized token - => TestAlgebra (TokenTest token) (RegEx token) where - testB (TokenTest tokenExam) = case tokenExam of + => TokenAlgebra token (RegEx token) where + tokenClass (TokenTest tokenExam) = case tokenExam of Fail -> RegExam Fail Pass -> RegExam Pass OneOf as -> RegExam (OneOf as) NotOneOf as catTest -> RegExam (NotOneOf as catTest) Alternate exam1 exam2 -> - RegExam (Alternate (testB exam1) (testB exam2)) + RegExam (Alternate (tokenClass exam1) (tokenClass exam2)) instance BooleanAlgebra Bool where falseB = False trueB = True @@ -400,6 +396,6 @@ instance (Categorized token, Enum (Categorize token), HasTrie token) testNotOneOf :: (Categorized token, Enum (Categorize token)) => ([token], Either Int [Int]) -> RegEx token -testNotOneOf (chars, catTest) = testB $ +testNotOneOf (chars, catTest) = tokenClass $ notOneOf chars >&&< either (asIn . toEnum) (allB (notAsIn . toEnum)) catTest diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 8f4eaf5..afda24d 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -151,7 +151,7 @@ instance instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TestAlgebra (TokenTest a) (Parsor s s m a a) + ) => TokenAlgebra a (Parsor s s m a a) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m @@ -273,7 +273,7 @@ instance instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TestAlgebra (TokenTest a) (Printor s s m a a) + ) => TokenAlgebra a (Printor s s m a a) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m @@ -342,9 +342,9 @@ instance (Tokenized token t, Applicative f) notOneOf = grammor . notOneOf asIn = grammor . asIn notAsIn = grammor . notAsIn -instance (TestAlgebra bool t, Applicative f) - => TestAlgebra bool (Grammor s t f a b) where - testB = grammor . testB +instance (TokenAlgebra a t, Applicative f) + => TokenAlgebra a (Grammor s t f a b) where + tokenClass = grammor . tokenClass instance (TerminalSymbol token t, Applicative f) => TerminalSymbol token (Grammor s t f a b) where terminal = grammor . terminal @@ -400,7 +400,7 @@ instance (Alternative m, Filterable m, Monad m) anyToken = Reador (lift (GetT return)) instance ( Filterable m, Alternative m, Monad m - ) => TestAlgebra (TokenTest Char) (Reador m Char Char) + ) => TokenAlgebra Char (Reador m Char Char) instance ( Filterable m, Alternative m, Monad m ) => TerminalSymbol Char (Reador m () ()) diff --git a/test/Spec.hs b/test/Spec.hs index c2f556d..232f490 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,29 +3,34 @@ module Main (main) where import Data.Char import Data.Foldable hiding (toList) import Control.Lens.Grammar +import Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token +import Data.Profunctor import Data.Profunctor.Grammar import GHC.Exts import Test.Hspec -expectedRegexGrammar :: [String] -expectedRegexGrammar = - [ "start = \\q{regex}" - , "alternate = \\q{sequence}(\\|\\q{sequence})*" - , "any-token = \\.|\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]" - , "atom = (\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{fail}|\\q{any-token}|\\[\\q{char}+\\]|(\\[\\^)(\\q{char}+\\q{category-test}?)\\]|\\q{category-test}|\\(\\q{regex}\\)" - , "category = Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn" - , "category-test = (\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}" - , "char = [^\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\\\\\q{char-escaped}" - , "char-control-abbrev = NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC" - , "char-escaped = [\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control-abbrev}" - , "expression = \\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}" - , "fail = \\\\q|\\[\\]" - , "regex = \\q{alternate}" - , "sequence = \\q{char}*|\\q{expression}*" - ] +expectedRegexGrammar :: Bnf RegString +expectedRegexGrammar = Bnf + { startBnf = fromString "\\q{regex}" + , rulesBnf = fromList $ map (second' fromString) + [("alternate","\\q{sequence}(\\|\\q{sequence})*") + ,("any-token","\\.|\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") + ,("atom","(\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{fail}|\\q{any-token}|\\[\\q{char}+\\]|(\\[\\^)(\\q{char}+\\q{category-test}?)\\]|\\q{category-test}|\\(\\q{regex}\\)") + ,("category","Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn") + ,("category-test","(\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}") + ,("char","[^\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") + ,("char-control-abbrev","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") + ,("char-escaped","[\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control-abbrev}") + ,("expression","\\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}") + ,("fail","\\\\q|\\[\\]") + ,("regex","\\q{alternate}") + ,("sequence","\\q{char}*|\\q{expression}*") + ] + } + regexExamples :: [(RegString, String)] regexExamples = @@ -45,14 +50,16 @@ regexExamples = , (terminal "", "") , (optK (terminal "abc"), "(abc)?") , (optK (terminal "abc") <> nonTerminal "xyz", "(abc)?\\q{xyz}") + , (tokenClass (oneOf "abc" >||< oneOf "xyz"), "[abcxyz]") + , (tokenClass (notOneOf "abc" >&&< asIn LowercaseLetter), "[^abc\\p{Ll}]") + , (tokenClass (notOneOf "abc" >&&< notAsIn Control), "[^abc\\P{Cc}]") ] main :: IO () main = hspec $ do describe "regexGrammar" $ do it "should generate a correct grammar" $ do - let gramString = evalGrammor_ regexGrammar :: RegBnfString - lines (toList gramString) `shouldBe` expectedRegexGrammar + evalGrammor_ regexGrammar `shouldBe` expectedRegexGrammar for_ regexExamples $ \(rex, str) -> do it ("should print " <> show (runRegString rex) <> " correctly") $ toList rex `shouldBe` str From ba380b118b2cc350a95e25e5144fdd22effe6b97 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 07:54:19 -0800 Subject: [PATCH 132/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 4870cb6..09e4d69 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -52,17 +52,6 @@ data RegEx token | KleenePlus (RegEx token) | RegExam (RegExam token (RegEx token)) --- newtype RegEx token = RegEx (RegExtend token (RegEx token)) - --- data RegExtend token alg --- = Terminal [token] --- | NonTerminal String --- | Sequence (RegExtend token alg) (RegExtend token alg) --- | KleeneStar (RegExtend token alg) --- | KleeneOpt (RegExtend token alg) --- | KleenePlus (RegExtend token alg) --- | RegExam (RegExam token (RegExtend token alg)) - data RegExam token alg = Fail | Pass From 2f574722fabfb845b7d00afcd48b1f0ff2dbf93e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 09:34:17 -0800 Subject: [PATCH 133/282] Boole --- distributors.cabal | 1 + src/Control/Lens/Grammar.hs | 1 + src/Control/Lens/Grammar/BackusNaur.hs | 1 + src/Control/Lens/Grammar/Boole.hs | 188 +++++++++++++++++++++++ src/Control/Lens/Grammar/Kleene.hs | 200 ++----------------------- src/Data/Profunctor/Grammar.hs | 1 + test/Spec.hs | 1 + 7 files changed, 206 insertions(+), 187 deletions(-) create mode 100644 src/Control/Lens/Grammar/Boole.hs diff --git a/distributors.cabal b/distributors.cabal index b900f41..8129fc3 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -32,6 +32,7 @@ library Control.Lens.Diopter Control.Lens.Grammar Control.Lens.Grammar.BackusNaur + Control.Lens.Grammar.Boole Control.Lens.Grammar.Kleene Control.Lens.Grammar.Symbol Control.Lens.Grammar.Token diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index e988f4d..9e4f654 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -22,6 +22,7 @@ import Control.Comonad import Control.Lens import Control.Lens.PartialIso import Control.Lens.Grammar.BackusNaur +import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Token import Control.Lens.Grammar.Symbol diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index df6ae39..e7b7a27 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -10,6 +10,7 @@ module Control.Lens.Grammar.BackusNaur import Control.Lens import Control.Lens.Extras +import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Token import Control.Lens.Grammar.Symbol diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs new file mode 100644 index 0000000..8759b32 --- /dev/null +++ b/src/Control/Lens/Grammar/Boole.hs @@ -0,0 +1,188 @@ +module Control.Lens.Grammar.Boole + ( BooleanAlgebra (..) + , fromBool, andB, orB, allB, anyB + , TokenTest (..) + , TokenAlgebra (..) + ) where + +import Control.Applicative +import Control.Lens.Grammar.Kleene +import Control.Lens.Grammar.Token +import Data.Foldable +import Data.Function (on) +import Data.Monoid +import Data.Profunctor +import Data.Profunctor.Distributor +import qualified Data.Set as Set +import GHC.Generics + +class BooleanAlgebra b where + + failB :: b + default failB + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b + failB = pure failB + + passB :: b + default passB + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b + passB = pure passB + + notB :: b -> b + default notB + :: (b ~ f bool, BooleanAlgebra bool, Functor f) => b -> b + notB = fmap notB + + (>||<) :: b -> b -> b + default (>||<) + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b + (>||<) = liftA2 (>||<) + + (>&&<) :: b -> b -> b + default (>&&<) + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b + (>&&<) = liftA2 (>&&<) + +fromBool :: BooleanAlgebra b => Bool -> b +fromBool = \case + True -> passB + False -> failB + +andB :: (Foldable f, BooleanAlgebra b) => f b -> b +andB = foldl' (>&&<) passB + +orB :: (Foldable f, BooleanAlgebra b) => f b -> b +orB = foldl' (>||<) failB + +allB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b +allB f = foldl' (\b a -> b >&&< f a) passB + +anyB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b +anyB f = foldl' (\b a -> b >||< f a) failB + +newtype TokenTest token = TokenTest (RegExam token (TokenTest token)) + +class Tokenized token p => TokenAlgebra token p where + tokenClass :: TokenTest token -> p + default tokenClass + :: (p ~ q token token, Alternator q, Cochoice q) + => TokenTest token -> p + tokenClass (TokenTest exam) = case exam of + Fail -> empty + Pass -> anyToken + OneOf chars -> oneOf chars + NotOneOf chars (AsIn cat) -> + satisfy (notOneOf chars >&&< asIn cat) + NotOneOf chars (NotAsIn cats) -> + satisfy (notOneOf chars >&&< allB notAsIn cats) + Alternate exam1 exam2 -> tokenClass exam1 <|> tokenClass exam2 + +--instances +instance BooleanAlgebra (x -> Bool) +instance (Applicative f, BooleanAlgebra bool) + => BooleanAlgebra (Ap f bool) +deriving stock instance Generic (TokenTest token) +deriving stock instance + (Categorized token, Read token, Read (Categorize token)) + => Read (TokenTest token) +deriving stock instance + (Categorized token, Show token, Show (Categorize token)) + => Show (TokenTest token) +instance BooleanAlgebra Bool where + failB = False + passB = True + notB = not + (>&&<) = (&&) + (>||<) = (||) +deriving newtype instance Categorized token + => Eq (TokenTest token) +deriving newtype instance Categorized token + => Ord (TokenTest token) +deriving newtype instance Categorized token + => BooleanAlgebra (TokenTest token) +deriving newtype instance Categorized token + => Tokenized token (TokenTest token) +instance Categorized token + => TokenAlgebra token (RegEx token) where + tokenClass (TokenTest tokenExam) = case tokenExam of + Fail -> RegExam Fail + Pass -> RegExam Pass + OneOf as -> RegExam (OneOf as) + NotOneOf as catTest -> RegExam (NotOneOf as catTest) + Alternate exam1 exam2 -> + RegExam (Alternate (tokenClass exam1) (tokenClass exam2)) +instance Categorized token + => BooleanAlgebra (RegExam token (TokenTest token)) where + failB = Fail + passB = Pass + notB Fail = Pass + notB Pass = Fail + notB (Alternate (TokenTest x) (TokenTest y)) = x >&&< y + notB (OneOf xs) = NotOneOf xs (NotAsIn Set.empty) + notB (NotOneOf xs (AsIn y)) = + (Alternate `on` TokenTest) + (OneOf xs) + (NotOneOf Set.empty (NotAsIn (Set.singleton y))) + notB (NotOneOf xs (NotAsIn ys)) = + foldl' (Alternate `on` TokenTest) + (OneOf xs) + (Set.map (NotOneOf Set.empty . AsIn) ys) + _ >&&< Fail = Fail + Fail >&&< _ = Fail + x >&&< Pass = x + Pass >&&< y = y + x >&&< Alternate (TokenTest y) (TokenTest z) = (x >&&< y) >||< (x >&&< z) + Alternate (TokenTest x) (TokenTest y) >&&< z = (x >&&< z) >||< (y >&&< z) + OneOf xs >&&< OneOf ys = OneOf (Set.intersection xs ys) + OneOf xs >&&< NotOneOf ys (AsIn z) = OneOf + (Set.filter (\x -> categorize x == z) (Set.difference xs ys)) + NotOneOf xs (AsIn y) >&&< OneOf zs = OneOf + (Set.filter (\z -> categorize z == y) (Set.difference zs xs)) + OneOf xs >&&< NotOneOf ys (NotAsIn zs) = OneOf + (Set.filter (\x -> categorize x `notElem` zs) (Set.difference xs ys)) + NotOneOf xs (NotAsIn ys) >&&< OneOf zs = OneOf + (Set.filter (\z -> categorize z `notElem` ys) (Set.difference zs xs)) + NotOneOf xs (AsIn y) >&&< NotOneOf ws (AsIn z) = + if y /= z then Fail else NotOneOf + (Set.filter (\x -> categorize x == y) + (Set.union xs ws)) (AsIn y) + NotOneOf xs (AsIn y) >&&< NotOneOf ws (NotAsIn zs) = + if y `elem` zs then Fail else NotOneOf + (Set.filter (\x -> categorize x == y) + (Set.union xs ws)) (AsIn y) + NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (AsIn z) = + if z `elem` ys then Fail else NotOneOf + (Set.filter (\x -> categorize x == z) (Set.union xs ws)) + (AsIn z) + NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (NotAsIn zs) = + let + xws = Set.union xs ws + yzs = Set.union ys zs + in + NotOneOf + (Set.filter (\x -> categorize x `notElem` yzs) xws) + (NotAsIn yzs) + x >||< Fail = x + Fail >||< y = y + _ >||< Pass = Pass + Pass >||< _ = Pass + x >||< Alternate y z = Alternate (TokenTest x) (TokenTest (Alternate y z)) + Alternate x y >||< z = Alternate (TokenTest (Alternate x y)) (TokenTest z) + OneOf xs >||< OneOf ys = OneOf (Set.union xs ys) + OneOf xs >||< NotOneOf ys z = + Alternate (TokenTest (OneOf xs)) (TokenTest (NotOneOf ys z)) + NotOneOf xs y >||< OneOf zs = + Alternate (TokenTest (NotOneOf xs y)) (TokenTest (OneOf zs)) + NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (NotAsIn zs) = + NotOneOf (Set.intersection xs ws) (NotAsIn (Set.intersection ys zs)) + NotOneOf xs (AsIn y) >||< NotOneOf ws (AsIn z) = + if y == z then NotOneOf (Set.intersection xs ws) (AsIn y) + else Alternate + (TokenTest (NotOneOf xs (AsIn y))) + (TokenTest (NotOneOf ws (AsIn z))) + NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (AsIn z) = Alternate + (TokenTest (NotOneOf xs (NotAsIn ys))) + (TokenTest (NotOneOf ws (AsIn z))) + NotOneOf xs (AsIn y) >||< NotOneOf ws (NotAsIn zs) = Alternate + (TokenTest (NotOneOf xs (AsIn y))) + (TokenTest (NotOneOf ws (NotAsIn zs))) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 09e4d69..568618e 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -4,22 +4,15 @@ module Control.Lens.Grammar.Kleene , RegEx (..) , RegExam (..) , CategoryTest (..) - , BooleanAlgebra (..) - , fromBool - , andB, orB, allB, anyB - , TokenTest (..) - , TokenAlgebra (..) ) where import Control.Applicative import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Data.Foldable -import Data.Function (on) import Data.MemoTrie import Data.Monoid import Data.Profunctor -import Data.Profunctor.Distributor import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics @@ -63,72 +56,11 @@ data CategoryTest token = AsIn (Categorize token) | NotAsIn (Set (Categorize token)) -class BooleanAlgebra b where - - falseB :: b - default falseB - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b - falseB = pure falseB - - trueB :: b - default trueB - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b - trueB = pure trueB - - notB :: b -> b - default notB - :: (b ~ f bool, BooleanAlgebra bool, Functor f) => b -> b - notB = fmap notB - - (>||<) :: b -> b -> b - default (>||<) - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b - (>||<) = liftA2 (>||<) - - (>&&<) :: b -> b -> b - default (>&&<) - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b - (>&&<) = liftA2 (>&&<) - -fromBool :: BooleanAlgebra b => Bool -> b -fromBool = \case - True -> trueB - False -> falseB - -andB :: (Foldable f, BooleanAlgebra b) => f b -> b -andB = foldl' (>&&<) trueB - -orB :: (Foldable f, BooleanAlgebra b) => f b -> b -orB = foldl' (>||<) falseB - -allB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b -allB f = foldl' (\b a -> b >&&< f a) trueB - -anyB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b -anyB f = foldl' (\b a -> b >||< f a) falseB - -newtype TokenTest token = TokenTest (RegExam token (TokenTest token)) - -class Tokenized token p => TokenAlgebra token p where - tokenClass :: TokenTest token -> p - default tokenClass - :: (p ~ q token token, Alternator q, Cochoice q) - => TokenTest token -> p - tokenClass (TokenTest exam) = case exam of - Fail -> empty - Pass -> anyToken - OneOf chars -> oneOf chars - NotOneOf chars (AsIn cat) -> - satisfy (notOneOf chars >&&< asIn cat) - NotOneOf chars (NotAsIn cats) -> - satisfy (notOneOf chars >&&< allB notAsIn cats) - Alternate exam1 exam2 -> tokenClass exam1 <|> tokenClass exam2 - --instances instance (Alternative f, Monoid k) => KleeneStarAlgebra (Ap f k) deriving stock instance Generic (RegEx token) deriving stock instance Generic (RegExam token alg) -deriving stock instance Generic (TokenTest token) +deriving stock instance Generic1 (RegExam token) deriving stock instance Generic (CategoryTest token) deriving stock instance Categorized token => Eq (RegEx token) deriving stock instance Categorized token => Ord (RegEx token) @@ -187,28 +119,6 @@ instance Categorized token => KleeneStarAlgebra (RegEx token) where RegExam Fail >|< rex = rex rex0 >|< rex1 | rex0 == rex1 = rex0 rex0 >|< rex1 = RegExam (Alternate rex0 rex1) -instance Categorized token - => TokenAlgebra token (RegEx token) where - tokenClass (TokenTest tokenExam) = case tokenExam of - Fail -> RegExam Fail - Pass -> RegExam Pass - OneOf as -> RegExam (OneOf as) - NotOneOf as catTest -> RegExam (NotOneOf as catTest) - Alternate exam1 exam2 -> - RegExam (Alternate (tokenClass exam1) (tokenClass exam2)) -instance BooleanAlgebra Bool where - falseB = False - trueB = True - notB = not - (>&&<) = (&&) - (>||<) = (||) -instance BooleanAlgebra (x -> Bool) -instance (Applicative f, BooleanAlgebra bool) - => BooleanAlgebra (Ap f bool) -deriving newtype instance Categorized token - => BooleanAlgebra (TokenTest token) -deriving newtype instance Categorized token - => Tokenized token (TokenTest token) instance Categorized token => Tokenized token (RegExam token alg) where anyToken = Pass @@ -221,81 +131,6 @@ instance Categorized token asIn cat = NotOneOf Set.empty (AsIn cat) notAsIn cat = NotOneOf Set.empty (NotAsIn (Set.singleton cat)) -instance Categorized token - => BooleanAlgebra (RegExam token (TokenTest token)) where - falseB = Fail - trueB = Pass - notB Fail = Pass - notB Pass = Fail - notB (Alternate (TokenTest x) (TokenTest y)) = x >&&< y - notB (OneOf xs) = NotOneOf xs (NotAsIn Set.empty) - notB (NotOneOf xs (AsIn y)) = - (Alternate `on` TokenTest) - (OneOf xs) - (NotOneOf Set.empty (NotAsIn (Set.singleton y))) - notB (NotOneOf xs (NotAsIn ys)) = - foldl' (Alternate `on` TokenTest) - (OneOf xs) - (Set.map (NotOneOf Set.empty . AsIn) ys) - _ >&&< Fail = Fail - Fail >&&< _ = Fail - x >&&< Pass = x - Pass >&&< y = y - x >&&< Alternate (TokenTest y) (TokenTest z) = (x >&&< y) >||< (x >&&< z) - Alternate (TokenTest x) (TokenTest y) >&&< z = (x >&&< z) >||< (y >&&< z) - OneOf xs >&&< OneOf ys = OneOf (Set.intersection xs ys) - OneOf xs >&&< NotOneOf ys (AsIn z) = OneOf - (Set.filter (\x -> categorize x == z) (Set.difference xs ys)) - NotOneOf xs (AsIn y) >&&< OneOf zs = OneOf - (Set.filter (\z -> categorize z == y) (Set.difference zs xs)) - OneOf xs >&&< NotOneOf ys (NotAsIn zs) = OneOf - (Set.filter (\x -> categorize x `notElem` zs) (Set.difference xs ys)) - NotOneOf xs (NotAsIn ys) >&&< OneOf zs = OneOf - (Set.filter (\z -> categorize z `notElem` ys) (Set.difference zs xs)) - NotOneOf xs (AsIn y) >&&< NotOneOf ws (AsIn z) = - if y /= z then Fail else NotOneOf - (Set.filter (\x -> categorize x == y) - (Set.union xs ws)) (AsIn y) - NotOneOf xs (AsIn y) >&&< NotOneOf ws (NotAsIn zs) = - if y `elem` zs then Fail else NotOneOf - (Set.filter (\x -> categorize x == y) - (Set.union xs ws)) (AsIn y) - NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (AsIn z) = - if z `elem` ys then Fail else NotOneOf - (Set.filter (\x -> categorize x == z) (Set.union xs ws)) - (AsIn z) - NotOneOf xs (NotAsIn ys) >&&< NotOneOf ws (NotAsIn zs) = - let - xws = Set.union xs ws - yzs = Set.union ys zs - in - NotOneOf - (Set.filter (\x -> categorize x `notElem` yzs) xws) - (NotAsIn yzs) - x >||< Fail = x - Fail >||< y = y - _ >||< Pass = Pass - Pass >||< _ = Pass - x >||< Alternate y z = Alternate (TokenTest x) (TokenTest (Alternate y z)) - Alternate x y >||< z = Alternate (TokenTest (Alternate x y)) (TokenTest z) - OneOf xs >||< OneOf ys = OneOf (Set.union xs ys) - OneOf xs >||< NotOneOf ys z = - Alternate (TokenTest (OneOf xs)) (TokenTest (NotOneOf ys z)) - NotOneOf xs y >||< OneOf zs = - Alternate (TokenTest (NotOneOf xs y)) (TokenTest (OneOf zs)) - NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (NotAsIn zs) = - NotOneOf (Set.intersection xs ws) (NotAsIn (Set.intersection ys zs)) - NotOneOf xs (AsIn y) >||< NotOneOf ws (AsIn z) = - if y == z then NotOneOf (Set.intersection xs ws) (AsIn y) - else Alternate - (TokenTest (NotOneOf xs (AsIn y))) - (TokenTest (NotOneOf ws (AsIn z))) - NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (AsIn z) = Alternate - (TokenTest (NotOneOf xs (NotAsIn ys))) - (TokenTest (NotOneOf ws (AsIn z))) - NotOneOf xs (AsIn y) >||< NotOneOf ws (NotAsIn zs) = Alternate - (TokenTest (NotOneOf xs (AsIn y))) - (TokenTest (NotOneOf ws (NotAsIn zs))) deriving stock instance (Categorized token, Read token, Read alg, Read (Categorize token)) => Read (RegExam token alg) @@ -317,14 +152,6 @@ deriving stock instance deriving stock instance (Categorized token, Show token, Show (Categorize token)) => Show (CategoryTest token) -deriving newtype instance Categorized token => Eq (TokenTest token) -deriving newtype instance Categorized token => Ord (TokenTest token) -deriving stock instance - (Categorized token, Read token, Read (Categorize token)) - => Read (TokenTest token) -deriving stock instance - (Categorized token, Show token, Show (Categorize token)) - => Show (TokenTest token) instance (Categorized token, Enum (Categorize token), HasTrie token) => HasTrie (RegEx token) where data (RegEx token :->: b) = RegExTrie @@ -370,21 +197,20 @@ instance (Categorized token, Enum (Categorize token), HasTrie token) (Set.toList chars, Right (Set.toList (Set.map fromEnum cats))) RegExam (Alternate x1 x2) -> untrie (alternateTrie rex) (x1,x2) enumerate rex = mconcat - [ first' terminal <$> enumerate (terminalTrie rex) - , first' nonTerminal <$> enumerate (nonTerminalTrie rex) - , first' (uncurry (<>)) <$> enumerate (sequenceTrie rex) - , first' (uncurry (>|<)) <$> enumerate (alternateTrie rex) - , first' starK <$> enumerate (kleeneStarTrie rex) - , first' optK <$> enumerate (kleeneOptTrie rex) - , first' plusK <$> enumerate (kleenePlusTrie rex) - , [(zeroK, failTrie rex)] - , [(anyToken, passTrie rex)] - , first' oneOf <$> enumerate (oneOfTrie rex) + [ first' Terminal <$> enumerate (terminalTrie rex) + , first' NonTerminal <$> enumerate (nonTerminalTrie rex) + , first' (uncurry Sequence) <$> enumerate (sequenceTrie rex) + , first' (RegExam . uncurry Alternate) <$> enumerate (alternateTrie rex) + , first' KleeneStar <$> enumerate (kleeneStarTrie rex) + , first' KleeneOpt <$> enumerate (kleeneOptTrie rex) + , first' KleenePlus <$> enumerate (kleenePlusTrie rex) + , [(RegExam Fail, failTrie rex)] + , [(RegExam Pass, passTrie rex)] + , first' (RegExam . OneOf . Set.fromList) <$> enumerate (oneOfTrie rex) , first' testNotOneOf <$> enumerate (notOneOfTrie rex) ] testNotOneOf :: (Categorized token, Enum (Categorize token)) => ([token], Either Int [Int]) -> RegEx token -testNotOneOf (chars, catTest) = tokenClass $ - notOneOf chars >&&< - either (asIn . toEnum) (allB (notAsIn . toEnum)) catTest +testNotOneOf (chars, catTest) = RegExam $ + NotOneOf (Set.fromList chars) (either (AsIn . toEnum) (NotAsIn . Set.map toEnum . Set.fromList) catTest) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index afda24d..56228c6 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -28,6 +28,7 @@ import Control.Monad.State import Control.Lens import Control.Lens.Extras import Control.Lens.Grammar.BackusNaur +import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token diff --git a/test/Spec.hs b/test/Spec.hs index 232f490..156024f 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,6 +4,7 @@ import Data.Char import Data.Foldable hiding (toList) import Control.Lens.Grammar import Control.Lens.Grammar.BackusNaur +import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token From 0171c239257b7caa2cab78ae382357e71da48d70 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 11:35:15 -0800 Subject: [PATCH 134/282] optimize local --- src/Data/Profunctor/Grammar.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 56228c6..25f4d80 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -434,9 +434,13 @@ instance (Alternative m, Monad m) => Monad (LookT m) where runLookT (k x) s instance (Alternative m, Monad m) => MonadReader String (LookT m) where ask = LookT return - local f p = do - s <- ask - FinalT (runLookT p (f s)) + local f = \case + GetT k -> do + s <- ask + FinalT (runLookT (GetT k) (f s)) + LookT k -> LookT (k . f) + ResultT x p -> ResultT x (local f p) + FinalT r -> FinalT r instance Filterable f => Filterable (LookT f) where mapMaybe f = \case GetT k -> GetT (mapMaybe f . k) From df773c61b4d4a76dc7043c1bad399a21f3289fbb Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 11:35:26 -0800 Subject: [PATCH 135/282] mfiltrate --- src/Data/Profunctor/Monadic.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 88447b6..e53d96b 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -12,6 +12,7 @@ Portability : non-portable module Data.Profunctor.Monadic ( Monadic (..) + , mfiltrate , Polyadic (..) , Tetradic (..) , WrappedMonadic (..) @@ -21,6 +22,7 @@ module Data.Profunctor.Monadic , UntaggedC (..) ) where +import Control.Applicative import Control.Category import Control.Comonad import Control.Arrow @@ -28,6 +30,7 @@ import Control.Monad import Control.Monad.State import Control.Monad.Trans.Indexed import Data.Profunctor +import Data.Profunctor.Distributor import Prelude hiding (id, (.)) class @@ -45,6 +48,15 @@ instance Monad m => Monadic m Star where instance Comonad w => Monadic w Costar where liftP = Costar . return . extract +mfiltrate + :: (Monadic m p, Alternator (p m)) + => p m (Either a c) (Either b d) + -> (p m a b, p m c d) +mfiltrate p = + ( lmap Left p >>= either pure (const empty) + , lmap Right p >>= either (const empty) pure + ) + class ( forall i j. Profunctor (p i j m) , forall i j x. Functor (p i j m x) From 3d4d7378d17651b06f3814107a7096884d93f3f2 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 11:42:16 -0800 Subject: [PATCH 136/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 25f4d80..715b2d1 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -389,13 +389,7 @@ instance (Alternative m, Monad m) => Alternator (Reador m) where alternate (Right (Reador p)) = Reador (fmap Right p) instance (Alternative m, Filterable m, Monad m) => Filtrator (Reador m) where - filtrate - = Reador . lift - . mapMaybe (either Just (const Nothing)) - . lowerCodensity . unReador - &&& Reador . lift - . mapMaybe (either (const Nothing) Just) - . lowerCodensity . unReador + filtrate = mfiltrate instance (Alternative m, Filterable m, Monad m) => Tokenized Char (Reador m Char Char) where anyToken = Reador (lift (GetT return)) From 445e018db4f058f37792173b0bffd9fd2cbf871e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 12:05:05 -0800 Subject: [PATCH 137/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index e53d96b..9c5e7bb 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -52,10 +52,10 @@ mfiltrate :: (Monadic m p, Alternator (p m)) => p m (Either a c) (Either b d) -> (p m a b, p m c d) -mfiltrate p = - ( lmap Left p >>= either pure (const empty) - , lmap Right p >>= either (const empty) pure - ) +mfiltrate = + (either pure (const empty) <=< lmap Left) + &&& + (either (const empty) pure <=< lmap Right) class ( forall i j. Profunctor (p i j m) From 48a939ecff1f50c1bbce2bc82128ba147e79bdf7 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 13:29:39 -0800 Subject: [PATCH 138/282] monochrome --- src/Control/Lens/Grammar.hs | 22 ---------------------- src/Data/Profunctor/Monadic.hs | 26 ++++++++++++++++++++++++++ 2 files changed, 26 insertions(+), 22 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 9e4f654..e657d7a 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -10,15 +10,10 @@ module Control.Lens.Grammar , regexGrammar , CtxGrammar , CtxGrammarr - , prismGrammar - , coPrismGrammar - , grammarrOptic - , grammarOptic , Tokenizor ) where import Control.Applicative -import Control.Comonad import Control.Lens import Control.Lens.PartialIso import Control.Lens.Grammar.BackusNaur @@ -29,7 +24,6 @@ import Control.Lens.Grammar.Symbol import Control.Monad import Data.Maybe hiding (mapMaybe) import Data.Monoid -import Data.Profunctor import Data.Profunctor.Distributor import Data.Profunctor.Filtrator import Data.Profunctor.Monadic @@ -93,22 +87,6 @@ type Tokenizor token p = => TokenAlgebra token (p x y) ) :: Constraint -prismGrammar :: (Monoidal p, Choice p) => Prism' a () -> p a a -prismGrammar = (>? oneP) - -coPrismGrammar :: (Monoidal p, Cochoice p) => Prism' () a -> p a a -coPrismGrammar = (?< oneP) - -grammarOptic - :: (Monoidal p, Comonad f, Applicative f) - => p a a -> Optic' p f a () -grammarOptic = grammarrOptic . (*<) - -grammarrOptic - :: (Profunctor p, Comonad f, Applicative f) - => (p a a -> p b b) -> Optic' p f b a -grammarrOptic = dimap (rmap extract) (rmap pure) - regexGrammar :: Grammar Char (RegEx Char) regexGrammar = ruleRec "regex" altG diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 9c5e7bb..17f65f0 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -13,6 +13,10 @@ Portability : non-portable module Data.Profunctor.Monadic ( Monadic (..) , mfiltrate + , monochrome + , monochrome_ + , runMonochrome + , runMonochrome_ , Polyadic (..) , Tetradic (..) , WrappedMonadic (..) @@ -26,10 +30,12 @@ import Control.Applicative import Control.Category import Control.Comonad import Control.Arrow +import Control.Lens import Control.Monad import Control.Monad.State import Control.Monad.Trans.Indexed import Data.Profunctor +import Data.Profunctor.Monoidal import Data.Profunctor.Distributor import Prelude hiding (id, (.)) @@ -57,6 +63,26 @@ mfiltrate = &&& (either (const empty) pure <=< lmap Right) +monochrome_ + :: (Monadic m p, Monad m) + => p m a b -> Optic (p m) m a b () () +monochrome_ = monochrome . (*<) + +monochrome + :: (Monadic m p, Monad m) + => (p m a b -> p m s t) -> Optic (p m) m s t a b +monochrome f = fmap return . f . joinP + +runMonochrome_ + :: (Monadic m p, Monad m) + => Optic (p m) m a b () () -> p m a b +runMonochrome_ f = runMonochrome f oneP + +runMonochrome + :: (Monadic m p, Monad m) + => Optic (p m) m s t a b -> p m a b -> p m s t +runMonochrome f = joinP . f . fmap return + class ( forall i j. Profunctor (p i j m) , forall i j x. Functor (p i j m x) From acd04ed127ec476b619a2a1f09f022fd6b323c48 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 14:22:45 -0800 Subject: [PATCH 139/282] dodo --- distributors.cabal | 2 +- src/Control/Lens/Internal/Equator.hs | 3 --- src/Data/Profunctor/Monadic.hs | 12 ++++++------ src/Data/Profunctor/{ => Polyadic}/Do.hs | 15 +++++++++++---- 4 files changed, 18 insertions(+), 14 deletions(-) rename src/Data/Profunctor/{ => Polyadic}/Do.hs (64%) diff --git a/distributors.cabal b/distributors.cabal index 8129fc3..01d6eaa 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -43,11 +43,11 @@ library Control.Lens.PartialIso Control.Lens.Wither Data.Profunctor.Distributor - Data.Profunctor.Do Data.Profunctor.Filtrator Data.Profunctor.Grammar Data.Profunctor.Monadic Data.Profunctor.Monoidal + Data.Profunctor.Polyadic.Do other-modules: Paths_distributors autogen-modules: diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs index a8dd083..b435447 100644 --- a/src/Control/Lens/Internal/Equator.hs +++ b/src/Control/Lens/Internal/Equator.hs @@ -4,7 +4,6 @@ module Control.Lens.Internal.Equator ) where import Control.Lens -import Control.Lens.Grammar.Token import Control.Lens.Internal.Iso import Control.Lens.Internal.Prism import Control.Lens.Internal.Profunctor @@ -12,8 +11,6 @@ import Control.Lens.PartialIso class Equator a b p | p -> a, p -> b where equate :: p a b - default equate :: Tokenized token (p a b) => p a b - equate = anyToken instance Equator a b (Identical a b) where equate = Identical instance Equator a b (Exchange a b) where equate = Exchange id id diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 17f65f0..d71b735 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -15,8 +15,8 @@ module Data.Profunctor.Monadic , mfiltrate , monochrome , monochrome_ - , runMonochrome - , runMonochrome_ + , withMonochrome + , withMonochrome_ , Polyadic (..) , Tetradic (..) , WrappedMonadic (..) @@ -73,15 +73,15 @@ monochrome => (p m a b -> p m s t) -> Optic (p m) m s t a b monochrome f = fmap return . f . joinP -runMonochrome_ +withMonochrome_ :: (Monadic m p, Monad m) => Optic (p m) m a b () () -> p m a b -runMonochrome_ f = runMonochrome f oneP +withMonochrome_ f = withMonochrome f oneP -runMonochrome +withMonochrome :: (Monadic m p, Monad m) => Optic (p m) m s t a b -> p m a b -> p m s t -runMonochrome f = joinP . f . fmap return +withMonochrome f = joinP . f . fmap return class ( forall i j. Profunctor (p i j m) diff --git a/src/Data/Profunctor/Do.hs b/src/Data/Profunctor/Polyadic/Do.hs similarity index 64% rename from src/Data/Profunctor/Do.hs rename to src/Data/Profunctor/Polyadic/Do.hs index e850899..1ada5c5 100644 --- a/src/Data/Profunctor/Do.hs +++ b/src/Data/Profunctor/Polyadic/Do.hs @@ -1,6 +1,6 @@ {-| -Module : Data.Profunctor.Do -Description : overloaded do-notation +Module : Data.Profunctor.Polyadic.Do +Description : polyadic do-notation Copyright : (C) 2025 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav @@ -8,7 +8,7 @@ Stability : provisional Portability : non-portable -} -module Data.Profunctor.Do +module Data.Profunctor.Polyadic.Do ( -- * (>>=) , (>>) @@ -17,7 +17,8 @@ module Data.Profunctor.Do ) where import Data.Profunctor.Monadic -import Prelude hiding ((>>), (>>=)) +import Prelude hiding ((>>), (>>=), fail) +import qualified Prelude (>>=) :: Polyadic m p @@ -28,3 +29,9 @@ x >>= f = composeP (fmap f x) :: Polyadic m p => p i j m a b -> p j k m a c -> p i k m a c x >> y = x >>= (\_ -> y) + +fail + :: (Polyadic m p, MonadFail m) + => String + -> p i i m a b +fail = liftP . Prelude.fail From 6fe4f1cc7f62c3d34a22b46555fd6ef2a99bfc4e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 14:24:50 -0800 Subject: [PATCH 140/282] Update Do.hs --- src/Data/Profunctor/Polyadic/Do.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Polyadic/Do.hs b/src/Data/Profunctor/Polyadic/Do.hs index 1ada5c5..7888fbd 100644 --- a/src/Data/Profunctor/Polyadic/Do.hs +++ b/src/Data/Profunctor/Polyadic/Do.hs @@ -12,8 +12,8 @@ module Data.Profunctor.Polyadic.Do ( -- * (>>=) , (>>) - , return , fail + , return ) where import Data.Profunctor.Monadic From 7f1269b781e59e7af9c74cf37ca9e6178864fd91 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 16:18:08 -0800 Subject: [PATCH 141/282] stuuf --- src/Control/Lens/Grammar.hs | 26 +++++++++++++------------- src/Data/Profunctor/Monadic.hs | 2 +- src/Data/Profunctor/Monoidal.hs | 6 +++--- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index e657d7a..078b23d 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -4,7 +4,7 @@ module Control.Lens.Grammar , RegBnfString (..) , RegGrammar , RegGrammarr - , bnfGrammarr + , ebnfGrammar , Grammar , Grammarr , regexGrammar @@ -35,6 +35,7 @@ import GHC.Exts import Prelude hiding (filter) import Witherable +makeNestedPrisms ''Bnf makeNestedPrisms ''RegEx makeNestedPrisms ''RegExam makeNestedPrisms ''CategoryTest @@ -171,7 +172,8 @@ categoryG = rule "category" $ choiceP ] charG :: Grammar Char Char -charG = rule "char" $ tokenClass (notOneOf charsReserved >&&< notAsIn Control) +charG = rule "char" $ + tokenClass (notOneOf charsReserved >&&< notAsIn Control) <|> terminal "\\" >* charEscapedG charEscapedG :: Grammar Char Char @@ -211,15 +213,13 @@ charsControl = failG :: Grammar Char () failG = rule "fail" $ terminal "\\q" <|> terminal "[]" -bnfGrammarr :: Ord rule => RegGrammarr Char rule (Bnf rule) -bnfGrammarr p = dimap hither thither $ startG >*< rulesG - where - hither (Bnf start rules) = (start, toList rules) - thither (start, rules) = Bnf start (fromList rules) - startG = terminal "start" >* ruleG - rulesG = manyP (terminal "\n" >* nameG >*< ruleG) - ruleG = terminal " = " >* p - nameG = manyP (notOneOf ['='] <|> (terminal "\\=" >* pure '=')) +ruleG :: Grammar Char (String, RegEx Char) +ruleG = rule "rule" $ manyP charG >*< terminal " = " >* regexGrammar + +ebnfGrammar :: Grammar Char (Bnf (RegEx Char)) +ebnfGrammar = rule "ebnf" $ _Bnf >~ + terminal "start = " >* regexGrammar + >*< several noSep (terminal "\n" >* ruleG) newtype RegString = RegString {runRegString :: RegEx Char} deriving newtype @@ -265,13 +265,13 @@ instance IsList RegBnfString where = fromMaybe zeroK . listToMaybe . mapMaybe prsF - . runReador (bnfGrammarr regexGrammar) + . runReador ebnfGrammar where prsF (ebnf,"") = Just (RegBnfString ebnf) prsF _ = Nothing toList = maybe "{start} = \\q" ($ "") - . evalPrintor (bnfGrammarr regexGrammar) + . evalPrintor ebnfGrammar . runRegBnfString instance IsString RegBnfString where fromString = fromList diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index d71b735..bc95986 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -1,6 +1,6 @@ {-| Module : Data.Profunctor.Monadic -Description : monadic profunctors +Description : monadic, polyadic & tetradic profunctors Copyright : (C) 2025 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index 76f2ecb..9d4216d 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -56,7 +56,7 @@ 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 >*< +infixr 5 >*< {- | `>*` sequences actions, discarding the value of the first argument; analagous to `*>`, extending it to `Monoidal`. @@ -66,7 +66,7 @@ prop> oneP >* p = p -} (>*) :: Monoidal p => p () c -> p a b -> p a b x >* y = lmap (const ()) x *> y -infixl 5 >* +infixl 6 >* {- | `*<` sequences actions, discarding the value of the second argument; analagous to `<*`, extending it to `Monoidal`. @@ -76,7 +76,7 @@ prop> p *< oneP = p -} (*<) :: Monoidal p => p a b -> p () c -> p a b x *< y = x <* lmap (const ()) y -infixl 5 *< +infixl 6 *< {- | `dimap2` is a curried, functionalized form of `>*<`, analagous to `liftA2`. -} From be83247a9db6ad97e52e5d2f9ea30741b18612c1 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 16:27:48 -0800 Subject: [PATCH 142/282] Update Spec.hs --- test/Spec.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/test/Spec.hs b/test/Spec.hs index 156024f..09e91bb 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -17,18 +17,18 @@ expectedRegexGrammar :: Bnf RegString expectedRegexGrammar = Bnf { startBnf = fromString "\\q{regex}" , rulesBnf = fromList $ map (second' fromString) - [("alternate","\\q{sequence}(\\|\\q{sequence})*") - ,("any-token","\\.|\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") - ,("atom","(\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{fail}|\\q{any-token}|\\[\\q{char}+\\]|(\\[\\^)(\\q{char}+\\q{category-test}?)\\]|\\q{category-test}|\\(\\q{regex}\\)") - ,("category","Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn") - ,("category-test","(\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}") - ,("char","[^\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") - ,("char-control-abbrev","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") - ,("char-escaped","[\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control-abbrev}") - ,("expression","\\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}") - ,("fail","\\\\q|\\[\\]") - ,("regex","\\q{alternate}") - ,("sequence","\\q{char}*|\\q{expression}*") + [ ("alternate","\\q{sequence}(\\|\\q{sequence})*") + , ("any-token","\\.|\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") + , ("atom","(\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{fail}|\\q{any-token}|\\[\\q{char}+\\]|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}|\\(\\q{regex}\\)") + , ("category","Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn") + , ("category-test","(\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}") + , ("char","[^\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") + , ("char-control-abbrev","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") + , ("char-escaped","[\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control-abbrev}") + , ("expression","\\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}") + , ("fail","\\\\q|\\[\\]") + , ("regex","\\q{alternate}") + , ("sequence","\\q{char}*|\\q{expression}*") ] } From b45449cb7eb449e750ffbeed4f79f29bfbeffbd2 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 16:34:07 -0800 Subject: [PATCH 143/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index bc95986..e3ba99a 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -64,24 +64,24 @@ mfiltrate = (either (const empty) pure <=< lmap Right) monochrome_ - :: (Monadic m p, Monad m) + :: (Monadic m p, Applicative m) => p m a b -> Optic (p m) m a b () () monochrome_ = monochrome . (*<) monochrome - :: (Monadic m p, Monad m) + :: (Monadic m p, Applicative m) => (p m a b -> p m s t) -> Optic (p m) m s t a b -monochrome f = fmap return . f . joinP +monochrome f = fmap pure . f . joinP withMonochrome_ - :: (Monadic m p, Monad m) + :: (Monadic m p, Applicative m) => Optic (p m) m a b () () -> p m a b withMonochrome_ f = withMonochrome f oneP withMonochrome - :: (Monadic m p, Monad m) + :: (Monadic m p, Applicative m) => Optic (p m) m s t a b -> p m a b -> p m s t -withMonochrome f = joinP . f . fmap return +withMonochrome f = joinP . f . fmap pure class ( forall i j. Profunctor (p i j m) From f3c1282eea4119c6dd22bb079a3565938fd3a9b2 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 16:37:40 -0800 Subject: [PATCH 144/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 078b23d..9139efa 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -91,6 +91,11 @@ type Tokenizor token p = regexGrammar :: Grammar Char (RegEx Char) regexGrammar = ruleRec "regex" altG +ebnfGrammar :: Grammar Char (Bnf (RegEx Char)) +ebnfGrammar = rule "ebnf" $ _Bnf >~ + terminal "start = " >* regexGrammar + >*< several noSep (terminal "\n" >* ruleG) + altG :: Grammarr Char (RegEx Char) (RegEx Char) altG rex = rule "alternate" $ chain1 Left (_RegExam . _Alternate) (sepBy (terminal "|")) (seqG rex) @@ -216,11 +221,6 @@ failG = rule "fail" $ terminal "\\q" <|> terminal "[]" ruleG :: Grammar Char (String, RegEx Char) ruleG = rule "rule" $ manyP charG >*< terminal " = " >* regexGrammar -ebnfGrammar :: Grammar Char (Bnf (RegEx Char)) -ebnfGrammar = rule "ebnf" $ _Bnf >~ - terminal "start = " >* regexGrammar - >*< several noSep (terminal "\n" >* ruleG) - newtype RegString = RegString {runRegString :: RegEx Char} deriving newtype ( Eq, Ord From 35fe6eb0fe64a8044b5d3e3a4e7c667453eee9cb Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 18:42:44 -0800 Subject: [PATCH 145/282] move mfilter --- src/Data/Profunctor/Filtrator.hs | 19 +++++++++++++++++-- src/Data/Profunctor/Monadic.hs | 11 ----------- 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/src/Data/Profunctor/Filtrator.hs b/src/Data/Profunctor/Filtrator.hs index 86a32b6..7592838 100644 --- a/src/Data/Profunctor/Filtrator.hs +++ b/src/Data/Profunctor/Filtrator.hs @@ -1,13 +1,17 @@ module Data.Profunctor.Filtrator ( Filtrator (filtrate) + , mfiltrate ) where +import Control.Applicative import Control.Arrow import Control.Lens.PartialIso import Control.Lens.Internal.Profunctor import Control.Monad import Data.Profunctor +import Data.Profunctor.Distributor import Data.Profunctor.Monad +import Data.Profunctor.Monadic import Data.Profunctor.Yoneda import Witherable @@ -34,9 +38,20 @@ class (Cochoice p, forall x. Filterable (p x)) => p (Either a c) (Either b d) -> (p a b, p c d) filtrate = - dimapMaybe (Just . Left) (either Just (pure Nothing)) + dimapMaybe (Just . Left) (either Just (const Nothing)) &&& - dimapMaybe (Just . Right) (either (pure Nothing) Just) + dimapMaybe (Just . Right) (either (const Nothing) Just) + +-- | `mfiltrate` can be used as `filtrate`, for `Monadic` `Alternator`s. +-- prop> mfiltrate = filtrate +mfiltrate + :: (Monadic m p, Alternator (p m)) + => p m (Either a c) (Either b d) + -> (p m a b, p m c d) +mfiltrate = + (lmap Left >=> either pure (const empty)) + &&& + (lmap Right >=> either (const empty) pure) instance (Profunctor p, forall x. Functor (p x), Filterable f) => Filtrator (WrappedPafb f p) where diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index e3ba99a..c703ad3 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -12,7 +12,6 @@ Portability : non-portable module Data.Profunctor.Monadic ( Monadic (..) - , mfiltrate , monochrome , monochrome_ , withMonochrome @@ -36,7 +35,6 @@ import Control.Monad.State import Control.Monad.Trans.Indexed import Data.Profunctor import Data.Profunctor.Monoidal -import Data.Profunctor.Distributor import Prelude hiding (id, (.)) class @@ -54,15 +52,6 @@ instance Monad m => Monadic m Star where instance Comonad w => Monadic w Costar where liftP = Costar . return . extract -mfiltrate - :: (Monadic m p, Alternator (p m)) - => p m (Either a c) (Either b d) - -> (p m a b, p m c d) -mfiltrate = - (either pure (const empty) <=< lmap Left) - &&& - (either (const empty) pure <=< lmap Right) - monochrome_ :: (Monadic m p, Applicative m) => p m a b -> Optic (p m) m a b () () From 46cd6ee1f71ef52a1cc648b5f454518c6efe6be1 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 21:00:06 -0800 Subject: [PATCH 146/282] Update Filtrator.hs --- src/Data/Profunctor/Filtrator.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Profunctor/Filtrator.hs b/src/Data/Profunctor/Filtrator.hs index 7592838..a43215f 100644 --- a/src/Data/Profunctor/Filtrator.hs +++ b/src/Data/Profunctor/Filtrator.hs @@ -18,6 +18,9 @@ import Witherable {- | The `Filtrator` class extends `Cochoice`, as well as `Filterable`, adding the `filtrate` method, which is an oplax monoidal structure morphism dual to `>+<`. + +prop> filtrate . uncurry (>+<) = id +prop> uncurry (>+<) . filtrate = id -} class (Cochoice p, forall x. Filterable (p x)) => Filtrator p where @@ -43,6 +46,7 @@ class (Cochoice p, forall x. Filterable (p x)) dimapMaybe (Just . Right) (either (const Nothing) Just) -- | `mfiltrate` can be used as `filtrate`, for `Monadic` `Alternator`s. +-- -- prop> mfiltrate = filtrate mfiltrate :: (Monadic m p, Alternator (p m)) From 315b81a62ac1dfd52e13052599d5b0798f3945ed Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 6 Dec 2025 22:23:35 -0800 Subject: [PATCH 147/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 9139efa..63752b2 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -82,10 +82,8 @@ type CtxGrammarr token a b = forall p m. ) => p m a a -> p m b b type Tokenizor token p = - ( forall x y. (x ~ (), y ~ ()) - => TerminalSymbol token (p x y) - , forall x y. (x ~ token, y ~ token) - => TokenAlgebra token (p x y) + ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) + , forall x y. (x ~ token, y ~ token) => TokenAlgebra token (p x y) ) :: Constraint regexGrammar :: Grammar Char (RegEx Char) From 8e3189af142120af9149edcca65ec8991113d350 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 7 Dec 2025 09:18:53 -0800 Subject: [PATCH 148/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 63752b2..75c4a72 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -113,8 +113,8 @@ exprG rex = rule "expression" $ choiceP ] anyG :: Grammar Char () -anyG = rule "any-token" $ - terminal "." <|> terminal "[^]" <|> terminal "\\P{}" <|> terminal "[^\\P{}]" +anyG = rule "any-token" $ choiceP $ map terminal + [".", "[^]", "\\P{}", "[^\\P{}]"] atomG :: Grammarr Char (RegEx Char) (RegEx Char) atomG rex = rule "atom" $ choiceP From a3e006f8fcf7e93f2df6509c8da2a53840fbf820 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 7 Dec 2025 19:12:46 -0800 Subject: [PATCH 149/282] monochrome optics --- distributors.cabal | 3 ++- src/Data/Profunctor/Monadic.hs | 28 ++++++++++++++++++++++++---- 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/distributors.cabal b/distributors.cabal index 01d6eaa..ae63516 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -43,11 +43,12 @@ library Control.Lens.PartialIso Control.Lens.Wither Data.Profunctor.Distributor + Data.Profunctor.Do.Monadic + Data.Profunctor.Do.Polyadic Data.Profunctor.Filtrator Data.Profunctor.Grammar Data.Profunctor.Monadic Data.Profunctor.Monoidal - Data.Profunctor.Polyadic.Do other-modules: Paths_distributors autogen-modules: diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index c703ad3..4b5d46f 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -12,10 +12,6 @@ Portability : non-portable module Data.Profunctor.Monadic ( Monadic (..) - , monochrome - , monochrome_ - , withMonochrome - , withMonochrome_ , Polyadic (..) , Tetradic (..) , WrappedMonadic (..) @@ -23,6 +19,14 @@ module Data.Profunctor.Monadic , TaggedP (..) , UntaggedT (..) , UntaggedC (..) + , monochrome + , monochrome_ + , withMonochrome + , withMonochrome_ + , liftedP + , joined + , joinedP + , bound ) where import Control.Applicative @@ -72,6 +76,22 @@ withMonochrome => Optic (p m) m s t a b -> p m a b -> p m s t withMonochrome f = joinP . f . fmap pure +liftedP :: (Monadic m p, Applicative m) => m b -> Optic (p m) m a b () () +liftedP m = monochrome_ (liftP m) + +joinedP :: (Monadic m p, Applicative m) => Optic (p m) m a b a (m b) +joinedP = monochrome joinP + +joined :: (Monadic m p, Applicative m) => Optic (p m) m a b a (p m a b) +joined = monochrome join + +bound + :: (Monadic m p, Applicative m) + => (b -> Optic (p m) m a c a ()) -> Optic (p m) m a c a b +bound f = monochrome $ \p -> do + b <- p + withMonochrome (f b) (return ()) + class ( forall i j. Profunctor (p i j m) , forall i j x. Functor (p i j m x) From 6ab4a260cd1a666bc4f01405000dbabb54c5346f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 7 Dec 2025 19:12:58 -0800 Subject: [PATCH 150/282] Monadic Do --- src/Data/Profunctor/Do/Monadic.hs | 38 +++++++++++++++++++ .../{Polyadic/Do.hs => Do/Polyadic.hs} | 4 +- 2 files changed, 41 insertions(+), 1 deletion(-) create mode 100644 src/Data/Profunctor/Do/Monadic.hs rename src/Data/Profunctor/{Polyadic/Do.hs => Do/Polyadic.hs} (92%) diff --git a/src/Data/Profunctor/Do/Monadic.hs b/src/Data/Profunctor/Do/Monadic.hs new file mode 100644 index 0000000..b5c5963 --- /dev/null +++ b/src/Data/Profunctor/Do/Monadic.hs @@ -0,0 +1,38 @@ +module Data.Profunctor.Do.Monadic + ( -- * + (>>=) + , (>>) + , fail + , return + , boundRec + ) where + +import Control.Lens +import Control.Monad.Fix +import Data.Profunctor.Monadic +import Prelude hiding ((>>), (>>=), fail) +import qualified Prelude + +(>>=) + :: (Monadic m p, forall x. MonadFix (p m x)) + => p m a a -> (a -> p m b b) -> p m b b +infixl 1 >>= +x >>= f = mdo + a <- lmap (const a) x + f a + +(>>) + :: (Monadic m p, forall x. MonadFix (p m x)) + => p m a a -> p m b b -> p m b b +infixl 1 >> +x >> y = x >>= const y + +fail + :: (Monadic m p, MonadFail m) + => String -> p m a a +fail = liftP . Prelude.fail + +boundRec + :: (Monadic m p, Applicative m, forall x. MonadFix (p m x)) + => (a -> Optic' (p m) m b ()) -> Optic' (p m) m b a +boundRec f = monochrome (\a -> a >>= rmap withMonochrome_ f) diff --git a/src/Data/Profunctor/Polyadic/Do.hs b/src/Data/Profunctor/Do/Polyadic.hs similarity index 92% rename from src/Data/Profunctor/Polyadic/Do.hs rename to src/Data/Profunctor/Do/Polyadic.hs index 7888fbd..6925c8f 100644 --- a/src/Data/Profunctor/Polyadic/Do.hs +++ b/src/Data/Profunctor/Do/Polyadic.hs @@ -8,7 +8,7 @@ Stability : provisional Portability : non-portable -} -module Data.Profunctor.Polyadic.Do +module Data.Profunctor.Do.Polyadic ( -- * (>>=) , (>>) @@ -23,11 +23,13 @@ import qualified Prelude (>>=) :: Polyadic m p => p i j m a b -> (b -> p j k m a c) -> p i k m a c +infixl 1 >>= x >>= f = composeP (fmap f x) (>>) :: Polyadic m p => p i j m a b -> p j k m a c -> p i k m a c +infixl 1 >> x >> y = x >>= (\_ -> y) fail From 8de46c3338ffcf7a555e4aaaffe7ea468e0cf2fb Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 7 Dec 2025 19:48:34 -0800 Subject: [PATCH 151/282] Update Monadic.hs --- src/Data/Profunctor/Do/Monadic.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Do/Monadic.hs b/src/Data/Profunctor/Do/Monadic.hs index b5c5963..57ba83b 100644 --- a/src/Data/Profunctor/Do/Monadic.hs +++ b/src/Data/Profunctor/Do/Monadic.hs @@ -35,4 +35,4 @@ fail = liftP . Prelude.fail boundRec :: (Monadic m p, Applicative m, forall x. MonadFix (p m x)) => (a -> Optic' (p m) m b ()) -> Optic' (p m) m b a -boundRec f = monochrome (\a -> a >>= rmap withMonochrome_ f) +boundRec f = monochrome (>>= rmap withMonochrome_ f) From 22f539b85e373f8912369bad2a198bbef2f8bcd7 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 7 Dec 2025 20:11:21 -0800 Subject: [PATCH 152/282] MonadFix stuff --- src/Data/Profunctor/Do/Monadic.hs | 4 ++-- src/Data/Profunctor/Do/Polyadic.hs | 13 +++++++------ 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Data/Profunctor/Do/Monadic.hs b/src/Data/Profunctor/Do/Monadic.hs index 57ba83b..f1f519c 100644 --- a/src/Data/Profunctor/Do/Monadic.hs +++ b/src/Data/Profunctor/Do/Monadic.hs @@ -15,7 +15,7 @@ import qualified Prelude (>>=) :: (Monadic m p, forall x. MonadFix (p m x)) - => p m a a -> (a -> p m b b) -> p m b b + => p m a a -> (a -> p m b c) -> p m b c infixl 1 >>= x >>= f = mdo a <- lmap (const a) x @@ -23,7 +23,7 @@ x >>= f = mdo (>>) :: (Monadic m p, forall x. MonadFix (p m x)) - => p m a a -> p m b b -> p m b b + => p m a a -> p m b c -> p m b c infixl 1 >> x >> y = x >>= const y diff --git a/src/Data/Profunctor/Do/Polyadic.hs b/src/Data/Profunctor/Do/Polyadic.hs index 6925c8f..d6a8bb0 100644 --- a/src/Data/Profunctor/Do/Polyadic.hs +++ b/src/Data/Profunctor/Do/Polyadic.hs @@ -16,19 +16,20 @@ module Data.Profunctor.Do.Polyadic , return ) where +import Control.Monad.Fix +import Data.Profunctor import Data.Profunctor.Monadic import Prelude hiding ((>>), (>>=), fail) import qualified Prelude (>>=) - :: Polyadic m p - => p i j m a b -> (b -> p j k m a c) -> p i k m a c -infixl 1 >>= -x >>= f = composeP (fmap f x) + :: (Polyadic m p, forall x. MonadFix (p i i m x)) + => p i i m a a -> (a -> p i j m b c) -> p i j m b c +x >>= f = composeP (fmap f (mfix (\a -> lmap (const a) x))) (>>) - :: Polyadic m p - => p i j m a b -> p j k m a c -> p i k m a c + :: (Polyadic m p, forall x. MonadFix (p i i m x)) + => p i i m a a -> p i j m b c -> p i j m b c infixl 1 >> x >> y = x >>= (\_ -> y) From 9b32f5ab6ab08133844034d6704d48ca884ac032 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 7 Dec 2025 20:16:07 -0800 Subject: [PATCH 153/282] dododo --- src/Data/Profunctor/Do/Monadic.hs | 10 ++++++++++ src/Data/Profunctor/Do/Polyadic.hs | 2 +- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Do/Monadic.hs b/src/Data/Profunctor/Do/Monadic.hs index f1f519c..02f270e 100644 --- a/src/Data/Profunctor/Do/Monadic.hs +++ b/src/Data/Profunctor/Do/Monadic.hs @@ -1,3 +1,13 @@ +{-| +Module : Data.Profunctor.Do.Monadic +Description : monadic do-notation +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + module Data.Profunctor.Do.Monadic ( -- * (>>=) diff --git a/src/Data/Profunctor/Do/Polyadic.hs b/src/Data/Profunctor/Do/Polyadic.hs index d6a8bb0..197cf3d 100644 --- a/src/Data/Profunctor/Do/Polyadic.hs +++ b/src/Data/Profunctor/Do/Polyadic.hs @@ -1,5 +1,5 @@ {-| -Module : Data.Profunctor.Polyadic.Do +Module : Data.Profunctor.Do.Polyadic Description : polyadic do-notation Copyright : (C) 2025 - Eitan Chatav License : BSD-style (see the file LICENSE) From d2334fa7abaf3c5c964c3666a6b40f3c0aee9b93 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 7 Dec 2025 20:24:23 -0800 Subject: [PATCH 154/282] Update Polyadic.hs --- src/Data/Profunctor/Do/Polyadic.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Profunctor/Do/Polyadic.hs b/src/Data/Profunctor/Do/Polyadic.hs index 197cf3d..1ef61da 100644 --- a/src/Data/Profunctor/Do/Polyadic.hs +++ b/src/Data/Profunctor/Do/Polyadic.hs @@ -25,6 +25,7 @@ import qualified Prelude (>>=) :: (Polyadic m p, forall x. MonadFix (p i i m x)) => p i i m a a -> (a -> p i j m b c) -> p i j m b c +infixl 1 >>= x >>= f = composeP (fmap f (mfix (\a -> lmap (const a) x))) (>>) From f687b5294209e62ccf9ddb4e97b8eb9dad0e3cca Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 7 Dec 2025 20:53:13 -0800 Subject: [PATCH 155/282] Update Polyadic.hs --- src/Data/Profunctor/Do/Polyadic.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/Data/Profunctor/Do/Polyadic.hs b/src/Data/Profunctor/Do/Polyadic.hs index 1ef61da..dd3632d 100644 --- a/src/Data/Profunctor/Do/Polyadic.hs +++ b/src/Data/Profunctor/Do/Polyadic.hs @@ -18,9 +18,9 @@ module Data.Profunctor.Do.Polyadic import Control.Monad.Fix import Data.Profunctor +import Data.Profunctor.Do.Monadic (fail) import Data.Profunctor.Monadic import Prelude hiding ((>>), (>>=), fail) -import qualified Prelude (>>=) :: (Polyadic m p, forall x. MonadFix (p i i m x)) @@ -33,9 +33,3 @@ x >>= f = composeP (fmap f (mfix (\a -> lmap (const a) x))) => p i i m a a -> p i j m b c -> p i j m b c infixl 1 >> x >> y = x >>= (\_ -> y) - -fail - :: (Polyadic m p, MonadFail m) - => String - -> p i i m a b -fail = liftP . Prelude.fail From 2d74a6195f209fe9686632834785f831445b9478 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 7 Dec 2025 21:06:33 -0800 Subject: [PATCH 156/282] moduuuules --- distributors.cabal | 5 +- src/Data/Profunctor/Grammar.hs | 1 + src/Data/Profunctor/Monadic.hs | 92 -------------- .../{Do/Monadic.hs => Monadic/Do.hs} | 4 +- src/Data/Profunctor/Polyadic.hs | 113 ++++++++++++++++++ .../{Do/Polyadic.hs => Polyadic/Do.hs} | 8 +- 6 files changed, 123 insertions(+), 100 deletions(-) rename src/Data/Profunctor/{Do/Monadic.hs => Monadic/Do.hs} (92%) create mode 100644 src/Data/Profunctor/Polyadic.hs rename src/Data/Profunctor/{Do/Polyadic.hs => Polyadic/Do.hs} (82%) diff --git a/distributors.cabal b/distributors.cabal index ae63516..d5fd385 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -43,12 +43,13 @@ library Control.Lens.PartialIso Control.Lens.Wither Data.Profunctor.Distributor - Data.Profunctor.Do.Monadic - Data.Profunctor.Do.Polyadic Data.Profunctor.Filtrator Data.Profunctor.Grammar Data.Profunctor.Monadic + Data.Profunctor.Monadic.Do Data.Profunctor.Monoidal + Data.Profunctor.Polyadic + Data.Profunctor.Polyadic.Do other-modules: Paths_distributors autogen-modules: diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 715b2d1..a711804 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -41,6 +41,7 @@ import Data.Profunctor.Distributor import Data.Profunctor.Filtrator import Data.Profunctor.Monadic import Data.Profunctor.Monoidal +import Data.Profunctor.Polyadic import Data.Void import Prelude hiding (id, (.)) import GHC.Exts diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 4b5d46f..fdd49ba 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -8,17 +8,8 @@ Stability : provisional Portability : non-portable -} -{-# LANGUAGE PolyKinds #-} - module Data.Profunctor.Monadic ( Monadic (..) - , Polyadic (..) - , Tetradic (..) - , WrappedMonadic (..) - , WrappedPolyadic (..) - , TaggedP (..) - , UntaggedT (..) - , UntaggedC (..) , monochrome , monochrome_ , withMonochrome @@ -92,26 +83,6 @@ bound f = monochrome $ \p -> do b <- p withMonochrome (f b) (return ()) -class - ( forall i j. Profunctor (p i j m) - , forall i j x. Functor (p i j m x) - , forall i. Monadic m (p i i) - ) => Polyadic m p where - composeP :: p i j m a (p j k m a b) -> p i k m a b - -class (forall i j. Profunctor (p i j f)) => Tetradic f p where - - tetramap - :: (h -> i) -> (j -> k) - -> (s -> a) -> (b -> t) - -> p i j f a b -> p h k f s t - tetramap f1 f2 f3 f4 = dimapT f1 f2 . dimap f3 f4 - - dimapT - :: (h -> i) -> (j -> k) - -> p i j f a b -> p h k f a b - dimapT f1 f2 = tetramap f1 f2 id id - newtype WrappedMonadic p m a b = WrapMonadic {unwrapMonadic :: p m a (m b)} instance (Monadic m p, Monad m) => Functor (WrappedMonadic p m a) where fmap = rmap @@ -127,66 +98,3 @@ instance (Monadic m p, Monad m) => Profunctor (WrappedMonadic p m) where dimap f g (WrapMonadic p) = WrapMonadic $ dimap f (fmap g) p instance (Monad m, Monadic m p) => Monadic m (WrappedMonadic p) where joinP (WrapMonadic p) = WrapMonadic (joinP p) - -newtype WrappedPolyadic p i j m a b = - WrapPolyadic {unwrapPolyadic :: p i j m a (m b)} -instance (Polyadic m p, Monad m) - => Functor (WrappedPolyadic p i j m a) where - fmap = rmap -instance (Polyadic m p, Monad m) - => Applicative (WrappedPolyadic p i i m a) where - pure x = WrapPolyadic $ pure (pure x) - WrapPolyadic p1 <*> WrapPolyadic p2 = - WrapPolyadic $ liftA2 (<*>) p1 p2 -instance (Polyadic m p, Monad m) - => Monad (WrappedPolyadic p i i m a) where - return = pure - WrapPolyadic p >>= f = WrapPolyadic $ do - b <- joinP p - unwrapPolyadic (f b) -instance (Polyadic m p, Monad m) - => Profunctor (WrappedPolyadic p i j m) where - dimap f g = WrapPolyadic . dimap f (fmap g) . unwrapPolyadic -instance (Monad m, Polyadic m p) - => Monadic m (WrappedPolyadic p i i) where - joinP = WrapPolyadic . joinP . unwrapPolyadic -instance (Monad m, Polyadic m p) => Polyadic m (WrappedPolyadic p) where - composeP - = WrapPolyadic . composeP - . fmap unwrapPolyadic . composeP - . fmap liftP . unwrapPolyadic - -newtype TaggedP t i j f a b = TagP {untagP :: t i j f b} - deriving newtype (Functor, Applicative, Monad) -instance Functor (t i j f) => Profunctor (TaggedP t i j f) where - dimap _ f = TagP . fmap f . untagP -instance (Monad m, MonadTrans (t i j)) - => Monadic m (TaggedP t i j) where - liftP = TagP . lift -instance (Monad m, IxMonadTrans t) - => Polyadic m (TaggedP t) where - composeP = TagP . joinIx . fmap untagP . untagP - -newtype UntaggedT p a i j f b = UntagT {tagT :: p i j f a b} - deriving newtype (Functor, Applicative, Monad) -instance (forall m. Monad m => Monadic m (p i j)) - => MonadTrans (UntaggedT p a i j) where - lift = UntagT . liftP -instance (forall m. Monad m => Polyadic m p) - => IxMonadTrans (UntaggedT p a) where - joinIx = UntagT . composeP . fmap tagT . tagT - -newtype UntaggedC p a b f i j = UntagC {tagC :: p i j f a b} -instance (Tetradic f p, Functor f) => Tetradic f (UntaggedC p) where - tetramap f1 f2 f3 f4 = UntagC . tetramap f3 f4 f1 f2 . tagC -instance (Tetradic f p, Functor f) => Profunctor (UntaggedC p a b f) where - dimap f g = UntagC . dimapT f g . tagC -instance (Tetradic f p, Functor f) => Functor (UntaggedC p a b f i) where - fmap = rmap -instance (Polyadic m p, Monoid b) => Category (UntaggedC p a b m) where - id = UntagC (pure mempty) - UntagC g . UntagC f = UntagC (composeP (fmap (\b -> fmap (<> b) g) f)) -instance (Polyadic m p, Monad m, Monoid b) - => Semigroup (UntaggedC p a b m i i) where (<>) = (>>>) -instance (Polyadic m p, Monad m, Monoid b) - => Monoid (UntaggedC p a b m i i) where mempty = id diff --git a/src/Data/Profunctor/Do/Monadic.hs b/src/Data/Profunctor/Monadic/Do.hs similarity index 92% rename from src/Data/Profunctor/Do/Monadic.hs rename to src/Data/Profunctor/Monadic/Do.hs index 02f270e..38fb198 100644 --- a/src/Data/Profunctor/Do/Monadic.hs +++ b/src/Data/Profunctor/Monadic/Do.hs @@ -1,5 +1,5 @@ {-| -Module : Data.Profunctor.Do.Monadic +Module : Data.Profunctor.Monadic.Do Description : monadic do-notation Copyright : (C) 2025 - Eitan Chatav License : BSD-style (see the file LICENSE) @@ -8,7 +8,7 @@ Stability : provisional Portability : non-portable -} -module Data.Profunctor.Do.Monadic +module Data.Profunctor.Monadic.Do ( -- * (>>=) , (>>) diff --git a/src/Data/Profunctor/Polyadic.hs b/src/Data/Profunctor/Polyadic.hs new file mode 100644 index 0000000..a4bfea0 --- /dev/null +++ b/src/Data/Profunctor/Polyadic.hs @@ -0,0 +1,113 @@ +{-| +Module : Data.Profunctor.Polyadic +Description : polyadic & tetradic profunctors +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + +{-# LANGUAGE PolyKinds #-} + +module Data.Profunctor.Polyadic + ( Polyadic (..) + , Tetradic (..) + , WrappedPolyadic (..) + , TaggedP (..) + , UntaggedT (..) + , UntaggedC (..) + ) where + +import Control.Applicative +import Control.Category +import Control.Comonad +import Control.Lens +import Control.Monad +import Control.Monad.State +import Control.Monad.Trans.Indexed +import Data.Profunctor.Monadic +import Prelude hiding (id, (.)) + +class + ( forall i j. Profunctor (p i j m) + , forall i j x. Functor (p i j m x) + , forall i. Monadic m (p i i) + ) => Polyadic m p where + composeP :: p i j m a (p j k m a b) -> p i k m a b + +class (forall i j. Profunctor (p i j f)) => Tetradic f p where + + tetramap + :: (h -> i) -> (j -> k) + -> (s -> a) -> (b -> t) + -> p i j f a b -> p h k f s t + tetramap f1 f2 f3 f4 = dimapT f1 f2 . dimap f3 f4 + + dimapT + :: (h -> i) -> (j -> k) + -> p i j f a b -> p h k f a b + dimapT f1 f2 = tetramap f1 f2 id id + +newtype WrappedPolyadic p i j m a b = + WrapPolyadic {unwrapPolyadic :: p i j m a (m b)} +instance (Polyadic m p, Monad m) + => Functor (WrappedPolyadic p i j m a) where + fmap = rmap +instance (Polyadic m p, Monad m) + => Applicative (WrappedPolyadic p i i m a) where + pure x = WrapPolyadic $ pure (pure x) + WrapPolyadic p1 <*> WrapPolyadic p2 = + WrapPolyadic $ liftA2 (<*>) p1 p2 +instance (Polyadic m p, Monad m) + => Monad (WrappedPolyadic p i i m a) where + return = pure + WrapPolyadic p >>= f = WrapPolyadic $ do + b <- joinP p + unwrapPolyadic (f b) +instance (Polyadic m p, Monad m) + => Profunctor (WrappedPolyadic p i j m) where + dimap f g = WrapPolyadic . dimap f (fmap g) . unwrapPolyadic +instance (Monad m, Polyadic m p) + => Monadic m (WrappedPolyadic p i i) where + joinP = WrapPolyadic . joinP . unwrapPolyadic +instance (Monad m, Polyadic m p) => Polyadic m (WrappedPolyadic p) where + composeP + = WrapPolyadic . composeP + . fmap unwrapPolyadic . composeP + . fmap liftP . unwrapPolyadic + +newtype TaggedP t i j f a b = TagP {untagP :: t i j f b} + deriving newtype (Functor, Applicative, Monad) +instance Functor (t i j f) => Profunctor (TaggedP t i j f) where + dimap _ f = TagP . fmap f . untagP +instance (Monad m, MonadTrans (t i j)) + => Monadic m (TaggedP t i j) where + liftP = TagP . lift +instance (Monad m, IxMonadTrans t) + => Polyadic m (TaggedP t) where + composeP = TagP . joinIx . fmap untagP . untagP + +newtype UntaggedT p a i j f b = UntagT {tagT :: p i j f a b} + deriving newtype (Functor, Applicative, Monad) +instance (forall m. Monad m => Monadic m (p i j)) + => MonadTrans (UntaggedT p a i j) where + lift = UntagT . liftP +instance (forall m. Monad m => Polyadic m p) + => IxMonadTrans (UntaggedT p a) where + joinIx = UntagT . composeP . fmap tagT . tagT + +newtype UntaggedC p a b f i j = UntagC {tagC :: p i j f a b} +instance (Tetradic f p, Functor f) => Tetradic f (UntaggedC p) where + tetramap f1 f2 f3 f4 = UntagC . tetramap f3 f4 f1 f2 . tagC +instance (Tetradic f p, Functor f) => Profunctor (UntaggedC p a b f) where + dimap f g = UntagC . dimapT f g . tagC +instance (Tetradic f p, Functor f) => Functor (UntaggedC p a b f i) where + fmap = rmap +instance (Polyadic m p, Monoid b) => Category (UntaggedC p a b m) where + id = UntagC (pure mempty) + UntagC g . UntagC f = UntagC (composeP (fmap (\b -> fmap (<> b) g) f)) +instance (Polyadic m p, Monad m, Monoid b) + => Semigroup (UntaggedC p a b m i i) where (<>) = (>>>) +instance (Polyadic m p, Monad m, Monoid b) + => Monoid (UntaggedC p a b m i i) where mempty = id diff --git a/src/Data/Profunctor/Do/Polyadic.hs b/src/Data/Profunctor/Polyadic/Do.hs similarity index 82% rename from src/Data/Profunctor/Do/Polyadic.hs rename to src/Data/Profunctor/Polyadic/Do.hs index dd3632d..6b47f15 100644 --- a/src/Data/Profunctor/Do/Polyadic.hs +++ b/src/Data/Profunctor/Polyadic/Do.hs @@ -1,5 +1,5 @@ {-| -Module : Data.Profunctor.Do.Polyadic +Module : Data.Profunctor.Polyadic.Do Description : polyadic do-notation Copyright : (C) 2025 - Eitan Chatav License : BSD-style (see the file LICENSE) @@ -8,7 +8,7 @@ Stability : provisional Portability : non-portable -} -module Data.Profunctor.Do.Polyadic +module Data.Profunctor.Polyadic.Do ( -- * (>>=) , (>>) @@ -18,8 +18,8 @@ module Data.Profunctor.Do.Polyadic import Control.Monad.Fix import Data.Profunctor -import Data.Profunctor.Do.Monadic (fail) -import Data.Profunctor.Monadic +import Data.Profunctor.Monadic.Do (fail) +import Data.Profunctor.Polyadic import Prelude hiding ((>>), (>>=), fail) (>>=) From a98ced6e98f1c9a663dd72882c578eddef59960b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 7 Dec 2025 21:09:48 -0800 Subject: [PATCH 157/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index fdd49ba..4998e98 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -1,6 +1,6 @@ {-| Module : Data.Profunctor.Monadic -Description : monadic, polyadic & tetradic profunctors +Description : monadic profunctors Copyright : (C) 2025 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav @@ -26,8 +26,6 @@ import Control.Comonad import Control.Arrow import Control.Lens import Control.Monad -import Control.Monad.State -import Control.Monad.Trans.Indexed import Data.Profunctor import Data.Profunctor.Monoidal import Prelude hiding (id, (.)) From 6845ba70c35b3cd07f0e5de3cb40994848d0c5d5 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 8 Dec 2025 16:44:37 -0800 Subject: [PATCH 158/282] pair bonding notation --- distributors.cabal | 5 ++- src/Data/Profunctor/Do/Bond.hs | 30 ++++++++++++++ src/Data/Profunctor/Do/Polyadic/Bind.hs | 43 +++++++++++++++++++ src/Data/Profunctor/Do/Polyadic/Bond.hs | 38 +++++++++++++++++ src/Data/Profunctor/Grammar.hs | 30 +++++++++----- src/Data/Profunctor/Monadic.hs | 54 +++++------------------- src/Data/Profunctor/Monadic/Do.hs | 48 --------------------- src/Data/Profunctor/Polyadic.hs | 55 ++++++++----------------- src/Data/Profunctor/Polyadic/Do.hs | 35 ---------------- 9 files changed, 162 insertions(+), 176 deletions(-) create mode 100644 src/Data/Profunctor/Do/Bond.hs create mode 100644 src/Data/Profunctor/Do/Polyadic/Bind.hs create mode 100644 src/Data/Profunctor/Do/Polyadic/Bond.hs delete mode 100644 src/Data/Profunctor/Monadic/Do.hs delete mode 100644 src/Data/Profunctor/Polyadic/Do.hs diff --git a/distributors.cabal b/distributors.cabal index d5fd385..357856b 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -43,13 +43,14 @@ library Control.Lens.PartialIso Control.Lens.Wither Data.Profunctor.Distributor + Data.Profunctor.Do.Bond + Data.Profunctor.Do.Polyadic.Bind + Data.Profunctor.Do.Polyadic.Bond Data.Profunctor.Filtrator Data.Profunctor.Grammar Data.Profunctor.Monadic - Data.Profunctor.Monadic.Do Data.Profunctor.Monoidal Data.Profunctor.Polyadic - Data.Profunctor.Polyadic.Do other-modules: Paths_distributors autogen-modules: diff --git a/src/Data/Profunctor/Do/Bond.hs b/src/Data/Profunctor/Do/Bond.hs new file mode 100644 index 0000000..70c6066 --- /dev/null +++ b/src/Data/Profunctor/Do/Bond.hs @@ -0,0 +1,30 @@ +{-| +Module : Data.Profunctor.Do.Bond +Description : monadic pair-bonding do-notation +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + +module Data.Profunctor.Do.Bond + ( -- * + (>>=) + , (>>) + , fail + , return + ) where + +import Data.Profunctor (Profunctor (dimap)) +import Data.Profunctor.Do.Polyadic.Bind (fail) +import Data.Profunctor.Monadic (Monadic (bondM)) +import Prelude hiding ((>>), (>>=), fail) + +(>>=) :: Monadic m p => p m a a -> (a -> p m b c) -> p m (a,b) (a,c) +infixl 1 >>= +(>>=) = flip bondM + +(>>) :: Monadic m p => p m () () -> p m b c -> p m b c +infixl 1 >> +x >> y = dimap ((),) snd (x >>= const y) diff --git a/src/Data/Profunctor/Do/Polyadic/Bind.hs b/src/Data/Profunctor/Do/Polyadic/Bind.hs new file mode 100644 index 0000000..6b68008 --- /dev/null +++ b/src/Data/Profunctor/Do/Polyadic/Bind.hs @@ -0,0 +1,43 @@ +{-| +Module : Data.Profunctor.Do.Polyadic.Bind +Description : polyadic binding do-notation +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + +module Data.Profunctor.Do.Polyadic.Bind + ( -- * + (>>=) + , (>>) + , fail + , return + ) where + +import Data.Profunctor.Monadic (Monadic (liftP)) +import Data.Profunctor.Polyadic (Polyadic, bindP) +import Prelude hiding ((>>), (>>=), fail) +import qualified Prelude (fail) + +(>>=) + :: Polyadic m p + => p i j m a b + -> (b -> p j k m a c) + -> p i k m a c +infixl 1 >>= +(>>=) = flip bindP + +(>>) + :: Polyadic m p + => p i j m a b + -> p j k m a c + -> p i k m a c +infixl 1 >> +x >> y = x >>= const y + +fail + :: (Monadic m p, MonadFail m) + => String -> p m a a +fail = liftP . Prelude.fail diff --git a/src/Data/Profunctor/Do/Polyadic/Bond.hs b/src/Data/Profunctor/Do/Polyadic/Bond.hs new file mode 100644 index 0000000..2ee4129 --- /dev/null +++ b/src/Data/Profunctor/Do/Polyadic/Bond.hs @@ -0,0 +1,38 @@ +{-| +Module : Data.Profunctor.Do.Polyadic.Bond +Description : polyadic pair-bonding do-notation +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + +module Data.Profunctor.Do.Polyadic.Bond + ( -- * + (>>=) + , (>>) + , fail + , return + ) where + +import Data.Profunctor (Profunctor (dimap)) +import Data.Profunctor.Do.Polyadic.Bind (fail) +import Data.Profunctor.Polyadic (Polyadic (bondP)) +import Prelude hiding ((>>), (>>=), fail) + +(>>=) + :: Polyadic m p + => p i i m a a + -> (a -> p i j m b c) + -> p i j m (a,b) (a,c) +infixl 1 >>= +(>>=) = flip bondP + +(>>) + :: Polyadic m p + => p i i m () () + -> p i j m b c + -> p i j m b c +infixl 1 >> +x >> y = dimap ((),) snd (x >>= const y) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index a711804..2fbfe15 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -125,14 +125,16 @@ instance (Alternative m, Monad m) => Alternator (Parsor s s m) where Left (Parsor p) -> Parsor (fmap (\(b, str) -> (Left b, str)) . p) Right (Parsor p) -> Parsor (fmap (\(b, str) -> (Right b, str)) . p) instance Monad m => Monadic m (Parsor s s) where - joinP (Parsor p) = Parsor $ \s -> do - (mb, s') <- p s - b <- mb - return (b, s') + liftP m = Parsor $ \s -> (,s) <$> m + bondM = bondP instance Monad m => Polyadic m Parsor where - composeP (Parsor p) = Parsor $ \s -> do + joinP (Parsor p) = Parsor $ \s -> do (mb, s') <- p s runParsor mb s' + bondP f (Parsor p) = Parsor $ \s0 -> do + (a,s1) <- p s0 + (c,s2) <- runParsor (f a) s1 + return ((a,c),s2) instance Filterable f => Filterable (Parsor s t f a) where mapMaybe f (Parsor p) = Parsor (mapMaybe (\(a,str) -> (,str) <$> f a) . p) instance Filterable f => Cochoice (Parsor s t f) where @@ -194,7 +196,7 @@ instance Filterable f => Filterable (Printor s s f a) where mapMaybe (\(a,q) -> fmap (, q) (f a)) . p instance Monad f => Monad (Printor s s f a) where return = pure - mx >>= f = composeP (fmap f mx) + mx >>= f = joinP (fmap f mx) instance (Alternative f, Monad f) => MonadPlus (Printor s s f a) instance MonadError e m => MonadError e (Printor s s m a) where throwError = liftP . throwError @@ -205,15 +207,17 @@ instance Monad m => MonadReader a (Printor s s m a) where reader f = (Printor (\a -> return (f a, id))) local f = Printor . (\m -> m . f) . runPrintor instance Monad m => Monadic m (Printor s s) where - joinP (Printor mf) = Printor $ \a -> do - (mb, f) <- mf a - b <- mb - return (b, f) + liftP m = Printor $ \_ -> (, id) <$> m + bondM = bondP instance Monad m => Polyadic m Printor where - composeP (Printor mf) = Printor $ \a -> do + joinP (Printor mf) = Printor $ \a -> do (Printor mg, f) <- mf a (b, g) <- mg a return (b, g . f) + bondP f (Printor m) = Printor $ \(a0,b) -> do + (a1,g) <- m a0 + (c,h) <- runPrintor (f a1) b + return ((a1,c), h . g) instance Applicative f => Distributor (Printor s s f) where zeroP = Printor absurd Printor p >+< Printor q = Printor $ @@ -377,6 +381,10 @@ instance (Alternative m, Monad m) => Monadic m Reador where liftP m = Reador $ do s <- ask lift $ FinalT ((,s) <$> m) + bondM f (Reador m) = Reador $ do + a <- m + c <- unReador (f a) + return (a,c) instance (Alternative m, Monad m) => Choice (Reador m) where left' = alternate . Left right' = alternate . Right diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 4998e98..53ea210 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -14,10 +14,6 @@ module Data.Profunctor.Monadic , monochrome_ , withMonochrome , withMonochrome_ - , liftedP - , joined - , joinedP - , bound ) where import Control.Applicative @@ -34,16 +30,20 @@ class ( Profunctor (p m) , forall x. Monad (p m x) ) => Monadic m p where - joinP :: p m a (m b) -> p m a b - joinP = join . fmap liftP liftP :: m b -> p m a b - liftP = joinP . return + bondM :: (a -> p m b c) -> p m a a -> p m (a,b) (a,c) instance Monad m => Monadic m Kleisli where liftP = Kleisli . return + bondM g (Kleisli f) = Kleisli $ \(a0,b) -> do + a1 <- f a0 + c <- runKleisli (g a1) b + return (a1,c) instance Monad m => Monadic m Star where liftP = Star . return -instance Comonad w => Monadic w Costar where - liftP = Costar . return . extract + bondM g (Star f) = Star $ \(a0,b) -> do + a1 <- f a0 + c <- runStar (g a1) b + return (a1,c) monochrome_ :: (Monadic m p, Applicative m) @@ -53,7 +53,7 @@ monochrome_ = monochrome . (*<) monochrome :: (Monadic m p, Applicative m) => (p m a b -> p m s t) -> Optic (p m) m s t a b -monochrome f = fmap pure . f . joinP +monochrome f = fmap pure . f . join . fmap liftP withMonochrome_ :: (Monadic m p, Applicative m) @@ -63,36 +63,4 @@ withMonochrome_ f = withMonochrome f oneP withMonochrome :: (Monadic m p, Applicative m) => Optic (p m) m s t a b -> p m a b -> p m s t -withMonochrome f = joinP . f . fmap pure - -liftedP :: (Monadic m p, Applicative m) => m b -> Optic (p m) m a b () () -liftedP m = monochrome_ (liftP m) - -joinedP :: (Monadic m p, Applicative m) => Optic (p m) m a b a (m b) -joinedP = monochrome joinP - -joined :: (Monadic m p, Applicative m) => Optic (p m) m a b a (p m a b) -joined = monochrome join - -bound - :: (Monadic m p, Applicative m) - => (b -> Optic (p m) m a c a ()) -> Optic (p m) m a c a b -bound f = monochrome $ \p -> do - b <- p - withMonochrome (f b) (return ()) - -newtype WrappedMonadic p m a b = WrapMonadic {unwrapMonadic :: p m a (m b)} -instance (Monadic m p, Monad m) => Functor (WrappedMonadic p m a) where - fmap = rmap -instance (Monadic m p, Monad m) => Applicative (WrappedMonadic p m a) where - pure x = WrapMonadic $ pure (pure x) - WrapMonadic p1 <*> WrapMonadic p2 = WrapMonadic $ liftA2 (<*>) p1 p2 -instance (Monadic m p, Monad m) => Monad (WrappedMonadic p m a) where - return = pure - WrapMonadic p >>= f = WrapMonadic $ do - b <- joinP p - unwrapMonadic (f b) -instance (Monadic m p, Monad m) => Profunctor (WrappedMonadic p m) where - dimap f g (WrapMonadic p) = WrapMonadic $ dimap f (fmap g) p -instance (Monad m, Monadic m p) => Monadic m (WrappedMonadic p) where - joinP (WrapMonadic p) = WrapMonadic (joinP p) +withMonochrome f = join . fmap liftP . f . fmap pure diff --git a/src/Data/Profunctor/Monadic/Do.hs b/src/Data/Profunctor/Monadic/Do.hs deleted file mode 100644 index 38fb198..0000000 --- a/src/Data/Profunctor/Monadic/Do.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-| -Module : Data.Profunctor.Monadic.Do -Description : monadic do-notation -Copyright : (C) 2025 - Eitan Chatav -License : BSD-style (see the file LICENSE) -Maintainer : Eitan Chatav -Stability : provisional -Portability : non-portable --} - -module Data.Profunctor.Monadic.Do - ( -- * - (>>=) - , (>>) - , fail - , return - , boundRec - ) where - -import Control.Lens -import Control.Monad.Fix -import Data.Profunctor.Monadic -import Prelude hiding ((>>), (>>=), fail) -import qualified Prelude - -(>>=) - :: (Monadic m p, forall x. MonadFix (p m x)) - => p m a a -> (a -> p m b c) -> p m b c -infixl 1 >>= -x >>= f = mdo - a <- lmap (const a) x - f a - -(>>) - :: (Monadic m p, forall x. MonadFix (p m x)) - => p m a a -> p m b c -> p m b c -infixl 1 >> -x >> y = x >>= const y - -fail - :: (Monadic m p, MonadFail m) - => String -> p m a a -fail = liftP . Prelude.fail - -boundRec - :: (Monadic m p, Applicative m, forall x. MonadFix (p m x)) - => (a -> Optic' (p m) m b ()) -> Optic' (p m) m b a -boundRec f = monochrome (>>= rmap withMonochrome_ f) diff --git a/src/Data/Profunctor/Polyadic.hs b/src/Data/Profunctor/Polyadic.hs index a4bfea0..633d1bb 100644 --- a/src/Data/Profunctor/Polyadic.hs +++ b/src/Data/Profunctor/Polyadic.hs @@ -8,12 +8,11 @@ Stability : provisional Portability : non-portable -} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE PolyKinds, QualifiedDo #-} module Data.Profunctor.Polyadic - ( Polyadic (..) + ( Polyadic (..), bindP , Tetradic (..) - , WrappedPolyadic (..) , TaggedP (..) , UntaggedT (..) , UntaggedC (..) @@ -26,6 +25,7 @@ import Control.Lens import Control.Monad import Control.Monad.State import Control.Monad.Trans.Indexed +import qualified Control.Monad.Trans.Indexed.Do as Ix import Data.Profunctor.Monadic import Prelude hiding (id, (.)) @@ -34,7 +34,11 @@ class , forall i j x. Functor (p i j m x) , forall i. Monadic m (p i i) ) => Polyadic m p where - composeP :: p i j m a (p j k m a b) -> p i k m a b + joinP :: p i j m a (p j k m a b) -> p i k m a b + bondP :: (a -> p i j m b c) -> p i i m a a -> p i j m (a,b) (a,c) + +bindP :: Polyadic m p => (b -> p j k m a c) -> p i j m a b -> p i k m a c +bindP f p = joinP (fmap f p) class (forall i j. Profunctor (p i j f)) => Tetradic f p where @@ -49,44 +53,21 @@ class (forall i j. Profunctor (p i j f)) => Tetradic f p where -> p i j f a b -> p h k f a b dimapT f1 f2 = tetramap f1 f2 id id -newtype WrappedPolyadic p i j m a b = - WrapPolyadic {unwrapPolyadic :: p i j m a (m b)} -instance (Polyadic m p, Monad m) - => Functor (WrappedPolyadic p i j m a) where - fmap = rmap -instance (Polyadic m p, Monad m) - => Applicative (WrappedPolyadic p i i m a) where - pure x = WrapPolyadic $ pure (pure x) - WrapPolyadic p1 <*> WrapPolyadic p2 = - WrapPolyadic $ liftA2 (<*>) p1 p2 -instance (Polyadic m p, Monad m) - => Monad (WrappedPolyadic p i i m a) where - return = pure - WrapPolyadic p >>= f = WrapPolyadic $ do - b <- joinP p - unwrapPolyadic (f b) -instance (Polyadic m p, Monad m) - => Profunctor (WrappedPolyadic p i j m) where - dimap f g = WrapPolyadic . dimap f (fmap g) . unwrapPolyadic -instance (Monad m, Polyadic m p) - => Monadic m (WrappedPolyadic p i i) where - joinP = WrapPolyadic . joinP . unwrapPolyadic -instance (Monad m, Polyadic m p) => Polyadic m (WrappedPolyadic p) where - composeP - = WrapPolyadic . composeP - . fmap unwrapPolyadic . composeP - . fmap liftP . unwrapPolyadic - newtype TaggedP t i j f a b = TagP {untagP :: t i j f b} deriving newtype (Functor, Applicative, Monad) instance Functor (t i j f) => Profunctor (TaggedP t i j f) where dimap _ f = TagP . fmap f . untagP -instance (Monad m, MonadTrans (t i j)) - => Monadic m (TaggedP t i j) where +instance (Monad m, IxMonadTrans t) + => Monadic m (TaggedP t i i) where liftP = TagP . lift + bondM = bondP instance (Monad m, IxMonadTrans t) => Polyadic m (TaggedP t) where - composeP = TagP . joinIx . fmap untagP . untagP + joinP = TagP . joinIx . fmap untagP . untagP + bondP f (TagP m) = TagP $ Ix.do + a <- m + c <- untagP (f a) + return (a,c) newtype UntaggedT p a i j f b = UntagT {tagT :: p i j f a b} deriving newtype (Functor, Applicative, Monad) @@ -95,7 +76,7 @@ instance (forall m. Monad m => Monadic m (p i j)) lift = UntagT . liftP instance (forall m. Monad m => Polyadic m p) => IxMonadTrans (UntaggedT p a) where - joinIx = UntagT . composeP . fmap tagT . tagT + joinIx = UntagT . joinP . fmap tagT . tagT newtype UntaggedC p a b f i j = UntagC {tagC :: p i j f a b} instance (Tetradic f p, Functor f) => Tetradic f (UntaggedC p) where @@ -106,7 +87,7 @@ instance (Tetradic f p, Functor f) => Functor (UntaggedC p a b f i) where fmap = rmap instance (Polyadic m p, Monoid b) => Category (UntaggedC p a b m) where id = UntagC (pure mempty) - UntagC g . UntagC f = UntagC (composeP (fmap (\b -> fmap (<> b) g) f)) + UntagC g . UntagC f = UntagC (joinP (fmap (\b -> fmap (<> b) g) f)) instance (Polyadic m p, Monad m, Monoid b) => Semigroup (UntaggedC p a b m i i) where (<>) = (>>>) instance (Polyadic m p, Monad m, Monoid b) diff --git a/src/Data/Profunctor/Polyadic/Do.hs b/src/Data/Profunctor/Polyadic/Do.hs deleted file mode 100644 index 6b47f15..0000000 --- a/src/Data/Profunctor/Polyadic/Do.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-| -Module : Data.Profunctor.Polyadic.Do -Description : polyadic do-notation -Copyright : (C) 2025 - Eitan Chatav -License : BSD-style (see the file LICENSE) -Maintainer : Eitan Chatav -Stability : provisional -Portability : non-portable --} - -module Data.Profunctor.Polyadic.Do - ( -- * - (>>=) - , (>>) - , fail - , return - ) where - -import Control.Monad.Fix -import Data.Profunctor -import Data.Profunctor.Monadic.Do (fail) -import Data.Profunctor.Polyadic -import Prelude hiding ((>>), (>>=), fail) - -(>>=) - :: (Polyadic m p, forall x. MonadFix (p i i m x)) - => p i i m a a -> (a -> p i j m b c) -> p i j m b c -infixl 1 >>= -x >>= f = composeP (fmap f (mfix (\a -> lmap (const a) x))) - -(>>) - :: (Polyadic m p, forall x. MonadFix (p i i m x)) - => p i i m a a -> p i j m b c -> p i j m b c -infixl 1 >> -x >> y = x >>= (\_ -> y) From 0ac78ca5e7a0b5966e02303ee5edc3181ddbb9ea Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 8 Dec 2025 16:45:33 -0800 Subject: [PATCH 159/282] Create TODO --- TODO | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 TODO diff --git a/TODO b/TODO new file mode 100644 index 0000000..28d71cb --- /dev/null +++ b/TODO @@ -0,0 +1,10 @@ +TODO + +x Monadic interface ala Lysxia + Parsec profunctor with TokenTest & NonTerminal errors ala Leijen + Categoric interface with diid + Arrowic? + Tests + Documents + Announcement + Delete TODO From 8f2ead501a75c0d95b8af4628237221c22115411 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 9 Dec 2025 19:52:30 -0800 Subject: [PATCH 160/282] replicateN --- .gitignore | 1 + TODO | 6 ++++-- src/Data/Profunctor/Do/Bond.hs | 14 ++++++++++++-- src/Data/Profunctor/Grammar.hs | 8 ++++---- src/Data/Profunctor/Monadic.hs | 16 ++++++++-------- src/Data/Profunctor/Monoidal.hs | 8 +++++++- 6 files changed, 36 insertions(+), 17 deletions(-) diff --git a/.gitignore b/.gitignore index d52bcb1..972ef57 100644 --- a/.gitignore +++ b/.gitignore @@ -23,3 +23,4 @@ stack.yaml.lock tags .*.swp .qodo +SCRATCH* diff --git a/TODO b/TODO index 28d71cb..005e0bf 100644 --- a/TODO +++ b/TODO @@ -1,10 +1,12 @@ TODO x Monadic interface ala Lysxia - Parsec profunctor with TokenTest & NonTerminal errors ala Leijen + Monadic example grammar + More Tests + Parsec profunctor with either TokenTest or NonTerminal errors ala Leijen Categoric interface with diid Arrowic? - Tests + Read Chomsky Documents Announcement Delete TODO diff --git a/src/Data/Profunctor/Do/Bond.hs b/src/Data/Profunctor/Do/Bond.hs index 70c6066..79838ac 100644 --- a/src/Data/Profunctor/Do/Bond.hs +++ b/src/Data/Profunctor/Do/Bond.hs @@ -12,14 +12,17 @@ module Data.Profunctor.Do.Bond ( -- * (>>=) , (>>) + , (<$>) , fail , return ) where +import Control.Lens (Optic) +import Control.Monad (join) import Data.Profunctor (Profunctor (dimap)) import Data.Profunctor.Do.Polyadic.Bind (fail) -import Data.Profunctor.Monadic (Monadic (bondM)) -import Prelude hiding ((>>), (>>=), fail) +import Data.Profunctor.Monadic (Monadic (liftP, bondM)) +import Prelude (Applicative (pure), const, fmap, flip, fst, snd, return, (.)) (>>=) :: Monadic m p => p m a a -> (a -> p m b c) -> p m (a,b) (a,c) infixl 1 >>= @@ -28,3 +31,10 @@ infixl 1 >>= (>>) :: Monadic m p => p m () () -> p m b c -> p m b c infixl 1 >> x >> y = dimap ((),) snd (x >>= const y) + +(<$>) + :: (Monadic m p, Applicative m) + => Optic (p m) m s t a b + -> p m (a,()) (b,()) -> p m s t +infixl 4 <$> +f <$> x = join (fmap liftP (f (dimap (,()) (pure . fst) x))) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 2fbfe15..de34436 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -214,10 +214,10 @@ instance Monad m => Polyadic m Printor where (Printor mg, f) <- mf a (b, g) <- mg a return (b, g . f) - bondP f (Printor m) = Printor $ \(a0,b) -> do - (a1,g) <- m a0 - (c,h) <- runPrintor (f a1) b - return ((a1,c), h . g) + bondP f (Printor m) = Printor $ \(x,b) -> do + (y,g) <- m x + (c,h) <- runPrintor (f y) b + return ((y,c), h . g) instance Applicative f => Distributor (Printor s s f) where zeroP = Printor absurd Printor p >+< Printor q = Printor $ diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 53ea210..9bd7646 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -34,16 +34,16 @@ class bondM :: (a -> p m b c) -> p m a a -> p m (a,b) (a,c) instance Monad m => Monadic m Kleisli where liftP = Kleisli . return - bondM g (Kleisli f) = Kleisli $ \(a0,b) -> do - a1 <- f a0 - c <- runKleisli (g a1) b - return (a1,c) + bondM g (Kleisli f) = Kleisli $ \(x,b) -> do + y <- f x + c <- runKleisli (g y) b + return (y,c) instance Monad m => Monadic m Star where liftP = Star . return - bondM g (Star f) = Star $ \(a0,b) -> do - a1 <- f a0 - c <- runStar (g a1) b - return (a1,c) + bondM g (Star f) = Star $ \(x,b) -> do + y <- f x + c <- runStar (g y) b + return (y,c) monochrome_ :: (Monadic m p, Applicative m) diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index 9d4216d..07d90ca 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -5,7 +5,7 @@ module Data.Profunctor.Monoidal Monoidal , oneP, (>*<), (>*), (*<) , dimap2, foreverP, replicateP - , (>:<), asEmpty + , (>:<), asEmpty, replicateN , meander, eotFunList ) where @@ -115,6 +115,12 @@ asEmpty = _Empty >? oneP x >:< xs = _Cons >? x >*< xs infixr 5 >:< +replicateN + :: (Monoidal p, Choice p, AsEmpty s, AsEmpty t, Cons s t a b) + => Int -> p a b -> p s t +replicateN n _ | n <= 0 = lmap (const Empty) asEmpty +replicateN n a = a >:< replicateN (n-1) a + {- | For any `Monoidal`, `Choice` & `Strong` `Profunctor`, `meander` is invertible and gives a default implementation for the `Data.Profunctor.Traversing.wander` From 1ac26e2fc80da8716f50467f8b35274d920b83fd Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 19 Dec 2025 18:07:35 -0800 Subject: [PATCH 161/282] PP --- src/Data/Profunctor/Grammar.hs | 129 ++++++++++++++++++++++++++++++++- 1 file changed, 126 insertions(+), 3 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index de34436..2e21dd3 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -1,6 +1,9 @@ module Data.Profunctor.Grammar ( -- * Parsor Parsor (..) + , PP (..) + , printP + , parseP -- * Printor , Printor (..) , printor @@ -55,6 +58,12 @@ printor f = Printor (\a -> fmap (a,) (f a)) evalPrintor :: Functor f => Printor s t f a b -> a -> f (s -> t) evalPrintor (Printor f) = fmap snd . f +newtype PP s t f a b = PP {runPP :: Maybe a -> s -> f (b,t)} +printP :: Functor f => PP s t f a b -> a -> s -> f t +printP (PP f) a = fmap snd . f (Just a) +parseP :: PP s t f a b -> s -> f (b,t) +parseP (PP f) = f Nothing + newtype Grammor s t f a b = Grammor {runGrammor :: s -> f t} grammor :: Applicative f => t -> Grammor s t f a b grammor = Grammor . pure . pure @@ -81,6 +90,120 @@ runLookT (LookT f) s = runLookT (f s) s runLookT (ResultT x p) s = pure (x,s) <|> runLookT p s runLookT (FinalT r) _ = r +-- PP instances +deriving stock instance Functor f => Functor (PP s t f a) +instance Functor f => Profunctor (PP s t f) where + dimap f g = PP . dimap (fmap f) (fmap (fmap (first' g))) . runPP +instance Functor f => Tetradic f PP where + dimapT f g = PP . fmap (dimap f (fmap (second' g))) . runPP + tetramap f g h i = PP . dimap (fmap h) (dimap f (fmap (i >*< g))) . runPP +instance Monad m => Applicative (PP s s m a) where + pure b = PP (\_ s -> pure (b,s)) + PP x <*> PP y = PP $ \ma s -> do + (f, t) <- x ma s + (a, u) <- y ma t + return (f a, u) +instance Monad m => Monad (PP s s m a) where + return = pure + PP p >>= f = PP $ \ma s -> do + (a, t) <- p ma s + runPP (f a) ma t +instance (Alternative m, Monad m) => Alternative (PP s s m a) where + empty = PP (\_ _ -> empty) + PP p <|> PP q = PP $ \ma s -> p ma s <|> q ma s +instance (Alternative m, Monad m) => MonadPlus (PP s s m a) +instance Filterable f => Filterable (PP s t f a) where + mapMaybe f (PP p) = PP $ \fa s -> + mapMaybe (\(a,t) -> fmap (,t) (f a)) (p fa s) +instance Filterable f => Cochoice (PP s t f) where + unleft = fst . filtrate + unright = snd . filtrate +instance Filterable f => Filtrator (PP s t f) where + filtrate (PP p) = + ( PP $ \ma s -> mapMaybe + (\case{(Left b,t) -> Just (b,t); _ -> Nothing}) + (p (fmap Left ma) s) + , PP $ \ma s -> mapMaybe + (\case{(Right b,t) -> Just (b,t); _ -> Nothing}) + (p (fmap Right ma) s) + ) +instance Monad m => Monadic m (PP s s) where + liftP m = PP $ \_ s -> (,s) <$> m + bondM = bondP +instance Monad m => Polyadic m PP where + joinP (PP mf) = PP $ \ma s -> do + (PP mg, j) <- mf ma s + mg ma j + bondP (PP p) f = PP $ \case + Nothing -> \s0 -> do + (x,s1) <- p Nothing s0 + (y,s2) <- runPP (f x) Nothing s1 + return ((x,y),s2) + Just (a,b) -> \s0 -> do + (x,s1) <- p (Just a) s0 + (y,s2) <- runPP (f x) (Just b) s1 + return ((a,y),s2) +instance (Alternative m, Monad m) => Distributor (PP s s m) +instance (Alternative m, Monad m) => Choice (PP s s m) where + left' = alternate . Left + right' = alternate . Right +instance (Alternative m, Monad m) => Alternator (PP s s m) where + alternate = \case + Left (PP p) -> PP $ \ma s -> case ma of + Nothing -> fmap (first' Left) (p Nothing s) + Just (Left a) -> fmap (first' Left) (p (Just a) s) + Just (Right _) -> empty + Right (PP p) -> PP $ \ma s -> case ma of + Nothing -> fmap (first' Right) (p Nothing s) + Just (Right a) -> fmap (first' Right) (p (Just a) s) + Just (Left _) -> empty +instance (Alternative m, Monad m) => Category (PP s s m) where + id = PP $ \ma s -> case ma of + Nothing -> empty + Just a -> pure (a,s) + PP q . PP p = PP $ \ma s -> case ma of + Nothing -> empty + Just a -> do + (b, t) <- p (Just a) s + q (Just b) t +instance (Alternative m, Monad m) => Arrow (PP s s m) where + arr f = PP $ \ma s -> case ma of + Nothing -> empty + Just a -> pure (f a, s) + (***) = (>*<) +instance (Alternative m, Monad m) => ArrowZero (PP s s m) where + zeroArrow = empty +instance (Alternative m, Monad m) => ArrowPlus (PP s s m) where + (<+>) = (<|>) +instance (Alternative m, Monad m) => ArrowChoice (PP s s m) where + (+++) = (>+<) + left = left' + right = right' +-- instance +-- ( Categorized a, a ~ Item s, IsList s, Cons s s a a +-- , Filterable m, Alternative m, Monad m +-- ) => Tokenized a (Printor s s m a a) where +-- anyToken = Printor (\b -> pure (b, cons b)) +-- instance +-- ( Categorized a, a ~ Item s, IsList s, Cons s s a a +-- , Filterable m, Alternative m, Monad m +-- ) => TokenAlgebra a (Printor s s m a a) +-- instance +-- ( Categorized a, a ~ Item s, IsList s, Cons s s a a +-- , Filterable m, Alternative m, Monad m +-- ) => TerminalSymbol a (Printor s s m () ()) where +-- instance +-- ( Char ~ Item s, IsList s, Cons s s Char Char +-- , Filterable m, Alternative m, Monad m +-- ) => IsString (Printor s s m () ()) where +-- fromString = terminal +-- instance +-- ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s +-- , Filterable m, Alternative m, Monad m +-- ) => IsString (Printor s s m s s) where +-- fromString = fromTokens +-- instance BackusNaurForm (Printor s t m a b) + -- Parsor instances instance Functor f => Functor (Parsor s t f a) where fmap f = Parsor . fmap (fmap (first' f)) . runParsor @@ -131,7 +254,7 @@ instance Monad m => Polyadic m Parsor where joinP (Parsor p) = Parsor $ \s -> do (mb, s') <- p s runParsor mb s' - bondP f (Parsor p) = Parsor $ \s0 -> do + bondP (Parsor p) f = Parsor $ \s0 -> do (a,s1) <- p s0 (c,s2) <- runParsor (f a) s1 return ((a,c),s2) @@ -214,7 +337,7 @@ instance Monad m => Polyadic m Printor where (Printor mg, f) <- mf a (b, g) <- mg a return (b, g . f) - bondP f (Printor m) = Printor $ \(x,b) -> do + bondP (Printor m) f = Printor $ \(x,b) -> do (y,g) <- m x (c,h) <- runPrintor (f y) b return ((y,c), h . g) @@ -381,7 +504,7 @@ instance (Alternative m, Monad m) => Monadic m Reador where liftP m = Reador $ do s <- ask lift $ FinalT ((,s) <$> m) - bondM f (Reador m) = Reador $ do + bondM (Reador m) f = Reador $ do a <- m c <- unReador (f a) return (a,c) From 472ed4441eee72ac65e9a2458f28bb29bf77982b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Fri, 19 Dec 2025 18:08:10 -0800 Subject: [PATCH 162/282] Grammar.Do --- distributors.cabal | 4 +- .../Do/Bond.hs => Control/Lens/Grammar/Do.hs} | 14 +++--- src/Data/Profunctor/Do/Polyadic/Bind.hs | 43 ------------------- src/Data/Profunctor/Do/Polyadic/Bond.hs | 38 ---------------- 4 files changed, 10 insertions(+), 89 deletions(-) rename src/{Data/Profunctor/Do/Bond.hs => Control/Lens/Grammar/Do.hs} (69%) delete mode 100644 src/Data/Profunctor/Do/Polyadic/Bind.hs delete mode 100644 src/Data/Profunctor/Do/Polyadic/Bond.hs diff --git a/distributors.cabal b/distributors.cabal index 357856b..7defa19 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -33,6 +33,7 @@ library Control.Lens.Grammar Control.Lens.Grammar.BackusNaur Control.Lens.Grammar.Boole + Control.Lens.Grammar.Do Control.Lens.Grammar.Kleene Control.Lens.Grammar.Symbol Control.Lens.Grammar.Token @@ -43,9 +44,6 @@ library Control.Lens.PartialIso Control.Lens.Wither Data.Profunctor.Distributor - Data.Profunctor.Do.Bond - Data.Profunctor.Do.Polyadic.Bind - Data.Profunctor.Do.Polyadic.Bond Data.Profunctor.Filtrator Data.Profunctor.Grammar Data.Profunctor.Monadic diff --git a/src/Data/Profunctor/Do/Bond.hs b/src/Control/Lens/Grammar/Do.hs similarity index 69% rename from src/Data/Profunctor/Do/Bond.hs rename to src/Control/Lens/Grammar/Do.hs index 79838ac..15e4f99 100644 --- a/src/Data/Profunctor/Do/Bond.hs +++ b/src/Control/Lens/Grammar/Do.hs @@ -1,5 +1,5 @@ {-| -Module : Data.Profunctor.Do.Bond +Module : Control.Lens.Grammar Description : monadic pair-bonding do-notation Copyright : (C) 2025 - Eitan Chatav License : BSD-style (see the file LICENSE) @@ -8,7 +8,7 @@ Stability : provisional Portability : non-portable -} -module Data.Profunctor.Do.Bond +module Control.Lens.Grammar.Do ( -- * (>>=) , (>>) @@ -17,16 +17,17 @@ module Data.Profunctor.Do.Bond , return ) where +import Control.Applicative (Alternative(empty)) import Control.Lens (Optic) +import Control.Lens.Grammar.BackusNaur (BackusNaurForm (rule)) import Control.Monad (join) import Data.Profunctor (Profunctor (dimap)) -import Data.Profunctor.Do.Polyadic.Bind (fail) import Data.Profunctor.Monadic (Monadic (liftP, bondM)) -import Prelude (Applicative (pure), const, fmap, flip, fst, snd, return, (.)) +import Prelude (Applicative (pure), const, fmap, fst, snd, return, (.), String) (>>=) :: Monadic m p => p m a a -> (a -> p m b c) -> p m (a,b) (a,c) infixl 1 >>= -(>>=) = flip bondM +(>>=) = bondM (>>) :: Monadic m p => p m () () -> p m b c -> p m b c infixl 1 >> @@ -38,3 +39,6 @@ x >> y = dimap ((),) snd (x >>= const y) -> p m (a,()) (b,()) -> p m s t infixl 4 <$> f <$> x = join (fmap liftP (f (dimap (,()) (pure . fst) x))) + +fail :: (Alternative f, BackusNaurForm (f a)) => String -> f a +fail msg = rule msg empty diff --git a/src/Data/Profunctor/Do/Polyadic/Bind.hs b/src/Data/Profunctor/Do/Polyadic/Bind.hs deleted file mode 100644 index 6b68008..0000000 --- a/src/Data/Profunctor/Do/Polyadic/Bind.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-| -Module : Data.Profunctor.Do.Polyadic.Bind -Description : polyadic binding do-notation -Copyright : (C) 2025 - Eitan Chatav -License : BSD-style (see the file LICENSE) -Maintainer : Eitan Chatav -Stability : provisional -Portability : non-portable --} - -module Data.Profunctor.Do.Polyadic.Bind - ( -- * - (>>=) - , (>>) - , fail - , return - ) where - -import Data.Profunctor.Monadic (Monadic (liftP)) -import Data.Profunctor.Polyadic (Polyadic, bindP) -import Prelude hiding ((>>), (>>=), fail) -import qualified Prelude (fail) - -(>>=) - :: Polyadic m p - => p i j m a b - -> (b -> p j k m a c) - -> p i k m a c -infixl 1 >>= -(>>=) = flip bindP - -(>>) - :: Polyadic m p - => p i j m a b - -> p j k m a c - -> p i k m a c -infixl 1 >> -x >> y = x >>= const y - -fail - :: (Monadic m p, MonadFail m) - => String -> p m a a -fail = liftP . Prelude.fail diff --git a/src/Data/Profunctor/Do/Polyadic/Bond.hs b/src/Data/Profunctor/Do/Polyadic/Bond.hs deleted file mode 100644 index 2ee4129..0000000 --- a/src/Data/Profunctor/Do/Polyadic/Bond.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-| -Module : Data.Profunctor.Do.Polyadic.Bond -Description : polyadic pair-bonding do-notation -Copyright : (C) 2025 - Eitan Chatav -License : BSD-style (see the file LICENSE) -Maintainer : Eitan Chatav -Stability : provisional -Portability : non-portable --} - -module Data.Profunctor.Do.Polyadic.Bond - ( -- * - (>>=) - , (>>) - , fail - , return - ) where - -import Data.Profunctor (Profunctor (dimap)) -import Data.Profunctor.Do.Polyadic.Bind (fail) -import Data.Profunctor.Polyadic (Polyadic (bondP)) -import Prelude hiding ((>>), (>>=), fail) - -(>>=) - :: Polyadic m p - => p i i m a a - -> (a -> p i j m b c) - -> p i j m (a,b) (a,c) -infixl 1 >>= -(>>=) = flip bondP - -(>>) - :: Polyadic m p - => p i i m () () - -> p i j m b c - -> p i j m b c -infixl 1 >> -x >> y = dimap ((),) snd (x >>= const y) From 8b0b36ad8bb041670d38ac177ccc83617978fc5b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 20 Dec 2025 08:34:42 -0800 Subject: [PATCH 163/282] do stuff --- TODO | 1 - src/Control/Lens/Grammar/Do.hs | 11 +++++------ 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/TODO b/TODO index 005e0bf..d3b3cf1 100644 --- a/TODO +++ b/TODO @@ -5,7 +5,6 @@ x Monadic interface ala Lysxia More Tests Parsec profunctor with either TokenTest or NonTerminal errors ala Leijen Categoric interface with diid - Arrowic? Read Chomsky Documents Announcement diff --git a/src/Control/Lens/Grammar/Do.hs b/src/Control/Lens/Grammar/Do.hs index 15e4f99..f7b5554 100644 --- a/src/Control/Lens/Grammar/Do.hs +++ b/src/Control/Lens/Grammar/Do.hs @@ -17,13 +17,12 @@ module Control.Lens.Grammar.Do , return ) where -import Control.Applicative (Alternative(empty)) -import Control.Lens (Optic) -import Control.Lens.Grammar.BackusNaur (BackusNaurForm (rule)) +import Control.Applicative hiding ((<$>)) +import Control.Lens +import Control.Lens.Grammar.BackusNaur import Control.Monad (join) -import Data.Profunctor (Profunctor (dimap)) -import Data.Profunctor.Monadic (Monadic (liftP, bondM)) -import Prelude (Applicative (pure), const, fmap, fst, snd, return, (.), String) +import Data.Profunctor.Monadic +import Prelude hiding ((>>=), (>>), (<$>), fail) (>>=) :: Monadic m p => p m a a -> (a -> p m b c) -> p m (a,b) (a,c) infixl 1 >>= From 192d7c10cc0ee6dc42ba81ae67364d208f36b27e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 20 Dec 2025 08:35:06 -0800 Subject: [PATCH 164/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 9bd7646..31c3d0b 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -31,16 +31,16 @@ class , forall x. Monad (p m x) ) => Monadic m p where liftP :: m b -> p m a b - bondM :: (a -> p m b c) -> p m a a -> p m (a,b) (a,c) + bondM :: p m a a -> (a -> p m b c) -> p m (a,b) (a,c) instance Monad m => Monadic m Kleisli where liftP = Kleisli . return - bondM g (Kleisli f) = Kleisli $ \(x,b) -> do + bondM (Kleisli f) g = Kleisli $ \(x,b) -> do y <- f x c <- runKleisli (g y) b return (y,c) instance Monad m => Monadic m Star where liftP = Star . return - bondM g (Star f) = Star $ \(x,b) -> do + bondM (Star f) g = Star $ \(x,b) -> do y <- f x c <- runStar (g y) b return (y,c) From 2b7220824595c689e716972c8b0e4add3232328f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 20 Dec 2025 08:36:36 -0800 Subject: [PATCH 165/282] Update Polyadic.hs --- src/Data/Profunctor/Polyadic.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Profunctor/Polyadic.hs b/src/Data/Profunctor/Polyadic.hs index 633d1bb..b330d27 100644 --- a/src/Data/Profunctor/Polyadic.hs +++ b/src/Data/Profunctor/Polyadic.hs @@ -35,7 +35,7 @@ class , forall i. Monadic m (p i i) ) => Polyadic m p where joinP :: p i j m a (p j k m a b) -> p i k m a b - bondP :: (a -> p i j m b c) -> p i i m a a -> p i j m (a,b) (a,c) + bondP :: p i i m a a -> (a -> p i j m b c) -> p i j m (a,b) (a,c) bindP :: Polyadic m p => (b -> p j k m a c) -> p i j m a b -> p i k m a c bindP f p = joinP (fmap f p) @@ -64,7 +64,7 @@ instance (Monad m, IxMonadTrans t) instance (Monad m, IxMonadTrans t) => Polyadic m (TaggedP t) where joinP = TagP . joinIx . fmap untagP . untagP - bondP f (TagP m) = TagP $ Ix.do + bondP (TagP m) f = TagP $ Ix.do a <- m c <- untagP (f a) return (a,c) From d8f53ee5a07bf90bbe660aed9acf5e650f65f04d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 20 Dec 2025 08:45:23 -0800 Subject: [PATCH 166/282] remove Equator --- distributors.cabal | 1 - src/Control/Lens/Bifocal.hs | 5 +---- src/Control/Lens/Diopter.hs | 5 +---- src/Control/Lens/Grate.hs | 5 +---- src/Control/Lens/Internal/Equator.hs | 23 ----------------------- src/Control/Lens/Monocle.hs | 5 +---- 6 files changed, 4 insertions(+), 40 deletions(-) delete mode 100644 src/Control/Lens/Internal/Equator.hs diff --git a/distributors.cabal b/distributors.cabal index 7defa19..c37f30f 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -38,7 +38,6 @@ library Control.Lens.Grammar.Symbol Control.Lens.Grammar.Token Control.Lens.Grate - Control.Lens.Internal.Equator Control.Lens.Internal.NestedPrismTH Control.Lens.Monocle Control.Lens.PartialIso diff --git a/src/Control/Lens/Bifocal.hs b/src/Control/Lens/Bifocal.hs index 4149cfc..a7a6845 100644 --- a/src/Control/Lens/Bifocal.hs +++ b/src/Control/Lens/Bifocal.hs @@ -34,7 +34,6 @@ module Control.Lens.Bifocal import Control.Applicative import Control.Lens -import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Control.Lens.PartialIso import Data.Profunctor @@ -137,7 +136,7 @@ chained assoc binPat nilPat = unwrapPafb . chain assoc binPat nilPat noSep . Wra withBifocal :: (Alternative f, Filterable f) => ABifocal s t a b -> ((s -> Maybe a) -> f b) -> f t -withBifocal bif = unBinocular (catMaybes (bif (Just <$> equate))) +withBifocal bif = unBinocular (catMaybes (bif (Just <$> Binocular ($ Just)))) {- | `Binocular` provides an efficient concrete representation of `Bifocal`s. -} @@ -146,8 +145,6 @@ newtype Binocular a b s t = Binocular :: forall f. (Alternative f, Filterable f) => ((s -> Maybe a) -> f b) -> f t } -instance Equator a b (Binocular a b) where - equate = 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 diff --git a/src/Control/Lens/Diopter.hs b/src/Control/Lens/Diopter.hs index e487c3c..0403c52 100644 --- a/src/Control/Lens/Diopter.hs +++ b/src/Control/Lens/Diopter.hs @@ -25,7 +25,6 @@ module Control.Lens.Diopter ) where import Control.Lens -import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Data.Profunctor.Distributor import Data.Void @@ -56,7 +55,7 @@ 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 <$> equate) of +withDiopter dio k = case runIdentity <$> dio (Identity <$> Dioptrice Par1 unPar1) of Dioptrice f g -> k f g {- | Action of `ADiopter` on `Distributor`s. -} @@ -95,8 +94,6 @@ data Dioptrice a b s t where => (s -> h a) -> (h b -> t) -> Dioptrice a b s t -instance Equator a b (Dioptrice a b) where - equate = 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 diff --git a/src/Control/Lens/Grate.hs b/src/Control/Lens/Grate.hs index 9e27926..832f5ec 100644 --- a/src/Control/Lens/Grate.hs +++ b/src/Control/Lens/Grate.hs @@ -30,7 +30,6 @@ module Control.Lens.Grate , Grating (..) ) where -import Control.Lens.Internal.Equator import Data.Distributive import Data.Function import Data.Functor.Identity @@ -78,7 +77,7 @@ cloneGrate = grate . withGrate {- | Run `AGrate`. -} withGrate :: AGrate s t a b -> ((s -> a) -> b) -> t -withGrate grt = runGrating $ runIdentity <$> grt (Identity <$> equate) +withGrate grt = runGrating $ runIdentity <$> grt (Identity <$> Grating ($ id)) {- | Distribute over a `Closed` `Profunctor`. -} distributing @@ -109,8 +108,6 @@ instance Functor (Grating a b s) where fmap = fmapRep instance Applicative (Grating a b s) where pure = pureRep (<*>) = apRep -instance Equator a b (Grating a b) where - equate = Grating ($ id) instance Distributive (Grating a b s) where distribute = distributeRep collect = collectRep diff --git a/src/Control/Lens/Internal/Equator.hs b/src/Control/Lens/Internal/Equator.hs deleted file mode 100644 index b435447..0000000 --- a/src/Control/Lens/Internal/Equator.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Control.Lens.Internal.Equator - ( -- * Equator - Equator (..) - ) where - -import Control.Lens -import Control.Lens.Internal.Iso -import Control.Lens.Internal.Prism -import Control.Lens.Internal.Profunctor -import Control.Lens.PartialIso - -class Equator a b p | p -> a, p -> b where - equate :: p a b -instance Equator a b (Identical a b) where equate = Identical -instance Equator a b (Exchange a b) where - equate = Exchange id id -instance Equator a b (Market a b) where - equate = Market id Right -instance Equator a b (PartialExchange a b) where - equate = PartialExchange Just Just -instance (Equator a b p, Profunctor p, Applicative f) - => Equator a b (WrappedPafb f p) where - equate = WrapPafb (rmap pure equate) diff --git a/src/Control/Lens/Monocle.hs b/src/Control/Lens/Monocle.hs index 166d468..d67d785 100644 --- a/src/Control/Lens/Monocle.hs +++ b/src/Control/Lens/Monocle.hs @@ -27,7 +27,6 @@ module Control.Lens.Monocle ) where import Control.Lens hiding (Traversing) -import Control.Lens.Internal.Equator import Control.Lens.Internal.Profunctor import Data.Distributive import Data.Profunctor.Monoidal @@ -77,14 +76,12 @@ 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 <$> equate)) +withMonocle mon = unMonocular (runIdentity <$> mon (Identity <$> Monocular ($ id))) {- | `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 Equator a b (Monocular a b) where - equate = Monocular ($ id) instance Profunctor (Monocular a b) where dimap f g (Monocular k) = Monocular (fmap g . k . (. (. f))) From 57783f93fc8be9fb244fb5b38a4957bafe80dabd Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 20 Dec 2025 11:28:37 -0800 Subject: [PATCH 167/282] remove failB & passB --- src/Control/Lens/Grammar/Boole.hs | 36 +++++++++++-------------------- 1 file changed, 13 insertions(+), 23 deletions(-) diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index 8759b32..997c20f 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -1,6 +1,6 @@ module Control.Lens.Grammar.Boole ( BooleanAlgebra (..) - , fromBool, andB, orB, allB, anyB + , andB, orB, allB, anyB , TokenTest (..) , TokenAlgebra (..) ) where @@ -18,15 +18,10 @@ import GHC.Generics class BooleanAlgebra b where - failB :: b - default failB - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b - failB = pure failB - - passB :: b - default passB - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b - passB = pure passB + fromBool :: Bool -> b + default fromBool + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => Bool -> b + fromBool = pure . fromBool notB :: b -> b default notB @@ -43,22 +38,17 @@ class BooleanAlgebra b where :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b (>&&<) = liftA2 (>&&<) -fromBool :: BooleanAlgebra b => Bool -> b -fromBool = \case - True -> passB - False -> failB - andB :: (Foldable f, BooleanAlgebra b) => f b -> b -andB = foldl' (>&&<) passB +andB = foldl' (>&&<) (fromBool True) orB :: (Foldable f, BooleanAlgebra b) => f b -> b -orB = foldl' (>||<) failB +orB = foldl' (>||<) (fromBool False) allB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b -allB f = foldl' (\b a -> b >&&< f a) passB +allB f = foldl' (\b a -> b >&&< f a) (fromBool True) anyB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b -anyB f = foldl' (\b a -> b >||< f a) failB +anyB f = foldl' (\b a -> b >||< f a) (fromBool False) newtype TokenTest token = TokenTest (RegExam token (TokenTest token)) @@ -89,8 +79,7 @@ deriving stock instance (Categorized token, Show token, Show (Categorize token)) => Show (TokenTest token) instance BooleanAlgebra Bool where - failB = False - passB = True + fromBool = id notB = not (>&&<) = (&&) (>||<) = (||) @@ -113,8 +102,9 @@ instance Categorized token RegExam (Alternate (tokenClass exam1) (tokenClass exam2)) instance Categorized token => BooleanAlgebra (RegExam token (TokenTest token)) where - failB = Fail - passB = Pass + fromBool = \case + False -> Fail + True -> Pass notB Fail = Pass notB Pass = Fail notB (Alternate (TokenTest x) (TokenTest y)) = x >&&< y From 911b1c31ce7a1e16ed890226e5a22b6fa0f47605 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 20 Dec 2025 11:28:50 -0800 Subject: [PATCH 168/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 157 +++++++++++++++++++-------------- 1 file changed, 89 insertions(+), 68 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 2e21dd3..3ddf7f1 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -72,18 +72,20 @@ evalGrammor = extract . extract . runGrammor evalGrammor_ :: Grammor () t Identity a b -> t evalGrammor_ = evalGrammor -newtype Reador f a b = Reador {unReador :: Codensity (LookT f) b} +newtype Reador s f a b = Reador {unReador :: Codensity (LookT s f) b} runReador - :: (Alternative m, Monad m) - => Reador m a b -> String -> m (b, String) + :: (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Reador s m a b -> s -> m (b, s) runReador (Reador (Codensity f)) = runLookT (f return) -data LookT f a - = LookT (String -> LookT f a) - | GetT (Char -> LookT f a) - | ResultT a (LookT f a) - | FinalT (f (a, String)) -runLookT :: Alternative f => LookT f a -> String -> f (a, String) +data LookT s f a + = LookT (s -> LookT s f a) + | GetT (Item s -> LookT s f a) + | ResultT a (LookT s f a) + | FinalT (f (a, s)) +runLookT + :: (Alternative f, IsList s, Cons s s (Item s) (Item s)) + => LookT s f a -> s -> f (a, s) runLookT (GetT f) s = maybe empty (\(h,t) -> runLookT (f h) t) (uncons s) runLookT (LookT f) s = runLookT (f s) s @@ -112,6 +114,9 @@ instance (Alternative m, Monad m) => Alternative (PP s s m a) where empty = PP (\_ _ -> empty) PP p <|> PP q = PP $ \ma s -> p ma s <|> q ma s instance (Alternative m, Monad m) => MonadPlus (PP s s m a) +instance Monad m => MonadReader s (PP s s m a) where + ask = PP $ \_ s -> return (s,s) + local f = PP . fmap (lmap f) . runPP instance Filterable f => Filterable (PP s t f a) where mapMaybe f (PP p) = PP $ \fa s -> mapMaybe (\(a,t) -> fmap (,t) (f a)) (p fa s) @@ -142,7 +147,7 @@ instance Monad m => Polyadic m PP where Just (a,b) -> \s0 -> do (x,s1) <- p (Just a) s0 (y,s2) <- runPP (f x) (Just b) s1 - return ((a,y),s2) + return ((x,y),s2) instance (Alternative m, Monad m) => Distributor (PP s s m) instance (Alternative m, Monad m) => Choice (PP s s m) where left' = alternate . Left @@ -179,30 +184,32 @@ instance (Alternative m, Monad m) => ArrowChoice (PP s s m) where (+++) = (>+<) left = left' right = right' --- instance --- ( Categorized a, a ~ Item s, IsList s, Cons s s a a --- , Filterable m, Alternative m, Monad m --- ) => Tokenized a (Printor s s m a a) where --- anyToken = Printor (\b -> pure (b, cons b)) --- instance --- ( Categorized a, a ~ Item s, IsList s, Cons s s a a --- , Filterable m, Alternative m, Monad m --- ) => TokenAlgebra a (Printor s s m a a) --- instance --- ( Categorized a, a ~ Item s, IsList s, Cons s s a a --- , Filterable m, Alternative m, Monad m --- ) => TerminalSymbol a (Printor s s m () ()) where --- instance --- ( Char ~ Item s, IsList s, Cons s s Char Char --- , Filterable m, Alternative m, Monad m --- ) => IsString (Printor s s m () ()) where --- fromString = terminal --- instance --- ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s --- , Filterable m, Alternative m, Monad m --- ) => IsString (Printor s s m s s) where --- fromString = fromTokens --- instance BackusNaurForm (Printor s t m a b) +instance + ( Categorized a, a ~ Item s, IsList s, Cons s s a a + , Filterable m, Alternative m, Monad m + ) => Tokenized a (PP s s m a a) where + anyToken = PP $ maybe + (maybe empty pure . uncons) + (\a -> pure . (a,) . cons a) +instance + ( Categorized a, a ~ Item s, IsList s, Cons s s a a + , Filterable m, Alternative m, Monad m + ) => TokenAlgebra a (PP s s m a a) +instance + ( Categorized a, a ~ Item s, IsList s, Cons s s a a + , Filterable m, Alternative m, Monad m + ) => TerminalSymbol a (PP s s m () ()) where +instance + ( Char ~ Item s, IsList s, Cons s s Char Char + , Filterable m, Alternative m, Monad m + ) => IsString (PP s s m () ()) where + fromString = terminal +instance + ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s + , Filterable m, Alternative m, Monad m + ) => IsString (PP s s m s s) where + fromString = fromTokens +instance BackusNaurForm (PP s t m a b) -- Parsor instances instance Functor f => Functor (Parsor s t f a) where @@ -483,24 +490,25 @@ instance (Comonad f, Applicative f, Monoid s, BackusNaurForm t) ruleRec name = grammor . ruleRec name . dimap grammor evalGrammor -- Reador instances -deriving newtype instance Functor (Reador f a) -deriving newtype instance Applicative (Reador f a) -deriving newtype instance Monad (Reador f a) -deriving newtype instance (Alternative m, Monad m) - => Alternative (Reador m a) -deriving newtype instance (Alternative m, Monad m) - => MonadPlus (Reador m a) -instance (Alternative m, Filterable m, Monad m) - => Filterable (Reador m a) where +deriving newtype instance Functor (Reador s f a) +deriving newtype instance Applicative (Reador s f a) +deriving newtype instance Monad (Reador s f a) +deriving newtype instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Alternative (Reador s m a) +deriving newtype instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => MonadPlus (Reador s m a) +instance (Alternative m, Filterable m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Filterable (Reador s m a) where mapMaybe f = Reador . lift . mapMaybe f . lowerCodensity . unReador -instance Profunctor (Reador f) where +instance Profunctor (Reador s f) where dimap _ f (Reador p) = Reador (fmap f p) -instance Bifunctor (Reador f) where +instance Bifunctor (Reador s f) where bimap _ f (Reador p) = Reador (fmap f p) -instance (Alternative m, Monad m) => Monadic m Reador where +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Monadic m (Reador s) where liftP m = Reador $ do s <- ask lift $ FinalT ((,s) <$> m) @@ -508,57 +516,69 @@ instance (Alternative m, Monad m) => Monadic m Reador where a <- m c <- unReador (f a) return (a,c) -instance (Alternative m, Monad m) => Choice (Reador m) where +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Choice (Reador s m) where left' = alternate . Left right' = alternate . Right -instance (Alternative m, Monad m, Filterable m) - => Cochoice (Reador m) where +instance (Alternative m, Monad m, Filterable m, IsList s, Cons s s (Item s) (Item s)) + => Cochoice (Reador s m) where unleft = fst . filtrate unright = snd . filtrate -instance (Alternative m, Monad m) => Distributor (Reador m) -instance (Alternative m, Monad m) => Alternator (Reador m) where +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Distributor (Reador s m) +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Alternator (Reador s m) where alternate (Left (Reador p)) = Reador (fmap Left p) alternate (Right (Reador p)) = Reador (fmap Right p) -instance (Alternative m, Filterable m, Monad m) - => Filtrator (Reador m) where +instance (Alternative m, Filterable m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Filtrator (Reador s m) where filtrate = mfiltrate -instance (Alternative m, Filterable m, Monad m) - => Tokenized Char (Reador m Char Char) where +instance + ( Alternative m, Filterable m, Monad m + , IsList s, Categorized c, c ~ Item s, Cons s s c c + ) => Tokenized c (Reador s m c c) where anyToken = Reador (lift (GetT return)) instance ( Filterable m, Alternative m, Monad m - ) => TokenAlgebra Char (Reador m Char Char) + , IsList s, Categorized c, c ~ Item s, Cons s s c c + ) => TokenAlgebra c (Reador s m c c) instance ( Filterable m, Alternative m, Monad m - ) => TerminalSymbol Char (Reador m () ()) + , IsList s, Categorized c, c ~ Item s, Cons s s c c + ) => TerminalSymbol c (Reador s m () ()) instance ( Filterable m, Alternative m, Monad m - ) => IsString (Reador m () ()) where + , IsList s, Item s ~ Char, Cons s s Char Char + ) => IsString (Reador s m () ()) where fromString = terminal instance ( Filterable m, Alternative m, Monad m - , AsEmpty s, Cons s s Char Char - ) => IsString (Reador m s s) where + , IsList s, Item s ~ Char, AsEmpty s, Cons s s Char Char + ) => IsString (Reador s m s s) where fromString = fromTokens -instance BackusNaurForm (Reador m a b) -instance Matching String (Reador Maybe a b) where +instance BackusNaurForm (Reador s m a b) +instance (IsList s, Cons s s (Item s) (Item s), AsEmpty s) + => Matching s (Reador s Maybe a b) where word =~ reador = case runReador reador word of Nothing -> False Just (_,t) -> is _Empty t -- LookT instances -deriving stock instance Functor f => Functor (LookT f) -instance (Alternative m, Monad m) => Applicative (LookT m) where +deriving stock instance Functor f => Functor (LookT s f) +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Applicative (LookT s m) where pure x = ResultT x (FinalT empty) (<*>) = ap -instance (Alternative m, Monad m) => Monad (LookT m) where +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Monad (LookT s m) where GetT f >>= k = GetT $ \c -> f c >>= k LookT f >>= k = LookT $ \s -> f s >>= k ResultT x p >>= k = k x <|> (p >>= k) FinalT r >>= k = FinalT $ do (x,s) <- r runLookT (k x) s -instance (Alternative m, Monad m) => MonadReader String (LookT m) where +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => MonadReader s (LookT s m) where ask = LookT return local f = \case GetT k -> do @@ -567,7 +587,7 @@ instance (Alternative m, Monad m) => MonadReader String (LookT m) where LookT k -> LookT (k . f) ResultT x p -> ResultT x (local f p) FinalT r -> FinalT r -instance Filterable f => Filterable (LookT f) where +instance Filterable f => Filterable (LookT s f) where mapMaybe f = \case GetT k -> GetT (mapMaybe f . k) LookT k -> LookT (mapMaybe f . k) @@ -575,7 +595,8 @@ instance Filterable f => Filterable (LookT f) where Nothing -> id Just y -> ResultT y FinalT r -> FinalT (mapMaybe (\(a,s) -> (,s) <$> f a) r) -instance (Alternative m, Monad m) => Alternative (LookT m) where +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Alternative (LookT s m) where empty = FinalT empty -- most common case: two gets are combined GetT f1 <|> GetT f2 = GetT (\c -> f1 c <|> f2 c) From 3a972cebb304d78d6c1d2db864f8e25985442b6b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 21 Dec 2025 08:13:49 -0800 Subject: [PATCH 169/282] Update Boole.hs --- src/Control/Lens/Grammar/Boole.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index 997c20f..5be02b0 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -69,6 +69,14 @@ class Tokenized token p => TokenAlgebra token p where --instances instance BooleanAlgebra (x -> Bool) +instance Categorized token => TokenAlgebra token (token -> Bool) where + tokenClass (TokenTest exam) = case exam of + Fail -> const False + Pass -> const True + OneOf chars -> oneOf chars + NotOneOf chars (AsIn cat) -> notOneOf chars >&&< asIn cat + NotOneOf chars (NotAsIn cats) -> notOneOf chars >&&< allB notAsIn cats + Alternate exam1 exam2 -> tokenClass exam1 >||< tokenClass exam2 instance (Applicative f, BooleanAlgebra bool) => BooleanAlgebra (Ap f bool) deriving stock instance Generic (TokenTest token) From f8e21034c15a5ab6061a339dbaf626490fd933aa Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 21 Dec 2025 20:25:49 -0800 Subject: [PATCH 170/282] removal --- distributors.cabal | 1 - src/Control/Lens/Grammar/Do.hs | 2 +- src/Data/Profunctor/Grammar.hs | 364 +++++++++++++++++++------------- src/Data/Profunctor/Monadic.hs | 42 +--- src/Data/Profunctor/Polyadic.hs | 94 --------- 5 files changed, 230 insertions(+), 273 deletions(-) delete mode 100644 src/Data/Profunctor/Polyadic.hs diff --git a/distributors.cabal b/distributors.cabal index c37f30f..d197a54 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -47,7 +47,6 @@ library Data.Profunctor.Grammar Data.Profunctor.Monadic Data.Profunctor.Monoidal - Data.Profunctor.Polyadic other-modules: Paths_distributors autogen-modules: diff --git a/src/Control/Lens/Grammar/Do.hs b/src/Control/Lens/Grammar/Do.hs index f7b5554..25a7ee1 100644 --- a/src/Control/Lens/Grammar/Do.hs +++ b/src/Control/Lens/Grammar/Do.hs @@ -26,7 +26,7 @@ import Prelude hiding ((>>=), (>>), (<$>), fail) (>>=) :: Monadic m p => p m a a -> (a -> p m b c) -> p m (a,b) (a,c) infixl 1 >>= -(>>=) = bondM +(>>=) = bondP (>>) :: Monadic m p => p m () () -> p m b c -> p m b c infixl 1 >> diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 3ddf7f1..74f4fed 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -25,7 +25,6 @@ import Control.Arrow import Control.Category import Control.Comonad import Control.Monad.Codensity -import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Control.Lens @@ -44,24 +43,23 @@ import Data.Profunctor.Distributor import Data.Profunctor.Filtrator import Data.Profunctor.Monadic import Data.Profunctor.Monoidal -import Data.Profunctor.Polyadic import Data.Void import Prelude hiding (id, (.)) import GHC.Exts import Witherable -newtype Parsor s t f a b = Parsor {runParsor :: s -> f (b,t)} +newtype Parsor s f a b = Parsor {runParsor :: s -> f (b,s)} -newtype Printor s t f a b = Printor {runPrintor :: a -> f (b, s -> t)} -printor :: Functor f => (a -> f (s -> t)) -> Printor s t f a a +newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)} +printor :: Functor f => (a -> f (s -> s)) -> Printor s f a a printor f = Printor (\a -> fmap (a,) (f a)) -evalPrintor :: Functor f => Printor s t f a b -> a -> f (s -> t) +evalPrintor :: Functor f => Printor s f a b -> a -> f (s -> s) evalPrintor (Printor f) = fmap snd . f -newtype PP s t f a b = PP {runPP :: Maybe a -> s -> f (b,t)} -printP :: Functor f => PP s t f a b -> a -> s -> f t +newtype PP s f a b = PP {runPP :: Maybe a -> s -> f (b,s)} +printP :: Functor f => PP s f a b -> a -> s -> f s printP (PP f) a = fmap snd . f (Just a) -parseP :: PP s t f a b -> s -> f (b,t) +parseP :: PP s f a b -> s -> f (b,s) parseP (PP f) = f Nothing newtype Grammor s t f a b = Grammor {runGrammor :: s -> f t} @@ -92,38 +90,55 @@ runLookT (LookT f) s = runLookT (f s) s runLookT (ResultT x p) s = pure (x,s) <|> runLookT p s runLookT (FinalT r) _ = r +data LookP s f a b + = ItemP (a -> f (Item s)) (Item s -> LookP s f a b) + | LookP (Maybe a -> s -> LookP s f a b) + | ResultP b (LookP s f a b) + | FinalP (f (b,s)) + +runLookP + :: (Monad m, Alternative m, IsList s, Cons s s (Item s) (Item s)) + => LookP s m a b -> Maybe a -> s -> m (b, s) +runLookP (ItemP f g) ma s = case ma of + Nothing -> maybe empty + (\(hd,tl) -> runLookP (g hd) ma tl) + (uncons s) + Just a -> do + item <- f a + runLookP (g item) ma (cons item s) +runLookP (LookP f) ma s = runLookP (f ma s) ma s +runLookP (ResultP x p) ma s = pure (x,s) <|> runLookP p ma s +runLookP (FinalP r) _ _ = r + -- PP instances -deriving stock instance Functor f => Functor (PP s t f a) -instance Functor f => Profunctor (PP s t f) where +deriving stock instance Functor f => Functor (PP s f a) +instance Functor f => Profunctor (PP s f) where dimap f g = PP . dimap (fmap f) (fmap (fmap (first' g))) . runPP -instance Functor f => Tetradic f PP where - dimapT f g = PP . fmap (dimap f (fmap (second' g))) . runPP - tetramap f g h i = PP . dimap (fmap h) (dimap f (fmap (i >*< g))) . runPP -instance Monad m => Applicative (PP s s m a) where +instance Monad m => Applicative (PP s m a) where pure b = PP (\_ s -> pure (b,s)) PP x <*> PP y = PP $ \ma s -> do (f, t) <- x ma s (a, u) <- y ma t return (f a, u) -instance Monad m => Monad (PP s s m a) where +instance Monad m => Monad (PP s m a) where return = pure PP p >>= f = PP $ \ma s -> do (a, t) <- p ma s runPP (f a) ma t -instance (Alternative m, Monad m) => Alternative (PP s s m a) where +instance (Alternative m, Monad m) => Alternative (PP s m a) where empty = PP (\_ _ -> empty) PP p <|> PP q = PP $ \ma s -> p ma s <|> q ma s -instance (Alternative m, Monad m) => MonadPlus (PP s s m a) -instance Monad m => MonadReader s (PP s s m a) where +instance (Alternative m, Monad m) => MonadPlus (PP s m a) +instance Monad m => MonadReader s (PP s m a) where ask = PP $ \_ s -> return (s,s) local f = PP . fmap (lmap f) . runPP -instance Filterable f => Filterable (PP s t f a) where +instance Filterable f => Filterable (PP s f a) where mapMaybe f (PP p) = PP $ \fa s -> mapMaybe (\(a,t) -> fmap (,t) (f a)) (p fa s) -instance Filterable f => Cochoice (PP s t f) where +instance Filterable f => Cochoice (PP s f) where unleft = fst . filtrate unright = snd . filtrate -instance Filterable f => Filtrator (PP s t f) where +instance Filterable f => Filtrator (PP s f) where filtrate (PP p) = ( PP $ \ma s -> mapMaybe (\case{(Left b,t) -> Just (b,t); _ -> Nothing}) @@ -132,27 +147,13 @@ instance Filterable f => Filtrator (PP s t f) where (\case{(Right b,t) -> Just (b,t); _ -> Nothing}) (p (fmap Right ma) s) ) -instance Monad m => Monadic m (PP s s) where +instance Monad m => Monadic m (PP s) where liftP m = PP $ \_ s -> (,s) <$> m - bondM = bondP -instance Monad m => Polyadic m PP where - joinP (PP mf) = PP $ \ma s -> do - (PP mg, j) <- mf ma s - mg ma j - bondP (PP p) f = PP $ \case - Nothing -> \s0 -> do - (x,s1) <- p Nothing s0 - (y,s2) <- runPP (f x) Nothing s1 - return ((x,y),s2) - Just (a,b) -> \s0 -> do - (x,s1) <- p (Just a) s0 - (y,s2) <- runPP (f x) (Just b) s1 - return ((x,y),s2) -instance (Alternative m, Monad m) => Distributor (PP s s m) -instance (Alternative m, Monad m) => Choice (PP s s m) where +instance (Alternative m, Monad m) => Distributor (PP s m) +instance (Alternative m, Monad m) => Choice (PP s m) where left' = alternate . Left right' = alternate . Right -instance (Alternative m, Monad m) => Alternator (PP s s m) where +instance (Alternative m, Monad m) => Alternator (PP s m) where alternate = \case Left (PP p) -> PP $ \ma s -> case ma of Nothing -> fmap (first' Left) (p Nothing s) @@ -162,7 +163,7 @@ instance (Alternative m, Monad m) => Alternator (PP s s m) where Nothing -> fmap (first' Right) (p Nothing s) Just (Right a) -> fmap (first' Right) (p (Just a) s) Just (Left _) -> empty -instance (Alternative m, Monad m) => Category (PP s s m) where +instance (Alternative m, Monad m) => Category (PP s m) where id = PP $ \ma s -> case ma of Nothing -> empty Just a -> pure (a,s) @@ -171,106 +172,92 @@ instance (Alternative m, Monad m) => Category (PP s s m) where Just a -> do (b, t) <- p (Just a) s q (Just b) t -instance (Alternative m, Monad m) => Arrow (PP s s m) where +instance (Alternative m, Monad m) => Arrow (PP s m) where arr f = PP $ \ma s -> case ma of Nothing -> empty Just a -> pure (f a, s) (***) = (>*<) -instance (Alternative m, Monad m) => ArrowZero (PP s s m) where +instance (Alternative m, Monad m) => ArrowZero (PP s m) where zeroArrow = empty -instance (Alternative m, Monad m) => ArrowPlus (PP s s m) where +instance (Alternative m, Monad m) => ArrowPlus (PP s m) where (<+>) = (<|>) -instance (Alternative m, Monad m) => ArrowChoice (PP s s m) where +instance (Alternative m, Monad m) => ArrowChoice (PP s m) where (+++) = (>+<) left = left' right = right' instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => Tokenized a (PP s s m a a) where + ) => Tokenized a (PP s m a a) where anyToken = PP $ maybe (maybe empty pure . uncons) (\a -> pure . (a,) . cons a) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TokenAlgebra a (PP s s m a a) -instance + ) => TokenAlgebra a (PP s m a a) +instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TerminalSymbol a (PP s s m () ()) where + ) => TerminalSymbol a (PP s m () ()) where instance ( Char ~ Item s, IsList s, Cons s s Char Char , Filterable m, Alternative m, Monad m - ) => IsString (PP s s m () ()) where + ) => IsString (PP s m () ()) where fromString = terminal instance ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m - ) => IsString (PP s s m s s) where + ) => IsString (PP s m s s) where fromString = fromTokens -instance BackusNaurForm (PP s t m a b) +instance BackusNaurForm (PP s m a b) +instance (Alternative m, Monad m) => MonadFail (PP s m a) where + fail _ = empty -- Parsor instances -instance Functor f => Functor (Parsor s t f a) where +instance Functor f => Functor (Parsor s f a) where fmap f = Parsor . fmap (fmap (first' f)) . runParsor -instance Functor f => Bifunctor (Parsor s t f) where +instance Functor f => Bifunctor (Parsor s f) where bimap _ = lmap coerce . fmap first _ = coerce second = fmap -instance Functor f => Profunctor (Parsor s t f) where +instance Functor f => Profunctor (Parsor s f) where dimap _ = rmap coerce . fmap lmap _ = coerce rmap = fmap -instance Functor f => Tetradic f Parsor where - dimapT f g (Parsor p) = Parsor (fmap (fmap g) . p . f) - tetramap f g _ i (Parsor p) = Parsor (fmap (i >*< g) . p . f) -instance Monad m => Applicative (Parsor s s m a) where +instance Monad m => Applicative (Parsor s m a) where pure b = Parsor (\s -> return (b,s)) Parsor x <*> Parsor y = Parsor $ \s -> do (f, t) <- x s (a, u) <- y t return (f a, u) -instance Monad m => Monad (Parsor s s m a) where +instance Monad m => Monad (Parsor s m a) where Parsor p >>= f = Parsor $ \s -> do (a, t) <- p s runParsor (f a) t -instance (Alternative m, Monad m) => Alternative (Parsor s s m a) where +instance (Alternative m, Monad m) => Alternative (Parsor s m a) where empty = Parsor (\_ -> empty) Parsor p <|> Parsor q = Parsor (\str -> p str <|> q str) -instance (Alternative m, Monad m) => MonadPlus (Parsor s s m a) -instance MonadError e m => MonadError e (Parsor s s m a) where - throwError = liftP . throwError - catchError p f = Parsor $ \s -> - catchError (runParsor p s) (\e -> runParsor (f e) s) -instance Monad m => MonadState s (Parsor s s m a) where +instance (Alternative m, Monad m) => MonadPlus (Parsor s m a) +instance Monad m => MonadState s (Parsor s m a) where get = Parsor (\s -> pure (s,s)) put = Parsor . (pure (pure . ((),))) -instance (Alternative m, Monad m) => Choice (Parsor s s m) where +instance (Alternative m, Monad m) => Choice (Parsor s m) where left' = alternate . Left right' = alternate . Right -instance (Alternative m, Monad m) => Distributor (Parsor s s m) -instance (Alternative m, Monad m) => Alternator (Parsor s s m) where +instance (Alternative m, Monad m) => Distributor (Parsor s m) +instance (Alternative m, Monad m) => Alternator (Parsor s m) 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 Monad m => Monadic m (Parsor s s) where +instance Monad m => Monadic m (Parsor s) where liftP m = Parsor $ \s -> (,s) <$> m - bondM = bondP -instance Monad m => Polyadic m Parsor where - joinP (Parsor p) = Parsor $ \s -> do - (mb, s') <- p s - runParsor mb s' - bondP (Parsor p) f = Parsor $ \s0 -> do - (a,s1) <- p s0 - (c,s2) <- runParsor (f a) s1 - return ((a,c),s2) -instance Filterable f => Filterable (Parsor s t f a) where +instance Filterable f => Filterable (Parsor s f a) where mapMaybe f (Parsor p) = Parsor (mapMaybe (\(a,str) -> (,str) <$> f a) . p) -instance Filterable f => Cochoice (Parsor s t f) where +instance Filterable f => Cochoice (Parsor s f) where unleft = fst . filtrate unright = snd . filtrate -instance Filterable f => Filtrator (Parsor s t f) where +instance Filterable f => Filtrator (Parsor s f) where filtrate (Parsor p) = ( Parsor (mapMaybe leftMay . p) , Parsor (mapMaybe rightMay . p) @@ -280,85 +267,73 @@ instance Filterable f => Filtrator (Parsor s t f) where instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => Tokenized a (Parsor s s m a a) where + ) => Tokenized a (Parsor s m a a) where anyToken = Parsor (maybe empty pure . uncons) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TokenAlgebra a (Parsor s s m a a) + ) => TokenAlgebra a (Parsor s m a a) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TerminalSymbol a (Parsor s s m () ()) + ) => TerminalSymbol a (Parsor s m () ()) instance ( Char ~ Item s, IsList s, Cons s s Char Char , Filterable m, Alternative m, Monad m - ) => IsString (Parsor s s m () ()) where + ) => IsString (Parsor s m () ()) where fromString = terminal instance ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m - ) => IsString (Parsor s s m s s) where + ) => IsString (Parsor s m s s) where fromString = fromTokens -instance BackusNaurForm (Parsor s t m a b) -instance AsEmpty t => Matching s (Parsor s t Maybe a b) where +instance BackusNaurForm (Parsor s m a b) +instance AsEmpty s => Matching s (Parsor s Maybe a b) where word =~ parsor = case runParsor parsor word of Nothing -> False Just (_,t) -> is _Empty t +instance (Alternative m, Monad m) => MonadFail (Parsor s m a) where + fail _ = empty -- Printor instances -instance Functor f => Functor (Printor s t f a) where +instance Functor f => Functor (Printor s f a) where fmap f = Printor . fmap (fmap (first' f)) . runPrintor -instance Functor f => Profunctor (Printor s t f) where +instance Functor f => Profunctor (Printor s f) where dimap f g = Printor . dimap f (fmap (first' g)) . runPrintor -instance Functor f => Tetradic f Printor where - dimapT f g = Printor . rmap (fmap (second' (dimap f g))) . runPrintor - tetramap f g h i = Printor . dimap h (fmap (i >*< dimap f g)) . runPrintor -instance Applicative f => Applicative (Printor s s f a) where +instance Applicative f => Applicative (Printor s f a) where pure b = Printor (\_ -> pure (b, id)) Printor f <*> Printor x = Printor $ \c -> liftA2 (\(g, p) (a, q) -> (g a, p . q)) (f c) (x c) -instance Alternative f => Alternative (Printor s s f a) where +instance Alternative f => Alternative (Printor s f a) where empty = Printor (\_ -> empty) Printor p <|> Printor q = Printor (\a -> p a <|> q a) -instance Filterable f => Filterable (Printor s s f a) where +instance Filterable f => Filterable (Printor s f a) where mapMaybe f (Printor p) = Printor $ mapMaybe (\(a,q) -> fmap (, q) (f a)) . p -instance Monad f => Monad (Printor s s f a) where +instance Monad f => Monad (Printor s f a) where return = pure - mx >>= f = joinP (fmap f mx) -instance (Alternative f, Monad f) => MonadPlus (Printor s s f a) -instance MonadError e m => MonadError e (Printor s s m a) where - throwError = liftP . throwError - catchError p f = Printor $ \s -> - catchError (runPrintor p s) (\e -> runPrintor (f e) s) -instance Monad m => MonadReader a (Printor s s m a) where + Printor mx >>= f = Printor $ \a -> do + (a1,g) <- mx a + (b,h) <- runPrintor (f a1) a + return (b, h . g) +instance (Alternative f, Monad f) => MonadPlus (Printor s f a) +instance Monad m => MonadReader a (Printor s m a) where ask = Printor (\a -> return (a, id)) reader f = (Printor (\a -> return (f a, id))) local f = Printor . (\m -> m . f) . runPrintor -instance Monad m => Monadic m (Printor s s) where +instance Monad m => Monadic m (Printor s) where liftP m = Printor $ \_ -> (, id) <$> m - bondM = bondP -instance Monad m => Polyadic m Printor where - joinP (Printor mf) = Printor $ \a -> do - (Printor mg, f) <- mf a - (b, g) <- mg a - return (b, g . f) - bondP (Printor m) f = Printor $ \(x,b) -> do - (y,g) <- m x - (c,h) <- runPrintor (f y) b - return ((y,c), h . g) -instance Applicative f => Distributor (Printor s s f) where +instance Applicative f => Distributor (Printor s f) where zeroP = Printor absurd Printor p >+< Printor q = Printor $ either (fmap (first' Left) . p) (fmap (first' Right) . q) -instance Alternative f => Alternator (Printor s s f) where +instance Alternative f => Alternator (Printor s f) where alternate = \case Left (Printor p) -> Printor $ either (fmap (first' Left) . p) (\_ -> empty) Right (Printor p) -> Printor $ either (\_ -> empty) (fmap (first' Right) . p) -instance Filterable f => Filtrator (Printor s s f) where +instance Filterable f => Filtrator (Printor s f) where filtrate (Printor p) = let leftMaybe = \case @@ -371,69 +346,68 @@ instance Filterable f => Filtrator (Printor s s f) where ( Printor (mapMaybe leftMaybe . p . Left) , Printor (mapMaybe rightMaybe . p . Right) ) -instance Alternative f => Choice (Printor s s f) where +instance Alternative f => Choice (Printor s f) where left' = alternate . Left right' = alternate . Right -instance Filterable f => Cochoice (Printor s s f) where +instance Filterable f => Cochoice (Printor s f) where unleft = fst . filtrate unright = snd . filtrate -instance Functor f => Strong (Printor s s f) where +instance Functor f => Strong (Printor s f) where first' (Printor p) = Printor (\(a,c) -> fmap (\(b,q) -> ((b,c),q)) (p a)) second' (Printor p) = Printor (\(c,a) -> fmap (\(b,q) -> ((c,b),q)) (p a)) -instance Monad f => Category (Printor s s f) where +instance Monad f => Category (Printor s f) where id = Printor $ \a -> return (a, id) Printor q . Printor p = Printor $ \a -> do (b, p') <- p a (c, q') <- q b return (c, q' . p') -instance Monad f => Arrow (Printor s s f) where +instance Monad f => Arrow (Printor s f) where arr f = Printor (return . (, id) . f) (***) = (>*<) first = first' second = second' -instance (Alternative f, Monad f) => ArrowZero (Printor s s f) where +instance (Alternative f, Monad f) => ArrowZero (Printor s f) where zeroArrow = empty -instance (Alternative f, Monad f) => ArrowPlus (Printor s s f) where +instance (Alternative f, Monad f) => ArrowPlus (Printor s f) where (<+>) = (<|>) -instance (Alternative f, Monad f) => ArrowChoice (Printor s s f) where +instance (Alternative f, Monad f) => ArrowChoice (Printor s f) where (+++) = (>+<) left = left' right = right' instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => Tokenized a (Printor s s m a a) where + ) => Tokenized a (Printor s m a a) where anyToken = Printor (\b -> pure (b, cons b)) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TokenAlgebra a (Printor s s m a a) -instance + ) => TokenAlgebra a (Printor s m a a) +instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TerminalSymbol a (Printor s s m () ()) where + ) => TerminalSymbol a (Printor s m () ()) where instance ( Char ~ Item s, IsList s, Cons s s Char Char , Filterable m, Alternative m, Monad m - ) => IsString (Printor s s m () ()) where + ) => IsString (Printor s m () ()) where fromString = terminal instance ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m - ) => IsString (Printor s s m s s) where + ) => IsString (Printor s m s s) where fromString = fromTokens -instance BackusNaurForm (Printor s t m a b) +instance BackusNaurForm (Printor s m a b) +instance (Alternative m, Monad m) => MonadFail (Printor s m a) where + fail _ = empty -- Grammor instances instance Functor (Grammor s t f a) where fmap _ = coerce instance Contravariant (Grammor s t f a) where contramap _ = coerce instance Profunctor (Grammor s t f) where dimap _ _ = coerce instance Bifunctor (Grammor s t f) where bimap _ _ = coerce -instance Functor f => Tetradic f Grammor where - dimapT f g = Grammor . dimap f (fmap g) . runGrammor - tetramap f g _ _ = Grammor . dimap f (fmap g) . runGrammor instance Choice (Grammor s t f) where left' = coerce right' = coerce @@ -512,10 +486,6 @@ instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) liftP m = Reador $ do s <- ask lift $ FinalT ((,s) <$> m) - bondM (Reador m) f = Reador $ do - a <- m - c <- unReador (f a) - return (a,c) instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) => Choice (Reador s m) where left' = alternate . Left @@ -562,6 +532,11 @@ instance (IsList s, Cons s s (Item s) (Item s), AsEmpty s) word =~ reador = case runReador reador word of Nothing -> False Just (_,t) -> is _Empty t +instance + ( Alternative m, Monad m + , IsList s, Item s ~ Char, Cons s s Char Char + ) => MonadFail (Reador s m a) where + fail _ = empty -- LookT instances deriving stock instance Functor f => Functor (LookT s f) @@ -616,3 +591,108 @@ instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) LookT f <|> LookT g = LookT (\s -> f s <|> g s) LookT f <|> p = LookT (\s -> f s <|> p) p <|> LookT f = LookT (\s -> p <|> f s) + +-- LookP instances +deriving stock instance Functor f => Functor (LookP s f a) +instance Functor f => Profunctor (LookP s f) where + dimap f g = \case + ItemP l k -> ItemP (lmap f l) (rmap (dimap f g) k) + LookP k -> LookP (dimap (fmap f) (rmap (dimap f g)) k) + ResultP c p -> ResultP (g c) (dimap f g p) + FinalP r -> FinalP (fmap (first' g) r) +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Applicative (LookP s m a) where + pure x = ResultP x (FinalP empty) + (<*>) = ap +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Monad (LookP s m a) where + ItemP f g >>= k = ItemP f $ \c -> g c >>= k + LookP f >>= k = LookP $ \ma s -> f ma s >>= k + ResultP x p >>= k = k x <|> (p >>= k) + FinalP r >>= k = FinalP $ do + (x,s) <- r + runLookP (k x) Nothing s +-- instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) +-- => Monadic m (LookP s) where +-- liftP m = do +-- s <- LookP (\_ -> return) +-- FinalP $ (,s) <$> m +instance Filterable f => Filterable (LookP s f a) where + mapMaybe f = \case + ItemP l k -> ItemP l (mapMaybe f . k) + LookP k -> LookP (\ma -> mapMaybe f . k ma) + ResultP x p -> mapMaybe f p & case f x of + Nothing -> id + Just y -> ResultP y + FinalP r -> FinalP (mapMaybe (\(a,s) -> (,s) <$> f a) r) +instance Filterable f => Cochoice (LookP s f) where + unleft = fst . filtrate + unright = snd . filtrate +instance Filterable f => Filtrator (LookP s f) where + filtrate = \case + ItemP l k -> + ( ItemP (l . Left) (fst . filtrate . k) + , ItemP (l . Right) (snd . filtrate . k) + ) + LookP k -> + ( LookP (dimap (fmap Left) (rmap (fst . filtrate)) k) + , LookP (dimap (fmap Right) (rmap (snd . filtrate)) k) + ) + ResultP x p -> case x of + Left b -> + ( ResultP b (fst (filtrate p)) + , snd (filtrate p) + ) + Right c -> + ( fst (filtrate p) + , ResultP c (snd (filtrate p)) + ) + FinalP r -> + ( FinalP (mapMaybe (\case {(Left b, s) -> Just (b,s); _ -> Nothing}) r) + , FinalP (mapMaybe (\case {(Right c, s) -> Just (c,s); _ -> Nothing}) r) + ) +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Alternative (LookP s m a) where + empty = FinalP empty + -- most common case: two items are combined + ItemP l1 f1 <|> ItemP l2 f2 = + ItemP (\a -> l1 a <|> l2 a) (\c -> f1 c <|> f2 c) + -- results are delivered as soon as possible + ResultP x p <|> q = ResultP x (p <|> q) + p <|> ResultP x q = ResultP x (p <|> q) + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + FinalP r <|> FinalP t = FinalP (r <|> t) + FinalP r <|> LookP f = LookP $ \ma s -> FinalP (r <|> runLookP (f ma s) ma s) + FinalP r <|> p = LookP $ \ma s -> FinalP (r <|> runLookP p ma s) + LookP f <|> FinalP r = LookP $ \ma s -> FinalP (runLookP (f ma s) ma s <|> r) + p <|> FinalP r = LookP $ \ma s -> FinalP (runLookP p ma s <|> r) + -- two looks are combined (=optimization) + -- look + sthg else floats upwards + LookP f <|> LookP g = LookP (\ma s -> f ma s <|> g ma s) + LookP f <|> p = LookP (\ma s -> f ma s <|> p) + p <|> LookP f = LookP (\ma s -> p <|> f ma s) +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Choice (LookP s m) where + left' = alternate . Left + right' = alternate . Right +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Alternator (LookP s m) where + alternate = \case + Left (ItemP l k) -> + ItemP (either l (const empty)) (alternate . Left . k) + Right (ItemP l k) -> + ItemP (either (const empty) l) (alternate . Right . k) + Left (LookP k) -> LookP $ dimap + (maybe Nothing (either Just (const Nothing))) + (rmap (alternate . Left)) k + Right (LookP k) -> LookP $ dimap + (maybe Nothing (either (const Nothing) Just)) + (rmap (alternate . Right)) k + Left (ResultP x p) -> ResultP (Left x) (alternate (Left p)) + Right (ResultP x p) -> ResultP (Right x) (alternate (Right p)) + Left (FinalP r) -> FinalP (fmap (first' Left) r) + Right (FinalP r) -> FinalP (fmap (first' Right) r) +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Distributor (LookP s m) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 31c3d0b..ae04c24 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -10,20 +10,14 @@ Portability : non-portable module Data.Profunctor.Monadic ( Monadic (..) - , monochrome - , monochrome_ - , withMonochrome - , withMonochrome_ + , bondP ) where -import Control.Applicative import Control.Category -import Control.Comonad import Control.Arrow import Control.Lens import Control.Monad import Data.Profunctor -import Data.Profunctor.Monoidal import Prelude hiding (id, (.)) class @@ -31,36 +25,14 @@ class , forall x. Monad (p m x) ) => Monadic m p where liftP :: m b -> p m a b - bondM :: p m a a -> (a -> p m b c) -> p m (a,b) (a,c) + instance Monad m => Monadic m Kleisli where liftP = Kleisli . return - bondM (Kleisli f) g = Kleisli $ \(x,b) -> do - y <- f x - c <- runKleisli (g y) b - return (y,c) instance Monad m => Monadic m Star where liftP = Star . return - bondM (Star f) g = Star $ \(x,b) -> do - y <- f x - c <- runStar (g y) b - return (y,c) - -monochrome_ - :: (Monadic m p, Applicative m) - => p m a b -> Optic (p m) m a b () () -monochrome_ = monochrome . (*<) - -monochrome - :: (Monadic m p, Applicative m) - => (p m a b -> p m s t) -> Optic (p m) m s t a b -monochrome f = fmap pure . f . join . fmap liftP - -withMonochrome_ - :: (Monadic m p, Applicative m) - => Optic (p m) m a b () () -> p m a b -withMonochrome_ f = withMonochrome f oneP -withMonochrome - :: (Monadic m p, Applicative m) - => Optic (p m) m s t a b -> p m a b -> p m s t -withMonochrome f = join . fmap liftP . f . fmap pure +bondP :: Monadic m p => p m a b -> (b -> p m c d) -> p m (a,c) (b,d) +bondP p f = do + b <- lmap fst p + d <- lmap snd (f b) + return (b,d) diff --git a/src/Data/Profunctor/Polyadic.hs b/src/Data/Profunctor/Polyadic.hs deleted file mode 100644 index b330d27..0000000 --- a/src/Data/Profunctor/Polyadic.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-| -Module : Data.Profunctor.Polyadic -Description : polyadic & tetradic profunctors -Copyright : (C) 2025 - Eitan Chatav -License : BSD-style (see the file LICENSE) -Maintainer : Eitan Chatav -Stability : provisional -Portability : non-portable --} - -{-# LANGUAGE PolyKinds, QualifiedDo #-} - -module Data.Profunctor.Polyadic - ( Polyadic (..), bindP - , Tetradic (..) - , TaggedP (..) - , UntaggedT (..) - , UntaggedC (..) - ) where - -import Control.Applicative -import Control.Category -import Control.Comonad -import Control.Lens -import Control.Monad -import Control.Monad.State -import Control.Monad.Trans.Indexed -import qualified Control.Monad.Trans.Indexed.Do as Ix -import Data.Profunctor.Monadic -import Prelude hiding (id, (.)) - -class - ( forall i j. Profunctor (p i j m) - , forall i j x. Functor (p i j m x) - , forall i. Monadic m (p i i) - ) => Polyadic m p where - joinP :: p i j m a (p j k m a b) -> p i k m a b - bondP :: p i i m a a -> (a -> p i j m b c) -> p i j m (a,b) (a,c) - -bindP :: Polyadic m p => (b -> p j k m a c) -> p i j m a b -> p i k m a c -bindP f p = joinP (fmap f p) - -class (forall i j. Profunctor (p i j f)) => Tetradic f p where - - tetramap - :: (h -> i) -> (j -> k) - -> (s -> a) -> (b -> t) - -> p i j f a b -> p h k f s t - tetramap f1 f2 f3 f4 = dimapT f1 f2 . dimap f3 f4 - - dimapT - :: (h -> i) -> (j -> k) - -> p i j f a b -> p h k f a b - dimapT f1 f2 = tetramap f1 f2 id id - -newtype TaggedP t i j f a b = TagP {untagP :: t i j f b} - deriving newtype (Functor, Applicative, Monad) -instance Functor (t i j f) => Profunctor (TaggedP t i j f) where - dimap _ f = TagP . fmap f . untagP -instance (Monad m, IxMonadTrans t) - => Monadic m (TaggedP t i i) where - liftP = TagP . lift - bondM = bondP -instance (Monad m, IxMonadTrans t) - => Polyadic m (TaggedP t) where - joinP = TagP . joinIx . fmap untagP . untagP - bondP (TagP m) f = TagP $ Ix.do - a <- m - c <- untagP (f a) - return (a,c) - -newtype UntaggedT p a i j f b = UntagT {tagT :: p i j f a b} - deriving newtype (Functor, Applicative, Monad) -instance (forall m. Monad m => Monadic m (p i j)) - => MonadTrans (UntaggedT p a i j) where - lift = UntagT . liftP -instance (forall m. Monad m => Polyadic m p) - => IxMonadTrans (UntaggedT p a) where - joinIx = UntagT . joinP . fmap tagT . tagT - -newtype UntaggedC p a b f i j = UntagC {tagC :: p i j f a b} -instance (Tetradic f p, Functor f) => Tetradic f (UntaggedC p) where - tetramap f1 f2 f3 f4 = UntagC . tetramap f3 f4 f1 f2 . tagC -instance (Tetradic f p, Functor f) => Profunctor (UntaggedC p a b f) where - dimap f g = UntagC . dimapT f g . tagC -instance (Tetradic f p, Functor f) => Functor (UntaggedC p a b f i) where - fmap = rmap -instance (Polyadic m p, Monoid b) => Category (UntaggedC p a b m) where - id = UntagC (pure mempty) - UntagC g . UntagC f = UntagC (joinP (fmap (\b -> fmap (<> b) g) f)) -instance (Polyadic m p, Monad m, Monoid b) - => Semigroup (UntaggedC p a b m i i) where (<>) = (>>>) -instance (Polyadic m p, Monad m, Monoid b) - => Monoid (UntaggedC p a b m i i) where mempty = id From cc65ec3db7a0555b7fc7736995151dc5f9418fa7 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 21 Dec 2025 20:36:59 -0800 Subject: [PATCH 171/282] removal --- distributors.cabal | 4 -- package.yaml | 2 - src/Data/Profunctor/Grammar.hs | 102 ++++++++++++--------------------- test/Spec.hs | 2 +- 4 files changed, 37 insertions(+), 73 deletions(-) diff --git a/distributors.cabal b/distributors.cabal index d197a54..1d463e7 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -97,11 +97,9 @@ library , base >=4.7 && <5 , bifunctors >=5.6 && <6 , bytestring >=0.11 && <1 - , comonad >=5.0.8 && <6 , containers >=0.6 && <1 , contravariant >=1.5 && <2 , distributive >=0.6 && <1 - , indexed-transformers >=0.1.0.4 && <1 , kan-extensions >=5.2.5 && <6 , lens >=5.2 && <6 , mtl >=2.3 && <3 @@ -167,13 +165,11 @@ test-suite spec , base >=4.7 && <5 , bifunctors >=5.6 && <6 , bytestring >=0.11 && <1 - , comonad >=5.0.8 && <6 , containers >=0.6 && <1 , contravariant >=1.5 && <2 , distributive >=0.6 && <1 , distributors , hspec - , indexed-transformers >=0.1.0.4 && <1 , kan-extensions >=5.2.5 && <6 , lens >=5.2 && <6 , mtl >=2.3 && <3 diff --git a/package.yaml b/package.yaml index 8a609f0..4c5cefd 100644 --- a/package.yaml +++ b/package.yaml @@ -23,7 +23,6 @@ dependencies: - adjunctions >= 4.4 && < 5 - bifunctors >= 5.6 && < 6 - bytestring >= 0.11 && < 1 -- comonad >= 5.0.8 && < 6 - containers >= 0.6 && < 1 - contravariant >= 1.5 && < 2 - distributive >= 0.6 && < 1 @@ -31,7 +30,6 @@ dependencies: - lens >= 5.2 && < 6 - MemoTrie >= 0.6.11 && < 1 - mtl >= 2.3 && < 3 -- indexed-transformers >= 0.1.0.4 && < 1 - profunctors >= 5.6 && < 6 - tagged >= 0.8 && < 1 - template-haskell diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 74f4fed..8872b43 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -10,9 +10,6 @@ module Data.Profunctor.Grammar , evalPrintor -- * Grammor , Grammor (..) - , grammor - , evalGrammor - , evalGrammor_ -- * Reador , Reador (..) , runReador @@ -23,7 +20,6 @@ module Data.Profunctor.Grammar import Control.Applicative import Control.Arrow import Control.Category -import Control.Comonad import Control.Monad.Codensity import Control.Monad.Reader import Control.Monad.State @@ -62,13 +58,7 @@ printP (PP f) a = fmap snd . f (Just a) parseP :: PP s f a b -> s -> f (b,s) parseP (PP f) = f Nothing -newtype Grammor s t f a b = Grammor {runGrammor :: s -> f t} -grammor :: Applicative f => t -> Grammor s t f a b -grammor = Grammor . pure . pure -evalGrammor :: (Monoid s, Comonad f) => Grammor s t f a b -> t -evalGrammor = extract . extract . runGrammor -evalGrammor_ :: Grammor () t Identity a b -> t -evalGrammor_ = evalGrammor +newtype Grammor t a b = Grammor {runGrammor :: t} newtype Reador s f a b = Reador {unReador :: Codensity (LookT s f) b} runReador @@ -404,64 +394,44 @@ instance (Alternative m, Monad m) => MonadFail (Printor s m a) where fail _ = empty -- Grammor instances -instance Functor (Grammor s t f a) where fmap _ = coerce -instance Contravariant (Grammor s t f a) where contramap _ = coerce -instance Profunctor (Grammor s t f) where dimap _ _ = coerce -instance Bifunctor (Grammor s t f) where bimap _ _ = coerce -instance Choice (Grammor s t f) where +instance Functor (Grammor t a) where fmap _ = coerce +instance Contravariant (Grammor t a) where contramap _ = coerce +instance Profunctor (Grammor t) where dimap _ _ = coerce +instance Bifunctor (Grammor t) where bimap _ _ = coerce +instance Choice (Grammor t) where left' = coerce right' = coerce -instance Filterable (Grammor s t ((,) All) a) where - mapMaybe _ = Grammor . fmap (\(_, t) -> (All False, t)) . runGrammor -instance Cochoice (Grammor s t ((,) All)) where - unleft = Grammor . fmap (\(_, t) -> (All False, t)) . runGrammor - unright = Grammor . fmap (\(_, t) -> (All False, t)) . runGrammor -instance Filtrator (Grammor s t ((,) All)) where - filtrate (Grammor p) = - ( Grammor (fmap (\(_, t) -> (All False, t)) p) - , Grammor (fmap (\(_, t) -> (All False, t)) p) - ) -instance (Monoid t, Applicative f) - => Applicative (Grammor s t f a) where - pure _ = Grammor (pure (pure mempty)) - Grammor rex1 <*> Grammor rex2 = - Grammor (liftA2 (liftA2 (<>)) rex1 rex2) -instance (KleeneStarAlgebra t, Applicative f) - => Alternative (Grammor s t f a) where - empty = Grammor (pure (pure zeroK)) - Grammor rex1 <|> Grammor rex2 = - Grammor (liftA2 (liftA2 (>|<)) rex1 rex2) - many (Grammor rex) = Grammor (fmap (fmap starK) rex) - some (Grammor rex) = Grammor (fmap (fmap plusK) rex) -instance (KleeneStarAlgebra t, Applicative f) - => Distributor (Grammor s t f) where - zeroP = Grammor (pure (pure zeroK)) - Grammor rex1 >+< Grammor rex2 = - Grammor (liftA2 (liftA2 (>|<)) rex1 rex2) - manyP (Grammor rex) = Grammor (fmap (fmap starK) rex) - optionalP (Grammor rex) = Grammor (fmap (fmap optK) rex) -instance (KleeneStarAlgebra t, Applicative f) - => Alternator (Grammor s t f) where +instance Monoid t => Applicative (Grammor t a) where + pure _ = Grammor mempty + Grammor rex1 <*> Grammor rex2 = Grammor (rex1 <> rex2) +instance KleeneStarAlgebra t => Alternative (Grammor t a) where + empty = Grammor zeroK + Grammor rex1 <|> Grammor rex2 = Grammor (rex1 >|< rex2) + many (Grammor rex) = Grammor (starK rex) + some (Grammor rex) = Grammor (plusK rex) +instance KleeneStarAlgebra t => Distributor (Grammor t) where + zeroP = Grammor zeroK + Grammor rex1 >+< Grammor rex2 = Grammor (rex1 >|< rex2) + manyP (Grammor rex) = Grammor (starK rex) + optionalP (Grammor rex) = Grammor (optK rex) +instance KleeneStarAlgebra t => Alternator (Grammor t) where alternate = either coerce coerce - someP (Grammor rex) = Grammor (fmap (fmap plusK) rex) -instance (Tokenized token t, Applicative f) - => Tokenized token (Grammor s t f a b) where - anyToken = grammor anyToken - token = grammor . token - oneOf = grammor . oneOf - notOneOf = grammor . notOneOf - asIn = grammor . asIn - notAsIn = grammor . notAsIn -instance (TokenAlgebra a t, Applicative f) - => TokenAlgebra a (Grammor s t f a b) where - tokenClass = grammor . tokenClass -instance (TerminalSymbol token t, Applicative f) - => TerminalSymbol token (Grammor s t f a b) where - terminal = grammor . terminal -instance (Comonad f, Applicative f, Monoid s, BackusNaurForm t) - => BackusNaurForm (Grammor s t f a b) where - rule name = Grammor . fmap (fmap (rule name)) . runGrammor - ruleRec name = grammor . ruleRec name . dimap grammor evalGrammor + someP (Grammor rex) = Grammor (plusK rex) +instance Tokenized token t => Tokenized token (Grammor t a b) where + anyToken = Grammor anyToken + token = Grammor . token + oneOf = Grammor . oneOf + notOneOf = Grammor . notOneOf + asIn = Grammor . asIn + notAsIn = Grammor . notAsIn +instance TokenAlgebra a t => TokenAlgebra a (Grammor t a b) where + tokenClass = Grammor . tokenClass +instance TerminalSymbol token t + => TerminalSymbol token (Grammor t a b) where + terminal = Grammor . terminal +instance BackusNaurForm t => BackusNaurForm (Grammor t a b) where + rule name = Grammor . rule name . runGrammor + ruleRec name = Grammor . ruleRec name . dimap Grammor runGrammor -- Reador instances deriving newtype instance Functor (Reador s f a) diff --git a/test/Spec.hs b/test/Spec.hs index 09e91bb..b71954a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -60,7 +60,7 @@ main :: IO () main = hspec $ do describe "regexGrammar" $ do it "should generate a correct grammar" $ do - evalGrammor_ regexGrammar `shouldBe` expectedRegexGrammar + runGrammor regexGrammar `shouldBe` expectedRegexGrammar for_ regexExamples $ \(rex, str) -> do it ("should print " <> show (runRegString rex) <> " correctly") $ toList rex `shouldBe` str From ced024db56960b735b067f37d4a514b15a6b1fa6 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 21 Dec 2025 20:45:49 -0800 Subject: [PATCH 172/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 8872b43..12b411d 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -582,11 +582,11 @@ instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) FinalP r >>= k = FinalP $ do (x,s) <- r runLookP (k x) Nothing s --- instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) --- => Monadic m (LookP s) where --- liftP m = do --- s <- LookP (\_ -> return) --- FinalP $ (,s) <$> m +instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) + => Monadic m (LookP s) where + liftP m = do + s <- LookP (\_ -> return) + FinalP $ (,s) <$> m instance Filterable f => Filterable (LookP s f a) where mapMaybe f = \case ItemP l k -> ItemP l (mapMaybe f . k) From 18e055b2dab593807648d8fd52eb7b3b1e43cdca Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 21 Dec 2025 22:42:49 -0800 Subject: [PATCH 173/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index ae04c24..ecdcd92 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -16,7 +16,6 @@ module Data.Profunctor.Monadic import Control.Category import Control.Arrow import Control.Lens -import Control.Monad import Data.Profunctor import Prelude hiding (id, (.)) From a75c4791c450a1eecf19718f5e9770be0c41ad8c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 18:09:14 -0800 Subject: [PATCH 174/282] simplify --- distributors.cabal | 3 - package.yaml | 1 - src/Control/Lens/Grammar.hs | 43 ++- src/Control/Lens/Grammar/Do.hs | 43 --- src/Data/Profunctor/Filtrator.hs | 7 +- src/Data/Profunctor/Grammar.hs | 489 ++++--------------------------- src/Data/Profunctor/Monadic.hs | 37 ++- 7 files changed, 94 insertions(+), 529 deletions(-) delete mode 100644 src/Control/Lens/Grammar/Do.hs diff --git a/distributors.cabal b/distributors.cabal index 1d463e7..bd6985f 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -33,7 +33,6 @@ library Control.Lens.Grammar Control.Lens.Grammar.BackusNaur Control.Lens.Grammar.Boole - Control.Lens.Grammar.Do Control.Lens.Grammar.Kleene Control.Lens.Grammar.Symbol Control.Lens.Grammar.Token @@ -100,7 +99,6 @@ library , containers >=0.6 && <1 , contravariant >=1.5 && <2 , distributive >=0.6 && <1 - , kan-extensions >=5.2.5 && <6 , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 @@ -170,7 +168,6 @@ test-suite spec , distributive >=0.6 && <1 , distributors , hspec - , kan-extensions >=5.2.5 && <6 , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 diff --git a/package.yaml b/package.yaml index 4c5cefd..b0a72bb 100644 --- a/package.yaml +++ b/package.yaml @@ -26,7 +26,6 @@ dependencies: - containers >= 0.6 && < 1 - contravariant >= 1.5 && < 2 - distributive >= 0.6 && < 1 -- kan-extensions >= 5.2.5 && < 6 - lens >= 5.2 && < 6 - MemoTrie >= 0.6.11 && < 1 - mtl >= 2.3 && < 3 diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 75c4a72..3e0eec4 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -21,7 +21,6 @@ import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Token import Control.Lens.Grammar.Symbol -import Control.Monad import Data.Maybe hiding (mapMaybe) import Data.Monoid import Data.Profunctor.Distributor @@ -50,16 +49,13 @@ type Grammar token a = forall p. , forall x. BackusNaurForm (p x x) , Alternator p ) => p a a -type CtxGrammar token a = forall p m. - ( Tokenizor token (p m) - , forall x. BackusNaurForm (p m x x) - , Alternator (p m) - , Filtrator (p m) - , Monadic m p - , Alternative m - , Filterable m - , Monad m - ) => p m a a +type CtxGrammar token a = forall p. + ( Tokenizor token p + , forall x. BackusNaurForm (p x x) + , Monadic p + , Alternator p + , Filtrator p + ) => p a a type RegGrammarr token a b = forall p. ( Tokenizor token p @@ -70,16 +66,13 @@ type Grammarr token a b = forall p. , forall x. BackusNaurForm (p x x) , Alternator p ) => p a a -> p b b -type CtxGrammarr token a b = forall p m. - ( Tokenizor token (p m) - , forall x. BackusNaurForm (p m x x) - , Alternator (p m) - , Filtrator (p m) - , Monadic m p - , Alternative m - , Filterable m - , Monad m - ) => p m a a -> p m b b +type CtxGrammarr token a b = forall p. + ( Tokenizor token p + , forall x. BackusNaurForm (p x x) + , Monadic p + , Alternator p + , Filtrator p + ) => p a a -> p b b type Tokenizor token p = ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) @@ -243,13 +236,13 @@ instance IsList RegString where = fromMaybe zeroK . listToMaybe . mapMaybe prsF - . runReador regexGrammar + . parseP regexGrammar where prsF (rex,"") = Just (RegString rex) prsF _ = Nothing toList = maybe "\\q" ($ "") - . evalPrintor regexGrammar + . printP regexGrammar . runRegString instance IsString RegString where fromString = fromList @@ -263,13 +256,13 @@ instance IsList RegBnfString where = fromMaybe zeroK . listToMaybe . mapMaybe prsF - . runReador ebnfGrammar + . parseP ebnfGrammar where prsF (ebnf,"") = Just (RegBnfString ebnf) prsF _ = Nothing toList = maybe "{start} = \\q" ($ "") - . evalPrintor ebnfGrammar + . printP ebnfGrammar . runRegBnfString instance IsString RegBnfString where fromString = fromList diff --git a/src/Control/Lens/Grammar/Do.hs b/src/Control/Lens/Grammar/Do.hs deleted file mode 100644 index 25a7ee1..0000000 --- a/src/Control/Lens/Grammar/Do.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-| -Module : Control.Lens.Grammar -Description : monadic pair-bonding do-notation -Copyright : (C) 2025 - Eitan Chatav -License : BSD-style (see the file LICENSE) -Maintainer : Eitan Chatav -Stability : provisional -Portability : non-portable --} - -module Control.Lens.Grammar.Do - ( -- * - (>>=) - , (>>) - , (<$>) - , fail - , return - ) where - -import Control.Applicative hiding ((<$>)) -import Control.Lens -import Control.Lens.Grammar.BackusNaur -import Control.Monad (join) -import Data.Profunctor.Monadic -import Prelude hiding ((>>=), (>>), (<$>), fail) - -(>>=) :: Monadic m p => p m a a -> (a -> p m b c) -> p m (a,b) (a,c) -infixl 1 >>= -(>>=) = bondP - -(>>) :: Monadic m p => p m () () -> p m b c -> p m b c -infixl 1 >> -x >> y = dimap ((),) snd (x >>= const y) - -(<$>) - :: (Monadic m p, Applicative m) - => Optic (p m) m s t a b - -> p m (a,()) (b,()) -> p m s t -infixl 4 <$> -f <$> x = join (fmap liftP (f (dimap (,()) (pure . fst) x))) - -fail :: (Alternative f, BackusNaurForm (f a)) => String -> f a -fail msg = rule msg empty diff --git a/src/Data/Profunctor/Filtrator.hs b/src/Data/Profunctor/Filtrator.hs index a43215f..017ccc6 100644 --- a/src/Data/Profunctor/Filtrator.hs +++ b/src/Data/Profunctor/Filtrator.hs @@ -11,7 +11,6 @@ import Control.Monad import Data.Profunctor import Data.Profunctor.Distributor import Data.Profunctor.Monad -import Data.Profunctor.Monadic import Data.Profunctor.Yoneda import Witherable @@ -49,9 +48,9 @@ class (Cochoice p, forall x. Filterable (p x)) -- -- prop> mfiltrate = filtrate mfiltrate - :: (Monadic m p, Alternator (p m)) - => p m (Either a c) (Either b d) - -> (p m a b, p m c d) + :: (Alternator p, forall x. Monad (p x)) + => p (Either a c) (Either b d) + -> (p a b, p c d) mfiltrate = (lmap Left >=> either pure (const empty)) &&& diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 12b411d..51a808f 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -1,264 +1,130 @@ module Data.Profunctor.Grammar ( -- * Parsor Parsor (..) - , PP (..) - , printP + , unparseP , parseP -- * Printor , Printor (..) - , printor - , evalPrintor + , printP -- * Grammor , Grammor (..) - -- * Reador - , Reador (..) - , runReador - , LookT (..) - , runLookT ) where import Control.Applicative import Control.Arrow import Control.Category -import Control.Monad.Codensity -import Control.Monad.Reader -import Control.Monad.State import Control.Lens -import Control.Lens.Extras import Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Control.Monad -import Data.Bifunctor import Data.Coerce import Data.Monoid import Data.Profunctor import Data.Profunctor.Distributor import Data.Profunctor.Filtrator -import Data.Profunctor.Monadic import Data.Profunctor.Monoidal import Data.Void import Prelude hiding (id, (.)) import GHC.Exts import Witherable -newtype Parsor s f a b = Parsor {runParsor :: s -> f (b,s)} +newtype Parsor s f a b = Parsor {runParsor :: Maybe a -> s -> f (b,s)} +parseP :: Parsor s f a b -> s -> f (b,s) +parseP (Parsor f) = f Nothing +unparseP :: Functor f => Parsor s f a b -> a -> s -> f s +unparseP (Parsor f) a = fmap snd . f (Just a) newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)} -printor :: Functor f => (a -> f (s -> s)) -> Printor s f a a -printor f = Printor (\a -> fmap (a,) (f a)) -evalPrintor :: Functor f => Printor s f a b -> a -> f (s -> s) -evalPrintor (Printor f) = fmap snd . f - -newtype PP s f a b = PP {runPP :: Maybe a -> s -> f (b,s)} -printP :: Functor f => PP s f a b -> a -> s -> f s -printP (PP f) a = fmap snd . f (Just a) -parseP :: PP s f a b -> s -> f (b,s) -parseP (PP f) = f Nothing +printP :: Functor f => Printor s f a b -> a -> f (s -> s) +printP (Printor f) = fmap snd . f newtype Grammor t a b = Grammor {runGrammor :: t} -newtype Reador s f a b = Reador {unReador :: Codensity (LookT s f) b} -runReador - :: (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Reador s m a b -> s -> m (b, s) -runReador (Reador (Codensity f)) = runLookT (f return) - -data LookT s f a - = LookT (s -> LookT s f a) - | GetT (Item s -> LookT s f a) - | ResultT a (LookT s f a) - | FinalT (f (a, s)) -runLookT - :: (Alternative f, IsList s, Cons s s (Item s) (Item s)) - => LookT s f a -> s -> f (a, s) -runLookT (GetT f) s = - maybe empty (\(h,t) -> runLookT (f h) t) (uncons s) -runLookT (LookT f) s = runLookT (f s) s -runLookT (ResultT x p) s = pure (x,s) <|> runLookT p s -runLookT (FinalT r) _ = r - -data LookP s f a b - = ItemP (a -> f (Item s)) (Item s -> LookP s f a b) - | LookP (Maybe a -> s -> LookP s f a b) - | ResultP b (LookP s f a b) - | FinalP (f (b,s)) - -runLookP - :: (Monad m, Alternative m, IsList s, Cons s s (Item s) (Item s)) - => LookP s m a b -> Maybe a -> s -> m (b, s) -runLookP (ItemP f g) ma s = case ma of - Nothing -> maybe empty - (\(hd,tl) -> runLookP (g hd) ma tl) - (uncons s) - Just a -> do - item <- f a - runLookP (g item) ma (cons item s) -runLookP (LookP f) ma s = runLookP (f ma s) ma s -runLookP (ResultP x p) ma s = pure (x,s) <|> runLookP p ma s -runLookP (FinalP r) _ _ = r - --- PP instances -deriving stock instance Functor f => Functor (PP s f a) -instance Functor f => Profunctor (PP s f) where - dimap f g = PP . dimap (fmap f) (fmap (fmap (first' g))) . runPP -instance Monad m => Applicative (PP s m a) where - pure b = PP (\_ s -> pure (b,s)) - PP x <*> PP y = PP $ \ma s -> do - (f, t) <- x ma s - (a, u) <- y ma t - return (f a, u) -instance Monad m => Monad (PP s m a) where +-- Parsor instances +deriving stock instance Functor f => Functor (Parsor s f a) +instance Functor f => Profunctor (Parsor s f) where + dimap f g = Parsor . dimap (fmap f) (fmap (fmap (first' g))) . runParsor +instance Monad m => Applicative (Parsor s m a) where + pure b = Parsor (\_ s -> pure (b,s)) + Parsor f <*> Parsor x = Parsor $ \ma s -> do + (g, s') <- f ma s + (a, s'') <- x ma s' + return (g a, s'') +instance (Alternative m, Monad m) => Strong (Parsor s m) where + first' p = p >*< id + second' p = id >*< p +instance Monad m => Monad (Parsor s m a) where return = pure - PP p >>= f = PP $ \ma s -> do - (a, t) <- p ma s - runPP (f a) ma t -instance (Alternative m, Monad m) => Alternative (PP s m a) where - empty = PP (\_ _ -> empty) - PP p <|> PP q = PP $ \ma s -> p ma s <|> q ma s -instance (Alternative m, Monad m) => MonadPlus (PP s m a) -instance Monad m => MonadReader s (PP s m a) where - ask = PP $ \_ s -> return (s,s) - local f = PP . fmap (lmap f) . runPP -instance Filterable f => Filterable (PP s f a) where - mapMaybe f (PP p) = PP $ \fa s -> + Parsor p >>= f = Parsor $ \ma s -> do + (a, s') <- p ma s + runParsor (f a) ma s' +instance (Alternative m, Monad m) => Alternative (Parsor s m a) where + empty = Parsor (\_ _ -> empty) + Parsor p <|> Parsor q = Parsor $ \ma s -> p ma s <|> q ma s +instance (Alternative m, Monad m) => MonadPlus (Parsor s m a) +instance Filterable f => Filterable (Parsor s f a) where + mapMaybe f (Parsor p) = Parsor $ \fa s -> mapMaybe (\(a,t) -> fmap (,t) (f a)) (p fa s) -instance Filterable f => Cochoice (PP s f) where +instance Filterable f => Cochoice (Parsor s f) where unleft = fst . filtrate unright = snd . filtrate -instance Filterable f => Filtrator (PP s f) where - filtrate (PP p) = - ( PP $ \ma s -> mapMaybe +instance Filterable f => Filtrator (Parsor s f) where + filtrate (Parsor p) = + ( Parsor $ \ma s -> mapMaybe (\case{(Left b,t) -> Just (b,t); _ -> Nothing}) (p (fmap Left ma) s) - , PP $ \ma s -> mapMaybe + , Parsor $ \ma s -> mapMaybe (\case{(Right b,t) -> Just (b,t); _ -> Nothing}) (p (fmap Right ma) s) ) -instance Monad m => Monadic m (PP s) where - liftP m = PP $ \_ s -> (,s) <$> m -instance (Alternative m, Monad m) => Distributor (PP s m) -instance (Alternative m, Monad m) => Choice (PP s m) where +instance (Alternative m, Monad m) => Distributor (Parsor s m) +instance (Alternative m, Monad m) => Choice (Parsor s m) where left' = alternate . Left right' = alternate . Right -instance (Alternative m, Monad m) => Alternator (PP s m) where +instance (Alternative m, Monad m) => Alternator (Parsor s m) where alternate = \case - Left (PP p) -> PP $ \ma s -> case ma of + Left (Parsor p) -> Parsor $ \ma s -> case ma of Nothing -> fmap (first' Left) (p Nothing s) Just (Left a) -> fmap (first' Left) (p (Just a) s) Just (Right _) -> empty - Right (PP p) -> PP $ \ma s -> case ma of + Right (Parsor p) -> Parsor $ \ma s -> case ma of Nothing -> fmap (first' Right) (p Nothing s) Just (Right a) -> fmap (first' Right) (p (Just a) s) Just (Left _) -> empty -instance (Alternative m, Monad m) => Category (PP s m) where - id = PP $ \ma s -> case ma of +instance (Alternative m, Monad m) => Category (Parsor s m) where + id = Parsor $ \ma s -> case ma of Nothing -> empty Just a -> pure (a,s) - PP q . PP p = PP $ \ma s -> case ma of + Parsor q . Parsor p = Parsor $ \ma s -> case ma of Nothing -> empty Just a -> do (b, t) <- p (Just a) s q (Just b) t -instance (Alternative m, Monad m) => Arrow (PP s m) where - arr f = PP $ \ma s -> case ma of +instance (Alternative m, Monad m) => Arrow (Parsor s m) where + arr f = Parsor $ \ma s -> case ma of Nothing -> empty Just a -> pure (f a, s) (***) = (>*<) -instance (Alternative m, Monad m) => ArrowZero (PP s m) where + first = first' + second = second' +instance (Alternative m, Monad m) => ArrowZero (Parsor s m) where zeroArrow = empty -instance (Alternative m, Monad m) => ArrowPlus (PP s m) where +instance (Alternative m, Monad m) => ArrowPlus (Parsor s m) where (<+>) = (<|>) -instance (Alternative m, Monad m) => ArrowChoice (PP s m) where +instance (Alternative m, Monad m) => ArrowChoice (Parsor s m) where (+++) = (>+<) left = left' right = right' instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => Tokenized a (PP s m a a) where - anyToken = PP $ maybe + ) => Tokenized a (Parsor s m a a) where + anyToken = Parsor $ maybe (maybe empty pure . uncons) (\a -> pure . (a,) . cons a) -instance - ( Categorized a, a ~ Item s, IsList s, Cons s s a a - , Filterable m, Alternative m, Monad m - ) => TokenAlgebra a (PP s m a a) -instance - ( Categorized a, a ~ Item s, IsList s, Cons s s a a - , Filterable m, Alternative m, Monad m - ) => TerminalSymbol a (PP s m () ()) where -instance - ( Char ~ Item s, IsList s, Cons s s Char Char - , Filterable m, Alternative m, Monad m - ) => IsString (PP s m () ()) where - fromString = terminal -instance - ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s - , Filterable m, Alternative m, Monad m - ) => IsString (PP s m s s) where - fromString = fromTokens -instance BackusNaurForm (PP s m a b) -instance (Alternative m, Monad m) => MonadFail (PP s m a) where - fail _ = empty - --- Parsor instances -instance Functor f => Functor (Parsor s f a) where - fmap f = Parsor . fmap (fmap (first' f)) . runParsor -instance Functor f => Bifunctor (Parsor s f) where - bimap _ = lmap coerce . fmap - first _ = coerce - second = fmap -instance Functor f => Profunctor (Parsor s f) where - dimap _ = rmap coerce . fmap - lmap _ = coerce - rmap = fmap -instance Monad m => Applicative (Parsor s m a) where - pure b = Parsor (\s -> return (b,s)) - Parsor x <*> Parsor y = Parsor $ \s -> do - (f, t) <- x s - (a, u) <- y t - return (f a, u) -instance Monad m => Monad (Parsor s m a) where - Parsor p >>= f = Parsor $ \s -> do - (a, t) <- p s - runParsor (f a) t -instance (Alternative m, Monad m) => Alternative (Parsor s m a) where - empty = Parsor (\_ -> empty) - Parsor p <|> Parsor q = Parsor (\str -> p str <|> q str) -instance (Alternative m, Monad m) => MonadPlus (Parsor s m a) -instance Monad m => MonadState s (Parsor s m a) where - get = Parsor (\s -> pure (s,s)) - put = Parsor . (pure (pure . ((),))) -instance (Alternative m, Monad m) => Choice (Parsor s m) where - left' = alternate . Left - right' = alternate . Right -instance (Alternative m, Monad m) => Distributor (Parsor s m) -instance (Alternative m, Monad m) => Alternator (Parsor s m) 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 Monad m => Monadic m (Parsor s) where - liftP m = Parsor $ \s -> (,s) <$> m -instance Filterable f => Filterable (Parsor s f a) where - mapMaybe f (Parsor p) = Parsor (mapMaybe (\(a,str) -> (,str) <$> f a) . p) -instance Filterable f => Cochoice (Parsor s f) where - unleft = fst . filtrate - unright = snd . filtrate -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 - ( Categorized a, a ~ Item s, IsList s, Cons s s a a - , Filterable m, Alternative m, Monad m - ) => Tokenized a (Parsor s m a a) where - anyToken = Parsor (maybe empty pure . uncons) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m @@ -266,7 +132,7 @@ instance instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m - ) => TerminalSymbol a (Parsor s m () ()) + ) => TerminalSymbol a (Parsor s m () ()) where instance ( Char ~ Item s, IsList s, Cons s s Char Char , Filterable m, Alternative m, Monad m @@ -278,10 +144,6 @@ instance ) => IsString (Parsor s m s s) where fromString = fromTokens instance BackusNaurForm (Parsor s m a b) -instance AsEmpty s => Matching s (Parsor s Maybe a b) where - word =~ parsor = case runParsor parsor word of - Nothing -> False - Just (_,t) -> is _Empty t instance (Alternative m, Monad m) => MonadFail (Parsor s m a) where fail _ = empty @@ -307,12 +169,6 @@ instance Monad f => Monad (Printor s f a) where (b,h) <- runPrintor (f a1) a return (b, h . g) instance (Alternative f, Monad f) => MonadPlus (Printor s f a) -instance Monad m => MonadReader a (Printor s m a) where - ask = Printor (\a -> return (a, id)) - reader f = (Printor (\a -> return (f a, id))) - local f = Printor . (\m -> m . f) . runPrintor -instance Monad m => Monadic m (Printor s) where - liftP m = Printor $ \_ -> (, id) <$> m instance Applicative f => Distributor (Printor s f) where zeroP = Printor absurd Printor p >+< Printor q = Printor $ @@ -371,6 +227,7 @@ instance , Filterable m, Alternative m, Monad m ) => Tokenized a (Printor s m a a) where anyToken = Printor (\b -> pure (b, cons b)) + -- anyToken = Printor (\a -> pure (\s -> (uncons s, cons a s))) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m @@ -432,237 +289,3 @@ instance TerminalSymbol token t instance BackusNaurForm t => BackusNaurForm (Grammor t a b) where rule name = Grammor . rule name . runGrammor ruleRec name = Grammor . ruleRec name . dimap Grammor runGrammor - --- Reador instances -deriving newtype instance Functor (Reador s f a) -deriving newtype instance Applicative (Reador s f a) -deriving newtype instance Monad (Reador s f a) -deriving newtype instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Alternative (Reador s m a) -deriving newtype instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => MonadPlus (Reador s m a) -instance (Alternative m, Filterable m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Filterable (Reador s m a) where - mapMaybe f - = Reador . lift - . mapMaybe f - . lowerCodensity . unReador -instance Profunctor (Reador s f) where - dimap _ f (Reador p) = Reador (fmap f p) -instance Bifunctor (Reador s f) where - bimap _ f (Reador p) = Reador (fmap f p) -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Monadic m (Reador s) where - liftP m = Reador $ do - s <- ask - lift $ FinalT ((,s) <$> m) -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Choice (Reador s m) where - left' = alternate . Left - right' = alternate . Right -instance (Alternative m, Monad m, Filterable m, IsList s, Cons s s (Item s) (Item s)) - => Cochoice (Reador s m) where - unleft = fst . filtrate - unright = snd . filtrate -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Distributor (Reador s m) -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Alternator (Reador s m) where - alternate (Left (Reador p)) = Reador (fmap Left p) - alternate (Right (Reador p)) = Reador (fmap Right p) -instance (Alternative m, Filterable m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Filtrator (Reador s m) where - filtrate = mfiltrate -instance - ( Alternative m, Filterable m, Monad m - , IsList s, Categorized c, c ~ Item s, Cons s s c c - ) => Tokenized c (Reador s m c c) where - anyToken = Reador (lift (GetT return)) -instance - ( Filterable m, Alternative m, Monad m - , IsList s, Categorized c, c ~ Item s, Cons s s c c - ) => TokenAlgebra c (Reador s m c c) -instance - ( Filterable m, Alternative m, Monad m - , IsList s, Categorized c, c ~ Item s, Cons s s c c - ) => TerminalSymbol c (Reador s m () ()) -instance - ( Filterable m, Alternative m, Monad m - , IsList s, Item s ~ Char, Cons s s Char Char - ) => IsString (Reador s m () ()) where - fromString = terminal -instance - ( Filterable m, Alternative m, Monad m - , IsList s, Item s ~ Char, AsEmpty s, Cons s s Char Char - ) => IsString (Reador s m s s) where - fromString = fromTokens -instance BackusNaurForm (Reador s m a b) -instance (IsList s, Cons s s (Item s) (Item s), AsEmpty s) - => Matching s (Reador s Maybe a b) where - word =~ reador = case runReador reador word of - Nothing -> False - Just (_,t) -> is _Empty t -instance - ( Alternative m, Monad m - , IsList s, Item s ~ Char, Cons s s Char Char - ) => MonadFail (Reador s m a) where - fail _ = empty - --- LookT instances -deriving stock instance Functor f => Functor (LookT s f) -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Applicative (LookT s m) where - pure x = ResultT x (FinalT empty) - (<*>) = ap -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Monad (LookT s m) where - GetT f >>= k = GetT $ \c -> f c >>= k - LookT f >>= k = LookT $ \s -> f s >>= k - ResultT x p >>= k = k x <|> (p >>= k) - FinalT r >>= k = FinalT $ do - (x,s) <- r - runLookT (k x) s -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => MonadReader s (LookT s m) where - ask = LookT return - local f = \case - GetT k -> do - s <- ask - FinalT (runLookT (GetT k) (f s)) - LookT k -> LookT (k . f) - ResultT x p -> ResultT x (local f p) - FinalT r -> FinalT r -instance Filterable f => Filterable (LookT s f) where - mapMaybe f = \case - GetT k -> GetT (mapMaybe f . k) - LookT k -> LookT (mapMaybe f . k) - ResultT x p -> mapMaybe f p & case f x of - Nothing -> id - Just y -> ResultT y - FinalT r -> FinalT (mapMaybe (\(a,s) -> (,s) <$> f a) r) -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Alternative (LookT s m) where - empty = FinalT empty - -- most common case: two gets are combined - GetT f1 <|> GetT f2 = GetT (\c -> f1 c <|> f2 c) - -- results are delivered as soon as possible - ResultT x p <|> q = ResultT x (p <|> q) - p <|> ResultT x q = ResultT x (p <|> q) - -- two finals are combined - -- final + look becomes one look and one final (=optimization) - -- final + sthg else becomes one look and one final - FinalT r <|> FinalT t = FinalT (r <|> t) - FinalT r <|> LookT f = LookT $ \s -> FinalT (r <|> runLookT (f s) s) - FinalT r <|> p = LookT $ \s -> FinalT (r <|> runLookT p s) - LookT f <|> FinalT r = LookT $ \s -> FinalT (runLookT (f s) s <|> r) - p <|> FinalT r = LookT $ \s -> FinalT (runLookT p s <|> r) - -- two looks are combined (=optimization) - -- look + sthg else floats upwards - LookT f <|> LookT g = LookT (\s -> f s <|> g s) - LookT f <|> p = LookT (\s -> f s <|> p) - p <|> LookT f = LookT (\s -> p <|> f s) - --- LookP instances -deriving stock instance Functor f => Functor (LookP s f a) -instance Functor f => Profunctor (LookP s f) where - dimap f g = \case - ItemP l k -> ItemP (lmap f l) (rmap (dimap f g) k) - LookP k -> LookP (dimap (fmap f) (rmap (dimap f g)) k) - ResultP c p -> ResultP (g c) (dimap f g p) - FinalP r -> FinalP (fmap (first' g) r) -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Applicative (LookP s m a) where - pure x = ResultP x (FinalP empty) - (<*>) = ap -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Monad (LookP s m a) where - ItemP f g >>= k = ItemP f $ \c -> g c >>= k - LookP f >>= k = LookP $ \ma s -> f ma s >>= k - ResultP x p >>= k = k x <|> (p >>= k) - FinalP r >>= k = FinalP $ do - (x,s) <- r - runLookP (k x) Nothing s -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Monadic m (LookP s) where - liftP m = do - s <- LookP (\_ -> return) - FinalP $ (,s) <$> m -instance Filterable f => Filterable (LookP s f a) where - mapMaybe f = \case - ItemP l k -> ItemP l (mapMaybe f . k) - LookP k -> LookP (\ma -> mapMaybe f . k ma) - ResultP x p -> mapMaybe f p & case f x of - Nothing -> id - Just y -> ResultP y - FinalP r -> FinalP (mapMaybe (\(a,s) -> (,s) <$> f a) r) -instance Filterable f => Cochoice (LookP s f) where - unleft = fst . filtrate - unright = snd . filtrate -instance Filterable f => Filtrator (LookP s f) where - filtrate = \case - ItemP l k -> - ( ItemP (l . Left) (fst . filtrate . k) - , ItemP (l . Right) (snd . filtrate . k) - ) - LookP k -> - ( LookP (dimap (fmap Left) (rmap (fst . filtrate)) k) - , LookP (dimap (fmap Right) (rmap (snd . filtrate)) k) - ) - ResultP x p -> case x of - Left b -> - ( ResultP b (fst (filtrate p)) - , snd (filtrate p) - ) - Right c -> - ( fst (filtrate p) - , ResultP c (snd (filtrate p)) - ) - FinalP r -> - ( FinalP (mapMaybe (\case {(Left b, s) -> Just (b,s); _ -> Nothing}) r) - , FinalP (mapMaybe (\case {(Right c, s) -> Just (c,s); _ -> Nothing}) r) - ) -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Alternative (LookP s m a) where - empty = FinalP empty - -- most common case: two items are combined - ItemP l1 f1 <|> ItemP l2 f2 = - ItemP (\a -> l1 a <|> l2 a) (\c -> f1 c <|> f2 c) - -- results are delivered as soon as possible - ResultP x p <|> q = ResultP x (p <|> q) - p <|> ResultP x q = ResultP x (p <|> q) - -- two finals are combined - -- final + look becomes one look and one final (=optimization) - -- final + sthg else becomes one look and one final - FinalP r <|> FinalP t = FinalP (r <|> t) - FinalP r <|> LookP f = LookP $ \ma s -> FinalP (r <|> runLookP (f ma s) ma s) - FinalP r <|> p = LookP $ \ma s -> FinalP (r <|> runLookP p ma s) - LookP f <|> FinalP r = LookP $ \ma s -> FinalP (runLookP (f ma s) ma s <|> r) - p <|> FinalP r = LookP $ \ma s -> FinalP (runLookP p ma s <|> r) - -- two looks are combined (=optimization) - -- look + sthg else floats upwards - LookP f <|> LookP g = LookP (\ma s -> f ma s <|> g ma s) - LookP f <|> p = LookP (\ma s -> f ma s <|> p) - p <|> LookP f = LookP (\ma s -> p <|> f ma s) -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Choice (LookP s m) where - left' = alternate . Left - right' = alternate . Right -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Alternator (LookP s m) where - alternate = \case - Left (ItemP l k) -> - ItemP (either l (const empty)) (alternate . Left . k) - Right (ItemP l k) -> - ItemP (either (const empty) l) (alternate . Right . k) - Left (LookP k) -> LookP $ dimap - (maybe Nothing (either Just (const Nothing))) - (rmap (alternate . Left)) k - Right (LookP k) -> LookP $ dimap - (maybe Nothing (either (const Nothing) Just)) - (rmap (alternate . Right)) k - Left (ResultP x p) -> ResultP (Left x) (alternate (Left p)) - Right (ResultP x p) -> ResultP (Right x) (alternate (Right p)) - Left (FinalP r) -> FinalP (fmap (first' Left) r) - Right (FinalP r) -> FinalP (fmap (first' Right) r) -instance (Alternative m, Monad m, IsList s, Cons s s (Item s) (Item s)) - => Distributor (LookP s m) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index ecdcd92..92649da 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -1,6 +1,6 @@ {-| -Module : Data.Profunctor.Monadic -Description : monadic profunctors +Module : Control.Lens.Grammar.Do +Description : monadic pair-bonding do-notation Copyright : (C) 2025 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav @@ -9,29 +9,26 @@ Portability : non-portable -} module Data.Profunctor.Monadic - ( Monadic (..) - , bondP + ( -- * + Monadic + , (>>=) + , (>>) + , fail + , return ) where -import Control.Category -import Control.Arrow -import Control.Lens import Data.Profunctor -import Prelude hiding (id, (.)) +import Prelude hiding ((>>=), (>>)) -class - ( Profunctor (p m) - , forall x. Monad (p m x) - ) => Monadic m p where - liftP :: m b -> p m a b +type Monadic p = (Profunctor p, forall x. Monad (p x)) -instance Monad m => Monadic m Kleisli where - liftP = Kleisli . return -instance Monad m => Monadic m Star where - liftP = Star . return - -bondP :: Monadic m p => p m a b -> (b -> p m c d) -> p m (a,c) (b,d) -bondP p f = do +(>>=) :: Monadic p => p a b -> (b -> p c d) -> p (a,c) (b,d) +infixl 1 >>= +p >>= f = do b <- lmap fst p d <- lmap snd (f b) return (b,d) + +(>>) :: Monadic p => p a b -> p () c -> p a b +infixl 1 >> +x >> y = dimap (,()) fst (x >>= const y) From b033aaa0fde4b676cc257687090bdc021a4af4c3 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 18:41:24 -0800 Subject: [PATCH 175/282] names --- src/Control/Lens/Monocle.hs | 2 +- src/Data/Profunctor/Distributor.hs | 2 +- src/Data/Profunctor/Monoidal.hs | 16 ++++++++-------- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Control/Lens/Monocle.hs b/src/Control/Lens/Monocle.hs index d67d785..892ec43 100644 --- a/src/Control/Lens/Monocle.hs +++ b/src/Control/Lens/Monocle.hs @@ -68,7 +68,7 @@ prop> traverse = ditraversed prop> cotraversed = ditraversed -} ditraversed :: (Traversable g, Distributive g) => Monocle (g a) (g b) a b -ditraversed = unwrapPafb . replicateP . WrapPafb +ditraversed = unwrapPafb . ditraverse . WrapPafb {- | Repeat action indefinitely. -} forevered :: Monocle s t () b diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index 954a93a..c45f63e 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -213,7 +213,7 @@ class Traversable t => Homogeneous t where Any `Traversable` & `Distributive` countable product can be given a default implementation for the `homogeneously` method. - prop> homogeneously = replicateP + prop> homogeneously = ditraverse And any user-defined homogeneous algebraic datatype has a default instance for `Homogeneous`, by deriving `Generic1`. diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index 07d90ca..24570bb 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -4,8 +4,8 @@ module Data.Profunctor.Monoidal ( -- * Monoidal Monoidal , oneP, (>*<), (>*), (*<) - , dimap2, foreverP, replicateP - , (>:<), asEmpty, replicateN + , dimap2, foreverP, ditraverse + , (>:<), asEmpty, replicateP , meander, eotFunList ) where @@ -95,16 +95,16 @@ foreverP a = let a' = a >* a' in a' {- | Thanks to Fy on Monoidal Café Discord. -`replicateP` is roughly analagous to `replicateM`, +`ditraverse` 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 +ditraverse :: (Traversable t, Distributive t, Monoidal p) => p a b -> p (t a) (t b) -replicateP p = traverse (\f -> lmap f p) (distribute id) +ditraverse p = traverse (\f -> lmap f p) (distribute id) {- | A `Monoidal` nil operator. -} asEmpty :: (AsEmpty s, Monoidal p, Choice p) => p s s @@ -115,11 +115,11 @@ asEmpty = _Empty >? oneP x >:< xs = _Cons >? x >*< xs infixr 5 >:< -replicateN +replicateP :: (Monoidal p, Choice p, AsEmpty s, AsEmpty t, Cons s t a b) => Int -> p a b -> p s t -replicateN n _ | n <= 0 = lmap (const Empty) asEmpty -replicateN n a = a >:< replicateN (n-1) a +replicateP n _ | n <= 0 = lmap (const Empty) asEmpty +replicateP n a = a >:< replicateP (n-1) a {- | For any `Monoidal`, `Choice` & `Strong` `Profunctor`, `meander` is invertible and gives a default implementation for the From a501817a7966ef150690d37e7e7f9238b1292024 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 19:08:47 -0800 Subject: [PATCH 176/282] Snoc unparseP --- src/Data/Profunctor/Grammar.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 51a808f..db68353 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -119,27 +119,32 @@ instance (Alternative m, Monad m) => ArrowChoice (Parsor s m) where left = left' right = right' instance - ( Categorized a, a ~ Item s, IsList s, Cons s s a a + ( Categorized a, a ~ Item s, IsList s + , Cons s s a a, Snoc s s a a , Filterable m, Alternative m, Monad m ) => Tokenized a (Parsor s m a a) where anyToken = Parsor $ maybe (maybe empty pure . uncons) - (\a -> pure . (a,) . cons a) + (\a -> pure . (a,) . flip snoc a) instance - ( Categorized a, a ~ Item s, IsList s, Cons s s a a + ( Categorized a, a ~ Item s, IsList s + , Cons s s a a, Snoc s s a a , Filterable m, Alternative m, Monad m ) => TokenAlgebra a (Parsor s m a a) instance - ( Categorized a, a ~ Item s, IsList s, Cons s s a a + ( Categorized a, a ~ Item s, IsList s + , Cons s s a a, Snoc s s a a , Filterable m, Alternative m, Monad m ) => TerminalSymbol a (Parsor s m () ()) where instance - ( Char ~ Item s, IsList s, Cons s s Char Char + ( Char ~ Item s, IsList s + , Cons s s Char Char, Snoc s s Char Char , Filterable m, Alternative m, Monad m ) => IsString (Parsor s m () ()) where fromString = terminal instance - ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s + ( Char ~ Item s, IsList s + , Cons s s Char Char, Snoc s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m ) => IsString (Parsor s m s s) where fromString = fromTokens @@ -227,7 +232,6 @@ instance , Filterable m, Alternative m, Monad m ) => Tokenized a (Printor s m a a) where anyToken = Printor (\b -> pure (b, cons b)) - -- anyToken = Printor (\a -> pure (\s -> (uncons s, cons a s))) instance ( Categorized a, a ~ Item s, IsList s, Cons s s a a , Filterable m, Alternative m, Monad m From 2ef0287b31709c506d54830fe3d39ffe460d060d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 19:15:20 -0800 Subject: [PATCH 177/282] Update Filtrator.hs --- src/Data/Profunctor/Filtrator.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Filtrator.hs b/src/Data/Profunctor/Filtrator.hs index 017ccc6..26eea07 100644 --- a/src/Data/Profunctor/Filtrator.hs +++ b/src/Data/Profunctor/Filtrator.hs @@ -11,6 +11,7 @@ import Control.Monad import Data.Profunctor import Data.Profunctor.Distributor import Data.Profunctor.Monad +import Data.Profunctor.Monadic (Monadic) import Data.Profunctor.Yoneda import Witherable @@ -48,7 +49,7 @@ class (Cochoice p, forall x. Filterable (p x)) -- -- prop> mfiltrate = filtrate mfiltrate - :: (Alternator p, forall x. Monad (p x)) + :: (Monadic p, Alternator p) => p (Either a c) (Either b d) -> (p a b, p c d) mfiltrate = From f7bd99f88a19052c9b442078cad3e5c3229cd0fe Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 19:40:53 -0800 Subject: [PATCH 178/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index db68353..64ce5f3 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -41,7 +41,7 @@ newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)} printP :: Functor f => Printor s f a b -> a -> f (s -> s) printP (Printor f) = fmap snd . f -newtype Grammor t a b = Grammor {runGrammor :: t} +newtype Grammor g a b = Grammor {runGrammor :: g} -- Parsor instances deriving stock instance Functor f => Functor (Parsor s f a) @@ -255,41 +255,41 @@ instance (Alternative m, Monad m) => MonadFail (Printor s m a) where fail _ = empty -- Grammor instances -instance Functor (Grammor t a) where fmap _ = coerce -instance Contravariant (Grammor t a) where contramap _ = coerce -instance Profunctor (Grammor t) where dimap _ _ = coerce -instance Bifunctor (Grammor t) where bimap _ _ = coerce -instance Choice (Grammor t) where +instance Functor (Grammor g a) where fmap _ = coerce +instance Contravariant (Grammor g a) where contramap _ = coerce +instance Profunctor (Grammor g) where dimap _ _ = coerce +instance Bifunctor (Grammor g) where bimap _ _ = coerce +instance Choice (Grammor g) where left' = coerce right' = coerce -instance Monoid t => Applicative (Grammor t a) where +instance Monoid g => Applicative (Grammor g a) where pure _ = Grammor mempty Grammor rex1 <*> Grammor rex2 = Grammor (rex1 <> rex2) -instance KleeneStarAlgebra t => Alternative (Grammor t a) where +instance KleeneStarAlgebra g => Alternative (Grammor g a) where empty = Grammor zeroK Grammor rex1 <|> Grammor rex2 = Grammor (rex1 >|< rex2) many (Grammor rex) = Grammor (starK rex) some (Grammor rex) = Grammor (plusK rex) -instance KleeneStarAlgebra t => Distributor (Grammor t) where +instance KleeneStarAlgebra g => Distributor (Grammor g) where zeroP = Grammor zeroK Grammor rex1 >+< Grammor rex2 = Grammor (rex1 >|< rex2) manyP (Grammor rex) = Grammor (starK rex) optionalP (Grammor rex) = Grammor (optK rex) -instance KleeneStarAlgebra t => Alternator (Grammor t) where +instance KleeneStarAlgebra g => Alternator (Grammor g) where alternate = either coerce coerce someP (Grammor rex) = Grammor (plusK rex) -instance Tokenized token t => Tokenized token (Grammor t a b) where +instance Tokenized token g => Tokenized token (Grammor g a b) where anyToken = Grammor anyToken token = Grammor . token oneOf = Grammor . oneOf notOneOf = Grammor . notOneOf asIn = Grammor . asIn notAsIn = Grammor . notAsIn -instance TokenAlgebra a t => TokenAlgebra a (Grammor t a b) where +instance TokenAlgebra a g => TokenAlgebra a (Grammor g a b) where tokenClass = Grammor . tokenClass -instance TerminalSymbol token t - => TerminalSymbol token (Grammor t a b) where +instance TerminalSymbol token g + => TerminalSymbol token (Grammor g a b) where terminal = Grammor . terminal -instance BackusNaurForm t => BackusNaurForm (Grammor t a b) where +instance BackusNaurForm g => BackusNaurForm (Grammor g a b) where rule name = Grammor . rule name . runGrammor ruleRec name = Grammor . ruleRec name . dimap Grammor runGrammor From 643cf4f17a59fd8b85ed7f2f4e69be592aeba951 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 20:13:15 -0800 Subject: [PATCH 179/282] Delete TODO --- TODO | 11 ----------- 1 file changed, 11 deletions(-) delete mode 100644 TODO diff --git a/TODO b/TODO deleted file mode 100644 index d3b3cf1..0000000 --- a/TODO +++ /dev/null @@ -1,11 +0,0 @@ -TODO - -x Monadic interface ala Lysxia - Monadic example grammar - More Tests - Parsec profunctor with either TokenTest or NonTerminal errors ala Leijen - Categoric interface with diid - Read Chomsky - Documents - Announcement - Delete TODO From 9473281e110933b7d2c056ad4a68658c479f20d2 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 20:29:15 -0800 Subject: [PATCH 180/282] simplify regular expression language --- src/Control/Lens/Grammar.hs | 8 ++++---- test/Spec.hs | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 3e0eec4..176c441 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -107,7 +107,7 @@ exprG rex = rule "expression" $ choiceP anyG :: Grammar Char () anyG = rule "any-token" $ choiceP $ map terminal - [".", "[^]", "\\P{}", "[^\\P{}]"] + ["[^]", "\\P{}", "[^\\P{}]"] atomG :: Grammarr Char (RegEx Char) (RegEx Char) atomG rex = rule "atom" $ choiceP @@ -207,7 +207,7 @@ charsControl = ] failG :: Grammar Char () -failG = rule "fail" $ terminal "\\q" <|> terminal "[]" +failG = rule "fail" $ terminal "[]" ruleG :: Grammar Char (String, RegEx Char) ruleG = rule "rule" $ manyP charG >*< terminal " = " >* regexGrammar @@ -241,7 +241,7 @@ instance IsList RegString where prsF (rex,"") = Just (RegString rex) prsF _ = Nothing toList - = maybe "\\q" ($ "") + = maybe "[]" ($ "") . printP regexGrammar . runRegString instance IsString RegString where @@ -261,7 +261,7 @@ instance IsList RegBnfString where prsF (ebnf,"") = Just (RegBnfString ebnf) prsF _ = Nothing toList - = maybe "{start} = \\q" ($ "") + = maybe "{start} = []" ($ "") . printP ebnfGrammar . runRegBnfString instance IsString RegBnfString where diff --git a/test/Spec.hs b/test/Spec.hs index b71954a..e26f840 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -18,7 +18,7 @@ expectedRegexGrammar = Bnf { startBnf = fromString "\\q{regex}" , rulesBnf = fromList $ map (second' fromString) [ ("alternate","\\q{sequence}(\\|\\q{sequence})*") - , ("any-token","\\.|\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") + , ("any-token","\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") , ("atom","(\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{fail}|\\q{any-token}|\\[\\q{char}+\\]|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}|\\(\\q{regex}\\)") , ("category","Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn") , ("category-test","(\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}") @@ -26,7 +26,7 @@ expectedRegexGrammar = Bnf , ("char-control-abbrev","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") , ("char-escaped","[\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control-abbrev}") , ("expression","\\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}") - , ("fail","\\\\q|\\[\\]") + , ("fail","\\[\\]") , ("regex","\\q{alternate}") , ("sequence","\\q{char}*|\\q{expression}*") ] @@ -37,12 +37,12 @@ regexExamples :: [(RegString, String)] regexExamples = [ (terminal "abc123etc.", "abc123etc\\.") , (terminal "x" <> terminal "y", "xy") - , (zeroK, "\\q") + , (zeroK, "[]") , (terminal "x" >|< terminal "y", "x|y") , (optK (terminal "x"), "x?") , (starK (terminal "x"), "x*") , (plusK (terminal "x"), "x+") - , (anyToken, ".") + , (anyToken, "[^]") , (oneOf "abc", "[abc]") , (notOneOf "abc", "[^abc]") , (asIn UppercaseLetter, "\\p{Lu}") From 35b67ac8db51fd40e1d8e074d0856b67b3cf2910 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 20:58:48 -0800 Subject: [PATCH 181/282] add empty doctest --- distributors.cabal | 75 ++++++++++++++++++++++++++++++++-- package.yaml | 11 +++-- test/doc/Main.hs | 11 +++++ test/{Spec.hs => spec/Main.hs} | 0 4 files changed, 91 insertions(+), 6 deletions(-) create mode 100644 test/doc/Main.hs rename test/{Spec.hs => spec/Main.hs} (100%) diff --git a/distributors.cabal b/distributors.cabal index bd6985f..ccfd357 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.38.1. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack @@ -110,15 +110,84 @@ library , witherable >=0.4 && <1 default-language: Haskell2010 +test-suite doc + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_distributors + autogen-modules: + Paths_distributors + hs-source-dirs: + test/doc + default-extensions: + AllowAmbiguousTypes + Arrows + ConstraintKinds + DataKinds + DefaultSignatures + DeriveFoldable + DeriveFunctor + DeriveTraversable + DeriveGeneric + DerivingStrategies + DerivingVia + EmptyCase + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + ImpredicativeTypes + InstanceSigs + LambdaCase + MagicHash + MonoLocalBinds + 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: + MemoTrie >=0.6.11 && <1 + , adjunctions >=4.4 && <5 + , base >=4.7 && <5 + , bifunctors >=5.6 && <6 + , bytestring >=0.11 && <1 + , containers >=0.6 && <1 + , contravariant >=1.5 && <2 + , distributive >=0.6 && <1 + , distributors + , doctest + , lens >=5.2 && <6 + , 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 + test-suite spec type: exitcode-stdio-1.0 - main-is: Spec.hs + main-is: Main.hs other-modules: Paths_distributors autogen-modules: Paths_distributors hs-source-dirs: - test + test/spec default-extensions: AllowAmbiguousTypes Arrows diff --git a/package.yaml b/package.yaml index b0a72bb..7d2759f 100644 --- a/package.yaml +++ b/package.yaml @@ -11,7 +11,6 @@ extra-source-files: extra-doc-files: - CHANGELOG.md - category: Profunctors, Optics, Parsing synopsis: Unifying Parsers, Printers & Grammars description: @@ -90,9 +89,15 @@ default-extensions: - UndecidableSuperClasses tests: + doc: + main: Main.hs + source-dirs: test/doc + dependencies: + - distributors + - doctest spec: - main: Spec.hs - source-dirs: test + main: Main.hs + source-dirs: test/spec dependencies: - distributors - hspec diff --git a/test/doc/Main.hs b/test/doc/Main.hs new file mode 100644 index 0000000..dc8989a --- /dev/null +++ b/test/doc/Main.hs @@ -0,0 +1,11 @@ +module Main (main) where + +import Test.DocTest + +main :: IO () +main = doctest + [ +-- "-isrc" +-- , "src" +-- , "-XLambdaCase" + ] diff --git a/test/Spec.hs b/test/spec/Main.hs similarity index 100% rename from test/Spec.hs rename to test/spec/Main.hs From 26b1dd7f9efc6e290325fbd1835fe6630be86057 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 21:11:38 -0800 Subject: [PATCH 182/282] some module headers --- src/Data/Profunctor/Filtrator.hs | 10 ++++++++++ src/Data/Profunctor/Grammar.hs | 10 ++++++++++ src/Data/Profunctor/Monadic.hs | 7 +++++-- src/Data/Profunctor/Monoidal.hs | 10 ++++++++++ 4 files changed, 35 insertions(+), 2 deletions(-) diff --git a/src/Data/Profunctor/Filtrator.hs b/src/Data/Profunctor/Filtrator.hs index 26eea07..9a88776 100644 --- a/src/Data/Profunctor/Filtrator.hs +++ b/src/Data/Profunctor/Filtrator.hs @@ -1,3 +1,13 @@ +{-| +Module : Data.Profunctor.Filtrator +Description : filtrators +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + module Data.Profunctor.Filtrator ( Filtrator (filtrate) , mfiltrate diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 64ce5f3..f5381a7 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -1,3 +1,13 @@ +{-| +Module : Data.Profunctor.Grammar +Description : grammar distributors +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + module Data.Profunctor.Grammar ( -- * Parsor Parsor (..) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 92649da..57ed038 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -1,6 +1,6 @@ {-| -Module : Control.Lens.Grammar.Do -Description : monadic pair-bonding do-notation +Module : Data.Profunctor.Monadic +Description : monadic profunctors Copyright : (C) 2025 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav @@ -22,6 +22,9 @@ import Prelude hiding ((>>=), (>>)) type Monadic p = (Profunctor p, forall x. Monad (p x)) +{- | See Li-yao Xia [Monadic profunctors for bidirectional programming] +(https://blog.poisson.chat/posts/2017-01-01-monadic-profunctors.html) +-} (>>=) :: Monadic p => p a b -> (b -> p c d) -> p (a,c) (b,d) infixl 1 >>= p >>= f = do diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index 24570bb..26fc9cf 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -1,5 +1,15 @@ {-# OPTIONS_GHC -Wno-orphans #-} +{-| +Module : Data.Profunctor.Monoidal +Description : monoidal profunctors +Copyright : (C) 2025 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + module Data.Profunctor.Monoidal ( -- * Monoidal Monoidal From 8fac0216f02f6ce19597aae42ad8ecdb8e54cef0 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 21:12:31 -0800 Subject: [PATCH 183/282] Update stack.yaml --- stack.yaml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/stack.yaml b/stack.yaml index 74f6bc6..53ed11c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,3 @@ resolver: lts-22.6 packages: -- . -extra-deps: -- indexed-transformers-0.1.0.4 +- . \ No newline at end of file From 7efc2f6672e47de1fe84f4d7b0b80becb015cd01 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sat, 31 Jan 2026 21:12:47 -0800 Subject: [PATCH 184/282] Update stack.yaml --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 53ed11c..6cb3778 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ resolver: lts-22.6 packages: -- . \ No newline at end of file +- . From 7f99a766082048f2e9c7bc7a63ba04c1bb6af3a5 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 08:10:53 -0800 Subject: [PATCH 185/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 57ed038..af399d2 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -20,11 +20,11 @@ module Data.Profunctor.Monadic import Data.Profunctor import Prelude hiding ((>>=), (>>)) -type Monadic p = (Profunctor p, forall x. Monad (p x)) - -{- | See Li-yao Xia [Monadic profunctors for bidirectional programming] +{- | See Li-yao Xia, [Monadic profunctors for bidirectional programming] (https://blog.poisson.chat/posts/2017-01-01-monadic-profunctors.html) -} +type Monadic p = (Profunctor p, forall x. Monad (p x)) + (>>=) :: Monadic p => p a b -> (b -> p c d) -> p (a,c) (b,d) infixl 1 >>= p >>= f = do @@ -32,6 +32,6 @@ p >>= f = do d <- lmap snd (f b) return (b,d) -(>>) :: Monadic p => p a b -> p () c -> p a b +(>>) :: Monadic p => p () c -> p a b -> p a b infixl 1 >> -x >> y = dimap (,()) fst (x >>= const y) +x >> y = do _ <- lmap (const ()) x; y From 7982e66b188b6d568ac410a314fe63714fa921ba Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 12:18:49 -0800 Subject: [PATCH 186/282] more regex simplification --- src/Control/Lens/Grammar.hs | 270 ++++++++++++++++-------------------- test/spec/Main.hs | 11 +- 2 files changed, 126 insertions(+), 155 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 176c441..894960a 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -1,15 +1,11 @@ module Control.Lens.Grammar - ( -- * RegEx - RegString (..) - , RegBnfString (..) - , RegGrammar - , RegGrammarr - , ebnfGrammar + ( RegGrammar , Grammar - , Grammarr - , regexGrammar , CtxGrammar - , CtxGrammarr + , RegString (..) + , RegBnfString (..) + , regexGrammar + , ebnfGrammar , Tokenizor ) where @@ -57,23 +53,6 @@ type CtxGrammar token a = forall p. , Filtrator p ) => p a a -type RegGrammarr token a b = forall p. - ( Tokenizor token p - , Alternator p - ) => p a a -> p b b -type Grammarr token a b = forall p. - ( Tokenizor token p - , forall x. BackusNaurForm (p x x) - , Alternator p - ) => p a a -> p b b -type CtxGrammarr token a b = forall p. - ( Tokenizor token p - , forall x. BackusNaurForm (p x x) - , Monadic p - , Alternator p - , Filtrator p - ) => p a a -> p b b - type Tokenizor token p = ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) , forall x y. (x ~ token, y ~ token) => TokenAlgebra token (p x y) @@ -81,136 +60,127 @@ type Tokenizor token p = regexGrammar :: Grammar Char (RegEx Char) regexGrammar = ruleRec "regex" altG - -ebnfGrammar :: Grammar Char (Bnf (RegEx Char)) -ebnfGrammar = rule "ebnf" $ _Bnf >~ - terminal "start = " >* regexGrammar - >*< several noSep (terminal "\n" >* ruleG) - -altG :: Grammarr Char (RegEx Char) (RegEx Char) -altG rex = rule "alternate" $ - chain1 Left (_RegExam . _Alternate) (sepBy (terminal "|")) (seqG rex) - -seqG :: Grammarr Char (RegEx Char) (RegEx Char) -seqG rex = rule "sequence" $ choiceP - [ _Terminal >? manyP charG - , chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) - ] - -exprG :: Grammarr Char (RegEx Char) (RegEx Char) -exprG rex = rule "expression" $ choiceP - [ _KleeneOpt >? atomG rex *< terminal "?" - , _KleeneStar >? atomG rex *< terminal "*" - , _KleenePlus >? atomG rex *< terminal "+" - , atomG rex - ] - -anyG :: Grammar Char () -anyG = rule "any-token" $ choiceP $ map terminal - ["[^]", "\\P{}", "[^\\P{}]"] - -atomG :: Grammarr Char (RegEx Char) (RegEx Char) -atomG rex = rule "atom" $ choiceP - [ _NonTerminal >? terminal "\\q{" >* manyP charG *< terminal "}" - , _Terminal >? charG >:< asEmpty - , _RegExam . _Fail >? failG - , _RegExam . _Pass >? anyG - , _RegExam . _OneOf >? - terminal "[" >* several1 noSep charG *< terminal "]" - , _RegExam . _NotOneOf >? - terminal "[^" >* several1 noSep charG - >*< (catTestG <|> pure (NotAsIn Set.empty)) - *< terminal "]" - , _RegExam . _NotOneOf >? pure Set.empty >*< catTestG - , terminal "(" >* rex *< terminal ")" - ] - -catTestG :: Grammar Char (CategoryTest Char) -catTestG = rule "category-test" $ choiceP - [ _AsIn >? terminal "\\p{" >* categoryG *< terminal "}" - , _NotAsIn >? terminal "\\P{" >* - several1 (sepBy (terminal "|")) categoryG - *< terminal "}" - ] - -categoryG :: Grammar Char GeneralCategory -categoryG = rule "category" $ choiceP - [ _LowercaseLetter >? terminal "Ll" - , _UppercaseLetter >? terminal "Lu" - , _TitlecaseLetter >? terminal "Lt" - , _ModifierLetter >? terminal "Lm" - , _OtherLetter >? terminal "Lo" - , _NonSpacingMark >? terminal "Mn" - , _SpacingCombiningMark >? terminal "Mc" - , _EnclosingMark >? terminal "Me" - , _DecimalNumber >? terminal "Nd" - , _LetterNumber >? terminal "Nl" - , _OtherNumber >? terminal "No" - , _ConnectorPunctuation >? terminal "Pc" - , _DashPunctuation >? terminal "Pd" - , _OpenPunctuation >? terminal "Ps" - , _ClosePunctuation >? terminal "Pe" - , _InitialQuote >? terminal "Pi" - , _FinalQuote >? terminal "Pf" - , _OtherPunctuation >? terminal "Po" - , _MathSymbol >? terminal "Sm" - , _CurrencySymbol >? terminal "Sc" - , _ModifierSymbol >? terminal "Sk" - , _OtherSymbol >? terminal "So" - , _Space >? terminal "Zs" - , _LineSeparator >? terminal "Zl" - , _ParagraphSeparator >? terminal "Zp" - , _Control >? terminal "Cc" - , _Format >? terminal "Cf" - , _Surrogate >? terminal "Cs" - , _PrivateUse >? terminal "Co" - , _NotAssigned >? terminal "Cn" - ] + where + altG rex = rule "alternate" $ + chain1 Left (_RegExam . _Alternate) (sepBy (terminal "|")) (seqG rex) + + seqG rex = rule "sequence" $ choiceP + [ _Terminal >? manyP charG + , chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) + ] + + exprG rex = rule "expression" $ choiceP + [ _KleeneOpt >? atomG rex *< terminal "?" + , _KleeneStar >? atomG rex *< terminal "*" + , _KleenePlus >? atomG rex *< terminal "+" + , atomG rex + ] + + anyG = rule "any-token" $ choiceP $ map terminal + ["[^]", "\\P{}", "[^\\P{}]"] + + atomG rex = rule "atom" $ choiceP + [ _NonTerminal >? terminal "\\q{" >* manyP charG *< terminal "}" + , _Terminal >? charG >:< asEmpty + , _RegExam >? classG + , terminal "(" >* rex *< terminal ")" + ] + + catTestG = rule "category-test" $ choiceP + [ _AsIn >? terminal "\\p{" >* categoryG *< terminal "}" + , _NotAsIn >? terminal "\\P{" >* + several1 (sepBy (terminal "|")) categoryG + *< terminal "}" + ] + + categoryG = rule "category" $ choiceP + [ _LowercaseLetter >? terminal "Ll" + , _UppercaseLetter >? terminal "Lu" + , _TitlecaseLetter >? terminal "Lt" + , _ModifierLetter >? terminal "Lm" + , _OtherLetter >? terminal "Lo" + , _NonSpacingMark >? terminal "Mn" + , _SpacingCombiningMark >? terminal "Mc" + , _EnclosingMark >? terminal "Me" + , _DecimalNumber >? terminal "Nd" + , _LetterNumber >? terminal "Nl" + , _OtherNumber >? terminal "No" + , _ConnectorPunctuation >? terminal "Pc" + , _DashPunctuation >? terminal "Pd" + , _OpenPunctuation >? terminal "Ps" + , _ClosePunctuation >? terminal "Pe" + , _InitialQuote >? terminal "Pi" + , _FinalQuote >? terminal "Pf" + , _OtherPunctuation >? terminal "Po" + , _MathSymbol >? terminal "Sm" + , _CurrencySymbol >? terminal "Sc" + , _ModifierSymbol >? terminal "Sk" + , _OtherSymbol >? terminal "So" + , _Space >? terminal "Zs" + , _LineSeparator >? terminal "Zl" + , _ParagraphSeparator >? terminal "Zp" + , _Control >? terminal "Cc" + , _Format >? terminal "Cf" + , _Surrogate >? terminal "Cs" + , _PrivateUse >? terminal "Co" + , _NotAssigned >? terminal "Cn" + ] + + classG = rule "char-class" $ choiceP + [ _Fail >? failG + , _Pass >? anyG + , _OneOf >? terminal "[" >* several1 noSep charG *< terminal "]" + , _NotOneOf >? + terminal "[^" >* several1 noSep charG + >*< (catTestG <|> pure (NotAsIn Set.empty)) + *< terminal "]" + , _NotOneOf >? pure Set.empty >*< catTestG + ] + + failG = rule "fail" $ terminal "[]" charG :: Grammar Char Char charG = rule "char" $ tokenClass (notOneOf charsReserved >&&< notAsIn Control) <|> terminal "\\" >* charEscapedG + where + charEscapedG = rule "char-escaped" $ + oneOf charsReserved <|> charControlG + + charsReserved = "$()*+?[\\]^{|}" + + charControlG = rule "char-control" $ choiceP + [ terminal abbreviation >* pure charControl + | (abbreviation, charControl) <- charsControl + ] + + charsControl = + [ ("NUL", '\NUL'), ("SOH", '\SOH'), ("STX", '\STX'), ("ETX", '\ETX') + , ("EOT", '\EOT'), ("ENQ", '\ENQ'), ("ACK", '\ACK'), ("BEL", '\BEL') + , ("BS", '\BS'), ("HT", '\HT'), ("LF", '\LF'), ("VT", '\VT') + , ("FF", '\FF'), ("CR", '\CR'), ("SO", '\SO'), ("SI", '\SI') + , ("DLE", '\DLE'), ("DC1", '\DC1'), ("DC2", '\DC2'), ("DC3", '\DC3') + , ("DC4", '\DC4'), ("NAK", '\NAK'), ("SYN", '\SYN'), ("ETB", '\ETB') + , ("CAN", '\CAN'), ("EM", '\EM'), ("SUB", '\SUB'), ("ESC", '\ESC') + , ("FS", '\FS'), ("GS", '\GS'), ("RS", '\RS'), ("US", '\US') + , ("DEL", '\DEL') + , ("PAD", '\x80'), ("HOP", '\x81'), ("BPH", '\x82'), ("NBH", '\x83') + , ("IND", '\x84'), ("NEL", '\x85'), ("SSA", '\x86'), ("ESA", '\x87') + , ("HTS", '\x88'), ("HTJ", '\x89'), ("VTS", '\x8A'), ("PLD", '\x8B') + , ("PLU", '\x8C'), ("RI", '\x8D'), ("SS2", '\x8E'), ("SS3", '\x8F') + , ("DCS", '\x90'), ("PU1", '\x91'), ("PU2", '\x92'), ("STS", '\x93') + , ("CCH", '\x94'), ("MW", '\x95'), ("SPA", '\x96'), ("EPA", '\x97') + , ("SOS", '\x98'), ("SGCI",'\x99'), ("SCI", '\x9A'), ("CSI", '\x9B') + , ("ST", '\x9C'), ("OSC", '\x9D'), ("PM", '\x9E'), ("APC", '\x9F') + ] -charEscapedG :: Grammar Char Char -charEscapedG = rule "char-escaped" $ - oneOf charsReserved <|> charControlG - -charControlG :: Grammar Char Char -charControlG = rule "char-control-abbrev" $ choiceP - [ terminal abbreviation >* pure charControl - | (abbreviation, charControl) <- charsControl - ] - -charsReserved :: [Char] -charsReserved = "$()*+.?[\\]^{|}" - -charsControl :: [(String, Char)] -charsControl = - [ ("NUL", '\NUL'), ("SOH", '\SOH'), ("STX", '\STX'), ("ETX", '\ETX') - , ("EOT", '\EOT'), ("ENQ", '\ENQ'), ("ACK", '\ACK'), ("BEL", '\BEL') - , ("BS", '\BS'), ("HT", '\HT'), ("LF", '\LF'), ("VT", '\VT') - , ("FF", '\FF'), ("CR", '\CR'), ("SO", '\SO'), ("SI", '\SI') - , ("DLE", '\DLE'), ("DC1", '\DC1'), ("DC2", '\DC2'), ("DC3", '\DC3') - , ("DC4", '\DC4'), ("NAK", '\NAK'), ("SYN", '\SYN'), ("ETB", '\ETB') - , ("CAN", '\CAN'), ("EM", '\EM'), ("SUB", '\SUB'), ("ESC", '\ESC') - , ("FS", '\FS'), ("GS", '\GS'), ("RS", '\RS'), ("US", '\US') - , ("DEL", '\DEL') - , ("PAD", '\x80'), ("HOP", '\x81'), ("BPH", '\x82'), ("NBH", '\x83') - , ("IND", '\x84'), ("NEL", '\x85'), ("SSA", '\x86'), ("ESA", '\x87') - , ("HTS", '\x88'), ("HTJ", '\x89'), ("VTS", '\x8A'), ("PLD", '\x8B') - , ("PLU", '\x8C'), ("RI", '\x8D'), ("SS2", '\x8E'), ("SS3", '\x8F') - , ("DCS", '\x90'), ("PU1", '\x91'), ("PU2", '\x92'), ("STS", '\x93') - , ("CCH", '\x94'), ("MW", '\x95'), ("SPA", '\x96'), ("EPA", '\x97') - , ("SOS", '\x98'), ("SGCI",'\x99'), ("SCI", '\x9A'), ("CSI", '\x9B') - , ("ST", '\x9C'), ("OSC", '\x9D'), ("PM", '\x9E'), ("APC", '\x9F') - ] - -failG :: Grammar Char () -failG = rule "fail" $ terminal "[]" - -ruleG :: Grammar Char (String, RegEx Char) -ruleG = rule "rule" $ manyP charG >*< terminal " = " >* regexGrammar +ebnfGrammar :: Grammar Char (Bnf (RegEx Char)) +ebnfGrammar = rule "ebnf" $ _Bnf >~ + terminal "{start} = " >* regexGrammar + >*< several noSep (terminal "\n" >* ruleG) + where + ruleG = rule "rule" $ terminal "{" >* manyP charG *< terminal "} = " + >*< regexGrammar newtype RegString = RegString {runRegString :: RegEx Char} deriving newtype diff --git a/test/spec/Main.hs b/test/spec/Main.hs index e26f840..a121beb 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -19,12 +19,13 @@ expectedRegexGrammar = Bnf , rulesBnf = fromList $ map (second' fromString) [ ("alternate","\\q{sequence}(\\|\\q{sequence})*") , ("any-token","\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") - , ("atom","(\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{fail}|\\q{any-token}|\\[\\q{char}+\\]|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}|\\(\\q{regex}\\)") + , ("atom","(\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{char-class}|\\(\\q{regex}\\)") , ("category","Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn") , ("category-test","(\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}") - , ("char","[^\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") - , ("char-control-abbrev","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") - , ("char-escaped","[\\$\\(\\)\\*\\+\\.\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control-abbrev}") + , ("char","[^\\$\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") + , ("char-class","\\q{fail}|\\q{any-token}|\\[\\q{char}+\\]|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}") + , ("char-control","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") + , ("char-escaped","[\\$\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control}") , ("expression","\\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}") , ("fail","\\[\\]") , ("regex","\\q{alternate}") @@ -35,7 +36,7 @@ expectedRegexGrammar = Bnf regexExamples :: [(RegString, String)] regexExamples = - [ (terminal "abc123etc.", "abc123etc\\.") + [ (terminal "abc123etc.", "abc123etc.") , (terminal "x" <> terminal "y", "xy") , (zeroK, "[]") , (terminal "x" >|< terminal "y", "x|y") From 6b7e6a1b7b566505ec8317dc80de492f22a6c42f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 12:21:25 -0800 Subject: [PATCH 187/282] char-any --- src/Control/Lens/Grammar.hs | 2 +- test/spec/Main.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 894960a..3619e03 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -76,7 +76,7 @@ regexGrammar = ruleRec "regex" altG , atomG rex ] - anyG = rule "any-token" $ choiceP $ map terminal + anyG = rule "char-any" $ choiceP $ map terminal ["[^]", "\\P{}", "[^\\P{}]"] atomG rex = rule "atom" $ choiceP diff --git a/test/spec/Main.hs b/test/spec/Main.hs index a121beb..d39ed90 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -18,12 +18,12 @@ expectedRegexGrammar = Bnf { startBnf = fromString "\\q{regex}" , rulesBnf = fromList $ map (second' fromString) [ ("alternate","\\q{sequence}(\\|\\q{sequence})*") - , ("any-token","\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") , ("atom","(\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{char-class}|\\(\\q{regex}\\)") , ("category","Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn") , ("category-test","(\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}") , ("char","[^\\$\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") - , ("char-class","\\q{fail}|\\q{any-token}|\\[\\q{char}+\\]|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}") + , ("char-any","\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") + , ("char-class","\\q{fail}|\\q{char-any}|\\[\\q{char}+\\]|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}") , ("char-control","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") , ("char-escaped","[\\$\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control}") , ("expression","\\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}") From 23ff17971cdc8a16ef7cf362cecb3478f147e95b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 12:21:45 -0800 Subject: [PATCH 188/282] Update Main.hs --- test/spec/Main.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/spec/Main.hs b/test/spec/Main.hs index d39ed90..163a5c8 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -33,7 +33,6 @@ expectedRegexGrammar = Bnf ] } - regexExamples :: [(RegString, String)] regexExamples = [ (terminal "abc123etc.", "abc123etc.") From 9be609fdcfff9db9fb6bb6c2946605bb3bdfaf46 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 13:07:55 -0800 Subject: [PATCH 189/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 103 +++++++++++++++++------------------- 1 file changed, 50 insertions(+), 53 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 3619e03..8cf84f1 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -2,11 +2,11 @@ module Control.Lens.Grammar ( RegGrammar , Grammar , CtxGrammar + , Regular , RegString (..) - , RegBnfString (..) + , RegBnf (..) , regexGrammar - , ebnfGrammar - , Tokenizor + , regBnfGrammar ) where import Control.Applicative @@ -30,36 +30,53 @@ import GHC.Exts import Prelude hiding (filter) import Witherable -makeNestedPrisms ''Bnf -makeNestedPrisms ''RegEx -makeNestedPrisms ''RegExam -makeNestedPrisms ''CategoryTest -makeNestedPrisms ''GeneralCategory - -type RegGrammar token a = forall p. - ( Tokenizor token p - , Alternator p - ) => p a a +type RegGrammar token a = forall p. Regular token p => p a a type Grammar token a = forall p. - ( Tokenizor token p + ( Regular token p , forall x. BackusNaurForm (p x x) - , Alternator p ) => p a a type CtxGrammar token a = forall p. - ( Tokenizor token p + ( Regular token p , forall x. BackusNaurForm (p x x) , Monadic p - , Alternator p , Filtrator p ) => p a a - -type Tokenizor token p = +type Regular token p = ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) , forall x y. (x ~ token, y ~ token) => TokenAlgebra token (p x y) + , Alternator p ) :: Constraint -regexGrammar :: Grammar Char (RegEx Char) -regexGrammar = ruleRec "regex" altG +newtype RegString = RegString {runRegString :: RegEx Char} + deriving newtype + ( Eq, Ord + , Semigroup, Monoid, KleeneStarAlgebra + , Tokenized Char, TokenAlgebra Char + , TerminalSymbol Char, NonTerminalSymbol + , Matching String + ) + +newtype RegBnf = RegBnf {runRegBnf :: Bnf RegString} + deriving newtype + ( Eq, Ord + , Semigroup, Monoid, KleeneStarAlgebra + , Tokenized Char, TokenAlgebra Char + , TerminalSymbol Char, NonTerminalSymbol + , BackusNaurForm + ) +instance Matching String RegBnf where + word =~ pattern = word =~ liftBnf1 runRegString (runRegBnf pattern) + +makeNestedPrisms ''Bnf +makeNestedPrisms ''RegEx +makeNestedPrisms ''RegExam +makeNestedPrisms ''CategoryTest +makeNestedPrisms ''GeneralCategory +makeNestedPrisms ''RegString +makeNestedPrisms ''RegBnf + +regexGrammar :: Grammar Char RegString +regexGrammar = _RegString >~ ruleRec "regex" altG where altG rex = rule "alternate" $ chain1 Left (_RegExam . _Alternate) (sepBy (terminal "|")) (seqG rex) @@ -147,7 +164,7 @@ charG = rule "char" $ charEscapedG = rule "char-escaped" $ oneOf charsReserved <|> charControlG - charsReserved = "$()*+?[\\]^{|}" + charsReserved = "()*+?[\\]^{|}" charControlG = rule "char-control" $ choiceP [ terminal abbreviation >* pure charControl @@ -174,32 +191,14 @@ charG = rule "char" $ , ("ST", '\x9C'), ("OSC", '\x9D'), ("PM", '\x9E'), ("APC", '\x9F') ] -ebnfGrammar :: Grammar Char (Bnf (RegEx Char)) -ebnfGrammar = rule "ebnf" $ _Bnf >~ +regBnfGrammar :: Grammar Char RegBnf +regBnfGrammar = rule "reg-bnf" $ _RegBnf . _Bnf >~ terminal "{start} = " >* regexGrammar >*< several noSep (terminal "\n" >* ruleG) where ruleG = rule "rule" $ terminal "{" >* manyP charG *< terminal "} = " >*< regexGrammar -newtype RegString = RegString {runRegString :: RegEx Char} - deriving newtype - ( Eq, Ord - , Semigroup, Monoid, KleeneStarAlgebra - , Tokenized Char, TokenAlgebra Char - , TerminalSymbol Char, NonTerminalSymbol - , Matching String - ) - -newtype RegBnfString = RegBnfString {runRegBnfString :: Bnf (RegEx Char)} - deriving newtype - ( Eq, Ord - , Semigroup, Monoid, KleeneStarAlgebra - , Tokenized Char, TokenAlgebra Char - , TerminalSymbol Char, NonTerminalSymbol - , BackusNaurForm, Matching String - ) - instance IsList RegString where type Item RegString = Char fromList @@ -208,35 +207,33 @@ instance IsList RegString where . mapMaybe prsF . parseP regexGrammar where - prsF (rex,"") = Just (RegString rex) + prsF (rex,"") = Just rex prsF _ = Nothing toList = maybe "[]" ($ "") . printP regexGrammar - . runRegString instance IsString RegString where fromString = fromList instance Show RegString where showsPrec precision = showsPrec precision . toList instance Read RegString where readsPrec _ str = [(fromList str, "")] -instance IsList RegBnfString where - type Item RegBnfString = Char +instance IsList RegBnf where + type Item RegBnf = Char fromList = fromMaybe zeroK . listToMaybe . mapMaybe prsF - . parseP ebnfGrammar + . parseP regBnfGrammar where - prsF (ebnf,"") = Just (RegBnfString ebnf) + prsF (regBnf,"") = Just regBnf prsF _ = Nothing toList = maybe "{start} = []" ($ "") - . printP ebnfGrammar - . runRegBnfString -instance IsString RegBnfString where + . printP regBnfGrammar +instance IsString RegBnf where fromString = fromList -instance Show RegBnfString where +instance Show RegBnf where showsPrec precision = showsPrec precision . toList -instance Read RegBnfString where +instance Read RegBnf where readsPrec _ str = [(fromList str, "")] From 1efbbcee50faedab4140a644b5a895a08ba43458 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 13:10:16 -0800 Subject: [PATCH 190/282] Revert "Update Grammar.hs" This reverts commit 9be609fdcfff9db9fb6bb6c2946605bb3bdfaf46. --- src/Control/Lens/Grammar.hs | 103 +++++++++++++++++++----------------- 1 file changed, 53 insertions(+), 50 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 8cf84f1..3619e03 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -2,11 +2,11 @@ module Control.Lens.Grammar ( RegGrammar , Grammar , CtxGrammar - , Regular , RegString (..) - , RegBnf (..) + , RegBnfString (..) , regexGrammar - , regBnfGrammar + , ebnfGrammar + , Tokenizor ) where import Control.Applicative @@ -30,53 +30,36 @@ import GHC.Exts import Prelude hiding (filter) import Witherable -type RegGrammar token a = forall p. Regular token p => p a a +makeNestedPrisms ''Bnf +makeNestedPrisms ''RegEx +makeNestedPrisms ''RegExam +makeNestedPrisms ''CategoryTest +makeNestedPrisms ''GeneralCategory + +type RegGrammar token a = forall p. + ( Tokenizor token p + , Alternator p + ) => p a a type Grammar token a = forall p. - ( Regular token p + ( Tokenizor token p , forall x. BackusNaurForm (p x x) + , Alternator p ) => p a a type CtxGrammar token a = forall p. - ( Regular token p + ( Tokenizor token p , forall x. BackusNaurForm (p x x) , Monadic p + , Alternator p , Filtrator p ) => p a a -type Regular token p = + +type Tokenizor token p = ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) , forall x y. (x ~ token, y ~ token) => TokenAlgebra token (p x y) - , Alternator p ) :: Constraint -newtype RegString = RegString {runRegString :: RegEx Char} - deriving newtype - ( Eq, Ord - , Semigroup, Monoid, KleeneStarAlgebra - , Tokenized Char, TokenAlgebra Char - , TerminalSymbol Char, NonTerminalSymbol - , Matching String - ) - -newtype RegBnf = RegBnf {runRegBnf :: Bnf RegString} - deriving newtype - ( Eq, Ord - , Semigroup, Monoid, KleeneStarAlgebra - , Tokenized Char, TokenAlgebra Char - , TerminalSymbol Char, NonTerminalSymbol - , BackusNaurForm - ) -instance Matching String RegBnf where - word =~ pattern = word =~ liftBnf1 runRegString (runRegBnf pattern) - -makeNestedPrisms ''Bnf -makeNestedPrisms ''RegEx -makeNestedPrisms ''RegExam -makeNestedPrisms ''CategoryTest -makeNestedPrisms ''GeneralCategory -makeNestedPrisms ''RegString -makeNestedPrisms ''RegBnf - -regexGrammar :: Grammar Char RegString -regexGrammar = _RegString >~ ruleRec "regex" altG +regexGrammar :: Grammar Char (RegEx Char) +regexGrammar = ruleRec "regex" altG where altG rex = rule "alternate" $ chain1 Left (_RegExam . _Alternate) (sepBy (terminal "|")) (seqG rex) @@ -164,7 +147,7 @@ charG = rule "char" $ charEscapedG = rule "char-escaped" $ oneOf charsReserved <|> charControlG - charsReserved = "()*+?[\\]^{|}" + charsReserved = "$()*+?[\\]^{|}" charControlG = rule "char-control" $ choiceP [ terminal abbreviation >* pure charControl @@ -191,14 +174,32 @@ charG = rule "char" $ , ("ST", '\x9C'), ("OSC", '\x9D'), ("PM", '\x9E'), ("APC", '\x9F') ] -regBnfGrammar :: Grammar Char RegBnf -regBnfGrammar = rule "reg-bnf" $ _RegBnf . _Bnf >~ +ebnfGrammar :: Grammar Char (Bnf (RegEx Char)) +ebnfGrammar = rule "ebnf" $ _Bnf >~ terminal "{start} = " >* regexGrammar >*< several noSep (terminal "\n" >* ruleG) where ruleG = rule "rule" $ terminal "{" >* manyP charG *< terminal "} = " >*< regexGrammar +newtype RegString = RegString {runRegString :: RegEx Char} + deriving newtype + ( Eq, Ord + , Semigroup, Monoid, KleeneStarAlgebra + , Tokenized Char, TokenAlgebra Char + , TerminalSymbol Char, NonTerminalSymbol + , Matching String + ) + +newtype RegBnfString = RegBnfString {runRegBnfString :: Bnf (RegEx Char)} + deriving newtype + ( Eq, Ord + , Semigroup, Monoid, KleeneStarAlgebra + , Tokenized Char, TokenAlgebra Char + , TerminalSymbol Char, NonTerminalSymbol + , BackusNaurForm, Matching String + ) + instance IsList RegString where type Item RegString = Char fromList @@ -207,33 +208,35 @@ instance IsList RegString where . mapMaybe prsF . parseP regexGrammar where - prsF (rex,"") = Just rex + prsF (rex,"") = Just (RegString rex) prsF _ = Nothing toList = maybe "[]" ($ "") . printP regexGrammar + . runRegString instance IsString RegString where fromString = fromList instance Show RegString where showsPrec precision = showsPrec precision . toList instance Read RegString where readsPrec _ str = [(fromList str, "")] -instance IsList RegBnf where - type Item RegBnf = Char +instance IsList RegBnfString where + type Item RegBnfString = Char fromList = fromMaybe zeroK . listToMaybe . mapMaybe prsF - . parseP regBnfGrammar + . parseP ebnfGrammar where - prsF (regBnf,"") = Just regBnf + prsF (ebnf,"") = Just (RegBnfString ebnf) prsF _ = Nothing toList = maybe "{start} = []" ($ "") - . printP regBnfGrammar -instance IsString RegBnf where + . printP ebnfGrammar + . runRegBnfString +instance IsString RegBnfString where fromString = fromList -instance Show RegBnf where +instance Show RegBnfString where showsPrec precision = showsPrec precision . toList -instance Read RegBnf where +instance Read RegBnfString where readsPrec _ str = [(fromList str, "")] From 972c7bd9e3fb8eeb6943add648d95eff45fabafe Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 13:11:07 -0800 Subject: [PATCH 191/282] Reapply "Update Grammar.hs" This reverts commit 1efbbcee50faedab4140a644b5a895a08ba43458. --- src/Control/Lens/Grammar.hs | 103 +++++++++++++++++------------------- 1 file changed, 50 insertions(+), 53 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 3619e03..8cf84f1 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -2,11 +2,11 @@ module Control.Lens.Grammar ( RegGrammar , Grammar , CtxGrammar + , Regular , RegString (..) - , RegBnfString (..) + , RegBnf (..) , regexGrammar - , ebnfGrammar - , Tokenizor + , regBnfGrammar ) where import Control.Applicative @@ -30,36 +30,53 @@ import GHC.Exts import Prelude hiding (filter) import Witherable -makeNestedPrisms ''Bnf -makeNestedPrisms ''RegEx -makeNestedPrisms ''RegExam -makeNestedPrisms ''CategoryTest -makeNestedPrisms ''GeneralCategory - -type RegGrammar token a = forall p. - ( Tokenizor token p - , Alternator p - ) => p a a +type RegGrammar token a = forall p. Regular token p => p a a type Grammar token a = forall p. - ( Tokenizor token p + ( Regular token p , forall x. BackusNaurForm (p x x) - , Alternator p ) => p a a type CtxGrammar token a = forall p. - ( Tokenizor token p + ( Regular token p , forall x. BackusNaurForm (p x x) , Monadic p - , Alternator p , Filtrator p ) => p a a - -type Tokenizor token p = +type Regular token p = ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) , forall x y. (x ~ token, y ~ token) => TokenAlgebra token (p x y) + , Alternator p ) :: Constraint -regexGrammar :: Grammar Char (RegEx Char) -regexGrammar = ruleRec "regex" altG +newtype RegString = RegString {runRegString :: RegEx Char} + deriving newtype + ( Eq, Ord + , Semigroup, Monoid, KleeneStarAlgebra + , Tokenized Char, TokenAlgebra Char + , TerminalSymbol Char, NonTerminalSymbol + , Matching String + ) + +newtype RegBnf = RegBnf {runRegBnf :: Bnf RegString} + deriving newtype + ( Eq, Ord + , Semigroup, Monoid, KleeneStarAlgebra + , Tokenized Char, TokenAlgebra Char + , TerminalSymbol Char, NonTerminalSymbol + , BackusNaurForm + ) +instance Matching String RegBnf where + word =~ pattern = word =~ liftBnf1 runRegString (runRegBnf pattern) + +makeNestedPrisms ''Bnf +makeNestedPrisms ''RegEx +makeNestedPrisms ''RegExam +makeNestedPrisms ''CategoryTest +makeNestedPrisms ''GeneralCategory +makeNestedPrisms ''RegString +makeNestedPrisms ''RegBnf + +regexGrammar :: Grammar Char RegString +regexGrammar = _RegString >~ ruleRec "regex" altG where altG rex = rule "alternate" $ chain1 Left (_RegExam . _Alternate) (sepBy (terminal "|")) (seqG rex) @@ -147,7 +164,7 @@ charG = rule "char" $ charEscapedG = rule "char-escaped" $ oneOf charsReserved <|> charControlG - charsReserved = "$()*+?[\\]^{|}" + charsReserved = "()*+?[\\]^{|}" charControlG = rule "char-control" $ choiceP [ terminal abbreviation >* pure charControl @@ -174,32 +191,14 @@ charG = rule "char" $ , ("ST", '\x9C'), ("OSC", '\x9D'), ("PM", '\x9E'), ("APC", '\x9F') ] -ebnfGrammar :: Grammar Char (Bnf (RegEx Char)) -ebnfGrammar = rule "ebnf" $ _Bnf >~ +regBnfGrammar :: Grammar Char RegBnf +regBnfGrammar = rule "reg-bnf" $ _RegBnf . _Bnf >~ terminal "{start} = " >* regexGrammar >*< several noSep (terminal "\n" >* ruleG) where ruleG = rule "rule" $ terminal "{" >* manyP charG *< terminal "} = " >*< regexGrammar -newtype RegString = RegString {runRegString :: RegEx Char} - deriving newtype - ( Eq, Ord - , Semigroup, Monoid, KleeneStarAlgebra - , Tokenized Char, TokenAlgebra Char - , TerminalSymbol Char, NonTerminalSymbol - , Matching String - ) - -newtype RegBnfString = RegBnfString {runRegBnfString :: Bnf (RegEx Char)} - deriving newtype - ( Eq, Ord - , Semigroup, Monoid, KleeneStarAlgebra - , Tokenized Char, TokenAlgebra Char - , TerminalSymbol Char, NonTerminalSymbol - , BackusNaurForm, Matching String - ) - instance IsList RegString where type Item RegString = Char fromList @@ -208,35 +207,33 @@ instance IsList RegString where . mapMaybe prsF . parseP regexGrammar where - prsF (rex,"") = Just (RegString rex) + prsF (rex,"") = Just rex prsF _ = Nothing toList = maybe "[]" ($ "") . printP regexGrammar - . runRegString instance IsString RegString where fromString = fromList instance Show RegString where showsPrec precision = showsPrec precision . toList instance Read RegString where readsPrec _ str = [(fromList str, "")] -instance IsList RegBnfString where - type Item RegBnfString = Char +instance IsList RegBnf where + type Item RegBnf = Char fromList = fromMaybe zeroK . listToMaybe . mapMaybe prsF - . parseP ebnfGrammar + . parseP regBnfGrammar where - prsF (ebnf,"") = Just (RegBnfString ebnf) + prsF (regBnf,"") = Just regBnf prsF _ = Nothing toList = maybe "{start} = []" ($ "") - . printP ebnfGrammar - . runRegBnfString -instance IsString RegBnfString where + . printP regBnfGrammar +instance IsString RegBnf where fromString = fromList -instance Show RegBnfString where +instance Show RegBnf where showsPrec precision = showsPrec precision . toList -instance Read RegBnfString where +instance Read RegBnf where readsPrec _ str = [(fromList str, "")] From 1e8ffb325e07404ebd06486b3edf3e07def3ac66 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 13:12:32 -0800 Subject: [PATCH 192/282] Update Main.hs --- test/spec/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/spec/Main.hs b/test/spec/Main.hs index 163a5c8..f9af1b9 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -21,11 +21,11 @@ expectedRegexGrammar = Bnf , ("atom","(\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{char-class}|\\(\\q{regex}\\)") , ("category","Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn") , ("category-test","(\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}") - , ("char","[^\\$\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") + , ("char","[^\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") , ("char-any","\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") , ("char-class","\\q{fail}|\\q{char-any}|\\[\\q{char}+\\]|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}") , ("char-control","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") - , ("char-escaped","[\\$\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control}") + , ("char-escaped","[\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control}") , ("expression","\\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}") , ("fail","\\[\\]") , ("regex","\\q{alternate}") From 838dc1273b356aa85d30a5c8ed055fe435b9e46e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 13:12:56 -0800 Subject: [PATCH 193/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 8cf84f1..e5b52f5 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -6,7 +6,7 @@ module Control.Lens.Grammar , RegString (..) , RegBnf (..) , regexGrammar - , regBnfGrammar + , regbnfGrammar ) where import Control.Applicative @@ -191,8 +191,8 @@ charG = rule "char" $ , ("ST", '\x9C'), ("OSC", '\x9D'), ("PM", '\x9E'), ("APC", '\x9F') ] -regBnfGrammar :: Grammar Char RegBnf -regBnfGrammar = rule "reg-bnf" $ _RegBnf . _Bnf >~ +regbnfGrammar :: Grammar Char RegBnf +regbnfGrammar = rule "reg-bnf" $ _RegBnf . _Bnf >~ terminal "{start} = " >* regexGrammar >*< several noSep (terminal "\n" >* ruleG) where @@ -224,13 +224,13 @@ instance IsList RegBnf where = fromMaybe zeroK . listToMaybe . mapMaybe prsF - . parseP regBnfGrammar + . parseP regbnfGrammar where - prsF (regBnf,"") = Just regBnf + prsF (regbnf,"") = Just regbnf prsF _ = Nothing toList = maybe "{start} = []" ($ "") - . printP regBnfGrammar + . printP regbnfGrammar instance IsString RegBnf where fromString = fromList instance Show RegBnf where From 9fa52fce42c69127012ffe3f0086c857a9260cdc Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 13:40:44 -0800 Subject: [PATCH 194/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index b5a7bd0..4ea0745 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -103,7 +103,11 @@ and produces the given token while printing. oneLike :: forall token p. (Profunctor p, Tokenized token (p token token)) => token -> p () () -oneLike a = dimap (const a) (\(_::token) -> ()) (asIn (categorize a)) +oneLike a = dimap preF postF catA + where + preF _ = a + postF (_:: token) = () + catA = asIn (categorize a) {- | `manyLike` consumes zero or more tokens @@ -113,8 +117,11 @@ and produces no tokens printing. manyLike :: forall token p. (Distributor p, Tokenized token (p token token)) => token -> p () () -manyLike a = dimap (\_ -> []::[token]) (\(_::[token]) -> ()) - (manyP (asIn (categorize a))) +manyLike a = dimap preF postF (manyP catA) + where + preF _ = []::[token] + postF (_::[token]) = () + catA = asIn (categorize a) {- | `optLike` consumes zero or more tokens @@ -124,8 +131,11 @@ and produces the given token while printing. optLike :: forall token p. (Distributor p, Tokenized token (p token token)) => token -> p () () -optLike a = dimap (\_ -> [a]::[token]) (\(_::[token]) -> ()) - (manyP (asIn (categorize a))) +optLike a = dimap preF postF (manyP catA) + where + preF _ = [a]::[token] + postF (_::[token]) = () + catA = asIn (categorize a) {- | `someLike` consumes one or more tokens @@ -135,5 +145,8 @@ and produces the given token while printing. someLike :: forall token p. (Distributor p, Tokenized token (p token token)) => token -> p () () -someLike a = dimap (const (a, [] :: [token])) (\(_::token, _::[token]) -> ()) - (asIn (categorize a) >*< manyP (asIn (categorize a))) +someLike a = dimap preF postF (catA >*< manyP catA) + where + preF _ = (a, []::[token]) + postF (_::token, _::[token]) = () + catA = asIn (categorize a) From d26b1486e4269caa6f451a2b3c43bfdc10b8a16d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 15:40:54 -0800 Subject: [PATCH 195/282] Update PartialIso.hs --- src/Control/Lens/PartialIso.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index fbda406..d083f8b 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -283,7 +283,7 @@ iterating pattern = withPartialIso pattern $ \f g -> iso (iter f) (iter g) where iter h state = maybe state (iter h) (h state) -{- | Left fold & unfold `PartialIso` to an `Control.Lens.Iso.Iso`. -} +{- | Left fold & unfold `APartialIso` to an `Control.Lens.Iso.Iso`. -} difoldl1 :: Cons s t a b => APartialIso d c (d,b) (c,a) @@ -315,22 +315,22 @@ difoldr1 pattern = . crossPartialIso id (coPartialIso pattern) in from (iterating step) -{- | Left fold & unfold `PartialIso` to a `PartialIso`. -} +{- | Left fold & unfold `APartialIso` to a `Prism`. -} difoldl :: (AsEmpty t, Cons s t a b) => APartialIso d c (d,b) (c,a) -> Prism d c (d,t) (c,s) difoldl pattern - = dimap (, Empty) (fmap fst) + = dimap (,Empty) (fmap fst) . difoldl1 pattern -{- | Right fold & unfold `APartialIso` to a `PartialIso`. -} +{- | Right fold & unfold `APartialIso` to a `Prism`. -} difoldr :: (AsEmpty t, Cons s t a b) => APartialIso d c (b,d) (a,c) -> Prism d c (t,d) (s,c) difoldr pattern - = dimap (Empty, ) (fmap snd) + = dimap (Empty,) (fmap snd) . difoldr1 pattern -- Orphanage -- From 44bbdbb3efc79506ed822a29889c3d454eeab46f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 16:10:56 -0800 Subject: [PATCH 196/282] docs --- src/Control/Lens/Bifocal.hs | 2 +- src/Control/Lens/Diopter.hs | 2 +- src/Control/Lens/Grammar.hs | 16 +++++++++++++++- src/Control/Lens/Grammar/BackusNaur.hs | 21 ++++++++++++++++++--- src/Control/Lens/Grammar/Boole.hs | 12 ++++++++++++ src/Control/Lens/Grammar/Kleene.hs | 12 ++++++++++++ src/Control/Lens/Grammar/Symbol.hs | 22 ++++++++++++++++++++++ src/Control/Lens/Grammar/Token.hs | 10 ++++++++++ src/Control/Lens/Grate.hs | 2 +- src/Control/Lens/Internal/NestedPrismTH.hs | 2 +- src/Control/Lens/Monocle.hs | 2 +- src/Control/Lens/PartialIso.hs | 2 +- src/Control/Lens/Wither.hs | 2 +- src/Data/Profunctor/Distributor.hs | 2 +- src/Data/Profunctor/Filtrator.hs | 2 +- src/Data/Profunctor/Grammar.hs | 2 +- src/Data/Profunctor/Monadic.hs | 2 +- src/Data/Profunctor/Monoidal.hs | 2 +- 18 files changed, 101 insertions(+), 16 deletions(-) diff --git a/src/Control/Lens/Bifocal.hs b/src/Control/Lens/Bifocal.hs index a7a6845..6a09aaf 100644 --- a/src/Control/Lens/Bifocal.hs +++ b/src/Control/Lens/Bifocal.hs @@ -1,7 +1,7 @@ {- | Module : Control.Lens.Bifocal Description : bifocals -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Control/Lens/Diopter.hs b/src/Control/Lens/Diopter.hs index 0403c52..c78b06c 100644 --- a/src/Control/Lens/Diopter.hs +++ b/src/Control/Lens/Diopter.hs @@ -1,7 +1,7 @@ {- | Module : Control.Lens.Diopter Description : diopters -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index e5b52f5..6e78930 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -1,5 +1,19 @@ +{- | +Module : Control.Lens.Grammar +Description : grammar hierarchy +Copyright : (C) 2026 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable + +See Chomsky, [Three Models for the Description of Language] +(https://chomsky.info/wp-content/uploads/195609-.pdf) +-} + module Control.Lens.Grammar - ( RegGrammar + ( -- * Grammar + RegGrammar , Grammar , CtxGrammar , Regular diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index e7b7a27..08dc74f 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -1,11 +1,26 @@ +{- | +Module : Control.Lens.Grammar.BackusNaur +Description : Backus-Naur forms & pattern matching +Copyright : (C) 2026 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable + +See Breitner, [Showcasing Applicative] +(https://www.joachim-breitner.de/blog/710-Showcasing_Applicative) +-} + module Control.Lens.Grammar.BackusNaur - ( BackusNaurForm (..) + ( -- * Backus-Naur form + BackusNaurForm (..) , Bnf (..) - , Matching (..) - , diffB , liftBnf0 , liftBnf1 , liftBnf2 + -- * Pattern matching + , Matching (..) + , diffB ) where import Control.Lens diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index 5be02b0..41c90af 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -1,3 +1,15 @@ +{- | +Module : Control.Lens.Grammar.Boole +Description : Boolean algebras & token classes +Copyright : (C) 2026 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable + +Token classes form a Boolean algebra +-} + module Control.Lens.Grammar.Boole ( BooleanAlgebra (..) , andB, orB, allB, anyB diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 568618e..2ca1188 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -1,3 +1,15 @@ +{- | +Module : Control.Lens.Grammar.Kleene +Description : Kleene (star) algebras & regular expressions +Copyright : (C) 2026 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable + +Kleene (star) algebras form the basis of regular expressions +-} + module Control.Lens.Grammar.Kleene ( KleeneStarAlgebra (..) , orK, anyK diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index d8f8cbf..fde89e3 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -1,3 +1,13 @@ +{- | +Module : Control.Lens.Grammar.Symbol +Description : terminal & nonterminal symbols +Copyright : (C) 2026 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + module Control.Lens.Grammar.Symbol ( TerminalSymbol (..) , NonTerminalSymbol (..) @@ -6,6 +16,10 @@ module Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Data.Profunctor import Data.Profunctor.Monoidal +import qualified Data.Sequence as Seq +import qualified Data.Vector as Vec +import qualified Data.Text as Strict +import qualified Data.Text.Lazy as Lazy class TerminalSymbol token s where terminal :: [token] -> s @@ -16,6 +30,14 @@ class TerminalSymbol token s where instance TerminalSymbol a [a] where terminal = id +instance TerminalSymbol a (Vec.Vector a) where + terminal = Vec.fromList +instance TerminalSymbol a (Seq.Seq a) where + terminal = Seq.fromList +instance TerminalSymbol Char Lazy.Text where + terminal = Lazy.pack +instance TerminalSymbol Char Strict.Text where + terminal = Strict.pack class NonTerminalSymbol s where nonTerminal :: String -> s diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 4ea0745..11f1642 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -1,3 +1,13 @@ +{- | +Module : Control.Lens.Grammar.Token +Description : lexical tokens +Copyright : (C) 2026 - Eitan Chatav +License : BSD-style (see the file LICENSE) +Maintainer : Eitan Chatav +Stability : provisional +Portability : non-portable +-} + module Control.Lens.Grammar.Token ( -- * Tokenized Tokenized (..) diff --git a/src/Control/Lens/Grate.hs b/src/Control/Lens/Grate.hs index 832f5ec..9db64ae 100644 --- a/src/Control/Lens/Grate.hs +++ b/src/Control/Lens/Grate.hs @@ -1,7 +1,7 @@ {- | Module : Control.Lens.Grate Description : grates -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Control/Lens/Internal/NestedPrismTH.hs b/src/Control/Lens/Internal/NestedPrismTH.hs index 169787c..4a2de3e 100644 --- a/src/Control/Lens/Internal/NestedPrismTH.hs +++ b/src/Control/Lens/Internal/NestedPrismTH.hs @@ -1,7 +1,7 @@ {- | Module : Control.Lens.Internal.NestedPrismTH Description : nested pair prisms -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Control/Lens/Monocle.hs b/src/Control/Lens/Monocle.hs index 892ec43..c2d055e 100644 --- a/src/Control/Lens/Monocle.hs +++ b/src/Control/Lens/Monocle.hs @@ -1,7 +1,7 @@ {- | Module : Control.Lens.Monocle Description : monocles -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index d083f8b..976b692 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -1,7 +1,7 @@ {- | Module : Control.Lens.PartialIso Description : partial isomorphisms -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Control/Lens/Wither.hs b/src/Control/Lens/Wither.hs index b58a559..72dd0be 100644 --- a/src/Control/Lens/Wither.hs +++ b/src/Control/Lens/Wither.hs @@ -1,7 +1,7 @@ {- | Module : Control.Lens.Wither Description : withers -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index c45f63e..e69b0a2 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -1,7 +1,7 @@ {-| Module : Data.Profunctor.Distributor Description : distributors -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Data/Profunctor/Filtrator.hs b/src/Data/Profunctor/Filtrator.hs index 9a88776..fba141a 100644 --- a/src/Data/Profunctor/Filtrator.hs +++ b/src/Data/Profunctor/Filtrator.hs @@ -1,7 +1,7 @@ {-| Module : Data.Profunctor.Filtrator Description : filtrators -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index f5381a7..dfee09e 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -1,7 +1,7 @@ {-| Module : Data.Profunctor.Grammar Description : grammar distributors -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index af399d2..8db7e26 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -1,7 +1,7 @@ {-| Module : Data.Profunctor.Monadic Description : monadic profunctors -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index 26fc9cf..4a6135f 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -3,7 +3,7 @@ {-| Module : Data.Profunctor.Monoidal Description : monoidal profunctors -Copyright : (C) 2025 - Eitan Chatav +Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional From 2c2d30671e1e61f8468ff234b92d49a2fbff1bd2 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 16:38:29 -0800 Subject: [PATCH 197/282] tokens & terminal --- src/Control/Lens/Grammar/Symbol.hs | 21 ++++----------------- src/Control/Lens/Grammar/Token.hs | 14 +++----------- src/Data/Profunctor/Grammar.hs | 4 ++-- 3 files changed, 9 insertions(+), 30 deletions(-) diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index fde89e3..6aa5c75 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -13,31 +13,18 @@ module Control.Lens.Grammar.Symbol , NonTerminalSymbol (..) ) where +import Control.Lens +import Control.Lens.PartialIso import Control.Lens.Grammar.Token import Data.Profunctor import Data.Profunctor.Monoidal -import qualified Data.Sequence as Seq -import qualified Data.Vector as Vec -import qualified Data.Text as Strict -import qualified Data.Text.Lazy as Lazy -class TerminalSymbol token s where +class TerminalSymbol token s | s -> token where terminal :: [token] -> s default terminal :: (p () () ~ s, Tokenized token (p token token), Monoidal p, Cochoice p) => [token] -> s - terminal = terminator - -instance TerminalSymbol a [a] where - terminal = id -instance TerminalSymbol a (Vec.Vector a) where - terminal = Vec.fromList -instance TerminalSymbol a (Seq.Seq a) where - terminal = Seq.fromList -instance TerminalSymbol Char Lazy.Text where - terminal = Lazy.pack -instance TerminalSymbol Char Strict.Text where - terminal = Strict.pack + terminal = foldr (\a p -> only a ?< anyToken *> p) oneP class NonTerminalSymbol s where nonTerminal :: String -> s diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 11f1642..d56c390 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -12,8 +12,7 @@ module Control.Lens.Grammar.Token ( -- * Tokenized Tokenized (..) , satisfy - , fromTokens - , terminator + , tokens -- * Like , oneLike , manyLike @@ -90,20 +89,13 @@ satisfy => (a -> Bool) -> p a a satisfy f = satisfied f >?< anyToken -fromTokens +tokens :: ( Foldable f, Tokenized a (p a a) , Monoidal p, Choice p , AsEmpty s, Cons s s a a ) => f a -> p s s -fromTokens = foldr ((>:<) . token) asEmpty - -terminator - :: ( Foldable f, Tokenized a (p a a) - , Monoidal p, Cochoice p - ) - => f a -> p () () -terminator = foldr (\a p -> only a ?< anyToken *> p) oneP +tokens = foldr ((>:<) . token) asEmpty {- | `oneLike` consumes one token diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index dfee09e..47562fa 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -157,7 +157,7 @@ instance , Cons s s Char Char, Snoc s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m ) => IsString (Parsor s m s s) where - fromString = fromTokens + fromString = tokens instance BackusNaurForm (Parsor s m a b) instance (Alternative m, Monad m) => MonadFail (Parsor s m a) where fail _ = empty @@ -259,7 +259,7 @@ instance ( Char ~ Item s, IsList s, Cons s s Char Char, AsEmpty s , Filterable m, Alternative m, Monad m ) => IsString (Printor s m s s) where - fromString = fromTokens + fromString = tokens instance BackusNaurForm (Printor s m a b) instance (Alternative m, Monad m) => MonadFail (Printor s m a) where fail _ = empty From c762fd02f3231496f9b10e993a5e463bc6645099 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 16:49:26 -0800 Subject: [PATCH 198/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 6e78930..a2eff19 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -206,7 +206,7 @@ charG = rule "char" $ ] regbnfGrammar :: Grammar Char RegBnf -regbnfGrammar = rule "reg-bnf" $ _RegBnf . _Bnf >~ +regbnfGrammar = rule "regbnf" $ _RegBnf . _Bnf >~ terminal "{start} = " >* regexGrammar >*< several noSep (terminal "\n" >* ruleG) where From 1e8696b2de5b4ffb52ac36b067982affbd1a7b42 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 17:30:49 -0800 Subject: [PATCH 199/282] docs --- src/Control/Lens/Grammar.hs | 19 ++++++++++------- src/Control/Lens/Grammar/Boole.hs | 34 ++++++++++++++++--------------- 2 files changed, 30 insertions(+), 23 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index a2eff19..504dac6 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -12,15 +12,20 @@ See Chomsky, [Three Models for the Description of Language] -} module Control.Lens.Grammar - ( -- * Grammar + ( -- * Regular grammar RegGrammar - , Grammar - , CtxGrammar - , Regular , RegString (..) - , RegBnf (..) + , TerminalSymbol (..) + , Tokenized (..) + , Regular , regexGrammar + -- * Context-free grammar + , Grammar + , RegBnf (..) + , BackusNaurForm (..) , regbnfGrammar + -- * Context-sensitive grammar + , CtxGrammar ) where import Control.Applicative @@ -56,9 +61,9 @@ type CtxGrammar token a = forall p. , Filtrator p ) => p a a type Regular token p = - ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) + ( Alternator p + , forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) , forall x y. (x ~ token, y ~ token) => TokenAlgebra token (p x y) - , Alternator p ) :: Constraint newtype RegString = RegString {runRegString :: RegEx Char} diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index 41c90af..6d7200e 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -11,10 +11,12 @@ Token classes form a Boolean algebra -} module Control.Lens.Grammar.Boole - ( BooleanAlgebra (..) - , andB, orB, allB, anyB + ( -- * token class + TokenAlgebra (..) , TokenTest (..) - , TokenAlgebra (..) + -- * Boolean algebra + , BooleanAlgebra (..) + , andB, orB, allB, anyB ) where import Control.Applicative @@ -30,25 +32,25 @@ import GHC.Generics class BooleanAlgebra b where - fromBool :: Bool -> b - default fromBool - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => Bool -> b - fromBool = pure . fromBool - - notB :: b -> b - default notB - :: (b ~ f bool, BooleanAlgebra bool, Functor f) => b -> b - notB = fmap notB + (>&&<) :: b -> b -> b + default (>&&<) + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b + (>&&<) = liftA2 (>&&<) (>||<) :: b -> b -> b default (>||<) :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b (>||<) = liftA2 (>||<) - (>&&<) :: b -> b -> b - default (>&&<) - :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b - (>&&<) = liftA2 (>&&<) + notB :: b -> b + default notB + :: (b ~ f bool, BooleanAlgebra bool, Functor f) => b -> b + notB = fmap notB + + fromBool :: Bool -> b + default fromBool + :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => Bool -> b + fromBool = pure . fromBool andB :: (Foldable f, BooleanAlgebra b) => f b -> b andB = foldl' (>&&<) (fromBool True) From 48ccdcc201e6b162a5ab9720facfc6697b54b34b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 18:49:19 -0800 Subject: [PATCH 200/282] Update Grammar.hs --- src/Data/Profunctor/Grammar.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 47562fa..bbeab0c 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -51,7 +51,7 @@ newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)} printP :: Functor f => Printor s f a b -> a -> f (s -> s) printP (Printor f) = fmap snd . f -newtype Grammor g a b = Grammor {runGrammor :: g} +newtype Grammor k a b = Grammor {runGrammor :: k} -- Parsor instances deriving stock instance Functor f => Functor (Parsor s f a) @@ -265,41 +265,41 @@ instance (Alternative m, Monad m) => MonadFail (Printor s m a) where fail _ = empty -- Grammor instances -instance Functor (Grammor g a) where fmap _ = coerce -instance Contravariant (Grammor g a) where contramap _ = coerce -instance Profunctor (Grammor g) where dimap _ _ = coerce -instance Bifunctor (Grammor g) where bimap _ _ = coerce -instance Choice (Grammor g) where +instance Functor (Grammor k a) where fmap _ = coerce +instance Contravariant (Grammor k a) where contramap _ = coerce +instance Profunctor (Grammor k) where dimap _ _ = coerce +instance Bifunctor (Grammor k) where bimap _ _ = coerce +instance Choice (Grammor k) where left' = coerce right' = coerce -instance Monoid g => Applicative (Grammor g a) where +instance Monoid k => Applicative (Grammor k a) where pure _ = Grammor mempty Grammor rex1 <*> Grammor rex2 = Grammor (rex1 <> rex2) -instance KleeneStarAlgebra g => Alternative (Grammor g a) where +instance KleeneStarAlgebra k => Alternative (Grammor k a) where empty = Grammor zeroK Grammor rex1 <|> Grammor rex2 = Grammor (rex1 >|< rex2) many (Grammor rex) = Grammor (starK rex) some (Grammor rex) = Grammor (plusK rex) -instance KleeneStarAlgebra g => Distributor (Grammor g) where +instance KleeneStarAlgebra k => Distributor (Grammor k) where zeroP = Grammor zeroK Grammor rex1 >+< Grammor rex2 = Grammor (rex1 >|< rex2) manyP (Grammor rex) = Grammor (starK rex) optionalP (Grammor rex) = Grammor (optK rex) -instance KleeneStarAlgebra g => Alternator (Grammor g) where +instance KleeneStarAlgebra k => Alternator (Grammor k) where alternate = either coerce coerce someP (Grammor rex) = Grammor (plusK rex) -instance Tokenized token g => Tokenized token (Grammor g a b) where +instance Tokenized token k => Tokenized token (Grammor k a b) where anyToken = Grammor anyToken token = Grammor . token oneOf = Grammor . oneOf notOneOf = Grammor . notOneOf asIn = Grammor . asIn notAsIn = Grammor . notAsIn -instance TokenAlgebra a g => TokenAlgebra a (Grammor g a b) where +instance TokenAlgebra a k => TokenAlgebra a (Grammor k a b) where tokenClass = Grammor . tokenClass -instance TerminalSymbol token g - => TerminalSymbol token (Grammor g a b) where +instance TerminalSymbol token k + => TerminalSymbol token (Grammor k a b) where terminal = Grammor . terminal -instance BackusNaurForm g => BackusNaurForm (Grammor g a b) where +instance BackusNaurForm k => BackusNaurForm (Grammor k a b) where rule name = Grammor . rule name . runGrammor ruleRec name = Grammor . ruleRec name . dimap Grammor runGrammor From b6ec2dd4d55ae697291933c5850024a804cc405a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 18:49:21 -0800 Subject: [PATCH 201/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 2ca1188..ef431a3 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -1,18 +1,20 @@ {- | Module : Control.Lens.Grammar.Kleene -Description : Kleene (star) algebras & regular expressions +Description : Kleene star algebras & regular expressions Copyright : (C) 2026 - Eitan Chatav License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional Portability : non-portable -Kleene (star) algebras form the basis of regular expressions +Regular expressions form a Kleene star algebra -} module Control.Lens.Grammar.Kleene - ( KleeneStarAlgebra (..) + ( -- * Kleene star algebras + KleeneStarAlgebra (..) , orK, anyK + -- * regular expressions , RegEx (..) , RegExam (..) , CategoryTest (..) From ad8a1560562fdeb4eda025242cbaa6ae461d420e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 18:50:57 -0800 Subject: [PATCH 202/282] Update Monadic.hs --- src/Data/Profunctor/Monadic.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 8db7e26..1199c48 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -6,6 +6,9 @@ License : BSD-style (see the file LICENSE) Maintainer : Eitan Chatav Stability : provisional Portability : non-portable + +See Li-yao Xia, [Monadic profunctors for bidirectional programming] +(https://blog.poisson.chat/posts/2017-01-01-monadic-profunctors.html) -} module Data.Profunctor.Monadic @@ -20,9 +23,6 @@ module Data.Profunctor.Monadic import Data.Profunctor import Prelude hiding ((>>=), (>>)) -{- | See Li-yao Xia, [Monadic profunctors for bidirectional programming] -(https://blog.poisson.chat/posts/2017-01-01-monadic-profunctors.html) --} type Monadic p = (Profunctor p, forall x. Monad (p x)) (>>=) :: Monadic p => p a b -> (b -> p c d) -> p (a,c) (b,d) From db16ee5f38f93c1065960bcaafef43876b366ab0 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 19:45:21 -0800 Subject: [PATCH 203/282] docs & one-of grammar --- src/Control/Lens/Grammar.hs | 4 +++- src/Control/Lens/Grammar/BackusNaur.hs | 4 ++-- src/Control/Lens/Grammar/Boole.hs | 4 ++-- src/Control/Lens/Grammar/Kleene.hs | 4 ++-- src/Control/Lens/Grammar/Symbol.hs | 3 ++- src/Control/Lens/Internal/NestedPrismTH.hs | 2 +- src/Data/Profunctor/Monadic.hs | 11 ++++++++++- test/spec/Main.hs | 4 ++-- 8 files changed, 24 insertions(+), 12 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 504dac6..0863de6 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -165,7 +165,7 @@ regexGrammar = _RegString >~ ruleRec "regex" altG classG = rule "char-class" $ choiceP [ _Fail >? failG , _Pass >? anyG - , _OneOf >? terminal "[" >* several1 noSep charG *< terminal "]" + , _OneOf >? oneOfG , _NotOneOf >? terminal "[^" >* several1 noSep charG >*< (catTestG <|> pure (NotAsIn Set.empty)) @@ -175,6 +175,8 @@ regexGrammar = _RegString >~ ruleRec "regex" altG failG = rule "fail" $ terminal "[]" + oneOfG = rule "one-of" $ terminal "[" >* several1 noSep charG *< terminal "]" + charG :: Grammar Char Char charG = rule "char" $ tokenClass (notOneOf charsReserved >&&< notAsIn Control) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 08dc74f..bbfe3a9 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -12,13 +12,13 @@ See Breitner, [Showcasing Applicative] -} module Control.Lens.Grammar.BackusNaur - ( -- * Backus-Naur form + ( -- * BackusNaurForm BackusNaurForm (..) , Bnf (..) , liftBnf0 , liftBnf1 , liftBnf2 - -- * Pattern matching + -- * Matching , Matching (..) , diffB ) where diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index 6d7200e..e8cd214 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -11,10 +11,10 @@ Token classes form a Boolean algebra -} module Control.Lens.Grammar.Boole - ( -- * token class + ( -- * TokenAlgebra TokenAlgebra (..) , TokenTest (..) - -- * Boolean algebra + -- * BooleanAlgebra , BooleanAlgebra (..) , andB, orB, allB, anyB ) where diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index ef431a3..37395d3 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -11,10 +11,10 @@ Regular expressions form a Kleene star algebra -} module Control.Lens.Grammar.Kleene - ( -- * Kleene star algebras + ( -- * KleeneStarAlgebra KleeneStarAlgebra (..) , orK, anyK - -- * regular expressions + -- * RegEx , RegEx (..) , RegExam (..) , CategoryTest (..) diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index 6aa5c75..1d09f79 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -9,7 +9,8 @@ Portability : non-portable -} module Control.Lens.Grammar.Symbol - ( TerminalSymbol (..) + ( -- * Symbol + TerminalSymbol (..) , NonTerminalSymbol (..) ) where diff --git a/src/Control/Lens/Internal/NestedPrismTH.hs b/src/Control/Lens/Internal/NestedPrismTH.hs index 4a2de3e..62f7b31 100644 --- a/src/Control/Lens/Internal/NestedPrismTH.hs +++ b/src/Control/Lens/Internal/NestedPrismTH.hs @@ -12,7 +12,7 @@ with small tweaks to support nested pairs. -} module Control.Lens.Internal.NestedPrismTH - ( -- * Nested Prisms + ( -- * Nested prisms makeNestedPrisms ) where diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 1199c48..7d69c0f 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -9,10 +9,15 @@ Portability : non-portable See Li-yao Xia, [Monadic profunctors for bidirectional programming] (https://blog.poisson.chat/posts/2017-01-01-monadic-profunctors.html) + +This module can provide qualified do-notation for `Monadic` profunctors. + +>>> :set -XQualifiedDo +>>> import qualified Data.Profunctor.Monadic as P -} module Data.Profunctor.Monadic - ( -- * + ( -- * Monadic Monadic , (>>=) , (>>) @@ -23,8 +28,11 @@ module Data.Profunctor.Monadic import Data.Profunctor import Prelude hiding ((>>=), (>>)) +{- | A `Profunctor` which is also a `Monad`. -} type Monadic p = (Profunctor p, forall x. Monad (p x)) +{- | The pair bonding operator `>>=` is a context-sensitive +version of `Data.Profunctor.Monoidal.>*<`. -} (>>=) :: Monadic p => p a b -> (b -> p c d) -> p (a,c) (b,d) infixl 1 >>= p >>= f = do @@ -32,6 +40,7 @@ p >>= f = do d <- lmap snd (f b) return (b,d) +{- | The unit bonding operator `>>`. -} (>>) :: Monadic p => p () c -> p a b -> p a b infixl 1 >> x >> y = do _ <- lmap (const ()) x; y diff --git a/test/spec/Main.hs b/test/spec/Main.hs index f9af1b9..a7a2125 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -7,7 +7,6 @@ import Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol -import Control.Lens.Grammar.Token import Data.Profunctor import Data.Profunctor.Grammar import GHC.Exts @@ -23,11 +22,12 @@ expectedRegexGrammar = Bnf , ("category-test","(\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}") , ("char","[^\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") , ("char-any","\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") - , ("char-class","\\q{fail}|\\q{char-any}|\\[\\q{char}+\\]|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}") + , ("char-class","\\q{fail}|\\q{char-any}|\\q{one-of}|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}") , ("char-control","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") , ("char-escaped","[\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control}") , ("expression","\\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}") , ("fail","\\[\\]") + , ("one-of","\\[\\q{char}+\\]") , ("regex","\\q{alternate}") , ("sequence","\\q{char}*|\\q{expression}*") ] From b8cea0405882213b8bd2937bda834b9e93d75b50 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 19:50:03 -0800 Subject: [PATCH 204/282] optionP --- src/Data/Profunctor/Distributor.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index e69b0a2..c41255b 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -14,6 +14,7 @@ module Data.Profunctor.Distributor -- * Alternator , Alternator (..) , choiceP + , optionP -- * Homogeneous , Homogeneous (..) -- * SepBy @@ -349,6 +350,9 @@ class (Choice p, Distributor p, forall x. Alternative (p x)) choiceP :: (Foldable f, Alternator p) => f (p a b) -> p a b choiceP = foldl' (<|>) empty +optionP :: Alternator p => a -> p a a -> p a a +optionP x p = p <|> pure x + instance (Alternator p, Applicative f) => Alternator (WrappedPafb f p) where alternate = From 9775d6be5f1a1dec8f17910b36d595391cde7ac1 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 19:58:44 -0800 Subject: [PATCH 205/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 0863de6..c8e2a7c 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -112,8 +112,7 @@ regexGrammar = _RegString >~ ruleRec "regex" altG , atomG rex ] - anyG = rule "char-any" $ choiceP $ map terminal - ["[^]", "\\P{}", "[^\\P{}]"] + anyG = rule "char-any" $ terminal "[^]" atomG rex = rule "atom" $ choiceP [ _NonTerminal >? terminal "\\q{" >* manyP charG *< terminal "}" @@ -124,9 +123,10 @@ regexGrammar = _RegString >~ ruleRec "regex" altG catTestG = rule "category-test" $ choiceP [ _AsIn >? terminal "\\p{" >* categoryG *< terminal "}" - , _NotAsIn >? terminal "\\P{" >* - several1 (sepBy (terminal "|")) categoryG - *< terminal "}" + , _NotAsIn >? several1 (sepBy (terminal "|")) + { beginBy = terminal "\\P{" + , endBy = terminal "}" + } categoryG ] categoryG = rule "category" $ choiceP @@ -168,7 +168,7 @@ regexGrammar = _RegString >~ ruleRec "regex" altG , _OneOf >? oneOfG , _NotOneOf >? terminal "[^" >* several1 noSep charG - >*< (catTestG <|> pure (NotAsIn Set.empty)) + >*< optionP (NotAsIn Set.empty) catTestG *< terminal "]" , _NotOneOf >? pure Set.empty >*< catTestG ] From 0f7a5ac53618e88f0646840999c561027eb02e1b Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 19:58:48 -0800 Subject: [PATCH 206/282] Update Main.hs --- test/spec/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/spec/Main.hs b/test/spec/Main.hs index a7a2125..df79782 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -21,7 +21,7 @@ expectedRegexGrammar = Bnf , ("category","Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn") , ("category-test","(\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}") , ("char","[^\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") - , ("char-any","\\[\\^\\]|\\\\P\\{\\}|\\[\\^\\\\P\\{\\}\\]") + , ("char-any","\\[\\^\\]") , ("char-class","\\q{fail}|\\q{char-any}|\\q{one-of}|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}") , ("char-control","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") , ("char-escaped","[\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control}") From 8e020dc445e1b464c420fcd2555678beb0f80b0a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 20:01:52 -0800 Subject: [PATCH 207/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index c8e2a7c..34d6052 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -112,8 +112,6 @@ regexGrammar = _RegString >~ ruleRec "regex" altG , atomG rex ] - anyG = rule "char-any" $ terminal "[^]" - atomG rex = rule "atom" $ choiceP [ _NonTerminal >? terminal "\\q{" >* manyP charG *< terminal "}" , _Terminal >? charG >:< asEmpty @@ -175,6 +173,8 @@ regexGrammar = _RegString >~ ruleRec "regex" altG failG = rule "fail" $ terminal "[]" + anyG = rule "char-any" $ terminal "[^]" + oneOfG = rule "one-of" $ terminal "[" >* several1 noSep charG *< terminal "]" charG :: Grammar Char Char From 4541bd75825e9629dea45a9a8229164b5bb20ea4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 20:08:52 -0800 Subject: [PATCH 208/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 34d6052..8b78a97 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -188,8 +188,8 @@ charG = rule "char" $ charsReserved = "()*+?[\\]^{|}" charControlG = rule "char-control" $ choiceP - [ terminal abbreviation >* pure charControl - | (abbreviation, charControl) <- charsControl + [ terminal abbrev >* pure charControl + | (abbrev, charControl) <- charsControl ] charsControl = From 5e228b0fa62619440ed51ef3bbc5136fdced346f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 20:13:33 -0800 Subject: [PATCH 209/282] Update Distributor.hs --- src/Data/Profunctor/Distributor.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index c41255b..c5f7ae6 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -350,8 +350,8 @@ class (Choice p, Distributor p, forall x. Alternative (p x)) choiceP :: (Foldable f, Alternator p) => f (p a b) -> p a b choiceP = foldl' (<|>) empty -optionP :: Alternator p => a -> p a a -> p a a -optionP x p = p <|> pure x +optionP :: Alternator p => b -> p a b -> p a b +optionP b p = p <|> pure b instance (Alternator p, Applicative f) => Alternator (WrappedPafb f p) where From 3e35270d7b23558dc4a2bbe779497c8f670846fe Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 20:59:55 -0800 Subject: [PATCH 210/282] Update Filtrator.hs --- src/Data/Profunctor/Filtrator.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Filtrator.hs b/src/Data/Profunctor/Filtrator.hs index fba141a..75a1e42 100644 --- a/src/Data/Profunctor/Filtrator.hs +++ b/src/Data/Profunctor/Filtrator.hs @@ -9,7 +9,8 @@ Portability : non-portable -} module Data.Profunctor.Filtrator - ( Filtrator (filtrate) + ( -- * Filtrator + Filtrator (filtrate) , mfiltrate ) where From 89dc38e313e3465045079637bb007829052cafd3 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 21:00:06 -0800 Subject: [PATCH 211/282] Generators --- src/Control/Lens/Grammar.hs | 50 +++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 8b78a97..1ae8e70 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -26,6 +26,12 @@ module Control.Lens.Grammar , regbnfGrammar -- * Context-sensitive grammar , CtxGrammar + -- * Generators + , regstringG + , regbnfG + , printG + , parseG + , unparseG ) where import Control.Applicative @@ -258,3 +264,47 @@ instance Show RegBnf where showsPrec precision = showsPrec precision . toList instance Read RegBnf where readsPrec _ str = [(fromList str, "")] + +regstringG :: RegGrammar Char a -> RegString +regstringG = runGrammor + +regbnfG :: Grammar Char a -> RegBnf +regbnfG = runGrammor + +printG + :: ( Cons string string token token + , IsList string + , Item string ~ token + , Categorized token + , Alternative m + , Monad m + , Filterable m + ) + => CtxGrammar token a -> a -> m (string -> string) +printG = printP + +parseG + :: ( Cons string string token token + , Snoc string string token token + , IsList string + , Item string ~ token + , Categorized token + , Alternative m + , Monad m + , Filterable m + ) + => CtxGrammar token a -> string -> m (a, string) +parseG = parseP + +unparseG + :: ( Cons string string token token + , Snoc string string token token + , IsList string + , Item string ~ token + , Categorized token + , Alternative m + , Monad m + , Filterable m + ) + => CtxGrammar token a -> a -> string -> m string +unparseG = unparseP From 031393c8feb763f4d6aecd4646f5555099ba73cb Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 21:28:32 -0800 Subject: [PATCH 212/282] Update Main.hs --- test/doc/Main.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/test/doc/Main.hs b/test/doc/Main.hs index dc8989a..e6661b5 100644 --- a/test/doc/Main.hs +++ b/test/doc/Main.hs @@ -4,8 +4,10 @@ import Test.DocTest main :: IO () main = doctest - [ --- "-isrc" --- , "src" --- , "-XLambdaCase" + [ "src/Control/Lens/Grammar.hs" + , "-XLambdaCase" + , "-XDerivingStrategies" + , "-XImpredicativeTypes" + , "-XQuantifiedConstraints" + , "-XTypeFamilies" ] From bbf113c190fe0b0b34fecb6e673b59e31a1c55e7 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 21:28:36 -0800 Subject: [PATCH 213/282] Update Main.hs --- test/spec/Main.hs | 28 +--------------------------- 1 file changed, 1 insertion(+), 27 deletions(-) diff --git a/test/spec/Main.hs b/test/spec/Main.hs index df79782..f21e563 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -3,36 +3,12 @@ module Main (main) where import Data.Char import Data.Foldable hiding (toList) import Control.Lens.Grammar -import Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol -import Data.Profunctor -import Data.Profunctor.Grammar import GHC.Exts import Test.Hspec -expectedRegexGrammar :: Bnf RegString -expectedRegexGrammar = Bnf - { startBnf = fromString "\\q{regex}" - , rulesBnf = fromList $ map (second' fromString) - [ ("alternate","\\q{sequence}(\\|\\q{sequence})*") - , ("atom","(\\\\q\\{)\\q{char}*\\}|\\q{char}|\\q{char-class}|\\(\\q{regex}\\)") - , ("category","Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn") - , ("category-test","(\\\\p\\{)\\q{category}\\}|(\\\\P\\{)(\\q{category}(\\|\\q{category})*)\\}") - , ("char","[^\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}\\P{Cc}]|\\\\\\q{char-escaped}") - , ("char-any","\\[\\^\\]") - , ("char-class","\\q{fail}|\\q{char-any}|\\q{one-of}|(\\[\\^)\\q{char}+(\\q{category-test}?\\])|\\q{category-test}") - , ("char-control","NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC") - , ("char-escaped","[\\(\\)\\*\\+\\?\\[\\\\\\]\\^\\{\\|\\}]|\\q{char-control}") - , ("expression","\\q{atom}\\?|\\q{atom}\\*|\\q{atom}\\+|\\q{atom}") - , ("fail","\\[\\]") - , ("one-of","\\[\\q{char}+\\]") - , ("regex","\\q{alternate}") - , ("sequence","\\q{char}*|\\q{expression}*") - ] - } - regexExamples :: [(RegString, String)] regexExamples = [ (terminal "abc123etc.", "abc123etc.") @@ -58,9 +34,7 @@ regexExamples = main :: IO () main = hspec $ do - describe "regexGrammar" $ do - it "should generate a correct grammar" $ do - runGrammor regexGrammar `shouldBe` expectedRegexGrammar + describe "regexGrammar" $ for_ regexExamples $ \(rex, str) -> do it ("should print " <> show (runRegString rex) <> " correctly") $ toList rex `shouldBe` str From cdc4121f476253f61d34301cd54fa590b0082941 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Sun, 1 Feb 2026 21:28:47 -0800 Subject: [PATCH 214/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 111 ++++++++++++++++++++++-------------- 1 file changed, 67 insertions(+), 44 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 1ae8e70..1fe555c 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -32,6 +32,8 @@ module Control.Lens.Grammar , printG , parseG , unparseG + -- * Utilities + , putStringLn ) where import Control.Applicative @@ -100,6 +102,24 @@ makeNestedPrisms ''GeneralCategory makeNestedPrisms ''RegString makeNestedPrisms ''RegBnf +{- | +>>> putStringLn (regbnfG regexGrammar) +{start} = \q{regex} +{alternate} = \q{sequence}(\|\q{sequence})* +{atom} = (\\q\{)\q{char}*\}|\q{char}|\q{char-class}|\(\q{regex}\) +{category} = Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn +{category-test} = (\\p\{)\q{category}\}|(\\P\{)(\q{category}(\|\q{category})*)\} +{char} = [^\(\)\*\+\?\[\\\]\^\{\|\}\P{Cc}]|\\\q{char-escaped} +{char-any} = \[\^\] +{char-class} = \q{fail}|\q{char-any}|\q{one-of}|(\[\^)\q{char}+(\q{category-test}?\])|\q{category-test} +{char-control} = NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC +{char-escaped} = [\(\)\*\+\?\[\\\]\^\{\|\}]|\q{char-control} +{expression} = \q{atom}\?|\q{atom}\*|\q{atom}\+|\q{atom} +{fail} = \[\] +{one-of} = \[\q{char}+\] +{regex} = \q{alternate} +{sequence} = \q{char}*|\q{expression}* +-} regexGrammar :: Grammar Char RegString regexGrammar = _RegString >~ ruleRec "regex" altG where @@ -226,50 +246,11 @@ regbnfGrammar = rule "regbnf" $ _RegBnf . _Bnf >~ ruleG = rule "rule" $ terminal "{" >* manyP charG *< terminal "} = " >*< regexGrammar -instance IsList RegString where - type Item RegString = Char - fromList - = fromMaybe zeroK - . listToMaybe - . mapMaybe prsF - . parseP regexGrammar - where - prsF (rex,"") = Just rex - prsF _ = Nothing - toList - = maybe "[]" ($ "") - . printP regexGrammar -instance IsString RegString where - fromString = fromList -instance Show RegString where - showsPrec precision = showsPrec precision . toList -instance Read RegString where - readsPrec _ str = [(fromList str, "")] -instance IsList RegBnf where - type Item RegBnf = Char - fromList - = fromMaybe zeroK - . listToMaybe - . mapMaybe prsF - . parseP regbnfGrammar - where - prsF (regbnf,"") = Just regbnf - prsF _ = Nothing - toList - = maybe "{start} = []" ($ "") - . printP regbnfGrammar -instance IsString RegBnf where - fromString = fromList -instance Show RegBnf where - showsPrec precision = showsPrec precision . toList -instance Read RegBnf where - readsPrec _ str = [(fromList str, "")] - regstringG :: RegGrammar Char a -> RegString -regstringG = runGrammor +regstringG x = runGrammor x regbnfG :: Grammar Char a -> RegBnf -regbnfG = runGrammor +regbnfG x = runGrammor x printG :: ( Cons string string token token @@ -281,7 +262,7 @@ printG , Filterable m ) => CtxGrammar token a -> a -> m (string -> string) -printG = printP +printG x = printP x parseG :: ( Cons string string token token @@ -294,7 +275,7 @@ parseG , Filterable m ) => CtxGrammar token a -> string -> m (a, string) -parseG = parseP +parseG x = parseP x unparseG :: ( Cons string string token token @@ -307,4 +288,46 @@ unparseG , Filterable m ) => CtxGrammar token a -> a -> string -> m string -unparseG = unparseP +unparseG x = unparseP x + +putStringLn :: (IsList string, Item string ~ Char) => string -> IO () +putStringLn = putStrLn . toList + +instance IsList RegString where + type Item RegString = Char + fromList + = fromMaybe zeroK + . listToMaybe + . mapMaybe prsF + . parseP regexGrammar + where + prsF (rex,"") = Just rex + prsF _ = Nothing + toList + = maybe "[]" ($ "") + . printP regexGrammar +instance IsString RegString where + fromString = fromList +instance Show RegString where + showsPrec precision = showsPrec precision . toList +instance Read RegString where + readsPrec _ str = [(fromList str, "")] +instance IsList RegBnf where + type Item RegBnf = Char + fromList + = fromMaybe zeroK + . listToMaybe + . mapMaybe prsF + . parseP regbnfGrammar + where + prsF (regbnf,"") = Just regbnf + prsF _ = Nothing + toList + = maybe "{start} = []" ($ "") + . printP regbnfGrammar +instance IsString RegBnf where + fromString = fromList +instance Show RegBnf where + showsPrec precision = showsPrec precision . toList +instance Read RegBnf where + readsPrec _ str = [(fromList str, "")] From 12e3cad5dea1eea6d78f1b559ce203cbc1b3c3a0 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 08:17:27 -0800 Subject: [PATCH 215/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 121 ++++++++++++++++++++++++++++-------- 1 file changed, 94 insertions(+), 27 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 1fe555c..ca8f7f7 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -111,11 +111,12 @@ makeNestedPrisms ''RegBnf {category-test} = (\\p\{)\q{category}\}|(\\P\{)(\q{category}(\|\q{category})*)\} {char} = [^\(\)\*\+\?\[\\\]\^\{\|\}\P{Cc}]|\\\q{char-escaped} {char-any} = \[\^\] -{char-class} = \q{fail}|\q{char-any}|\q{one-of}|(\[\^)\q{char}+(\q{category-test}?\])|\q{category-test} +{char-class} = \q{fail}|\q{char-any}|\q{one-of}|\q{not-one-of}|\q{category-test} {char-control} = NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC {char-escaped} = [\(\)\*\+\?\[\\\]\^\{\|\}]|\q{char-control} {expression} = \q{atom}\?|\q{atom}\*|\q{atom}\+|\q{atom} {fail} = \[\] +{not-one-of} = (\[\^)\q{char}+(\q{category-test}?\]) {one-of} = \[\q{char}+\] {regex} = \q{alternate} {sequence} = \q{char}*|\q{expression}* @@ -190,10 +191,7 @@ regexGrammar = _RegString >~ ruleRec "regex" altG [ _Fail >? failG , _Pass >? anyG , _OneOf >? oneOfG - , _NotOneOf >? - terminal "[^" >* several1 noSep charG - >*< optionP (NotAsIn Set.empty) catTestG - *< terminal "]" + , _NotOneOf >? notOneOfG , _NotOneOf >? pure Set.empty >*< catTestG ] @@ -203,6 +201,11 @@ regexGrammar = _RegString >~ ruleRec "regex" altG oneOfG = rule "one-of" $ terminal "[" >* several1 noSep charG *< terminal "]" + notOneOfG = rule "not-one-of" $ + terminal "[^" >* several1 noSep charG + >*< optionP (NotAsIn Set.empty) catTestG + *< terminal "]" + charG :: Grammar Char Char charG = rule "char" $ tokenClass (notOneOf charsReserved >&&< notAsIn Control) @@ -214,30 +217,94 @@ charG = rule "char" $ charsReserved = "()*+?[\\]^{|}" charControlG = rule "char-control" $ choiceP - [ terminal abbrev >* pure charControl - | (abbrev, charControl) <- charsControl - ] - - charsControl = - [ ("NUL", '\NUL'), ("SOH", '\SOH'), ("STX", '\STX'), ("ETX", '\ETX') - , ("EOT", '\EOT'), ("ENQ", '\ENQ'), ("ACK", '\ACK'), ("BEL", '\BEL') - , ("BS", '\BS'), ("HT", '\HT'), ("LF", '\LF'), ("VT", '\VT') - , ("FF", '\FF'), ("CR", '\CR'), ("SO", '\SO'), ("SI", '\SI') - , ("DLE", '\DLE'), ("DC1", '\DC1'), ("DC2", '\DC2'), ("DC3", '\DC3') - , ("DC4", '\DC4'), ("NAK", '\NAK'), ("SYN", '\SYN'), ("ETB", '\ETB') - , ("CAN", '\CAN'), ("EM", '\EM'), ("SUB", '\SUB'), ("ESC", '\ESC') - , ("FS", '\FS'), ("GS", '\GS'), ("RS", '\RS'), ("US", '\US') - , ("DEL", '\DEL') - , ("PAD", '\x80'), ("HOP", '\x81'), ("BPH", '\x82'), ("NBH", '\x83') - , ("IND", '\x84'), ("NEL", '\x85'), ("SSA", '\x86'), ("ESA", '\x87') - , ("HTS", '\x88'), ("HTJ", '\x89'), ("VTS", '\x8A'), ("PLD", '\x8B') - , ("PLU", '\x8C'), ("RI", '\x8D'), ("SS2", '\x8E'), ("SS3", '\x8F') - , ("DCS", '\x90'), ("PU1", '\x91'), ("PU2", '\x92'), ("STS", '\x93') - , ("CCH", '\x94'), ("MW", '\x95'), ("SPA", '\x96'), ("EPA", '\x97') - , ("SOS", '\x98'), ("SGCI",'\x99'), ("SCI", '\x9A'), ("CSI", '\x9B') - , ("ST", '\x9C'), ("OSC", '\x9D'), ("PM", '\x9E'), ("APC", '\x9F') + [ only '\NUL' >? terminal "NUL" + , only '\SOH' >? terminal "SOH" + , only '\STX' >? terminal "STX" + , only '\ETX' >? terminal "ETX" + , only '\EOT' >? terminal "EOT" + , only '\ENQ' >? terminal "ENQ" + , only '\ACK' >? terminal "ACK" + , only '\BEL' >? terminal "BEL" + , only '\BS' >? terminal "BS" + , only '\HT' >? terminal "HT" + , only '\LF' >? terminal "LF" + , only '\VT' >? terminal "VT" + , only '\FF' >? terminal "FF" + , only '\CR' >? terminal "CR" + , only '\SO' >? terminal "SO" + , only '\SI' >? terminal "SI" + , only '\DLE' >? terminal "DLE" + , only '\DC1' >? terminal "DC1" + , only '\DC2' >? terminal "DC2" + , only '\DC3' >? terminal "DC3" + , only '\DC4' >? terminal "DC4" + , only '\NAK' >? terminal "NAK" + , only '\SYN' >? terminal "SYN" + , only '\ETB' >? terminal "ETB" + , only '\CAN' >? terminal "CAN" + , only '\EM' >? terminal "EM" + , only '\SUB' >? terminal "SUB" + , only '\ESC' >? terminal "ESC" + , only '\FS' >? terminal "FS" + , only '\GS' >? terminal "GS" + , only '\RS' >? terminal "RS" + , only '\US' >? terminal "US" + , only '\DEL' >? terminal "DEL" + , only '\x80' >? terminal "PAD" + , only '\x81' >? terminal "HOP" + , only '\x82' >? terminal "BPH" + , only '\x83' >? terminal "NBH" + , only '\x84' >? terminal "IND" + , only '\x85' >? terminal "NEL" + , only '\x86' >? terminal "SSA" + , only '\x87' >? terminal "ESA" + , only '\x88' >? terminal "HTS" + , only '\x89' >? terminal "HTJ" + , only '\x8A' >? terminal "VTS" + , only '\x8B' >? terminal "PLD" + , only '\x8C' >? terminal "PLU" + , only '\x8D' >? terminal "RI" + , only '\x8E' >? terminal "SS2" + , only '\x8F' >? terminal "SS3" + , only '\x90' >? terminal "DCS" + , only '\x91' >? terminal "PU1" + , only '\x92' >? terminal "PU2" + , only '\x93' >? terminal "STS" + , only '\x94' >? terminal "CCH" + , only '\x95' >? terminal "MW" + , only '\x96' >? terminal "SPA" + , only '\x97' >? terminal "EPA" + , only '\x98' >? terminal "SOS" + , only '\x99' >? terminal "SGCI" + , only '\x9A' >? terminal "SCI" + , only '\x9B' >? terminal "CSI" + , only '\x9C' >? terminal "ST" + , only '\x9D' >? terminal "OSC" + , only '\x9E' >? terminal "PM" + , only '\x9F' >? terminal "APC" ] +{- | +>>> putStringLn (regbnfG regbnfGrammar) +{start} = \q{regbnf} +{alternate} = \q{sequence}(\|\q{sequence})* +{atom} = (\\q\{)\q{char}*\}|\q{char}|\q{char-class}|\(\q{regex}\) +{category} = Ll|Lu|Lt|Lm|Lo|Mn|Mc|Me|Nd|Nl|No|Pc|Pd|Ps|Pe|Pi|Pf|Po|Sm|Sc|Sk|So|Zs|Zl|Zp|Cc|Cf|Cs|Co|Cn +{category-test} = (\\p\{)\q{category}\}|(\\P\{)(\q{category}(\|\q{category})*)\} +{char} = [^\(\)\*\+\?\[\\\]\^\{\|\}\P{Cc}]|\\\q{char-escaped} +{char-any} = \[\^\] +{char-class} = \q{fail}|\q{char-any}|\q{one-of}|\q{not-one-of}|\q{category-test} +{char-control} = NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|DEL|PAD|HOP|BPH|NBH|IND|NEL|SSA|ESA|HTS|HTJ|VTS|PLD|PLU|RI|SS2|SS3|DCS|PU1|PU2|STS|CCH|MW|SPA|EPA|SOS|SGCI|SCI|CSI|ST|OSC|PM|APC +{char-escaped} = [\(\)\*\+\?\[\\\]\^\{\|\}]|\q{char-control} +{expression} = \q{atom}\?|\q{atom}\*|\q{atom}\+|\q{atom} +{fail} = \[\] +{not-one-of} = (\[\^)\q{char}+(\q{category-test}?\]) +{one-of} = \[\q{char}+\] +{regbnf} = (\{start\} = )\q{regex}(\LF\q{rule})* +{regex} = \q{alternate} +{rule} = \{\q{char}*(\} = )\q{regex} +{sequence} = \q{char}*|\q{expression}* +-} regbnfGrammar :: Grammar Char RegBnf regbnfGrammar = rule "regbnf" $ _RegBnf . _Bnf >~ terminal "{start} = " >* regexGrammar From db9503d6ffa60243335a0b30cf799f6bc3e54857 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 08:41:39 -0800 Subject: [PATCH 216/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index ca8f7f7..e372015 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -7,16 +7,14 @@ Maintainer : Eitan Chatav Stability : provisional Portability : non-portable -See Chomsky, [Three Models for the Description of Language] -(https://chomsky.info/wp-content/uploads/195609-.pdf) +See Chomsky, [On Certain Formal Properties of Grammars] +(https://somr.info/lib/Chomsky_1959.pdf) -} module Control.Lens.Grammar ( -- * Regular grammar RegGrammar , RegString (..) - , TerminalSymbol (..) - , Tokenized (..) , Regular , regexGrammar -- * Context-free grammar From 986c1677245cc84cd9797b026fb8f8cc958ed4b8 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 08:41:42 -0800 Subject: [PATCH 217/282] Update Kleene.hs --- src/Control/Lens/Grammar/Kleene.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 37395d3..69b55a5 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -7,7 +7,9 @@ Maintainer : Eitan Chatav Stability : provisional Portability : non-portable -Regular expressions form a Kleene star algebra +Regular expressions form a Kleene star algebra. See Kleene, +[Representation of Events in Nerve Nets and Finite Automata] +(https://www.rand.org/pubs/research_memoranda/RM704.html) -} module Control.Lens.Grammar.Kleene From 721333caca71fa16d0fb2ae3a0228fc84ccff986 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 10:49:59 -0800 Subject: [PATCH 218/282] docs --- src/Control/Lens/Grammar.hs | 20 +++++++++----------- src/Control/Lens/Grammar/BackusNaur.hs | 5 +++-- src/Control/Lens/Grammar/Boole.hs | 4 +++- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index e372015..bf72e1a 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -14,23 +14,21 @@ See Chomsky, [On Certain Formal Properties of Grammars] module Control.Lens.Grammar ( -- * Regular grammar RegGrammar - , RegString (..) , Regular + , RegString (..) + , regstringG , regexGrammar -- * Context-free grammar , Grammar , RegBnf (..) - , BackusNaurForm (..) + , regbnfG , regbnfGrammar -- * Context-sensitive grammar , CtxGrammar - -- * Generators - , regstringG - , regbnfG , printG , parseG , unparseG - -- * Utilities + -- * Utility , putStringLn ) where @@ -312,10 +310,10 @@ regbnfGrammar = rule "regbnf" $ _RegBnf . _Bnf >~ >*< regexGrammar regstringG :: RegGrammar Char a -> RegString -regstringG x = runGrammor x +regstringG rex = runGrammor rex regbnfG :: Grammar Char a -> RegBnf -regbnfG x = runGrammor x +regbnfG bnf = runGrammor bnf printG :: ( Cons string string token token @@ -327,7 +325,7 @@ printG , Filterable m ) => CtxGrammar token a -> a -> m (string -> string) -printG x = printP x +printG printor = printP printor parseG :: ( Cons string string token token @@ -340,7 +338,7 @@ parseG , Filterable m ) => CtxGrammar token a -> string -> m (a, string) -parseG x = parseP x +parseG parsor = parseP parsor unparseG :: ( Cons string string token token @@ -353,7 +351,7 @@ unparseG , Filterable m ) => CtxGrammar token a -> a -> string -> m string -unparseG x = unparseP x +unparseG parsor = unparseP parsor putStringLn :: (IsList string, Item string ~ Char) => string -> IO () putStringLn = putStrLn . toList diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index bbfe3a9..7678d8c 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -7,8 +7,9 @@ Maintainer : Eitan Chatav Stability : provisional Portability : non-portable -See Breitner, [Showcasing Applicative] -(https://www.joachim-breitner.de/blog/710-Showcasing_Applicative) +See Backus & Naur, +[Report on the Algorithmic Language ALGOL 60] +(https://softwarepreservation.computerhistory.org/ALGOL/report/Algol60_report_CACM_1960_June.pdf) -} module Control.Lens.Grammar.BackusNaur diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index e8cd214..17eaacf 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -7,7 +7,9 @@ Maintainer : Eitan Chatav Stability : provisional Portability : non-portable -Token classes form a Boolean algebra +See Boole, [The Mathematical Analysis of Logic] +(https://www.gutenberg.org/files/36884/36884-pdf.pdf). +Token classes form a Boolean algebra. -} module Control.Lens.Grammar.Boole From 5413f6b402c74645d7e1cc98cfab8929c44e99c4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 10:51:17 -0800 Subject: [PATCH 219/282] Update BackusNaur.hs --- src/Control/Lens/Grammar/BackusNaur.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 7678d8c..31fc409 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -7,7 +7,7 @@ Maintainer : Eitan Chatav Stability : provisional Portability : non-portable -See Backus & Naur, +See Naur & Backus, et al. [Report on the Algorithmic Language ALGOL 60] (https://softwarepreservation.computerhistory.org/ALGOL/report/Algol60_report_CACM_1960_June.pdf) -} From 5a4630bb6fac3fd5a3f6b52e3296cbd3cb53c14e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 10:54:26 -0800 Subject: [PATCH 220/282] Update Main.hs --- test/spec/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/spec/Main.hs b/test/spec/Main.hs index f21e563..d7d73c6 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -6,6 +6,7 @@ import Control.Lens.Grammar import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token import GHC.Exts import Test.Hspec From 2fc2f764c009e71702acd3fa289a1cb8a67bfd31 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 11:15:37 -0800 Subject: [PATCH 221/282] Boole Docs --- src/Control/Lens/Grammar/Boole.hs | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index 17eaacf..d496231 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -9,16 +9,16 @@ Portability : non-portable See Boole, [The Mathematical Analysis of Logic] (https://www.gutenberg.org/files/36884/36884-pdf.pdf). -Token classes form a Boolean algebra. +Categorized token classes form a Boolean algebra. -} module Control.Lens.Grammar.Boole - ( -- * TokenAlgebra - TokenAlgebra (..) - , TokenTest (..) - -- * BooleanAlgebra - , BooleanAlgebra (..) + ( -- * BooleanAlgebra + BooleanAlgebra (..) , andB, orB, allB, anyB + -- * TokenAlgebra + , TokenAlgebra (..) + , TokenTest (..) ) where import Control.Applicative @@ -32,43 +32,58 @@ import Data.Profunctor.Distributor import qualified Data.Set as Set import GHC.Generics +-- | A `BooleanAlgebra`, like `Bool`, supporting classical logical operations. class BooleanAlgebra b where + -- | conjunction (>&&<) :: b -> b -> b default (>&&<) :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b (>&&<) = liftA2 (>&&<) + -- | disjunction (>||<) :: b -> b -> b default (>||<) :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => b -> b -> b (>||<) = liftA2 (>||<) + -- | negation notB :: b -> b default notB :: (b ~ f bool, BooleanAlgebra bool, Functor f) => b -> b notB = fmap notB + -- | inclusion fromBool :: Bool -> b default fromBool :: (b ~ f bool, BooleanAlgebra bool, Applicative f) => Bool -> b fromBool = pure . fromBool +-- | cumulative conjunction andB :: (Foldable f, BooleanAlgebra b) => f b -> b andB = foldl' (>&&<) (fromBool True) +-- | cumulative disjunction orB :: (Foldable f, BooleanAlgebra b) => f b -> b orB = foldl' (>||<) (fromBool False) +-- | universal qualification allB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b allB f = foldl' (\b a -> b >&&< f a) (fromBool True) +-- | existential qualification anyB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b anyB f = foldl' (\b a -> b >||< f a) (fromBool False) +-- | `TokenTest` forms a `Tokenized` `BooleanAlgebra` +-- of `Categorized` `tokenClass`es. newtype TokenTest token = TokenTest (RegExam token (TokenTest token)) +-- | `TokenAlgebra` extends `Tokenized` methods to support +-- `BooleanAlgebra` operations in a `tokenClass` class Tokenized token p => TokenAlgebra token p where + -- | Arguments of `tokenClass` can be constructed from + -- `Tokenized` and `BooleanAlgebra` methods. tokenClass :: TokenTest token -> p default tokenClass :: (p ~ q token token, Alternator q, Cochoice q) From 48fcf1f3efc76b1ddfc26d9df7c8c86cc37efebc Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 11:28:13 -0800 Subject: [PATCH 222/282] partialInvoluted --- src/Control/Lens/PartialIso.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index 976b692..41d6bbb 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -22,7 +22,7 @@ module Control.Lens.PartialIso , PartialExchange (PartialExchange) -- Combinators , partialIso - , involutedMaybe + , partialInvoluted , withPartialIso , clonePartialIso , coPartialIso @@ -149,8 +149,10 @@ partialIso :: (s -> Maybe a) -> (b -> Maybe t) -> PartialIso s t a b partialIso f g = unright . iso (maybe (Left ()) Right . f =<<) (mapMaybe g) . right' -involutedMaybe :: (a -> Maybe a) -> PartialIso' a a -involutedMaybe f = partialIso f f +{- | Given a function that is its own partial inverse, +this gives you a `PartialIso'` using it in both directions. -} +partialInvoluted :: (a -> Maybe a) -> PartialIso' a a +partialInvoluted f = partialIso f f {- | Convert `APartialIso` to the pair of functions that characterize it. -} withPartialIso @@ -248,7 +250,7 @@ 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 = involutedMaybe satiate where +satisfied f = partialInvoluted satiate where satiate a = if f a then Just a else Nothing {- | `nulled` matches an `Empty` pattern, like `_Empty`. -} @@ -315,7 +317,7 @@ difoldr1 pattern = . crossPartialIso id (coPartialIso pattern) in from (iterating step) -{- | Left fold & unfold `APartialIso` to a `Prism`. -} +{- | Left fold & unfold `APartialIso` to a `Control.Lens.Prism.Prism`. -} difoldl :: (AsEmpty t, Cons s t a b) => APartialIso d c (d,b) (c,a) @@ -324,7 +326,7 @@ difoldl pattern = dimap (,Empty) (fmap fst) . difoldl1 pattern -{- | Right fold & unfold `APartialIso` to a `Prism`. -} +{- | Right fold & unfold `APartialIso` to a `Control.Lens.Prism.Prism`. -} difoldr :: (AsEmpty t, Cons s t a b) => APartialIso d c (b,d) (a,c) From 7f9ef4008797eaa60b1673942a898426b5ca0c95 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 11:51:11 -0800 Subject: [PATCH 223/282] docs --- src/Data/Profunctor/Monadic.hs | 6 +++--- src/Data/Profunctor/Monoidal.hs | 33 +++++++++++++++++---------------- 2 files changed, 20 insertions(+), 19 deletions(-) diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 7d69c0f..9a0b2bc 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -21,8 +21,8 @@ module Data.Profunctor.Monadic Monadic , (>>=) , (>>) - , fail , return + , fail ) where import Data.Profunctor @@ -31,7 +31,7 @@ import Prelude hiding ((>>=), (>>)) {- | A `Profunctor` which is also a `Monad`. -} type Monadic p = (Profunctor p, forall x. Monad (p x)) -{- | The pair bonding operator `>>=` is a context-sensitive +{- | The pair bonding operator @P.@`>>=` is a context-sensitive version of `Data.Profunctor.Monoidal.>*<`. -} (>>=) :: Monadic p => p a b -> (b -> p c d) -> p (a,c) (b,d) infixl 1 >>= @@ -40,7 +40,7 @@ p >>= f = do d <- lmap snd (f b) return (b,d) -{- | The unit bonding operator `>>`. -} +{- | @P.@`>>` sequences actions. -} (>>) :: Monadic p => p () c -> p a b -> p a b infixl 1 >> x >> y = do _ <- lmap (const ()) x; y diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index 4a6135f..6b6c513 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -15,7 +15,8 @@ module Data.Profunctor.Monoidal Monoidal , oneP, (>*<), (>*), (*<) , dimap2, foreverP, ditraverse - , (>:<), asEmpty, replicateP + -- * Monoidal & Choice + , replicateP, (>:<), asEmpty , meander, eotFunList ) where @@ -99,32 +100,32 @@ dimap2 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`. -} +analagous to `Control.Monad.forever`, extending it to `Monoidal`. -} foreverP :: Monoidal p => p () c -> p a b foreverP a = let a' = a >* a' in a' +{- | A `Monoidal` & `Choice` nil operator. -} +asEmpty :: (AsEmpty s, Monoidal p, Choice p) => p s s +asEmpty = _Empty >? oneP + +{- | A `Monoidal` & `Choice` cons operator. -} +(>:<) :: (Cons s t a b, Monoidal p, Choice p) => p a b -> p s t -> p s t +x >:< xs = _Cons >? x >*< xs +infixr 5 >:< + {- | Thanks to Fy on Monoidal Café Discord. -`ditraverse` 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. +A `Traversable` & `Distributive` type is a homogeneous countable product. +That means it is a static length container, so unlike `replicateP`, +`ditraverse` does not need an `Int` argument. -} ditraverse :: (Traversable t, Distributive t, Monoidal p) => p a b -> p (t a) (t b) ditraverse p = traverse (\f -> lmap f p) (distribute id) -{- | A `Monoidal` nil operator. -} -asEmpty :: (AsEmpty s, Monoidal p, Choice p) => p s s -asEmpty = _Empty >? oneP - -{- | A `Monoidal` cons operator. -} -(>:<) :: (Cons s t a b, Monoidal p, Choice p) => p a b -> p s t -> p s t -x >:< xs = _Cons >? x >*< xs -infixr 5 >:< - +{- | `replicateP` is analagous to `replicateM`, +for `Monoidal` & `Choice` `Profunctor`s. -} replicateP :: (Monoidal p, Choice p, AsEmpty s, AsEmpty t, Cons s t a b) => Int -> p a b -> p s t From 811dd108c41b131339f8f77f86d439a7eaedb88f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 11:52:25 -0800 Subject: [PATCH 224/282] Update Monoidal.hs --- src/Data/Profunctor/Monoidal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index 6b6c513..a066491 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -124,7 +124,7 @@ ditraverse => p a b -> p (t a) (t b) ditraverse p = traverse (\f -> lmap f p) (distribute id) -{- | `replicateP` is analagous to `replicateM`, +{- | `replicateP` is analagous to `Control.Monad.replicateM`, for `Monoidal` & `Choice` `Profunctor`s. -} replicateP :: (Monoidal p, Choice p, AsEmpty s, AsEmpty t, Cons s t a b) From 2ea5c44293572f1b6e9b6fc9be89b45267a55181 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 12:14:18 -0800 Subject: [PATCH 225/282] Update Monoidal.hs --- src/Data/Profunctor/Monoidal.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Monoidal.hs b/src/Data/Profunctor/Monoidal.hs index a066491..b1aefa7 100644 --- a/src/Data/Profunctor/Monoidal.hs +++ b/src/Data/Profunctor/Monoidal.hs @@ -115,7 +115,8 @@ infixr 5 >:< {- | Thanks to Fy on Monoidal Café Discord. -A `Traversable` & `Distributive` type is a homogeneous countable product. +A `Traversable` & `Data.Distributive.Distributive` type +is a homogeneous countable product. That means it is a static length container, so unlike `replicateP`, `ditraverse` does not need an `Int` argument. -} From 9ea57c622b2fc5b5385bd9e6a3e4c2ee84410ca7 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 12:14:25 -0800 Subject: [PATCH 226/282] Update Distributor.hs --- src/Data/Profunctor/Distributor.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index c5f7ae6..5fc5a8a 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -347,10 +347,12 @@ class (Choice p, Distributor p, forall x. Alternative (p x)) someP :: p a b -> p [a] [b] someP p = _Cons >? p >*< manyP p +-- | Combines all `Alternator` choices in the specified list. choiceP :: (Foldable f, Alternator p) => f (p a b) -> p a b choiceP = foldl' (<|>) empty -optionP :: Alternator p => b -> p a b -> p a b +-- | Perform an `Alternator` action or return a default value. +optionP :: Alternator p => b {- ^ default value -} -> p a b -> p a b optionP b p = p <|> pure b instance (Alternator p, Applicative f) @@ -423,6 +425,8 @@ several1 several1 (SepBy beg end sep) p = iso toList fromList . _Cons >? beg >* (p >*< manyP (sep >* p)) *< end +{- | Use a nilary constructor pattern to sequence zero times, or +associate a binary constructor pattern to sequence one or more times. -} chain :: Alternator p => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate @@ -432,6 +436,7 @@ chain chain association pat2 pat0 (SepBy beg end sep) p = beg >* (pat0 >? oneP <|> chain1 association pat2 (sepBy sep) p) *< end +{- | Associate a binary constructor pattern to sequence one or more times. -} chain1 :: (Distributor p, Choice p) => (forall x. x -> Either x x) -- ^ `Left` or `Right` associate From 781ed22761c9ccee2ed76a8db8859a4bab7d8b81 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 12:53:49 -0800 Subject: [PATCH 227/282] Enum (Categorize token) --- src/Control/Lens/Grammar/BackusNaur.hs | 8 ++++---- src/Control/Lens/Grammar/Kleene.hs | 4 ++-- src/Control/Lens/Grammar/Token.hs | 3 ++- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index 31fc409..c6dc752 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -73,7 +73,7 @@ The [Brzozowski derivative] prop> word =~ diffB prefix pattern = prefix <> word =~ pattern -} diffB - :: (Categorized token, Enum (Categorize token), HasTrie token) + :: (Categorized token, HasTrie token) => [token] -> Bnf (RegEx token) -> Bnf (RegEx token) diffB prefix (Bnf start rules) = Bnf (foldl' (flip diff1B) start prefix) rules @@ -105,7 +105,7 @@ diffB prefix (Bnf start rules) = RegExam (Alternate y1 y2) -> diff1B x y1 >|< diff1B x y2 -- | Does a pattern match the empty word? -δ :: (Categorized token, Enum (Categorize token), HasTrie token) +δ :: (Categorized token, HasTrie token) => Bnf (RegEx token) -> Bool δ (Bnf start rules) = ν start where ν = memo $ \case @@ -162,10 +162,10 @@ instance (Ord rule, Monoid rule) => Monoid (Bnf rule) where mempty = liftBnf0 mempty instance (Ord rule, Semigroup rule) => Semigroup (Bnf rule) where (<>) = liftBnf2 (<>) -instance (Categorized token, Enum (Categorize token), HasTrie token) +instance (Categorized token, HasTrie token) => Matching [token] (Bnf (RegEx token)) where (=~) word = δ . diffB word -instance (Categorized token, Enum (Categorize token), HasTrie token) +instance (Categorized token, HasTrie token) => Matching [token] (RegEx token) where word =~ pattern = word =~ liftBnf0 pattern instance Matching s (APrism s t a b) where diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 69b55a5..42e6b54 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -168,7 +168,7 @@ deriving stock instance deriving stock instance (Categorized token, Show token, Show (Categorize token)) => Show (CategoryTest token) -instance (Categorized token, Enum (Categorize token), HasTrie token) +instance (Categorized token, HasTrie token) => HasTrie (RegEx token) where data (RegEx token :->: b) = RegExTrie { terminalTrie :: [token] :->: b @@ -226,7 +226,7 @@ instance (Categorized token, Enum (Categorize token), HasTrie token) , first' testNotOneOf <$> enumerate (notOneOfTrie rex) ] testNotOneOf - :: (Categorized token, Enum (Categorize token)) + :: Categorized token => ([token], Either Int [Int]) -> RegEx token testNotOneOf (chars, catTest) = RegExam $ NotOneOf (Set.fromList chars) (either (AsIn . toEnum) (NotAsIn . Set.map toEnum . Set.fromList) catTest) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index d56c390..d65e89d 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -31,7 +31,8 @@ import Data.Profunctor.Distributor import Data.Profunctor.Monoidal import Data.Word -class (Ord token, Ord (Categorize token)) => Categorized token where +class (Ord token, Ord (Categorize token), Enum (Categorize token)) + => Categorized token where type Categorize token type Categorize token = () categorize :: token -> Categorize token From b04036d1271affdc36038ecf9e6e1a098ea9969f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 13:16:11 -0800 Subject: [PATCH 228/282] doctests --- src/Control/Lens/Grammar/Token.hs | 10 ++++++++++ test/doc/Main.hs | 25 +++++++++++++++++-------- 2 files changed, 27 insertions(+), 8 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index d65e89d..34ccd48 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -31,6 +31,16 @@ import Data.Profunctor.Distributor import Data.Profunctor.Monoidal import Data.Word +{- | `Categorized` provides a type family `Categorize` +and a function `categorize` to classify tokens into discrete categories. + +>>> :kind! Categorize Char +Categorize Char :: * += GeneralCategory + +>>> categorize 'a' +LowercaseLetter +-} class (Ord token, Ord (Categorize token), Enum (Categorize token)) => Categorized token where type Categorize token diff --git a/test/doc/Main.hs b/test/doc/Main.hs index e6661b5..4972566 100644 --- a/test/doc/Main.hs +++ b/test/doc/Main.hs @@ -1,13 +1,22 @@ module Main (main) where +import Data.Foldable (for_) import Test.DocTest main :: IO () -main = doctest - [ "src/Control/Lens/Grammar.hs" - , "-XLambdaCase" - , "-XDerivingStrategies" - , "-XImpredicativeTypes" - , "-XQuantifiedConstraints" - , "-XTypeFamilies" - ] +main = for_ + [ "src/Control/Lens/Grammar.hs" + , "src/Control/Lens/Grammar/Token.hs" + ] $ \modulePath -> do + putStr "Testing module documentation in " + putStrLn modulePath + doctest + [ modulePath + , "-XLambdaCase" + , "-XDerivingStrategies" + , "-XImpredicativeTypes" + , "-XQuantifiedConstraints" + , "-XTypeFamilies" + , "-XFunctionalDependencies" + , "-XDefaultSignatures" + ] From ed169957a1faa76927093c51c550b9f25256b9aa Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 13:25:14 -0800 Subject: [PATCH 229/282] Update Main.hs --- test/doc/Main.hs | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/test/doc/Main.hs b/test/doc/Main.hs index 4972566..0adc985 100644 --- a/test/doc/Main.hs +++ b/test/doc/Main.hs @@ -4,15 +4,14 @@ import Data.Foldable (for_) import Test.DocTest main :: IO () -main = for_ - [ "src/Control/Lens/Grammar.hs" - , "src/Control/Lens/Grammar/Token.hs" - ] $ \modulePath -> do - putStr "Testing module documentation in " - putStrLn modulePath - doctest - [ modulePath - , "-XLambdaCase" +main = do + let + modulePaths = + [ "src/Control/Lens/Grammar.hs" + , "src/Control/Lens/Grammar/Token.hs" + ] + languageExtensions = + [ "-XLambdaCase" , "-XDerivingStrategies" , "-XImpredicativeTypes" , "-XQuantifiedConstraints" @@ -20,3 +19,7 @@ main = for_ , "-XFunctionalDependencies" , "-XDefaultSignatures" ] + for_ modulePaths $ \modulePath -> do + putStr "Testing module documentation in " + putStrLn modulePath + doctest (modulePath : languageExtensions) From 78c2be6fb8128cec7e92cb6af2536a1d3b5d4e4e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 14:00:07 -0800 Subject: [PATCH 230/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 34ccd48..de41bd5 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -32,7 +32,7 @@ import Data.Profunctor.Monoidal import Data.Word {- | `Categorized` provides a type family `Categorize` -and a function `categorize` to classify tokens into discrete categories. +and a function `categorize` to classify tokens into disjoint categories. >>> :kind! Categorize Char Categorize Char :: * From 88a7e2a0a6e82b04b52921b7cbcd70e5547ec8ad Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 14:04:31 -0800 Subject: [PATCH 231/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index de41bd5..9173c18 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -32,7 +32,7 @@ import Data.Profunctor.Monoidal import Data.Word {- | `Categorized` provides a type family `Categorize` -and a function `categorize` to classify tokens into disjoint categories. +and a function to `categorize` tokens into disjoint categories. >>> :kind! Categorize Char Categorize Char :: * From d15a44ffa11663be82f395ac29d6ae2dc33d244a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 14:36:29 -0800 Subject: [PATCH 232/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 9173c18..cd7ecda 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -54,33 +54,40 @@ instance Categorized Char where instance Categorized Word8 instance Categorized () +{- | `Tokenized` combinators for constructing lexical tokens. -} class Categorized token => Tokenized token p | p -> token where + {- | Sequences any single token. -} anyToken :: p + {- | Sequences a single specified `token`. -} token :: token -> p default token :: (p ~ q token token, Choice q, Cochoice q) => token -> p token = satisfy . token + {- | Sequences a single token which is `oneOf` a set. -} oneOf :: Foldable f => f token -> p default oneOf :: (p ~ q token token, Choice q, Cochoice q, Foldable f) => f token -> p oneOf = satisfy . oneOf + {- | Sequences a single token which is `notOneOf` a set. -} notOneOf :: Foldable f => f token -> p default notOneOf :: (p ~ q token token, Choice q, Cochoice q, Foldable f) => f token -> p notOneOf = satisfy . notOneOf + {- | Sequences a single token which is `asIn` a category. -} asIn :: Categorize token -> p default asIn :: (p ~ q token token, Choice q, Cochoice q) => Categorize token -> p asIn = satisfy . asIn + {- | Sequences a single token which is `notAsIn` a category. -} notAsIn :: Categorize token -> p default notAsIn :: (p ~ q token token, Choice q, Cochoice q) @@ -95,11 +102,16 @@ instance Categorized token => Tokenized token (token -> Bool) where asIn = lmap categorize . (==) notAsIn = lmap categorize . (/=) +{- | Sequences a single token that satisfies a predicate. -} satisfy :: (Tokenized a (p a a), Choice p, Cochoice p) => (a -> Bool) -> p a a satisfy f = satisfied f >?< 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 :: ( Foldable f, Tokenized a (p a a) , Monoidal p, Choice p From dcfd6c794d1d311f6cd045233d390ebbb770f5c1 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 14:39:38 -0800 Subject: [PATCH 233/282] Update Distributor.hs --- src/Data/Profunctor/Distributor.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index 5fc5a8a..c835b22 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -211,7 +211,7 @@ class Traversable t => Homogeneous t where prop> homogeneously @Maybe = optionalP prop> homogeneously @[] = manyP - Any `Traversable` & `Distributive` countable product + Any `Traversable` & `Data.Distributive.Distributive` countable product can be given a default implementation for the `homogeneously` method. prop> homogeneously = ditraverse From 2eaad80ac429f6512c9bda358b5a9fb57fbcdd32 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 14:39:41 -0800 Subject: [PATCH 234/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index cd7ecda..737c4d7 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -109,8 +109,8 @@ satisfy satisfy f = satisfied f >?< 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`. +It can be used as a default definition for the `Data.String.fromString` +method of `Data.String.IsString` when `Tokenized` `Char` `Char`. -} tokens :: ( Foldable f, Tokenized a (p a a) From a47e7c1a537573df93ac0456b30ba82437cce4d4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 14:53:03 -0800 Subject: [PATCH 235/282] Update BackusNaur.hs --- src/Control/Lens/Grammar/BackusNaur.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index c6dc752..a6c798a 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -37,23 +37,40 @@ import Data.MemoTrie import qualified Data.Set as Set import Data.Set (Set) +{- | `BackusNaurForm` grammar combinators formalize +`rule` abstraction and general recursion. Context-free +`Control.Lens.Grammar.Grammar`s support the `BackusNaurForm` interface. +-} class BackusNaurForm bnf where + + {- | For a `BackusNaurForm` parser instance, + `rule` can be used to detail parse errors. + + prop> rule name bnf = ruleRec name (\_ -> bnf) + -} rule :: String -> bnf -> bnf rule _ = id + + {- | General recursion, using `ruleRec`, rules can refer to themselves. -} ruleRec :: String -> (bnf -> bnf) -> bnf ruleRec _ = fix +{- | A `Bnf` consists of a distinguished starting rule +and a set of named rules. -} data Bnf rule = Bnf { startBnf :: rule , rulesBnf :: Set (String, rule) } deriving stock (Eq, Ord, Show, Read) +{- | Lift a rule to a `Bnf`. -} liftBnf0 :: Ord a => a -> Bnf a liftBnf0 a = Bnf a mempty +{- | Lift a function of rules to `Bnf`s. -} liftBnf1 :: (Coercible a b, Ord b) => (a -> b) -> Bnf a -> Bnf b liftBnf1 f (Bnf start rules) = Bnf (f start) (Set.map coerce rules) +{- | Lift a binary function of rules to `Bnf`s. -} liftBnf2 :: (Coercible a c, Coercible b c, Ord c) => (a -> b -> c) -> Bnf a -> Bnf b -> Bnf c From 2ee9a2e270dcf52cc563c40ee6db33728f432007 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 14:54:34 -0800 Subject: [PATCH 236/282] Update ci.yml --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index e47fee5..d05fd1a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -13,7 +13,7 @@ jobs: uses: actions/checkout@v4 - name: Setup Haskell Stack - uses: haskell/actions/setup@v2 + uses: haskell-actions/setup@v2 with: enable-stack: true From 9a270716c55e302e52c10a314a62d92dacb86997 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 15:44:21 -0800 Subject: [PATCH 237/282] docs --- src/Control/Lens/Grammar/Kleene.hs | 21 +++++++++++++++++++++ src/Control/Lens/Grammar/Symbol.hs | 2 ++ src/Data/Profunctor/Grammar.hs | 13 +++++++++++++ 3 files changed, 36 insertions(+) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 42e6b54..2dd4396 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -33,6 +33,19 @@ import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics +{- | A `KleeneStarAlgebra` is a ring +with a generally non-commutaive multiplication, +the `Monoid` concatenation operator `<>` with identity `mempty`; +and an idempotent addition, the alternation operator `>|<` +with identity `zeroK`. + +It has three unary operators `optK`, `plusK` and the eponymous `starK`. + +prop> starK x = optK (plusK x) +prop> plusK x = x <> starK x +prop> optK x = mempty >|< x + +-} class Monoid k => KleeneStarAlgebra k where starK, plusK, optK :: k -> k starK x = optK (plusK x) @@ -46,12 +59,15 @@ class Monoid k => KleeneStarAlgebra k where (>|<) = (<|>) zeroK = empty +-- | cumulative alternation, orK :: (Foldable f, KleeneStarAlgebra k) => f k -> k orK = foldl' (>|<) zeroK +-- | universal qualification anyK :: (Foldable f, KleeneStarAlgebra k) => (a -> k) -> f a -> k anyK f = foldl' (\b a -> b >|< f a) zeroK +-- | The `RegEx`pression type is the prototypical `KleeneStarAlgebra`. data RegEx token = Terminal [token] | NonTerminal String @@ -61,6 +77,10 @@ data RegEx token | KleenePlus (RegEx token) | RegExam (RegExam token (RegEx token)) +{- | A component of both `RegEx`pressions +and `Control.Lens.Grammar.Boole.TokenTest`s, so that the latter can +be embedded in the former with `Control.Lens.Grammar.Boole.tokenClass`. +-} data RegExam token alg = Fail | Pass @@ -68,6 +88,7 @@ data RegExam token alg | NotOneOf (Set token) (CategoryTest token) | Alternate alg alg +{- | `CategoryTest`s for `Categorized` tokens.-} data CategoryTest token = AsIn (Categorize token) | NotAsIn (Set (Categorize token)) diff --git a/src/Control/Lens/Grammar/Symbol.hs b/src/Control/Lens/Grammar/Symbol.hs index 1d09f79..4f69e98 100644 --- a/src/Control/Lens/Grammar/Symbol.hs +++ b/src/Control/Lens/Grammar/Symbol.hs @@ -20,6 +20,7 @@ import Control.Lens.Grammar.Token import Data.Profunctor import Data.Profunctor.Monoidal +-- | A `terminal` symbol in a grammar. class TerminalSymbol token s | s -> token where terminal :: [token] -> s default terminal @@ -27,5 +28,6 @@ class TerminalSymbol token s | s -> token where => [token] -> s terminal = foldr (\a p -> only a ?< anyToken *> p) oneP +-- | A `nonTerminal` symbol in a grammar. class NonTerminalSymbol s where nonTerminal :: String -> s diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index bbeab0c..0bc2f6f 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -41,16 +41,29 @@ import Prelude hiding (id, (.)) import GHC.Exts import Witherable +-- | `Parsor` is a simple parser `Profunctor`. newtype Parsor s f a b = Parsor {runParsor :: Maybe a -> s -> f (b,s)} + +-- | Run the parser on an input string, +-- popping tokens from the beginning of the string, +-- returning a value and the remaining string. parseP :: Parsor s f a b -> s -> f (b,s) parseP (Parsor f) = f Nothing + +-- | Run the parser in reverse on a value and an input string, +-- placing tokens at the end of the string and returning the new string. unparseP :: Functor f => Parsor s f a b -> a -> s -> f s unparseP (Parsor f) a = fmap snd . f (Just a) +-- | `Printor` is a simple printer `Profunctor`. newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)} + +-- | Run the printer on a value, returning a function +-- that places tokens at the beginning of an input string. printP :: Functor f => Printor s f a b -> a -> f (s -> s) printP (Printor f) = fmap snd . f +-- | `Grammor` is a constant `Profunctor`. newtype Grammor k a b = Grammor {runGrammor :: k} -- Parsor instances From a1e955c3e75bde14987431d6cbe5f525851d3a39 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 16:05:58 -0800 Subject: [PATCH 238/282] Update BackusNaur.hs --- src/Control/Lens/Grammar/BackusNaur.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar/BackusNaur.hs b/src/Control/Lens/Grammar/BackusNaur.hs index a6c798a..8beba91 100644 --- a/src/Control/Lens/Grammar/BackusNaur.hs +++ b/src/Control/Lens/Grammar/BackusNaur.hs @@ -56,7 +56,7 @@ class BackusNaurForm bnf where ruleRec _ = fix {- | A `Bnf` consists of a distinguished starting rule -and a set of named rules. -} +and a set of named rules, supporting the `BackusNaurForm` interface. -} data Bnf rule = Bnf { startBnf :: rule , rulesBnf :: Set (String, rule) From ecb49cf55e2ee004a1bdf75daef02a52565241f4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 16:07:27 -0800 Subject: [PATCH 239/282] Matching instances --- src/Data/Profunctor/Grammar.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 0bc2f6f..d77801d 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -24,6 +24,7 @@ import Control.Applicative import Control.Arrow import Control.Category import Control.Lens +import Control.Lens.Extras import Control.Lens.Grammar.BackusNaur import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Kleene @@ -174,6 +175,11 @@ instance instance BackusNaurForm (Parsor s m a b) instance (Alternative m, Monad m) => MonadFail (Parsor s m a) where fail _ = empty +instance AsEmpty s => Matching s (Parsor s [] a b) where + word =~ p = case + [ () | (_, remaining) <- runParsor p Nothing word + , is _Empty remaining + ] of [] -> False; _:_ -> True -- Printor instances instance Functor f => Functor (Printor s f a) where @@ -316,3 +322,5 @@ instance TerminalSymbol token k instance BackusNaurForm k => BackusNaurForm (Grammor k a b) where rule name = Grammor . rule name . runGrammor ruleRec name = Grammor . ruleRec name . dimap Grammor runGrammor +instance Matching s k => Matching s (Grammor k a b) where + word =~ pattern = word =~ runGrammor pattern From 9583a060ce46f10b6542e92ee5d974db48e6bfb0 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 17:47:33 -0800 Subject: [PATCH 240/282] Lexical --- src/Control/Lens/Grammar.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index bf72e1a..ba2c52f 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -53,20 +53,24 @@ import GHC.Exts import Prelude hiding (filter) import Witherable -type RegGrammar token a = forall p. Regular token p => p a a +type RegGrammar token a = forall p. + ( Lexical token p + , Alternator p + ) => p a a type Grammar token a = forall p. - ( Regular token p + ( Lexical token p , forall x. BackusNaurForm (p x x) + , Alternator p ) => p a a type CtxGrammar token a = forall p. - ( Regular token p + ( Lexical token p , forall x. BackusNaurForm (p x x) + , Alternator p , Monadic p , Filtrator p ) => p a a -type Regular token p = - ( Alternator p - , forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) +type Lexical token p = + ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) , forall x y. (x ~ token, y ~ token) => TokenAlgebra token (p x y) ) :: Constraint From 1c371c7f08644f7ecfd517f85af0c426df58cf27 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 18:03:34 -0800 Subject: [PATCH 241/282] Lexical --- src/Control/Lens/Grammar.hs | 2 +- src/Data/Profunctor/Grammar.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index ba2c52f..10e033e 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -14,7 +14,7 @@ See Chomsky, [On Certain Formal Properties of Grammars] module Control.Lens.Grammar ( -- * Regular grammar RegGrammar - , Regular + , Lexical , RegString (..) , regstringG , regexGrammar diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index d77801d..349b289 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -42,18 +42,18 @@ import Prelude hiding (id, (.)) import GHC.Exts import Witherable --- | `Parsor` is a simple parser `Profunctor`. +-- | `Parsor` is a simple invertible parser `Profunctor`. newtype Parsor s f a b = Parsor {runParsor :: Maybe a -> s -> f (b,s)} -- | Run the parser on an input string, -- popping tokens from the beginning of the string, -- returning a value and the remaining string. -parseP :: Parsor s f a b -> s -> f (b,s) +parseP :: Parsor s f a a -> s -> f (a,s) parseP (Parsor f) = f Nothing -- | Run the parser in reverse on a value and an input string, -- placing tokens at the end of the string and returning the new string. -unparseP :: Functor f => Parsor s f a b -> a -> s -> f s +unparseP :: Functor f => Parsor s f a a -> a -> s -> f s unparseP (Parsor f) a = fmap snd . f (Just a) -- | `Printor` is a simple printer `Profunctor`. @@ -61,7 +61,7 @@ newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)} -- | Run the printer on a value, returning a function -- that places tokens at the beginning of an input string. -printP :: Functor f => Printor s f a b -> a -> f (s -> s) +printP :: Functor f => Printor s f a a -> a -> f (s -> s) printP (Printor f) = fmap snd . f -- | `Grammor` is a constant `Profunctor`. From 77dba00eb142ef0eccabe694f09eff6793b0aab4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Mon, 2 Feb 2026 21:11:50 -0800 Subject: [PATCH 242/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 737c4d7..36257f8 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -56,38 +56,38 @@ instance Categorized () {- | `Tokenized` combinators for constructing lexical tokens. -} class Categorized token => Tokenized token p | p -> token where - {- | Sequences any single token. -} + {- | Any single token. -} anyToken :: p - {- | Sequences a single specified `token`. -} + {- | A single specified `token`. -} token :: token -> p default token :: (p ~ q token token, Choice q, Cochoice q) => token -> p token = satisfy . token - {- | Sequences a single token which is `oneOf` a set. -} + {- | A single token which is `oneOf` a set. -} oneOf :: Foldable f => f token -> p default oneOf :: (p ~ q token token, Choice q, Cochoice q, Foldable f) => f token -> p oneOf = satisfy . oneOf - {- | Sequences a single token which is `notOneOf` a set. -} + {- | A single token which is `notOneOf` a set. -} notOneOf :: Foldable f => f token -> p default notOneOf :: (p ~ q token token, Choice q, Cochoice q, Foldable f) => f token -> p notOneOf = satisfy . notOneOf - {- | Sequences a single token which is `asIn` a category. -} + {- | A single token which is `asIn` a category. -} asIn :: Categorize token -> p default asIn :: (p ~ q token token, Choice q, Cochoice q) => Categorize token -> p asIn = satisfy . asIn - {- | Sequences a single token which is `notAsIn` a category. -} + {- | A single token which is `notAsIn` a category. -} notAsIn :: Categorize token -> p default notAsIn :: (p ~ q token token, Choice q, Cochoice q) @@ -102,13 +102,13 @@ instance Categorized token => Tokenized token (token -> Bool) where asIn = lmap categorize . (==) notAsIn = lmap categorize . (/=) -{- | Sequences a single token that satisfies a predicate. -} +{- | A single token that satisfies a predicate. -} satisfy :: (Tokenized a (p a a), Choice p, Cochoice p) => (a -> Bool) -> p a a satisfy f = satisfied f >?< anyToken -{- | Sequences a specified stream of `tokens`. +{- | A specified stream of `tokens`. It can be used as a default definition for the `Data.String.fromString` method of `Data.String.IsString` when `Tokenized` `Char` `Char`. -} From 5f1952881be807b33f217fafd1d82f37be5d9eaf Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 3 Feb 2026 18:37:43 -0800 Subject: [PATCH 243/282] examples and tests with vibe coding help from Claude --- distributors.cabal | 5 ++ src/Control/Lens/Grammar/Token.hs | 8 +- test/spec/Examples/Arithmetic.hs | 45 ++++++++++ test/spec/Examples/Json.hs | 135 ++++++++++++++++++++++++++++++ test/spec/Examples/Lambda.hs | 107 +++++++++++++++++++++++ test/spec/Examples/RegString.hs | 32 +++++++ test/spec/Examples/SExpr.hs | 65 ++++++++++++++ test/spec/Main.hs | 80 ++++++++++++------ 8 files changed, 446 insertions(+), 31 deletions(-) create mode 100644 test/spec/Examples/Arithmetic.hs create mode 100644 test/spec/Examples/Json.hs create mode 100644 test/spec/Examples/Lambda.hs create mode 100644 test/spec/Examples/RegString.hs create mode 100644 test/spec/Examples/SExpr.hs diff --git a/distributors.cabal b/distributors.cabal index ccfd357..729ac31 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -183,6 +183,11 @@ test-suite spec type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + Examples.Arithmetic + Examples.Json + Examples.Lambda + Examples.RegString + Examples.SExpr Paths_distributors autogen-modules: Paths_distributors diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 36257f8..8319eb0 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -17,7 +17,7 @@ module Control.Lens.Grammar.Token , oneLike , manyLike , optLike - , someLike + , reqLike -- * Categorized , Categorized (..) , GeneralCategory (..) @@ -163,14 +163,14 @@ optLike a = dimap preF postF (manyP catA) catA = asIn (categorize a) {- | -`someLike` consumes one or more tokens +`reqLike` consumes one or more tokens of a given token's category while parsing, and produces the given token while printing. -} -someLike +reqLike :: forall token p. (Distributor p, Tokenized token (p token token)) => token -> p () () -someLike a = dimap preF postF (catA >*< manyP catA) +reqLike a = dimap preF postF (catA >*< manyP catA) where preF _ = (a, []::[token]) postF (_::token, _::[token]) = () diff --git a/test/spec/Examples/Arithmetic.hs b/test/spec/Examples/Arithmetic.hs new file mode 100644 index 0000000..4a40f2d --- /dev/null +++ b/test/spec/Examples/Arithmetic.hs @@ -0,0 +1,45 @@ +module Examples.Arithmetic + ( Arith (..) + , arithGrammar + , arithExamples + ) where + +import Control.Applicative +import Control.Lens +import Control.Lens.Grammar +import Control.Lens.Grammar.BackusNaur +import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token +import Control.Lens.PartialIso +import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal +import Numeric.Natural + +data Arith + = Num Natural + | Add Arith Arith + | Mul Arith Arith + deriving stock (Eq, Ord, Show, Read) + +makePrisms ''Arith + +arithGrammar :: Grammar Char Arith +arithGrammar = ruleRec "arith" sumG + where + sumG arith = rule "sum" $ + chain1 Left _Add (sepBy (terminal "+")) (prodG arith) + prodG arith = rule "product" $ + chain1 Left _Mul (sepBy (terminal "*")) (factorG arith) + factorG arith = rule "factor" $ + number <|> terminal "(" >* arith *< terminal ")" + number = rule "number" $ + _Num . iso show read >? someP (asIn @Char DecimalNumber) + +arithExamples :: [(Arith, String)] +arithExamples = + [ (Num 42, "42") + , (Add (Num 1) (Num 2), "1+2") + , (Add (Mul (Num 2) (Num 3)) (Num 4), "2*3+4") + , (Mul (Num 2) (Add (Num 3) (Num 4)), "2*(3+4)") + , (Add (Add (Num 1) (Mul (Num 2) (Num 3))) (Num 4), "1+2*3+4") + ] diff --git a/test/spec/Examples/Json.hs b/test/spec/Examples/Json.hs new file mode 100644 index 0000000..53b5bb8 --- /dev/null +++ b/test/spec/Examples/Json.hs @@ -0,0 +1,135 @@ +module Examples.Json + ( Json (..) + , jsonGrammar + , jsonExamples + ) where + +import Control.Applicative +import Control.Lens +import Control.Lens.Grammar +import Control.Lens.Grammar.BackusNaur +import Control.Lens.Grammar.Boole +import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token +import Control.Lens.PartialIso +import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Numeric.Natural + +-- | Abstract syntax tree for JSON values +data Json + = JNull + | JBool Bool + | JNumber Natural + | JString String + | JArray [Json] + | JObject (Map String Json) + deriving stock (Eq, Ord, Show, Read) + +-- Generate prisms +makePrisms ''Json + +-- | JSON grammar following the McKeeman Form specification from json.org +jsonGrammar :: Grammar Char Json +jsonGrammar = ruleRec "json" elementG + where + -- element = ws value ws + elementG json = rule "element" $ + ws >* valueG json *< ws + + -- value = object | array | string | number | "true" | "false" | "null" + valueG json = rule "value" $ choiceP + [ _JNull >? terminal "null" + , _JBool . only True >? terminal "true" + , _JBool . only False >? terminal "false" + , _JNumber >? numberG + , _JString >? stringG + , _JArray >? arrayG json + , _JObject >? objectG json + ] + + -- object = '{' ws '}' | '{' members '}' + objectG json = rule "object" $ choiceP + [ only Map.empty >? + terminal "{" >* ws >* terminal "}" + , iso Map.toList Map.fromList >~ + terminal "{" >* membersG json *< terminal "}" + ] + + -- members = member | member ',' members + membersG json = rule "members" $ + several1 (sepBy (terminal ",")) (memberG json) + + -- member = ws string ws ':' element + memberG json = rule "member" $ + ws >* stringG *< ws *< terminal ":" >*< elementG json + + -- array = '[' ws ']' | '[' elements ']' + arrayG json = rule "array" $ choiceP + [ only [] >? terminal "[" >* ws >* terminal "]" + , terminal "[" >* elementsG json *< terminal "]" + ] + + -- elements = element | element ',' elements + elementsG json = rule "elements" $ + several1 (sepBy (terminal ",")) (elementG json) + + -- string = '"' characters '"' + stringG = rule "string" $ + terminal "\"" >* manyP characterG *< terminal "\"" + + -- character = '0020' . '10FFFF' - '"' - '\' | '\' escape + characterG = rule "character" $ + tokenClass (oneOf ['\x0020' .. '\x10FFFF'] >&&< notOneOf ['\"','\\']) + <|> terminal "\\" >* escapeG + + -- escape = '"' | '\' | '/' | 'b' | 'f' | 'n' | 'r' | 't' + escapeG = rule "escape" $ choiceP + [ only '"' >? terminal "\"" + , only '\\' >? terminal "\\" + , only '/' >? terminal "/" + , only '\b' >? terminal "b" + , only '\f' >? terminal "f" + , only '\n' >? terminal "n" + , only '\r' >? terminal "r" + , only '\t' >? terminal "t" + ] + + -- number = decimal natural number + numberG = rule "number" $ + iso show read >~ someP (asIn @Char DecimalNumber) + + -- Simplified: zero or more whitespace characters + ws = rule "ws" $ manyLike ' ' + +-- | Example JSON values for testing +jsonExamples :: [(Json, String)] +jsonExamples = + [ (JNull, "null") + , (JBool True, "true") + , (JBool False, "false") + , (JNumber 0, "0") + , (JNumber 42, "42") + , (JString "", "\"\"") + , (JString "hello", "\"hello\"") + , (JString "hello world", "\"hello world\"") + , (JString "\"quoted\"", "\"\\\"quoted\\\"\"") + , (JString "line1\nline2", "\"line1\\nline2\"") + , (JArray [], "[]") + , (JArray [JNumber 1, JNumber 2, JNumber 3], "[1,2,3]") + , (JArray [JBool True, JBool False], "[true,false]") + , (JObject Map.empty, "{}") + , (JObject (Map.fromList [("key", JString "value")]), "{\"key\":\"value\"}") + , (JObject (Map.fromList [("a", JNumber 1), ("b", JNumber 2)]), + "{\"a\":1,\"b\":2}") + , (JObject (Map.fromList + [ ("name", JString "Alice") + , ("age", JNumber 30) + , ("active", JBool True) + ]), "{\"active\":true,\"age\":30,\"name\":\"Alice\"}") + , (JArray [JObject (Map.fromList [("x", JNumber 1)]), + JObject (Map.fromList [("x", JNumber 2)])], + "[{\"x\":1},{\"x\":2}]") + ] diff --git a/test/spec/Examples/Lambda.hs b/test/spec/Examples/Lambda.hs new file mode 100644 index 0000000..77947f5 --- /dev/null +++ b/test/spec/Examples/Lambda.hs @@ -0,0 +1,107 @@ +module Examples.Lambda + ( Lambda (..) + , lambdaGrammar + , lambdaExamples + ) where + +import Control.Lens +import Control.Lens.Grammar +import Control.Lens.Grammar.BackusNaur +import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token +import Control.Lens.PartialIso +import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal + +-- | Abstract syntax tree for lambda calculus terms +data Lambda + = Var String -- ^ Variable + | Lam String Lambda -- ^ Lambda abstraction (\\x.body) + | App Lambda Lambda -- ^ Function application + deriving stock (Eq, Ord, Show, Read) + +-- Generate prisms +makePrisms ''Lambda + +-- | Grammar for untyped lambda calculus +lambdaGrammar :: Grammar Char Lambda +lambdaGrammar = ruleRec "lambda" termG + where + -- Top level term: lambda abstraction or application + termG term = rule "term" $ choiceP + [ lamG term + , appG term + ] + + -- Lambda abstraction: \x.body + lamG term = rule "lambda" $ + _Lam >? terminal "\\" >* varNameG *< terminal "." >*< term + + -- Application: left-associative chain of atoms + -- e.g., "f x y" parses as "(f x) y" + appG term = rule "application" $ + chain1 Left _App (sepBy (reqLike ' ')) (atomG term) + + -- Atomic term: variable or parenthesized term + atomG term = rule "atom" $ choiceP + [ _Var >? varNameG + , terminal "(" >* term *< terminal ")" + ] + + -- Variable name: starts with lowercase letter, + -- followed by alphanumeric or underscore + varNameG = rule "varname" $ asIn LowercaseLetter >:< + manyP (choiceP (token '_' : map asIn [LowercaseLetter, UppercaseLetter, DecimalNumber])) + +-- | Example lambda calculus terms for testing +lambdaExamples :: [(Lambda, String)] +lambdaExamples = + -- Variables + [ (Var "x", "x") + , (Var "y", "y") + , (Var "foo", "foo") + , (Var "x1", "x1") + + -- Simple lambda abstractions + , (Lam "x" (Var "x"), "\\x.x") -- Identity + , (Lam "x" (Lam "y" (Var "x")), "\\x.\\y.x") -- K combinator + , (Lam "x" (Lam "y" (Var "y")), "\\x.\\y.y") -- K* combinator + + -- Applications + , (App (Var "f") (Var "x"), "f x") + , (App (App (Var "f") (Var "x")) (Var "y"), "f x y") + + -- Lambda with application in body + , (Lam "f" (Lam "x" (App (Var "f") (Var "x"))), + "\\f.\\x.f x") + + -- S combinator: \x.\y.\z.x z (y z) + , (Lam "x" (Lam "y" (Lam "z" + (App (App (Var "x") (Var "z")) + (App (Var "y") (Var "z"))))), + "\\x.\\y.\\z.x z (y z)") + + -- Omega combinator: (\x.x x)(\x.x x) + , (App (Lam "x" (App (Var "x") (Var "x"))) + (Lam "x" (App (Var "x") (Var "x"))), + "(\\x.x x) (\\x.x x)") + + -- Church numeral 0: \f.\x.x + , (Lam "f" (Lam "x" (Var "x")), + "\\f.\\x.x") + + -- Church numeral 1: \f.\x.f x + , (Lam "f" (Lam "x" (App (Var "f") (Var "x"))), + "\\f.\\x.f x") + + -- Church numeral 2: \f.\x.f (f x) + , (Lam "f" (Lam "x" + (App (Var "f") (App (Var "f") (Var "x")))), + "\\f.\\x.f (f x)") + + -- Y combinator: \f.(\x.f (x x)) (\x.f (x x)) + , (Lam "f" + (App (Lam "x" (App (Var "f") (App (Var "x") (Var "x")))) + (Lam "x" (App (Var "f") (App (Var "x") (Var "x"))))), + "\\f.(\\x.f (x x)) (\\x.f (x x))") + ] diff --git a/test/spec/Examples/RegString.hs b/test/spec/Examples/RegString.hs new file mode 100644 index 0000000..107f51c --- /dev/null +++ b/test/spec/Examples/RegString.hs @@ -0,0 +1,32 @@ +module Examples.RegString + ( regexExamples + ) where + +import Control.Lens.Grammar +import Control.Lens.Grammar.Boole +import Control.Lens.Grammar.Kleene +import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token + +regexExamples :: [(RegString, String)] +regexExamples = + [ (terminal "abc123etc.", "abc123etc.") + , (terminal "x" <> terminal "y", "xy") + , (zeroK, "[]") + , (terminal "x" >|< terminal "y", "x|y") + , (optK (terminal "x"), "x?") + , (starK (terminal "x"), "x*") + , (plusK (terminal "x"), "x+") + , (anyToken, "[^]") + , (oneOf "abc", "[abc]") + , (notOneOf "abc", "[^abc]") + , (asIn UppercaseLetter, "\\p{Lu}") + , (notAsIn LowercaseLetter, "\\P{Ll}") + , (nonTerminal "rule-name", "\\q{rule-name}") + , (terminal "", "") + , (optK (terminal "abc"), "(abc)?") + , (optK (terminal "abc") <> nonTerminal "xyz", "(abc)?\\q{xyz}") + , (tokenClass (oneOf "abc" >||< oneOf "xyz"), "[abcxyz]") + , (tokenClass (notOneOf "abc" >&&< asIn LowercaseLetter), "[^abc\\p{Ll}]") + , (tokenClass (notOneOf "abc" >&&< notAsIn Control), "[^abc\\P{Cc}]") + ] diff --git a/test/spec/Examples/SExpr.hs b/test/spec/Examples/SExpr.hs new file mode 100644 index 0000000..3dc53f0 --- /dev/null +++ b/test/spec/Examples/SExpr.hs @@ -0,0 +1,65 @@ +module Examples.SExpr + ( SExpr (..) + , sexprGrammar + , sexprExamples + ) where + +import Control.Lens hiding (List) +import Control.Lens.Grammar +import Control.Lens.Grammar.BackusNaur +import Control.Lens.Grammar.Boole +import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token +import Control.Lens.PartialIso hiding (List) +import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal + +-- | Abstract syntax tree for S-expressions +data SExpr + = Atom String -- ^ Atomic symbol + | List [SExpr] -- ^ List of S-expressions + deriving stock (Eq, Ord, Show, Read) + +-- Generate prisms +makePrisms ''SExpr + +-- | Grammar for S-expressions +sexprGrammar :: Grammar Char SExpr +sexprGrammar = ruleRec "sexpr" $ \sexpr -> choiceP + [ _Atom >? atomG + , _List >? listG sexpr + ] + where + -- Atom: one or more alphanumeric or symbol characters + atomG = rule "atom" $ someP (tokenClass atomChars) + + -- List: parenthesized sequence of S-expressions + -- Elements are separated by whitespace + listG sexpr = rule "list" $ + terminal "(" >* several (sepBy (reqLike ' ')) sexpr *< terminal ")" + + -- Characters allowed in atoms: letters, digits, and symbols + atomChars = + oneOf (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_+-*/<>=!?") + +-- | Example S-expressions for testing +sexprExamples :: [(SExpr, String)] +sexprExamples = + [ (Atom "foo", "foo") + , (Atom "x", "x") + , (Atom "+", "+") + , (Atom "define", "define") + , (List [], "()") + , (List [Atom "foo"], "(foo)") + , (List [Atom "foo", Atom "bar"], "(foo bar)") + , (List [Atom "foo", List [Atom "bar", Atom "baz"]], + "(foo (bar baz))") + , (List [Atom "define", List [Atom "square", Atom "x"], + List [Atom "*", Atom "x", Atom "x"]], + "(define (square x) (* x x))") + , (List [Atom "+", Atom "1", Atom "2"], "(+ 1 2)") + , (List [Atom "if", Atom "test", + List [Atom "then-branch"], + List [Atom "else-branch"]], + "(if test (then-branch) (else-branch))") + ] diff --git a/test/spec/Main.hs b/test/spec/Main.hs index d7d73c6..9380bf7 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -1,37 +1,15 @@ module Main (main) where -import Data.Char import Data.Foldable hiding (toList) import Control.Lens.Grammar -import Control.Lens.Grammar.Boole -import Control.Lens.Grammar.Kleene -import Control.Lens.Grammar.Symbol -import Control.Lens.Grammar.Token import GHC.Exts import Test.Hspec -regexExamples :: [(RegString, String)] -regexExamples = - [ (terminal "abc123etc.", "abc123etc.") - , (terminal "x" <> terminal "y", "xy") - , (zeroK, "[]") - , (terminal "x" >|< terminal "y", "x|y") - , (optK (terminal "x"), "x?") - , (starK (terminal "x"), "x*") - , (plusK (terminal "x"), "x+") - , (anyToken, "[^]") - , (oneOf "abc", "[abc]") - , (notOneOf "abc", "[^abc]") - , (asIn UppercaseLetter, "\\p{Lu}") - , (notAsIn LowercaseLetter, "\\P{Ll}") - , (nonTerminal "rule-name", "\\q{rule-name}") - , (terminal "", "") - , (optK (terminal "abc"), "(abc)?") - , (optK (terminal "abc") <> nonTerminal "xyz", "(abc)?\\q{xyz}") - , (tokenClass (oneOf "abc" >||< oneOf "xyz"), "[abcxyz]") - , (tokenClass (notOneOf "abc" >&&< asIn LowercaseLetter), "[^abc\\p{Ll}]") - , (tokenClass (notOneOf "abc" >&&< notAsIn Control), "[^abc\\P{Cc}]") - ] +import Examples.RegString +import Examples.Arithmetic +import Examples.Json +import Examples.SExpr +import Examples.Lambda main :: IO () main = hspec $ do @@ -41,3 +19,51 @@ main = hspec $ do toList rex `shouldBe` str it ("should parse " <> str <> " correctly") $ do fromString str `shouldBe` rex + + describe "arithGrammar" $ + for_ arithExamples $ \(expectedArith, str) -> do + it ("should parse " <> str <> " correctly") $ do + let actualArith = [parsedArith | (parsedArith, "") <- parseG arithGrammar str] + actualArith `shouldBe` [expectedArith] + it ("should unparse " <> show expectedArith <> " correctly") $ do + let unparsedArith = unparseG arithGrammar expectedArith "" + unparsedArith `shouldBe` Just str + it ("should print " <> show expectedArith <> " correctly") $ do + let printedArith = ($ "") <$> printG arithGrammar expectedArith + printedArith `shouldBe` Just str + + describe "jsonGrammar" $ + for_ jsonExamples $ \(expectedJson, str) -> do + it ("should parse " <> str <> " correctly") $ do + let actualJson = [parsedJson | (parsedJson, "") <- parseG jsonGrammar str] + actualJson `shouldBe` [expectedJson] + it ("should unparse " <> show expectedJson <> " correctly") $ do + let unparsedJson = unparseG jsonGrammar expectedJson "" + unparsedJson `shouldBe` Just str + it ("should print " <> show expectedJson <> " correctly") $ do + let printedJson = ($ "") <$> printG jsonGrammar expectedJson + printedJson `shouldBe` Just str + + describe "sexprGrammar" $ + for_ sexprExamples $ \(expectedSExpr, str) -> do + it ("should parse " <> str <> " correctly") $ do + let actualSExpr = [parsedSExpr | (parsedSExpr, "") <- parseG sexprGrammar str] + actualSExpr `shouldBe` [expectedSExpr] + it ("should unparse " <> show expectedSExpr <> " correctly") $ do + let unparsedSExpr = unparseG sexprGrammar expectedSExpr "" + unparsedSExpr `shouldBe` Just str + it ("should print " <> show expectedSExpr <> " correctly") $ do + let printedSExpr = ($ "") <$> printG sexprGrammar expectedSExpr + printedSExpr `shouldBe` Just str + + describe "lambdaGrammar" $ + for_ lambdaExamples $ \(expectedLambda, str) -> do + it ("should parse " <> str <> " correctly") $ do + let actualLambda = [parsedLambda | (parsedLambda, "") <- parseG lambdaGrammar str] + actualLambda `shouldBe` [expectedLambda] + it ("should unparse " <> show expectedLambda <> " correctly") $ do + let unparsedLambda = unparseG lambdaGrammar expectedLambda "" + unparsedLambda `shouldBe` Just str + it ("should print " <> show expectedLambda <> " correctly") $ do + let printedLambda = ($ "") <$> printG lambdaGrammar expectedLambda + printedLambda `shouldBe` Just str From b2063cd91c60adf348fa6609f3fd85174fcdd40f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 3 Feb 2026 19:07:47 -0800 Subject: [PATCH 244/282] Update Main.hs --- test/spec/Main.hs | 64 +++++++++++++---------------------------------- 1 file changed, 18 insertions(+), 46 deletions(-) diff --git a/test/spec/Main.hs b/test/spec/Main.hs index 9380bf7..653003c 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -20,50 +20,22 @@ main = hspec $ do it ("should parse " <> str <> " correctly") $ do fromString str `shouldBe` rex - describe "arithGrammar" $ - for_ arithExamples $ \(expectedArith, str) -> do - it ("should parse " <> str <> " correctly") $ do - let actualArith = [parsedArith | (parsedArith, "") <- parseG arithGrammar str] - actualArith `shouldBe` [expectedArith] - it ("should unparse " <> show expectedArith <> " correctly") $ do - let unparsedArith = unparseG arithGrammar expectedArith "" - unparsedArith `shouldBe` Just str - it ("should print " <> show expectedArith <> " correctly") $ do - let printedArith = ($ "") <$> printG arithGrammar expectedArith - printedArith `shouldBe` Just str - - describe "jsonGrammar" $ - for_ jsonExamples $ \(expectedJson, str) -> do - it ("should parse " <> str <> " correctly") $ do - let actualJson = [parsedJson | (parsedJson, "") <- parseG jsonGrammar str] - actualJson `shouldBe` [expectedJson] - it ("should unparse " <> show expectedJson <> " correctly") $ do - let unparsedJson = unparseG jsonGrammar expectedJson "" - unparsedJson `shouldBe` Just str - it ("should print " <> show expectedJson <> " correctly") $ do - let printedJson = ($ "") <$> printG jsonGrammar expectedJson - printedJson `shouldBe` Just str + -- testGrammar "regexGrammar" regexGrammar regexExamples + testGrammar "arithGrammar" arithGrammar arithExamples + testGrammar "jsonGrammar" jsonGrammar jsonExamples + testGrammar "sexprGrammar" sexprGrammar sexprExamples + testGrammar "lambdaGrammar" lambdaGrammar lambdaExamples - describe "sexprGrammar" $ - for_ sexprExamples $ \(expectedSExpr, str) -> do - it ("should parse " <> str <> " correctly") $ do - let actualSExpr = [parsedSExpr | (parsedSExpr, "") <- parseG sexprGrammar str] - actualSExpr `shouldBe` [expectedSExpr] - it ("should unparse " <> show expectedSExpr <> " correctly") $ do - let unparsedSExpr = unparseG sexprGrammar expectedSExpr "" - unparsedSExpr `shouldBe` Just str - it ("should print " <> show expectedSExpr <> " correctly") $ do - let printedSExpr = ($ "") <$> printG sexprGrammar expectedSExpr - printedSExpr `shouldBe` Just str - - describe "lambdaGrammar" $ - for_ lambdaExamples $ \(expectedLambda, str) -> do - it ("should parse " <> str <> " correctly") $ do - let actualLambda = [parsedLambda | (parsedLambda, "") <- parseG lambdaGrammar str] - actualLambda `shouldBe` [expectedLambda] - it ("should unparse " <> show expectedLambda <> " correctly") $ do - let unparsedLambda = unparseG lambdaGrammar expectedLambda "" - unparsedLambda `shouldBe` Just str - it ("should print " <> show expectedLambda <> " correctly") $ do - let printedLambda = ($ "") <$> printG lambdaGrammar expectedLambda - printedLambda `shouldBe` Just str +testGrammar :: (Show a, Eq a) => String -> Grammar Char a -> [(a, String)] -> Spec +testGrammar name grammar examples = + describe name $ + for_ examples $ \(expectedSyntax, expectedString) -> do + it ("should parse from " <> expectedString <> " correctly") $ do + let actualSyntax = [parsed | (parsed, "") <- parseG grammar expectedString] + actualSyntax `shouldBe` [expectedSyntax] + it ("should unparse to " <> expectedString <> " correctly") $ do + let actualString = unparseG grammar expectedSyntax "" + actualString `shouldBe` Just expectedString + it ("should print to " <> expectedString <> " correctly") $ do + let actualString = ($ "") <$> printG grammar expectedSyntax + actualString `shouldBe` Just expectedString From 12d8b8009bca58ee4e51ec2151627bd0f667e4bc Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 3 Feb 2026 19:46:58 -0800 Subject: [PATCH 245/282] Update Main.hs --- test/doc/Main.hs | 35 ++++++++++++++++++++++++++++++++--- 1 file changed, 32 insertions(+), 3 deletions(-) diff --git a/test/doc/Main.hs b/test/doc/Main.hs index 0adc985..2d00056 100644 --- a/test/doc/Main.hs +++ b/test/doc/Main.hs @@ -11,13 +11,42 @@ main = do , "src/Control/Lens/Grammar/Token.hs" ] languageExtensions = - [ "-XLambdaCase" + [ "-XAllowAmbiguousTypes" + , "-XArrows" + , "-XConstraintKinds" + , "-XDataKinds" + , "-XDefaultSignatures" + , "-XDeriveFoldable" + , "-XDeriveFunctor" + , "-XDeriveTraversable" + , "-XDeriveGeneric" , "-XDerivingStrategies" + , "-XDerivingVia" + , "-XEmptyCase" + , "-XFlexibleContexts" + , "-XFlexibleInstances" + , "-XFunctionalDependencies" + , "-XGADTs" + , "-XGeneralizedNewtypeDeriving" + , "-XImportQualifiedPost" , "-XImpredicativeTypes" + , "-XInstanceSigs" + , "-XLambdaCase" + , "-XMagicHash" + , "-XMonoLocalBinds" , "-XQuantifiedConstraints" + , "-XRankNTypes" + , "-XRecursiveDo" + , "-XScopedTypeVariables" + , "-XStandaloneDeriving" + , "-XStandaloneKindSignatures" + , "-XTemplateHaskell" + , "-XTupleSections" + , "-XTypeApplications" , "-XTypeFamilies" - , "-XFunctionalDependencies" - , "-XDefaultSignatures" + , "-XTypeOperators" + , "-XUndecidableInstances" + , "-XUndecidableSuperClasses" ] for_ modulePaths $ \modulePath -> do putStr "Testing module documentation in " From 932b51c35fab5bece501f3c294cebb855a9750de Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 3 Feb 2026 19:47:24 -0800 Subject: [PATCH 246/282] doctest Arith Grammar --- src/Control/Lens/Grammar.hs | 51 +++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 10e033e..9860386 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -57,6 +57,57 @@ type RegGrammar token a = forall p. ( Lexical token p , Alternator p ) => p a a + +{- | +>>> import Numeric.Natural (Natural) +>>> import Control.Lens (Prism', prism') +>>> :{ +data Arith + = Num Natural + | Add Arith Arith + | Mul Arith Arith + deriving stock (Eq, Ord, Show, Read) +:} + +>>> :{ +_Num :: Prism' Arith Natural +_Num = prism' Num (\case Num n -> Just n; _ -> Nothing) +_Add, _Mul :: Prism' Arith (Arith, Arith) +_Add = prism' (uncurry Add) (\case Add x y -> Just (x,y); _ -> Nothing) +_Mul = prism' (uncurry Mul) (\case Mul x y -> Just (x,y); _ -> Nothing) +:} + +>>> :{ +arithGrammar :: Grammar Char Arith +arithGrammar = ruleRec "arith" sumG + where + sumG arith = rule "sum" $ + chain1 Left _Add (sepBy (terminal "+")) (prodG arith) + prodG arith = rule "product" $ + chain1 Left _Mul (sepBy (terminal "*")) (factorG arith) + factorG arith = rule "factor" $ + numberG <|> terminal "(" >* arith *< terminal ")" + numberG = rule "number" $ + _Num . iso show read >? someP (asIn @Char DecimalNumber) +:} + +>>> [x | (x,"") <- parseG arithGrammar "1+2*3+4"] +[Add (Add (Num 1) (Mul (Num 2) (Num 3))) (Num 4)] + +>>> unparseG arithGrammar (Add (Num 1) (Mul (Num 2) (Num 3))) "" :: Maybe String +Just "1+2*3" + +>>> do pr <- printG arithGrammar (Num 69); return (pr "") :: Maybe String +Just "69" + +>>> putStringLn (regbnfG arithGrammar) +{start} = \q{arith} +{arith} = \q{sum} +{factor} = \q{number}|\(\q{arith}\) +{number} = \p{Nd}+ +{product} = \q{factor}(\*\q{factor})* +{sum} = \q{product}(\+\q{product})* +-} type Grammar token a = forall p. ( Lexical token p , forall x. BackusNaurForm (p x x) From d4c1eb010d4f0db5535b86dac7c4da99706eccb2 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 3 Feb 2026 21:40:33 -0800 Subject: [PATCH 247/282] SemVer --- distributors.cabal | 1 + test/spec/Examples/SemVer.hs | 84 ++++++++++++++++++++++++++++++++++++ test/spec/Main.hs | 2 + 3 files changed, 87 insertions(+) create mode 100644 test/spec/Examples/SemVer.hs diff --git a/distributors.cabal b/distributors.cabal index 729ac31..986dc01 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -187,6 +187,7 @@ test-suite spec Examples.Json Examples.Lambda Examples.RegString + Examples.SemVer Examples.SExpr Paths_distributors autogen-modules: diff --git a/test/spec/Examples/SemVer.hs b/test/spec/Examples/SemVer.hs new file mode 100644 index 0000000..e52ff58 --- /dev/null +++ b/test/spec/Examples/SemVer.hs @@ -0,0 +1,84 @@ +module Examples.SemVer + ( SemVer (..) + , semverGrammar + , semverExamples + ) where + +import Control.Lens.Grammar +import Control.Lens.Grammar.Boole +import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token +import Control.Lens.PartialIso +import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal +import Numeric.Natural + +-- | Semantic version structure following semver.org specification +-- Format: ..[-][+] +-- Example: 1.2.3-alpha.1+build.123 +data SemVer = SemVer + { semverMajor :: Natural -- e.g., 1 + , semverMinor :: Natural -- e.g., 2 + , semverPatch :: Natural -- e.g., 3 + , semverPreRelease :: [String] -- e.g., "alpha.1", "rc.2" + , semverBuildMetadata :: [String] -- e.g., "build.123", "20130313144700" + } + deriving (Eq, Ord, Show, Read) + +makeNestedPrisms ''SemVer + +-- | Grammar for semantic versions following semver.org specification +-- Regular grammar: +-- semver = version ["-" prerelease] ["+" buildmetadata] +-- version = number "." number "." number +-- number = digit+ +-- prerelease = identifier ("." identifier)* +-- buildmetadata = identifier ("." identifier)* +-- identifier = [0-9A-Za-z-]+ +semverGrammar :: Grammar Char SemVer +semverGrammar = _SemVer + >? numberG *< terminal "." + >*< numberG *< terminal "." + >*< numberG + >*< optionP [] (terminal "-" >* several1 (sepBy (terminal ".")) (someP charG)) + >*< optionP [] (terminal "+" >* several1 (sepBy (terminal ".")) (someP charG)) + where + -- Decimal natural number grammar + numberG :: Grammar Char Natural + numberG = iso show read >~ someP (asIn @Char DecimalNumber) + + -- Identifier character: alphanumeric or hyphen + charG = tokenClass $ orB + [ asIn LowercaseLetter + , asIn UppercaseLetter + , asIn DecimalNumber + , token '-' + ] + +semverExamples :: [(SemVer, String)] +semverExamples = + [ (SemVer 0 0 1 [] [], + "0.0.1") + , (SemVer 1 0 0 [] [], + "1.0.0") + , (SemVer 1 2 3 [] [], + "1.2.3") + , (SemVer 1 0 0 ["alpha"] [], + "1.0.0-alpha") + , (SemVer 1 0 0 ["alpha", "1"] [], + "1.0.0-alpha.1") + , (SemVer 1 0 0 ["0", "3", "7"] [], + "1.0.0-0.3.7") + , (SemVer 1 0 0 ["x", "7", "z", "92"] [], + "1.0.0-x.7.z.92") + , (SemVer 1 0 0 [] ["20130313144700"], + "1.0.0+20130313144700") + , (SemVer 1 0 0 [] ["exp", "sha", "5114f85"], + "1.0.0+exp.sha.5114f85") + , (SemVer 1 0 0 ["beta"] ["exp", "sha", "5114f85"], + "1.0.0-beta+exp.sha.5114f85") + , (SemVer 1 0 0 ["beta", "11"] ["exp", "sha", "5114f85"], + "1.0.0-beta.11+exp.sha.5114f85") + , (SemVer 2 1 5 ["rc", "1"] ["build", "123"], + "2.1.5-rc.1+build.123") + ] diff --git a/test/spec/Main.hs b/test/spec/Main.hs index 653003c..aa7a588 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -10,6 +10,7 @@ import Examples.Arithmetic import Examples.Json import Examples.SExpr import Examples.Lambda +import Examples.SemVer main :: IO () main = hspec $ do @@ -21,6 +22,7 @@ main = hspec $ do fromString str `shouldBe` rex -- testGrammar "regexGrammar" regexGrammar regexExamples + testGrammar "semverGrammar" semverGrammar semverExamples testGrammar "arithGrammar" arithGrammar arithExamples testGrammar "jsonGrammar" jsonGrammar jsonExamples testGrammar "sexprGrammar" sexprGrammar sexprExamples From 48cb2766e8c1db35c3ff409a588ff763867af52e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 3 Feb 2026 21:56:45 -0800 Subject: [PATCH 248/282] Update Json.hs --- test/spec/Examples/Json.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/spec/Examples/Json.hs b/test/spec/Examples/Json.hs index 53b5bb8..e8e617e 100644 --- a/test/spec/Examples/Json.hs +++ b/test/spec/Examples/Json.hs @@ -22,7 +22,7 @@ import Numeric.Natural data Json = JNull | JBool Bool - | JNumber Natural + | JNumber Natural -- simplified to only decimal natural numbers | JString String | JArray [Json] | JObject (Map String Json) From de60563a03ff5aef4b63fdc408e544c7a572c32f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Tue, 3 Feb 2026 22:19:42 -0800 Subject: [PATCH 249/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 41 +++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 9860386..7fec71a 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -53,6 +53,47 @@ import GHC.Exts import Prelude hiding (filter) import Witherable +{- | +>>> import Numeric.Natural (Natural) +>>> import Control.Lens (Iso', iso) +>>> :{ +data SemVer = SemVer + { major :: Natural -- e.g., 1 + , minor :: Natural -- e.g., 2 + , patch :: Natural -- e.g., 3 + , preRelease :: [String] -- e.g., "alpha.1", "rc.2" + , buildMetadata :: [String] -- e.g., "build.123", "20130313144700" + } + deriving (Eq, Ord, Show, Read) +:} + +>>> :set -XRecordWildCards +>>> :{ +_SemVer :: Iso' SemVer (Natural, (Natural, (Natural, ([String], [String])))) +_SemVer = iso + (\SemVer {..} -> (major, (minor, (patch, (preRelease, buildMetadata))))) + (\(major, (minor, (patch, (preRelease, buildMetadata)))) -> SemVer {..}) +:} + +>>> :{ +semverGrammar :: Grammar Char SemVer +semverGrammar = _SemVer + >? numberG *< terminal "." + >*< numberG *< terminal "." + >*< numberG + >*< optionP [] (terminal "-" >* several1 (sepBy (terminal ".")) (someP charG)) + >*< optionP [] (terminal "+" >* several1 (sepBy (terminal ".")) (someP charG)) + where + numberG = iso show read >~ someP (asIn @Char DecimalNumber) + charG = tokenClass $ orB + [ asIn LowercaseLetter + , asIn UppercaseLetter + , asIn DecimalNumber + , token '-' + ] +:} + +-} type RegGrammar token a = forall p. ( Lexical token p , Alternator p From 84dd6304219aee8e9619486371f5b5273919d20e Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 13:32:34 -0800 Subject: [PATCH 250/282] mawr --- src/Control/Lens/Grammar.hs | 122 +++++++++++++++++---- src/Control/Lens/Grammar/Boole.hs | 4 +- src/Control/Lens/Grammar/Kleene.hs | 2 +- src/Control/Lens/Internal/NestedPrismTH.hs | 1 + src/Control/Lens/PartialIso.hs | 6 +- src/Data/Profunctor/Distributor.hs | 16 +-- test/spec/Examples/Json.hs | 8 +- test/spec/Examples/Lambda.hs | 6 +- test/spec/Examples/SExpr.hs | 2 +- test/spec/Examples/SemVer.hs | 29 ++--- 10 files changed, 136 insertions(+), 60 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 7fec71a..93d86df 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -54,10 +54,15 @@ import Prelude hiding (filter) import Witherable {- | +A regular grammar may be constructed using +`Lexical` and `Alternator` combinators. +Let's see an example using +[semantic versioning](https://semver.org/). + >>> import Numeric.Natural (Natural) >>> import Control.Lens (Iso', iso) >>> :{ -data SemVer = SemVer +data SemVer = SemVer -- e.g., 2.1.5-rc.1+build.123 { major :: Natural -- e.g., 1 , minor :: Natural -- e.g., 2 , patch :: Natural -- e.g., 3 @@ -67,6 +72,15 @@ data SemVer = SemVer deriving (Eq, Ord, Show, Read) :} +We'd like to define an optic @_SemVer@, +corresponding to the constructor pattern @SemVer@. +Unfortunately, we can't use TemplateHaskell to generate it in [GHCi] +(https://wiki.haskell.org/GHC/GHCi), +which is used to test this documenation. +Normally we would write `makeNestedPrisms` @''SemVer@, +but here is equivalent explicit Haskell code instead. +Since @SemVer@ is a newtype, @_SemVer@ can be an `Control.Lens.Iso.Iso`. + >>> :set -XRecordWildCards >>> :{ _SemVer :: Iso' SemVer (Natural, (Natural, (Natural, ([String], [String])))) @@ -75,24 +89,81 @@ _SemVer = iso (\(major, (minor, (patch, (preRelease, buildMetadata)))) -> SemVer {..}) :} +Now we can build a `RegGrammar` for @SemVer@ using the "idiom" style of +`Applicative` parsing with a couple modifications. + >>> :{ -semverGrammar :: Grammar Char SemVer +semverGrammar :: RegGrammar Char SemVer semverGrammar = _SemVer - >? numberG *< terminal "." - >*< numberG *< terminal "." - >*< numberG - >*< optionP [] (terminal "-" >* several1 (sepBy (terminal ".")) (someP charG)) - >*< optionP [] (terminal "+" >* several1 (sepBy (terminal ".")) (someP charG)) + >? numberG + >*< terminal "." >* numberG + >*< terminal "." >* numberG + >*< option [] (terminal "-" >* identifiersG) + >*< option [] (terminal "+" >* identifiersG) where numberG = iso show read >~ someP (asIn @Char DecimalNumber) - charG = tokenClass $ orB - [ asIn LowercaseLetter - , asIn UppercaseLetter - , asIn DecimalNumber - , token '-' - ] + identifiersG = several1 (sepBy (terminal ".")) (someP charG) + charG = asIn LowercaseLetter + <|> asIn UppercaseLetter + <|> asIn DecimalNumber + <|> token '-' :} +Instead of using the constructor @SemVer@ with the `Functor` applicator `<$>`, +we use the optic @_SemVer@ we defined and the `Choice` applicator `>?`; +although, we could have used the `Profunctor` applicator `>~` instead, +because @_SemVer@ is an `Control.Lens.Iso.Iso`. A few `Alternative` +combinators like `<|>` work both `Functor`ially and `Profunctor`ially. + ++------------+---------------+ +| Functorial | Profunctorial | ++============+===============+ +| @SemVer@ | @_SemVer@ | ++------------+---------------+ +| `<$>` | `>?` | ++------------+---------------+ +| `*>` | `>*` | ++------------+---------------+ +| `<*` | `*<` | ++------------+---------------+ +| `<*>` | `>*<` | ++------------+---------------+ +| `<|>` | `<|>` | ++------------+---------------+ +| `option` | `option` | ++------------+---------------+ +| `choice` | `choice` | ++------------+---------------+ +| `many` | `manyP` | ++------------+---------------+ +| `some` | `someP` | ++------------+---------------+ +| `optional` | `optionalP` | ++------------+---------------+ + +You can generate a `RegString` from a `RegGrammar` with `regstringG`. + +>>> putStringLn (regstringG semverGrammar) +\p{Nd}+(.\p{Nd}+(.\p{Nd}+((-((\p{Ll}|\p{Lu}|\p{Nd}|-)+(.(\p{Ll}|\p{Lu}|\p{Nd}|-)+)*))?(\+((\p{Ll}|\p{Lu}|\p{Nd}|-)+(.(\p{Ll}|\p{Lu}|\p{Nd}|-)+)*))?))) + +You can also generate parsers and printers. + +>>> [parsed | (parsed, "") <- parseG semverGrammar "2.1.5-rc.1+build.123"] +[SemVer {major = 2, minor = 1, patch = 5, preRelease = ["rc","1"], buildMetadata = ["build","123"]}] + +Parsing `uncons`es tokens left-to-right, from the beginning of a string. +Unparsing, on the other hand, `snoc`s tokens left-to-right, to the end of a string. + +>>> unparseG semverGrammar (SemVer 1 0 0 ["alpha"] []) "SemVer: " :: Maybe String +Just "SemVer: 1.0.0-alpha" + +Printing, on the gripping hand, `cons`es tokens right-to-left, to the beginning of a string. + +>>> ($ " is the SemVer.") <$> printG semverGrammar (SemVer 1 2 3 [] []) :: Maybe String +Just "1.2.3 is the SemVer." + +`Profunctor`ial combinators give us correct-by-construction invertible parsers. +New `RegGrammar` generators can be defined with new instances of `Lexical` `Alternator`s. -} type RegGrammar token a = forall p. ( Lexical token p @@ -154,6 +225,7 @@ type Grammar token a = forall p. , forall x. BackusNaurForm (p x x) , Alternator p ) => p a a + type CtxGrammar token a = forall p. ( Lexical token p , forall x. BackusNaurForm (p x x) @@ -161,6 +233,14 @@ type CtxGrammar token a = forall p. , Monadic p , Filtrator p ) => p a a + +{- | +`Lexical` combinators include + +* `terminal` symbols from "Control.Lens.Grammar.Symbol"; +* `Tokenized` combinators from "Control.Lens.Grammar.Token"; +* `tokenClass` `BooleanAlgebra` combinators from "Control.Lens.Grammar.Boole". +-} type Lexical token p = ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) , forall x y. (x ~ token, y ~ token) => TokenAlgebra token (p x y) @@ -219,26 +299,26 @@ regexGrammar = _RegString >~ ruleRec "regex" altG altG rex = rule "alternate" $ chain1 Left (_RegExam . _Alternate) (sepBy (terminal "|")) (seqG rex) - seqG rex = rule "sequence" $ choiceP + seqG rex = rule "sequence" $ choice [ _Terminal >? manyP charG , chain Left _Sequence (_Terminal . _Empty) noSep (exprG rex) ] - exprG rex = rule "expression" $ choiceP + exprG rex = rule "expression" $ choice [ _KleeneOpt >? atomG rex *< terminal "?" , _KleeneStar >? atomG rex *< terminal "*" , _KleenePlus >? atomG rex *< terminal "+" , atomG rex ] - atomG rex = rule "atom" $ choiceP + atomG rex = rule "atom" $ choice [ _NonTerminal >? terminal "\\q{" >* manyP charG *< terminal "}" , _Terminal >? charG >:< asEmpty , _RegExam >? classG , terminal "(" >* rex *< terminal ")" ] - catTestG = rule "category-test" $ choiceP + catTestG = rule "category-test" $ choice [ _AsIn >? terminal "\\p{" >* categoryG *< terminal "}" , _NotAsIn >? several1 (sepBy (terminal "|")) { beginBy = terminal "\\P{" @@ -246,7 +326,7 @@ regexGrammar = _RegString >~ ruleRec "regex" altG } categoryG ] - categoryG = rule "category" $ choiceP + categoryG = rule "category" $ choice [ _LowercaseLetter >? terminal "Ll" , _UppercaseLetter >? terminal "Lu" , _TitlecaseLetter >? terminal "Lt" @@ -279,7 +359,7 @@ regexGrammar = _RegString >~ ruleRec "regex" altG , _NotAssigned >? terminal "Cn" ] - classG = rule "char-class" $ choiceP + classG = rule "char-class" $ choice [ _Fail >? failG , _Pass >? anyG , _OneOf >? oneOfG @@ -295,7 +375,7 @@ regexGrammar = _RegString >~ ruleRec "regex" altG notOneOfG = rule "not-one-of" $ terminal "[^" >* several1 noSep charG - >*< optionP (NotAsIn Set.empty) catTestG + >*< option (NotAsIn Set.empty) catTestG *< terminal "]" charG :: Grammar Char Char @@ -308,7 +388,7 @@ charG = rule "char" $ charsReserved = "()*+?[\\]^{|}" - charControlG = rule "char-control" $ choiceP + charControlG = rule "char-control" $ choice [ only '\NUL' >? terminal "NUL" , only '\SOH' >? terminal "SOH" , only '\STX' >? terminal "STX" diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index d496231..3febe78 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -67,11 +67,11 @@ andB = foldl' (>&&<) (fromBool True) orB :: (Foldable f, BooleanAlgebra b) => f b -> b orB = foldl' (>||<) (fromBool False) --- | universal qualification +-- | universal allB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b allB f = foldl' (\b a -> b >&&< f a) (fromBool True) --- | existential qualification +-- | existential anyB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b anyB f = foldl' (\b a -> b >||< f a) (fromBool False) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index 2dd4396..bb12b8b 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -63,7 +63,7 @@ class Monoid k => KleeneStarAlgebra k where orK :: (Foldable f, KleeneStarAlgebra k) => f k -> k orK = foldl' (>|<) zeroK --- | universal qualification +-- | universal anyK :: (Foldable f, KleeneStarAlgebra k) => (a -> k) -> f a -> k anyK f = foldl' (\b a -> b >|< f a) zeroK diff --git a/src/Control/Lens/Internal/NestedPrismTH.hs b/src/Control/Lens/Internal/NestedPrismTH.hs index 62f7b31..83e2520 100644 --- a/src/Control/Lens/Internal/NestedPrismTH.hs +++ b/src/Control/Lens/Internal/NestedPrismTH.hs @@ -44,6 +44,7 @@ import Prelude -- is that constructors with @n > 2@ arguments -- will use right-nested pairs, rather than a flat @n@-tuple. -- This makes them suitable for use on the left-hand-side of +-- `Control.Lens.PartialIso.>~`, -- `Control.Lens.PartialIso.>?` and `Control.Lens.PartialIso.>?<`; -- with repeated use of `Data.Profunctor.Distributor.>*<` -- on the right-hand-side, resulting in right-nested pairs. diff --git a/src/Control/Lens/PartialIso.hs b/src/Control/Lens/PartialIso.hs index 41d6bbb..64c927a 100644 --- a/src/Control/Lens/PartialIso.hs +++ b/src/Control/Lens/PartialIso.hs @@ -20,7 +20,7 @@ module Control.Lens.PartialIso , PartialIso' , APartialIso , PartialExchange (PartialExchange) - -- Combinators + -- * Combinators , partialIso , partialInvoluted , withPartialIso @@ -28,7 +28,7 @@ module Control.Lens.PartialIso , coPartialIso , crossPartialIso , altPartialIso - -- * Actions + -- * Applicators , (>?) , (?<) , (>?<) @@ -41,7 +41,7 @@ module Control.Lens.PartialIso , notNulled , eotMaybe , eotList - -- * Iterations + -- * Iterators , iterating , difoldl1 , difoldr1 diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index c835b22..50cc256 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -13,8 +13,8 @@ module Data.Profunctor.Distributor Distributor (..), dialt -- * Alternator , Alternator (..) - , choiceP - , optionP + , choice + , option -- * Homogeneous , Homogeneous (..) -- * SepBy @@ -347,13 +347,13 @@ class (Choice p, Distributor p, forall x. Alternative (p x)) someP :: p a b -> p [a] [b] someP p = _Cons >? p >*< manyP p --- | Combines all `Alternator` choices in the specified list. -choiceP :: (Foldable f, Alternator p) => f (p a b) -> p a b -choiceP = foldl' (<|>) empty +-- | Combines all `Alternative` choices in the specified list. +choice :: (Foldable f, Alternative p) => f (p a) -> p a +choice = foldl' (<|>) empty --- | Perform an `Alternator` action or return a default value. -optionP :: Alternator p => b {- ^ default value -} -> p a b -> p a b -optionP b p = p <|> pure b +-- | Perform an `Alternative` action or return a default value. +option :: Alternative p => a {- ^ default value -} -> p a -> p a +option a p = p <|> pure a instance (Alternator p, Applicative f) => Alternator (WrappedPafb f p) where diff --git a/test/spec/Examples/Json.hs b/test/spec/Examples/Json.hs index e8e617e..e8ffc44 100644 --- a/test/spec/Examples/Json.hs +++ b/test/spec/Examples/Json.hs @@ -40,7 +40,7 @@ jsonGrammar = ruleRec "json" elementG ws >* valueG json *< ws -- value = object | array | string | number | "true" | "false" | "null" - valueG json = rule "value" $ choiceP + valueG json = rule "value" $ choice [ _JNull >? terminal "null" , _JBool . only True >? terminal "true" , _JBool . only False >? terminal "false" @@ -51,7 +51,7 @@ jsonGrammar = ruleRec "json" elementG ] -- object = '{' ws '}' | '{' members '}' - objectG json = rule "object" $ choiceP + objectG json = rule "object" $ choice [ only Map.empty >? terminal "{" >* ws >* terminal "}" , iso Map.toList Map.fromList >~ @@ -67,7 +67,7 @@ jsonGrammar = ruleRec "json" elementG ws >* stringG *< ws *< terminal ":" >*< elementG json -- array = '[' ws ']' | '[' elements ']' - arrayG json = rule "array" $ choiceP + arrayG json = rule "array" $ choice [ only [] >? terminal "[" >* ws >* terminal "]" , terminal "[" >* elementsG json *< terminal "]" ] @@ -86,7 +86,7 @@ jsonGrammar = ruleRec "json" elementG <|> terminal "\\" >* escapeG -- escape = '"' | '\' | '/' | 'b' | 'f' | 'n' | 'r' | 't' - escapeG = rule "escape" $ choiceP + escapeG = rule "escape" $ choice [ only '"' >? terminal "\"" , only '\\' >? terminal "\\" , only '/' >? terminal "/" diff --git a/test/spec/Examples/Lambda.hs b/test/spec/Examples/Lambda.hs index 77947f5..1a39dfa 100644 --- a/test/spec/Examples/Lambda.hs +++ b/test/spec/Examples/Lambda.hs @@ -28,7 +28,7 @@ lambdaGrammar :: Grammar Char Lambda lambdaGrammar = ruleRec "lambda" termG where -- Top level term: lambda abstraction or application - termG term = rule "term" $ choiceP + termG term = rule "term" $ choice [ lamG term , appG term ] @@ -43,7 +43,7 @@ lambdaGrammar = ruleRec "lambda" termG chain1 Left _App (sepBy (reqLike ' ')) (atomG term) -- Atomic term: variable or parenthesized term - atomG term = rule "atom" $ choiceP + atomG term = rule "atom" $ choice [ _Var >? varNameG , terminal "(" >* term *< terminal ")" ] @@ -51,7 +51,7 @@ lambdaGrammar = ruleRec "lambda" termG -- Variable name: starts with lowercase letter, -- followed by alphanumeric or underscore varNameG = rule "varname" $ asIn LowercaseLetter >:< - manyP (choiceP (token '_' : map asIn [LowercaseLetter, UppercaseLetter, DecimalNumber])) + manyP (choice (token '_' : map asIn [LowercaseLetter, UppercaseLetter, DecimalNumber])) -- | Example lambda calculus terms for testing lambdaExamples :: [(Lambda, String)] diff --git a/test/spec/Examples/SExpr.hs b/test/spec/Examples/SExpr.hs index 3dc53f0..b682a5a 100644 --- a/test/spec/Examples/SExpr.hs +++ b/test/spec/Examples/SExpr.hs @@ -25,7 +25,7 @@ makePrisms ''SExpr -- | Grammar for S-expressions sexprGrammar :: Grammar Char SExpr -sexprGrammar = ruleRec "sexpr" $ \sexpr -> choiceP +sexprGrammar = ruleRec "sexpr" $ \sexpr -> choice [ _Atom >? atomG , _List >? listG sexpr ] diff --git a/test/spec/Examples/SemVer.hs b/test/spec/Examples/SemVer.hs index e52ff58..1078dbf 100644 --- a/test/spec/Examples/SemVer.hs +++ b/test/spec/Examples/SemVer.hs @@ -4,8 +4,8 @@ module Examples.SemVer , semverExamples ) where +import Control.Applicative import Control.Lens.Grammar -import Control.Lens.Grammar.Boole import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Control.Lens.PartialIso @@ -35,25 +35,20 @@ makeNestedPrisms ''SemVer -- prerelease = identifier ("." identifier)* -- buildmetadata = identifier ("." identifier)* -- identifier = [0-9A-Za-z-]+ -semverGrammar :: Grammar Char SemVer +semverGrammar :: RegGrammar Char SemVer semverGrammar = _SemVer - >? numberG *< terminal "." - >*< numberG *< terminal "." - >*< numberG - >*< optionP [] (terminal "-" >* several1 (sepBy (terminal ".")) (someP charG)) - >*< optionP [] (terminal "+" >* several1 (sepBy (terminal ".")) (someP charG)) + >? numberG + >*< terminal "." >* numberG + >*< terminal "." >* numberG + >*< option [] (terminal "-" >* identifiersG) + >*< option [] (terminal "+" >* identifiersG) where - -- Decimal natural number grammar - numberG :: Grammar Char Natural numberG = iso show read >~ someP (asIn @Char DecimalNumber) - - -- Identifier character: alphanumeric or hyphen - charG = tokenClass $ orB - [ asIn LowercaseLetter - , asIn UppercaseLetter - , asIn DecimalNumber - , token '-' - ] + identifiersG = several1 (sepBy (terminal ".")) (someP charG) + charG = asIn LowercaseLetter + <|> asIn UppercaseLetter + <|> asIn DecimalNumber + <|> token '-' semverExamples :: [(SemVer, String)] semverExamples = From 3967f98392fa155216d322c06fe9fff98d325d97 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 14:15:10 -0800 Subject: [PATCH 251/282] Update Token.hs --- src/Control/Lens/Grammar/Token.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 8319eb0..46a3922 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -109,8 +109,6 @@ satisfy satisfy f = satisfied f >?< anyToken {- | A specified stream of `tokens`. -It can be used as a default definition for the `Data.String.fromString` -method of `Data.String.IsString` when `Tokenized` `Char` `Char`. -} tokens :: ( Foldable f, Tokenized a (p a a) From ff951025f47cdf172843403b450f4798a672eb6a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 19:16:17 -0800 Subject: [PATCH 252/282] tests and fixes --- src/Control/Lens/Grammar.hs | 91 +++++++++++++++++++++++++++++++ src/Control/Lens/Grammar/Boole.hs | 15 ++--- src/Control/Lens/Grammar/Token.hs | 3 +- test/spec/Examples/RegString.hs | 33 +++++++++++ test/spec/Main.hs | 13 +---- 5 files changed, 132 insertions(+), 23 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 93d86df..87a4ea4 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -30,6 +30,7 @@ module Control.Lens.Grammar , unparseG -- * Utility , putStringLn + , getStringLn ) where import Control.Applicative @@ -246,6 +247,93 @@ type Lexical token p = , forall x y. (x ~ token, y ~ token) => TokenAlgebra token (p x y) ) :: Constraint +{- | `RegString`s are an embedded domain specific language +for regular expression strings. +Since they are strings, they have a string-like interface. + +>>> let rex = fromString "ab|c" :: RegString +>>> putStringLn rex +ab|c +>>> rex +"ab|c" + +`RegString`s can be generated from `RegGrammar`s with `regstringG` + +>>> regstringG (terminal "a" >* terminal "b" <|> terminal "c") +"ab|c" + +`RegString`s are actually stored as an algebraic datatype, `RegEx`. + +>>> runRegString rex +RegExam (Alternate (Terminal "ab") (Terminal "c")) + +`RegString`s are similar to regular expression strings in many other +programming languages. We can use them to see if a word and pattern +are `Matching`. + +>>> "ab" =~ rex +True +>>> "c" =~ rex +True +>>> "xyz" =~ rex +False + +Like `RegGrammar`s, `RegString`s can use all the `Lexical` combinators. +Unlike `RegGrammar`s, instead of using `Monoidal` and `Alternator` combinators, +`RegString`s use `Monoid` and `KleeneStarAlgebra` combinators. + +>>> terminal "a" <> terminal "b" >|< terminal "c" :: RegString +"ab|c" +>>> mempty :: RegString +"" + +Since `RegString`s are a `KleeneStarAlgebra`, +they support Kleene quantifiers. + +>>> starK rex +"(ab|c)*" +>>> plusK rex +"(ab|c)+" +>>> optK rex +"(ab|c)?" + +Like other regular expression languages, `RegString`s support +character classes. + +>>> oneOf "abc" :: RegString +"[abc]" +>>> notOneOf "abc" :: RegString +"[^abc]" + +The character classes are used for failure, matching no character or string, +as well as the wildcard, matching any single character. + +>>> zeroK :: RegString +"[]" +>>> anyToken :: RegString +"[^]" + +Additional forms of character classes test for character categories. + +>>> asIn LowercaseLetter :: RegString +"\\p{Ll}" +>>> notAsIn Control :: RegString +"\\P{Cc}" + +`KleeneStarAlgebra`s support alternation `>|<`, +and the `Tokenized` combinators are all negatable. +However, we'd like to be able to take the conjunctive +intersection of character classes as well. +Our `RegString`s can combine character classes +using `BooleanAlgebra` combinators. + +>>> tokenClass (notOneOf "abc" >&&< notOneOf "xyz") :: RegString +"[^abcxyz]" +>>> tokenClass (notOneOf "#$%" >&&< notAsIn Control) :: RegString +"[^#$%\\P{Cc}]" +>>> tokenClass (notAsIn MathSymbol >&&< notAsIn Control) :: RegString +"\\P{Sm|Cc}" +-} newtype RegString = RegString {runRegString :: RegEx Char} deriving newtype ( Eq, Ord @@ -532,6 +620,9 @@ unparseG parsor = unparseP parsor putStringLn :: (IsList string, Item string ~ Char) => string -> IO () putStringLn = putStrLn . toList +getStringLn :: (IsList string, Item string ~ Char) => IO string +getStringLn = fromList <$> getLine + instance IsList RegString where type Item RegString = Char fromList diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index 3febe78..a99b0d0 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -25,7 +25,6 @@ import Control.Applicative import Control.Lens.Grammar.Kleene import Control.Lens.Grammar.Token import Data.Foldable -import Data.Function (on) import Data.Monoid import Data.Profunctor import Data.Profunctor.Distributor @@ -148,14 +147,8 @@ instance Categorized token notB Pass = Fail notB (Alternate (TokenTest x) (TokenTest y)) = x >&&< y notB (OneOf xs) = NotOneOf xs (NotAsIn Set.empty) - notB (NotOneOf xs (AsIn y)) = - (Alternate `on` TokenTest) - (OneOf xs) - (NotOneOf Set.empty (NotAsIn (Set.singleton y))) - notB (NotOneOf xs (NotAsIn ys)) = - foldl' (Alternate `on` TokenTest) - (OneOf xs) - (Set.map (NotOneOf Set.empty . AsIn) ys) + notB (NotOneOf xs (AsIn y)) = oneOf xs >||< notAsIn y + notB (NotOneOf xs (NotAsIn ys)) = oneOf xs >||< anyB asIn ys _ >&&< Fail = Fail Fail >&&< _ = Fail x >&&< Pass = x @@ -197,13 +190,13 @@ instance Categorized token Pass >||< _ = Pass x >||< Alternate y z = Alternate (TokenTest x) (TokenTest (Alternate y z)) Alternate x y >||< z = Alternate (TokenTest (Alternate x y)) (TokenTest z) - OneOf xs >||< OneOf ys = OneOf (Set.union xs ys) + OneOf xs >||< OneOf ys = oneOf (Set.union xs ys) OneOf xs >||< NotOneOf ys z = Alternate (TokenTest (OneOf xs)) (TokenTest (NotOneOf ys z)) NotOneOf xs y >||< OneOf zs = Alternate (TokenTest (NotOneOf xs y)) (TokenTest (OneOf zs)) NotOneOf xs (NotAsIn ys) >||< NotOneOf ws (NotAsIn zs) = - NotOneOf (Set.intersection xs ws) (NotAsIn (Set.intersection ys zs)) + notOneOf (Set.intersection xs ws) >&&< allB notAsIn (Set.intersection ys zs) NotOneOf xs (AsIn y) >||< NotOneOf ws (AsIn z) = if y == z then NotOneOf (Set.intersection xs ws) (AsIn y) else Alternate diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 46a3922..83ac5da 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -108,8 +108,7 @@ satisfy => (a -> Bool) -> p a a satisfy f = satisfied f >?< anyToken -{- | A specified stream of `tokens`. --} +{- | A specified stream of `tokens`. -} tokens :: ( Foldable f, Tokenized a (p a a) , Monoidal p, Choice p diff --git a/test/spec/Examples/RegString.hs b/test/spec/Examples/RegString.hs index 107f51c..b3070ad 100644 --- a/test/spec/Examples/RegString.hs +++ b/test/spec/Examples/RegString.hs @@ -26,7 +26,40 @@ regexExamples = , (terminal "", "") , (optK (terminal "abc"), "(abc)?") , (optK (terminal "abc") <> nonTerminal "xyz", "(abc)?\\q{xyz}") + + -- Boolean OR (>||<) operations , (tokenClass (oneOf "abc" >||< oneOf "xyz"), "[abcxyz]") + , (tokenClass (notOneOf "abc" >||< notOneOf "xyz"), "[^]") + , (tokenClass (oneOf "abc" >||< notOneOf "xyz"), "[abc]|[^xyz]") + , (tokenClass (notOneOf "abc" >||< oneOf "xyz"), "[^abc]|[xyz]") + , (tokenClass (asIn UppercaseLetter >||< asIn LowercaseLetter), "\\p{Lu}|\\p{Ll}") + , (tokenClass (notAsIn Control >||< notAsIn Space), "[^]") + , (tokenClass (oneOf "abc" >||< asIn DecimalNumber), "[abc]|\\p{Nd}") + , (tokenClass (notOneOf "xyz" >||< notAsIn UppercaseLetter), "[^]") + + -- Boolean AND (>&&<) operations + , (tokenClass (oneOf "abcdef" >&&< oneOf "def123"), "[def]") + , (tokenClass (notOneOf "abc" >&&< notOneOf "xyz"), "[^abcxyz]") + , (tokenClass (oneOf "abc" >&&< notOneOf "bc"), "[a]") , (tokenClass (notOneOf "abc" >&&< asIn LowercaseLetter), "[^abc\\p{Ll}]") , (tokenClass (notOneOf "abc" >&&< notAsIn Control), "[^abc\\P{Cc}]") + , (tokenClass (asIn UppercaseLetter >&&< notOneOf "XYZ"), "[^XYZ\\p{Lu}]") + , (tokenClass (notAsIn Control >&&< notAsIn Space), "\\P{Zs|Cc}") + , (tokenClass (oneOf "0123456789" >&&< asIn DecimalNumber), "[0123456789]") + + -- Boolean NOT (notB) operations + , (tokenClass (notB (oneOf "abc")), "[^abc]") + , (tokenClass (notB (notOneOf "abc")), "[abc]") + , (tokenClass (notB (oneOf "abc" >||< oneOf "xyz")), "[^abcxyz]") + , (tokenClass (notB (asIn UppercaseLetter)), "\\P{Lu}") + -- , (tokenClass (notB (notAsIn Control)), "\\p{Cc}") + , (tokenClass (notB (notOneOf "abc" >&&< asIn LowercaseLetter)), "[abc]|\\P{Ll}") + + -- fromBool operations + , (tokenClass (fromBool True), "[^]") + , (tokenClass (fromBool False), "[]") + + -- Complex combinations + , (tokenClass (notOneOf "abc" >&&< (asIn LowercaseLetter >||< asIn UppercaseLetter)), "[^abc\\p{Ll}]|\\p{Lu}") + , (tokenClass ((oneOf "123" >||< asIn DecimalNumber) >&&< notOneOf "789"), "[123]|[^789\\p{Nd}]") ] diff --git a/test/spec/Main.hs b/test/spec/Main.hs index aa7a588..d6c3063 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -1,8 +1,8 @@ module Main (main) where import Data.Foldable hiding (toList) +import Data.Maybe (listToMaybe) import Control.Lens.Grammar -import GHC.Exts import Test.Hspec import Examples.RegString @@ -14,14 +14,7 @@ import Examples.SemVer main :: IO () main = hspec $ do - describe "regexGrammar" $ - for_ regexExamples $ \(rex, str) -> do - it ("should print " <> show (runRegString rex) <> " correctly") $ - toList rex `shouldBe` str - it ("should parse " <> str <> " correctly") $ do - fromString str `shouldBe` rex - - -- testGrammar "regexGrammar" regexGrammar regexExamples + testGrammar "regexGrammar" regexGrammar regexExamples testGrammar "semverGrammar" semverGrammar semverExamples testGrammar "arithGrammar" arithGrammar arithExamples testGrammar "jsonGrammar" jsonGrammar jsonExamples @@ -34,7 +27,7 @@ testGrammar name grammar examples = for_ examples $ \(expectedSyntax, expectedString) -> do it ("should parse from " <> expectedString <> " correctly") $ do let actualSyntax = [parsed | (parsed, "") <- parseG grammar expectedString] - actualSyntax `shouldBe` [expectedSyntax] + listToMaybe actualSyntax `shouldBe` Just expectedSyntax it ("should unparse to " <> expectedString <> " correctly") $ do let actualString = unparseG grammar expectedSyntax "" actualString `shouldBe` Just expectedString From 7e96281391f06f80604780542882f3d4c1276e77 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 19:16:40 -0800 Subject: [PATCH 253/282] Update RegString.hs --- test/spec/Examples/RegString.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/spec/Examples/RegString.hs b/test/spec/Examples/RegString.hs index b3070ad..cbd1278 100644 --- a/test/spec/Examples/RegString.hs +++ b/test/spec/Examples/RegString.hs @@ -52,7 +52,7 @@ regexExamples = , (tokenClass (notB (notOneOf "abc")), "[abc]") , (tokenClass (notB (oneOf "abc" >||< oneOf "xyz")), "[^abcxyz]") , (tokenClass (notB (asIn UppercaseLetter)), "\\P{Lu}") - -- , (tokenClass (notB (notAsIn Control)), "\\p{Cc}") + , (tokenClass (notB (notAsIn Control)), "\\p{Cc}") , (tokenClass (notB (notOneOf "abc" >&&< asIn LowercaseLetter)), "[abc]|\\P{Ll}") -- fromBool operations From 0af76f87b93842d7218c622a7593d5e330abf491 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 19:47:29 -0800 Subject: [PATCH 254/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 87a4ea4..b6cc5ec 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -61,7 +61,6 @@ Let's see an example using [semantic versioning](https://semver.org/). >>> import Numeric.Natural (Natural) ->>> import Control.Lens (Iso', iso) >>> :{ data SemVer = SemVer -- e.g., 2.1.5-rc.1+build.123 { major :: Natural -- e.g., 1 @@ -83,6 +82,7 @@ but here is equivalent explicit Haskell code instead. Since @SemVer@ is a newtype, @_SemVer@ can be an `Control.Lens.Iso.Iso`. >>> :set -XRecordWildCards +>>> import Control.Lens (Iso', iso) >>> :{ _SemVer :: Iso' SemVer (Natural, (Natural, (Natural, ([String], [String])))) _SemVer = iso @@ -313,7 +313,7 @@ as well as the wildcard, matching any single character. >>> anyToken :: RegString "[^]" -Additional forms of character classes test for character categories. +Additional forms of character classes test for character's `GeneralCategory`. >>> asIn LowercaseLetter :: RegString "\\p{Ll}" @@ -322,17 +322,21 @@ Additional forms of character classes test for character categories. `KleeneStarAlgebra`s support alternation `>|<`, and the `Tokenized` combinators are all negatable. -However, we'd like to be able to take the conjunctive +However, we'd like to be able to take the intersection of character classes as well. -Our `RegString`s can combine character classes +`RegString`s can combine character's `tokenClass`es using `BooleanAlgebra` combinators. >>> tokenClass (notOneOf "abc" >&&< notOneOf "xyz") :: RegString "[^abcxyz]" +>>> tokenClass (oneOf "abcxyz" >&&< notOneOf "xyz") :: RegString +"[abc]" >>> tokenClass (notOneOf "#$%" >&&< notAsIn Control) :: RegString "[^#$%\\P{Cc}]" >>> tokenClass (notAsIn MathSymbol >&&< notAsIn Control) :: RegString "\\P{Sm|Cc}" +>>> tokenClass (notB (oneOf "xyz")) :: RegString +"[^xyz]" -} newtype RegString = RegString {runRegString :: RegEx Char} deriving newtype From 73a3fe6dade6a34f6f08160809ef2be59aa9ef3d Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 19:47:32 -0800 Subject: [PATCH 255/282] Update RegString.hs --- test/spec/Examples/RegString.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/spec/Examples/RegString.hs b/test/spec/Examples/RegString.hs index cbd1278..11edf62 100644 --- a/test/spec/Examples/RegString.hs +++ b/test/spec/Examples/RegString.hs @@ -62,4 +62,6 @@ regexExamples = -- Complex combinations , (tokenClass (notOneOf "abc" >&&< (asIn LowercaseLetter >||< asIn UppercaseLetter)), "[^abc\\p{Ll}]|\\p{Lu}") , (tokenClass ((oneOf "123" >||< asIn DecimalNumber) >&&< notOneOf "789"), "[123]|[^789\\p{Nd}]") + -- , (tokenClass (notB (oneOf "&%$" >||< asIn MathSymbol)), "") + -- FIXME ^^^ ] From ff1b2a877d989747a80bd1e4717f50e3ec74b079 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 20:09:34 -0800 Subject: [PATCH 256/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index b6cc5ec..c0ca591 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -240,7 +240,7 @@ type CtxGrammar token a = forall p. * `terminal` symbols from "Control.Lens.Grammar.Symbol"; * `Tokenized` combinators from "Control.Lens.Grammar.Token"; -* `tokenClass` `BooleanAlgebra` combinators from "Control.Lens.Grammar.Boole". +* `tokenClass`es from "Control.Lens.Grammar.Boole". -} type Lexical token p = ( forall x y. (x ~ (), y ~ ()) => TerminalSymbol token (p x y) @@ -313,7 +313,7 @@ as well as the wildcard, matching any single character. >>> anyToken :: RegString "[^]" -Additional forms of character classes test for character's `GeneralCategory`. +Additional forms of character classes test for a character's `GeneralCategory`. >>> asIn LowercaseLetter :: RegString "\\p{Ll}" From c35512f892b2f8a43a0458e382a68b474c2c731a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 20:09:42 -0800 Subject: [PATCH 257/282] anyLike --- src/Control/Lens/Grammar/Token.hs | 8 ++++---- test/spec/Examples/Json.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 83ac5da..52fa009 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -15,7 +15,7 @@ module Control.Lens.Grammar.Token , tokens -- * Like , oneLike - , manyLike + , anyLike , optLike , reqLike -- * Categorized @@ -132,14 +132,14 @@ oneLike a = dimap preF postF catA catA = asIn (categorize a) {- | -`manyLike` consumes zero or more tokens +`anyLike` consumes zero or more tokens of a given token's category while parsing, and produces no tokens printing. -} -manyLike +anyLike :: forall token p. (Distributor p, Tokenized token (p token token)) => token -> p () () -manyLike a = dimap preF postF (manyP catA) +anyLike a = dimap preF postF (manyP catA) where preF _ = []::[token] postF (_::[token]) = () diff --git a/test/spec/Examples/Json.hs b/test/spec/Examples/Json.hs index e8ffc44..413c1fc 100644 --- a/test/spec/Examples/Json.hs +++ b/test/spec/Examples/Json.hs @@ -102,7 +102,7 @@ jsonGrammar = ruleRec "json" elementG iso show read >~ someP (asIn @Char DecimalNumber) -- Simplified: zero or more whitespace characters - ws = rule "ws" $ manyLike ' ' + ws = rule "ws" $ anyLike ' ' -- | Example JSON values for testing jsonExamples :: [(Json, String)] From 8be4f433d5d2c6fe46c084a4eb6fc49d5bb29635 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 20:47:37 -0800 Subject: [PATCH 258/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 38 +++++++++++++++++++++++++++++++++---- 1 file changed, 34 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index c0ca591..a2c6865 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -30,7 +30,6 @@ module Control.Lens.Grammar , unparseG -- * Utility , putStringLn - , getStringLn ) where import Control.Applicative @@ -577,12 +576,30 @@ regbnfGrammar = rule "regbnf" $ _RegBnf . _Bnf >~ ruleG = rule "rule" $ terminal "{" >* manyP charG *< terminal "} = " >*< regexGrammar +{- | `regstringG` is a generates a `RegString` from a regular grammar. +Since context-free `Grammar`s aren't necessarily regular, +the type system will prevent `regstringG` +from being applied to a context-free `Grammar`. +-} regstringG :: RegGrammar Char a -> RegString regstringG rex = runGrammor rex +{- | `regbnfG` generates a `RegBnf` from a context-free `Grammar`. +Since context-sensitive `Grammar`s aren't context-free, +the type system will prevent `regbnfG` from being applied to a `CtxGrammar`. +It can apply to a `RegGrammar`. +-} regbnfG :: Grammar Char a -> RegBnf regbnfG bnf = runGrammor bnf +{- | `printG` generates a printer from a `CtxGrammar`. +Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s, +the type system will allow `printG` to be applies to them. + +Running the printer on a value returns a function +that `cons`es tokens at the beginning of an input string, +from right to left. +-} printG :: ( Cons string string token token , IsList string @@ -595,6 +612,14 @@ printG => CtxGrammar token a -> a -> m (string -> string) printG printor = printP printor +{- | `parseG` generates a parser from a `CtxGrammar`. +Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s, +the type system will allow `parseG` to be applies to them. + +Running the parser on an input string value `uncons`es +tokens from the beginning of an input string from left to right, +returning a value and the remaining output string. +-} parseG :: ( Cons string string token token , Snoc string string token token @@ -608,6 +633,14 @@ parseG => CtxGrammar token a -> string -> m (a, string) parseG parsor = parseP parsor +{- | `unparseG` generates an unparser from a `CtxGrammar`. +Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s, +the type system will allow `unparseG` to be applies to them. + +Running the unparser on a value and an input string +`snoc`s tokens at the end of the string, from left to right, +returning the output string. +-} unparseG :: ( Cons string string token token , Snoc string string token token @@ -624,9 +657,6 @@ unparseG parsor = unparseP parsor putStringLn :: (IsList string, Item string ~ Char) => string -> IO () putStringLn = putStrLn . toList -getStringLn :: (IsList string, Item string ~ Char) => IO string -getStringLn = fromList <$> getLine - instance IsList RegString where type Item RegString = Char fromList From 2f21a7faa2f523c40075f0ef4d26fbbf070c52a1 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 22:09:14 -0800 Subject: [PATCH 259/282] docs --- src/Control/Lens/Grammar.hs | 96 ++++++++++++++++++---------------- src/Data/Profunctor/Grammar.hs | 12 +++-- 2 files changed, 59 insertions(+), 49 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index a2c6865..6eaad20 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -170,9 +170,18 @@ type RegGrammar token a = forall p. , Alternator p ) => p a a -{- | +{- | Context-free `Grammar`s add two capabilities to `RegGrammar`s, +coming from the `BackusNaurForm` interface + +* `rule` abstraction, +* and general recursion. + +`regexGrammar` and `regbnfGrammar` are examples of context-free +`Grammar`s. Regular expressions are an form of an expression algebra. +Let's see a similar but simpler example, +the algebra of arithmetic expressions of natural numbers. + >>> import Numeric.Natural (Natural) ->>> import Control.Lens (Prism', prism') >>> :{ data Arith = Num Natural @@ -181,6 +190,9 @@ data Arith deriving stock (Eq, Ord, Show, Read) :} +Here are `Control.Lens.Prism.Prism`s for the constructor patterns. + +>>> import Control.Lens (Prism', prism') >>> :{ _Num :: Prism' Arith Natural _Num = prism' Num (\case Num n -> Just n; _ -> Nothing) @@ -189,6 +201,12 @@ _Add = prism' (uncurry Add) (\case Add x y -> Just (x,y); _ -> Nothing) _Mul = prism' (uncurry Mul) (\case Mul x y -> Just (x,y); _ -> Nothing) :} +Now we can build a `Grammar` for @Arith@ +by combining "idiom" style with named `rule`s, +and tying the recursive loop +(caused by parenthesization) +with `ruleRec`. + >>> :{ arithGrammar :: Grammar Char Arith arithGrammar = ruleRec "arith" sumG @@ -365,7 +383,11 @@ makeNestedPrisms ''GeneralCategory makeNestedPrisms ''RegString makeNestedPrisms ''RegBnf -{- | +{- | `regexGrammar` is a context-free `Grammar` for `RegString`s. +It can't be a `RegGrammar`, since `RegString`s include parenthesization. +But [balanced parentheses](https://en.wikipedia.org/wiki/Dyck_language) +are a context-free language. + >>> putStringLn (regbnfG regexGrammar) {start} = \q{regex} {alternate} = \q{sequence}(\|\q{sequence})* @@ -576,10 +598,9 @@ regbnfGrammar = rule "regbnf" $ _RegBnf . _Bnf >~ ruleG = rule "rule" $ terminal "{" >* manyP charG *< terminal "} = " >*< regexGrammar -{- | `regstringG` is a generates a `RegString` from a regular grammar. -Since context-free `Grammar`s aren't necessarily regular, -the type system will prevent `regstringG` -from being applied to a context-free `Grammar`. +{- | `regstringG` generates a `RegString` from a regular grammar. +Since context-free `Grammar`s and `CtxGrammar`s aren't necessarily regular, +the type system will prevent `regstringG` from being applied to them. -} regstringG :: RegGrammar Char a -> RegString regstringG rex = runGrammor rex @@ -594,64 +615,51 @@ regbnfG bnf = runGrammor bnf {- | `printG` generates a printer from a `CtxGrammar`. Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s, -the type system will allow `printG` to be applies to them. - -Running the printer on a value returns a function +the type system will allow `printG` to be applied to them. +Running the printer on a syntax value returns a function that `cons`es tokens at the beginning of an input string, from right to left. -} printG - :: ( Cons string string token token - , IsList string - , Item string ~ token - , Categorized token - , Alternative m - , Monad m - , Filterable m - ) - => CtxGrammar token a -> a -> m (string -> string) + :: Cons string string token token + => (IsList string, Item string ~ token, Categorized token) + => (Alternative m, Monad m, Filterable m) + => CtxGrammar token a + -> a {- ^ syntax -} + -> m (string -> string) printG printor = printP printor {- | `parseG` generates a parser from a `CtxGrammar`. Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s, -the type system will allow `parseG` to be applies to them. - +the type system will allow `parseG` to be applied to them. Running the parser on an input string value `uncons`es tokens from the beginning of an input string from left to right, returning a value and the remaining output string. -} parseG - :: ( Cons string string token token - , Snoc string string token token - , IsList string - , Item string ~ token - , Categorized token - , Alternative m - , Monad m - , Filterable m - ) - => CtxGrammar token a -> string -> m (a, string) + :: (Cons string string token token, Snoc string string token token) + => (IsList string, Item string ~ token, Categorized token) + => (Alternative m, Monad m, Filterable m) + => CtxGrammar token a + -> string {- ^ input -} + -> m (a, string) parseG parsor = parseP parsor {- | `unparseG` generates an unparser from a `CtxGrammar`. Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s, -the type system will allow `unparseG` to be applies to them. - -Running the unparser on a value and an input string +the type system will allow `unparseG` to be applied to them. +Running the unparser on a syntax value and an input string `snoc`s tokens at the end of the string, from left to right, returning the output string. -} unparseG - :: ( Cons string string token token - , Snoc string string token token - , IsList string - , Item string ~ token - , Categorized token - , Alternative m - , Monad m - , Filterable m - ) - => CtxGrammar token a -> a -> string -> m string + :: (Cons string string token token, Snoc string string token token) + => (IsList string, Item string ~ token, Categorized token) + => (Alternative m, Monad m, Filterable m) + => CtxGrammar token a + -> a {- ^ syntax -} + -> string {- ^ input -} + -> m string unparseG parsor = unparseP parsor putStringLn :: (IsList string, Item string ~ Char) => string -> IO () diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 349b289..7de9470 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -46,13 +46,14 @@ import Witherable newtype Parsor s f a b = Parsor {runParsor :: Maybe a -> s -> f (b,s)} -- | Run the parser on an input string, --- popping tokens from the beginning of the string, --- returning a value and the remaining string. +-- `uncons`ing tokens from the beginning of the string, +-- from left to right, returning a value and the remaining string. parseP :: Parsor s f a a -> s -> f (a,s) parseP (Parsor f) = f Nothing --- | Run the parser in reverse on a value and an input string, --- placing tokens at the end of the string and returning the new string. +-- | Run the parser in reverse on a value and an input string; +-- `snoc`ing tokens at the end of the string, from left to right, +-- and returning the new string. unparseP :: Functor f => Parsor s f a a -> a -> s -> f s unparseP (Parsor f) a = fmap snd . f (Just a) @@ -60,7 +61,8 @@ unparseP (Parsor f) a = fmap snd . f (Just a) newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)} -- | Run the printer on a value, returning a function --- that places tokens at the beginning of an input string. +-- that `cons`es tokens at the beginning of an input string, +-- from right to left. printP :: Functor f => Printor s f a a -> a -> f (s -> s) printP (Printor f) = fmap snd . f From acc0b5e3f3504b03d81e423d7e6f53cfc2a5731c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 22:54:48 -0800 Subject: [PATCH 260/282] LenVec --- distributors.cabal | 4 ++++ package.yaml | 1 + test/spec/Examples/LenVec.hs | 39 ++++++++++++++++++++++++++++++++++++ test/spec/Main.hs | 5 ++++- 4 files changed, 48 insertions(+), 1 deletion(-) create mode 100644 test/spec/Examples/LenVec.hs diff --git a/distributors.cabal b/distributors.cabal index 986dc01..8ed818a 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -76,6 +76,7 @@ library LambdaCase MagicHash MonoLocalBinds + QualifiedDo QuantifiedConstraints RankNTypes RecursiveDo @@ -143,6 +144,7 @@ test-suite doc LambdaCase MagicHash MonoLocalBinds + QualifiedDo QuantifiedConstraints RankNTypes RecursiveDo @@ -186,6 +188,7 @@ test-suite spec Examples.Arithmetic Examples.Json Examples.Lambda + Examples.LenVec Examples.RegString Examples.SemVer Examples.SExpr @@ -218,6 +221,7 @@ test-suite spec LambdaCase MagicHash MonoLocalBinds + QualifiedDo QuantifiedConstraints RankNTypes RecursiveDo diff --git a/package.yaml b/package.yaml index 7d2759f..ccf3857 100644 --- a/package.yaml +++ b/package.yaml @@ -74,6 +74,7 @@ default-extensions: - LambdaCase - MagicHash - MonoLocalBinds +- QualifiedDo - QuantifiedConstraints - RankNTypes - RecursiveDo diff --git a/test/spec/Examples/LenVec.hs b/test/spec/Examples/LenVec.hs new file mode 100644 index 0000000..5af27c9 --- /dev/null +++ b/test/spec/Examples/LenVec.hs @@ -0,0 +1,39 @@ +module Examples.LenVec + ( LenVec + , lenvecGrammar + , lenvecExamples + ) where + +import Control.Lens.Grammar +import Control.Lens.Grammar.Symbol +import Control.Lens.Grammar.Token +import Control.Lens.PartialIso +import Data.Profunctor.Distributor +import Data.Profunctor.Monoidal +import qualified Data.Profunctor.Monadic as P +import Numeric.Natural + +data LenVec = LenVec {length :: Natural, vector :: [Natural]} + deriving (Eq, Ord, Show, Read) + +makeNestedPrisms ''LenVec + +lenvecGrammar :: CtxGrammar Char LenVec +lenvecGrammar = _LenVec >? P.do + let numberG = iso show read >~ someP (asIn @Char DecimalNumber) + len <- numberG *< terminal ";" + if len == 0 then return [] else + let + lenSub1 = fromIntegral len - 1 + headG = numberG + tailG = replicateP lenSub1 $ P.do + terminal "," + numberG + in + headG >:< tailG + +lenvecExamples :: [(LenVec, String)] +lenvecExamples = + [ (LenVec 3 [1,2,3], "3;1,2,3") + , (LenVec 0 [], "0;") + ] diff --git a/test/spec/Main.hs b/test/spec/Main.hs index d6c3063..2896394 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -10,6 +10,7 @@ import Examples.Arithmetic import Examples.Json import Examples.SExpr import Examples.Lambda +-- import Examples.LenVec import Examples.SemVer main :: IO () @@ -20,8 +21,10 @@ main = hspec $ do testGrammar "jsonGrammar" jsonGrammar jsonExamples testGrammar "sexprGrammar" sexprGrammar sexprExamples testGrammar "lambdaGrammar" lambdaGrammar lambdaExamples + -- testGrammar "lenvecGrammar" lenvecGrammar lenvecExamples + -- FIXME -testGrammar :: (Show a, Eq a) => String -> Grammar Char a -> [(a, String)] -> Spec +testGrammar :: (Show a, Eq a) => String -> CtxGrammar Char a -> [(a, String)] -> Spec testGrammar name grammar examples = describe name $ for_ examples $ \(expectedSyntax, expectedString) -> do From a538dddd328a78d424a34c17fc6bfff91ac05e62 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Wed, 4 Feb 2026 23:19:52 -0800 Subject: [PATCH 261/282] Claud fixed Printor Monad! vibe coding ftw --- src/Data/Profunctor/Grammar.hs | 2 +- test/spec/Main.hs | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index 7de9470..a7ca96d 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -203,7 +203,7 @@ instance Monad f => Monad (Printor s f a) where Printor mx >>= f = Printor $ \a -> do (a1,g) <- mx a (b,h) <- runPrintor (f a1) a - return (b, h . g) + return (b, g . h) instance (Alternative f, Monad f) => MonadPlus (Printor s f a) instance Applicative f => Distributor (Printor s f) where zeroP = Printor absurd diff --git a/test/spec/Main.hs b/test/spec/Main.hs index 2896394..ba2dce0 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -10,7 +10,7 @@ import Examples.Arithmetic import Examples.Json import Examples.SExpr import Examples.Lambda --- import Examples.LenVec +import Examples.LenVec import Examples.SemVer main :: IO () @@ -21,8 +21,7 @@ main = hspec $ do testGrammar "jsonGrammar" jsonGrammar jsonExamples testGrammar "sexprGrammar" sexprGrammar sexprExamples testGrammar "lambdaGrammar" lambdaGrammar lambdaExamples - -- testGrammar "lenvecGrammar" lenvecGrammar lenvecExamples - -- FIXME + testGrammar "lenvecGrammar" lenvecGrammar lenvecExamples testGrammar :: (Show a, Eq a) => String -> CtxGrammar Char a -> [(a, String)] -> Spec testGrammar name grammar examples = From b2a82e7688f595ba05aab835ca44db9a7bef4344 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 07:39:35 -0800 Subject: [PATCH 262/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 6eaad20..0863cd1 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -265,8 +265,8 @@ type Lexical token p = ) :: Constraint {- | `RegString`s are an embedded domain specific language -for regular expression strings. -Since they are strings, they have a string-like interface. +of regular expression strings. Since they are strings, +they have a string-like interface. >>> let rex = fromString "ab|c" :: RegString >>> putStringLn rex @@ -274,7 +274,7 @@ ab|c >>> rex "ab|c" -`RegString`s can be generated from `RegGrammar`s with `regstringG` +`RegString`s can be generated from `RegGrammar`s with `regstringG`. >>> regstringG (terminal "a" >* terminal "b" <|> terminal "c") "ab|c" @@ -341,7 +341,7 @@ Additional forms of character classes test for a character's `GeneralCategory`. and the `Tokenized` combinators are all negatable. However, we'd like to be able to take the intersection of character classes as well. -`RegString`s can combine character's `tokenClass`es +`RegString`s can combine characters' `tokenClass`es using `BooleanAlgebra` combinators. >>> tokenClass (notOneOf "abc" >&&< notOneOf "xyz") :: RegString From 06127c41f6adb58313011adcd4e456d05f744c23 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 08:03:22 -0800 Subject: [PATCH 263/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 0863cd1..dfdbe1d 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -364,6 +364,25 @@ newtype RegString = RegString {runRegString :: RegEx Char} , Matching String ) +{- | `RegBnf`s are an embedded domain specific language +of Backus-Naur forms extended by regular expression strings. +Like `RegString`s they have a string-like interface. + +>>> let bnf = fromString "{start} = foo|bar" :: RegString +>>> putStringLn bnf +{start} = foo|bar +>>> bnf +"{start} = foo|bar" + +`RegBnf`s can be generated from context-free `Grammar`s with `regbnfG`. + +>>> :type regbnf regbnfGrammar +regbnf regbnfGrammar :: RegBnf + +Like `RegString`s, `RegBnf`s can be constructed using +`Lexical`, `Monoid` and `KleeneStarAlgebra` combinators. +But they also support `BackusNaurForm` `rule`s and `ruleRec`s. +-} newtype RegBnf = RegBnf {runRegBnf :: Bnf RegString} deriving newtype ( Eq, Ord @@ -570,6 +589,9 @@ charG = rule "char" $ ] {- | +`regbnfGrammar` is a context-free `Grammar` for `RegBnf`s. +That means that it can generate a self-hosting definition. + >>> putStringLn (regbnfG regbnfGrammar) {start} = \q{regbnf} {alternate} = \q{sequence}(\|\q{sequence})* @@ -662,6 +684,9 @@ unparseG -> m string unparseG parsor = unparseP parsor +{- | `putStringLn` is a utility that generalizes `putStrLn` +to string-like interfaces such as `RegString` and `RegBnf`. +-} putStringLn :: (IsList string, Item string ~ Char) => string -> IO () putStringLn = putStrLn . toList From 179f4bf94ce8565a502b9354f6c4fc674a99a8be Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 09:57:33 -0800 Subject: [PATCH 264/282] context grammars and testing --- src/Control/Lens/Grammar.hs | 63 ++++++++++++++++++++++++++++-- src/Data/Profunctor/Distributor.hs | 10 +++++ test/spec/Examples/LenVec.hs | 18 +++------ test/spec/Examples/SemVer.hs | 18 +++++++++ test/spec/Main.hs | 1 + 5 files changed, 94 insertions(+), 16 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index dfdbe1d..56e2b2f 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -244,12 +244,67 @@ type Grammar token a = forall p. , Alternator p ) => p a a +{- | +In addition to context-sensitivity via `Monadic` combinators, +`CtxGrammar`s adds general filtration via `Filtrator` to `Grammar`s. + +>>> :{ +palindromeG :: CtxGrammar Char String +palindromeG = rule "palindrome" $ + satisfied (\wrd -> reverse wrd == wrd) >?< manyP (anyToken @Char) +:} + +The `satisfied` pattern is used together with the `Choice` & `Cochoice` +applicator `>?<` for general filtration. For context-sensitivity, +the `Monadic` interface is used by importing "Data.Profunctor.Monadic" +qualified and using a notation which mixes +"idiom" style with qualified do-notation. +Let's use length-encoded vectors of numbers as an example. + +>>> import Numeric.Natural (Natural) +>>> import Control.Lens.Iso (Iso', iso) +>>> :set -XRecordWildCards +>>> :{ +data LenVec = LenVec {length :: Natural, vector :: [Natural]} + deriving (Eq, Ord, Show, Read) +_LenVec :: Iso' LenVec (Natural, [Natural]) +_LenVec = iso (\LenVec {..} -> (length, vector)) (\(length, vector) -> LenVec {..}) +:} + +>>> :set -XQualifiedDo +>>> import qualified Data.Profunctor.Monadic as P +>>> :{ +lenvecGrammar :: CtxGrammar Char LenVec +lenvecGrammar = _LenVec >? P.do + let + numberG = iso show read >~ someP (asIn @Char DecimalNumber) + vectorG n = intercalateP n (sepBy (terminal ",")) numberG + len <- numberG -- bonds to _LenVec + terminal ";" -- doesn't bond + vectorG (fromIntegral len) -- bonds to _LenVec +:} + +The qualified do-notation changes the signature of @P.@`Data.Profunctor.Monadic.>>=`, +so that we must apply the constructor pattern @_LenVec@ +to the do-block with the `>?` applicator. +Any bound variable, @var <- action@, gets "bonded" to the constructor pattern. +Also, the ending action gets bonded to the pattern. + +>>> [vec | (vec, "") <- parseG lenvecGrammar "3;1,2,3"] :: [LenVec] +[LenVec {length = 3, vector = [1,2,3]}] +>>> [vec | (vec, "") <- parseG lenvecGrammar "0;1,2,3"] :: [LenVec] +[] +>>> [pr "" | pr <- printG lenvecGrammar (LenVec 2 [6,7])] :: [String] +["2;6,7"] +>>> [pr "" | pr <- printG lenvecGrammar (LenVec 200 [100])] :: [String] +[] +-} type CtxGrammar token a = forall p. ( Lexical token p , forall x. BackusNaurForm (p x x) , Alternator p - , Monadic p , Filtrator p + , Monadic p ) => p a a {- | @@ -368,7 +423,7 @@ newtype RegString = RegString {runRegString :: RegEx Char} of Backus-Naur forms extended by regular expression strings. Like `RegString`s they have a string-like interface. ->>> let bnf = fromString "{start} = foo|bar" :: RegString +>>> let bnf = fromString "{start} = foo|bar" :: RegBnf >>> putStringLn bnf {start} = foo|bar >>> bnf @@ -376,8 +431,8 @@ Like `RegString`s they have a string-like interface. `RegBnf`s can be generated from context-free `Grammar`s with `regbnfG`. ->>> :type regbnf regbnfGrammar -regbnf regbnfGrammar :: RegBnf +>>> :type regbnfG regbnfGrammar +regbnfG regbnfGrammar :: RegBnf Like `RegString`s, `RegBnf`s can be constructed using `Lexical`, `Monoid` and `KleeneStarAlgebra` combinators. diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index 50cc256..cf88e16 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -25,6 +25,7 @@ module Data.Profunctor.Distributor , several1 , chain , chain1 + , intercalateP ) where import Control.Applicative hiding (WrappedArrow) @@ -447,3 +448,12 @@ chain1 association pat (SepBy beg end sep) = leftOrRight chainl1 chainr1 leftOrRight a b = case association () of Left _ -> a; Right _ -> b chainl1 p = difoldl pat >? beg >* p >*< manyP (sep >* p) *< end chainr1 p = difoldr pat >? beg >* manyP (p *< sep) >*< p *< end + +{- | `intercalateP` adds a `SepBy` to `replicateP`. -} +intercalateP + :: (Monoidal p, Choice p, AsEmpty s, AsEmpty t, Cons s t a b) + => Int -> SepBy (p () ()) -> p a b -> p s t +intercalateP n (SepBy beg end _) _ | n <= 0 = + beg >* lmap (const Empty) asEmpty *< end +intercalateP n (SepBy beg end comma) p = + beg >* p >:< replicateP (n-1) (comma >* p) *< end diff --git a/test/spec/Examples/LenVec.hs b/test/spec/Examples/LenVec.hs index 5af27c9..a37b608 100644 --- a/test/spec/Examples/LenVec.hs +++ b/test/spec/Examples/LenVec.hs @@ -9,7 +9,6 @@ import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Control.Lens.PartialIso import Data.Profunctor.Distributor -import Data.Profunctor.Monoidal import qualified Data.Profunctor.Monadic as P import Numeric.Natural @@ -20,17 +19,12 @@ makeNestedPrisms ''LenVec lenvecGrammar :: CtxGrammar Char LenVec lenvecGrammar = _LenVec >? P.do - let numberG = iso show read >~ someP (asIn @Char DecimalNumber) - len <- numberG *< terminal ";" - if len == 0 then return [] else - let - lenSub1 = fromIntegral len - 1 - headG = numberG - tailG = replicateP lenSub1 $ P.do - terminal "," - numberG - in - headG >:< tailG + let + numberG = iso show read >~ someP (asIn @Char DecimalNumber) + vectorG n = intercalateP n (sepBy (terminal ",")) numberG + len <- numberG -- bonds to _LenVec + terminal ";" -- doesn't bond + vectorG (fromIntegral len) -- bonds to _LenVec lenvecExamples :: [(LenVec, String)] lenvecExamples = diff --git a/test/spec/Examples/SemVer.hs b/test/spec/Examples/SemVer.hs index 1078dbf..af096ca 100644 --- a/test/spec/Examples/SemVer.hs +++ b/test/spec/Examples/SemVer.hs @@ -1,6 +1,7 @@ module Examples.SemVer ( SemVer (..) , semverGrammar + , semverCtxGrammar , semverExamples ) where @@ -10,6 +11,7 @@ import Control.Lens.Grammar.Symbol import Control.Lens.Grammar.Token import Control.Lens.PartialIso import Data.Profunctor.Distributor +import qualified Data.Profunctor.Monadic as P import Data.Profunctor.Monoidal import Numeric.Natural @@ -50,6 +52,22 @@ semverGrammar = _SemVer <|> asIn DecimalNumber <|> token '-' +-- Recapitulated as context-sensitive to test qualified-do +semverCtxGrammar :: CtxGrammar Char SemVer +semverCtxGrammar = _SemVer >? P.do + let + numberG = iso show read >~ someP (asIn @Char DecimalNumber) + identifiersG = several1 (sepBy (terminal ".")) (someP charG) + charG = asIn LowercaseLetter + <|> asIn UppercaseLetter + <|> asIn DecimalNumber + <|> token '-' + _ <- numberG + _ <- terminal "." >* numberG + _ <- terminal "." >* numberG + _ <- option [] (terminal "-" >* identifiersG) + option [] (terminal "+" >* identifiersG) + semverExamples :: [(SemVer, String)] semverExamples = [ (SemVer 0 0 1 [] [], diff --git a/test/spec/Main.hs b/test/spec/Main.hs index ba2dce0..2727954 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -17,6 +17,7 @@ main :: IO () main = hspec $ do testGrammar "regexGrammar" regexGrammar regexExamples testGrammar "semverGrammar" semverGrammar semverExamples + testGrammar "semverCtxGrammar" semverCtxGrammar semverExamples testGrammar "arithGrammar" arithGrammar arithExamples testGrammar "jsonGrammar" jsonGrammar jsonExamples testGrammar "sexprGrammar" sexprGrammar sexprExamples From 55d57d2cde48e4c57fdeaf7cef43814fed3ef376 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 10:07:18 -0800 Subject: [PATCH 265/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 56e2b2f..ef2f528 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -405,7 +405,7 @@ using `BooleanAlgebra` combinators. "[abc]" >>> tokenClass (notOneOf "#$%" >&&< notAsIn Control) :: RegString "[^#$%\\P{Cc}]" ->>> tokenClass (notAsIn MathSymbol >&&< notAsIn Control) :: RegString +>>> tokenClass (allB notAsIn [MathSymbol, Control]) :: RegString "\\P{Sm|Cc}" >>> tokenClass (notB (oneOf "xyz")) :: RegString "[^xyz]" From baf157f85d62cd9891ace849309a64102df3b77f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 10:20:15 -0800 Subject: [PATCH 266/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index ef2f528..7a62af7 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -254,8 +254,9 @@ palindromeG = rule "palindrome" $ satisfied (\wrd -> reverse wrd == wrd) >?< manyP (anyToken @Char) :} -The `satisfied` pattern is used together with the `Choice` & `Cochoice` -applicator `>?<` for general filtration. For context-sensitivity, +The `satisfied` pattern is used together with the `Choice` & +`Data.Profunctor.Cochoice` applicator `>?<` for general filtration. +For context-sensitivity, the `Monadic` interface is used by importing "Data.Profunctor.Monadic" qualified and using a notation which mixes "idiom" style with qualified do-notation. @@ -409,6 +410,11 @@ using `BooleanAlgebra` combinators. "\\P{Sm|Cc}" >>> tokenClass (notB (oneOf "xyz")) :: RegString "[^xyz]" + +Ill-formed `RegStrings` normalize to failure `"[]"`. + +>>> fromString ")(" :: RegString +"[]" -} newtype RegString = RegString {runRegString :: RegEx Char} deriving newtype From 2370c7153564d7981f0bc61133993b22828cf415 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 11:10:02 -0800 Subject: [PATCH 267/282] Update SemVer.hs --- test/spec/Examples/SemVer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/spec/Examples/SemVer.hs b/test/spec/Examples/SemVer.hs index af096ca..ffc5792 100644 --- a/test/spec/Examples/SemVer.hs +++ b/test/spec/Examples/SemVer.hs @@ -52,7 +52,7 @@ semverGrammar = _SemVer <|> asIn DecimalNumber <|> token '-' --- Recapitulated as context-sensitive to test qualified-do +-- Context-sensitive SemVer to test qualified-do semverCtxGrammar :: CtxGrammar Char SemVer semverCtxGrammar = _SemVer >? P.do let From 5c59eb66fa3d7374b736d229c0a63ac753ba28f9 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 11:10:05 -0800 Subject: [PATCH 268/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 40 ++++++++++++++++++++++++------------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index 7a62af7..c617492 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -177,7 +177,7 @@ coming from the `BackusNaurForm` interface * and general recursion. `regexGrammar` and `regbnfGrammar` are examples of context-free -`Grammar`s. Regular expressions are an form of an expression algebra. +`Grammar`s. Regular expressions are a form of expression algebra. Let's see a similar but simpler example, the algebra of arithmetic expressions of natural numbers. @@ -221,14 +221,7 @@ arithGrammar = ruleRec "arith" sumG _Num . iso show read >? someP (asIn @Char DecimalNumber) :} ->>> [x | (x,"") <- parseG arithGrammar "1+2*3+4"] -[Add (Add (Num 1) (Mul (Num 2) (Num 3))) (Num 4)] - ->>> unparseG arithGrammar (Add (Num 1) (Mul (Num 2) (Num 3))) "" :: Maybe String -Just "1+2*3" - ->>> do pr <- printG arithGrammar (Num 69); return (pr "") :: Maybe String -Just "69" +We can generate a `RegBnf`, printers and parsers from `arithGrammar`. >>> putStringLn (regbnfG arithGrammar) {start} = \q{arith} @@ -237,6 +230,14 @@ Just "69" {number} = \p{Nd}+ {product} = \q{factor}(\*\q{factor})* {sum} = \q{product}(\+\q{product})* + +>>> [x | (x,"") <- parseG arithGrammar "1+2*3+4"] +[Add (Add (Num 1) (Mul (Num 2) (Num 3))) (Num 4)] +>>> unparseG arithGrammar (Add (Num 1) (Mul (Num 2) (Num 3))) "" :: Maybe String +Just "1+2*3" +>>> do pr <- printG arithGrammar (Num 69); return (pr "") :: Maybe String +Just "69" + -} type Grammar token a = forall p. ( Lexical token p @@ -288,8 +289,17 @@ lenvecGrammar = _LenVec >? P.do The qualified do-notation changes the signature of @P.@`Data.Profunctor.Monadic.>>=`, so that we must apply the constructor pattern @_LenVec@ to the do-block with the `>?` applicator. -Any bound variable, @var <- action@, gets "bonded" to the constructor pattern. +Any bound named variable, @var <- action@, +gets "bonded" to the constructor pattern. Also, the ending action gets bonded to the pattern. +Any unnamed bound action, @_ <- action@, +also gets bonded to the pattern, +but being unnamed means it isn't added to the context. +If all bound actions are unnamed, then a `CtxGrammar` can +be rewritten as a `Grammar` since it is context-free. +We can't generate a `RegBnf` since the `rule`s +of a `CtxGrammar` aren't static, but dynamic and contextual. +We can generate parsers and printers as expected. >>> [vec | (vec, "") <- parseG lenvecGrammar "3;1,2,3"] :: [LenVec] [LenVec {length = 3, vector = [1,2,3]}] @@ -299,6 +309,8 @@ Also, the ending action gets bonded to the pattern. ["2;6,7"] >>> [pr "" | pr <- printG lenvecGrammar (LenVec 200 [100])] :: [String] [] +>>> [pal | word <- ["racecar", "word"], (pal, "") <- parseG palindromeG word] +["racecar"] -} type CtxGrammar token a = forall p. ( Lexical token p @@ -411,7 +423,7 @@ using `BooleanAlgebra` combinators. >>> tokenClass (notB (oneOf "xyz")) :: RegString "[^xyz]" -Ill-formed `RegStrings` normalize to failure `"[]"`. +Ill-formed `RegString`s normalize to failure. >>> fromString ")(" :: RegString "[]" @@ -651,7 +663,7 @@ charG = rule "char" $ {- | `regbnfGrammar` is a context-free `Grammar` for `RegBnf`s. -That means that it can generate a self-hosting definition. +That means that it can generate a self-hosted definition. >>> putStringLn (regbnfG regbnfGrammar) {start} = \q{regbnf} @@ -689,7 +701,7 @@ regstringG :: RegGrammar Char a -> RegString regstringG rex = runGrammor rex {- | `regbnfG` generates a `RegBnf` from a context-free `Grammar`. -Since context-sensitive `Grammar`s aren't context-free, +Since `CtxGrammar`s aren't context-free, the type system will prevent `regbnfG` from being applied to a `CtxGrammar`. It can apply to a `RegGrammar`. -} @@ -717,7 +729,7 @@ Since both `RegGrammar`s and context-free `Grammar`s are `CtxGrammar`s, the type system will allow `parseG` to be applied to them. Running the parser on an input string value `uncons`es tokens from the beginning of an input string from left to right, -returning a value and the remaining output string. +returning a syntax value and the remaining output string. -} parseG :: (Cons string string token token, Snoc string string token token) From b98568399a393960b938eae183aa4a6b25787a67 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 13:07:43 -0800 Subject: [PATCH 269/282] remove Like --- src/Control/Lens/Grammar/Token.hs | 62 ------------------------------- test/spec/Examples/Json.hs | 3 +- test/spec/Examples/Lambda.hs | 2 +- test/spec/Examples/SExpr.hs | 2 +- 4 files changed, 4 insertions(+), 65 deletions(-) diff --git a/src/Control/Lens/Grammar/Token.hs b/src/Control/Lens/Grammar/Token.hs index 52fa009..bb9d825 100644 --- a/src/Control/Lens/Grammar/Token.hs +++ b/src/Control/Lens/Grammar/Token.hs @@ -13,11 +13,6 @@ module Control.Lens.Grammar.Token Tokenized (..) , satisfy , tokens - -- * Like - , oneLike - , anyLike - , optLike - , reqLike -- * Categorized , Categorized (..) , GeneralCategory (..) @@ -27,7 +22,6 @@ import Control.Lens import Control.Lens.PartialIso import Data.Char import Data.Profunctor -import Data.Profunctor.Distributor import Data.Profunctor.Monoidal import Data.Word @@ -116,59 +110,3 @@ tokens ) => f a -> p s s tokens = foldr ((>:<) . token) asEmpty - -{- | -`oneLike` consumes one token -of a given token's category while parsing, -and produces the given token while printing. --} -oneLike - :: forall token p. (Profunctor p, Tokenized token (p token token)) - => token -> p () () -oneLike a = dimap preF postF catA - where - preF _ = a - postF (_:: token) = () - catA = asIn (categorize a) - -{- | -`anyLike` consumes zero or more tokens -of a given token's category while parsing, -and produces no tokens printing. --} -anyLike - :: forall token p. (Distributor p, Tokenized token (p token token)) - => token -> p () () -anyLike a = dimap preF postF (manyP catA) - where - preF _ = []::[token] - postF (_::[token]) = () - catA = asIn (categorize a) - -{- | -`optLike` consumes zero or more tokens -of a given token's category while parsing, -and produces the given token while printing. --} -optLike - :: forall token p. (Distributor p, Tokenized token (p token token)) - => token -> p () () -optLike a = dimap preF postF (manyP catA) - where - preF _ = [a]::[token] - postF (_::[token]) = () - catA = asIn (categorize a) - -{- | -`reqLike` consumes one or more tokens -of a given token's category while parsing, -and produces the given token while printing. --} -reqLike - :: forall token p. (Distributor p, Tokenized token (p token token)) - => token -> p () () -reqLike a = dimap preF postF (catA >*< manyP catA) - where - preF _ = (a, []::[token]) - postF (_::token, _::[token]) = () - catA = asIn (categorize a) diff --git a/test/spec/Examples/Json.hs b/test/spec/Examples/Json.hs index 413c1fc..79cc5f9 100644 --- a/test/spec/Examples/Json.hs +++ b/test/spec/Examples/Json.hs @@ -102,7 +102,8 @@ jsonGrammar = ruleRec "json" elementG iso show read >~ someP (asIn @Char DecimalNumber) -- Simplified: zero or more whitespace characters - ws = rule "ws" $ anyLike ' ' + ws = rule "ws" $ + iso (\() -> "") (\_ -> ()) >~ manyP (token @Char ' ') -- | Example JSON values for testing jsonExamples :: [(Json, String)] diff --git a/test/spec/Examples/Lambda.hs b/test/spec/Examples/Lambda.hs index 1a39dfa..bee41e3 100644 --- a/test/spec/Examples/Lambda.hs +++ b/test/spec/Examples/Lambda.hs @@ -40,7 +40,7 @@ lambdaGrammar = ruleRec "lambda" termG -- Application: left-associative chain of atoms -- e.g., "f x y" parses as "(f x) y" appG term = rule "application" $ - chain1 Left _App (sepBy (reqLike ' ')) (atomG term) + chain1 Left _App (sepBy (terminal " ")) (atomG term) -- Atomic term: variable or parenthesized term atomG term = rule "atom" $ choice diff --git a/test/spec/Examples/SExpr.hs b/test/spec/Examples/SExpr.hs index b682a5a..84ebe5b 100644 --- a/test/spec/Examples/SExpr.hs +++ b/test/spec/Examples/SExpr.hs @@ -36,7 +36,7 @@ sexprGrammar = ruleRec "sexpr" $ \sexpr -> choice -- List: parenthesized sequence of S-expressions -- Elements are separated by whitespace listG sexpr = rule "list" $ - terminal "(" >* several (sepBy (reqLike ' ')) sexpr *< terminal ")" + terminal "(" >* several (sepBy (terminal " ")) sexpr *< terminal ")" -- Characters allowed in atoms: letters, digits, and symbols atomChars = From be916408a89924b6453210d44ba7c0c5a4a1ce8c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 14:30:29 -0800 Subject: [PATCH 270/282] fix not fix not test --- src/Control/Lens/Grammar/Boole.hs | 4 ++-- test/spec/Examples/RegString.hs | 5 ++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index a99b0d0..2841403 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -145,8 +145,8 @@ instance Categorized token True -> Pass notB Fail = Pass notB Pass = Fail - notB (Alternate (TokenTest x) (TokenTest y)) = x >&&< y - notB (OneOf xs) = NotOneOf xs (NotAsIn Set.empty) + notB (Alternate (TokenTest x) (TokenTest y)) = notB x >&&< notB y + notB (OneOf xs) = notOneOf xs notB (NotOneOf xs (AsIn y)) = oneOf xs >||< notAsIn y notB (NotOneOf xs (NotAsIn ys)) = oneOf xs >||< anyB asIn ys _ >&&< Fail = Fail diff --git a/test/spec/Examples/RegString.hs b/test/spec/Examples/RegString.hs index 11edf62..3e6a23e 100644 --- a/test/spec/Examples/RegString.hs +++ b/test/spec/Examples/RegString.hs @@ -40,7 +40,7 @@ regexExamples = -- Boolean AND (>&&<) operations , (tokenClass (oneOf "abcdef" >&&< oneOf "def123"), "[def]") , (tokenClass (notOneOf "abc" >&&< notOneOf "xyz"), "[^abcxyz]") - , (tokenClass (oneOf "abc" >&&< notOneOf "bc"), "[a]") + , (tokenClass (oneOf "abcd" >&&< notOneOf "cd"), "[ab]") , (tokenClass (notOneOf "abc" >&&< asIn LowercaseLetter), "[^abc\\p{Ll}]") , (tokenClass (notOneOf "abc" >&&< notAsIn Control), "[^abc\\P{Cc}]") , (tokenClass (asIn UppercaseLetter >&&< notOneOf "XYZ"), "[^XYZ\\p{Lu}]") @@ -62,6 +62,5 @@ regexExamples = -- Complex combinations , (tokenClass (notOneOf "abc" >&&< (asIn LowercaseLetter >||< asIn UppercaseLetter)), "[^abc\\p{Ll}]|\\p{Lu}") , (tokenClass ((oneOf "123" >||< asIn DecimalNumber) >&&< notOneOf "789"), "[123]|[^789\\p{Nd}]") - -- , (tokenClass (notB (oneOf "&%$" >||< asIn MathSymbol)), "") - -- FIXME ^^^ + , (tokenClass (notB (oneOf "abc" >||< asIn MathSymbol)), "[^abc\\P{Sm}]") ] From bf3a2e044a2e751c05ddc9cb730f02bae72654bc Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 14:33:47 -0800 Subject: [PATCH 271/282] Update Grammar.hs --- src/Control/Lens/Grammar.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index c617492..b8cbf33 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -221,7 +221,7 @@ arithGrammar = ruleRec "arith" sumG _Num . iso show read >? someP (asIn @Char DecimalNumber) :} -We can generate a `RegBnf`, printers and parsers from `arithGrammar`. +We can generate a `RegBnf`, printers and parsers from @arithGrammar@. >>> putStringLn (regbnfG arithGrammar) {start} = \q{arith} From 8fb23461ebbcf26bc1ea185b241f3a44b15ebc10 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 15:42:54 -0800 Subject: [PATCH 272/282] stuff --- src/Control/Lens/Grammar.hs | 9 ++++++--- src/Control/Lens/Grammar/Boole.hs | 2 +- src/Control/Lens/Grammar/Kleene.hs | 2 +- src/Data/Profunctor/Distributor.hs | 4 ++-- src/Data/Profunctor/Grammar.hs | 6 +++--- src/Data/Profunctor/Monadic.hs | 8 +++++++- 6 files changed, 20 insertions(+), 11 deletions(-) diff --git a/src/Control/Lens/Grammar.hs b/src/Control/Lens/Grammar.hs index b8cbf33..27ce10b 100644 --- a/src/Control/Lens/Grammar.hs +++ b/src/Control/Lens/Grammar.hs @@ -259,7 +259,7 @@ The `satisfied` pattern is used together with the `Choice` & `Data.Profunctor.Cochoice` applicator `>?<` for general filtration. For context-sensitivity, the `Monadic` interface is used by importing "Data.Profunctor.Monadic" -qualified and using a notation which mixes +qualified and using a "bonding" notation which mixes "idiom" style with qualified do-notation. Let's use length-encoded vectors of numbers as an example. @@ -286,12 +286,15 @@ lenvecGrammar = _LenVec >? P.do vectorG (fromIntegral len) -- bonds to _LenVec :} -The qualified do-notation changes the signature of @P.@`Data.Profunctor.Monadic.>>=`, +The qualified do-notation changes the signature of +@P.@`Data.Profunctor.Monadic.>>=`, so that we must apply the constructor pattern @_LenVec@ to the do-block with the `>?` applicator. Any bound named variable, @var <- action@, gets "bonded" to the constructor pattern. -Also, the ending action gets bonded to the pattern. +Any unbound actions, except for the last action in the do-block, +does not get bonded to the pattern. +The last action does get bonded to the pattern. Any unnamed bound action, @_ <- action@, also gets bonded to the pattern, but being unnamed means it isn't added to the context. diff --git a/src/Control/Lens/Grammar/Boole.hs b/src/Control/Lens/Grammar/Boole.hs index 2841403..f5a5cef 100644 --- a/src/Control/Lens/Grammar/Boole.hs +++ b/src/Control/Lens/Grammar/Boole.hs @@ -74,7 +74,7 @@ allB f = foldl' (\b a -> b >&&< f a) (fromBool True) anyB :: (Foldable f, BooleanAlgebra b) => (a -> b) -> f a -> b anyB f = foldl' (\b a -> b >||< f a) (fromBool False) --- | `TokenTest` forms a `Tokenized` `BooleanAlgebra` +-- | `TokenTest` forms a closed `Tokenized` `BooleanAlgebra` -- of `Categorized` `tokenClass`es. newtype TokenTest token = TokenTest (RegExam token (TokenTest token)) diff --git a/src/Control/Lens/Grammar/Kleene.hs b/src/Control/Lens/Grammar/Kleene.hs index bb12b8b..f13a1f5 100644 --- a/src/Control/Lens/Grammar/Kleene.hs +++ b/src/Control/Lens/Grammar/Kleene.hs @@ -59,7 +59,7 @@ class Monoid k => KleeneStarAlgebra k where (>|<) = (<|>) zeroK = empty --- | cumulative alternation, +-- | cumulative alternation orK :: (Foldable f, KleeneStarAlgebra k) => f k -> k orK = foldl' (>|<) zeroK diff --git a/src/Data/Profunctor/Distributor.hs b/src/Data/Profunctor/Distributor.hs index cf88e16..1d2fd37 100644 --- a/src/Data/Profunctor/Distributor.hs +++ b/src/Data/Profunctor/Distributor.hs @@ -102,7 +102,7 @@ class Monoidal p => Distributor p where zeroP = empty {- | The sum structure morphism of a `Distributor`. - + `>+<` has a default for `Alternator`. prop> x >+< y = alternate (Left x) <|> alternate (Right y) @@ -211,7 +211,7 @@ class Traversable t => Homogeneous t where prop> homogeneously @Maybe = optionalP prop> homogeneously @[] = manyP - + Any `Traversable` & `Data.Distributive.Distributive` countable product can be given a default implementation for the `homogeneously` method. diff --git a/src/Data/Profunctor/Grammar.hs b/src/Data/Profunctor/Grammar.hs index a7ca96d..aca3466 100644 --- a/src/Data/Profunctor/Grammar.hs +++ b/src/Data/Profunctor/Grammar.hs @@ -48,13 +48,13 @@ newtype Parsor s f a b = Parsor {runParsor :: Maybe a -> s -> f (b,s)} -- | Run the parser on an input string, -- `uncons`ing tokens from the beginning of the string, -- from left to right, returning a value and the remaining string. -parseP :: Parsor s f a a -> s -> f (a,s) +parseP :: Parsor s f a b -> s -> f (b,s) parseP (Parsor f) = f Nothing -- | Run the parser in reverse on a value and an input string; -- `snoc`ing tokens at the end of the string, from left to right, -- and returning the new string. -unparseP :: Functor f => Parsor s f a a -> a -> s -> f s +unparseP :: Functor f => Parsor s f a b -> a -> s -> f s unparseP (Parsor f) a = fmap snd . f (Just a) -- | `Printor` is a simple printer `Profunctor`. @@ -63,7 +63,7 @@ newtype Printor s f a b = Printor {runPrintor :: a -> f (b, s -> s)} -- | Run the printer on a value, returning a function -- that `cons`es tokens at the beginning of an input string, -- from right to left. -printP :: Functor f => Printor s f a a -> a -> f (s -> s) +printP :: Functor f => Printor s f a b -> a -> f (s -> s) printP (Printor f) = fmap snd . f -- | `Grammor` is a constant `Profunctor`. diff --git a/src/Data/Profunctor/Monadic.hs b/src/Data/Profunctor/Monadic.hs index 9a0b2bc..54d4a37 100644 --- a/src/Data/Profunctor/Monadic.hs +++ b/src/Data/Profunctor/Monadic.hs @@ -14,6 +14,9 @@ This module can provide qualified do-notation for `Monadic` profunctors. >>> :set -XQualifiedDo >>> import qualified Data.Profunctor.Monadic as P + +See "Control.Lens.Grammar#t:CtxGrammar" for +an example of how to use "bonding" notation. -} module Data.Profunctor.Monadic @@ -32,7 +35,10 @@ import Prelude hiding ((>>=), (>>)) type Monadic p = (Profunctor p, forall x. Monad (p x)) {- | The pair bonding operator @P.@`>>=` is a context-sensitive -version of `Data.Profunctor.Monoidal.>*<`. -} +version of `Data.Profunctor.Monoidal.>*<`. + +prop> x >*< y = x P.>>= (\_ -> y) +-} (>>=) :: Monadic p => p a b -> (b -> p c d) -> p (a,c) (b,d) infixl 1 >>= p >>= f = do From 2935fa9e2d779bca03ade8555802f3b42a711633 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 15:53:47 -0800 Subject: [PATCH 273/282] conjoin tests --- distributors.cabal | 75 +-------------------- package.yaml | 9 +-- test/{spec => }/Examples/Arithmetic.hs | 0 test/{spec => }/Examples/Json.hs | 0 test/{spec => }/Examples/Lambda.hs | 0 test/{spec => }/Examples/LenVec.hs | 0 test/{spec => }/Examples/RegString.hs | 0 test/{spec => }/Examples/SExpr.hs | 0 test/{spec => }/Examples/SemVer.hs | 0 test/Main.hs | 92 ++++++++++++++++++++++++++ test/doc/Main.hs | 54 --------------- test/spec/Main.hs | 39 ----------- 12 files changed, 97 insertions(+), 172 deletions(-) rename test/{spec => }/Examples/Arithmetic.hs (100%) rename test/{spec => }/Examples/Json.hs (100%) rename test/{spec => }/Examples/Lambda.hs (100%) rename test/{spec => }/Examples/LenVec.hs (100%) rename test/{spec => }/Examples/RegString.hs (100%) rename test/{spec => }/Examples/SExpr.hs (100%) rename test/{spec => }/Examples/SemVer.hs (100%) create mode 100644 test/Main.hs delete mode 100644 test/doc/Main.hs delete mode 100644 test/spec/Main.hs diff --git a/distributors.cabal b/distributors.cabal index 8ed818a..e8b64cf 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -111,77 +111,7 @@ library , witherable >=0.4 && <1 default-language: Haskell2010 -test-suite doc - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Paths_distributors - autogen-modules: - Paths_distributors - hs-source-dirs: - test/doc - default-extensions: - AllowAmbiguousTypes - Arrows - ConstraintKinds - DataKinds - DefaultSignatures - DeriveFoldable - DeriveFunctor - DeriveTraversable - DeriveGeneric - DerivingStrategies - DerivingVia - EmptyCase - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralizedNewtypeDeriving - ImportQualifiedPost - ImpredicativeTypes - InstanceSigs - LambdaCase - MagicHash - MonoLocalBinds - QualifiedDo - 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: - MemoTrie >=0.6.11 && <1 - , adjunctions >=4.4 && <5 - , base >=4.7 && <5 - , bifunctors >=5.6 && <6 - , bytestring >=0.11 && <1 - , containers >=0.6 && <1 - , contravariant >=1.5 && <2 - , distributive >=0.6 && <1 - , distributors - , doctest - , lens >=5.2 && <6 - , 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 - -test-suite spec +test-suite test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: @@ -196,7 +126,7 @@ test-suite spec autogen-modules: Paths_distributors hs-source-dirs: - test/spec + test default-extensions: AllowAmbiguousTypes Arrows @@ -246,6 +176,7 @@ test-suite spec , contravariant >=1.5 && <2 , distributive >=0.6 && <1 , distributors + , doctest , hspec , lens >=5.2 && <6 , mtl >=2.3 && <3 diff --git a/package.yaml b/package.yaml index ccf3857..7acae37 100644 --- a/package.yaml +++ b/package.yaml @@ -90,15 +90,10 @@ default-extensions: - UndecidableSuperClasses tests: - doc: + test: main: Main.hs - source-dirs: test/doc + source-dirs: test dependencies: - distributors - doctest - spec: - main: Main.hs - source-dirs: test/spec - dependencies: - - distributors - hspec diff --git a/test/spec/Examples/Arithmetic.hs b/test/Examples/Arithmetic.hs similarity index 100% rename from test/spec/Examples/Arithmetic.hs rename to test/Examples/Arithmetic.hs diff --git a/test/spec/Examples/Json.hs b/test/Examples/Json.hs similarity index 100% rename from test/spec/Examples/Json.hs rename to test/Examples/Json.hs diff --git a/test/spec/Examples/Lambda.hs b/test/Examples/Lambda.hs similarity index 100% rename from test/spec/Examples/Lambda.hs rename to test/Examples/Lambda.hs diff --git a/test/spec/Examples/LenVec.hs b/test/Examples/LenVec.hs similarity index 100% rename from test/spec/Examples/LenVec.hs rename to test/Examples/LenVec.hs diff --git a/test/spec/Examples/RegString.hs b/test/Examples/RegString.hs similarity index 100% rename from test/spec/Examples/RegString.hs rename to test/Examples/RegString.hs diff --git a/test/spec/Examples/SExpr.hs b/test/Examples/SExpr.hs similarity index 100% rename from test/spec/Examples/SExpr.hs rename to test/Examples/SExpr.hs diff --git a/test/spec/Examples/SemVer.hs b/test/Examples/SemVer.hs similarity index 100% rename from test/spec/Examples/SemVer.hs rename to test/Examples/SemVer.hs diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..06bb306 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,92 @@ +module Main (main) where + +import Data.Foldable hiding (toList) +import Data.Maybe (listToMaybe) +import Control.Lens.Grammar +import Test.DocTest +import Test.Hspec + +import Examples.RegString +import Examples.Arithmetic +import Examples.Json +import Examples.SExpr +import Examples.Lambda +import Examples.LenVec +import Examples.SemVer + +main :: IO () +main = do + doctests + hspec $ do + testGrammar "regexGrammar" regexGrammar regexExamples + testGrammar "semverGrammar" semverGrammar semverExamples + testGrammar "semverCtxGrammar" semverCtxGrammar semverExamples + testGrammar "arithGrammar" arithGrammar arithExamples + testGrammar "jsonGrammar" jsonGrammar jsonExamples + testGrammar "sexprGrammar" sexprGrammar sexprExamples + testGrammar "lambdaGrammar" lambdaGrammar lambdaExamples + testGrammar "lenvecGrammar" lenvecGrammar lenvecExamples + +doctests :: IO () +doctests = do + let + modulePaths = + [ "src/Control/Lens/Grammar.hs" + , "src/Control/Lens/Grammar/Token.hs" + ] + languageExtensions = + [ "-XAllowAmbiguousTypes" + , "-XArrows" + , "-XConstraintKinds" + , "-XDataKinds" + , "-XDefaultSignatures" + , "-XDeriveFoldable" + , "-XDeriveFunctor" + , "-XDeriveTraversable" + , "-XDeriveGeneric" + , "-XDerivingStrategies" + , "-XDerivingVia" + , "-XEmptyCase" + , "-XFlexibleContexts" + , "-XFlexibleInstances" + , "-XFunctionalDependencies" + , "-XGADTs" + , "-XGeneralizedNewtypeDeriving" + , "-XImportQualifiedPost" + , "-XImpredicativeTypes" + , "-XInstanceSigs" + , "-XLambdaCase" + , "-XMagicHash" + , "-XMonoLocalBinds" + , "-XQuantifiedConstraints" + , "-XRankNTypes" + , "-XRecursiveDo" + , "-XScopedTypeVariables" + , "-XStandaloneDeriving" + , "-XStandaloneKindSignatures" + , "-XTemplateHaskell" + , "-XTupleSections" + , "-XTypeApplications" + , "-XTypeFamilies" + , "-XTypeOperators" + , "-XUndecidableInstances" + , "-XUndecidableSuperClasses" + ] + for_ modulePaths $ \modulePath -> do + putStr "Testing module documentation in " + putStrLn modulePath + doctest (modulePath : languageExtensions) + +testGrammar :: (Show a, Eq a) => String -> CtxGrammar Char a -> [(a, String)] -> Spec +testGrammar name grammar examples = + describe name $ + for_ examples $ \(expectedSyntax, expectedString) -> do + it ("should parse from " <> expectedString <> " correctly") $ do + let actualSyntax = [parsed | (parsed, "") <- parseG grammar expectedString] + listToMaybe actualSyntax `shouldBe` Just expectedSyntax + it ("should unparse to " <> expectedString <> " correctly") $ do + let actualString = unparseG grammar expectedSyntax "" + actualString `shouldBe` Just expectedString + it ("should print to " <> expectedString <> " correctly") $ do + let actualString = ($ "") <$> printG grammar expectedSyntax + actualString `shouldBe` Just expectedString diff --git a/test/doc/Main.hs b/test/doc/Main.hs deleted file mode 100644 index 2d00056..0000000 --- a/test/doc/Main.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Main (main) where - -import Data.Foldable (for_) -import Test.DocTest - -main :: IO () -main = do - let - modulePaths = - [ "src/Control/Lens/Grammar.hs" - , "src/Control/Lens/Grammar/Token.hs" - ] - languageExtensions = - [ "-XAllowAmbiguousTypes" - , "-XArrows" - , "-XConstraintKinds" - , "-XDataKinds" - , "-XDefaultSignatures" - , "-XDeriveFoldable" - , "-XDeriveFunctor" - , "-XDeriveTraversable" - , "-XDeriveGeneric" - , "-XDerivingStrategies" - , "-XDerivingVia" - , "-XEmptyCase" - , "-XFlexibleContexts" - , "-XFlexibleInstances" - , "-XFunctionalDependencies" - , "-XGADTs" - , "-XGeneralizedNewtypeDeriving" - , "-XImportQualifiedPost" - , "-XImpredicativeTypes" - , "-XInstanceSigs" - , "-XLambdaCase" - , "-XMagicHash" - , "-XMonoLocalBinds" - , "-XQuantifiedConstraints" - , "-XRankNTypes" - , "-XRecursiveDo" - , "-XScopedTypeVariables" - , "-XStandaloneDeriving" - , "-XStandaloneKindSignatures" - , "-XTemplateHaskell" - , "-XTupleSections" - , "-XTypeApplications" - , "-XTypeFamilies" - , "-XTypeOperators" - , "-XUndecidableInstances" - , "-XUndecidableSuperClasses" - ] - for_ modulePaths $ \modulePath -> do - putStr "Testing module documentation in " - putStrLn modulePath - doctest (modulePath : languageExtensions) diff --git a/test/spec/Main.hs b/test/spec/Main.hs deleted file mode 100644 index 2727954..0000000 --- a/test/spec/Main.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Main (main) where - -import Data.Foldable hiding (toList) -import Data.Maybe (listToMaybe) -import Control.Lens.Grammar -import Test.Hspec - -import Examples.RegString -import Examples.Arithmetic -import Examples.Json -import Examples.SExpr -import Examples.Lambda -import Examples.LenVec -import Examples.SemVer - -main :: IO () -main = hspec $ do - testGrammar "regexGrammar" regexGrammar regexExamples - testGrammar "semverGrammar" semverGrammar semverExamples - testGrammar "semverCtxGrammar" semverCtxGrammar semverExamples - testGrammar "arithGrammar" arithGrammar arithExamples - testGrammar "jsonGrammar" jsonGrammar jsonExamples - testGrammar "sexprGrammar" sexprGrammar sexprExamples - testGrammar "lambdaGrammar" lambdaGrammar lambdaExamples - testGrammar "lenvecGrammar" lenvecGrammar lenvecExamples - -testGrammar :: (Show a, Eq a) => String -> CtxGrammar Char a -> [(a, String)] -> Spec -testGrammar name grammar examples = - describe name $ - for_ examples $ \(expectedSyntax, expectedString) -> do - it ("should parse from " <> expectedString <> " correctly") $ do - let actualSyntax = [parsed | (parsed, "") <- parseG grammar expectedString] - listToMaybe actualSyntax `shouldBe` Just expectedSyntax - it ("should unparse to " <> expectedString <> " correctly") $ do - let actualString = unparseG grammar expectedSyntax "" - actualString `shouldBe` Just expectedString - it ("should print to " <> expectedString <> " correctly") $ do - let actualString = ($ "") <$> printG grammar expectedSyntax - actualString `shouldBe` Just expectedString From 0ea37e33b0a2f25b5a199e652ade42f57386d99f Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 15:56:11 -0800 Subject: [PATCH 274/282] 2026 --- distributors.cabal | 2 +- package.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/distributors.cabal b/distributors.cabal index e8b64cf..e286129 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -13,7 +13,7 @@ homepage: https://github.com/morphismtech/distributors#readme bug-reports: https://github.com/morphismtech/distributors/issues author: Eitan Chatav maintainer: eitan.chatav@gmail.com -copyright: 2025 Eitan Chatav +copyright: 2026 Eitan Chatav license: BSD-3-Clause license-file: LICENSE build-type: Simple diff --git a/package.yaml b/package.yaml index 7acae37..087dea3 100644 --- a/package.yaml +++ b/package.yaml @@ -4,7 +4,7 @@ github: "morphismtech/distributors" license: BSD-3-Clause author: "Eitan Chatav" maintainer: "eitan.chatav@gmail.com" -copyright: "2025 Eitan Chatav" +copyright: "2026 Eitan Chatav" extra-source-files: - README.md From 09e0b392d4098393b5af58ee06b88b030a560e48 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 15:58:41 -0800 Subject: [PATCH 275/282] Update package.yaml --- package.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/package.yaml b/package.yaml index 087dea3..ecf7926 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: distributors -version: 0.2.0.1 +version: 0.3.0.0 github: "morphismtech/distributors" license: BSD-3-Clause author: "Eitan Chatav" From 67c10ee7c06fa88612c0366f4764f6a7a480282a Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 16:00:18 -0800 Subject: [PATCH 276/282] Update distributors.cabal --- distributors.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/distributors.cabal b/distributors.cabal index e286129..98bb91b 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -5,7 +5,7 @@ cabal-version: 2.2 -- see: https://github.com/sol/hpack name: distributors -version: 0.2.0.1 +version: 0.3.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 From db45c2a286ea26324e0590841b372fe3297dc069 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 16:02:59 -0800 Subject: [PATCH 277/282] bounds --- distributors.cabal | 12 ++++++------ package.yaml | 8 ++++---- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/distributors.cabal b/distributors.cabal index 98bb91b..121e8cd 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -104,9 +104,9 @@ library , mtl >=2.3 && <3 , profunctors >=5.6 && <6 , tagged >=0.8 && <1 - , template-haskell + , template-haskell >=2.18 && <3 , text ==2.* - , th-abstraction + , th-abstraction >=0.5 && <1 , vector >=0.13 && <1 , witherable >=0.4 && <1 default-language: Haskell2010 @@ -176,15 +176,15 @@ test-suite test , contravariant >=1.5 && <2 , distributive >=0.6 && <1 , distributors - , doctest - , hspec + , doctest >=0.20 && <1 + , hspec >=2.10 && <3 , lens >=5.2 && <6 , mtl >=2.3 && <3 , profunctors >=5.6 && <6 , tagged >=0.8 && <1 - , template-haskell + , template-haskell >=2.18 && <3 , text ==2.* - , th-abstraction + , th-abstraction >=0.5 && <1 , vector >=0.13 && <1 , witherable >=0.4 && <1 default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index ecf7926..17d3047 100644 --- a/package.yaml +++ b/package.yaml @@ -30,9 +30,9 @@ dependencies: - mtl >= 2.3 && < 3 - profunctors >= 5.6 && < 6 - tagged >= 0.8 && < 1 -- template-haskell +- template-haskell >= 2.18 && < 3 - text >= 2 && < 3 -- th-abstraction +- th-abstraction >= 0.5 && < 1 - vector >= 0.13 && < 1 - witherable >= 0.4 && < 1 @@ -95,5 +95,5 @@ tests: source-dirs: test dependencies: - distributors - - doctest - - hspec + - doctest >= 0.20 && < 1 + - hspec >= 2.10 && < 3 From 3780df486c0cc1ab0ba101e15aeb7dabc7623d0c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 16:06:18 -0800 Subject: [PATCH 278/282] Update CHANGELOG.md --- CHANGELOG.md | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index bca2c02..693daf6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,29 @@ # Changelog for `distributors` +## 0.3.0.0 - 2026-02-05 + +### New Modules + +- `Control.Lens.Grammar` - Grammar hierarchy based on Chomsky's formal grammar classification +- `Control.Lens.Grammar.BackusNaur` - Context-free grammar combinators (BNF) +- `Control.Lens.Grammar.Boole` - Boolean algebra for grammars +- `Control.Lens.Grammar.Kleene` - Regular expression combinators +- `Control.Lens.Grammar.Symbol` - Symbol-level grammar primitives +- `Control.Lens.Grammar.Token` - Token-level grammar primitives +- `Data.Profunctor.Filtrator` - Filterable profunctors +- `Data.Profunctor.Grammar` - Grammar profunctor abstraction +- `Data.Profunctor.Monadic` - Monadic profunctor combinators with QualifiedDo support +- `Data.Profunctor.Monoidal` - Monoidal profunctor combinators + +### Removed Modules + +- `Text.Grammar.Distributor` - Functionality split into the new modules above + +### Testing + +- Added `doctest` for documentation testing +- New test examples: Arithmetic, Json, Lambda, LenVec, RegString, SemVer, SExpr + ## 0.2.0.0 - 2025-07-08 Added some combinators for `RegEx`es. Updated documentation. From ad0975e52cfd1d405e91ac8f45eb16939699bae4 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 16:17:46 -0800 Subject: [PATCH 279/282] bounds --- distributors.cabal | 36 ++++++++++++++++++------------------ package.yaml | 20 ++++++++++---------- 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/distributors.cabal b/distributors.cabal index 121e8cd..9a92b07 100644 --- a/distributors.cabal +++ b/distributors.cabal @@ -92,22 +92,22 @@ library UndecidableSuperClasses ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - MemoTrie >=0.6.11 && <1 + MemoTrie >=0.6 && <1 , adjunctions >=4.4 && <5 - , base >=4.7 && <5 - , bifunctors >=5.6 && <6 + , base >=4.15 && <5 + , bifunctors >=5.5 && <6 , bytestring >=0.11 && <1 , containers >=0.6 && <1 , contravariant >=1.5 && <2 , distributive >=0.6 && <1 - , lens >=5.2 && <6 - , mtl >=2.3 && <3 + , lens >=5.0 && <6 + , mtl >=2.2 && <3 , profunctors >=5.6 && <6 , tagged >=0.8 && <1 - , template-haskell >=2.18 && <3 + , template-haskell >=2.17 && <3 , text ==2.* - , th-abstraction >=0.5 && <1 - , vector >=0.13 && <1 + , th-abstraction >=0.4 && <1 + , vector >=0.12 && <1 , witherable >=0.4 && <1 default-language: Haskell2010 @@ -167,24 +167,24 @@ test-suite test UndecidableSuperClasses ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: - MemoTrie >=0.6.11 && <1 + MemoTrie >=0.6 && <1 , adjunctions >=4.4 && <5 - , base >=4.7 && <5 - , bifunctors >=5.6 && <6 + , base >=4.15 && <5 + , bifunctors >=5.5 && <6 , bytestring >=0.11 && <1 , containers >=0.6 && <1 , contravariant >=1.5 && <2 , distributive >=0.6 && <1 , distributors - , doctest >=0.20 && <1 - , hspec >=2.10 && <3 - , lens >=5.2 && <6 - , mtl >=2.3 && <3 + , doctest >=0.18 && <1 + , hspec >=2.7 && <3 + , lens >=5.0 && <6 + , mtl >=2.2 && <3 , profunctors >=5.6 && <6 , tagged >=0.8 && <1 - , template-haskell >=2.18 && <3 + , template-haskell >=2.17 && <3 , text ==2.* - , th-abstraction >=0.5 && <1 - , vector >=0.13 && <1 + , th-abstraction >=0.4 && <1 + , vector >=0.12 && <1 , witherable >=0.4 && <1 default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 17d3047..3f0209e 100644 --- a/package.yaml +++ b/package.yaml @@ -18,22 +18,22 @@ description: for coders to write parsers that can also be inverted to printers. dependencies: -- base >= 4.7 && < 5 +- base >= 4.15 && < 5 - adjunctions >= 4.4 && < 5 -- bifunctors >= 5.6 && < 6 +- bifunctors >= 5.5 && < 6 - bytestring >= 0.11 && < 1 - containers >= 0.6 && < 1 - contravariant >= 1.5 && < 2 - distributive >= 0.6 && < 1 -- lens >= 5.2 && < 6 -- MemoTrie >= 0.6.11 && < 1 -- mtl >= 2.3 && < 3 +- lens >= 5.0 && < 6 +- MemoTrie >= 0.6 && < 1 +- mtl >= 2.2 && < 3 - profunctors >= 5.6 && < 6 - tagged >= 0.8 && < 1 -- template-haskell >= 2.18 && < 3 +- template-haskell >= 2.17 && < 3 - text >= 2 && < 3 -- th-abstraction >= 0.5 && < 1 -- vector >= 0.13 && < 1 +- th-abstraction >= 0.4 && < 1 +- vector >= 0.12 && < 1 - witherable >= 0.4 && < 1 ghc-options: @@ -95,5 +95,5 @@ tests: source-dirs: test dependencies: - distributors - - doctest >= 0.20 && < 1 - - hspec >= 2.10 && < 3 + - doctest >= 0.18 && < 1 + - hspec >= 2.7 && < 3 From 3582db19d459e65ec0024385698e04b3269f0062 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 16:26:25 -0800 Subject: [PATCH 280/282] Update README.md --- README.md | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index 4a68cc1..aa2a64c 100644 --- a/README.md +++ b/README.md @@ -18,7 +18,8 @@ The term "distributor" is a synonym for "[profunctor](https://ncatlab.org/nlab/s 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 language syntax design. +This library provides a study distributor theory and optics, +and their application to invertible grammar theory. ## previous work @@ -28,6 +29,11 @@ While `Distributor`s in the library are lax distributive endoprofunctors, a math The idea for unifying Backus-Naur grammars with parsers comes from Joachim Breitner in a post [Showcasing Applicative](https://www.joachim-breitner.de/blog/710-Showcasing_Applicative). +The idea for using monadic profunctors for reversible context-free grammars +comes from Li-Yao Xia, in some posts and a paper but particularly +this post on [Monadic profunctors for bidirectional programming] +(https://blog.poisson.chat/posts/2017-01-01-monadic-profunctors.html). + 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. From dd7fb77b99c1cd6e68c351f56e705232d49b111c Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 16:29:16 -0800 Subject: [PATCH 281/282] Update LICENSE --- LICENSE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/LICENSE b/LICENSE index d43363b..c969d4b 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Eitan Chatav (c) 2024 +Copyright Eitan Chatav (c) 2026 All rights reserved. From 6ec59e932d869aab5f7fda25761ce4800f98b978 Mon Sep 17 00:00:00 2001 From: Eitan Chatav Date: Thu, 5 Feb 2026 16:31:01 -0800 Subject: [PATCH 282/282] Update README.md --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index aa2a64c..f5992d9 100644 --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ The term "distributor" is a synonym for "[profunctor](https://ncatlab.org/nlab/s 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 distributor theory and optics, +This library provides a study of distributor theory and optics, and their application to invertible grammar theory. ## previous work @@ -30,7 +30,7 @@ While `Distributor`s in the library are lax distributive endoprofunctors, a math The idea for unifying Backus-Naur grammars with parsers comes from Joachim Breitner in a post [Showcasing Applicative](https://www.joachim-breitner.de/blog/710-Showcasing_Applicative). The idea for using monadic profunctors for reversible context-free grammars -comes from Li-Yao Xia, in some posts and a paper but particularly +comes from Li-Yao Xia, in some posts and a paper but particularly this post on [Monadic profunctors for bidirectional programming] (https://blog.poisson.chat/posts/2017-01-01-monadic-profunctors.html).