summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorcmk <>2019-12-02 17:30:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-12-02 17:30:00 (GMT)
commit318cbb4e2078760bcc62f04a347bc0a0c68d3965 (patch)
tree3133a9b162b17b1edee2447c94b68bf7568e6831
parentbf9495cd762c9e85620fb7400e30ac2225fca0c6 (diff)
version 0.0.0.2HEAD0.0.0.2master
-rw-r--r--ChangeLog.md5
-rw-r--r--profunctor-arrows.cabal3
-rw-r--r--src/Data/Profunctor/Arrow.hs111
-rw-r--r--src/Data/Profunctor/Arrow/Free.hs31
-rw-r--r--src/Data/Profunctor/Extra.hs232
5 files changed, 268 insertions, 114 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..0fa6e83
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,5 @@
+# Revision history for dioids
+
+## 0.0.1 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/profunctor-arrows.cabal b/profunctor-arrows.cabal
index 3a9c6e5..027199d 100644
--- a/profunctor-arrows.cabal
+++ b/profunctor-arrows.cabal
@@ -1,7 +1,7 @@
cabal-version: >= 1.10
name: profunctor-arrows
-version: 0.0.0.1
+version: 0.0.0.2
synopsis: Profunctor arrows
description: Free prearrows and arrows for profunctors.
category: Data, Profunctors
@@ -13,6 +13,7 @@ copyright: 2019 Chris McKinlay
license: BSD3
license-file: LICENSE
build-type: Simple
+extra-source-files: ChangeLog.md
source-repository head
type: git
diff --git a/src/Data/Profunctor/Arrow.hs b/src/Data/Profunctor/Arrow.hs
index 0391252..f57cb9e 100644
--- a/src/Data/Profunctor/Arrow.hs
+++ b/src/Data/Profunctor/Arrow.hs
@@ -1,37 +1,42 @@
{-# LANGUAGE GADTs #-}
-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ExistentialQuantification #-}
-module Data.Profunctor.Arrow where
+module Data.Profunctor.Arrow (
+ arr
+ , ex1
+ , ex2
+ , inl
+ , inr
+ , braid
+ , ebraid
+ , loop
+ , left
+ , right
+ , first
+ , second
+ , returnA
+ , (***)
+ , (+++)
+ , (&&&)
+ , (|||)
+ , ($$$)
+ , adivide
+ , adivide'
+ , adivided
+ , aselect
+ , aselect'
+ , aselected
+) where
-import Control.Arrow (Arrow)
import Control.Category hiding ((.), id)
import Data.Profunctor
import Data.Profunctor.Extra
import Prelude
-import qualified Control.Arrow as A
import qualified Control.Category as C
-newtype PArrow p a b = PArrow { runPArrow :: forall x y. p (b , x) y -> p (a , x) y }
-
-instance Profunctor p => Profunctor (PArrow p) where
- dimap f g (PArrow pp) = PArrow $ \p -> dimap (lft f) id (pp (dimap (lft g) id p))
- where lft h (a, b) = (h a, b)
-
-instance Profunctor p => Category (PArrow p) where
- id = PArrow id
-
- PArrow pp . PArrow qq = PArrow $ \r -> qq (pp r)
-
-instance Profunctor p => Strong (PArrow p) where
- first' (PArrow pp) = PArrow $ lmap assocr . pp . lmap assocl
-
-toArrow :: Arrow a => PArrow a b c -> a b c
-toArrow (PArrow aa) = A.arr (\x -> (x,())) >>> aa (A.arr fst)
-
-fromArrow :: Arrow a => a b c -> PArrow a b c
-fromArrow x = PArrow (\z -> A.first x >>> z)
-
+-- | Lift a function into a profunctor arrow.
+--
+-- Usable w/ arrow syntax w/ the /Arrows/ & /RebindableSyntax/ extensions.
+--
-- @
-- (a '>>>' b) '>>>' c = a '>>>' (b '>>>' c)
-- 'arr' f '>>>' a = 'dimap' f id a
@@ -41,36 +46,43 @@ fromArrow x = PArrow (\z -> A.first x >>> z)
--
arr :: Category p => Profunctor p => (a -> b) -> p a b
arr f = rmap f C.id
-
-preturn :: Category p => Profunctor p => p a a
-preturn = arr id
+{-# INLINE arr #-}
ex1 :: Category p => Profunctor p => p (a , b) b
ex1 = arr snd
+{-# INLINE ex1 #-}
ex2 :: Category p => Profunctor p => p (a , b) a
ex2 = arr fst
+{-# INLINE ex2 #-}
inl :: Category p => Profunctor p => p a (a + b)
inl = arr Left
+{-# INLINE inl #-}
inr :: Category p => Profunctor p => p b (a + b)
inr = arr Right
+{-# INLINE inr #-}
braid :: Category p => Profunctor p => p (a , b) (b , a)
-braid = arr swp
+braid = arr swap
+{-# INLINE braid #-}
-braide :: Category p => Profunctor p => p (a + b) (b + a)
-braide = arr eswp
+ebraid :: Category p => Profunctor p => p (a + b) (b + a)
+ebraid = arr eswap
+{-# INLINE ebraid #-}
loop :: Costrong p => p (a, d) (b, d) -> p a b
loop = unfirst
+{-# INLINE loop #-}
left :: Choice p => p a b -> p (a + c) (b + c)
left = left'
+{-# INLINE left #-}
right :: Choice p => p a b -> p (c + a) (c + b)
right = right'
+{-# INLINE right #-}
-- @
-- first ('arr' f) = 'arr' (f '***' id)
@@ -79,53 +91,66 @@ right = right'
--
first :: Strong p => p a b -> p (a , c) (b , c)
first = first'
+{-# INLINE first #-}
second :: Strong p => p a b -> p (c , a) (c , b)
second = second'
+{-# INLINE second #-}
returnA :: Category p => Profunctor p => p a a
returnA = C.id
+{-# INLINE returnA #-}
infixr 3 ***
(***) :: Category p => Strong p => p a1 b1 -> p a2 b2 -> p (a1 , a2) (b1 , b2)
-x *** y = first x >>> arr swp >>> first y >>> arr swp
+x *** y = first x >>> arr swap >>> first y >>> arr swap
+{-# INLINE (***) #-}
infixr 2 +++
(+++) :: Category p => Choice p => p a1 b1 -> p a2 b2 -> p (a1 + a2) (b1 + b2)
-x +++ y = left x >>> arr eswp >>> left y >>> arr eswp
+x +++ y = left x >>> arr eswap >>> left y >>> arr eswap
+{-# INLINE (+++) #-}
infixr 3 &&&
(&&&) :: Category p => Strong p => p a b1 -> p a b2 -> p a (b1 , b2)
x &&& y = dimap fork id $ x *** y
+{-# INLINE (&&&) #-}
infixr 2 |||
(|||) :: Category p => Choice p => p a1 b -> p a2 b -> p (a1 + a2) b
-x ||| y = achoose id x y
+x ||| y = dimap id join $ x +++ y
+{-# INLINE (|||) #-}
infixr 0 $$$
($$$) :: Category p => Strong p => p a (b -> c) -> p a b -> p a c
($$$) f x = dimap fork apply (f *** x)
+{-# INLINE ($$$) #-}
-achoose :: Category p => Choice p => (a -> (a1 + a2)) -> p a1 b -> p a2 b -> p a b
-achoose f x y = dimap f join $ x +++ y
-
--- | Profunctor arrow equivalent of 'Data.Functor.Divisible.divide'.
---
adivide :: Category p => Strong p => (a -> (a1 , a2)) -> p a1 b -> p a2 b -> p a b
adivide f x y = dimap f fst $ x *** y
+{-# INLINE adivide #-}
-aselect :: Category p => Choice p => ((b1 + b2) -> b) -> p a b1 -> p a b2 -> p a b
-aselect f x y = dimap Left f $ x +++ y
+adivide' :: Category p => Strong p => p a b -> p a b -> p a b
+adivide' = adivide fork
+{-# INLINE adivide' #-}
--- | Profunctor arrow equivalent of 'Data.Functor.Divisible.divided'.
---
adivided :: Category p => Strong p => p a1 b -> p a2 b -> p (a1 , a2) b
adivided = adivide id
+{-# INLINE adivided #-}
+
+aselect :: Category p => Choice p => ((b1 + b2) -> b) -> p a b1 -> p a b2 -> p a b
+aselect f x y = dimap Left f $ x +++ y
+{-# INLINE aselect #-}
+
+aselect' :: Category p => Choice p => p a b -> p a b -> p a b
+aselect' = aselect join
+{-# INLINE aselect' #-}
aselected :: Category p => Choice p => p a b1 -> p a b2 -> p a (b1 + b2)
aselected = aselect id
+{-# INLINE aselected #-}
diff --git a/src/Data/Profunctor/Arrow/Free.hs b/src/Data/Profunctor/Arrow/Free.hs
index 72cb419..336dcd6 100644
--- a/src/Data/Profunctor/Arrow/Free.hs
+++ b/src/Data/Profunctor/Arrow/Free.hs
@@ -1,17 +1,42 @@
{-# LANGUAGE GADTs #-}
-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ExistentialQuantification #-}
module Data.Profunctor.Arrow.Free where
+import Control.Arrow (Arrow)
import Control.Category hiding ((.), id)
import Data.Profunctor
import Data.Profunctor.Arrow
+import Data.Profunctor.Extra
import Data.Profunctor.Traversing
+import qualified Control.Arrow as A
import qualified Control.Category as C
import Prelude
+-- | Lift a profunctor into an 'Arrow' cofreely.
+--
+newtype PArrow p a b = PArrow { runPArrow :: forall x y. p (b , x) y -> p (a , x) y }
+
+instance Profunctor p => Profunctor (PArrow p) where
+ dimap f g (PArrow pp) = PArrow $ \p -> dimap (lft f) id (pp (dimap (lft g) id p))
+ where lft h (a, b) = (h a, b)
+
+instance Profunctor p => Category (PArrow p) where
+ id = PArrow id
+
+ PArrow pp . PArrow qq = PArrow $ \r -> qq (pp r)
+
+instance Profunctor p => Strong (PArrow p) where
+ first' (PArrow pp) = PArrow $ lmap assocr . pp . lmap assocl
+
+toArrow :: Arrow a => PArrow a b c -> a b c
+toArrow (PArrow aa) = A.arr (\x -> (x,())) >>> aa (A.arr fst)
+{-# INLINE toArrow #-}
+
+fromArrow :: Arrow a => a b c -> PArrow a b c
+fromArrow x = PArrow (\z -> A.first x >>> z)
+{-# INLINE fromArrow #-}
+
-- | Free monoid in the category of profunctors.
--
-- See <https://arxiv.org/abs/1406.4823> section 6.2.
@@ -55,11 +80,13 @@ instance Mapping p => Mapping (Free p) where
foldFree :: Category q => Profunctor q => p :-> q -> Free p a b -> q a b
foldFree _ (Parr ab) = arr ab
foldFree pq (Free p f) = pq p <<< foldFree pq f
+{-# INLINE foldFree #-}
-- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @'Free' f@ to @'Free' g@.
hoistFree :: p :-> q -> Free p a b -> Free q a b
hoistFree _ (Parr ab) = Parr ab
hoistFree pq (Free p f) = Free (pq p) (hoistFree pq f)
+{-# INLINE hoistFree #-}
-- Analog of 'Const' for pliftows
newtype Append r a b = Append { getAppend :: r }
diff --git a/src/Data/Profunctor/Extra.hs b/src/Data/Profunctor/Extra.hs
index ca6ee71..718e00a 100644
--- a/src/Data/Profunctor/Extra.hs
+++ b/src/Data/Profunctor/Extra.hs
@@ -1,5 +1,64 @@
-module Data.Profunctor.Extra where
-
+module Data.Profunctor.Extra (
+ type (+)
+ , rgt
+ , rgt'
+ , lft
+ , lft'
+ , swap
+ , eswap
+ , fork
+ , join
+ , eval
+ , apply
+ , coeval
+ , branch
+ , branch'
+ , assocl
+ , assocr
+ , assocl'
+ , assocr'
+ , eassocl
+ , eassocr
+ , eassocr'
+ , forget1
+ , forget2
+ , forgetl
+ , forgetr
+ , unarr
+ , peval
+ , constl
+ , constr
+ , shiftl
+ , shiftr
+ , coercel
+ , coercer
+ , coercel'
+ , coercer'
+ , strong
+ , costrong
+ , choice
+ , cochoice
+ , pull
+ , repn
+ , corepn
+ , star
+ , toStar
+ , fromStar
+ , costar
+ , uncostar
+ , toCostar
+ , fromCostar
+ , pushr
+ , pushl
+ , pliftA
+ , pdivide
+ , pappend
+ , (<<*>>)
+ , (****)
+ , (&&&&)
+) where
+
+import Control.Applicative (liftA2)
import Control.Arrow ((|||),(&&&))
import Control.Category (Category)
import Control.Comonad (Comonad(..))
@@ -8,6 +67,7 @@ import Data.Functor.Contravariant
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
+import Data.Tuple (swap)
import Data.Void
import Prelude
import qualified Control.Category as C (id)
@@ -19,194 +79,230 @@ type (+) = Either
rgt :: (a -> b) -> a + b -> b
rgt f = either f id
-
+{-# INLINE rgt #-}
+
rgt' :: Void + b -> b
rgt' = rgt absurd
+{-# INLINE rgt' #-}
lft :: (b -> a) -> a + b -> a
lft f = either id f
+{-# INLINE lft #-}
lft' :: a + Void -> a
lft' = lft absurd
+{-# INLINE lft' #-}
-swp :: (a1 , a2) -> (a2 , a1)
-swp = snd &&& fst
-
-eswp :: (a1 + a2) -> (a2 + a1)
-eswp = Right ||| Left
+eswap :: (a1 + a2) -> (a2 + a1)
+eswap = Right ||| Left
+{-# INLINE eswap #-}
fork :: a -> (a , a)
fork = M.join (,)
+{-# INLINE fork #-}
join :: (a + a) -> a
join = M.join either id
+{-# INLINE join #-}
eval :: (a , a -> b) -> b
eval = uncurry $ flip id
+{-# INLINE eval #-}
apply :: (b -> a , b) -> a
apply = uncurry id
+{-# INLINE apply #-}
coeval :: b -> (b -> a) + a -> a
coeval b = either ($ b) id
+{-# INLINE coeval #-}
branch :: (a -> Bool) -> b -> c -> a -> b + c
branch f y z x = if f x then Right z else Left y
+{-# INLINE branch #-}
branch' :: (a -> Bool) -> a -> a + a
branch' f x = branch f x x x
+{-# INLINE branch' #-}
assocl :: (a , (b , c)) -> ((a , b) , c)
assocl (a, (b, c)) = ((a, b), c)
+{-# INLINE assocl #-}
assocr :: ((a , b) , c) -> (a , (b , c))
assocr ((a, b), c) = (a, (b, c))
+{-# INLINE assocr #-}
+
+assocl' :: (a , b + c) -> (a , b) + c
+assocl' = eswap . traverse eswap
+{-# INLINE assocl' #-}
+
+assocr' :: (a + b , c) -> a + (b , c)
+assocr' (f, b) = fmap (,b) f
+{-# INLINE assocr' #-}
-eassocl :: (a + (b + c)) -> ((a + b) + c)
+eassocl :: a + (b + c) -> (a + b) + c
eassocl (Left a) = Left (Left a)
eassocl (Right (Left b)) = Left (Right b)
eassocl (Right (Right c)) = Right c
+{-# INLINE eassocl #-}
-eassocr :: ((a + b) + c) -> (a + (b + c))
+eassocr :: (a + b) + c -> a + (b + c)
eassocr (Left (Left a)) = Left a
eassocr (Left (Right b)) = Right (Left b)
eassocr (Right c) = Right (Right c)
+{-# INLINE eassocr #-}
-fstrong :: Functor f => f a -> b -> f (a , b)
-fstrong f b = fmap (,b) f
+eassocr' :: (a -> b) + c -> a -> b + c
+eassocr' abc a = either (\ab -> Left $ ab a) Right abc
+{-# INLINE eassocr' #-}
-fchoice :: Traversable f => f (a + b) -> (f a) + b
-fchoice = eswp . traverse eswp
-
-forget1 :: ((c , a) -> (c , b)) -> a -> b
+forget1 :: ((c, a) -> (c, b)) -> a -> b
forget1 f a = b where (c, b) = f (c, a)
+{-# INLINE forget1 #-}
-forget2 :: ((a , c) -> (b , c)) -> a -> b
+forget2 :: ((a, c) -> (b, c)) -> a -> b
forget2 f a = b where (b, c) = f (a, c)
+{-# INLINE forget2 #-}
-forgetl :: ((c + a) -> (c + b)) -> a -> b
+forgetl :: (c + a -> c + b) -> a -> b
forgetl f = go . Right where go = either (go . Left) id . f
+{-# INLINE forgetl #-}
-forgetr :: ((a + c) -> (b + c)) -> a -> b
+forgetr :: (a + c -> b + c) -> a -> b
forgetr f = go . Left where go = either id (go . Right) . f
+{-# INLINE forgetr #-}
unarr :: Comonad w => Sieve p w => p a b -> a -> b
unarr = (extract .) . sieve
+{-# INLINE unarr #-}
peval :: Strong p => p a (a -> b) -> p a b
peval = rmap eval . pull
+{-# INLINE peval #-}
constl :: Profunctor p => b -> p b c -> p a c
constl = lmap . const
+{-# INLINE constl #-}
constr :: Profunctor p => c -> p a b -> p a c
constr = rmap . const
+{-# INLINE constr #-}
shiftl :: Profunctor p => p (a + b) c -> p b (c + d)
shiftl = dimap Right Left
+{-# INLINE shiftl #-}
shiftr :: Profunctor p => p b (c , d) -> p (a , b) c
shiftr = dimap snd fst
-
-coercer :: Profunctor p => Contravariant (p a) => p a b -> p a c
-coercer = rmap absurd . contramap absurd
-
-coercer' :: Representable p => Contravariant (Rep p) => p a b -> p a c
-coercer' = lift (phantom .)
+{-# INLINE shiftr #-}
coercel :: Profunctor p => Bifunctor p => p a b -> p c b
coercel = first absurd . lmap absurd
+{-# INLINE coercel #-}
+
+coercer :: Profunctor p => Contravariant (p a) => p a b -> p a c
+coercer = rmap absurd . contramap absurd
+{-# INLINE coercer #-}
coercel' :: Corepresentable p => Contravariant (Corep p) => p a b -> p c b
-coercel' = lower (. phantom)
+coercel' = corepn (. phantom)
+{-# INLINE coercel' #-}
+
+coercer' :: Representable p => Contravariant (Rep p) => p a b -> p a c
+coercer' = repn (phantom .)
+{-# INLINE coercer' #-}
strong :: Strong p => ((a , b) -> c) -> p a b -> p a c
strong f = dimap fork f . second'
+{-# INLINE strong #-}
costrong :: Costrong p => ((a , b) -> c) -> p c a -> p b a
costrong f = unsecond . dimap f fork
+{-# INLINE costrong #-}
choice :: Choice p => (c -> (a + b)) -> p b a -> p c a
choice f = dimap f join . right'
+{-# INLINE choice #-}
cochoice :: Cochoice p => (c -> (a + b)) -> p a c -> p a b
cochoice f = unright . dimap join f
+{-# INLINE cochoice #-}
pull :: Strong p => p a b -> p a (a , b)
pull = lmap fork . second'
+{-# INLINE pull #-}
-pull' :: Strong p => p b c -> p (a , b) b
-pull' = shiftr . pull
-
-lift :: Representable p => ((a -> Rep p b) -> s -> Rep p t) -> p a b -> p s t
-lift f = tabulate . f . sieve
+repn :: Representable p => ((a -> Rep p b) -> s -> Rep p t) -> p a b -> p s t
+repn f = tabulate . f . sieve
+{-# INLINE repn #-}
-lower :: Corepresentable p => ((Corep p a -> b) -> Corep p s -> t) -> p a b -> p s t
-lower f = cotabulate . f . cosieve
+corepn :: Corepresentable p => ((Corep p a -> b) -> Corep p s -> t) -> p a b -> p s t
+corepn f = cotabulate . f . cosieve
+{-# INLINE corepn #-}
star :: Applicative f => Star f a a
star = Star pure
+{-# INLINE star #-}
toStar :: Sieve p f => p d c -> Star f d c
toStar = Star . sieve
+{-# INLINE toStar #-}
fromStar :: Representable p => Star (Rep p) a b -> p a b
fromStar = tabulate . runStar
+{-# INLINE fromStar #-}
costar :: Foldable f => Monoid b => (a -> b) -> Costar f a b
costar f = Costar (foldMap f)
+{-# INLINE costar #-}
uncostar :: Applicative f => Costar f a b -> a -> b
uncostar f = runCostar f . pure
+{-# INLINE uncostar #-}
toCostar :: Cosieve p f => p a b -> Costar f a b
toCostar = Costar . cosieve
+{-# INLINE toCostar #-}
fromCostar :: Corepresentable p => Costar (Corep p) a b -> p a b
fromCostar = cotabulate . runCostar
+{-# INLINE fromCostar #-}
-pushr :: Closed p => (forall x. Applicative (p x)) => p (a , b) c -> p a b -> p a c
-pushr = papply . curry'
+pushr :: Closed p => Representable p => Applicative (Rep p) => p (a , b) c -> p a b -> p a c
+pushr = (<<*>>) . curry'
+{-# INLINE pushr #-}
-pushl :: Closed p => (forall x. Applicative (p x)) => p a c -> p b c -> p a (b -> c)
-pushl f g = curry' $ pdivided f g
+pushl :: Closed p => Representable p => Applicative (Rep p) => p a c -> p b c -> p a (b -> c)
+pushl p q = curry' $ pdivide id p q
+{-# INLINE pushl #-}
-ppure :: Profunctor p => (forall x. Applicative (p x)) => b -> p a b
-ppure b = dimap (const ()) (const b) $ pure ()
+pliftA :: Representable p => Applicative (Rep p) => (b -> c -> d) -> p a b -> p a c -> p a d
+pliftA f x y = tabulate $ \s -> liftA2 f (sieve x s) (sieve y s)
+{-# INLINE pliftA #-}
---pabsurd :: Profunctor p => (forall x. Divisible (p x)) => p Void a
---pabsurd = rmap absurd $ conquer
+infixl 4 <<*>>
-infixr 3 @@@
+(<<*>>) :: Representable p => Applicative (Rep p) => p a (b -> c) -> p a b -> p a c
+(<<*>>) = pliftA ($)
+{-# INLINE (<<*>>) #-}
--- | Profunctor version of '***' from 'Control.Arrow'.
---
--- @
--- p <*> x ≡ dimap fork eval (p @@@ x)
--- @
---
-(@@@) :: Profunctor p => (forall x. Applicative (p x)) => p a1 b1 -> p a2 b2 -> p (a1 , a2) (b1 , b2)
-f @@@ g = pappend f g
+infixr 3 ****
-pappend :: Profunctor p => (forall x. Applicative (p x)) => p a1 b1 -> p a2 b2 -> p (a1 , a2) (b1 , b2)
-pappend f g = dimap fst (,) f <*> lmap snd g
+(****) :: Representable p => Applicative (Rep p) => p a1 b1 -> p a2 b2 -> p (a1 , a2) (b1 , b2)
+p **** q = dimap fst (,) p <<*>> lmap snd q
+{-# INLINE (****) #-}
--- | Profunctor equivalent of 'Data.Functor.Divisible.divide'.
---
-pdivide :: Profunctor p => (forall x. Applicative (p x)) => (a -> (a1 , a2)) -> p a1 b -> p a2 b -> p a b
-pdivide f x y = dimap f fst $ x @@@ y
+infixr 3 &&&&
--- | Profunctor equivalent of 'Data.Functor.Divisible.divided'.
---
-pdivided :: Profunctor p => (forall x. Applicative (p x)) => p a1 b -> p a2 b -> p (a1 , a2) b
-pdivided = pdivide id
+(&&&&) :: Representable p => Applicative (Rep p) => p a b1 -> p a b2 -> p a (b1 , b2)
+p &&&& q = pliftA (,) p q
+{-# INLINE (&&&&) #-}
--- | Profunctor equivalent of '<*>'.
---
-papply :: Profunctor p => (forall x. Applicative (p x)) => p a (b -> c) -> p a b -> p a c
-papply f x = dimap fork apply (f @@@ x)
+pdivide :: Representable p => Applicative (Rep p) => (a -> (a1 , a2)) -> p a1 b -> p a2 b -> p a b
+pdivide f p q = dimap f fst $ dimap fst (,) p <<*>> lmap snd q
+{-# INLINE pdivide #-}
--- | Profunctor equivalent of 'liftA2'.
---
-pliftA2 :: Profunctor p => (forall x. Applicative (p x)) => ((b1 , b2) -> b) -> p a b1 -> p a b2 -> p a b
-pliftA2 f x y = dimap fork f $ pappend x y
+pappend :: Representable p => Applicative (Rep p) => p a b -> p a b -> p a b
+pappend = pdivide fork
+{-# INLINE pappend #-}