profunctors 5.1.2 → 5.2

raw patch · 22 files changed

+1483/−774 lines, 22 filesdep +base-orphansdep ~basedep ~bifunctorsdep ~comonad

Dependencies added: base-orphans

Dependency ranges changed: base, bifunctors, comonad, transformers

Files

• .travis.yml +3/−8
• CHANGELOG.markdown +6/−0
• LICENSE +1/−1
• profunctors.cabal +10/−8
• src/Data/Profunctor.hs +11/−394
• src/Data/Profunctor/Adjunction.hs +11/−1
• src/Data/Profunctor/Cayley.hs +4/−1
• src/Data/Profunctor/Choice.hs +364/−0
• src/Data/Profunctor/Closed.hs +34/−4
• src/Data/Profunctor/Codensity.hs +0/−54
• src/Data/Profunctor/Composition.hs +18/−2
• src/Data/Profunctor/Mapping.hs +108/−0
• src/Data/Profunctor/Monad.hs +47/−1
• src/Data/Profunctor/Monoid.hs +0/−16
• src/Data/Profunctor/Ran.hs +40/−1
• src/Data/Profunctor/Rep.hs +14/−2
• src/Data/Profunctor/Strong.hs +390/−0
• src/Data/Profunctor/Tambara.hs +0/−261
• src/Data/Profunctor/Trace.hs +0/−19
• src/Data/Profunctor/Traversing.hs +157/−0
• src/Data/Profunctor/Types.hs +229/−0
• src/Data/Profunctor/Unsafe.hs +36/−1

@@ -2,21 +2,16 @@  # See also https://github.com/hvr/multi-ghc-travis for more information env:- - GHCVER=7.0.1 CABALVER=1.16- - GHCVER=7.0.4 CABALVER=1.16- - GHCVER=7.2.2 CABALVER=1.16  - GHCVER=7.4.2 CABALVER=1.16  - GHCVER=7.6.3 CABALVER=1.16  - GHCVER=7.8.4 CABALVER=1.18  - GHCVER=7.10.1 CABALVER=1.22- - GHCVER=head CABALVER=1.22+ - GHCVER=8.0.1 CABALVER=1.24+ - GHCVER=head CABALVER=1.24  matrix:   allow_failures:-   - env: GHCVER=7.0.1 CABALVER=1.16-   - env: GHCVER=7.0.4 CABALVER=1.16-   - env: GHCVER=7.2.2 CABALVER=1.16-   - env: GHCVER=head CABALVER=1.22+   - env: GHCVER=head CABALVER=1.24  # Note: the distinction between `before_install` and `install` is not #       important.

@@ -1,3 +1,9 @@+5.2+---+* Renamed `Cotambara` to `TambaraChoice` and `Pastro` to `PastroChoice`.+* Added a true `Cotambara` and `Copastro` construction for (co)freely generating costrength, along with `CotambaraSum` and `CopastroSum` variants.+* Engaged in a fair bit of bikeshedding about the module structure for lesser used modules in this package.+ 5.1.2 ----- * Added `Prep` and `Coprep` along with witnesses to the adjunctions `Prep -| Star : [Hask,Hask] -> Prof` and `Coprep -| Costar : [Hask,Hask]^op -> Prof`.

@@ -1,4 +1,4 @@-Copyright 2011-2013 Edward Kmett+Copyright 2011-2015 Edward Kmett  All rights reserved. 

@@ -1,6 +1,6 @@ name:          profunctors category:      Control, Categories-version:       5.1.2+version:       5.2 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -30,27 +30,29 @@ library   build-depends:     base                >= 4     && < 5,-    bifunctors          >= 5     && < 6,-    comonad             >= 4     && < 5,+    base-orphans        >= 0.4   && < 0.6,+    bifunctors          >= 5.2   && < 6,+    comonad             >= 4     && < 6,     contravariant       >= 1     && < 2,     distributive        >= 0.4.4 && < 1,     tagged              >= 0.4.4 && < 1,-    transformers        >= 0.2   && < 0.5+    transformers        >= 0.2   && < 0.6    exposed-modules:     Data.Profunctor     Data.Profunctor.Adjunction     Data.Profunctor.Cayley+    Data.Profunctor.Choice     Data.Profunctor.Closed-    Data.Profunctor.Codensity     Data.Profunctor.Composition+    Data.Profunctor.Mapping     Data.Profunctor.Monad-    Data.Profunctor.Monoid     Data.Profunctor.Ran     Data.Profunctor.Rep     Data.Profunctor.Sieve-    Data.Profunctor.Tambara-    Data.Profunctor.Trace+    Data.Profunctor.Strong+    Data.Profunctor.Traversing+    Data.Profunctor.Types     Data.Profunctor.Unsafe    ghc-options:     -Wall -O2

@@ -7,7 +7,7 @@ #endif ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2011-2013 Edward Kmett,+-- Copyright   :  (C) 2011-2015 Edward Kmett, -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -28,7 +28,12 @@     Profunctor(dimap,lmap,rmap)   -- ** Profunctorial Strength   , Strong(..)+  , uncurry'   , Choice(..)+  -- ** Closed+  , Closed(..)+  , curry'+  , Mapping(..)   -- ** Profunctorial Costrength   , Costrong(..)   , Cochoice(..)@@ -42,396 +47,8 @@ #endif   ) where -import Control.Applicative hiding (WrappedArrow(..))-import Control.Arrow-import Control.Category-import Control.Comonad-import Control.Monad (liftM, MonadPlus(..))-import Control.Monad.Fix-import Data.Distributive-import Data.Foldable-import Data.Monoid-import Data.Tagged-import Data.Traversable-import Data.Tuple-import Data.Profunctor.Unsafe-import Prelude hiding (id,(.),sequence)--#if __GLASGOW_HASKELL__ >= 708-import Data.Coerce-#else-import Unsafe.Coerce-#endif--infixr 0 :->-type p :-> q = forall a b. p a b -> q a b----------------------------------------------------------------------------------- Star----------------------------------------------------------------------------------- | Lift a 'Functor' into a 'Profunctor' (forwards).-newtype Star f d c = Star { runStar :: d -> f c }--instance Functor f => Profunctor (Star f) where-  dimap ab cd (Star bfc) = Star (fmap cd . bfc . ab)-  {-# INLINE dimap #-}-  lmap k (Star f) = Star (f . k)-  {-# INLINE lmap #-}-  rmap k (Star f) = Star (fmap k . f)-  {-# INLINE rmap #-}-  -- We cannot safely overload ( #. ) because we didn't write the 'Functor'.-#if __GLASGOW_HASKELL__ >= 708-  p .# _ = coerce p-#else-  p .# _ = unsafeCoerce p-#endif-  {-# INLINE ( .# ) #-}--instance Functor f => Functor (Star f a) where-  fmap = rmap-  {-# INLINE fmap #-}--instance Applicative f => Applicative (Star f a) where-  pure a = Star $ \_ -> pure a-  Star ff <*> Star fx = Star $ \a -> ff a <*> fx a-  Star ff  *> Star fx = Star $ \a -> ff a  *> fx a-  Star ff <*  Star fx = Star $ \a -> ff a <*  fx a--instance Alternative f => Alternative (Star f a) where-  empty = Star $ \_ -> empty-  Star f <|> Star g = Star $ \a -> f a <|> g a--instance Monad f => Monad (Star f a) where-#if __GLASGOW_HASKELL__ < 710-  return a = Star $ \_ -> return a-#endif-  Star m >>= f = Star $ \ e -> do-    a <- m e-    runStar (f a) e--instance MonadPlus f => MonadPlus (Star f a) where-  mzero = Star $ \_ -> mzero-  Star f `mplus` Star g = Star $ \a -> f a `mplus` g a--instance Distributive f => Distributive (Star f a) where-  distribute fs = Star $ \a -> collect (($ a) .# runStar) fs----------------------------------------------------------------------------------- Costar----------------------------------------------------------------------------------- | Lift a 'Functor' into a 'Profunctor' (backwards).-newtype Costar f d c = Costar { runCostar :: f d -> c }--instance Functor f => Profunctor (Costar f) where-  dimap ab cd (Costar fbc) = Costar (cd . fbc . fmap ab)-  {-# INLINE dimap #-}-  lmap k (Costar f) = Costar (f . fmap k)-  {-# INLINE lmap #-}-  rmap k (Costar f) = Costar (k . f)-  {-# INLINE rmap #-}-#if __GLASGOW_HASKELL__ >= 708-  ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b-#else-  ( #. ) _ = unsafeCoerce-#endif-  {-# INLINE ( #. ) #-}-  -- We cannot overload ( .# ) because we didn't write the 'Functor'.--instance Distributive (Costar f d) where-  distribute fs = Costar $ \gd -> fmap (($ gd) .# runCostar) fs--instance Functor (Costar f a) where-  fmap k (Costar f) = Costar (k . f)-  {-# INLINE fmap #-}-  a <$ _ = Costar $ \_ -> a-  {-# INLINE (<$) #-}--instance Applicative (Costar f a) where-  pure a = Costar $ \_ -> a-  Costar ff <*> Costar fx = Costar $ \a -> ff a (fx a)-  _ *> m = m-  m <* _ = m--instance Monad (Costar f a) where-  return = pure-  Costar m >>= f = Costar $ \ x -> runCostar (f (m x)) x----------------------------------------------------------------------------------- Wrapped Profunctors----------------------------------------------------------------------------------- | Wrap an arrow for use as a 'Profunctor'.-newtype WrappedArrow p a b = WrapArrow { unwrapArrow :: p a b }--instance Category p => Category (WrappedArrow p) where-  WrapArrow f . WrapArrow g = WrapArrow (f . g)-  {-# INLINE (.) #-}-  id = WrapArrow id-  {-# INLINE id #-}--instance Arrow p => Arrow (WrappedArrow p) where-  arr = WrapArrow . arr-  {-# INLINE arr #-}-  first = WrapArrow . first . unwrapArrow-  {-# INLINE first #-}-  second = WrapArrow . second . unwrapArrow-  {-# INLINE second #-}-  WrapArrow a *** WrapArrow b = WrapArrow (a *** b)-  {-# INLINE (***) #-}-  WrapArrow a &&& WrapArrow b = WrapArrow (a &&& b)-  {-# INLINE (&&&) #-}--instance ArrowZero p => ArrowZero (WrappedArrow p) where-  zeroArrow = WrapArrow zeroArrow-  {-# INLINE zeroArrow #-}--instance ArrowChoice p => ArrowChoice (WrappedArrow p) where-  left = WrapArrow . left . unwrapArrow-  {-# INLINE left #-}-  right = WrapArrow . right . unwrapArrow-  {-# INLINE right #-}-  WrapArrow a +++ WrapArrow b = WrapArrow (a +++ b)-  {-# INLINE (+++) #-}-  WrapArrow a ||| WrapArrow b = WrapArrow (a ||| b)-  {-# INLINE (|||) #-}--instance ArrowApply p => ArrowApply (WrappedArrow p) where-  app = WrapArrow $ app . arr (first unwrapArrow)-  {-# INLINE app #-}--instance ArrowLoop p => ArrowLoop (WrappedArrow p) where-  loop = WrapArrow . loop . unwrapArrow-  {-# INLINE loop #-}--instance Arrow p => Profunctor (WrappedArrow p) where-  lmap = (^>>)-  {-# INLINE lmap #-}-  rmap = (^<<)-  {-# INLINE rmap #-}-  -- We cannot safely overload ( #. ) or ( .# ) because we didn't write the 'Arrow'.----------------------------------------------------------------------------------- Forget---------------------------------------------------------------------------------newtype Forget r a b = Forget { runForget :: a -> r }--instance Profunctor (Forget r) where-  dimap f _ (Forget k) = Forget (k . f)-  {-# INLINE dimap #-}-  lmap f (Forget k) = Forget (k . f)-  {-# INLINE lmap #-}-  rmap _ (Forget k) = Forget k-  {-# INLINE rmap #-}--instance Functor (Forget r a) where-  fmap _ (Forget k) = Forget k-  {-# INLINE fmap #-}--instance Foldable (Forget r a) where-  foldMap _ _ = mempty-  {-# INLINE foldMap #-}--instance Traversable (Forget r a) where-  traverse _ (Forget k) = pure (Forget k)-  {-# INLINE traverse #-}----------------------------------------------------------------------------------- Strong----------------------------------------------------------------------------------- | Generalizing 'Star' of a strong 'Functor'------ /Note:/ Every 'Functor' in Haskell is strong with respect to @(,)@.------ This describes profunctor strength with respect to the product structure--- of Hask.------ <http://www-kb.is.s.u-tokyo.ac.jp/~asada/papers/arrStrMnd.pdf>-class Profunctor p => Strong p where-  first' :: p a b  -> p (a, c) (b, c)-  first' = dimap swap swap . second'--  second' :: p a b -> p (c, a) (c, b)-  second' = dimap swap swap . first'---#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-  {-# MINIMAL first' | second' #-}-#endif--instance Strong (->) where-  first' ab ~(a, c) = (ab a, c)-  {-# INLINE first' #-}-  second' ab ~(c, a) = (c, ab a)--instance Monad m => Strong (Kleisli m) where-  first' (Kleisli f) = Kleisli $ \ ~(a, c) -> do-     b <- f a-     return (b, c)-  {-# INLINE first' #-}-  second' (Kleisli f) = Kleisli $ \ ~(c, a) -> do-     b <- f a-     return (c, b)-  {-# INLINE second' #-}--instance Functor m => Strong (Star m) where-  first' (Star f) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a-  {-# INLINE first' #-}-  second' (Star f) = Star $ \ ~(c, a) -> (,) c <$> f a-  {-# INLINE second' #-}---- | 'Arrow' is 'Strong' 'Category'-instance Arrow p => Strong (WrappedArrow p) where-  first' (WrapArrow k) = WrapArrow (first k)-  {-# INLINE first' #-}-  second' (WrapArrow k) = WrapArrow (second k)-  {-# INLINE second' #-}--instance Strong (Forget r) where-  first' (Forget k) = Forget (k . fst)-  {-# INLINE first' #-}-  second' (Forget k) = Forget (k . snd)-  {-# INLINE second' #-}----------------------------------------------------------------------------------- Choice----------------------------------------------------------------------------------- | The generalization of 'Costar' of 'Functor' that is strong with respect--- to 'Either'.------ Note: This is also a notion of strength, except with regards to another monoidal--- structure that we can choose to equip Hask with: the cocartesian coproduct.-class Profunctor p => Choice p where-  left'  :: p a b -> p (Either a c) (Either b c)-  left' =  dimap (either Right Left) (either Right Left) . right'--  right' :: p a b -> p (Either c a) (Either c b)-  right' =  dimap (either Right Left) (either Right Left) . left'--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-  {-# MINIMAL left' | right' #-}-#endif--instance Choice (->) where-  left' ab (Left a) = Left (ab a)-  left' _ (Right c) = Right c-  {-# INLINE left' #-}-  right' = fmap-  {-# INLINE right' #-}--instance Monad m => Choice (Kleisli m) where-  left' = left-  {-# INLINE left' #-}-  right' = right-  {-# INLINE right' #-}--instance Applicative f => Choice (Star f) where-  left' (Star f) = Star $ either (fmap Left . f) (pure . Right)-  {-# INLINE left' #-}-  right' (Star f) = Star $ either (pure . Left) (fmap Right . f)-  {-# INLINE right' #-}---- | 'extract' approximates 'costrength'-instance Comonad w => Choice (Cokleisli w) where-  left' = left-  {-# INLINE left' #-}-  right' = right-  {-# INLINE right' #-}---- NB: This instance is highly questionable-instance Traversable w => Choice (Costar w) where-  left' (Costar wab) = Costar (either Right Left . fmap wab . traverse (either Right Left))-  {-# INLINE left' #-}-  right' (Costar wab) = Costar (fmap wab . sequence)-  {-# INLINE right' #-}--instance Choice Tagged where-  left' (Tagged b) = Tagged (Left b)-  {-# INLINE left' #-}-  right' (Tagged b) = Tagged (Right b)-  {-# INLINE right' #-}--instance ArrowChoice p => Choice (WrappedArrow p) where-  left' (WrapArrow k) = WrapArrow (left k)-  {-# INLINE left' #-}-  right' (WrapArrow k) = WrapArrow (right k)-  {-# INLINE right' #-}--instance Monoid r => Choice (Forget r) where-  left' (Forget k) = Forget (either k (const mempty))-  {-# INLINE left' #-}-  right' (Forget k) = Forget (either (const mempty) k)-  {-# INLINE right' #-}------------------------------------------------------------------------------------- * Costrength for (,)------------------------------------------------------------------------------------- | Analogous to 'ArrowLoop', 'loop' = 'unfirst'-class Profunctor p => Costrong p where-  unfirst  :: p (a, d) (b, d) -> p a b-  unfirst = unsecond . dimap swap swap--  unsecond :: p (d, a) (d, b) -> p a b-  unsecond = unfirst . dimap swap swap--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-  {-# MINIMAL unfirst | unsecond #-}-#endif--instance Costrong (->) where-  unfirst f a = b where (b, d) = f (a, d)-  unsecond f a = b where (d, b) = f (d, a)--instance Functor f => Costrong (Costar f) where-  unfirst (Costar f) = Costar f'-    where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa)-  unsecond (Costar f) = Costar f'-    where f' fa = b where (d, b) = f ((,) d <$> fa)--instance Costrong Tagged where-  unfirst (Tagged bd) = Tagged (fst bd)-  unsecond (Tagged db) = Tagged (snd db)--instance ArrowLoop p => Costrong (WrappedArrow p) where-  unfirst (WrapArrow k) = WrapArrow (loop k)--instance MonadFix m => Costrong (Kleisli m) where-  unfirst (Kleisli f) = Kleisli (liftM fst . mfix . f')-    where f' x y = f (x, snd y)--instance Functor f => Costrong (Cokleisli f) where-  unfirst (Cokleisli f) = Cokleisli f'-    where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa)------------------------------------------------------------------------------------- * Costrength for Either-----------------------------------------------------------------------------------class Profunctor p => Cochoice p where-  unleft  :: p (Either a d) (Either b d) -> p a b-  unleft = unright . dimap (either Right Left) (either Right Left)--  unright :: p (Either d a) (Either d b) -> p a b-  unright = unleft . dimap (either Right Left) (either Right Left)--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708-  {-# MINIMAL unleft | unright #-}-#endif--instance Cochoice (->) where-  unleft f = go . Left where go = either id (go . Right) . f-  unright f = go . Right where go = either (go . Left) id . f--instance Applicative f => Cochoice (Costar f) where-  unleft (Costar f) = Costar (go . fmap Left)-    where go = either id (go . pure . Right) . f---- NB: Another instance that's highly questionable-instance Traversable f => Cochoice (Star f) where-  unright (Star f) = Star (go . Right)-    where go = either (go . Left) id . sequence . f+import Data.Profunctor.Choice+import Data.Profunctor.Closed+import Data.Profunctor.Mapping+import Data.Profunctor.Strong+import Data.Profunctor.Types

@@ -2,9 +2,19 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable, MPTCs, fundeps+--+---------------------------------------------------------------------------- module Data.Profunctor.Adjunction where -import Data.Profunctor+import Data.Profunctor.Types import Data.Profunctor.Monad  class (ProfunctorFunctor f, ProfunctorFunctor u) => ProfunctorAdjunction f u | f -> u, u -> f where

@@ -4,7 +4,7 @@ #endif ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2014 Edward Kmett+-- Copyright   :  (C) 2014-2015 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -80,3 +80,6 @@  instance (Applicative f, ArrowPlus p) => ArrowPlus (Cayley f p) where   Cayley f <+> Cayley g = Cayley (liftA2 (<+>) f g)++-- instance Adjunction f g => ProfunctorAdjunction (Cayley f) (Cayley g) where+  

@@ -0,0 +1,364 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2014-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  Rank2Types+--+----------------------------------------------------------------------------+module Data.Profunctor.Choice+  (+  -- * Strength+    Choice(..)+  , TambaraSum(..)+  , tambaraSum, untambaraSum+  , PastroSum(..)+  -- * Costrength+  , Cochoice(..)+  , CotambaraSum(..)+  , cotambaraSum, uncotambaraSum+  , CopastroSum(..)+  ) where++import Control.Applicative hiding (WrappedArrow(..))+import Control.Arrow+import Control.Category+import Control.Comonad+import Data.Bifunctor.Joker (Joker(..))+import Data.Bifunctor.Product (Product(..))+import Data.Bifunctor.Tannen (Tannen(..))+import Data.Monoid hiding (Product)+import Data.Profunctor.Adjunction+import Data.Profunctor.Monad+import Data.Profunctor.Strong+import Data.Profunctor.Types+import Data.Profunctor.Unsafe+import Data.Tagged+#if __GLASGOW_HASKELL__ < 710+import Data.Traversable+import Prelude hiding (id,(.),sequence)+#else+import Prelude hiding (id,(.))+#endif++------------------------------------------------------------------------------+-- Choice+------------------------------------------------------------------------------++-- | The generalization of 'Costar' of 'Functor' that is strong with respect+-- to 'Either'.+--+-- Note: This is also a notion of strength, except with regards to another monoidal+-- structure that we can choose to equip Hask with: the cocartesian coproduct.+class Profunctor p => Choice p where+  left'  :: p a b -> p (Either a c) (Either b c)+  left' =  dimap (either Right Left) (either Right Left) . right'++  right' :: p a b -> p (Either c a) (Either c b)+  right' =  dimap (either Right Left) (either Right Left) . left'++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+  {-# MINIMAL left' | right' #-}+#endif++instance Choice (->) where+  left' ab (Left a) = Left (ab a)+  left' _ (Right c) = Right c+  {-# INLINE left' #-}+  right' = fmap+  {-# INLINE right' #-}++instance Monad m => Choice (Kleisli m) where+  left' = left+  {-# INLINE left' #-}+  right' = right+  {-# INLINE right' #-}++instance Applicative f => Choice (Star f) where+  left' (Star f) = Star $ either (fmap Left . f) (pure . Right)+  {-# INLINE left' #-}+  right' (Star f) = Star $ either (pure . Left) (fmap Right . f)+  {-# INLINE right' #-}++-- | 'extract' approximates 'costrength'+instance Comonad w => Choice (Cokleisli w) where+  left' = left+  {-# INLINE left' #-}+  right' = right+  {-# INLINE right' #-}++-- NB: This instance is highly questionable+instance Traversable w => Choice (Costar w) where+  left' (Costar wab) = Costar (either Right Left . fmap wab . traverse (either Right Left))+  {-# INLINE left' #-}+  right' (Costar wab) = Costar (fmap wab . sequence)+  {-# INLINE right' #-}++instance Choice Tagged where+  left' (Tagged b) = Tagged (Left b)+  {-# INLINE left' #-}+  right' (Tagged b) = Tagged (Right b)+  {-# INLINE right' #-}++instance ArrowChoice p => Choice (WrappedArrow p) where+  left' (WrapArrow k) = WrapArrow (left k)+  {-# INLINE left' #-}+  right' (WrapArrow k) = WrapArrow (right k)+  {-# INLINE right' #-}++instance Monoid r => Choice (Forget r) where+  left' (Forget k) = Forget (either k (const mempty))+  {-# INLINE left' #-}+  right' (Forget k) = Forget (either (const mempty) k)+  {-# INLINE right' #-}++instance Functor f => Choice (Joker f) where+  left' (Joker fb) = Joker (fmap Left fb)+  {-# INLINE left' #-}+  right' (Joker fb) = Joker (fmap Right fb)+  {-# INLINE right' #-}++instance (Choice p, Choice q) => Choice (Product p q) where+  left' (Pair p q) = Pair (left' p) (left' q)+  {-# INLINE left' #-}+  right' (Pair p q) = Pair (right' p) (right' q)+  {-# INLINE right' #-}++instance (Functor f, Choice p) => Choice (Tannen f p) where+  left' (Tannen fp) = Tannen (fmap left' fp)+  {-# INLINE left' #-}+  right' (Tannen fp) = Tannen (fmap right' fp)+  {-# INLINE right' #-}++instance Choice p => Choice (Tambara p) where+  left' (Tambara f) = Tambara $ dimap hither yon $ left' f where+    hither :: (Either a b, c) -> Either (a, c) (b, c)+    hither (Left y, s) = Left (y, s)+    hither (Right z, s) = Right (z, s)++    yon :: Either (a, c) (b, c) -> (Either a b, c)+    yon (Left (y, s)) = (Left y, s)+    yon (Right (z, s)) = (Right z, s)+++----------------------------------------------------------------------------+-- * TambaraSum+----------------------------------------------------------------------------++-- | TambaraSum is cofreely adjoins strength with respect to Either.+--+-- Note: this is not dual to 'Data.Profunctor.Tambara.Tambara'. It is 'Data.Profunctor.Tambara.Tambara' with respect to a different tensor.+newtype TambaraSum p a b = TambaraSum { runTambaraSum :: forall c. p (Either a c) (Either b c) }++instance ProfunctorFunctor TambaraSum where+  promap f (TambaraSum p) = TambaraSum (f p)++instance ProfunctorComonad TambaraSum where+  proextract (TambaraSum p)   = dimap Left (\(Left a) -> a) p+  produplicate (TambaraSum p) = TambaraSum (TambaraSum $ dimap hither yon p) where+    hither :: Either (Either a b) c -> Either a (Either b c)+    hither (Left (Left x))   = Left x+    hither (Left (Right y))  = Right (Left y)+    hither (Right z)         = Right (Right z)++    yon    :: Either a (Either b c) -> Either (Either a b) c+    yon    (Left x)          = Left (Left x)+    yon    (Right (Left y))  = Left (Right y)+    yon    (Right (Right z)) = Right z++instance Profunctor p => Profunctor (TambaraSum p) where+  dimap f g (TambaraSum p) = TambaraSum $ dimap (left f) (left g) p+  {-# INLINE dimap #-}++instance Profunctor p => Choice (TambaraSum p) where+  left' = runTambaraSum . produplicate+  {-# INLINE left' #-}++instance Category p => Category (TambaraSum p) where+  id = TambaraSum id+  TambaraSum p . TambaraSum q = TambaraSum (p . q)++instance Profunctor p => Functor (TambaraSum p a) where+  fmap = rmap++-- |+-- @+-- 'tambaraSum' '.' 'untambaraSum' ≡ 'id'+-- 'untambaraSum' '.' 'tambaraSum' ≡ 'id'+-- @+tambaraSum :: Choice p => (p :-> q) -> p :-> TambaraSum q+tambaraSum f p = TambaraSum $ f $ left' p++-- |+-- @+-- 'tambaraSum' '.' 'untambaraSum' ≡ 'id'+-- 'untambaraSum' '.' 'tambaraSum' ≡ 'id'+-- @+untambaraSum :: Profunctor q => (p :-> TambaraSum q) -> p :-> q+untambaraSum f p = dimap Left (\(Left a) -> a) $ runTambaraSum $ f p++----------------------------------------------------------------------------+-- * PastroSum+----------------------------------------------------------------------------++-- | PastroSum -| TambaraSum+--+-- PastroSum freely constructs strength with respect to Either.+data PastroSum p a b where+  PastroSum :: (Either y z -> b) -> p x y -> (a -> Either x z) -> PastroSum p a b++instance Profunctor (PastroSum p) where+  dimap f g (PastroSum l m r) = PastroSum (g . l) m (r . f)+  lmap f (PastroSum l m r) = PastroSum l m (r . f)+  rmap g (PastroSum l m r) = PastroSum (g . l) m r+  w #. PastroSum l m r = PastroSum (w #. l) m r+  PastroSum l m r .# w = PastroSum l m (r .# w)++instance ProfunctorAdjunction PastroSum TambaraSum where+  counit (PastroSum f (TambaraSum g) h) = dimap h f g+  unit p = TambaraSum $ PastroSum id p id++instance ProfunctorFunctor PastroSum where+  promap f (PastroSum l m r) = PastroSum l (f m) r++instance ProfunctorMonad PastroSum where+  proreturn p = PastroSum (\(Left a)-> a) p Left+  projoin (PastroSum l (PastroSum m n o) q) = PastroSum lm n oq where+    oq a = case q a of+      Left b -> Left <$> o b+      Right z -> Right (Right z)+    lm (Left x) = l $ Left $ m $ Left x+    lm (Right (Left y)) = l $ Left $ m $ Right y+    lm (Right (Right z)) = l $ Right z++instance Choice (PastroSum p) where+  left' (PastroSum l m r) = PastroSum l' m r' where+    r' = either (fmap Left . r) (Right . Right)+    l' (Left y)          = Left (l (Left y))+    l' (Right (Left z))  = Left (l (Right z))+    l' (Right (Right c)) = Right c+  right' (PastroSum l m r) = PastroSum l' m r' where+    r' = either (Right . Left) (fmap Right . r)+    l' (Right (Left c))  = Left c+    l' (Right (Right z)) = Right (l (Right z))+    l' (Left y)          = Right (l (Left y))++--------------------------------------------------------------------------------+-- * Costrength for Either+--------------------------------------------------------------------------------++class Profunctor p => Cochoice p where+  unleft  :: p (Either a d) (Either b d) -> p a b+  unleft = unright . dimap (either Right Left) (either Right Left)++  unright :: p (Either d a) (Either d b) -> p a b+  unright = unleft . dimap (either Right Left) (either Right Left)++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+  {-# MINIMAL unleft | unright #-}+#endif++instance Cochoice (->) where+  unleft f = go . Left where go = either id (go . Right) . f+  unright f = go . Right where go = either (go . Left) id . f++instance Applicative f => Cochoice (Costar f) where+  unleft (Costar f) = Costar (go . fmap Left)+    where go = either id (go . pure . Right) . f++-- NB: Another instance that's highly questionable+instance Traversable f => Cochoice (Star f) where+  unright (Star f) = Star (go . Right)+    where go = either (go . Left) id . sequence . f++instance (Functor f, Cochoice p) => Cochoice (Tannen f p) where+  unleft (Tannen fp) = Tannen (fmap unleft fp)+  {-# INLINE unleft #-}+  unright (Tannen fp) = Tannen (fmap unright fp)+  {-# INLINE unright #-}++instance (Cochoice p, Cochoice q) => Cochoice (Product p q) where+  unleft (Pair p q) = Pair (unleft p) (unleft q)+  unright (Pair p q) = Pair (unright p) (unright q)++----------------------------------------------------------------------------+-- * CotambaraSum+----------------------------------------------------------------------------++-- | 'CotambaraSum' cofreely constructs costrength with respect to 'Either' (aka 'Choice')+data CotambaraSum q a b where+    CotambaraSum :: Cochoice r => (r :-> q) -> r a b -> CotambaraSum q a b++instance Profunctor (CotambaraSum p) where+  lmap f (CotambaraSum n p) = CotambaraSum n (lmap f p)+  rmap g (CotambaraSum n p) = CotambaraSum n (rmap g p)+  dimap f g (CotambaraSum n p) = CotambaraSum n (dimap f g p)++instance ProfunctorFunctor CotambaraSum where+  promap f (CotambaraSum n p) = CotambaraSum (f . n) p++instance ProfunctorComonad CotambaraSum where+  proextract (CotambaraSum n p)  = n p+  produplicate (CotambaraSum n p) = CotambaraSum id (CotambaraSum n p)++instance Cochoice (CotambaraSum p) where+  unleft (CotambaraSum n p) = CotambaraSum n (unleft p)+  unright (CotambaraSum n p) = CotambaraSum n (unright p)++instance Functor (CotambaraSum p a) where+  fmap = rmap++-- |+-- @+-- 'cotambaraSum' '.' 'uncotambaraSum' ≡ 'id'+-- 'uncotambaraSum' '.' 'cotambaraSum' ≡ 'id'+-- @+cotambaraSum :: Cochoice p => (p :-> q) -> p :-> CotambaraSum q+cotambaraSum = CotambaraSum++-- |+-- @+-- 'cotambaraSum' '.' 'uncotambaraSum' ≡ 'id'+-- 'uncotambaraSum' '.' 'cotambaraSum' ≡ 'id'+-- @+uncotambaraSum :: Profunctor q => (p :-> CotambaraSum q) -> p :-> q+uncotambaraSum f p = proextract (f p)++----------------------------------------------------------------------------+-- * Copastro+----------------------------------------------------------------------------++-- | CopastroSum -| CotambaraSum+--+-- 'CopastroSum' freely constructs costrength with respect to 'Either' (aka 'Choice')+newtype CopastroSum p a b = CopastroSum { runCopastroSum :: forall r. Cochoice r => (forall x y. p x y -> r x y) -> r a b }++instance Profunctor (CopastroSum p) where+  dimap f g (CopastroSum h) = CopastroSum $ \ n -> dimap f g (h n)+  lmap f (CopastroSum h) = CopastroSum $ \ n -> lmap f (h n)+  rmap g (CopastroSum h) = CopastroSum $ \ n -> rmap g (h n)++instance ProfunctorAdjunction CopastroSum CotambaraSum where+ unit p = CotambaraSum id (proreturn p)+ counit (CopastroSum h) = proextract (h id)++instance ProfunctorFunctor CopastroSum where+  promap f (CopastroSum h) = CopastroSum $ \n -> h (n . f)++instance ProfunctorMonad CopastroSum where+  proreturn p = CopastroSum $ \n -> n p+  projoin p = CopastroSum $ \c -> runCopastroSum p (\x -> runCopastroSum x c)++instance Cochoice (CopastroSum p) where+  unleft (CopastroSum p) = CopastroSum $ \n -> unleft (p n)+  unright (CopastroSum p) = CopastroSum $ \n -> unright (p n)

@@ -3,29 +3,45 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708++#if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} #endif +-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2014-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+---------------------------------------------------------------------------- module Data.Profunctor.Closed   ( Closed(..)   , Closure(..)   , close   , unclose   , Environment(..)+  , curry'   ) where  import Control.Applicative import Control.Arrow import Control.Category import Control.Comonad+import Data.Bifunctor.Product (Product(..))+import Data.Bifunctor.Tannen (Tannen(..)) import Data.Distributive-import Data.Monoid-import Data.Profunctor+import Data.Monoid hiding (Product) import Data.Profunctor.Adjunction import Data.Profunctor.Monad+import Data.Profunctor.Strong+import Data.Profunctor.Types import Data.Profunctor.Unsafe import Data.Tagged+import Data.Tuple import Prelude hiding ((.),id)  --------------------------------------------------------------------------------@@ -56,9 +72,18 @@ instance (Distributive f, Monad f) => Closed (Kleisli f) where   closed (Kleisli afb) = Kleisli $ \xa -> distribute $ \x -> afb (xa x) +instance (Closed p, Closed q) => Closed (Product p q) where+  closed (Pair p q) = Pair (closed p) (closed q)++instance (Functor f, Closed p) => Closed (Tannen f p) where+  closed (Tannen fp) = Tannen (fmap closed fp)+ -- instance Monoid r => Closed (Forget r) where --  closed _ = Forget $ \_ -> mempty +curry' :: Closed p => p (a, b) c -> p a (b -> c)+curry' = lmap (,) . closed+ -------------------------------------------------------------------------------- -- * Closure --------------------------------------------------------------------------------@@ -150,7 +175,7 @@ data Environment p a b where   Environment :: ((z -> y) -> b) -> p x y -> (a -> z -> x) -> Environment p a b -instance Profunctor p => Profunctor (Environment p) where+instance Profunctor (Environment p) where   dimap f g (Environment l m r) = Environment (g . l) m (r . f)   lmap f (Environment l m r) = Environment l m (r . f)   rmap g (Environment l m r) = Environment (g . l) m r@@ -169,3 +194,8 @@ instance ProfunctorAdjunction Environment Closure where   counit (Environment g (Closure p) f) = dimap f g p   unit p = Closure (Environment id p id)++instance Closed (Environment p) where+  closed (Environment l m r) = Environment l' m r' where+    r' wa (z,w) = r (wa w) z+    l' zx2y x = l (\z -> zx2y (z,x))

@@ -1,54 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Copyright   :  (C) 2014 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  Rank2Types, TFs---------------------------------------------------------------------------------module Data.Profunctor.Codensity-  ( Codensity(..)-  , decomposeCodensity-  ) where--import Control.Category-import Data.Profunctor.Unsafe-import Data.Profunctor.Composition-import Prelude hiding (id,(.))---- | This represents the right Kan extension of a 'Profunctor' @p@ along itself. This provides a generalization of the \"difference list\" trick to profunctors.-newtype Codensity p a b = Codensity { runCodensity :: forall x. p x a -> p x b }--instance Profunctor p => Profunctor (Codensity p) where-  dimap ca bd f = Codensity (rmap bd . runCodensity f . rmap ca)-  {-# INLINE dimap #-}-  lmap ca f = Codensity (runCodensity f . rmap ca)-  {-# INLINE lmap #-}-  rmap bd f = Codensity (rmap bd . runCodensity f)-  {-# INLINE rmap #-}-  bd #. f = Codensity (\p -> bd #. runCodensity f p)-  {-# INLINE ( #. ) #-}-  f .# ca = Codensity (\p -> runCodensity f (ca #. p))-  {-# INLINE (.#) #-}--instance Profunctor p => Functor (Codensity p a) where-  fmap bd f = Codensity (rmap bd . runCodensity f)-  {-# INLINE fmap #-}--instance Category (Codensity p) where-  id = Codensity id-  {-# INLINE id #-}-  Codensity f . Codensity g = Codensity (f . g)-  {-# INLINE (.) #-}--decomposeCodensity :: Procompose (Codensity p) p a b -> p a b-decomposeCodensity (Procompose (Codensity pp) p) = pp p-{-# INLINE decomposeCodensity #-}

@@ -11,7 +11,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Profunctor.Composition--- Copyright   :  (C) 2014 Edward Kmett+-- Copyright   :  (C) 2014-2015 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -28,6 +28,9 @@   , idl   , idr   , assoc+  -- * Categories as monoid objects+  , eta+  , mu   -- * Generalized Composition   , stars, kleislis   , costars, cokleislis@@ -43,7 +46,6 @@ import Data.Functor.Compose import Data.Profunctor import Data.Profunctor.Adjunction-import Data.Profunctor.Closed import Data.Profunctor.Monad import Data.Profunctor.Rep import Data.Profunctor.Sieve@@ -227,6 +229,7 @@ ---------------------------------------------------------------------------- -- * Rift ----------------------------------------------------------------------------+ -- | This represents the right Kan lift of a 'Profunctor' @q@ along a 'Profunctor' @p@ in a limited version of the 2-category of Profunctors where the only object is the category Hask, 1-morphisms are profunctors composed and compose with Profunctor composition, and 2-morphisms are just natural transformations. newtype Rift p q a b = Rift { runRift :: forall x. p b x -> q a x } @@ -272,3 +275,16 @@   unit q = Rift $ \p -> Procompose p q  --instance (ProfunctorAdjunction f g, ProfunctorAdjunction f' g') => ProfunctorAdjunction (ProfunctorCompose f' f) (ProfunctorCompose g g') where++----------------------------------------------------------------------------+-- * Monoids+----------------------------------------------------------------------------+++-- | a 'Category' that is also a 'Profunctor' is a 'Monoid' in @Prof@++eta :: (Profunctor p, Category p) => (->) :-> p+eta f = rmap f id++mu :: Category p => Procompose p p :-> p+mu (Procompose f g) = f . g

@@ -0,0 +1,108 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+module Data.Profunctor.Mapping+  ( Mapping(..)+  , CofreeMapping(..)+  , FreeMapping(..)+  -- * Closed in terms of Mapping+  , traverseMapping+  , closedMapping+  ) where++import Control.Arrow (Kleisli(..))+import Data.Distributive+import Data.Functor.Compose+import Data.Functor.Identity+import Data.Profunctor.Choice+import Data.Profunctor.Closed+import Data.Profunctor.Monad+import Data.Profunctor.Strong+import Data.Profunctor.Traversing+import Data.Profunctor.Types+import Data.Profunctor.Unsafe+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif++class (Traversing p, Closed p) => Mapping p where+  map' :: Functor f => p a b -> p (f a) (f b)++instance Mapping (->) where+  map' = fmap++instance (Monad m, Distributive m) => Mapping (Kleisli m) where+  map' (Kleisli f) = Kleisli (collect f)++-- see <https://github.com/ekmett/distributive/issues/12>+instance (Applicative m, Distributive m) => Mapping (Star m) where+  map' (Star f) = Star (collect f)++traverseMapping :: (Mapping p, Functor f) => p a b -> p (f a) (f b)+traverseMapping = map'++closedMapping :: Mapping p => p a b -> p (x -> a) (x -> b)+closedMapping = map'++newtype CofreeMapping p a b = CofreeMapping { runCofreeMapping :: forall f. Functor f => p (f a) (f b) }++instance Profunctor p => Profunctor (CofreeMapping p) where+  lmap f (CofreeMapping p) = CofreeMapping (lmap (fmap f) p)+  rmap g (CofreeMapping p) = CofreeMapping (rmap (fmap g) p)+  dimap f g (CofreeMapping p) = CofreeMapping (dimap (fmap f) (fmap g) p)++instance Profunctor p => Strong (CofreeMapping p) where+  second' = map'++instance Profunctor p => Choice (CofreeMapping p) where+  right' = map'++instance Profunctor p => Closed (CofreeMapping p) where+  closed = map'++instance Profunctor p => Traversing (CofreeMapping p) where+  traverse' = map'++instance Profunctor p => Mapping (CofreeMapping p) where+  -- !@(#*&() Compose isn't representational in its second arg or we could use #. and .#+  map' (CofreeMapping p) = CofreeMapping (dimap Compose getCompose p)++instance ProfunctorFunctor CofreeMapping where+  promap f (CofreeMapping p) = CofreeMapping (f p)++instance ProfunctorComonad CofreeMapping where+  proextract (CofreeMapping p) = runIdentity #. p .# Identity+  produplicate (CofreeMapping p) = CofreeMapping (CofreeMapping (dimap Compose getCompose p))++-- | @FreeMapping -| CofreeMapping@+data FreeMapping p a b where+  FreeMapping :: Functor f => (f y -> b) -> p x y -> (a -> f x) -> FreeMapping p a b++instance Profunctor (FreeMapping p) where+  lmap f (FreeMapping l m r) = FreeMapping l m (r . f)+  rmap g (FreeMapping l m r) = FreeMapping (g . l) m r+  dimap f g (FreeMapping l m r) = FreeMapping (g . l) m (r . f)+  g #. FreeMapping l m r = FreeMapping (g #. l) m r+  FreeMapping l m r .# f = FreeMapping l m (r .# f)++instance Strong (FreeMapping p) where+  second' = map'++instance Choice (FreeMapping p) where+  right' = map'++instance Closed (FreeMapping p) where+  closed = map'++instance Traversing (FreeMapping p) where+  traverse' = map'++instance Mapping (FreeMapping p) where+  map' (FreeMapping l m r) = FreeMapping (fmap l .# getCompose) m (Compose #. fmap r)++instance ProfunctorFunctor FreeMapping where+  promap f (FreeMapping l m r) = FreeMapping l (f m) r++instance ProfunctorMonad FreeMapping where+  proreturn p = FreeMapping runIdentity p Identity+  projoin (FreeMapping l (FreeMapping l' m r') r) = FreeMapping ((l . fmap l') .# getCompose) m (Compose #. (fmap r' . r))

@@ -1,16 +1,62 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-}+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2014-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+---------------------------------------------------------------------------- module Data.Profunctor.Monad where -import Data.Profunctor+import Control.Comonad+import Data.Bifunctor.Tannen+import Data.Bifunctor.Product+import Data.Bifunctor.Sum+import Data.Profunctor.Types  class ProfunctorFunctor t where   promap    :: Profunctor p => (p :-> q) -> t p :-> t q +instance Functor f => ProfunctorFunctor (Tannen f) where+  promap f (Tannen g) = Tannen (fmap f g)++instance ProfunctorFunctor (Product p) where+  promap f (Pair p q) = Pair p (f q)++instance ProfunctorFunctor (Sum p) where+  promap _ (L2 p) = L2 p+  promap f (R2 q) = R2 (f q)+ class ProfunctorFunctor t => ProfunctorMonad t where   proreturn :: Profunctor p => p :-> t p   projoin   :: Profunctor p => t (t p) :-> t p +#if __GLASGOW_HASKELL__ < 710+instance (Functor f, Monad f) => ProfunctorMonad (Tannen f) where+#else+instance Monad f => ProfunctorMonad (Tannen f) where+#endif+  proreturn = Tannen . return+  projoin (Tannen m) = Tannen $ m >>= runTannen++instance ProfunctorMonad (Sum p) where+  proreturn = R2+  projoin (L2 p) = L2 p+  projoin (R2 m) = m+ class ProfunctorFunctor t => ProfunctorComonad t where   proextract :: Profunctor p => t p :-> p   produplicate :: Profunctor p => t p :-> t (t p)++instance Comonad f => ProfunctorComonad (Tannen f) where+  proextract = extract . runTannen+  produplicate (Tannen w) = Tannen $ extend Tannen w++instance ProfunctorComonad (Product p) where+  proextract (Pair _ q) = q+  produplicate pq@(Pair p _) = Pair p pq

@@ -1,16 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE NoImplicitPrelude #-}-module Data.Profunctor.Monoid where--import Control.Category-import Data.Profunctor-import Data.Profunctor.Composition---- | a 'Category' that is also a 'Profunctor' is a 'Monoid' in @Prof@--eta :: (Profunctor p, Category p) => (->) :-> p-eta f = rmap f id--mu :: Category p => Procompose p p :-> p-mu (Procompose f g) = f . g

@@ -7,7 +7,7 @@ #endif ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2013-2014 Edward Kmett and Dan Doel+-- Copyright   :  (C) 2013-2015 Edward Kmett and Dan Doel -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -21,6 +21,8 @@   , precomposeRan   , curryRan   , uncurryRan+  , Codensity(..)+  , decomposeCodensity   ) where  import Control.Category@@ -30,6 +32,10 @@ import Data.Profunctor.Unsafe import Prelude hiding (id,(.)) +--------------------------------------------------------------------------------+-- * Ran+--------------------------------------------------------------------------------+ -- | This represents the right Kan extension of a 'Profunctor' @q@ along a 'Profunctor' @p@ in a limited version of the 2-category of Profunctors where the only object is the category Hask, 1-morphisms are profunctors composed and compose with Profunctor composition, and 2-morphisms are just natural transformations. newtype Ran p q a b = Ran { runRan :: forall x. p x a -> q x b } @@ -81,3 +87,36 @@ uncurryRan :: (p :-> Ran q r) -> Procompose p q :-> r uncurryRan f (Procompose p q) = runRan (f p) q {-# INLINE uncurryRan #-}++--------------------------------------------------------------------------------+-- * Codensity+--------------------------------------------------------------------------------++-- | This represents the right Kan extension of a 'Profunctor' @p@ along itself. This provides a generalization of the \"difference list\" trick to profunctors.+newtype Codensity p a b = Codensity { runCodensity :: forall x. p x a -> p x b }++instance Profunctor p => Profunctor (Codensity p) where+  dimap ca bd f = Codensity (rmap bd . runCodensity f . rmap ca)+  {-# INLINE dimap #-}+  lmap ca f = Codensity (runCodensity f . rmap ca)+  {-# INLINE lmap #-}+  rmap bd f = Codensity (rmap bd . runCodensity f)+  {-# INLINE rmap #-}+  bd #. f = Codensity (\p -> bd #. runCodensity f p)+  {-# INLINE ( #. ) #-}+  f .# ca = Codensity (\p -> runCodensity f (ca #. p))+  {-# INLINE (.#) #-}++instance Profunctor p => Functor (Codensity p a) where+  fmap bd f = Codensity (rmap bd . runCodensity f)+  {-# INLINE fmap #-}++instance Category (Codensity p) where+  id = Codensity id+  {-# INLINE id #-}+  Codensity f . Codensity g = Codensity (f . g)+  {-# INLINE (.) #-}++decomposeCodensity :: Procompose (Codensity p) p a b -> p a b+decomposeCodensity (Procompose (Codensity pp) p) = pp p+{-# INLINE decomposeCodensity #-}

@@ -30,6 +30,7 @@   , Corepresentable(..)   , cotabulated   , unfirstCorep, unsecondCorep+  , closedCorep   -- * Prep -| Star   , Prep(..)   , prepAdj@@ -89,7 +90,14 @@   tabulate = Forget . (getConst .)   {-# INLINE tabulate #-} +{- TODO: coproducts and products+instance (Representable p, Representable q) => Representable (Bifunctor.Product p q)+  type Rep (Bifunctor.Product p q) = Functor.Product p q +instance (Corepresentable p, Corepresentable q) => Corepresentable (Bifunctor.Product p q) where+  type Rep (Bifunctor.Product p q) = Functor.Sum p q+-}+ type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)  -- | 'tabulate' and 'sieve' form two halves of an isomorphism.@@ -109,15 +117,19 @@   type Corep p :: * -> *   cotabulate :: (Corep p d -> c) -> p d c --- | Default definition for 'unfirst' given that p is 'Corepresentable'.+-- | Default definition for 'unfirst' given that @p@ is 'Corepresentable'. unfirstCorep :: Corepresentable p => p (a, d) (b, d) -> p a b unfirstCorep p = cotabulate f   where f fa = b where (b, d) = cosieve p ((\a -> (a, d)) <$> fa) --- | Default definition for 'unsecond' given that p is 'Corepresentable'.+-- | Default definition for 'unsecond' given that @p@ is 'Corepresentable'. unsecondCorep :: Corepresentable p => p (d, a) (d, b) -> p a b unsecondCorep p = cotabulate f   where f fa = b where (d, b) = cosieve p ((,) d <$> fa)++-- | Default definition for 'closed' given that @p@ is 'Corepresentable'+closedCorep :: Corepresentable p => p a b -> p (x -> a) (x -> b)+closedCorep p = cotabulate $ \fs x -> cosieve p (fmap ($x) fs)  instance Corepresentable (->) where   type Corep (->) = Identity

@@ -0,0 +1,390 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}++#if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 708+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2014-2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  Rank2Types+--+----------------------------------------------------------------------------+module Data.Profunctor.Strong+  (+  -- * Strength+    Strong(..)+  , uncurry'+  , Tambara(..)+  , tambara, untambara+  , Pastro(..)+  -- * Costrength+  , Costrong(..)+  , Cotambara(..)+  , cotambara, uncotambara+  , Copastro(..)+  ) where++import Control.Applicative hiding (WrappedArrow(..))+import Control.Arrow+import Control.Category+import Control.Comonad+import Control.Monad (liftM)+import Control.Monad.Fix+import Data.Bifunctor.Clown (Clown(..))+import Data.Bifunctor.Product (Product(..))+import Data.Bifunctor.Tannen (Tannen(..))+import Data.Functor.Contravariant (Contravariant(..))+import Data.Monoid hiding (Product)+import Data.Profunctor.Adjunction+import Data.Profunctor.Monad+import Data.Profunctor.Types+import Data.Profunctor.Unsafe+import Data.Tagged+import Data.Tuple+import Prelude hiding (id,(.))++------------------------------------------------------------------------------+-- Strong+------------------------------------------------------------------------------++-- | Generalizing 'Star' of a strong 'Functor'+--+-- /Note:/ Every 'Functor' in Haskell is strong with respect to @(,)@.+--+-- This describes profunctor strength with respect to the product structure+-- of Hask.+--+-- <http://www-kb.is.s.u-tokyo.ac.jp/~asada/papers/arrStrMnd.pdf>+class Profunctor p => Strong p where+  first' :: p a b  -> p (a, c) (b, c)+  first' = dimap swap swap . second'++  second' :: p a b -> p (c, a) (c, b)+  second' = dimap swap swap . first'++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+  {-# MINIMAL first' | second' #-}+#endif++uncurry' :: Strong p => p a (b -> c) -> p (a, b) c+uncurry' = rmap (\(f,x) -> f x) . first'+{-# INLINE uncurry' #-}++instance Strong (->) where+  first' ab ~(a, c) = (ab a, c)+  {-# INLINE first' #-}+  second' ab ~(c, a) = (c, ab a)++instance Monad m => Strong (Kleisli m) where+  first' (Kleisli f) = Kleisli $ \ ~(a, c) -> do+     b <- f a+     return (b, c)+  {-# INLINE first' #-}+  second' (Kleisli f) = Kleisli $ \ ~(c, a) -> do+     b <- f a+     return (c, b)+  {-# INLINE second' #-}++instance Functor m => Strong (Star m) where+  first' (Star f) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a+  {-# INLINE first' #-}+  second' (Star f) = Star $ \ ~(c, a) -> (,) c <$> f a+  {-# INLINE second' #-}++-- | 'Arrow' is 'Strong' 'Category'+instance Arrow p => Strong (WrappedArrow p) where+  first' (WrapArrow k) = WrapArrow (first k)+  {-# INLINE first' #-}+  second' (WrapArrow k) = WrapArrow (second k)+  {-# INLINE second' #-}++instance Strong (Forget r) where+  first' (Forget k) = Forget (k . fst)+  {-# INLINE first' #-}+  second' (Forget k) = Forget (k . snd)+  {-# INLINE second' #-}++instance Contravariant f => Strong (Clown f) where+  first' (Clown fa) = Clown (contramap fst fa)+  {-# INLINE first' #-}+  second' (Clown fa) = Clown (contramap snd fa)+  {-# INLINE second' #-}++instance (Strong p, Strong q) => Strong (Product p q) where+  first' (Pair p q) = Pair (first' p) (first' q)+  {-# INLINE first' #-}+  second' (Pair p q) = Pair (second' p) (second' q)+  {-# INLINE second' #-}++instance (Functor f, Strong p) => Strong (Tannen f p) where+  first' (Tannen fp) = Tannen (fmap first' fp)+  {-# INLINE first' #-}+  second' (Tannen fp) = Tannen (fmap second' fp)+  {-# INLINE second' #-}++----------------------------------------------------------------------------+-- * Tambara+----------------------------------------------------------------------------++-- | 'Tambara' cofreely makes any 'Profunctor' 'Strong'.+newtype Tambara p a b = Tambara { runTambara :: forall c. p (a, c) (b, c) }++instance Profunctor p => Profunctor (Tambara p) where+  dimap f g (Tambara p) = Tambara $ dimap (first f) (first g) p+  {-# INLINE dimap #-}++instance ProfunctorFunctor Tambara where+  promap f (Tambara p) = Tambara (f p)++instance ProfunctorComonad Tambara where+  proextract (Tambara p) = dimap (\a -> (a,())) fst p+  produplicate (Tambara p) = Tambara (Tambara $ dimap hither yon p) where+    hither :: ((a, b), c) -> (a, (b, c))+    hither ~(~(x,y),z) = (x,(y,z))++    yon    :: (a, (b, c)) -> ((a, b), c)+    yon    ~(x,~(y,z)) = ((x,y),z)++instance Profunctor p => Strong (Tambara p) where+  first' = runTambara . produplicate+  {-# INLINE first' #-}++instance Category p => Category (Tambara p) where+  id = Tambara id+  Tambara p . Tambara q = Tambara (p . q)++instance Arrow p => Arrow (Tambara p) where+  arr f = Tambara $ arr $ first f+  first (Tambara f) = Tambara (arr go . first f . arr go) where+    go :: ((a, b), c) -> ((a, c), b)+    go ~(~(x,y),z) = ((x,z),y)++instance ArrowChoice p => ArrowChoice (Tambara p) where+  left (Tambara f) = Tambara (arr yon . left f . arr hither) where+    hither :: (Either a b, c) -> Either (a, c) (b, c)+    hither (Left y, s) = Left (y, s)+    hither (Right z, s) = Right (z, s)++    yon :: Either (a, c) (b, c) -> (Either a b, c)+    yon (Left (y, s)) = (Left y, s)+    yon (Right (z, s)) = (Right z, s)++instance ArrowApply p => ArrowApply (Tambara p) where+  app = Tambara $ app . arr (\((Tambara f, x), s) -> (f, (x, s)))++instance ArrowLoop p => ArrowLoop (Tambara p) where+  loop (Tambara f) = Tambara (loop (arr go . f . arr go)) where+    go :: ((a, b), c) -> ((a, c), b)+    go ~(~(x,y),z) = ((x,z),y)++instance ArrowZero p => ArrowZero (Tambara p) where+  zeroArrow = Tambara zeroArrow++instance ArrowPlus p => ArrowPlus (Tambara p) where+  Tambara f <+> Tambara g = Tambara (f <+> g)++instance Profunctor p => Functor (Tambara p a) where+  fmap = rmap++instance (Profunctor p, Arrow p) => Applicative (Tambara p a) where+  pure x = arr (const x)+  f <*> g = arr (uncurry id) . (f &&& g)++instance (Profunctor p, ArrowPlus p) => Alternative (Tambara p a) where+  empty = zeroArrow+  f <|> g = f <+> g++instance ArrowPlus p => Monoid (Tambara p a b) where+  mempty = zeroArrow+  mappend f g = f <+> g++-- |+-- @+-- 'tambara' '.' 'untambara' ≡ 'id'+-- 'untambara' '.' 'tambara' ≡ 'id'+-- @+tambara :: Strong p => (p :-> q) -> p :-> Tambara q+tambara f p = Tambara $ f $ first' p++-- |+-- @+-- 'tambara' '.' 'untambara' ≡ 'id'+-- 'untambara' '.' 'tambara' ≡ 'id'+-- @+untambara :: Profunctor q => (p :-> Tambara q) -> p :-> q+untambara f p = dimap (\a -> (a,())) fst $ runTambara $ f p++----------------------------------------------------------------------------+-- * Pastro+----------------------------------------------------------------------------++-- | Pastro -| Tambara+--+-- @+-- Pastro p ~ exists z. Costar ((,)z) `Procompose` p `Procompose` Star ((,)z)+-- @+--+-- 'Pastro' freely makes any 'Profunctor' 'Strong'.+data Pastro p a b where+  Pastro :: ((y, z) -> b) -> p x y -> (a -> (x, z)) -> Pastro p a b++instance Profunctor (Pastro p) where+  dimap f g (Pastro l m r) = Pastro (g . l) m (r . f)+  lmap f (Pastro l m r) = Pastro l m (r . f)+  rmap g (Pastro l m r) = Pastro (g . l) m r+  w #. Pastro l m r = Pastro (w #. l) m r+  Pastro l m r .# w = Pastro l m (r .# w)++instance ProfunctorFunctor Pastro where+  promap f (Pastro l m r) = Pastro l (f m) r++instance ProfunctorMonad Pastro where+  proreturn p = Pastro fst p $ \a -> (a,())+  projoin (Pastro l (Pastro m n o) p) = Pastro lm n op where+    op a = case p a of+      (b, f) -> case o b of+         (c, g) -> (c, (f, g))+    lm (d, (f, g)) = l (m (d, g), f)++instance ProfunctorAdjunction Pastro Tambara where+  counit (Pastro g (Tambara p) f) = dimap f g p+  unit p = Tambara (Pastro id p id)++instance Strong (Pastro p) where+  first' (Pastro l m r) = Pastro l' m r' where+    r' (a,c) = case r a of+      (x,z) -> (x,(z,c))+    l' (y,(z,c)) = (l (y,z), c)+  second' (Pastro l m r) = Pastro l' m r' where+    r' (c,a) = case r a of+      (x,z) -> (x,(c,z))+    l' (y,(c,z)) = (c,l (y,z))++--------------------------------------------------------------------------------+-- * Costrength for (,)+--------------------------------------------------------------------------------++-- | Analogous to 'ArrowLoop', 'loop' = 'unfirst'+class Profunctor p => Costrong p where+  unfirst  :: p (a, d) (b, d) -> p a b+  unfirst = unsecond . dimap swap swap++  unsecond :: p (d, a) (d, b) -> p a b+  unsecond = unfirst . dimap swap swap++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+  {-# MINIMAL unfirst | unsecond #-}+#endif++instance Costrong (->) where+  unfirst f a = b where (b, d) = f (a, d)+  unsecond f a = b where (d, b) = f (d, a)++instance Functor f => Costrong (Costar f) where+  unfirst (Costar f) = Costar f'+    where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa)+  unsecond (Costar f) = Costar f'+    where f' fa = b where (d, b) = f ((,) d <$> fa)++instance Costrong Tagged where+  unfirst (Tagged bd) = Tagged (fst bd)+  unsecond (Tagged db) = Tagged (snd db)++instance ArrowLoop p => Costrong (WrappedArrow p) where+  unfirst (WrapArrow k) = WrapArrow (loop k)++instance MonadFix m => Costrong (Kleisli m) where+  unfirst (Kleisli f) = Kleisli (liftM fst . mfix . f')+    where f' x y = f (x, snd y)++instance Functor f => Costrong (Cokleisli f) where+  unfirst (Cokleisli f) = Cokleisli f'+    where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa)++instance (Functor f, Costrong p) => Costrong (Tannen f p) where+  unfirst (Tannen fp) = Tannen (fmap unfirst fp)+  unsecond (Tannen fp) = Tannen (fmap unsecond fp)++instance (Costrong p, Costrong q) => Costrong (Product p q) where+  unfirst (Pair p q) = Pair (unfirst p) (unfirst q)+  unsecond (Pair p q) = Pair (unsecond p) (unsecond q)++----------------------------------------------------------------------------+-- * Cotambara+----------------------------------------------------------------------------++-- | Cotambara cofreely constructs costrength+data Cotambara q a b where+    Cotambara :: Costrong r => (r :-> q) -> r a b -> Cotambara q a b++instance Profunctor (Cotambara p) where+  lmap f (Cotambara n p) = Cotambara n (lmap f p)+  rmap g (Cotambara n p) = Cotambara n (rmap g p)+  dimap f g (Cotambara n p) = Cotambara n (dimap f g p)++instance ProfunctorFunctor Cotambara where+  promap f (Cotambara n p) = Cotambara (f . n) p++instance ProfunctorComonad Cotambara where+  proextract (Cotambara n p)  = n p+  produplicate (Cotambara n p) = Cotambara id (Cotambara n p)++instance Costrong (Cotambara p) where+  unfirst (Cotambara n p) = Cotambara n (unfirst p)++instance Functor (Cotambara p a) where+  fmap = rmap++-- |+-- @+-- 'cotambara' '.' 'uncotambara' ≡ 'id'+-- 'uncotambara' '.' 'cotambara' ≡ 'id'+-- @+cotambara :: Costrong p => (p :-> q) -> p :-> Cotambara q+cotambara = Cotambara++-- |+-- @+-- 'cotambara' '.' 'uncotambara' ≡ 'id'+-- 'uncotambara' '.' 'cotambara' ≡ 'id'+-- @+uncotambara :: Profunctor q => (p :-> Cotambara q) -> p :-> q+uncotambara f p = proextract (f p)++----------------------------------------------------------------------------+-- * Copastro+----------------------------------------------------------------------------++-- | Copastro -| Cotambara+--+-- Copastro freely constructs costrength+newtype Copastro p a b = Copastro { runCopastro :: forall r. Costrong r => (forall x y. p x y -> r x y) -> r a b }++instance Profunctor (Copastro p) where+  dimap f g (Copastro h) = Copastro $ \ n -> dimap f g (h n)+  lmap f (Copastro h) = Copastro $ \ n -> lmap f (h n)+  rmap g (Copastro h) = Copastro $ \ n -> rmap g (h n)++instance ProfunctorAdjunction Copastro Cotambara where+ unit p = Cotambara id (proreturn p)+ counit (Copastro h) = proextract (h id)++instance ProfunctorFunctor Copastro where+  promap f (Copastro h) = Copastro $ \n -> h (n . f)++instance ProfunctorMonad Copastro where+  proreturn p = Copastro $ \n -> n p+  projoin p = Copastro $ \c -> runCopastro p (\x -> runCopastro x c)++instance Costrong (Copastro p) where+  unfirst (Copastro p) = Copastro $ \n -> unfirst (p n)+  unsecond (Copastro p) = Copastro $ \n -> unsecond (p n)

@@ -1,261 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Copyright   :  (C) 2014 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  Rank2Types---------------------------------------------------------------------------------module Data.Profunctor.Tambara-  ( Tambara(..)-  , tambara, untambara-  , Pastro(..)-  , Cotambara(..)-  , cotambara, uncotambara-  , Copastro(..)-  ) where--import Control.Applicative-import Control.Arrow-import Control.Category-import Data.Monoid-import Data.Profunctor-import Data.Profunctor.Adjunction-import Data.Profunctor.Monad-import Data.Profunctor.Unsafe-import Prelude hiding (id,(.))--------------------------------------------------------------------------------- * Tambara-------------------------------------------------------------------------------newtype Tambara p a b = Tambara { runTambara :: forall c. p (a, c) (b, c) }--instance Profunctor p => Profunctor (Tambara p) where-  dimap f g (Tambara p) = Tambara $ dimap (first f) (first g) p-  {-# INLINE dimap #-}--instance ProfunctorFunctor Tambara where-  promap f (Tambara p) = Tambara (f p)--instance ProfunctorComonad Tambara where-  proextract (Tambara p) = dimap (\a -> (a,())) fst p-  produplicate (Tambara p) = Tambara (Tambara $ dimap hither yon p) where-    hither :: ((a, b), c) -> (a, (b, c))-    hither ~(~(x,y),z) = (x,(y,z))--    yon    :: (a, (b, c)) -> ((a, b), c)-    yon    ~(x,~(y,z)) = ((x,y),z)--instance Profunctor p => Strong (Tambara p) where-  first' = runTambara . produplicate-  {-# INLINE first' #-}--instance Choice p => Choice (Tambara p) where-  left' (Tambara f) = Tambara $ dimap hither yon $ left' f where-    hither :: (Either a b, c) -> Either (a, c) (b, c)-    hither (Left y, s) = Left (y, s)-    hither (Right z, s) = Right (z, s)--    yon :: Either (a, c) (b, c) -> (Either a b, c)-    yon (Left (y, s)) = (Left y, s)-    yon (Right (z, s)) = (Right z, s)--instance Category p => Category (Tambara p) where-  id = Tambara id-  Tambara p . Tambara q = Tambara (p . q)--instance Arrow p => Arrow (Tambara p) where-  arr f = Tambara $ arr $ first f-  first (Tambara f) = Tambara (arr go . first f . arr go) where-    go :: ((a, b), c) -> ((a, c), b)-    go ~(~(x,y),z) = ((x,z),y)--instance ArrowChoice p => ArrowChoice (Tambara p) where-  left (Tambara f) = Tambara (arr yon . left f . arr hither) where-    hither :: (Either a b, c) -> Either (a, c) (b, c)-    hither (Left y, s) = Left (y, s)-    hither (Right z, s) = Right (z, s)--    yon :: Either (a, c) (b, c) -> (Either a b, c)-    yon (Left (y, s)) = (Left y, s)-    yon (Right (z, s)) = (Right z, s)--instance ArrowApply p => ArrowApply (Tambara p) where-  app = Tambara $ app . arr (\((Tambara f, x), s) -> (f, (x, s)))--instance ArrowLoop p => ArrowLoop (Tambara p) where-  loop (Tambara f) = Tambara (loop (arr go . f . arr go)) where-    go :: ((a, b), c) -> ((a, c), b)-    go ~(~(x,y),z) = ((x,z),y)--instance ArrowZero p => ArrowZero (Tambara p) where-  zeroArrow = Tambara zeroArrow--instance ArrowPlus p => ArrowPlus (Tambara p) where-  Tambara f <+> Tambara g = Tambara (f <+> g)--instance Profunctor p => Functor (Tambara p a) where-  fmap = rmap--instance (Profunctor p, Arrow p) => Applicative (Tambara p a) where-  pure x = arr (const x)-  f <*> g = arr (uncurry id) . (f &&& g)--instance (Profunctor p, ArrowPlus p) => Alternative (Tambara p a) where-  empty = zeroArrow-  f <|> g = f <+> g--instance (Profunctor p, ArrowPlus p) => Monoid (Tambara p a b) where-  mempty = zeroArrow-  mappend f g = f <+> g---- |--- @--- 'tambara' '.' 'untambara' ≡ 'id'--- 'untambara' '.' 'tambara' ≡ 'id'--- @-tambara :: Strong p => (p :-> q) -> p :-> Tambara q-tambara f p = Tambara $ f $ first' p---- |--- @--- 'tambara' '.' 'untambara' ≡ 'id'--- 'untambara' '.' 'tambara' ≡ 'id'--- @-untambara :: Profunctor q => (p :-> Tambara q) -> p :-> q-untambara f p = dimap (\a -> (a,())) fst $ runTambara $ f p--------------------------------------------------------------------------------- * Pastro--------------------------------------------------------------------------------- | Pastro -| Tambara------ @--- Pastro p ~ exists z. Costar ((,)z) `Procompose` p `Procompose` Star ((,)z)--- @-data Pastro p a b where-  Pastro :: ((y, z) -> b) -> p x y -> (a -> (x, z)) -> Pastro p a b--instance Profunctor p => Profunctor (Pastro p) where-  dimap f g (Pastro l m r) = Pastro (g . l) m (r . f)-  lmap f (Pastro l m r) = Pastro l m (r . f)-  rmap g (Pastro l m r) = Pastro (g . l) m r-  w #. Pastro l m r = Pastro (w #. l) m r-  Pastro l m r .# w = Pastro l m (r .# w)--instance ProfunctorFunctor Pastro where-  promap f (Pastro l m r) = Pastro l (f m) r--instance ProfunctorMonad Pastro where-  proreturn p = Pastro fst p $ \a -> (a,())-  projoin (Pastro l (Pastro m n o) p) = Pastro lm n op where-    op a = case p a of-      (b, f) -> case o b of-         (c, g) -> (c, (f, g))-    lm (d, (f, g)) = l (m (d, g), f)--instance ProfunctorAdjunction Pastro Tambara where-  counit (Pastro g (Tambara p) f) = dimap f g p-  unit p = Tambara (Pastro id p id)--------------------------------------------------------------------------------- * Cotambara--------------------------------------------------------------------------------- | Cotambara is freely adjoins respect for cocartesian structure to a profunctor------ Note: this is not dual to 'Tambara'. It is 'Tambara' with respect to a different tensor.-newtype Cotambara p a b = Cotambara { runCotambara :: forall c. p (Either a c) (Either b c) }--instance ProfunctorFunctor Cotambara where-  promap f (Cotambara p) = Cotambara (f p)--instance ProfunctorComonad Cotambara where-  proextract (Cotambara p)   = dimap Left (\(Left a) -> a) p-  produplicate (Cotambara p) = Cotambara (Cotambara $ dimap hither yon p) where-    hither :: Either (Either a b) c -> Either a (Either b c)-    hither (Left (Left x))   = Left x-    hither (Left (Right y))  = Right (Left y)-    hither (Right z)         = Right (Right z)--    yon    :: Either a (Either b c) -> Either (Either a b) c-    yon    (Left x)          = Left (Left x)-    yon    (Right (Left y))  = Left (Right y)-    yon    (Right (Right z)) = Right z--instance Profunctor p => Profunctor (Cotambara p) where-  dimap f g (Cotambara p) = Cotambara $ dimap (left f) (left g) p-  {-# INLINE dimap #-}--instance Profunctor p => Choice (Cotambara p) where-  left' = runCotambara . produplicate-  {-# INLINE left' #-}--instance Category p => Category (Cotambara p) where-  id = Cotambara id-  Cotambara p . Cotambara q = Cotambara (p . q)--instance Profunctor p => Functor (Cotambara p a) where-  fmap = rmap---- |--- @--- 'cotambara' '.' 'uncotambara' ≡ 'id'--- 'uncotambara' '.' 'cotambara' ≡ 'id'--- @-cotambara :: Choice p => (p :-> q) -> p :-> Cotambara q-cotambara f p = Cotambara $ f $ left' p---- |--- @--- 'cotambara' '.' 'uncotambara' ≡ 'id'--- 'uncotambara' '.' 'cotambara' ≡ 'id'--- @-uncotambara :: Profunctor q => (p :-> Cotambara q) -> p :-> q-uncotambara f p = dimap Left (\(Left a) -> a) $ runCotambara $ f p--------------------------------------------------------------------------------- * Copastro--------------------------------------------------------------------------------- | Copastro -| Cotambara-data Copastro p a b where-  Copastro :: (Either y z -> b) -> p x y -> (a -> Either x z) -> Copastro p a b--instance Profunctor p => Profunctor (Copastro p) where-  dimap f g (Copastro l m r) = Copastro (g . l) m (r . f)-  lmap f (Copastro l m r) = Copastro l m (r . f)-  rmap g (Copastro l m r) = Copastro (g . l) m r-  w #. Copastro l m r = Copastro (w #. l) m r-  Copastro l m r .# w = Copastro l m (r .# w)--instance ProfunctorAdjunction Copastro Cotambara where-  counit (Copastro f (Cotambara g) h) = dimap h f g-  unit p = Cotambara $ Copastro id p id--instance ProfunctorFunctor Copastro where-  promap f (Copastro l m r) = Copastro l (f m) r--instance ProfunctorMonad Copastro where-  proreturn p = Copastro (\(Left a)-> a) p Left-  projoin (Copastro l (Copastro m n o) q) = Copastro lm n oq where-    oq a = case q a of-      Left b -> case o b of-        Left c -> Left c-        Right z -> Right (Left z)-      Right z -> Right (Right z)-    lm (Left x) = l $ Left $ m $ Left x-    lm (Right (Left y)) = l $ Left $ m $ Right y-    lm (Right (Right z)) = l $ Right z

@@ -1,19 +0,0 @@-{-# LANGUAGE GADTs #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Profunctor.Trace--- Copyright   :  (C) 2011-2012 Edward Kmett--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  GADTs---------------------------------------------------------------------------------module Data.Profunctor.Trace-  ( Trace(..)-  ) where---- | Coend of 'Data.Profunctor.Profunctor' from @Hask -> Hask@.-data Trace f where-  Trace :: f a a -> Trace f

@@ -0,0 +1,157 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveFunctor #-}+module Data.Profunctor.Traversing+  ( Traversing(..)+  , CofreeTraversing(..)+  , FreeTraversing(..)+  -- * Strong in terms of Traversing+  , firstTraversing+  , secondTraversing+  -- * Choice in terms of Traversing+  , leftTraversing+  , rightTraversing+  ) where++import Control.Applicative+import Control.Arrow (Kleisli(..))+import Data.Functor.Compose+import Data.Functor.Identity+import Data.Orphans ()+import Data.Profunctor.Choice+import Data.Profunctor.Monad+import Data.Profunctor.Strong+import Data.Profunctor.Types+import Data.Profunctor.Unsafe+import Data.Traversable+import Data.Tuple (swap)++#if __GLASGOW_HASKELL__ < 710+import Data.Foldable+import Prelude hiding (mapM)+#endif++firstTraversing :: Traversing p => p a b -> p (a, c) (b, c)+firstTraversing = dimap swap swap . traverse'++secondTraversing :: Traversing p => p a b -> p (c, a) (c, b)+secondTraversing = traverse'++swapE :: Either a b -> Either b a+swapE = either Right Left++leftTraversing :: Traversing p => p a b -> p (Either a c) (Either b c)+leftTraversing = dimap swapE swapE . traverse'++rightTraversing :: Traversing p => p a b -> p (Either c a) (Either c b)+rightTraversing = traverse'++newtype Bazaar a b t = Bazaar { runBazaar :: forall f. Applicative f => (a -> f b) -> f t }+  deriving Functor++instance Applicative (Bazaar a b) where+  pure a = Bazaar $ \_ -> pure a+  mf <*> ma = Bazaar $ \k -> runBazaar mf k <*> runBazaar ma k++instance Profunctor (Bazaar a) where+  dimap f g m = Bazaar $ \k -> g <$> runBazaar m (fmap f . k)++sell :: a -> Bazaar a b b+sell a = Bazaar $ \k -> k a++newtype Baz t b a = Baz { runBaz :: forall f. Applicative f => (a -> f b) -> f t }+  deriving Functor++-- bsell :: a -> Baz b b a+-- bsell a = Baz $ \k -> k a++-- aar :: Bazaar a b t -> Baz t b a+-- aar (Bazaar f) = Baz f++sold :: Baz t a a -> t+sold m = runIdentity (runBaz m Identity)++instance Foldable (Baz t b) where+  foldMap = foldMapDefault++instance Traversable (Baz t b) where+  traverse f bz = fmap (\m -> Baz (runBazaar m)) . getCompose . runBaz bz $ \x -> Compose $ sell <$> f x++instance Profunctor (Baz t) where+  dimap f g m = Baz $ \k -> runBaz m (fmap f . k . g)++-- | Note: Definitions in terms of 'wander' are much more efficient!+class (Choice p, Strong p) => Traversing p where+  traverse' :: Traversable f => p a b -> p (f a) (f b)+  traverse' = wander traverse++  wander :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> p a b -> p s t+  wander f pab = dimap (\s -> Baz $ \afb -> f afb s) sold (traverse' pab)++#if __GLASGOW_HASKELL__ >= 706+  {-# MINIMAL wander | traverse' #-}+#endif++instance Traversing (->) where+  traverse' = fmap+  wander f ab = runIdentity #. f (Identity #. ab)++instance Monad m => Traversing (Kleisli m) where+  traverse' (Kleisli m) = Kleisli (mapM m)+  wander f (Kleisli amb) = Kleisli $ unwrapMonad #. f (WrapMonad #. amb)++instance Applicative m => Traversing (Star m) where+  traverse' (Star m) = Star (traverse m)+  wander f (Star amb) = Star (f amb)++newtype CofreeTraversing p a b = CofreeTraversing { runCofreeTraversing :: forall f. Traversable f => p (f a) (f b) }++instance Profunctor p => Profunctor (CofreeTraversing p) where+  lmap f (CofreeTraversing p) = CofreeTraversing (lmap (fmap f) p)+  rmap g (CofreeTraversing p) = CofreeTraversing (rmap (fmap g) p)+  dimap f g (CofreeTraversing p) = CofreeTraversing (dimap (fmap f) (fmap g) p)++instance Profunctor p => Strong (CofreeTraversing p) where+  second' = traverse'++instance Profunctor p => Choice (CofreeTraversing p) where+  right' = traverse'++instance Profunctor p => Traversing (CofreeTraversing p) where+  -- !@(#*&() Compose isn't representational in its second arg or we could use #. and .#+  traverse' (CofreeTraversing p) = CofreeTraversing (dimap Compose getCompose p)++instance ProfunctorFunctor CofreeTraversing where+  promap f (CofreeTraversing p) = CofreeTraversing (f p)++instance ProfunctorComonad CofreeTraversing where+  proextract (CofreeTraversing p) = runIdentity #. p .# Identity+  produplicate (CofreeTraversing p) = CofreeTraversing (CofreeTraversing (dimap Compose getCompose p))++-- | @FreeTraversing -| CofreeTraversing@+data FreeTraversing p a b where+  FreeTraversing :: Traversable f => (f y -> b) -> p x y -> (a -> f x) -> FreeTraversing p a b++instance Profunctor (FreeTraversing p) where+  lmap f (FreeTraversing l m r) = FreeTraversing l m (r . f)+  rmap g (FreeTraversing l m r) = FreeTraversing (g . l) m r+  dimap f g (FreeTraversing l m r) = FreeTraversing (g . l) m (r . f)+  g #. FreeTraversing l m r = FreeTraversing (g #. l) m r+  FreeTraversing l m r .# f = FreeTraversing l m (r .# f)++instance Strong (FreeTraversing p) where+  second' = traverse'++instance Choice (FreeTraversing p) where+  right' = traverse'++instance Traversing (FreeTraversing p) where+  traverse' (FreeTraversing l m r) = FreeTraversing (fmap l .# getCompose) m (Compose #. fmap r)++instance ProfunctorFunctor FreeTraversing where+  promap f (FreeTraversing l m r) = FreeTraversing l (f m) r++instance ProfunctorMonad FreeTraversing where+  proreturn p = FreeTraversing runIdentity p Identity+  projoin (FreeTraversing l (FreeTraversing l' m r') r) = FreeTraversing ((l . fmap l') .# getCompose) m (Compose #. (fmap r' . r))

@@ -0,0 +1,229 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++#if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 708+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2011-2015 Edward Kmett,+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- For a good explanation of profunctors in Haskell see Dan Piponi's article:+--+-- <http://blog.sigfpe.com/2011/07/profunctors-in-haskell.html>+--+-- For more information on strength and costrength, see:+--+-- <http://comonad.com/reader/2008/deriving-strength-from-laziness/>+----------------------------------------------------------------------------+module Data.Profunctor.Types+  ( Profunctor(dimap, lmap, rmap)+  , Star(..)+  , Costar(..)+  , WrappedArrow(..)+  , Forget(..)+#ifndef HLINT+  , (:->)+#endif+  ) where++import Control.Applicative hiding (WrappedArrow(..))+import Control.Arrow+import Control.Category+import Control.Comonad+import Control.Monad (MonadPlus(..))+import Data.Distributive+import Data.Foldable+import Data.Monoid hiding (Product)+import Data.Profunctor.Unsafe+import Data.Traversable+import Prelude hiding (id,(.),sequence)++#if __GLASGOW_HASKELL__ >= 708+import Data.Coerce+#else+import Unsafe.Coerce+#endif++infixr 0 :->+type p :-> q = forall a b. p a b -> q a b++------------------------------------------------------------------------------+-- Star+------------------------------------------------------------------------------++-- | Lift a 'Functor' into a 'Profunctor' (forwards).+newtype Star f d c = Star { runStar :: d -> f c }++instance Functor f => Profunctor (Star f) where+  dimap ab cd (Star bfc) = Star (fmap cd . bfc . ab)+  {-# INLINE dimap #-}+  lmap k (Star f) = Star (f . k)+  {-# INLINE lmap #-}+  rmap k (Star f) = Star (fmap k . f)+  {-# INLINE rmap #-}+  -- We cannot safely overload ( #. ) because we didn't write the 'Functor'.+#if __GLASGOW_HASKELL__ >= 708+  p .# _ = coerce p+#else+  p .# _ = unsafeCoerce p+#endif+  {-# INLINE ( .# ) #-}++instance Functor f => Functor (Star f a) where+  fmap = rmap+  {-# INLINE fmap #-}++instance Applicative f => Applicative (Star f a) where+  pure a = Star $ \_ -> pure a+  Star ff <*> Star fx = Star $ \a -> ff a <*> fx a+  Star ff  *> Star fx = Star $ \a -> ff a  *> fx a+  Star ff <*  Star fx = Star $ \a -> ff a <*  fx a++instance Alternative f => Alternative (Star f a) where+  empty = Star $ \_ -> empty+  Star f <|> Star g = Star $ \a -> f a <|> g a++instance Monad f => Monad (Star f a) where+#if __GLASGOW_HASKELL__ < 710+  return a = Star $ \_ -> return a+#endif+  Star m >>= f = Star $ \ e -> do+    a <- m e+    runStar (f a) e++instance MonadPlus f => MonadPlus (Star f a) where+  mzero = Star $ \_ -> mzero+  Star f `mplus` Star g = Star $ \a -> f a `mplus` g a++instance Distributive f => Distributive (Star f a) where+  distribute fs = Star $ \a -> collect (($ a) .# runStar) fs++------------------------------------------------------------------------------+-- Costar+------------------------------------------------------------------------------++-- | Lift a 'Functor' into a 'Profunctor' (backwards).+newtype Costar f d c = Costar { runCostar :: f d -> c }++instance Functor f => Profunctor (Costar f) where+  dimap ab cd (Costar fbc) = Costar (cd . fbc . fmap ab)+  {-# INLINE dimap #-}+  lmap k (Costar f) = Costar (f . fmap k)+  {-# INLINE lmap #-}+  rmap k (Costar f) = Costar (k . f)+  {-# INLINE rmap #-}+#if __GLASGOW_HASKELL__ >= 708+  ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b+#else+  ( #. ) _ = unsafeCoerce+#endif+  {-# INLINE ( #. ) #-}+  -- We cannot overload ( .# ) because we didn't write the 'Functor'.++instance Distributive (Costar f d) where+  distribute fs = Costar $ \gd -> fmap (($ gd) .# runCostar) fs++instance Functor (Costar f a) where+  fmap k (Costar f) = Costar (k . f)+  {-# INLINE fmap #-}+  a <$ _ = Costar $ \_ -> a+  {-# INLINE (<$) #-}++instance Applicative (Costar f a) where+  pure a = Costar $ \_ -> a+  Costar ff <*> Costar fx = Costar $ \a -> ff a (fx a)+  _ *> m = m+  m <* _ = m++instance Monad (Costar f a) where+  return = pure+  Costar m >>= f = Costar $ \ x -> runCostar (f (m x)) x++------------------------------------------------------------------------------+-- Wrapped Profunctors+------------------------------------------------------------------------------++-- | Wrap an arrow for use as a 'Profunctor'.+newtype WrappedArrow p a b = WrapArrow { unwrapArrow :: p a b }++instance Category p => Category (WrappedArrow p) where+  WrapArrow f . WrapArrow g = WrapArrow (f . g)+  {-# INLINE (.) #-}+  id = WrapArrow id+  {-# INLINE id #-}++instance Arrow p => Arrow (WrappedArrow p) where+  arr = WrapArrow . arr+  {-# INLINE arr #-}+  first = WrapArrow . first . unwrapArrow+  {-# INLINE first #-}+  second = WrapArrow . second . unwrapArrow+  {-# INLINE second #-}+  WrapArrow a *** WrapArrow b = WrapArrow (a *** b)+  {-# INLINE (***) #-}+  WrapArrow a &&& WrapArrow b = WrapArrow (a &&& b)+  {-# INLINE (&&&) #-}++instance ArrowZero p => ArrowZero (WrappedArrow p) where+  zeroArrow = WrapArrow zeroArrow+  {-# INLINE zeroArrow #-}++instance ArrowChoice p => ArrowChoice (WrappedArrow p) where+  left = WrapArrow . left . unwrapArrow+  {-# INLINE left #-}+  right = WrapArrow . right . unwrapArrow+  {-# INLINE right #-}+  WrapArrow a +++ WrapArrow b = WrapArrow (a +++ b)+  {-# INLINE (+++) #-}+  WrapArrow a ||| WrapArrow b = WrapArrow (a ||| b)+  {-# INLINE (|||) #-}++instance ArrowApply p => ArrowApply (WrappedArrow p) where+  app = WrapArrow $ app . arr (first unwrapArrow)+  {-# INLINE app #-}++instance ArrowLoop p => ArrowLoop (WrappedArrow p) where+  loop = WrapArrow . loop . unwrapArrow+  {-# INLINE loop #-}++instance Arrow p => Profunctor (WrappedArrow p) where+  lmap = (^>>)+  {-# INLINE lmap #-}+  rmap = (^<<)+  {-# INLINE rmap #-}+  -- We cannot safely overload ( #. ) or ( .# ) because we didn't write the 'Arrow'.++------------------------------------------------------------------------------+-- Forget+------------------------------------------------------------------------------++newtype Forget r a b = Forget { runForget :: a -> r }++instance Profunctor (Forget r) where+  dimap f _ (Forget k) = Forget (k . f)+  {-# INLINE dimap #-}+  lmap f (Forget k) = Forget (k . f)+  {-# INLINE lmap #-}+  rmap _ (Forget k) = Forget k+  {-# INLINE rmap #-}++instance Functor (Forget r a) where+  fmap _ (Forget k) = Forget k+  {-# INLINE fmap #-}++instance Foldable (Forget r a) where+  foldMap _ _ = mempty+  {-# INLINE foldMap #-}++instance Traversable (Forget r a) where+  traverse _ (Forget k) = pure (Forget k)+  {-# INLINE traverse #-}

@@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- |--- Copyright   :  (C) 2011-2013 Edward Kmett+-- Copyright   :  (C) 2011-2015 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>@@ -38,8 +38,14 @@ import Control.Category import Control.Comonad (Cokleisli(..)) import Control.Monad (liftM)+import Data.Bifunctor.Biff (Biff(..)) import Data.Bifunctor.Clown (Clown(..)) import Data.Bifunctor.Joker (Joker(..))+import Data.Bifunctor.Product (Product(..))+import Data.Bifunctor.Tannen (Tannen(..))+#if __GLASGOW_HASKELL__ < 710+import Data.Functor+#endif import Data.Functor.Contravariant (Contravariant(..)) import Data.Tagged import Prelude hiding (id,(.),sequence)@@ -258,3 +264,32 @@   {-# INLINE rmap #-}   dimap _ g (Joker fb) = Joker (fmap g fb)   {-# INLINE dimap #-}++instance (Profunctor p, Functor f, Functor g) => Profunctor (Biff p f g) where+  lmap f (Biff p) = Biff (lmap (fmap f) p)+  rmap g (Biff p) = Biff (rmap (fmap g) p)+  dimap f g (Biff p) = Biff (dimap (fmap f) (fmap g) p)++instance (Profunctor p, Profunctor q) => Profunctor (Product p q) where+  lmap  f   (Pair p q) = Pair (lmap f p) (lmap f q)+  {-# INLINE lmap #-}+  rmap    g (Pair p q) = Pair (rmap g p) (rmap g q)+  {-# INLINE rmap #-}+  dimap f g (Pair p q) = Pair (dimap f g p) (dimap f g q)+  {-# INLINE dimap #-}+  ( #. ) f (Pair p q) = Pair (f #. p) (f #. q)+  {-# INLINE ( #. ) #-}+  ( .# ) (Pair p q) f = Pair (p .# f) (q .# f)+  {-# INLINE ( .# ) #-}++instance (Functor f, Profunctor p) => Profunctor (Tannen f p) where+  lmap f (Tannen h) = Tannen (lmap f <$> h)+  {-# INLINE lmap #-}+  rmap g (Tannen h) = Tannen (rmap g <$> h)+  {-# INLINE rmap #-}+  dimap f g (Tannen h) = Tannen (dimap f g <$> h)+  {-# INLINE dimap #-}+  ( #. ) f (Tannen h) = Tannen ((f #.) <$> h)+  {-# INLINE ( #. ) #-}+  ( .# ) (Tannen h) f = Tannen ((.# f) <$> h)+  {-# INLINE ( .# ) #-}