profunctors-5.1.2/0000755000000000000000000000000012627505135012277 5ustar0000000000000000profunctors-5.1.2/.ghci0000644000000000000000000000012512627505135013210 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h profunctors-5.1.2/.gitignore0000644000000000000000000000011512627505135014264 0ustar0000000000000000dist/ .hsenv/ docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# profunctors-5.1.2/.travis.yml0000644000000000000000000000367712627505135014425 0ustar0000000000000000# NB: don't set `language: haskell` here # 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 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 # 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 - 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 # 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. script: # -v2 provides useful information for debugging - cabal configure -v2 # this builds all libraries and executables # (including tests/benchmarks) - cabal build # tests that a source-distribution can be generated - cabal sdist - hlint src --cpp-define HLINT # check that the generated source-distribution can be built & installed - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; cd dist/; if [ -f "$SRC_TGZ" ]; then cabal install --force-reinstalls "$SRC_TGZ"; else echo "expected '$SRC_TGZ' not found"; exit 1; fi notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313profunctors\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" profunctors-5.1.2/.vim.custom0000644000000000000000000000137712627505135014414 0ustar0000000000000000" Add the following to your .vimrc to automatically load this on startup " if filereadable(".vim.custom") " so .vim.custom " endif function StripTrailingWhitespace() let myline=line(".") let mycolumn = col(".") silent %s/ *$// call cursor(myline, mycolumn) endfunction " enable syntax highlighting syntax on " search for the tags file anywhere between here and / set tags=TAGS;/ " highlight tabs and trailing spaces set listchars=tab:‗‗,trail:‗ set list " f2 runs hasktags map :exec ":!hasktags -x -c --ignore src" " strip trailing whitespace before saving " au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace() " rebuild hasktags after saving au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src" profunctors-5.1.2/CHANGELOG.markdown0000644000000000000000000000611512627505135015335 0ustar00000000000000005.1.2 ----- * Added `Prep` and `Coprep` along with witnesses to the adjunctions `Prep -| Star : [Hask,Hask] -> Prof` and `Coprep -| Costar : [Hask,Hask]^op -> Prof`. 5.1.1 ----- * Add proper support for GHC 7.0+. 5.1 --- * `instance Costrong (Cokleisli f)`. * `instance Cochoice (Star f)`. * Changed the instance for `Cochoice (Costar f)`. 5.0.1 ----- * MINIMAL pragma for `Costrong` and `Cochoice`. * More `Costrong` and `Cochoice` instances. 5.0.0.1 ------- * Documentation fix 5 - * `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. * Rather greatly widened the range of GHC versions we can support. 4.4.1 ------- * Using `SafeHaskell`, GHC 7.8+ `Data.Profunctor.Unsafe` now infers as `Trustworthy` and many more modules now infer as `Safe`. * We now build warning-free on GHC 7.10.0.20150307 4.4 ----- * Added `Coercible` constraint to (#.) and (.#) when building with GHC 7.8 * `Strong` is now a superclass of `Representable` * Updated the URL of the "Arrows are Strong Monads" paper. The old URL is now a dead link. 4.3.2 ----- * Added some missing instances for `UpStar` and `DownStar`. 4.3 --- * Removed the non law-abiding instance for `Closed (Forget r)` * `Forget` is `Representable` * MINIMAL pragmas 4.2.0.1 ------- * Avoided using 'type' in the export list, as that doesn't work on 7.4. 4.2 --- * Renamed `-|` to `ProfunctorAdjunction` because GHC 7.4 still exists in the wild. * Renamed `-/->` to `:->` for the same reason. Also the former was confusing as they conflated profunctor homomorphisms and profunctors themselves. 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. 4.0.2 ----- * Added `assoc` to `Data.Profunctor.Composition` so that we have all 3 associators. 4.0 --- * Merged the contents of `profunctor-extras` into `profunctors`. 3.3 --- * Added `instance Choice (Upstar f)` and introduced `Forget`. 3.2 --- * Renamed `Lenticular` and `Prismatic` to `Strong` and `Choice`, and restructured them. 3.1.3 ----- * Removed upper bounds on my own intra-package dependencies 3.1.1 ----- * Added Documentation! * Added `Lenticular` and `Prismatic` Profunctors 3.1 --- * instance Profunctor Tagged 3.0 --- * Updated version number to match the rest of my libraries profunctors-5.1.2/HLint.hs0000644000000000000000000000002312627505135013644 0ustar0000000000000000ignore "use const" profunctors-5.1.2/LICENSE0000644000000000000000000000266012627505135013310 0ustar0000000000000000Copyright 2011-2013 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. profunctors-5.1.2/profunctors.cabal0000644000000000000000000000331112627505135015645 0ustar0000000000000000name: profunctors category: Control, Categories version: 5.1.2 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: experimental homepage: http://github.com/ekmett/profunctors/ bug-reports: http://github.com/ekmett/profunctors/issues 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 build-type: Simple extra-source-files: .ghci .gitignore .travis.yml .vim.custom README.markdown CHANGELOG.markdown HLint.hs source-repository head type: git location: git://github.com/ekmett/profunctors.git library build-depends: base >= 4 && < 5, bifunctors >= 5 && < 6, comonad >= 4 && < 5, contravariant >= 1 && < 2, distributive >= 0.4.4 && < 1, 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.Monad Data.Profunctor.Monoid Data.Profunctor.Ran Data.Profunctor.Rep Data.Profunctor.Sieve Data.Profunctor.Tambara Data.Profunctor.Trace Data.Profunctor.Unsafe ghc-options: -Wall -O2 hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP GADTs FlexibleContexts FlexibleInstances UndecidableInstances TypeFamilies profunctors-5.1.2/README.markdown0000644000000000000000000000075012627505135015002 0ustar0000000000000000Profunctors =========== [![Hackage](https://img.shields.io/hackage/v/profunctors.svg)](https://hackage.haskell.org/package/profunctors) [![Build Status](https://secure.travis-ci.org/ekmett/profunctors.png?branch=master)](http://travis-ci.org/ekmett/profunctors) Profunctors for Haskell. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett profunctors-5.1.2/Setup.lhs0000644000000000000000000000016512627505135014111 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain profunctors-5.1.2/src/0000755000000000000000000000000012627505135013066 5ustar0000000000000000profunctors-5.1.2/src/Data/0000755000000000000000000000000012627505135013737 5ustar0000000000000000profunctors-5.1.2/src/Data/Profunctor.hs0000644000000000000000000003242012627505135016435 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- For a good explanation of profunctors in Haskell see Dan Piponi's article: -- -- -- -- For more information on strength and costrength, see: -- -- ---------------------------------------------------------------------------- module Data.Profunctor ( -- * Profunctors Profunctor(dimap,lmap,rmap) -- ** Profunctorial Strength , Strong(..) , Choice(..) -- ** Profunctorial Costrength , Costrong(..) , Cochoice(..) -- ** Common Profunctors , 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 (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. -- -- 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 profunctors-5.1.2/src/Data/Profunctor/0000755000000000000000000000000012627505135016100 5ustar0000000000000000profunctors-5.1.2/src/Data/Profunctor/Adjunction.hs0000644000000000000000000000064012627505135020532 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-} module Data.Profunctor.Adjunction where import Data.Profunctor import Data.Profunctor.Monad 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 profunctors-5.1.2/src/Data/Profunctor/Cayley.hs0000644000000000000000000000565412627505135017674 0ustar0000000000000000{-# LANGUAGE CPP #-} #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 -- 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) } instance Functor f => ProfunctorFunctor (Cayley f) where promap f (Cayley p) = Cayley (fmap f p) -- | Cayley transforms Monads in @Hask@ into monads on @Prof@ instance (Functor f, 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) profunctors-5.1.2/src/Data/Profunctor/Closed.hs0000644000000000000000000001252012627505135017645 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# 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 (Costar f) where closed (Costar fab) = Costar $ \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 (Star f) where closed (Star afb) = Star $ \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 'Strong'. 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 ProfunctorFunctor Closure where promap f (Closure p) = Closure (f p) 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 ProfunctorFunctor Environment where promap f (Environment l m r) = Environment l (f m) r 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 ProfunctorAdjunction Environment Closure where counit (Environment g (Closure p) f) = dimap f g p unit p = Closure (Environment id p id) profunctors-5.1.2/src/Data/Profunctor/Codensity.hs0000644000000000000000000000351612627505135020402 0ustar0000000000000000{-# 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 -- 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 #-} profunctors-5.1.2/src/Data/Profunctor/Composition.hs0000644000000000000000000002546012627505135020746 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Profunctor.Composition -- Copyright : (C) 2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : GADTs, TFs, MPTCs, RankN -- ---------------------------------------------------------------------------- module Data.Profunctor.Composition ( -- * Profunctor Composition Procompose(..) , procomposed -- * Unitors and Associator , idl , idr , assoc -- * Generalized Composition , stars, kleislis , costars, cokleislis -- * Right Kan Lift , Rift(..) , decomposeRift ) where import Control.Arrow import Control.Category import Control.Comonad 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.Sieve import Data.Profunctor.Unsafe import Prelude hiding ((.),id) type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) -- * Profunctor Composition -- | @'Procompose' p q@ is the 'Profunctor' composition of the -- 'Profunctor's @p@ and @q@. -- -- For a good explanation of 'Profunctor' composition in Haskell -- see Dan Piponi's article: -- -- data Procompose p q d c where Procompose :: p x c -> q d x -> Procompose p q d c instance ProfunctorFunctor (Procompose p) where promap f (Procompose p q) = Procompose p (f q) 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 pxc pdx) = pxc . pdx {-# INLINE procomposed #-} instance (Profunctor p, Profunctor q) => Profunctor (Procompose p q) where dimap l r (Procompose f g) = Procompose (rmap r f) (lmap l g) {-# INLINE dimap #-} lmap k (Procompose f g) = Procompose f (lmap k g) {-# INLINE rmap #-} rmap k (Procompose f g) = Procompose (rmap k f) g {-# INLINE lmap #-} k #. Procompose f g = Procompose (k #. f) g {-# INLINE ( #. ) #-} Procompose f g .# k = Procompose f (g .# k) {-# INLINE ( .# ) #-} instance Profunctor p => Functor (Procompose p q a) where fmap k (Procompose f g) = Procompose (rmap k f) g {-# INLINE fmap #-} instance (Sieve p f, Sieve q g) => Sieve (Procompose p q) (Compose g f) where sieve (Procompose g f) d = Compose $ sieve g <$> sieve f d {-# INLINE sieve #-} -- | 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 q) (Rep p) tabulate f = Procompose (tabulate id) (tabulate (getCompose . f)) {-# INLINE tabulate #-} instance (Cosieve p f, Cosieve q g) => Cosieve (Procompose p q) (Compose f g) where cosieve (Procompose g f) (Compose d) = cosieve g $ cosieve f <$> d {-# INLINE cosieve #-} instance (Corepresentable p, Corepresentable q) => Corepresentable (Procompose p q) where type Corep (Procompose p q) = Compose (Corep p) (Corep q) cotabulate f = Procompose (cotabulate (f . Compose)) (cotabulate id) {-# INLINE cotabulate #-} instance (Strong p, Strong q) => Strong (Procompose p q) where first' (Procompose x y) = Procompose (first' x) (first' y) {-# INLINE first' #-} second' (Procompose x y) = Procompose (second' x) (second' y) {-# INLINE second' #-} instance (Choice p, Choice q) => Choice (Procompose p q) where left' (Procompose x y) = Procompose (left' x) (left' y) {-# INLINE left' #-} 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 #-} instance (Corepresentable p, Corepresentable q) => Costrong (Procompose p q) where unfirst = unfirstCorep unsecond = unsecondCorep -- * Lax identity -- | @(->)@ functions as a lax identity for 'Profunctor' composition. -- -- This provides an 'Iso' for the @lens@ package that witnesses the -- isomorphism between @'Procompose' (->) q d c@ and @q d c@, which -- is the left identity law. -- -- @ -- '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 g f) -> rmap g f) (fmap (Procompose id)) -- | @(->)@ functions as a lax identity for 'Profunctor' composition. -- -- This provides an 'Iso' for the @lens@ package that witnesses the -- isomorphism between @'Procompose' q (->) d c@ and @q d c@, which -- is the right identity law. -- -- @ -- '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 g f) -> lmap f g) (fmap (`Procompose` id)) -- | The associator for 'Profunctor' composition. -- -- This provides an 'Iso' for the @lens@ package that witnesses the -- isomorphism between @'Procompose' p ('Procompose' q r) a b@ and -- @'Procompose' ('Procompose' p q) r a b@, which arises because -- @Prof@ is only a bicategory, rather than a strict 2-category. assoc :: Iso (Procompose p (Procompose q r) a b) (Procompose x (Procompose y z) a b) (Procompose (Procompose p q) r a b) (Procompose (Procompose x y) z a b) assoc = dimap (\(Procompose f (Procompose g h)) -> Procompose (Procompose f g) h) (fmap (\(Procompose (Procompose f g) h) -> Procompose f (Procompose g h))) -- | 'Profunctor' composition generalizes 'Functor' composition in two ways. -- -- This is the first, which shows that @exists b. (a -> f b, b -> g c)@ is -- isomorphic to @a -> f (g c)@. -- -- @'stars' :: 'Functor' f => Iso' ('Procompose' ('Star' f) ('Star' g) d c) ('Star' ('Compose' f g) d c)@ stars :: Functor g => Iso (Procompose (Star f ) (Star g ) d c ) (Procompose (Star f') (Star g') d' c') (Star (Compose g f ) d c ) (Star (Compose g' f') d' c') stars = dimap hither (fmap yon) where hither (Procompose (Star xgc) (Star dfx)) = Star (Compose . fmap xgc . dfx) yon (Star dfgc) = Procompose (Star id) (Star (getCompose . dfgc)) -- | 'Profunctor' composition generalizes 'Functor' composition in two ways. -- -- This is the second, which shows that @exists b. (f a -> b, g b -> c)@ is -- isomorphic to @g (f a) -> c@. -- -- @'costars' :: 'Functor' f => Iso' ('Procompose' ('Costar' f) ('Costar' g) d c) ('Costar' ('Compose' g f) d c)@ costars :: Functor f => Iso (Procompose (Costar f ) (Costar g ) d c ) (Procompose (Costar f') (Costar g') d' c') (Costar (Compose f g ) d c ) (Costar (Compose f' g') d' c') costars = dimap hither (fmap yon) where hither (Procompose (Costar gxc) (Costar fdx)) = Costar (gxc . fmap fdx . getCompose) yon (Costar dgfc) = Procompose (Costar (dgfc . Compose)) (Costar id) -- | This is a variant on 'stars' that uses 'Kleisli' instead of 'Star'. -- -- @'kleislis' :: 'Monad' f => Iso' ('Procompose' ('Kleisli' f) ('Kleisli' g) d c) ('Kleisli' ('Compose' f g) d c)@ kleislis :: Monad g => Iso (Procompose (Kleisli f ) (Kleisli g ) d c ) (Procompose (Kleisli f') (Kleisli g') d' c') (Kleisli (Compose g f ) d c ) (Kleisli (Compose g' f') d' c') kleislis = dimap hither (fmap yon) where 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 'costars' that uses 'Cokleisli' instead -- of 'Costar'. -- -- @'cokleislis' :: 'Functor' f => Iso' ('Procompose' ('Cokleisli' f) ('Cokleisli' g) d c) ('Cokleisli' ('Compose' g f) d c)@ cokleislis :: Functor f => Iso (Procompose (Cokleisli f ) (Cokleisli g ) d c ) (Procompose (Cokleisli f') (Cokleisli g') d' c') (Cokleisli (Compose f g ) d c ) (Cokleisli (Compose f' g') d' c') cokleislis = dimap hither (fmap yon) where 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 ProfunctorFunctor (Rift p) where promap f (Rift g) = Rift (f . g) 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 ProfunctorAdjunction (Procompose p) (Rift p) where counit (Procompose p (Rift pq)) = pq p unit q = Rift $ \p -> Procompose p q --instance (ProfunctorAdjunction f g, ProfunctorAdjunction f' g') => ProfunctorAdjunction (ProfunctorCompose f' f) (ProfunctorCompose g g') where profunctors-5.1.2/src/Data/Profunctor/Monad.hs0000644000000000000000000000076112627505135017476 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} module Data.Profunctor.Monad where import Data.Profunctor class ProfunctorFunctor t where promap :: Profunctor p => (p :-> q) -> t p :-> t q class ProfunctorFunctor t => ProfunctorMonad t where proreturn :: Profunctor p => p :-> t p projoin :: Profunctor p => t (t p) :-> t p class ProfunctorFunctor t => ProfunctorComonad t where proextract :: Profunctor p => t p :-> p produplicate :: Profunctor p => t p :-> t (t p) profunctors-5.1.2/src/Data/Profunctor/Monoid.hs0000644000000000000000000000064512627505135017666 0ustar0000000000000000{-# 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 profunctors-5.1.2/src/Data/Profunctor/Ran.hs0000644000000000000000000000560512627505135017162 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013-2014 Edward Kmett and Dan Doel -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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 ProfunctorFunctor (Ran p) where promap f (Ran g) = Ran (f . g) 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 #-} profunctors-5.1.2/src/Data/Profunctor/Rep.hs0000644000000000000000000001546712627505135017177 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Profunctor.Rep -- Copyright : (C) 2011-2015 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Type-Families -- ---------------------------------------------------------------------------- module Data.Profunctor.Rep ( -- * Representable Profunctors Representable(..) , tabulated , firstRep, secondRep -- * Corepresentable Profunctors , Corepresentable(..) , cotabulated , unfirstCorep, unsecondCorep -- * Prep -| Star , Prep(..) , prepAdj , unprepAdj , prepUnit , prepCounit -- * Coprep -| Costar , Coprep(..) , coprepAdj , uncoprepAdj , coprepUnit , coprepCounit ) where import Control.Applicative import Control.Arrow import Control.Comonad import Data.Functor.Identity import Data.Profunctor import Data.Profunctor.Sieve import Data.Proxy import Data.Tagged -- * Representable Profunctors -- | A 'Profunctor' @p@ is 'Representable' if there exists a 'Functor' @f@ such that -- @p d c@ is isomorphic to @d -> f c@. class (Sieve p (Rep p), Strong p) => Representable p where type Rep p :: * -> * tabulate :: (d -> Rep p c) -> p d c -- | Default definition for 'first'' given that p is 'Representable'. firstRep :: Representable p => p a b -> p (a, c) (b, c) firstRep p = tabulate $ \(a,c) -> (\b -> (b, c)) <$> sieve p a -- | Default definition for 'second'' given that p is 'Representable'. secondRep :: Representable p => p a b -> p (c, a) (c, b) secondRep p = tabulate $ \(c,a) -> (,) c <$> sieve p a instance Representable (->) where type Rep (->) = Identity tabulate f = runIdentity . f {-# INLINE tabulate #-} instance (Monad m, Functor m) => Representable (Kleisli m) where type Rep (Kleisli m) = m tabulate = Kleisli {-# INLINE tabulate #-} instance Functor f => Representable (Star f) where type Rep (Star f) = f tabulate = Star {-# INLINE tabulate #-} instance Representable (Forget r) where type Rep (Forget r) = Const r tabulate = Forget . (getConst .) {-# INLINE tabulate #-} 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. -- -- This can be used with the combinators from the @lens@ package. -- -- @'tabulated' :: 'Representable' p => 'Iso'' (d -> 'Rep' p c) (p d c)@ tabulated :: (Representable p, Representable q) => Iso (d -> Rep p c) (d' -> Rep q c') (p d c) (q d' c') tabulated = dimap tabulate (fmap sieve) {-# INLINE tabulated #-} -- * Corepresentable Profunctors -- | A 'Profunctor' @p@ is 'Corepresentable' if there exists a 'Functor' @f@ such that -- @p d c@ is isomorphic to @f d -> c@. class (Cosieve p (Corep p), Costrong p) => Corepresentable p where type Corep p :: * -> * cotabulate :: (Corep p d -> c) -> p d c -- | 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'. 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) instance Corepresentable (->) where type Corep (->) = Identity cotabulate f = f . Identity {-# INLINE cotabulate #-} instance Functor w => Corepresentable (Cokleisli w) where type Corep (Cokleisli w) = w cotabulate = Cokleisli {-# INLINE cotabulate #-} instance Corepresentable Tagged where type Corep Tagged = Proxy cotabulate f = Tagged (f Proxy) {-# INLINE cotabulate #-} instance Functor f => Corepresentable (Costar f) where type Corep (Costar f) = f cotabulate = Costar {-# INLINE cotabulate #-} -- | 'cotabulate' and 'cosieve' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'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 cosieve) {-# INLINE cotabulated #-} -------------------------------------------------------------------------------- -- * Prep -------------------------------------------------------------------------------- -- | @'Prep' -| 'Star' :: [Hask, Hask] -> Prof@ -- -- This gives rise to a monad in @Prof@, @('Star'.'Prep')@, and -- a comonad in @[Hask,Hask]@ @('Prep'.'Star')@ data Prep p a where Prep :: x -> p x a -> Prep p a instance Profunctor p => Functor (Prep p) where fmap f (Prep x p) = Prep x (rmap f p) instance (Applicative (Rep p), Representable p) => Applicative (Prep p) where pure a = Prep () $ tabulate $ const $ pure a Prep xf pf <*> Prep xa pa = Prep (xf,xa) (tabulate go) where go (xf',xa') = sieve pf xf' <*> sieve pa xa' instance (Monad (Rep p), Representable p) => Monad (Prep p) where return a = Prep () $ tabulate $ const $ return a Prep xa pa >>= f = Prep xa $ tabulate $ \xa' -> sieve pa xa' >>= \a -> case f a of Prep xb pb -> sieve pb xb prepAdj :: (forall a. Prep p a -> g a) -> p :-> Star g prepAdj k p = Star $ \x -> k (Prep x p) unprepAdj :: (p :-> Star g) -> Prep p a -> g a unprepAdj k (Prep x p) = runStar (k p) x prepUnit :: p :-> Star (Prep p) prepUnit p = Star $ \x -> Prep x p prepCounit :: Prep (Star f) a -> f a prepCounit (Prep x p) = runStar p x -------------------------------------------------------------------------------- -- * Coprep -------------------------------------------------------------------------------- newtype Coprep p a = Coprep { runCoprep :: forall r. p a r -> r } instance Profunctor p => Functor (Coprep p) where fmap f (Coprep g) = Coprep (g . lmap f) -- | @'Coprep' -| 'Costar' :: [Hask, Hask]^op -> Prof@ -- -- Like all adjunctions this gives rise to a monad and a comonad. -- -- This gives rise to a monad on Prof @('Costar'.'Coprep')@ and -- a comonad on @[Hask, Hask]^op@ given by @('Coprep'.'Costar')@ which -- is a monad in @[Hask,Hask]@ coprepAdj :: (forall a. f a -> Coprep p a) -> p :-> Costar f coprepAdj k p = Costar $ \f -> runCoprep (k f) p uncoprepAdj :: (p :-> Costar f) -> f a -> Coprep p a uncoprepAdj k f = Coprep $ \p -> runCostar (k p) f coprepUnit :: p :-> Costar (Coprep p) coprepUnit p = Costar $ \f -> runCoprep f p coprepCounit :: f a -> Coprep (Costar f) a coprepCounit f = Coprep $ \p -> runCostar p f profunctors-5.1.2/src/Data/Profunctor/Sieve.hs0000644000000000000000000000446412627505135017517 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- ---------------------------------------------------------------------------- module Data.Profunctor.Sieve ( Sieve(..) , Cosieve(..) ) where import Control.Applicative import Control.Arrow import Control.Comonad import Data.Functor.Identity import Data.Profunctor import Data.Proxy import Data.Tagged -- | A 'Profunctor' @p@ is a 'Sieve' __on__ @f@ if it is a subprofunctor of @'Star' f@. -- -- That is to say it is a subset of @Hom(-,f=)@ closed under 'lmap' and 'rmap'. -- -- Alternately, you can view it as a sieve __in__ the comma category @Hask/f@. class (Profunctor p, Functor f) => Sieve p f | p -> f where sieve :: p a b -> a -> f b instance Sieve (->) Identity where sieve f = Identity . f {-# INLINE sieve #-} instance (Monad m, Functor m) => Sieve (Kleisli m) m where sieve = runKleisli {-# INLINE sieve #-} instance Functor f => Sieve (Star f) f where sieve = runStar {-# INLINE sieve #-} instance Sieve (Forget r) (Const r) where sieve = (Const .) . runForget {-# INLINE sieve #-} -- | A 'Profunctor' @p@ is a 'Cosieve' __on__ @f@ if it is a subprofunctor of @'Costar' f@. -- -- That is to say it is a subset of @Hom(f-,=)@ closed under 'lmap' and 'rmap'. -- -- Alternately, you can view it as a cosieve __in__ the comma category @f/Hask@. class (Profunctor p, Functor f) => Cosieve p f | p -> f where cosieve :: p a b -> f a -> b instance Cosieve (->) Identity where cosieve f (Identity d) = f d {-# INLINE cosieve #-} instance Functor w => Cosieve (Cokleisli w) w where cosieve = runCokleisli {-# INLINE cosieve #-} instance Cosieve Tagged Proxy where cosieve (Tagged a) _ = a {-# INLINE cosieve #-} instance Functor f => Cosieve (Costar f) f where cosieve = runCostar {-# INLINE cosieve #-} profunctors-5.1.2/src/Data/Profunctor/Tambara.hs0000644000000000000000000002074412627505135020012 0ustar0000000000000000{-# 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 -- 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 profunctors-5.1.2/src/Data/Profunctor/Trace.hs0000644000000000000000000000112212627505135017466 0ustar0000000000000000{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Profunctor.Trace -- Copyright : (C) 2011-2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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 profunctors-5.1.2/src/Data/Profunctor/Unsafe.hs0000644000000000000000000001722612627505135017665 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Trustworthy #-} #elif __GLASGOW_HASKELL >= 704 {-# LANGUAGE Unsafe #-} #endif {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- For a good explanation of profunctors in Haskell see Dan Piponi's article: -- -- -- -- This module includes /unsafe/ composition operators that are useful in -- practice when it comes to generating optimal core in GHC. -- -- If you import this module you are taking upon yourself the obligation -- that you will only call the operators with @#@ in their names with functions -- that are operationally identity such as @newtype@ constructors or the field -- accessor of a @newtype@. -- -- If you are ever in doubt, use 'rmap' or 'lmap'. ---------------------------------------------------------------------------- module Data.Profunctor.Unsafe ( -- * Profunctors Profunctor(..) ) where import Control.Arrow import Control.Category import Control.Comonad (Cokleisli(..)) import Control.Monad (liftM) import Data.Bifunctor.Clown (Clown(..)) import Data.Bifunctor.Joker (Joker(..)) import Data.Functor.Contravariant (Contravariant(..)) import Data.Tagged import Prelude hiding (id,(.),sequence) #if __GLASGOW_HASKELL__ >= 708 import Data.Coerce #else import Unsafe.Coerce #endif {-# ANN module "Hlint: ignore Redundant lambda" #-} {-# ANN module "Hlint: ignore Collapse lambdas" #-} infixr 9 #. infixl 8 .# ---------------------------------------------------------------------------- -- Profunctors ---------------------------------------------------------------------------- -- | Formally, the class 'Profunctor' represents a profunctor -- from @Hask@ -> @Hask@. -- -- Intuitively it is a bifunctor where the first argument is contravariant -- and the second argument is covariant. -- -- You can define a 'Profunctor' by either defining 'dimap' or by defining both -- 'lmap' and 'rmap'. -- -- If you supply 'dimap', you should ensure that: -- -- @'dimap' 'id' 'id' ≡ 'id'@ -- -- If you supply 'lmap' and 'rmap', ensure: -- -- @ -- 'lmap' 'id' ≡ 'id' -- 'rmap' 'id' ≡ 'id' -- @ -- -- If you supply both, you should also ensure: -- -- @'dimap' f g ≡ 'lmap' f '.' 'rmap' g@ -- -- These ensure by parametricity: -- -- @ -- 'dimap' (f '.' g) (h '.' i) ≡ 'dimap' g h '.' 'dimap' f i -- 'lmap' (f '.' g) ≡ 'lmap' g '.' 'lmap' f -- 'rmap' (f '.' g) ≡ 'rmap' f '.' 'rmap' g -- @ class Profunctor p where -- | Map over both arguments at the same time. -- -- @'dimap' f g ≡ 'lmap' f '.' 'rmap' g@ dimap :: (a -> b) -> (c -> d) -> p b c -> p a d dimap f g = lmap f . rmap g {-# INLINE dimap #-} -- | Map the first argument contravariantly. -- -- @'lmap' f ≡ 'dimap' f 'id'@ lmap :: (a -> b) -> p b c -> p a c lmap f = dimap f id {-# INLINE lmap #-} -- | Map the second argument covariantly. -- -- @'rmap' ≡ 'dimap' 'id'@ rmap :: (b -> c) -> p a b -> p a c rmap = dimap id {-# INLINE rmap #-} -- | Strictly map the second argument argument -- covariantly with a function that is assumed -- operationally to be a cast, such as a newtype -- constructor. -- -- /Note:/ This operation is explicitly /unsafe/ -- since an implementation may choose to use -- 'unsafeCoerce' to implement this combinator -- and it has no way to validate that your function -- meets the requirements. -- -- If you implement this combinator with -- 'unsafeCoerce', then you are taking upon yourself -- the obligation that you don't use GADT-like -- tricks to distinguish values. -- -- If you import "Data.Profunctor.Unsafe" you are -- taking upon yourself the obligation that you -- will only call this with a first argument that is -- operationally identity. -- -- The semantics of this function with respect to bottoms -- should match the default definition: -- -- @('Profuctor.Unsafe.#.') ≡ \\f -> \\p -> p \`seq\` 'rmap' f p@ #if __GLASGOW_HASKELL__ >= 708 ( #. ) :: Coercible c b => (b -> c) -> p a b -> p a c #else ( #. ) :: (b -> c) -> p a b -> p a c #endif ( #. ) = \f -> \p -> p `seq` rmap f p {-# INLINE ( #. ) #-} -- | Strictly map the first argument argument -- contravariantly with a function that is assumed -- operationally to be a cast, such as a newtype -- constructor. -- -- /Note:/ This operation is explicitly /unsafe/ -- since an implementation may choose to use -- 'unsafeCoerce' to implement this combinator -- and it has no way to validate that your function -- meets the requirements. -- -- If you implement this combinator with -- 'unsafeCoerce', then you are taking upon yourself -- the obligation that you don't use GADT-like -- tricks to distinguish values. -- -- If you import "Data.Profunctor.Unsafe" you are -- taking upon yourself the obligation that you -- will only call this with a second argument that is -- operationally identity. -- -- @('.#') ≡ \\p -> p \`seq\` \\f -> 'lmap' f p@ #if __GLASGOW_HASKELL__ >= 708 ( .# ) :: Coercible b a => p b c -> (a -> b) -> p a c #else ( .# ) :: p b c -> (a -> b) -> p a c #endif ( .# ) = \p -> p `seq` \f -> lmap f p {-# INLINE ( .# ) #-} #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL dimap | (lmap, rmap) #-} #endif instance Profunctor (->) where dimap ab cd bc = cd . bc . ab {-# INLINE dimap #-} lmap = flip (.) {-# INLINE lmap #-} rmap = (.) {-# INLINE rmap #-} #if __GLASGOW_HASKELL__ >= 708 ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b ( .# ) pbc _ = coerce pbc #else ( #. ) _ = unsafeCoerce ( .# ) pbc _ = unsafeCoerce pbc #endif {-# INLINE ( #. ) #-} {-# INLINE ( .# ) #-} instance Profunctor Tagged where dimap _ f (Tagged s) = Tagged (f s) {-# INLINE dimap #-} lmap _ = retag {-# INLINE lmap #-} rmap = fmap {-# INLINE rmap #-} #if __GLASGOW_HASKELL__ >= 708 ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b #else ( #. ) _ = unsafeCoerce #endif {-# INLINE ( #. ) #-} Tagged s .# _ = Tagged s {-# INLINE ( .# ) #-} instance Monad m => Profunctor (Kleisli m) where dimap f g (Kleisli h) = Kleisli (liftM g . h . f) {-# INLINE dimap #-} lmap k (Kleisli f) = Kleisli (f . k) {-# INLINE lmap #-} rmap k (Kleisli f) = Kleisli (liftM k . f) {-# INLINE rmap #-} -- We cannot safely overload (#.) because we didn't provide the 'Monad'. #if __GLASGOW_HASKELL__ >= 708 ( .# ) pbc _ = coerce pbc #else ( .# ) pbc _ = unsafeCoerce pbc #endif {-# INLINE ( .# ) #-} instance Functor w => Profunctor (Cokleisli w) where dimap f g (Cokleisli h) = Cokleisli (g . h . fmap f) {-# INLINE dimap #-} lmap k (Cokleisli f) = Cokleisli (f . fmap k) {-# INLINE lmap #-} rmap k (Cokleisli f) = Cokleisli (k . f) {-# INLINE rmap #-} -- We cannot safely overload (.#) because we didn't provide the 'Functor'. #if __GLASGOW_HASKELL__ >= 708 ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b #else ( #. ) _ = unsafeCoerce #endif {-# INLINE ( #. ) #-} instance Contravariant f => Profunctor (Clown f) where lmap f (Clown fa) = Clown (contramap f fa) {-# INLINE lmap #-} rmap _ (Clown fa) = Clown fa {-# INLINE rmap #-} dimap f _ (Clown fa) = Clown (contramap f fa) {-# INLINE dimap #-} instance Functor f => Profunctor (Joker f) where lmap _ (Joker fb) = Joker fb {-# INLINE lmap #-} rmap g (Joker fb) = Joker (fmap g fb) {-# INLINE rmap #-} dimap _ g (Joker fb) = Joker (fmap g fb) {-# INLINE dimap #-}