summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorcmk <>2019-11-12 04:09:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-11-12 04:09:00 (GMT)
commitbf9495cd762c9e85620fb7400e30ac2225fca0c6 (patch)
treea0be9c4ab37558de7e00c0f61031802f36887f2e
version 0.0.0.10.0.0.1
-rw-r--r--LICENSE14
-rw-r--r--profunctor-arrows.cabal50
-rw-r--r--src/Data/Profunctor/Arrow.hs131
-rw-r--r--src/Data/Profunctor/Arrow/Adapter.hs50
-rw-r--r--src/Data/Profunctor/Arrow/Affine.hs42
-rw-r--r--src/Data/Profunctor/Arrow/Choice.hs52
-rw-r--r--src/Data/Profunctor/Arrow/Closed.hs42
-rw-r--r--src/Data/Profunctor/Arrow/Free.hs72
-rw-r--r--src/Data/Profunctor/Arrow/Internal.hs177
-rw-r--r--src/Data/Profunctor/Arrow/Strong.hs43
-rw-r--r--src/Data/Profunctor/Arrow/Traversing.hs59
-rw-r--r--src/Data/Profunctor/Extra.hs212
12 files changed, 944 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..4948990
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,14 @@
+BSD 3-Clause License
+
+Copyright Christopher McKinlay (c) 2019
+
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
diff --git a/profunctor-arrows.cabal b/profunctor-arrows.cabal
new file mode 100644
index 0000000..3a9c6e5
--- /dev/null
+++ b/profunctor-arrows.cabal
@@ -0,0 +1,50 @@
+cabal-version: >= 1.10
+
+name: profunctor-arrows
+version: 0.0.0.1
+synopsis: Profunctor arrows
+description: Free prearrows and arrows for profunctors.
+category: Data, Profunctors
+homepage: https://github.com/cmk/profunctor-extras
+bug-reports: https://github.com/cmk/profunctor-extras/issues
+author: Chris McKinlay
+maintainer: Chris McKinlay
+copyright: 2019 Chris McKinlay
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+
+source-repository head
+ type: git
+ location: https://github.com/cmk/profunctor-extras
+
+library
+ exposed-modules:
+ Data.Profunctor.Arrow
+ Data.Profunctor.Arrow.Free
+ Data.Profunctor.Arrow.Adapter
+ Data.Profunctor.Arrow.Affine
+ Data.Profunctor.Arrow.Choice
+ Data.Profunctor.Arrow.Closed
+ Data.Profunctor.Arrow.Strong
+ Data.Profunctor.Arrow.Traversing
+ Data.Profunctor.Extra
+ other-modules:
+ Data.Profunctor.Arrow.Internal
+ hs-source-dirs:
+ src
+ default-extensions:
+ RankNTypes
+ ConstraintKinds
+ TypeFamilies
+ TupleSections
+ TypeOperators
+ FlexibleContexts
+ FlexibleInstances
+ QuantifiedConstraints
+ default-language: Haskell2010
+ ghc-options: -Wall
+ build-depends:
+ base >= 4.9 && <5.0
+ , comonad >= 4 && < 6
+ , profunctors >= 5.3 && < 6
diff --git a/src/Data/Profunctor/Arrow.hs b/src/Data/Profunctor/Arrow.hs
new file mode 100644
index 0000000..0391252
--- /dev/null
+++ b/src/Data/Profunctor/Arrow.hs
@@ -0,0 +1,131 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Data.Profunctor.Arrow 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)
+
+-- @
+-- (a '>>>' b) '>>>' c = a '>>>' (b '>>>' c)
+-- 'arr' f '>>>' a = 'dimap' f id a
+-- a '>>>' arr f = 'dimap' id f a
+-- 'arr' (g . f) = 'arr' f '>>>' 'arr' g
+-- @
+--
+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
+
+ex1 :: Category p => Profunctor p => p (a , b) b
+ex1 = arr snd
+
+ex2 :: Category p => Profunctor p => p (a , b) a
+ex2 = arr fst
+
+inl :: Category p => Profunctor p => p a (a + b)
+inl = arr Left
+
+inr :: Category p => Profunctor p => p b (a + b)
+inr = arr Right
+
+braid :: Category p => Profunctor p => p (a , b) (b , a)
+braid = arr swp
+
+braide :: Category p => Profunctor p => p (a + b) (b + a)
+braide = arr eswp
+
+loop :: Costrong p => p (a, d) (b, d) -> p a b
+loop = unfirst
+
+left :: Choice p => p a b -> p (a + c) (b + c)
+left = left'
+
+right :: Choice p => p a b -> p (c + a) (c + b)
+right = right'
+
+-- @
+-- first ('arr' f) = 'arr' (f '***' id)
+-- first (a '>>>' b) = first a '>>>' first b
+-- @
+--
+first :: Strong p => p a b -> p (a , c) (b , c)
+first = first'
+
+second :: Strong p => p a b -> p (c , a) (c , b)
+second = second'
+
+returnA :: Category p => Profunctor p => p a a
+returnA = C.id
+
+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
+
+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
+
+infixr 3 &&&
+
+(&&&) :: Category p => Strong p => p a b1 -> p a b2 -> p a (b1 , b2)
+x &&& y = dimap fork id $ x *** y
+
+infixr 2 |||
+
+(|||) :: Category p => Choice p => p a1 b -> p a2 b -> p (a1 + a2) b
+x ||| y = achoose id x y
+
+infixr 0 $$$
+
+($$$) :: Category p => Strong p => p a (b -> c) -> p a b -> p a c
+($$$) f x = dimap fork apply (f *** x)
+
+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
+
+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
+
+-- | 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
+
+aselected :: Category p => Choice p => p a b1 -> p a b2 -> p a (b1 + b2)
+aselected = aselect id
diff --git a/src/Data/Profunctor/Arrow/Adapter.hs b/src/Data/Profunctor/Arrow/Adapter.hs
new file mode 100644
index 0000000..4688220
--- /dev/null
+++ b/src/Data/Profunctor/Arrow/Adapter.hs
@@ -0,0 +1,50 @@
+module Data.Profunctor.Arrow.Adapter (
+ Coyoneda
+ , AdapterA
+ , liftAdapter
+ , foldAdapter
+ , runAdapterT
+ , runAdapterM
+ , runAdapterW
+) where
+
+import Control.Arrow (Kleisli(..))
+import Control.Category hiding ((.), id)
+import Control.Comonad (Comonad, Cokleisli(..))
+import Data.Profunctor
+import Data.Profunctor.Arrow.Free
+import Data.Profunctor.Yoneda
+
+import Prelude
+
+type AdapterA p = Free (Coyoneda p)
+
+{-# INLINE liftAdapter #-}
+-- | TODO: Document
+--
+liftAdapter :: p a b -> AdapterA p a b
+liftAdapter p = Free (Coyoneda id id p) (Parr id)
+
+{-# INLINE foldAdapter #-}
+-- | TODO: Document
+--
+foldAdapter :: Category q => Profunctor q => p :-> q -> AdapterA p a b -> q a b
+foldAdapter pq = foldFree (runAdapterT pq)
+
+{-# INLINE runAdapterT #-}
+-- | TODO: Document
+--
+runAdapterT :: Profunctor q => p :-> q -> Coyoneda p a b -> q a b
+runAdapterT pq (Coyoneda l r p) = dimap l r (pq p)
+
+{-# INLINE runAdapterM #-}
+-- | TODO: Document
+--
+runAdapterM :: Monad m => (forall x y. p x y -> x -> m y) -> AdapterA p a b -> a -> m b
+runAdapterM f = runKleisli . foldAdapter (Kleisli . f)
+
+{-# INLINE runAdapterW #-}
+-- | TODO: Document
+--
+runAdapterW :: Comonad w => (forall x y. p x y -> w x -> y) -> AdapterA p a b -> w a -> b
+runAdapterW f = runCokleisli . foldAdapter (Cokleisli . f)
diff --git a/src/Data/Profunctor/Arrow/Affine.hs b/src/Data/Profunctor/Arrow/Affine.hs
new file mode 100644
index 0000000..bfc560c
--- /dev/null
+++ b/src/Data/Profunctor/Arrow/Affine.hs
@@ -0,0 +1,42 @@
+module Data.Profunctor.Arrow.Affine (
+ AffineT
+ , AffineA
+ , liftAffine
+ , foldAffine
+ , runAffineT
+ , runAffineM
+) where
+
+import Control.Arrow (Kleisli(..))
+import Control.Category hiding ((.), id)
+import Data.Profunctor
+import Data.Profunctor.Arrow.Free
+import Data.Profunctor.Arrow.Internal
+
+import Prelude
+
+type AffineA p = Free (AffineT p)
+
+{-# INLINE liftAffine #-}
+-- | TODO: Document
+--
+liftAffine :: p a b -> AffineA p a b
+liftAffine p = Free (affine_lift p) (Parr id)
+
+{-# INLINE foldAffine #-}
+-- | TODO: Document
+--
+foldAffine :: Category q => Choice q => Strong q => p :-> q -> AffineA p a b -> q a b
+foldAffine pq = foldFree (runAffineT pq)
+
+{-# INLINE runAffineT #-}
+-- | TODO: Document
+--
+runAffineT :: Choice q => Strong q => p :-> q -> AffineT p a b -> q a b
+runAffineT pq (Trans l p r) = dimap l r (affine (pq p))
+
+{-# INLINE runAffineM #-}
+-- | TODO: Document
+--
+runAffineM :: Monad m => (forall x y. p x y -> x -> m y) -> AffineA p a b -> a -> m b
+runAffineM f = runKleisli . foldAffine (Kleisli . f)
diff --git a/src/Data/Profunctor/Arrow/Choice.hs b/src/Data/Profunctor/Arrow/Choice.hs
new file mode 100644
index 0000000..0cd9025
--- /dev/null
+++ b/src/Data/Profunctor/Arrow/Choice.hs
@@ -0,0 +1,52 @@
+module Data.Profunctor.Arrow.Choice (
+ PastroSum(..)
+ , ChoiceA
+ , liftChoice
+ , foldChoice
+ , runChoiceT
+ , runChoiceM
+ , runChoiceW
+) where
+
+import Control.Arrow (Kleisli(..))
+import Control.Category hiding ((.), id)
+import Control.Comonad (Comonad, Cokleisli(..))
+
+import Data.Profunctor.Arrow.Free
+import Data.Profunctor.Choice
+import Data.Profunctor
+import Data.Profunctor.Extra
+
+import Prelude
+
+type ChoiceA p = Free (PastroSum p)
+
+{-# INLINE liftChoice #-}
+-- | TODO: Document
+--
+liftChoice :: p a b -> ChoiceA p a b
+liftChoice p = Free (PastroSum lft' p Left) (Parr id)
+
+{-# INLINE foldChoice #-}
+-- | TODO: Document
+--
+foldChoice :: Category q => Choice q => p :-> q -> ChoiceA p a b -> q a b
+foldChoice pq = foldFree (runChoiceT pq)
+
+{-# INLINE runChoiceT #-}
+-- | TODO: Document
+--
+runChoiceT :: Choice q => p :-> q -> PastroSum p a b -> q a b
+runChoiceT pq (PastroSum r p l) = dimap l r (left' (pq p))
+
+{-# INLINE runChoiceM #-}
+-- | TODO: Document
+--
+runChoiceM :: Monad m => (forall x y. p x y -> x -> m y) -> ChoiceA p a b -> (a -> m b)
+runChoiceM f = runKleisli . foldChoice (Kleisli . f)
+
+{-# INLINE runChoiceW #-}
+-- | TODO: Document
+--
+runChoiceW :: Comonad w => (forall x y. p x y -> w x -> y) -> ChoiceA p a b -> (w a -> b)
+runChoiceW f = runCokleisli . foldChoice (Cokleisli . f)
diff --git a/src/Data/Profunctor/Arrow/Closed.hs b/src/Data/Profunctor/Arrow/Closed.hs
new file mode 100644
index 0000000..e9b2953
--- /dev/null
+++ b/src/Data/Profunctor/Arrow/Closed.hs
@@ -0,0 +1,42 @@
+module Data.Profunctor.Arrow.Closed (
+ Environment(..)
+ , ClosedA
+ , liftClosed
+ , foldClosed
+ , runClosedT
+ , runClosedW
+) where
+
+import Control.Category hiding ((.), id)
+import Control.Comonad (Comonad, Cokleisli(..))
+import Data.Profunctor
+import Data.Profunctor.Arrow.Free
+import Data.Profunctor.Closed
+
+import Prelude
+
+type ClosedA p = Free (Environment p)
+
+{-# INLINE liftClosed #-}
+-- | TODO: Document
+--
+liftClosed :: p a b -> ClosedA p a b
+liftClosed p = Free (Environment ($ ()) p const) (Parr id)
+
+{-# INLINE foldClosed #-}
+-- | TODO: Document
+--
+foldClosed :: Category q => Closed q => p :-> q -> ClosedA p a b -> q a b
+foldClosed pq = foldFree (runClosedT pq)
+
+{-# INLINE runClosedT #-}
+-- | TODO: Document
+--
+runClosedT :: Closed q => p :-> q -> Environment p a b -> q a b
+runClosedT pq (Environment r p l) = dimap l r (closed (pq p))
+
+{-# INLINE runClosedW #-}
+-- | TODO: Document
+--
+runClosedW :: Comonad w => (forall x y. p x y -> w x -> y) -> ClosedA p a b -> w a -> b
+runClosedW f = runCokleisli . foldClosed (Cokleisli . f)
diff --git a/src/Data/Profunctor/Arrow/Free.hs b/src/Data/Profunctor/Arrow/Free.hs
new file mode 100644
index 0000000..72cb419
--- /dev/null
+++ b/src/Data/Profunctor/Arrow/Free.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Data.Profunctor.Arrow.Free where
+
+import Control.Category hiding ((.), id)
+import Data.Profunctor
+import Data.Profunctor.Arrow
+import Data.Profunctor.Traversing
+import qualified Control.Category as C
+
+import Prelude
+
+-- | Free monoid in the category of profunctors.
+--
+-- See <https://arxiv.org/abs/1406.4823> section 6.2.
+--
+--
+data Free p a b where
+ Parr :: (a -> b) -> Free p a b
+ Free :: p x b -> Free p a x -> Free p a b
+
+instance Profunctor p => Profunctor (Free p) where
+ dimap l r (Parr f) = Parr (dimap l r f)
+ dimap l r (Free f g) = Free (rmap r f) (lmap l g)
+
+instance Profunctor p => Category (Free p) where
+ id = Parr id
+ Parr g . f = rmap g f
+ Free h g . f = Free h (g <<< f)
+
+instance Strong p => Strong (Free p) where
+ first' (Parr f) = Parr (first' f)
+ first' (Free f g) = Free (first' f) (first' g)
+
+instance Choice p => Choice (Free p) where
+ left' (Parr f) = Parr (left' f)
+ left' (Free f g) = Free (left' f) (left' g)
+
+instance Closed p => Closed (Free p) where
+ closed (Parr f) = Parr (closed f)
+ closed (Free f g) = Free (closed f) (closed g)
+
+instance Traversing p => Traversing (Free p) where
+ traverse' (Parr f) = Parr (traverse' f)
+ traverse' (Free f g) = Free (traverse' f) (traverse' g)
+
+instance Mapping p => Mapping (Free p) where
+ map' (Parr f) = Parr (map' f)
+ map' (Free f g) = Free (map' f) (map' g)
+
+-- | Given a natural transformation this returns a profunctor.
+--
+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
+
+-- | 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)
+
+-- Analog of 'Const' for pliftows
+newtype Append r a b = Append { getAppend :: r }
+
+instance Profunctor (Append r) where
+ dimap _ _ (Append x) = Append x
+
+instance Monoid r => Category (Append r) where
+ id = Append mempty
+ Append x . Append y = Append (x <> y)
diff --git a/src/Data/Profunctor/Arrow/Internal.hs b/src/Data/Profunctor/Arrow/Internal.hs
new file mode 100644
index 0000000..06466e2
--- /dev/null
+++ b/src/Data/Profunctor/Arrow/Internal.hs
@@ -0,0 +1,177 @@
+{-# LANGUAGE ExistentialQuantification, DefaultSignatures, UndecidableInstances #-}
+
+module Data.Profunctor.Arrow.Internal where
+
+import Data.Functor.Compose (Compose(..))
+import Data.Functor.Identity (Identity(..))
+import Data.Kind
+import Data.Profunctor
+import Data.Profunctor.Choice
+import Data.Profunctor.Closed
+import Data.Profunctor.Extra
+import Data.Profunctor.Mapping
+import Data.Profunctor.Monad
+import Data.Profunctor.Strong
+import Data.Profunctor.Traversing
+import Data.Profunctor.Unsafe
+import Data.Profunctor.Yoneda
+import Data.Void
+
+import Prelude
+
+
+type family Arg (x :: * -> *) where Arg (f a) = a
+type family Arg1 (x :: * -> *) where Arg1 (f a b) = a
+type family Arg2 (x :: * -> *) where Arg2 (f a b) = b
+
+--Trans m p ~ m f => (Costar f) `Procompose` p `Procompose` (Star f)
+data Trans m p a b = forall x y f. m f => Trans (a -> f x) (p x y) (f y -> b)
+
+instance Profunctor (Trans m p) where
+ dimap f g (Trans l p r) = Trans (l . f) p (g . r)
+ lmap f (Trans l p r) = Trans (l . f) p r
+ rmap g (Trans l p r) = Trans l p (g . r)
+ g #. Trans l p r = Trans l p (g #. r)
+ Trans l p r .# f = Trans (l .# f) p r
+
+instance ProfunctorFunctor (Trans m) where
+ promap f (Trans l p r) = Trans l (f p) r
+
+
+type ChoiceT = Trans WithChoice
+
+type StrongT = Trans WithStrong
+
+type ClosedT = Trans WithClosed
+
+type AffineT = Trans WithAffine
+
+type TraversingT = Trans Traversable
+
+type MappingT = Trans Functor
+
+
+runMappingT :: Mapping q => p :-> q -> MappingT p a b -> q a b
+runMappingT pq (Trans l p r) = dimap l r (map' (pq p))
+
+--prisms
+
+choice_lift :: p a b -> ChoiceT p a b
+choice_lift p = Trans Right p rgt'
+
+--see also PastroSum's Choice instance
+choice_trans :: ChoiceT p a b -> ChoiceT p (c + a) (c + b)
+choice_trans (Trans l p r) = Trans
+ (either (Left . Left) (either (Left . Right) Right . l)) p
+ (either (either Left (Right . r . Left)) (Right . r . Right))
+
+
+--lenses
+
+strong_lift :: p a b -> StrongT p a b
+strong_lift p = Trans ((,) ()) p snd
+
+-- see also Pastro's Strong instance
+strong_trans :: StrongT p a b -> StrongT p (c, a) (c, b)
+strong_trans (Trans l p r) = Trans (\(d,s) -> ((d , fst (l s)), snd (l s))) p (\((d,c),b) -> (d,r (c,b)))
+
+
+--grates
+
+closed_lift :: p a b -> ClosedT p a b
+closed_lift p = Trans const p ($ ())
+
+--see also Environment's Closed instance
+closed_trans :: ClosedT p a b -> ClosedT p (c -> a) (c -> b)
+closed_trans (Trans l p r) = Trans (\f (d , c) -> l (f d) c) p ((r .) . curry)
+
+
+--affine traversals
+
+affine :: Choice p => Strong p => p a b -> p (Affine c d a) (Affine c d b)
+affine = dimap unAffine Affine . right' . second'
+
+affine_lift :: p a b -> AffineT p a b
+affine_lift p = Trans (Affine . Right . ((,) ())) p (either absurd snd . unAffine)
+
+affine_trans :: AffineT p a b -> AffineT p (Affine c d a) (Affine c d b)
+affine_trans (Trans l p r) = Trans (u l) p (v r)
+ where
+ u :: (s -> Affine c d a) -> Affine e f s -> Affine (Either e (f,c)) (f,d) a
+ u _ (Affine (Left e)) = Affine $ Left $ Left e
+ u l (Affine (Right (f,s))) = Affine $ case unAffine (l s) of
+ (Left c) -> (Left (Right (f,c)))
+ (Right (d,a)) -> (Right ((f,d),a))
+
+ v :: (Affine c d b -> t) -> Affine (Either e (f,c)) (f,d) b -> Affine e f t
+ v _ (Affine (Left (Left e))) = Affine $ Left e
+ v r (Affine (Left (Right (f,c)))) = Affine $ Right (f,r $ Affine $ Left c)
+ v r (Affine (Right ((f,d),b))) = Affine $ Right (f , r . Affine $ Right (d,b))
+
+-- traversals
+
+traversal_lift :: p a b -> TraversingT p a b
+traversal_lift p = Trans Identity p runIdentity
+
+--see also TransTraversing's Traversing instance
+traversal_trans :: Traversable f => TraversingT p a b -> TraversingT p (f a) (f b)
+traversal_trans (Trans l p r) = Trans (Compose . fmap l) p (fmap r . getCompose)
+
+
+-- setters
+
+setter_lift :: p a b -> MappingT p a b
+setter_lift p = Trans Identity p runIdentity
+
+--see also TransMapping's Mapping instance
+setter_trans :: Functor f => MappingT p a b -> MappingT p (f a) (f b)
+setter_trans (Trans l p r) = Trans (Compose . fmap l) p (fmap r . getCompose)
+
+
+--instances
+
+class f ~ (Either (Arg f)) => WithChoice f
+
+instance WithChoice (Either c)
+
+class f ~ ((,) (Arg f)) => WithStrong f
+
+instance WithStrong ((,) c)
+
+class (f ~ ((->) (Arg f))) => WithClosed f
+
+instance WithClosed ((->) c)
+
+newtype Affine a b c = Affine { unAffine :: a + (b , c) }
+
+class f ~ Affine (Arg1 f) (Arg2 f) => WithAffine f
+
+instance WithAffine (Affine c d)
+
+
+instance Choice (ChoiceT p) where right' = choice_trans
+
+instance Strong (StrongT p) where second' = strong_trans
+
+instance Closed (ClosedT p) where closed = closed_trans
+
+instance Choice (AffineT p) where right' = dimap (Affine . either (Left . id) (Right . ((,) ()))) (either Left (Right . snd) . unAffine) . affine_trans
+
+instance Strong (AffineT p) where second' = dimap (Affine . Right) (either absurd id . unAffine) . affine_trans
+
+instance Strong (TraversingT p) where second' = traverse'
+
+instance Choice (TraversingT p) where right' = traverse'
+
+instance Traversing (TraversingT p) where traverse' = traversal_trans
+
+instance Strong (MappingT p) where second' = map'
+
+instance Choice (MappingT p) where right' = map'
+
+instance Closed (MappingT p) where closed = map'
+
+instance Traversing (MappingT p) where traverse' = map'
+
+instance Mapping (MappingT p) where map' = setter_trans
+
diff --git a/src/Data/Profunctor/Arrow/Strong.hs b/src/Data/Profunctor/Arrow/Strong.hs
new file mode 100644
index 0000000..531ddfa
--- /dev/null
+++ b/src/Data/Profunctor/Arrow/Strong.hs
@@ -0,0 +1,43 @@
+module Data.Profunctor.Arrow.Strong (
+ Pastro(..)
+ , StrongA
+ , liftStrong
+ , foldStrong
+ , runStrongT
+ , runStrongM
+) where
+
+import Control.Arrow (Kleisli(..))
+import Control.Category hiding ((.), id)
+import Data.Profunctor
+import Data.Profunctor.Arrow.Free
+import Data.Profunctor.Extra
+import Data.Profunctor.Strong
+
+import Prelude
+
+type StrongA p = Free (Pastro p)
+
+{-# INLINE liftStrong #-}
+-- | TODO: Document
+--
+liftStrong :: p a b -> StrongA p a b
+liftStrong p = Free (Pastro fst p fork) (Parr id)
+
+{-# INLINE foldStrong #-}
+-- | TODO: Document
+--
+foldStrong :: Category q => Strong q => p :-> q -> StrongA p a b -> q a b
+foldStrong pq = foldFree (runStrongT pq)
+
+{-# INLINE runStrongT #-}
+-- | TODO: Document
+--
+runStrongT :: Strong q => p :-> q -> Pastro p a b -> q a b
+runStrongT pq (Pastro r p l) = dimap l r (first' (pq p))
+
+{-# INLINE runStrongM #-}
+-- | TODO: Document
+--
+runStrongM :: Monad m => (forall x y. p x y -> x -> m y) -> StrongA p a b -> a -> m b
+runStrongM f = runKleisli . foldStrong (Kleisli . f)
diff --git a/src/Data/Profunctor/Arrow/Traversing.hs b/src/Data/Profunctor/Arrow/Traversing.hs
new file mode 100644
index 0000000..e96eeae
--- /dev/null
+++ b/src/Data/Profunctor/Arrow/Traversing.hs
@@ -0,0 +1,59 @@
+module Data.Profunctor.Arrow.Traversing (
+ FreeTraversing(..)
+ , TraversingA
+ , liftTraversing
+ , foldTraversing
+ , foldTraversing'
+ , runTraversingT
+ , runTraversingM
+ , runTraversingM'
+) where
+
+import Control.Arrow (Kleisli(..))
+import Control.Category hiding ((.), id)
+import Data.Functor.Identity
+import Data.Profunctor.Arrow
+import Data.Profunctor.Arrow.Free
+import Data.Profunctor.Traversing
+import Data.Profunctor
+
+import Prelude
+
+type TraversingA p = Free (FreeTraversing p)
+
+{-# INLINE liftTraversing #-}
+-- | TODO: Document
+--
+liftTraversing :: p a b -> TraversingA p a b
+liftTraversing p = Free (FreeTraversing runIdentity p Identity) (Parr id)
+
+-- | TODO: Document
+--
+foldTraversing :: Category q => Profunctor q => (forall f x y . Traversable f => p x y -> q (f x) (f y)) -> TraversingA p a b -> q a b
+foldTraversing _ (Parr ab) = arr ab
+foldTraversing pq (Free (FreeTraversing r p l) f) = dimap l r (pq p) <<< foldTraversing pq f
+
+{-# INLINE foldTraversing' #-}
+-- | TODO: Document
+--
+foldTraversing' :: Category q => Traversing q => p :-> q -> TraversingA p a b -> q a b
+foldTraversing' pq = foldFree (runTraversingT pq)
+
+{-# INLINE runTraversingT #-}
+-- | TODO: Document
+--
+runTraversingT :: Traversing q => p :-> q -> FreeTraversing p a b -> q a b
+runTraversingT pq (FreeTraversing r p l) = dimap l r (traverse' (pq p))
+
+
+{-# INLINE runTraversingM #-}
+-- | TODO: Document
+--
+runTraversingM :: Monad m => (forall f x y . Traversable f => p x y -> f x -> m (f y)) -> TraversingA p a b -> a -> m b
+runTraversingM f = runKleisli . foldTraversing (Kleisli . f)
+
+{-# INLINE runTraversingM' #-}
+-- | TODO: Document
+--
+runTraversingM' :: Monad m => (forall x y. p x y -> x -> m y) -> TraversingA p a b -> a -> m b
+runTraversingM' f = runKleisli . foldTraversing' (Kleisli . f)
diff --git a/src/Data/Profunctor/Extra.hs b/src/Data/Profunctor/Extra.hs
new file mode 100644
index 0000000..ca6ee71
--- /dev/null
+++ b/src/Data/Profunctor/Extra.hs
@@ -0,0 +1,212 @@
+module Data.Profunctor.Extra where
+
+import Control.Arrow ((|||),(&&&))
+import Control.Category (Category)
+import Control.Comonad (Comonad(..))
+import Data.Bifunctor
+import Data.Functor.Contravariant
+import Data.Profunctor
+import Data.Profunctor.Rep
+import Data.Profunctor.Sieve
+import Data.Void
+import Prelude
+import qualified Control.Category as C (id)
+import qualified Control.Monad as M (join)
+
+infixr 5 +
+
+type (+) = Either
+
+rgt :: (a -> b) -> a + b -> b
+rgt f = either f id
+
+rgt' :: Void + b -> b
+rgt' = rgt absurd
+
+lft :: (b -> a) -> a + b -> a
+lft f = either id f
+
+lft' :: a + Void -> a
+lft' = lft absurd
+
+swp :: (a1 , a2) -> (a2 , a1)
+swp = snd &&& fst
+
+eswp :: (a1 + a2) -> (a2 + a1)
+eswp = Right ||| Left
+
+fork :: a -> (a , a)
+fork = M.join (,)
+
+join :: (a + a) -> a
+join = M.join either id
+
+eval :: (a , a -> b) -> b
+eval = uncurry $ flip id
+
+apply :: (b -> a , b) -> a
+apply = uncurry id
+
+coeval :: b -> (b -> a) + a -> a
+coeval b = either ($ b) id
+
+branch :: (a -> Bool) -> b -> c -> a -> b + c
+branch f y z x = if f x then Right z else Left y
+
+branch' :: (a -> Bool) -> a -> a + a
+branch' f x = branch f x x x
+
+assocl :: (a , (b , c)) -> ((a , b) , c)
+assocl (a, (b, c)) = ((a, b), c)
+
+assocr :: ((a , b) , c) -> (a , (b , c))
+assocr ((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
+
+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)
+
+fstrong :: Functor f => f a -> b -> f (a , b)
+fstrong f b = fmap (,b) f
+
+fchoice :: Traversable f => f (a + b) -> (f a) + b
+fchoice = eswp . traverse eswp
+
+forget1 :: ((c , a) -> (c , b)) -> a -> b
+forget1 f a = b where (c, b) = f (c, a)
+
+forget2 :: ((a , c) -> (b , c)) -> a -> b
+forget2 f a = b where (b, c) = f (a, c)
+
+forgetl :: ((c + a) -> (c + b)) -> a -> b
+forgetl f = go . Right where go = either (go . Left) id . f
+
+forgetr :: ((a + c) -> (b + c)) -> a -> b
+forgetr f = go . Left where go = either id (go . Right) . f
+
+unarr :: Comonad w => Sieve p w => p a b -> a -> b
+unarr = (extract .) . sieve
+
+peval :: Strong p => p a (a -> b) -> p a b
+peval = rmap eval . pull
+
+constl :: Profunctor p => b -> p b c -> p a c
+constl = lmap . const
+
+constr :: Profunctor p => c -> p a b -> p a c
+constr = rmap . const
+
+shiftl :: Profunctor p => p (a + b) c -> p b (c + d)
+shiftl = dimap Right Left
+
+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 .)
+
+coercel :: Profunctor p => Bifunctor p => p a b -> p c b
+coercel = first absurd . lmap absurd
+
+coercel' :: Corepresentable p => Contravariant (Corep p) => p a b -> p c b
+coercel' = lower (. phantom)
+
+strong :: Strong p => ((a , b) -> c) -> p a b -> p a c
+strong f = dimap fork f . second'
+
+costrong :: Costrong p => ((a , b) -> c) -> p c a -> p b a
+costrong f = unsecond . dimap f fork
+
+choice :: Choice p => (c -> (a + b)) -> p b a -> p c a
+choice f = dimap f join . right'
+
+cochoice :: Cochoice p => (c -> (a + b)) -> p a c -> p a b
+cochoice f = unright . dimap join f
+
+pull :: Strong p => p a b -> p a (a , b)
+pull = lmap fork . second'
+
+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
+
+lower :: Corepresentable p => ((Corep p a -> b) -> Corep p s -> t) -> p a b -> p s t
+lower f = cotabulate . f . cosieve
+
+star :: Applicative f => Star f a a
+star = Star pure
+
+toStar :: Sieve p f => p d c -> Star f d c
+toStar = Star . sieve
+
+fromStar :: Representable p => Star (Rep p) a b -> p a b
+fromStar = tabulate . runStar
+
+costar :: Foldable f => Monoid b => (a -> b) -> Costar f a b
+costar f = Costar (foldMap f)
+
+uncostar :: Applicative f => Costar f a b -> a -> b
+uncostar f = runCostar f . pure
+
+toCostar :: Cosieve p f => p a b -> Costar f a b
+toCostar = Costar . cosieve
+
+fromCostar :: Corepresentable p => Costar (Corep p) a b -> p a b
+fromCostar = cotabulate . runCostar
+
+pushr :: Closed p => (forall x. Applicative (p x)) => p (a , b) c -> p a b -> p a c
+pushr = papply . curry'
+
+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
+
+ppure :: Profunctor p => (forall x. Applicative (p x)) => b -> p a b
+ppure b = dimap (const ()) (const b) $ pure ()
+
+--pabsurd :: Profunctor p => (forall x. Divisible (p x)) => p Void a
+--pabsurd = rmap absurd $ conquer
+
+infixr 3 @@@
+
+-- | 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
+
+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
+
+-- | 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
+
+-- | 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
+
+-- | 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)
+
+-- | 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