packages feed

profunctors 4.0.4 → 4.1

raw patch · 14 files changed

+759/−170 lines, 14 filesdep +distributivedep ~base

Dependencies added: distributive

Dependency ranges changed: base

Files

CHANGELOG.markdown view
@@ -1,3 +1,14 @@+4.1+---+* Flipped the order of 'Procompose'+* Added the notion of Monads and Comonads on the category of profunctors.+* Added 'Cayley' which takes normal Haskell Monads and Comonads to a 'ProfunctorMonad' and 'ProfunctorComonad' respectively. Cayley is also known as the 'static arrow' construction+* Added 'Closed' which is adjoint to 'Strong'.+* Added 'Closure' which freely adjoins 'Closed' to any 'Profunctor'.+* Added 'Tambara' which freely adjoins 'Strong' to any 'Profunctor'.+* Added 'Cotambara' which freely adjoins 'Choice' to any 'Profunctor'.+* Under the new 'Procompose' the old 'Rift' is now 'Ran', and the old 'Lift' was misnamed. It is now 'Rift'+ 4.0.3 ----- * Added `Data.Profunctor.Lift` containing the left Kan lift of a profunctor.
profunctors.cabal view
@@ -1,6 +1,6 @@ name:          profunctors category:      Control, Categories-version:       4.0.4+version:       4.1 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -29,17 +29,23 @@   build-depends:     base                >= 4     && < 5,     comonad             >= 4     && < 5,+    distributive        >= 0.4.4 && < 1,     semigroupoids       >= 4     && < 5,     tagged              >= 0.4.4 && < 1,     transformers        >= 0.2   && < 0.5    exposed-modules:     Data.Profunctor+    Data.Profunctor.Adjunction+    Data.Profunctor.Cayley+    Data.Profunctor.Closed+    Data.Profunctor.Codensity     Data.Profunctor.Composition     Data.Profunctor.Collage-    Data.Profunctor.Lift+    Data.Profunctor.Monad+    Data.Profunctor.Ran     Data.Profunctor.Rep-    Data.Profunctor.Rift+    Data.Profunctor.Tambara     Data.Profunctor.Trace     Data.Profunctor.Unsafe
src/Data/Profunctor.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif@@ -31,6 +33,9 @@   , DownStar(..)   , WrappedArrow(..)   , Forget(..)+#ifndef HLINT+  , type (-/->)+#endif   ) where  import Control.Applicative hiding (WrappedArrow(..))@@ -45,6 +50,8 @@ import Data.Profunctor.Unsafe import Prelude hiding (id,(.),sequence) import Unsafe.Coerce++type p -/-> q = forall a b. p a b -> q a b  ------------------------------------------------------------------------------ -- UpStar
+ src/Data/Profunctor/Adjunction.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+module Data.Profunctor.Adjunction where++import Data.Profunctor++class f -| u | f -> u, u -> f where+  unit   :: Profunctor p => p -/-> u (f p)+  counit :: Profunctor p => f (u p) -/-> p
+ src/Data/Profunctor/Cayley.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2014 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+----------------------------------------------------------------------------++module Data.Profunctor.Cayley where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Comonad+import Data.Profunctor+import Data.Profunctor.Monad+import Data.Profunctor.Unsafe+import Prelude hiding ((.), id)++-- static arrows+newtype Cayley f p a b = Cayley { runCayley :: f (p a b) }++-- | Cayley transforms Monads in @Hask@ into monads on @Prof@+instance Monad f => ProfunctorMonad (Cayley f) where+  proreturn = Cayley . return+  projoin (Cayley m) = Cayley $ m >>= runCayley++-- | Cayley transforms Comonads in @Hask@ into comonads on @Prof@+instance Comonad f => ProfunctorComonad (Cayley f) where+  proextract = extract . runCayley+  produplicate (Cayley w) = Cayley $ extend Cayley w++instance (Functor f, Profunctor p) => Profunctor (Cayley f p) where+  dimap f g = Cayley . fmap (dimap f g) . runCayley+  lmap f = Cayley . fmap (lmap f) . runCayley+  rmap g = Cayley . fmap (rmap g) . runCayley+  w #. Cayley fp = Cayley $ fmap (w #.) fp+  Cayley fp .# w = Cayley $ fmap (.# w) fp++instance (Functor f, Strong p) => Strong (Cayley f p) where+  first'  = Cayley . fmap first' . runCayley+  second' = Cayley . fmap second' . runCayley++instance (Functor f, Choice p) => Choice (Cayley f p) where+  left'   = Cayley . fmap left' . runCayley+  right'  = Cayley . fmap right' . runCayley++instance (Applicative f, Category p) => Category (Cayley f p) where+  id = Cayley $ pure id+  Cayley fpbc . Cayley fpab = Cayley $ liftA2 (.) fpbc fpab++instance (Applicative f, Arrow p) => Arrow (Cayley f p) where+  arr f = Cayley $ pure $ arr f+  first = Cayley . fmap first . runCayley+  second = Cayley . fmap second . runCayley+  Cayley ab *** Cayley cd = Cayley $ liftA2 (***) ab cd+  Cayley ab &&& Cayley ac = Cayley $ liftA2 (&&&) ab ac++instance (Applicative f, ArrowChoice p) => ArrowChoice (Cayley f p) where+  left  = Cayley . fmap left . runCayley+  right = Cayley . fmap right . runCayley+  Cayley ab +++ Cayley cd = Cayley $ liftA2 (+++) ab cd+  Cayley ac ||| Cayley bc = Cayley $ liftA2 (|||) ac bc+  +instance (Applicative f, ArrowLoop p) => ArrowLoop (Cayley f p) where+  loop = Cayley . fmap loop . runCayley++instance (Applicative f, ArrowZero p) => ArrowZero (Cayley f p) where+  zeroArrow = Cayley $ pure zeroArrow++instance (Applicative f, ArrowPlus p) => ArrowPlus (Cayley f p) where+  Cayley f <+> Cayley g = Cayley (liftA2 (<+>) f g)
+ src/Data/Profunctor/Closed.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++module Data.Profunctor.Closed+  ( Closed(..)+  , Closure(..)+  , close+  , unclose+  , Environment(..)+  ) where++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Comonad+import Data.Distributive+import Data.Monoid+import Data.Profunctor+import Data.Profunctor.Adjunction+import Data.Profunctor.Monad+import Data.Profunctor.Unsafe+import Data.Tagged+import Prelude hiding ((.),id)++--------------------------------------------------------------------------------+-- * Closed+--------------------------------------------------------------------------------++-- | A strong profunctor allows the monoidal structure to pass through.+--+-- A closed profunctor allows the closed structure to pass through.+class Profunctor p => Closed p where+  closed :: p a b -> p (x -> a) (x -> b)++instance Closed Tagged where+  closed (Tagged b) = Tagged (const b)++instance Closed (->) where+  closed = (.)++instance Functor f => Closed (DownStar f) where+  closed (DownStar fab) = DownStar $ \fxa x -> fab (fmap ($x) fxa)++instance Functor f => Closed (Cokleisli f) where+  closed (Cokleisli fab) = Cokleisli $ \fxa x -> fab (fmap ($x) fxa)++instance Distributive f => Closed (UpStar f) where+  closed (UpStar afb) = UpStar $ \xa -> distribute $ \x -> afb (xa x)++instance (Distributive f, Monad f) => Closed (Kleisli f) where+  closed (Kleisli afb) = Kleisli $ \xa -> distribute $ \x -> afb (xa x)++instance Monoid r => Closed (Forget r) where+  closed _ = Forget $ \_ -> mempty++--------------------------------------------------------------------------------+-- * Closure+--------------------------------------------------------------------------------++-- | 'Closure' adjoins a 'Closed' structure to any 'Profunctor'.+--+-- Analogous to 'Data.Profunctor.Tambara.Tambara' for 'Closed'.++newtype Closure p a b = Closure { runClosure :: forall x. p (x -> a) (x -> b) }++instance Profunctor p => Profunctor (Closure p) where+  dimap f g (Closure p) = Closure $ dimap (fmap f) (fmap g) p+  lmap f (Closure p) = Closure $ lmap (fmap f) p+  rmap f (Closure p) = Closure $ rmap (fmap f) p+  w #. Closure p = Closure $ fmap w #. p+  Closure p .# w = Closure $ p .# fmap w++instance ProfunctorComonad Closure where+  proextract = dimap const ($ ()) . runClosure+  produplicate (Closure p) = Closure $ Closure $ dimap uncurry curry p++instance Profunctor p => Closed (Closure p) where+  closed = runClosure . produplicate++instance Strong p => Strong (Closure p) where+  first' (Closure p) = Closure $ dimap hither yon $ first' p++instance Category p => Category (Closure p) where+  id = Closure id+  Closure p . Closure q = Closure (p . q)++hither :: (s -> (a,b)) -> (s -> a, s -> b)+hither h = (fst . h, snd . h)++yon :: (s -> a, s -> b) -> s -> (a,b)+yon h s = (fst h s, snd h s)++instance Arrow p => Arrow (Closure p) where+  arr f = Closure (arr (f .))+  first (Closure f) = Closure $ arr yon . first f . arr hither++instance ArrowLoop p => ArrowLoop (Closure p) where+  loop (Closure f) = Closure $ loop (arr hither . f . arr yon)++instance ArrowZero p => ArrowZero (Closure p) where+  zeroArrow = Closure zeroArrow++instance ArrowPlus p => ArrowPlus (Closure p) where+  Closure f <+> Closure g = Closure (f <+> g)++instance Profunctor p => Functor (Closure p a) where+  fmap = rmap++instance (Profunctor p, Arrow p) => Applicative (Closure p a) where+  pure x = arr (const x)+  f <*> g = arr (uncurry id) . (f &&& g)++instance (Profunctor p, ArrowPlus p) => Alternative (Closure p a) where+  empty = zeroArrow+  f <|> g = f <+> g++instance (Profunctor p, Arrow p, Monoid b) => Monoid (Closure p a b) where+  mempty = pure mempty+  mappend = liftA2 mappend++-- |+-- @+-- 'close' '.' 'unclose' ≡ 'id'+-- 'unclose' '.' 'close' ≡ 'id'+-- @+close :: Closed p => (p -/-> q) -> p -/-> Closure q+close f p = Closure $ f $ closed p++-- |+-- @+-- 'close' '.' 'unclose' ≡ 'id'+-- 'unclose' '.' 'close' ≡ 'id'+-- @+unclose :: Profunctor q => (p -/-> Closure q) -> p -/-> q+unclose f p = dimap const ($ ()) $ runClosure $ f p++--------------------------------------------------------------------------------+-- * Environment+--------------------------------------------------------------------------------++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+  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+  w #. Environment l m r = Environment (w #. l) m r+  Environment l m r .# w = Environment l m (r .# w)++instance ProfunctorMonad Environment where+  proreturn p = Environment ($ ()) p const+  projoin (Environment l (Environment m n o) p) = Environment (lm . curry) n op where+    op a (b, c) = o (p a b) c+    lm zr = l (m.zr)++instance Environment -| Closure where+  counit (Environment g (Closure p) f) = dimap f g p+  unit p = Closure (Environment id p id)
+ src/Data/Profunctor/Codensity.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# 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 #-}
src/Data/Profunctor/Composition.hs view
@@ -2,18 +2,20 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module      :  Data.Profunctor.Composition--- Copyright   :  (C) 2011-2012 Edward Kmett+-- Copyright   :  (C) 2014 Edward Kmett -- License     :  BSD-style (see the file LICENSE) -- -- Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  GADTs+-- Stability   :  experimental+-- Portability :  GADTs, TFs, MPTCs, RankN -- ---------------------------------------------------------------------------- module Data.Profunctor.Composition@@ -21,13 +23,16 @@   -- * Profunctor Composition     Procompose(..)   , procomposed-  -- * Bicategorical Associators+  -- * Unitors and Associator   , idl   , idr   , assoc   -- * Generalized Composition   , upstars, kleislis   , downstars, cokleislis+  -- * Right Kan Lift+  , Rift(..)+  , decomposeRift   ) where  import Control.Arrow@@ -36,6 +41,9 @@ import Control.Monad (liftM) 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.Unsafe import Prelude hiding ((.),id)@@ -52,43 +60,46 @@ -- -- <http://blog.sigfpe.com/2011/07/profunctors-in-haskell.html> data Procompose p q d c where-  Procompose :: p d a -> q a c -> Procompose p q d c+  Procompose :: p x c -> q d x -> Procompose p q d c +instance Category p => ProfunctorMonad (Procompose p) where+  proreturn = Procompose id+  projoin (Procompose p (Procompose q r)) = Procompose (p . q) r+ procomposed :: Category p => Procompose p p a b -> p a b-procomposed (Procompose pda pac) = pac . pda+procomposed (Procompose pxc pdx) = pxc . pdx {-# INLINE procomposed #-} - instance (Profunctor p, Profunctor q) => Profunctor (Procompose p q) where-  dimap l r (Procompose f g) = Procompose (lmap l f) (rmap r g)+  dimap l r (Procompose f g) = Procompose (rmap r f) (lmap l g)   {-# INLINE dimap #-}-  lmap k (Procompose f g) = Procompose (lmap k f) g+  lmap k (Procompose f g) = Procompose f (lmap k g)   {-# INLINE rmap #-}-  rmap k (Procompose f g) = Procompose f (rmap k g)+  rmap k (Procompose f g) = Procompose (rmap k f) g   {-# INLINE lmap #-}-  k #. Procompose f g     = Procompose f (k #. g)+  k #. Procompose f g     = Procompose (k #. f) g   {-# INLINE ( #. ) #-}-  Procompose f g .# k     = Procompose (f .# k) g+  Procompose f g .# k     = Procompose f (g .# k)   {-# INLINE ( .# ) #-} -instance Profunctor q => Functor (Procompose p q a) where-  fmap k (Procompose f g) = Procompose f (rmap k g)+instance Profunctor p => Functor (Procompose p q a) where+  fmap k (Procompose f g) = Procompose (rmap k f) g   {-# INLINE fmap #-}  -- | The composition of two 'Representable' 'Profunctor's is 'Representable' by -- the composition of their representations. instance (Representable p, Representable q) => Representable (Procompose p q) where-  type Rep (Procompose p q) = Compose (Rep p) (Rep q)-  tabulate f = Procompose (tabulate (getCompose . f)) (tabulate id)+  type Rep (Procompose p q) = Compose (Rep q) (Rep p)+  tabulate f = Procompose (tabulate id) (tabulate (getCompose . f))   {-# INLINE tabulate #-}-  rep (Procompose f g) d = Compose $ rep g <$> rep f d+  rep (Procompose g f) d = Compose $ rep g <$> rep f d   {-# INLINE rep #-}  instance (Corepresentable p, Corepresentable q) => Corepresentable (Procompose p q) where-  type Corep (Procompose p q) = Compose (Corep q) (Corep p)-  cotabulate f = Procompose (cotabulate id) (cotabulate (f . Compose))+  type Corep (Procompose p q) = Compose (Corep p) (Corep q)+  cotabulate f = Procompose (cotabulate (f . Compose)) (cotabulate id)   {-# INLINE cotabulate #-}-  corep (Procompose f g) (Compose d) = corep g $ corep f <$> d+  corep (Procompose g f) (Compose d) = corep g $ corep f <$> d   {-# INLINE corep #-}  instance (Strong p, Strong q) => Strong (Procompose p q) where@@ -103,6 +114,9 @@   right' (Procompose x y) = Procompose (right' x) (right' y)   {-# INLINE right' #-} +instance (Closed p, Closed q) => Closed (Procompose p q) where+  closed (Procompose x y) = Procompose (closed x) (closed y)+  {-# INLINE closed #-}  -- * Lax identity @@ -116,7 +130,7 @@ -- 'idl' :: 'Profunctor' q => Iso' ('Procompose' (->) q d c) (q d c) -- @ idl :: Profunctor q => Iso (Procompose (->) q d c) (Procompose (->) r d' c') (q d c) (r d' c')-idl = dimap (\(Procompose f g) -> lmap f g) (fmap (Procompose id))+idl = dimap (\(Procompose g f) -> rmap g f) (fmap (Procompose id))  -- | @(->)@ functions as a lax identity for 'Profunctor' composition. --@@ -128,7 +142,7 @@ -- 'idr' :: 'Profunctor' q => Iso' ('Procompose' q (->) d c) (q d c) -- @ idr :: Profunctor q => Iso (Procompose q (->) d c) (Procompose r (->) d' c') (q d c) (r d' c')-idr = dimap (\(Procompose f g) -> rmap g f) (fmap (`Procompose` id))+idr = dimap (\(Procompose g f) -> lmap f g) (fmap (`Procompose` id))   -- | The associator for 'Profunctor' composition.@@ -148,14 +162,14 @@ -- isomorphic to @a -> f (g c)@. -- -- @'upstars' :: 'Functor' f => Iso' ('Procompose' ('UpStar' f) ('UpStar' g) d c) ('UpStar' ('Compose' f g) d c)@-upstars :: Functor f+upstars :: Functor g         => Iso (Procompose (UpStar f ) (UpStar g ) d  c )                (Procompose (UpStar f') (UpStar g') d' c')-               (UpStar (Compose f  g ) d  c )-               (UpStar (Compose f' g') d' c')+               (UpStar (Compose g  f ) d  c )+               (UpStar (Compose g' f') d' c') upstars = dimap hither (fmap yon) where-  hither (Procompose (UpStar dfx) (UpStar xgc)) = UpStar (Compose . fmap xgc . dfx)-  yon (UpStar dfgc) = Procompose (UpStar (getCompose . dfgc)) (UpStar id)+  hither (Procompose (UpStar xgc) (UpStar dfx)) = UpStar (Compose . fmap xgc . dfx)+  yon (UpStar dfgc) = Procompose (UpStar id) (UpStar (getCompose . dfgc))  -- | 'Profunctor' composition generalizes 'Functor' composition in two ways. --@@ -163,36 +177,80 @@ -- isomorphic to @g (f a) -> c@. -- -- @'downstars' :: 'Functor' f => Iso' ('Procompose' ('DownStar' f) ('DownStar' g) d c) ('DownStar' ('Compose' g f) d c)@-downstars :: Functor g+downstars :: Functor f           => Iso (Procompose (DownStar f ) (DownStar g ) d  c )                  (Procompose (DownStar f') (DownStar g') d' c')-                 (DownStar (Compose g  f ) d  c )-                 (DownStar (Compose g' f') d' c')+                 (DownStar (Compose f  g ) d  c )+                 (DownStar (Compose f' g') d' c') downstars = dimap hither (fmap yon) where-  hither (Procompose (DownStar fdx) (DownStar gxc)) = DownStar (gxc . fmap fdx . getCompose)-  yon (DownStar dgfc) = Procompose (DownStar id) (DownStar (dgfc . Compose))+  hither (Procompose (DownStar gxc) (DownStar fdx)) = DownStar (gxc . fmap fdx . getCompose)+  yon (DownStar dgfc) = Procompose (DownStar (dgfc . Compose)) (DownStar id)  -- | This is a variant on 'upstars' that uses 'Kleisli' instead of 'UpStar'. -- -- @'kleislis' :: 'Monad' f => Iso' ('Procompose' ('Kleisli' f) ('Kleisli' g) d c) ('Kleisli' ('Compose' f g) d c)@-kleislis :: Monad f+kleislis :: Monad g         => Iso (Procompose (Kleisli f ) (Kleisli g ) d  c )                (Procompose (Kleisli f') (Kleisli g') d' c')-               (Kleisli (Compose f  g ) d  c )-               (Kleisli (Compose f' g') d' c')+               (Kleisli (Compose g  f ) d  c )+               (Kleisli (Compose g' f') d' c') kleislis = dimap hither (fmap yon) where-  hither (Procompose (Kleisli dfx) (Kleisli xgc)) = Kleisli (Compose . liftM xgc . dfx)-  yon (Kleisli dfgc) = Procompose (Kleisli (getCompose . dfgc)) (Kleisli id)+  hither (Procompose (Kleisli xgc) (Kleisli dfx)) = Kleisli (Compose . liftM xgc . dfx)+  yon (Kleisli dfgc) = Procompose (Kleisli id) (Kleisli (getCompose . dfgc))  -- | This is a variant on 'downstars' that uses 'Cokleisli' instead -- of 'DownStar'. -- -- @'cokleislis' :: 'Functor' f => Iso' ('Procompose' ('Cokleisli' f) ('Cokleisli' g) d c) ('Cokleisli' ('Compose' g f) d c)@-cokleislis :: Functor g+cokleislis :: Functor f           => Iso (Procompose (Cokleisli f ) (Cokleisli g ) d  c )                  (Procompose (Cokleisli f') (Cokleisli g') d' c')-                 (Cokleisli (Compose g  f ) d  c )-                 (Cokleisli (Compose g' f') d' c')+                 (Cokleisli (Compose f  g ) d  c )+                 (Cokleisli (Compose f' g') d' c') cokleislis = dimap hither (fmap yon) where-  hither (Procompose (Cokleisli fdx) (Cokleisli gxc)) = Cokleisli (gxc . fmap fdx . getCompose)-  yon (Cokleisli dgfc) = Procompose (Cokleisli id) (Cokleisli (dgfc . Compose))+  hither (Procompose (Cokleisli gxc) (Cokleisli fdx)) = Cokleisli (gxc . fmap fdx . getCompose)+  yon (Cokleisli dgfc) = Procompose (Cokleisli (dgfc . Compose)) (Cokleisli id)++----------------------------------------------------------------------------+-- * 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 }++instance Category p => ProfunctorComonad (Rift p) where+  proextract (Rift f) = f id+  produplicate (Rift f) = Rift $ \p -> Rift $ \q -> f (q . p)++instance (Profunctor p, Profunctor q) => Profunctor (Rift p q) where+  dimap ca bd f = Rift (lmap ca . runRift f . lmap bd)+  {-# INLINE dimap #-}+  lmap ca f = Rift (lmap ca . runRift f)+  {-# INLINE lmap #-}+  rmap bd f = Rift (runRift f . lmap bd)+  {-# INLINE rmap #-}+  bd #. f = Rift (\p -> runRift f (p .# bd))+  {-# INLINE ( #. ) #-}+  f .# ca = Rift (\p -> runRift f p .# ca)+  {-# INLINE (.#) #-}++instance Profunctor p => Functor (Rift p q a) where+  fmap bd f = Rift (runRift f . lmap bd)+  {-# INLINE fmap #-}++-- | @'Rift' p p@ forms a 'Monad' in the 'Profunctor' 2-category, which is isomorphic to a Haskell 'Category' instance.+instance p ~ q => Category (Rift p q) where+  id = Rift id+  {-# INLINE id #-}+  Rift f . Rift g = Rift (g . f)+  {-# INLINE (.) #-}++-- | The 2-morphism that defines a left Kan lift.+--+-- Note: When @p@ is right adjoint to @'Rift' p (->)@ then 'decomposeRift' is the 'counit' of the adjunction.+decomposeRift :: Procompose p (Rift p q) -/-> q+decomposeRift (Procompose p (Rift pq)) = pq p+{-# INLINE decomposeRift #-}++instance Procompose p -| Rift p where+  counit (Procompose p (Rift pq)) = pq p+  unit q = Rift $ \p -> Procompose p q
− src/Data/Profunctor/Lift.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# 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.Lift-  ( Lift(..)-  , decomposeLift-  ) where--import Control.Category-import Data.Profunctor.Unsafe-import Data.Profunctor.Composition-import Prelude hiding (id,(.))---- | This represents the left 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 Lift p q a b = Lift { runLift :: forall x. p b x -> q a x }---instance (Profunctor p, Profunctor q) => Profunctor (Lift p q) where-  dimap ca bd f = Lift (lmap ca . runLift f . lmap bd)-  {-# INLINE dimap #-}-  lmap ca f = Lift (lmap ca . runLift f)-  {-# INLINE lmap #-}-  rmap bd f = Lift (runLift f . lmap bd)-  {-# INLINE rmap #-}-  bd #. f = Lift (\p -> runLift f (p .# bd))-  {-# INLINE ( #. ) #-}-  f .# ca = Lift (\p -> runLift f p .# ca)-  {-# INLINE (.#) #-}--instance Profunctor p => Functor (Lift p q a) where-  fmap bd f = Lift (runLift f . lmap bd)-  {-# INLINE fmap #-}---- | @'Lift' p p@ forms a 'Monad' in the 'Profunctor' 2-category, which is isomorphic to a Haskell 'Category' instance.-instance p ~ q => Category (Lift p q) where-  id = Lift id-  {-# INLINE id #-}-  Lift f . Lift g = Lift (g . f)-  {-# INLINE (.) #-}---- | The 2-morphism that defines a left Kan lift.------ Note: When @p@ is right adjoint to @'Lift' p (->)@ then 'decomposeLift' is the 'counit' of the adjunction.-decomposeLift :: Procompose (Lift p q) p a b -> q a b-decomposeLift (Procompose (Lift pq) p) = pq p-{-# INLINE decomposeLift #-}
+ src/Data/Profunctor/Monad.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+module Data.Profunctor.Monad where++import Data.Profunctor++class ProfunctorMonad t where+  proreturn :: Profunctor p => p -/-> t p+  projoin   :: Profunctor p => t (t p) -/-> t p++class ProfunctorComonad t where+  proextract :: Profunctor p => t p -/-> p+  produplicate :: Profunctor p => t p -/-> t (t p)
+ src/Data/Profunctor/Ran.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2013-2014 Edward Kmett and Dan Doel+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  Rank2Types, TFs+--+----------------------------------------------------------------------------+module Data.Profunctor.Ran+  ( Ran(..)+  , decomposeRan+  , precomposeRan+  , curryRan+  , uncurryRan+  ) where++import Control.Category+import Data.Profunctor+import Data.Profunctor.Composition+import Data.Profunctor.Monad+import Data.Profunctor.Unsafe+import Prelude hiding (id,(.))++-- | 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 }++instance Category p => ProfunctorComonad (Ran p) where+  proextract (Ran f) = f id+  produplicate (Ran f) = Ran $ \ p -> Ran $ \q -> f (p . q)++instance (Profunctor p, Profunctor q) => Profunctor (Ran p q) where+  dimap ca bd f = Ran (rmap bd . runRan f . rmap ca)+  {-# INLINE dimap #-}+  lmap ca f = Ran (runRan f . rmap ca)+  {-# INLINE lmap #-}+  rmap bd f = Ran (rmap bd . runRan f)+  {-# INLINE rmap #-}+  bd #. f = Ran (\p -> bd #. runRan f p)+  {-# INLINE ( #. ) #-}+  f .# ca = Ran (\p -> runRan f (ca #. p))+  {-# INLINE (.#) #-}++instance Profunctor q => Functor (Ran p q a) where+  fmap bd f = Ran (rmap bd . runRan f)+  {-# INLINE fmap #-}++-- | @'Ran' p p@ forms a 'Monad' in the 'Profunctor' 2-category, which is isomorphic to a Haskell 'Category' instance.+instance p ~ q => Category (Ran p q) where+  id = Ran id+  {-# INLINE id #-}+  Ran f . Ran g = Ran (f . g)+  {-# INLINE (.) #-}++-- | The 2-morphism that defines a right Kan extension.+--+-- Note: When @q@ is left adjoint to @'Ran' q (->)@ then 'decomposeRan' is the 'counit' of the adjunction.+decomposeRan :: Procompose (Ran q p) q -/-> p+decomposeRan (Procompose (Ran qp) q) = qp q+{-# INLINE decomposeRan #-}++precomposeRan :: Profunctor q => Procompose q (Ran p (->)) -/-> Ran p q+precomposeRan (Procompose p pf) = Ran (\pxa -> runRan pf pxa `lmap` p)+{-# INLINE precomposeRan #-}++curryRan :: (Procompose p q -/-> r) -> p -/-> Ran q r+curryRan f p = Ran $ \q -> f (Procompose p q)+{-# INLINE curryRan #-}++uncurryRan :: (p -/-> Ran q r) -> Procompose p q -/-> r+uncurryRan f (Procompose p q) = runRan (f p) q+{-# INLINE uncurryRan #-}
src/Data/Profunctor/Rep.hs view
@@ -115,7 +115,7 @@ -- -- This can be used with the combinators from the @lens@ package. ----- @'tabulated' :: 'Corep' f p => 'Iso'' (f d -> c) (p d c)@+-- @'cotabulated' :: 'Corep' f p => 'Iso'' (f d -> c) (p d c)@ cotabulated :: (Corepresentable p, Corepresentable q) => Iso (Corep p d -> c) (Corep q d' -> c') (p d c) (q d' c') cotabulated = dimap cotabulate (fmap corep) {-# INLINE cotabulated #-}
− src/Data/Profunctor/Rift.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Copyright   :  (C) 2013 Edward Kmett and Dan Doel--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Edward Kmett <ekmett@gmail.com>--- Stability   :  provisional--- Portability :  Rank2Types, TFs---------------------------------------------------------------------------------module Data.Profunctor.Rift-  ( Rift(..)-  , decomposeRift-  , precomposeRift-  ) where--import Control.Category-import Data.Profunctor.Unsafe-import Data.Profunctor.Composition-import Prelude hiding (id,(.))---- | 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 x a -> q x b }----  Ran f g a = forall b. (a -> f b) -> g b--instance (Profunctor p, Profunctor q) => Profunctor (Rift p q) where-  dimap ca bd f = Rift (rmap bd . runRift f . rmap ca)-  {-# INLINE dimap #-}-  lmap ca f = Rift (runRift f . rmap ca)-  {-# INLINE lmap #-}-  rmap bd f = Rift (rmap bd . runRift f)-  {-# INLINE rmap #-}-  bd #. f = Rift (\p -> bd #. runRift f p)-  {-# INLINE ( #. ) #-}-  f .# ca = Rift (\p -> runRift f (ca #. p))-  {-# INLINE (.#) #-}--instance Profunctor q => Functor (Rift p q a) where-  fmap bd f = Rift (rmap bd . runRift f)-  {-# INLINE fmap #-}---- | @'Rift' p p@ forms a 'Monad' in the 'Profunctor' 2-category, which is isomorphic to a Haskell 'Category' instance.-instance p ~ q => Category (Rift p q) where-  id = Rift id-  {-# INLINE id #-}-  Rift f . Rift g = Rift (f . g)-  {-# INLINE (.) #-}---- | The 2-morphism that defines a right Kan lift.------ Note: When @q@ is left adjoint to @'Rift' q (->)@ then 'decomposeRift' is the 'counit' of the adjunction.-decomposeRift :: Procompose q (Rift q p) a b -> p a b-decomposeRift (Procompose q (Rift qp)) = qp q-{-# INLINE decomposeRift #-}--precomposeRift :: Profunctor q => Procompose (Rift p (->)) q a b -> Rift p q a b-precomposeRift (Procompose pf p) = Rift (\pxa -> runRift pf pxa `lmap` p)-{-# INLINE precomposeRift #-}
+ src/Data/Profunctor/Tambara.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# 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 ProfunctorComonad Tambara where+  proextract (Tambara p) = dimap (\a -> (a,())) fst p+  produplicate (Tambara p) = Tambara (Tambara $ dimap hither yon p) where+    hither ~(~(x,y),z) = (x,(y,z))+    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 (Left y, s) = Left (y, s)+    hither (Right z, s) = Right (z, s)+    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 ~(~(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 (Left y, s) = Left (y, s)+    hither (Right z, s) = Right (z, s)+    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 ~(~(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+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 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 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+newtype Cotambara p a b = Cotambara { runCotambara :: forall c. p (Either a c) (Either b c) }++instance ProfunctorComonad Cotambara where+  proextract (Cotambara p)   = dimap Left (\(Left a) -> a) p+  produplicate (Cotambara p) = Cotambara (Cotambara $ dimap hither yon p) where+    hither (Left (Left x))   = Left x+    hither (Left (Right y))  = Right (Left y)+    hither (Right z)         = Right (Right z)+    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 Copastro -| Cotambara where+  counit (Copastro f (Cotambara g) h) = dimap h f g+  unit p = Cotambara $ Copastro id p id++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