profunctors 5.2 → 5.2.1
raw patch · 18 files changed
+631/−31 lines, 18 filesnew-uploader
Files
- .gitignore +1/−0
- .travis.yml +80/−19
- CHANGELOG.markdown +13/−1
- profunctors.cabal +4/−3
- src/Data/Profunctor.hs +1/−1
- src/Data/Profunctor/Adjunction.hs +6/−0
- src/Data/Profunctor/Cayley.hs +38/−0
- src/Data/Profunctor/Choice.hs +72/−0
- src/Data/Profunctor/Closed.hs +7/−0
- src/Data/Profunctor/Composition.hs +12/−0
- src/Data/Profunctor/Mapping.hs +7/−0
- src/Data/Profunctor/Monad.hs +22/−0
- src/Data/Profunctor/Rep.hs +12/−0
- src/Data/Profunctor/Strong.hs +64/−5
- src/Data/Profunctor/Traversing.hs +34/−1
- src/Data/Profunctor/Types.hs +5/−1
- src/Data/Profunctor/Unsafe.hs +2/−0
- src/Data/Profunctor/Yoneda.hs +251/−0
.gitignore view
@@ -12,3 +12,4 @@ *.hi *~ *#+:w
.travis.yml view
@@ -1,32 +1,91 @@-# NB: don't set `language: haskell` here+# This file has been generated -- see https://github.com/hvr/multi-ghc-travis+language: c+sudo: false -# See also https://github.com/hvr/multi-ghc-travis for more information-env:- - 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=8.0.1 CABALVER=1.24- - GHCVER=head CABALVER=1.24+cache:+ directories:+ - $HOME/.cabsnap+ - $HOME/.cabal/packages +before_cache:+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar+ matrix:+ include:+ - env: CABALVER=1.18 GHCVER=7.0.4+ compiler: ": #GHC 7.0.4"+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.0.4,hlint], sources: [hvr-ghc]}}+ - env: CABALVER=1.18 GHCVER=7.2.2+ compiler: ": #GHC 7.2.2"+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.2.2,hlint], sources: [hvr-ghc]}}+ - env: CABALVER=1.18 GHCVER=7.4.2+ compiler: ": #GHC 7.4.2"+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2,hlint], sources: [hvr-ghc]}}+ - env: CABALVER=1.18 GHCVER=7.6.3+ compiler: ": #GHC 7.6.3"+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3,hlint], sources: [hvr-ghc]}}+ - env: CABALVER=1.18 GHCVER=7.8.4+ compiler: ": #GHC 7.8.4"+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,hlint], sources: [hvr-ghc]}}+ - env: CABALVER=1.22 GHCVER=7.10.3+ compiler: ": #GHC 7.10.3"+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,hlint], sources: [hvr-ghc]}}+ - env: CABALVER=1.24 GHCVER=8.0.2+ compiler: ": #GHC 8.0.2"+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,hlint], sources: [hvr-ghc]}}+ - env: CABALVER=2.0 GHCVER=8.2.1+ compiler: ": #GHC 8.2.1"+ addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,hlint], sources: [hvr-ghc]}}+ - env: CABALVER=head GHCVER=head+ compiler: ": #GHC head"+ addons: {apt: {packages: [cabal-install-head,ghc-head,hlint], sources: [hvr-ghc]}}+ allow_failures:- - env: GHCVER=head CABALVER=1.24+ - env: CABALVER=1.18 GHCVER=7.0.4+ - env: CABALVER=1.18 GHCVER=7.2.2+ - env: CABALVER=head GHCVER=head -# Note: the distinction between `before_install` and `install` is not-# important. before_install:- - travis_retry sudo add-apt-repository -y ppa:hvr/ghc- - travis_retry sudo apt-get update- - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER+ - unset CC - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH- - cabal --version install:- - travis_retry cabal update- - cabal install --only-dependencies- - travis_retry sudo apt-get -q -y install hlint || cabal install hlint+ - cabal --version+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];+ then+ zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;+ fi+ - travis_retry cabal update -v+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config+ - cabal install --only-dependencies --enable-tests --dry -v > installplan.txt+ - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt +# check whether current requested install-plan matches cached package-db snapshot+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;+ then+ echo "cabal build-cache HIT";+ rm -rfv .ghc;+ cp -a $HOME/.cabsnap/ghc $HOME/.ghc;+ cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;+ else+ echo "cabal build-cache MISS";+ rm -rf $HOME/.cabsnap;+ mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;+ cabal install -j --only-dependencies --enable-tests;+ fi++# snapshot package-db on cache miss+ - if [ ! -d $HOME/.cabsnap ];+ then+ echo "snapshotting package-db to build-cache";+ mkdir $HOME/.cabsnap;+ cp -a $HOME/.ghc $HOME/.cabsnap/ghc;+ cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;+ fi+ # Here starts the actual work to be performed for the package under # test; any command which exits with a non-zero exit code causes the # build to fail.@@ -59,3 +118,5 @@ skip_join: true template: - "\x0313profunctors\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"++# EOF
CHANGELOG.markdown view
@@ -1,3 +1,15 @@+5.2.1+-----+* Allow `base-orphans-0.6`.+* Add `Traversing` instance for `Forget`+* Add `Traversing` and `Mapping` instances for `Procompose`+* Add `Category` instance for `Star`+* Add `mapCayley` to `Data.Profunctor.Cayley`+* Add `pastro` and `unpastro` to `Data.Profunctor.Strong`.+* Add `dimapWandering`, `lmapWandering`, and `rmapWandering` to `Data.Profunctor.Traversing`+* Add documentation stating the laws for various profunctors.+* Introduce the `Data.Profunctor.Yoneda` module.+ 5.2 --- * Renamed `Cotambara` to `TambaraChoice` and `Pastro` to `PastroChoice`.@@ -31,7 +43,7 @@ - * `UpStar` and `DownStar` have become `Star` and `Costar`. `Star` is analogous to `Kleisli`, `Costar` is analogous to `Cokleisli`. * Split representability into sieves and representability.-* Moved `Data.Profunctor.Collage` to `semigroupoids` 5, and removed the `semigroupoids` dependency. +* Moved `Data.Profunctor.Collage` to `semigroupoids` 5, and removed the `semigroupoids` dependency. * Rather greatly widened the range of GHC versions we can support. 4.4.1
profunctors.cabal view
@@ -1,6 +1,6 @@ name: profunctors category: Control, Categories-version: 5.2+version: 5.2.1 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -12,7 +12,7 @@ copyright: Copyright (C) 2011-2015 Edward A. Kmett synopsis: Profunctors description: Profunctors-tested-with: GHC==7.0.1, GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1+tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 build-type: Simple extra-source-files: .ghci@@ -30,7 +30,7 @@ library build-depends: base >= 4 && < 5,- base-orphans >= 0.4 && < 0.6,+ base-orphans >= 0.4 && < 0.7, bifunctors >= 5.2 && < 6, comonad >= 4 && < 6, contravariant >= 1 && < 2,@@ -54,6 +54,7 @@ Data.Profunctor.Traversing Data.Profunctor.Types Data.Profunctor.Unsafe+ Data.Profunctor.Yoneda ghc-options: -Wall -O2 hs-source-dirs: src
src/Data/Profunctor.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} #endif -----------------------------------------------------------------------------
src/Data/Profunctor/Adjunction.hs view
@@ -17,6 +17,12 @@ import Data.Profunctor.Types import Data.Profunctor.Monad +-- | Laws:+--+-- @+-- 'unit' '.' 'counit' ≡ 'id'+-- 'counit' '.' 'unit' ≡ 'id'+-- @ class (ProfunctorFunctor f, ProfunctorFunctor u) => ProfunctorAdjunction 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
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #endif@@ -81,5 +82,42 @@ instance (Applicative f, ArrowPlus p) => ArrowPlus (Cayley f p) where Cayley f <+> Cayley g = Cayley (liftA2 (<+>) f g) +mapCayley :: (forall a. f a -> g a) -> Cayley f p x y -> Cayley g p x y+mapCayley f (Cayley g) = Cayley (f g)+ -- instance Adjunction f g => ProfunctorAdjunction (Cayley f) (Cayley g) where +{-+newtype Uncayley p a = Uncayley (p () a)++instance Profunctor p => Functor (Uncayley p) where+ fmap f (Uncayley p) = Uncayley (rmap f p)++smash :: Strong p => Cayley (Uncayley p) (->) a b -> p a b+smash (Cayley (Uncayley pab)) = dimap ((,)()) (uncurry id) (first' pab)++unsmash :: Closed p => p a b -> Cayley (Uncayley p) (->) a b+unsmash = Cayley . Uncayley . curry' . lmap snd++type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)++-- pastro and street's strong tambara module+class (Strong p, Closed p) => Stronger p++-- only a true iso for Stronger p and q, no?+_Smash :: (Strong p, Closed q) => Iso+ (Cayley (Uncayley p) (->) a b)+ (Cayley (Uncayley q) (->) c d) + (p a b)+ (q c d)+_Smash = dimap hither (fmap yon) where+ hither (Cayley (Uncayley pab)) = dimap ((,)()) (uncurry id) (first' pab)+ yon = Cayley . Uncayley . curry' . lmap snd++fsmash :: (forall x y. p x y -> q x y) -> Cayley (Uncayley p) (->) a b -> Cayley (Uncayley q) (->) a b+fsmash f (Cayley (Uncayley puab)) = Cayley (Uncayley (f puab))++-- | proposition 4.3 from pastro and street is that fsmash and funsmash form an equivalence of categories+funsmash :: (Closed p, Strong q) => (forall x y. Cayley (Uncayley p) (->) x y -> Cayley (Uncayley q) (->) x y) -> p a b -> q a b+funsmash k = smash . k . unsmash+-}
src/Data/Profunctor/Choice.hs view
@@ -61,9 +61,45 @@ -- 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+ -- | Laws:+ --+ -- @+ -- 'left'' ≡ 'dimap' swapE swapE '.' 'right'' where+ -- swapE :: 'Either' a b -> 'Either' b a+ -- swapE = 'either' 'Right' 'Left'+ -- 'rmap' 'Left' ≡ 'lmap' 'Left' '.' 'left''+ -- 'lmap' ('right' f) '.' 'left'' ≡ 'rmap' ('right' f) '.' 'left''+ -- 'left'' '.' 'left'' ≡ 'dimap' assocE unassocE '.' 'left'' where+ -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c)+ -- assocE ('Left' ('Left' a)) = 'Left' a+ -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b)+ -- assocE ('Right' c) = 'Right' ('Right' c)+ -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c+ -- unassocE ('Left' a) = 'Left' ('Left' a)+ -- unassocE ('Right' ('Left' b) = 'Left' ('Right' b)+ -- unassocE ('Right' ('Right' c)) = 'Right' c)+ -- @ left' :: p a b -> p (Either a c) (Either b c) left' = dimap (either Right Left) (either Right Left) . right' + -- | Laws:+ --+ -- @+ -- 'right'' ≡ 'dimap' swapE swapE '.' 'left'' where+ -- swapE :: 'Either' a b -> 'Either' b a+ -- swapE = 'either' 'Right' 'Left'+ -- 'rmap' 'Right' ≡ 'lmap' 'Right' '.' 'right''+ -- 'lmap' ('left' f) '.' 'right'' ≡ 'rmap' ('left' f) '.' 'right''+ -- 'right'' '.' 'right'' ≡ 'dimap' unassocE assocE '.' 'right'' where+ -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c)+ -- assocE ('Left' ('Left' a)) = 'Left' a+ -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b)+ -- assocE ('Right' c) = 'Right' ('Right' c)+ -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c+ -- unassocE ('Left' a) = 'Left' ('Left' a)+ -- unassocE ('Right' ('Left' b) = 'Left' ('Right' b)+ -- unassocE ('Right' ('Right' c)) = 'Right' c)+ -- @ right' :: p a b -> p (Either c a) (Either c b) right' = dimap (either Right Left) (either Right Left) . left' @@ -258,9 +294,45 @@ -------------------------------------------------------------------------------- class Profunctor p => Cochoice p where+ -- | Laws:+ --+ -- @+ -- 'unleft' ≡ 'unright' '.' 'dimap' swapE swapE where+ -- swapE :: 'Either' a b -> 'Either' b a+ -- swapE = 'either' 'Right' 'Left'+ -- 'rmap' ('either' 'id' 'absurd') ≡ 'unleft' '.' 'lmap' ('either' 'id' 'absurd')+ -- 'unfirst' '.' 'rmap' ('second' f) ≡ 'unfirst' '.' 'lmap' ('second' f)+ -- 'unleft' '.' 'unleft' ≡ 'unleft' '.' 'dimap' assocE unassocE where+ -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c)+ -- assocE ('Left' ('Left' a)) = 'Left' a+ -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b)+ -- assocE ('Right' c) = 'Right' ('Right' c)+ -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c+ -- unassocE ('Left' a) = 'Left' ('Left' a)+ -- unassocE ('Right' ('Left' b) = 'Left' ('Right' b)+ -- unassocE ('Right' ('Right' c)) = 'Right' c)+ -- @ unleft :: p (Either a d) (Either b d) -> p a b unleft = unright . dimap (either Right Left) (either Right Left) + -- | Laws:+ --+ -- @+ -- 'unright' ≡ 'unleft' '.' 'dimap' swapE swapE where+ -- swapE :: 'Either' a b -> 'Either' b a+ -- swapE = 'either' 'Right' 'Left'+ -- 'rmap' ('either' 'absurd' 'id') ≡ 'unright' '.' 'lmap' ('either' 'absurd' 'id')+ -- 'unsecond' '.' 'rmap' ('first' f) ≡ 'unsecond' '.' 'lmap' ('first' f)+ -- 'unright' '.' 'unright' ≡ 'unright' '.' 'dimap' unassocE assocE where+ -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c)+ -- assocE ('Left' ('Left' a)) = 'Left' a+ -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b)+ -- assocE ('Right' c) = 'Right' ('Right' c)+ -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c+ -- unassocE ('Left' a) = 'Left' ('Left' a)+ -- unassocE ('Right' ('Left' b) = 'Left' ('Right' b)+ -- unassocE ('Right' ('Right' c)) = 'Right' c)+ -- @ unright :: p (Either d a) (Either d b) -> p a b unright = unleft . dimap (either Right Left) (either Right Left)
src/Data/Profunctor/Closed.hs view
@@ -52,6 +52,13 @@ -- -- A closed profunctor allows the closed structure to pass through. class Profunctor p => Closed p where+ -- | Laws:+ --+ -- @+ -- 'lmap' ('.' f) '.' 'closed' ≡ 'rmap' ('.' f) '.' 'closed'+ -- 'closed' '.' 'closed' ≡ 'dimap' 'uncurry' 'curry' '.' 'closed'+ -- 'dimap' 'const' ('$'()) '.' 'closed' ≡ 'id'+ -- @ closed :: p a b -> p (x -> a) (x -> b) instance Closed Tagged where
src/Data/Profunctor/Composition.hs view
@@ -46,9 +46,11 @@ import Data.Functor.Compose import Data.Profunctor import Data.Profunctor.Adjunction+import Data.Profunctor.Mapping import Data.Profunctor.Monad import Data.Profunctor.Rep import Data.Profunctor.Sieve+import Data.Profunctor.Traversing import Data.Profunctor.Unsafe import Prelude hiding ((.),id) @@ -129,9 +131,19 @@ closed (Procompose x y) = Procompose (closed x) (closed y) {-# INLINE closed #-} +instance (Traversing p, Traversing q) => Traversing (Procompose p q) where+ traverse' (Procompose p q) = Procompose (traverse' p) (traverse' q)+ {-# INLINE traverse' #-}++instance (Mapping p, Mapping q) => Mapping (Procompose p q) where+ map' (Procompose p q) = Procompose (map' p) (map' q)+ {-# INLINE map' #-}+ instance (Corepresentable p, Corepresentable q) => Costrong (Procompose p q) where unfirst = unfirstCorep+ {-# INLINE unfirst #-} unsecond = unsecondCorep+ {-# INLINE unsecond #-} -- * Lax identity
src/Data/Profunctor/Mapping.hs view
@@ -26,6 +26,13 @@ #endif class (Traversing p, Closed p) => Mapping p where+ -- | Laws:+ --+ -- @+ -- 'map'' '.' 'rmap' f ≡ 'rmap' ('fmap' f) '.' 'map''+ -- 'map'' '.' 'map'' ≡ 'dimap' 'Data.Functor.Compose.Compose' 'Data.Functor.Compose.getCompose' '.' 'map''+ -- 'dimap' 'Data.Functor.Identity.Identity' 'Data.Functor.Identity.runIdentity' '.' 'map'' ≡ 'id'+ -- @ map' :: Functor f => p a b -> p (f a) (f b) instance Mapping (->) where
src/Data/Profunctor/Monad.hs view
@@ -20,6 +20,12 @@ import Data.Profunctor.Types class ProfunctorFunctor t where+ -- | Laws:+ --+ -- @+ -- 'promap' f '.' 'promap' g ≡ 'promap' (f '.' g)+ -- 'promap' 'id' ≡ 'id'+ -- @ promap :: Profunctor p => (p :-> q) -> t p :-> t q instance Functor f => ProfunctorFunctor (Tannen f) where@@ -32,6 +38,14 @@ promap _ (L2 p) = L2 p promap f (R2 q) = R2 (f q) +-- | Laws:+--+-- @+-- 'promap' f '.' 'proreturn' ≡ 'proreturn' '.' f+-- 'projoin' '.' 'proreturn' ≡ 'id'+-- 'projoin' '.' 'promap' 'proreturn' ≡ 'id'+-- 'projoin' '.' 'projoin' ≡ 'projoin' '.' 'promap' 'projoin'+-- @ class ProfunctorFunctor t => ProfunctorMonad t where proreturn :: Profunctor p => p :-> t p projoin :: Profunctor p => t (t p) :-> t p@@ -49,6 +63,14 @@ projoin (L2 p) = L2 p projoin (R2 m) = m +-- | Laws:+--+-- @+-- 'proextract' '.' 'promap' f ≡ f '.' 'proextract'+-- 'proextract' '.' 'produplicate' ≡ 'id'+-- 'promap' 'proextract' '.' 'produplicate' ≡ 'id'+-- 'produplicate' '.' 'produplicate' ≡ 'promap' 'produplicate' '.' 'produplicate'+-- @ class ProfunctorFunctor t => ProfunctorComonad t where proextract :: Profunctor p => t p :-> p produplicate :: Profunctor p => t p :-> t (t p)
src/Data/Profunctor/Rep.hs view
@@ -60,6 +60,12 @@ -- @p d c@ is isomorphic to @d -> f c@. class (Sieve p (Rep p), Strong p) => Representable p where type Rep p :: * -> *+ -- | Laws:+ --+ -- @+ -- 'tabulate' '.' 'sieve' ≡ 'id'+ -- 'sieve' '.' 'tabulate' ≡ 'id'+ -- @ tabulate :: (d -> Rep p c) -> p d c -- | Default definition for 'first'' given that p is 'Representable'.@@ -115,6 +121,12 @@ -- @p d c@ is isomorphic to @f d -> c@. class (Cosieve p (Corep p), Costrong p) => Corepresentable p where type Corep p :: * -> *+ -- | Laws:+ --+ -- @+ -- 'cotabulate' '.' 'cosieve' ≡ 'id'+ -- 'cosieve' '.' 'cotabulate' ≡ 'id'+ -- @ cotabulate :: (Corep p d -> c) -> p d c -- | Default definition for 'unfirst' given that @p@ is 'Corepresentable'.
src/Data/Profunctor/Strong.hs view
@@ -26,6 +26,7 @@ , Tambara(..) , tambara, untambara , Pastro(..)+ , pastro, unpastro -- * Costrength , Costrong(..) , Cotambara(..)@@ -64,14 +65,35 @@ -- of Hask. -- -- <http://www-kb.is.s.u-tokyo.ac.jp/~asada/papers/arrStrMnd.pdf>+-- class Profunctor p => Strong p where+ -- | Laws:+ --+ -- @+ -- 'first'' ≡ 'dimap' 'swap' 'swap' '.' 'second''+ -- 'lmap' 'fst' ≡ 'rmap' 'fst' '.' 'first''+ -- 'lmap' ('second' f) '.' 'first'' ≡ 'rmap' ('second' f) '.' 'first'+ -- 'first'' '.' 'first'' ≡ 'dimap' assoc unassoc '.' 'first'' where+ -- assoc ((a,b),c) = (a,(b,c))+ -- unassoc (a,(b,c)) = ((a,b),c)+ -- @ first' :: p a b -> p (a, c) (b, c) first' = dimap swap swap . second' + -- | Laws:+ --+ -- @+ -- 'second'' ≡ 'dimap' 'swap' 'swap' '.' 'first''+ -- 'lmap' 'snd' ≡ 'rmap' 'snd' '.' 'second''+ -- 'lmap' ('first' f) '.' 'second'' ≡ 'rmap' ('first' f) '.' 'second''+ -- 'second'' '.' 'second'' ≡ 'dimap' unassoc assoc '.' 'second'' where+ -- assoc ((a,b),c) = (a,(b,c))+ -- unassoc (a,(b,c)) = ((a,b),c)+ -- @ second' :: p a b -> p (c, a) (c, b) second' = dimap swap swap . first' -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708+#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL first' | second' #-} #endif @@ -83,6 +105,7 @@ first' ab ~(a, c) = (ab a, c) {-# INLINE first' #-} second' ab ~(c, a) = (c, ab a)+ {-# INLINE second' #-} instance Monad m => Strong (Kleisli m) where first' (Kleisli f) = Kleisli $ \ ~(a, c) -> do@@ -209,16 +232,16 @@ -- | -- @--- 'tambara' '.' 'untambara' ≡ 'id'--- 'untambara' '.' 'tambara' ≡ 'id'+-- 'tambara' ('untambara' f) ≡ f+-- 'untambara' ('tambara' f) ≡ f -- @ tambara :: Strong p => (p :-> q) -> p :-> Tambara q tambara f p = Tambara $ f $ first' p -- | -- @--- 'tambara' '.' 'untambara' ≡ 'id'--- 'untambara' '.' 'tambara' ≡ 'id'+-- 'tambara' ('untambara' f) ≡ f+-- 'untambara' ('tambara' f) ≡ f -- @ untambara :: Profunctor q => (p :-> Tambara q) -> p :-> q untambara f p = dimap (\a -> (a,())) fst $ runTambara $ f p@@ -269,15 +292,51 @@ (x,z) -> (x,(c,z)) l' (y,(c,z)) = (c,l (y,z)) +-- |+-- @+-- 'pastro' ('unpastro' f) ≡ f+-- 'unpastro' ('pastro' f) ≡ f+-- @+pastro :: Strong q => (p :-> q) -> Pastro p :-> q+pastro f (Pastro r g l) = dimap l r (first' (f g))++-- |+-- @+-- 'pastro' ('unpastro' f) ≡ f+-- 'unpastro' ('pastro' f) ≡ f+-- @+unpastro :: (Pastro p :-> q) -> p :-> q+unpastro f p = f (Pastro fst p (\a -> (a, ())))+ -------------------------------------------------------------------------------- -- * Costrength for (,) -------------------------------------------------------------------------------- -- | Analogous to 'ArrowLoop', 'loop' = 'unfirst' class Profunctor p => Costrong p where+ -- | Laws:+ --+ -- @+ -- 'unfirst' ≡ 'unsecond' '.' 'dimap' 'swap' 'swap'+ -- 'lmap' (,()) ≡ 'unfirst' '.' 'rmap' (,())+ -- 'unfirst' '.' 'lmap' ('second' f) ≡ 'unfirst' '.' 'rmap' ('second' f)+ -- 'unfirst' '.' 'unfirst' = 'unfirst' '.' 'dimap' assoc unassoc where+ -- assoc ((a,b),c) = (a,(b,c))+ -- unassoc (a,(b,c)) = ((a,b),c)+ -- @ unfirst :: p (a, d) (b, d) -> p a b unfirst = unsecond . dimap swap swap + -- | Laws:+ --+ -- @+ -- 'unsecond' ≡ 'unfirst' '.' 'dimap' 'swap' 'swap'+ -- 'lmap' ((),) ≡ 'unsecond' '.' 'rmap' ((),)+ -- 'unsecond' '.' 'lmap' ('first' f) ≡ 'unsecond' '.' 'rmap' ('first' f)+ -- 'unsecond' '.' 'unsecond' = 'unsecond' '.' 'dimap' unassoc assoc where+ -- assoc ((a,b),c) = (a,(b,c))+ -- unassoc (a,(b,c)) = ((a,b),c)+ -- @ unsecond :: p (d, a) (d, b) -> p a b unsecond = unfirst . dimap swap swap
src/Data/Profunctor/Traversing.hs view
@@ -6,6 +6,10 @@ ( Traversing(..) , CofreeTraversing(..) , FreeTraversing(..)+ -- * Profunctor in terms of Traversing+ , dimapWandering+ , lmapWandering+ , rmapWandering -- * Strong in terms of Traversing , firstTraversing , secondTraversing@@ -28,6 +32,7 @@ import Data.Tuple (swap) #if __GLASGOW_HASKELL__ < 710+import Data.Monoid (Monoid) import Data.Foldable import Prelude hiding (mapM) #endif@@ -41,6 +46,21 @@ swapE :: Either a b -> Either b a swapE = either Right Left +-- | A definition of 'dimap' for 'Traversing' instances that define+-- an explicit 'wander'.+dimapWandering :: Traversing p => (a' -> a) -> (b -> b') -> p a b -> p a' b'+dimapWandering f g = wander (\afb a' -> g <$> afb (f a'))++-- | 'lmapWandering' may be a more efficient implementation+-- of 'lmap' than the default produced from 'dimapWandering'.+lmapWandering :: Traversing p => (a -> b) -> p b c -> p a c+lmapWandering f = wander (\afb a' -> afb (f a'))++-- | 'rmapWandering' is the same as the default produced from+-- 'dimapWandering'.+rmapWandering :: Traversing p => (b -> c) -> p a b -> p a c+rmapWandering g = wander (\afb a' -> g <$> afb a')+ leftTraversing :: Traversing p => p a b -> p (Either a c) (Either b c) leftTraversing = dimap swapE swapE . traverse' @@ -83,19 +103,32 @@ -- | Note: Definitions in terms of 'wander' are much more efficient! class (Choice p, Strong p) => Traversing p where+ -- | Laws:+ --+ -- @+ -- 'traverse'' ≡ 'wander' 'traverse'+ -- 'traverse'' '.' 'rmap' f ≡ 'rmap' ('fmap' f) '.' 'traverse''+ -- 'traverse'' '.' 'traverse'' ≡ 'dimap' 'Compose' 'getCompose' '.' 'traverse''+ -- 'dimap' 'Identity' 'runIdentity' '.' 'traverse'' ≡ 'id'+ -- @ traverse' :: Traversable f => p a b -> p (f a) (f b) traverse' = wander traverse + -- | This combinator is mutually defined in terms of '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+#if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL wander | traverse' #-} #endif instance Traversing (->) where traverse' = fmap wander f ab = runIdentity #. f (Identity #. ab)++instance Monoid m => Traversing (Forget m) where+ traverse' (Forget h) = Forget (foldMap h)+ wander f (Forget h) = Forget (getConst . f (Const . h)) instance Monad m => Traversing (Kleisli m) where traverse' (Kleisli m) = Kleisli (mapM m)
src/Data/Profunctor/Types.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 708+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif @@ -106,6 +106,10 @@ instance Distributive f => Distributive (Star f a) where distribute fs = Star $ \a -> collect (($ a) .# runStar) fs++instance Monad f => Category (Star f) where+ id = Star return+ Star f . Star g = Star $ \a -> g a >>= f ------------------------------------------------------------------------------ -- Costar
src/Data/Profunctor/Unsafe.hs view
@@ -56,8 +56,10 @@ import Unsafe.Coerce #endif +#ifdef HLINT {-# ANN module "Hlint: ignore Redundant lambda" #-} {-# ANN module "Hlint: ignore Collapse lambdas" #-}+#endif infixr 9 #. infixl 8 .#
+ src/Data/Profunctor/Yoneda.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2017 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : Rank2Types, TFs+--+----------------------------------------------------------------------------+module Data.Profunctor.Yoneda+ ( Yoneda(..), extractYoneda, duplicateYoneda+ , Coyoneda(..), returnCoyoneda, joinCoyoneda+ ) where++import Control.Category+import Data.Profunctor+import Data.Profunctor.Monad+import Data.Profunctor.Traversing+import Data.Profunctor.Unsafe+import Prelude hiding (id,(.))++#if __GLASGOW_HASKELL__ >= 708+import Data.Coerce+#else+import Unsafe.Coerce+#endif++--------------------------------------------------------------------------------+-- * Yoneda+--------------------------------------------------------------------------------++-- | This is the cofree profunctor given a data constructor of kind @* -> * -> *@+newtype Yoneda p a b = Yoneda { runYoneda :: forall x y. (x -> a) -> (b -> y) -> p x y }++-- Yoneda is a comonad on |*| -> Nat(|*|,*), we don't need the profunctor constraint to extract or duplicate+-- |+-- @+-- 'projoin' '.' 'extractYoneda' ≡ 'id'+-- 'extractYoneda' '.' 'projoin' ≡ 'id'+-- 'projoin' ≡ 'extractYoneda'+-- @+extractYoneda :: Yoneda p a b -> p a b+extractYoneda p = runYoneda p id id++-- |+-- @+-- 'projoin' '.' 'duplicateYoneda' ≡ 'id'+-- 'duplicateYoneda' '.' 'projoin' ≡ 'id'+-- 'duplicateYoneda' = 'proreturn'+-- @+duplicateYoneda :: Yoneda p a b -> Yoneda (Yoneda p) a b+duplicateYoneda p = Yoneda $ \l r -> dimap l r p++instance Profunctor (Yoneda p) where+ dimap l r p = Yoneda $ \l' r' -> runYoneda p (l . l') (r' . r)+ {-# INLINE dimap #-}+ lmap l p = Yoneda $ \l' r -> runYoneda p (l . l') r+ {-# INLINE lmap #-}+ rmap r p = Yoneda $ \l r' -> runYoneda p l (r' . r)+ {-# INLINE rmap #-}+#if __GLASGOW_HASKELL__ >= 708+ ( .# ) p _ = coerce p+ {-# INLINE ( .# ) #-}+ ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b+ {-# INLINE ( #. ) #-}+#else+ ( .# ) p _ = unsafeCoerce p+ {-# INLINE ( .# ) #-}+ ( #. ) _ = unsafeCoerce+ {-# INLINE ( #. ) #-}+#endif++instance Functor (Yoneda p a) where+ fmap f p = Yoneda $ \l r -> runYoneda p l (r . f)+ {-# INLINE fmap #-}++instance ProfunctorFunctor Yoneda where+ promap f p = Yoneda $ \l r -> f (runYoneda p l r)+ {-# INLINE promap #-}++instance ProfunctorComonad Yoneda where+ proextract p = runYoneda p id id+ {-# INLINE proextract #-}+ produplicate p = Yoneda $ \l r -> dimap l r p+ {-# INLINE produplicate #-}++instance ProfunctorMonad Yoneda where+ proreturn p = Yoneda $ \l r -> dimap l r p+ {-# INLINE proreturn #-}+ projoin p = runYoneda p id id+ {-# INLINE projoin #-}++instance (Category p, Profunctor p) => Category (Yoneda p) where+ id = Yoneda $ \l r -> dimap l r id+ {-# INLINE id #-}+ p . q = Yoneda $ \ l r -> runYoneda p id r . runYoneda q l id+ {-# INLINE (.) #-}++instance Strong p => Strong (Yoneda p) where+ first' = proreturn . first' . extractYoneda+ {-# INLINE first' #-}+ second' = proreturn . second' . extractYoneda+ {-# INLINE second' #-}++instance Choice p => Choice (Yoneda p) where+ left' = proreturn . left' . extractYoneda+ {-# INLINE left' #-}+ right' = proreturn . right' . extractYoneda+ {-# INLINE right' #-}++instance Costrong p => Costrong (Yoneda p) where+ unfirst = proreturn . unfirst . extractYoneda+ {-# INLINE unfirst #-}+ unsecond = proreturn . unsecond . extractYoneda+ {-# INLINE unsecond #-}++instance Cochoice p => Cochoice (Yoneda p) where+ unleft = proreturn . unleft . extractYoneda+ {-# INLINE unleft #-}+ unright = proreturn . unright . extractYoneda+ {-# INLINE unright #-}++instance Closed p => Closed (Yoneda p) where+ closed = proreturn . closed . extractYoneda+ {-# INLINE closed #-}++instance Mapping p => Mapping (Yoneda p) where+ map' = proreturn . map' . extractYoneda+ {-# INLINE map' #-}++instance Traversing p => Traversing (Yoneda p) where+ traverse' = proreturn . traverse' . extractYoneda+ {-# INLINE traverse' #-}+ wander f = proreturn . wander f . extractYoneda+ {-# INLINE wander #-}++--------------------------------------------------------------------------------+-- * Coyoneda+--------------------------------------------------------------------------------++data Coyoneda p a b where+ Coyoneda :: (a -> x) -> (y -> b) -> p x y -> Coyoneda p a b++-- Coyoneda is a Monad on |*| -> Nat(|*|,*), we don't need the profunctor constraint to extract or duplicate++-- |+-- @+-- 'returnCoyoneda' '.' 'proextract' ≡ 'id'+-- 'proextract' '.' 'returnCoyoneda' ≡ 'id'+-- 'produplicate' ≡ 'returnCoyoneda'+-- @+returnCoyoneda :: p a b -> Coyoneda p a b+returnCoyoneda = Coyoneda id id++-- |+-- @+-- 'joinCoyoneda' '.' 'produplicate' ≡ 'id'+-- 'produplicate' '.' 'joinCoyoneda' ≡ 'id'+-- 'joinCoyoneda' ≡ 'proextract'+-- @+joinCoyoneda :: Coyoneda (Coyoneda p) a b -> Coyoneda p a b+joinCoyoneda (Coyoneda l r p) = dimap l r p++instance Profunctor (Coyoneda p) where+ dimap l r (Coyoneda l' r' p) = Coyoneda (l' . l) (r . r') p+ {-# INLINE dimap #-}+ lmap l (Coyoneda l' r p) = Coyoneda (l' . l) r p+ {-# INLINE lmap #-}+ rmap r (Coyoneda l r' p) = Coyoneda l (r . r') p+ {-# INLINE rmap #-}+#if __GLASGOW_HASKELL__ >= 708+ ( .# ) p _ = coerce p+ {-# INLINE ( .# ) #-}+ ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b+ {-# INLINE ( #. ) #-}+#else+ ( .# ) p _ = unsafeCoerce p+ {-# INLINE ( .# ) #-}+ ( #. ) _ = unsafeCoerce+ {-# INLINE ( #. ) #-}+#endif++instance ProfunctorFunctor Coyoneda where+ promap f (Coyoneda l r p) = Coyoneda l r (f p)+ {-# INLINE promap #-}++instance ProfunctorComonad Coyoneda where+ proextract (Coyoneda l r p) = dimap l r p+ {-# INLINE proextract #-}+ produplicate = Coyoneda id id+ {-# INLINE produplicate #-}++instance ProfunctorMonad Coyoneda where+ proreturn = returnCoyoneda+ {-# INLINE proreturn #-}+ projoin = joinCoyoneda+ {-# INLINE projoin #-}++instance (Category p, Profunctor p) => Category (Coyoneda p) where+ id = Coyoneda id id id+ {-# INLINE id #-}+ Coyoneda lp rp p . Coyoneda lq rq q = Coyoneda lq rp (p . rmap (lp . rq) q)+ {-# INLINE (.) #-}++instance Strong p => Strong (Coyoneda p) where+ first' = returnCoyoneda . first' . proextract+ {-# INLINE first' #-}+ second' = returnCoyoneda . second' . proextract+ {-# INLINE second' #-}++instance Choice p => Choice (Coyoneda p) where+ left' = returnCoyoneda . left' . proextract+ {-# INLINE left' #-}+ right' = returnCoyoneda . right' . proextract+ {-# INLINE right' #-}++instance Costrong p => Costrong (Coyoneda p) where+ unfirst = returnCoyoneda . unfirst . proextract+ {-# INLINE unfirst #-}+ unsecond = returnCoyoneda . unsecond . proextract+ {-# INLINE unsecond #-}++instance Cochoice p => Cochoice (Coyoneda p) where+ unleft = returnCoyoneda . unleft . proextract+ {-# INLINE unleft #-}+ unright = returnCoyoneda . unright . proextract+ {-# INLINE unright #-}++instance Closed p => Closed (Coyoneda p) where+ closed = returnCoyoneda . closed . proextract+ {-# INLINE closed #-}++instance Mapping p => Mapping (Coyoneda p) where+ map' = returnCoyoneda . map' . proextract+ {-# INLINE map' #-}++instance Traversing p => Traversing (Coyoneda p) where+ traverse' = returnCoyoneda . traverse' . proextract+ {-# INLINE traverse' #-}+ wander f = returnCoyoneda . wander f . proextract+ {-# INLINE wander #-}