profunctors-4.0.1/0000755000000000000000000000000012226610741012267 5ustar0000000000000000profunctors-4.0.1/.ghci0000644000000000000000000000012512226610741013200 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h profunctors-4.0.1/.gitignore0000644000000000000000000000011512226610741014254 0ustar0000000000000000dist/ .hsenv/ docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# profunctors-4.0.1/.travis.yml0000644000000000000000000000130712226610741014401 0ustar0000000000000000language: haskell before_install: # Uncomment whenever hackage is down. # - mkdir -p ~/.cabal && cp config ~/.cabal/config && cabal update # Try installing some of the build-deps with apt-get for speed. - ./travis-cabal-apt-install --only-dependencies --force-reinstall $mode - sudo apt-get -q -y install hlint || cabal install hlint install: - cabal configure $mode - cabal build script: - $script - hlint src --cpp-define HLINT notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313profunctors\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" env: - mode="--enable-tests" script="cabal test" profunctors-4.0.1/.vim.custom0000644000000000000000000000137712226610741014404 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-4.0.1/CHANGELOG.markdown0000644000000000000000000000077112226610741015327 0ustar00000000000000004.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-4.0.1/LICENSE0000644000000000000000000000266012226610741013300 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-4.0.1/profunctors.cabal0000644000000000000000000000247412226610741015646 0ustar0000000000000000name: profunctors category: Control, Categories version: 4.0.1 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-2013 Edward A. Kmett synopsis: Profunctors description: Profunctors build-type: Simple extra-source-files: .ghci .gitignore .travis.yml .vim.custom README.markdown CHANGELOG.markdown source-repository head type: git location: git://github.com/ekmett/profunctors.git library build-depends: base >= 4 && < 5, comonad >= 4 && < 5, semigroupoids >= 4 && < 5, tagged >= 0.4.4 && < 1, transformers >= 0.2 && < 0.4 exposed-modules: Data.Profunctor Data.Profunctor.Composition Data.Profunctor.Collage Data.Profunctor.Rep Data.Profunctor.Rift 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-4.0.1/README.markdown0000644000000000000000000000055012226610741014770 0ustar0000000000000000Profunctors =========== [![Build Status](https://secure.travis-ci.org/ekmett/profunctors.png)](http://travis-ci.org/ekmett/profunctors) Haskell 98 Profunctors 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-4.0.1/Setup.lhs0000644000000000000000000000016512226610741014101 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain profunctors-4.0.1/src/0000755000000000000000000000000012226610741013056 5ustar0000000000000000profunctors-4.0.1/src/Data/0000755000000000000000000000000012226610741013727 5ustar0000000000000000profunctors-4.0.1/src/Data/Profunctor.hs0000644000000000000000000002142412226610741016427 0ustar0000000000000000{-# LANGUAGE CPP #-} #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(..) -- ** Common Profunctors , UpStar(..) , DownStar(..) , WrappedArrow(..) , Forget(..) ) where import Control.Applicative hiding (WrappedArrow(..)) import Control.Arrow import Control.Category import Control.Comonad import Data.Foldable import Data.Monoid import Data.Tagged import Data.Traversable import Data.Tuple import Data.Profunctor.Unsafe import Prelude hiding (id,(.),sequence) import Unsafe.Coerce ------------------------------------------------------------------------------ -- UpStar ------------------------------------------------------------------------------ -- | Lift a 'Functor' into a 'Profunctor' (forwards). newtype UpStar f d c = UpStar { runUpStar :: d -> f c } instance Functor f => Profunctor (UpStar f) where dimap ab cd (UpStar bfc) = UpStar (fmap cd . bfc . ab) {-# INLINE dimap #-} lmap k (UpStar f) = UpStar (f . k) {-# INLINE lmap #-} rmap k (UpStar f) = UpStar (fmap k . f) {-# INLINE rmap #-} -- We cannot safely overload ( #. ) because we didn't write the 'Functor'. p .# _ = unsafeCoerce p {-# INLINE ( .# ) #-} instance Functor f => Functor (UpStar f a) where fmap = rmap {-# INLINE fmap #-} ------------------------------------------------------------------------------ -- DownStar ------------------------------------------------------------------------------ -- | Lift a 'Functor' into a 'Profunctor' (backwards). newtype DownStar f d c = DownStar { runDownStar :: f d -> c } instance Functor f => Profunctor (DownStar f) where dimap ab cd (DownStar fbc) = DownStar (cd . fbc . fmap ab) {-# INLINE dimap #-} lmap k (DownStar f) = DownStar (f . fmap k) {-# INLINE lmap #-} rmap k (DownStar f) = DownStar (k . f) {-# INLINE rmap #-} ( #. ) _ = unsafeCoerce {-# INLINE ( #. ) #-} -- We cannot overload ( .# ) because we didn't write the 'Functor'. instance Functor (DownStar f a) where fmap k (DownStar f) = DownStar (k . f) {-# INLINE fmap #-} ------------------------------------------------------------------------------ -- 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 upstar of a strong 'Functor' -- -- Minimal complete definition: 'first'' or 'second'' -- -- /Note:/ Every 'Functor' in Haskell is strong. 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' 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 (UpStar m) where first' (UpStar f) = UpStar $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a {-# INLINE first' #-} second' (UpStar f) = UpStar $ \ ~(c, a) -> (,) c <$> f a {-# INLINE second' #-} 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 'DownStar' of a \"costrong\" 'Functor' -- -- Minimal complete definition: 'left'' or 'right'' -- -- /Note:/ We use 'traverse' and 'extract' as approximate costrength as needed. 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' 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 (UpStar f) where left' (UpStar f) = UpStar $ either (fmap Left . f) (fmap Right . pure) {-# INLINE left' #-} right' (UpStar f) = UpStar $ either (fmap Left . pure) (fmap Right . f) {-# INLINE right' #-} -- | 'extract' approximates 'costrength' instance Comonad w => Choice (Cokleisli w) where left' = left {-# INLINE left' #-} right' = right {-# INLINE right' #-} -- | 'sequence' approximates 'costrength' instance Traversable w => Choice (DownStar w) where left' (DownStar wab) = DownStar (either Right Left . fmap wab . traverse (either Right Left)) {-# INLINE left' #-} right' (DownStar wab) = DownStar (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' #-} profunctors-4.0.1/src/Data/Profunctor/0000755000000000000000000000000012226610741016070 5ustar0000000000000000profunctors-4.0.1/src/Data/Profunctor/Collage.hs0000644000000000000000000000256112226610741017776 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Profunctor.Collage -- Copyright : (C) 2011-2012 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs -- ---------------------------------------------------------------------------- module Data.Profunctor.Collage ( Collage(..) ) where import Data.Semigroupoid import Data.Semigroupoid.Ob import Data.Semigroupoid.Coproduct (L, R) import Data.Profunctor -- | The cograph of a 'Profunctor'. data Collage k b a where L :: (b -> b') -> Collage k (L b) (L b') R :: (a -> a') -> Collage k (R a) (R a') C :: k b a -> Collage k (L b) (R a) instance Profunctor k => Semigroupoid (Collage k) where L f `o` L g = L (f . g) R f `o` R g = R (f . g) R f `o` C g = C (rmap f g) C f `o` L g = C (lmap g f) instance Profunctor k => Ob (Collage k) (L a) where semiid = L semiid instance Profunctor k => Ob (Collage k) (R a) where semiid = R semiid profunctors-4.0.1/src/Data/Profunctor/Composition.hs0000644000000000000000000001623412226610741020735 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Profunctor.Composition -- Copyright : (C) 2011-2012 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : GADTs -- ---------------------------------------------------------------------------- module Data.Profunctor.Composition ( -- * Profunctor Composition Procompose(..) , procomposed -- * Lax identity , idl , idr -- * Generalized Composition , upstars, kleislis , downstars, cokleislis ) where import Control.Arrow import Control.Category import Control.Comonad import Control.Monad (liftM) import Data.Functor.Compose import Data.Profunctor import Data.Profunctor.Rep 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 d a -> q a c -> Procompose p q d c procomposed :: Category p => Procompose p p a b -> p a b procomposed (Procompose pda pac) = pac . pda {-# INLINE procomposed #-} instance (Profunctor p, Profunctor q) => Profunctor (Procompose p q) where dimap l r (Procompose f g) = Procompose (lmap l f) (rmap r g) {-# INLINE dimap #-} lmap k (Procompose f g) = Procompose (lmap k f) g {-# INLINE rmap #-} rmap k (Procompose f g) = Procompose f (rmap k g) {-# INLINE lmap #-} k #. Procompose f g = Procompose f (k #. g) {-# INLINE ( #. ) #-} Procompose f g .# k = Procompose (f .# k) g {-# INLINE ( .# ) #-} instance Profunctor q => Functor (Procompose p q a) where fmap k (Procompose f g) = Procompose f (rmap k g) {-# INLINE fmap #-} -- | The composition of two 'Representable' 'Profunctor's is 'Representable' by -- the composition of their representations. instance (Representable p, Representable q) => Representable (Procompose p q) where type Rep (Procompose p q) = Compose (Rep p) (Rep q) tabulate f = Procompose (tabulate (getCompose . f)) (tabulate id) {-# INLINE tabulate #-} rep (Procompose f g) d = Compose $ rep g <$> rep f d {-# INLINE rep #-} instance (Corepresentable p, Corepresentable q) => Corepresentable (Procompose p q) where type Corep (Procompose p q) = Compose (Corep q) (Corep p) cotabulate f = Procompose (cotabulate id) (cotabulate (f . Compose)) {-# INLINE cotabulate #-} corep (Procompose f g) (Compose d) = corep g $ corep f <$> d {-# INLINE corep #-} 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' #-} -- * 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 f g) -> lmap f g) (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 f g) -> rmap g f) (fmap (`Procompose` id)) -- | '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)@. -- -- @'upstars' :: 'Functor' f => Iso' ('Procompose' ('UpStar' f) ('UpStar' g) d c) ('UpStar' ('Compose' f g) d c)@ upstars :: Functor f => Iso (Procompose (UpStar f ) (UpStar g ) d c ) (Procompose (UpStar f') (UpStar g') d' c') (UpStar (Compose f g ) d c ) (UpStar (Compose f' g') d' c') upstars = dimap hither (fmap yon) where hither (Procompose (UpStar dfx) (UpStar xgc)) = UpStar (Compose . fmap xgc . dfx) yon (UpStar dfgc) = Procompose (UpStar (getCompose . dfgc)) (UpStar id) -- | '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@. -- -- @'downstars' :: 'Functor' f => Iso' ('Procompose' ('DownStar' f) ('DownStar' g) d c) ('DownStar' ('Compose' g f) d c)@ downstars :: Functor g => Iso (Procompose (DownStar f ) (DownStar g ) d c ) (Procompose (DownStar f') (DownStar g') d' c') (DownStar (Compose g f ) d c ) (DownStar (Compose g' f') d' c') downstars = dimap hither (fmap yon) where hither (Procompose (DownStar fdx) (DownStar gxc)) = DownStar (gxc . fmap fdx . getCompose) yon (DownStar dgfc) = Procompose (DownStar id) (DownStar (dgfc . Compose)) -- | This is a variant on 'upstars' that uses 'Kleisli' instead of 'UpStar'. -- -- @'kleislis' :: 'Monad' f => Iso' ('Procompose' ('Kleisli' f) ('Kleisli' g) d c) ('Kleisli' ('Compose' f g) d c)@ kleislis :: Monad f => Iso (Procompose (Kleisli f ) (Kleisli g ) d c ) (Procompose (Kleisli f') (Kleisli g') d' c') (Kleisli (Compose f g ) d c ) (Kleisli (Compose f' g') d' c') kleislis = dimap hither (fmap yon) where hither (Procompose (Kleisli dfx) (Kleisli xgc)) = Kleisli (Compose . liftM xgc . dfx) yon (Kleisli dfgc) = Procompose (Kleisli (getCompose . dfgc)) (Kleisli id) -- | This is a variant on 'downstars' that uses 'Cokleisli' instead -- of 'DownStar'. -- -- @'cokleislis' :: 'Functor' f => Iso' ('Procompose' ('Cokleisli' f) ('Cokleisli' g) d c) ('Cokleisli' ('Compose' g f) d c)@ cokleislis :: Functor g => Iso (Procompose (Cokleisli f ) (Cokleisli g ) d c ) (Procompose (Cokleisli f') (Cokleisli g') d' c') (Cokleisli (Compose g f ) d c ) (Cokleisli (Compose g' f') d' c') cokleislis = dimap hither (fmap yon) where hither (Procompose (Cokleisli fdx) (Cokleisli gxc)) = Cokleisli (gxc . fmap fdx . getCompose) yon (Cokleisli dgfc) = Procompose (Cokleisli id) (Cokleisli (dgfc . Compose)) profunctors-4.0.1/src/Data/Profunctor/Rep.hs0000644000000000000000000000722612226610741017161 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Profunctor.Rep -- Copyright : (C) 2011-2012 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 -- * Corepresentable Profunctors , Corepresentable(..), cotabulated ) where import Control.Arrow import Control.Comonad import Data.Functor.Identity import Data.Profunctor 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 (Functor (Rep p), Profunctor p) => Representable p where type Rep p :: * -> * tabulate :: (d -> Rep p c) -> p d c rep :: p d c -> d -> Rep p c instance Representable (->) where type Rep (->) = Identity tabulate f = runIdentity . f {-# INLINE tabulate #-} rep f = Identity . f {-# INLINE rep #-} instance (Monad m, Functor m) => Representable (Kleisli m) where type Rep (Kleisli m) = m tabulate = Kleisli {-# INLINE tabulate #-} rep = runKleisli {-# INLINE rep #-} instance Functor f => Representable (UpStar f) where type Rep (UpStar f) = f tabulate = UpStar {-# INLINE tabulate #-} rep = runUpStar {-# INLINE rep #-} type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) -- | 'tabulate' and 'rep' 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 rep) {-# 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 (Functor (Corep p), Profunctor p) => Corepresentable p where type Corep p :: * -> * cotabulate :: (Corep p d -> c) -> p d c corep :: p d c -> Corep p d -> c instance Corepresentable (->) where type Corep (->) = Identity cotabulate f = f . Identity {-# INLINE cotabulate #-} corep f (Identity d) = f d {-# INLINE corep #-} instance Functor w => Corepresentable (Cokleisli w) where type Corep (Cokleisli w) = w cotabulate = Cokleisli {-# INLINE cotabulate #-} corep = runCokleisli {-# INLINE corep #-} instance Corepresentable Tagged where type Corep Tagged = Proxy cotabulate f = Tagged (f Proxy) {-# INLINE cotabulate #-} corep (Tagged a) _ = a {-# INLINE corep #-} instance Functor f => Corepresentable (DownStar f) where type Corep (DownStar f) = f cotabulate = DownStar {-# INLINE cotabulate #-} corep = runDownStar {-# INLINE corep #-} -- | 'cotabulate' and 'corep' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'tabulated' :: 'Corep' f p => 'Iso'' (f d -> c) (p d c)@ cotabulated :: (Corepresentable p, Corepresentable q) => Iso (Corep p d -> c) (Corep q d' -> c') (p d c) (q d' c') cotabulated = dimap cotabulate (fmap corep) {-# INLINE cotabulated #-} profunctors-4.0.1/src/Data/Profunctor/Rift.hs0000644000000000000000000000462212226610741017334 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013 Edward Kmett and Dan Doel -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module Data.Profunctor.Rift ( Rift(..) , decomposeRift , precomposeRift ) where import Control.Category import Data.Profunctor.Unsafe import Data.Profunctor.Composition import Prelude hiding (id,(.)) -- | This represents the right Kan lift of a 'Profunctor' @q@ along a 'Profunctor' @p@ in a limited version of the 2-category of Profunctors where the only object is the category Hask, 1-morphisms are profunctors composed and compose with Profunctor composition, and 2-morphisms are just natural transformations. newtype Rift p q a b = Rift { runRift :: forall x. p x a -> q x b } -- Ran f g a = forall b. (a -> f b) -> g b instance (Profunctor p, Profunctor q) => Profunctor (Rift p q) where dimap ca bd f = Rift (rmap bd . runRift f . rmap ca) {-# INLINE dimap #-} lmap ca f = Rift (runRift f . rmap ca) {-# INLINE lmap #-} rmap bd f = Rift (rmap bd . runRift f) {-# INLINE rmap #-} bd #. f = Rift (\p -> bd #. runRift f p) {-# INLINE ( #. ) #-} f .# ca = Rift (\p -> runRift f (ca #. p)) {-# INLINE (.#) #-} instance Profunctor q => Functor (Rift p q a) where fmap bd f = Rift (rmap bd . runRift f) {-# INLINE fmap #-} -- | @'Rift' p p@ forms a 'Monad' in the 'Profunctor' 2-category, which is isomorphic to a Haskell 'Category' instance. instance p ~ q => Category (Rift p q) where id = Rift id {-# INLINE id #-} Rift f . Rift g = Rift (f . g) {-# INLINE (.) #-} -- | The 2-morphism that defines a right Kan lift. -- -- Note: When @f@ is left adjoint to @'Rift' f (->)@ then 'decomposeRift' is the 'counit' of the adjunction. decomposeRift :: Procompose q (Rift q p) a b -> p a b decomposeRift (Procompose q (Rift qp)) = qp q {-# INLINE decomposeRift #-} precomposeRift :: Profunctor q => Procompose (Rift p (->)) q a b -> Rift p q a b precomposeRift (Procompose pf p) = Rift (\pxa -> runRift pf pxa `lmap` p) {-# INLINE precomposeRift #-} profunctors-4.0.1/src/Data/Profunctor/Trace.hs0000644000000000000000000000112212226610741017456 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-4.0.1/src/Data/Profunctor/Unsafe.hs0000644000000000000000000001432512226610741017652 0ustar0000000000000000{-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Unsafe #-} #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: -- -- -- -- 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.Tagged import Prelude hiding (id,(.),sequence) import Unsafe.Coerce {-# 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@ ( #. ) :: (b -> c) -> p a b -> p a c ( #. ) = \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@ ( .# ) :: p b c -> (a -> b) -> p a c ( .# ) = \p -> p `seq` \f -> lmap f p {-# INLINE ( .# ) #-} instance Profunctor (->) where dimap ab cd bc = cd . bc . ab {-# INLINE dimap #-} lmap = flip (.) {-# INLINE lmap #-} rmap = (.) {-# INLINE rmap #-} ( #. ) _ = unsafeCoerce {-# INLINE ( #. ) #-} ( .# ) pbc _ = unsafeCoerce pbc {-# INLINE ( .# ) #-} instance Profunctor Tagged where dimap _ f (Tagged s) = Tagged (f s) {-# INLINE dimap #-} lmap _ = retag {-# INLINE lmap #-} rmap = fmap {-# INLINE rmap #-} ( #. ) _ = unsafeCoerce {-# 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'. ( .# ) pbc _ = unsafeCoerce pbc {-# 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'. ( #. ) _ = unsafeCoerce {-# INLINE ( #. ) #-}