Merge pull request #18 from morphismtech/polyadic-branch2

Polyadic branch2

Author: echatav

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

distributors.cabal

@@ -33,19 +33,16 @@ 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
       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.Do.Bond
-      Data.Profunctor.Do.Polyadic.Bind
-      Data.Profunctor.Do.Polyadic.Bond
       Data.Profunctor.Filtrator
       Data.Profunctor.Grammar
       Data.Profunctor.Monadic

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

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

src/Data/Profunctor/Do/Bond.hs src/Control/Lens/Grammar/Do.hssrc/Data/Profunctor/Do/Bond.hs renamed to 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,16 @@ module Data.Profunctor.Do.Bond
   , return
   ) where
 
-import Control.Lens (Optic)
+import Control.Applicative hiding ((<$>))
+import Control.Lens
+import Control.Lens.Grammar.BackusNaur
 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 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 >>=
-(>>=) = flip bondM
+(>>=) = bondM
 
 (>>) :: Monadic m p => p m () () -> p m b c -> p m b c
 infixl 1 >>
@@ -38,3 +38,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

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

src/Control/Lens/Internal/Equator.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)))