profunctors-5.2.1/0000755000000000000000000000000013136741523012276 5ustar0000000000000000profunctors-5.2.1/.ghci0000644000000000000000000000012513136741523013207 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h profunctors-5.2.1/CHANGELOG.markdown0000644000000000000000000000760513136741523015341 0ustar00000000000000005.2.1 ----- * Allow `base-orphans-0.6`. * Add `Traversing` instance for `Forget` * Add `Traversing` and `Mapping` instances for `Procompose` * Add `Category` instance for `Star` * Add `mapCayley` to `Data.Profunctor.Cayley` * Add `pastro` and `unpastro` to `Data.Profunctor.Strong`. * Add `dimapWandering`, `lmapWandering`, and `rmapWandering` to `Data.Profunctor.Traversing` * Add documentation stating the laws for various profunctors. * Introduce the `Data.Profunctor.Yoneda` module. 5.2 --- * Renamed `Cotambara` to `TambaraChoice` and `Pastro` to `PastroChoice`. * Added a true `Cotambara` and `Copastro` construction for (co)freely generating costrength, along with `CotambaraSum` and `CopastroSum` variants. * Engaged in a fair bit of bikeshedding about the module structure for lesser used modules in this package. 5.1.2 ----- * Added `Prep` and `Coprep` along with witnesses to the adjunctions `Prep -| Star : [Hask,Hask] -> Prof` and `Coprep -| Costar : [Hask,Hask]^op -> Prof`. 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.2.1/README.markdown0000644000000000000000000000075013136741523015001 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.2.1/Setup.lhs0000644000000000000000000000016513136741523014110 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain profunctors-5.2.1/.vim.custom0000644000000000000000000000137713136741523014413 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.2.1/.travis.yml0000644000000000000000000001044013136741523014406 0ustar0000000000000000# This file has been generated -- see https://github.com/hvr/multi-ghc-travis language: c sudo: false cache: directories: - $HOME/.cabsnap - $HOME/.cabal/packages before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar matrix: include: - env: CABALVER=1.18 GHCVER=7.0.4 compiler: ": #GHC 7.0.4" addons: {apt: {packages: [cabal-install-1.18,ghc-7.0.4,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.2.2 compiler: ": #GHC 7.2.2" addons: {apt: {packages: [cabal-install-1.18,ghc-7.2.2,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.8.4 compiler: ": #GHC 7.8.4" addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.22 GHCVER=7.10.3 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,hlint], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=8.0.2 compiler: ": #GHC 8.0.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,hlint], sources: [hvr-ghc]}} - env: CABALVER=2.0 GHCVER=8.2.1 compiler: ": #GHC 8.2.1" addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,hlint], sources: [hvr-ghc]}} - env: CABALVER=head GHCVER=head compiler: ": #GHC head" addons: {apt: {packages: [cabal-install-head,ghc-head,hlint], sources: [hvr-ghc]}} allow_failures: - env: CABALVER=1.18 GHCVER=7.0.4 - env: CABALVER=1.18 GHCVER=7.2.2 - env: CABALVER=head GHCVER=head before_install: - unset CC - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH install: - cabal --version - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; then zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; fi - travis_retry cabal update -v - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - cabal install --only-dependencies --enable-tests --dry -v > installplan.txt - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt # check whether current requested install-plan matches cached package-db snapshot - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; then echo "cabal build-cache HIT"; rm -rfv .ghc; cp -a $HOME/.cabsnap/ghc $HOME/.ghc; cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; else echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; cabal install -j --only-dependencies --enable-tests; fi # snapshot package-db on cache miss - if [ ! -d $HOME/.cabsnap ]; then echo "snapshotting package-db to build-cache"; mkdir $HOME/.cabsnap; cp -a $HOME/.ghc $HOME/.cabsnap/ghc; cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; fi # Here starts the actual work to be performed for the package under # test; any command which exits with a non-zero exit code causes the # build to fail. 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}" # EOF profunctors-5.2.1/.gitignore0000644000000000000000000000012013136741523014257 0ustar0000000000000000dist/ .hsenv/ docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# :w profunctors-5.2.1/LICENSE0000644000000000000000000000266013136741523013307 0ustar0000000000000000Copyright 2011-2015 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.2.1/HLint.hs0000644000000000000000000000002313136741523013643 0ustar0000000000000000ignore "use const" profunctors-5.2.1/profunctors.cabal0000644000000000000000000000347313136741523015655 0ustar0000000000000000name: profunctors category: Control, Categories version: 5.2.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-2015 Edward A. Kmett synopsis: Profunctors description: Profunctors tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 build-type: Simple extra-source-files: .ghci .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, base-orphans >= 0.4 && < 0.7, bifunctors >= 5.2 && < 6, comonad >= 4 && < 6, contravariant >= 1 && < 2, distributive >= 0.4.4 && < 1, tagged >= 0.4.4 && < 1, transformers >= 0.2 && < 0.6 exposed-modules: Data.Profunctor Data.Profunctor.Adjunction Data.Profunctor.Cayley Data.Profunctor.Choice Data.Profunctor.Closed Data.Profunctor.Composition Data.Profunctor.Mapping Data.Profunctor.Monad Data.Profunctor.Ran Data.Profunctor.Rep Data.Profunctor.Sieve Data.Profunctor.Strong Data.Profunctor.Traversing Data.Profunctor.Types Data.Profunctor.Unsafe Data.Profunctor.Yoneda ghc-options: -Wall -O2 hs-source-dirs: src default-language: Haskell2010 other-extensions: CPP GADTs FlexibleContexts FlexibleInstances UndecidableInstances TypeFamilies profunctors-5.2.1/src/0000755000000000000000000000000013136741523013065 5ustar0000000000000000profunctors-5.2.1/src/Data/0000755000000000000000000000000013136741523013736 5ustar0000000000000000profunctors-5.2.1/src/Data/Profunctor.hs0000644000000000000000000000265313136741523016441 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 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(..) , uncurry' , Choice(..) -- ** Closed , Closed(..) , curry' , Mapping(..) -- ** Profunctorial Costrength , Costrong(..) , Cochoice(..) -- ** Common Profunctors , Star(..) , Costar(..) , WrappedArrow(..) , Forget(..) #ifndef HLINT , (:->) #endif ) where import Data.Profunctor.Choice import Data.Profunctor.Closed import Data.Profunctor.Mapping import Data.Profunctor.Strong import Data.Profunctor.Types profunctors-5.2.1/src/Data/Profunctor/0000755000000000000000000000000013136741523016077 5ustar0000000000000000profunctors-5.2.1/src/Data/Profunctor/Choice.hs0000644000000000000000000003727213136741523017640 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module Data.Profunctor.Choice ( -- * Strength Choice(..) , TambaraSum(..) , tambaraSum, untambaraSum , PastroSum(..) -- * Costrength , Cochoice(..) , CotambaraSum(..) , cotambaraSum, uncotambaraSum , CopastroSum(..) ) where import Control.Applicative hiding (WrappedArrow(..)) import Control.Arrow import Control.Category import Control.Comonad import Data.Bifunctor.Joker (Joker(..)) import Data.Bifunctor.Product (Product(..)) import Data.Bifunctor.Tannen (Tannen(..)) import Data.Monoid hiding (Product) import Data.Profunctor.Adjunction import Data.Profunctor.Monad import Data.Profunctor.Strong import Data.Profunctor.Types import Data.Profunctor.Unsafe import Data.Tagged #if __GLASGOW_HASKELL__ < 710 import Data.Traversable import Prelude hiding (id,(.),sequence) #else import Prelude hiding (id,(.)) #endif ------------------------------------------------------------------------------ -- Choice ------------------------------------------------------------------------------ -- | The generalization of 'Costar' of 'Functor' that is strong with respect -- to 'Either'. -- -- Note: This is also a notion of strength, except with regards to another monoidal -- structure that we can choose to equip Hask with: the cocartesian coproduct. class Profunctor p => Choice p where -- | Laws: -- -- @ -- 'left'' ≡ 'dimap' swapE swapE '.' 'right'' where -- swapE :: 'Either' a b -> 'Either' b a -- swapE = 'either' 'Right' 'Left' -- 'rmap' 'Left' ≡ 'lmap' 'Left' '.' 'left'' -- 'lmap' ('right' f) '.' 'left'' ≡ 'rmap' ('right' f) '.' 'left'' -- 'left'' '.' 'left'' ≡ 'dimap' assocE unassocE '.' 'left'' where -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c) -- assocE ('Left' ('Left' a)) = 'Left' a -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b) -- assocE ('Right' c) = 'Right' ('Right' c) -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c -- unassocE ('Left' a) = 'Left' ('Left' a) -- unassocE ('Right' ('Left' b) = 'Left' ('Right' b) -- unassocE ('Right' ('Right' c)) = 'Right' c) -- @ left' :: p a b -> p (Either a c) (Either b c) left' = dimap (either Right Left) (either Right Left) . right' -- | Laws: -- -- @ -- 'right'' ≡ 'dimap' swapE swapE '.' 'left'' where -- swapE :: 'Either' a b -> 'Either' b a -- swapE = 'either' 'Right' 'Left' -- 'rmap' 'Right' ≡ 'lmap' 'Right' '.' 'right'' -- 'lmap' ('left' f) '.' 'right'' ≡ 'rmap' ('left' f) '.' 'right'' -- 'right'' '.' 'right'' ≡ 'dimap' unassocE assocE '.' 'right'' where -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c) -- assocE ('Left' ('Left' a)) = 'Left' a -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b) -- assocE ('Right' c) = 'Right' ('Right' c) -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c -- unassocE ('Left' a) = 'Left' ('Left' a) -- unassocE ('Right' ('Left' b) = 'Left' ('Right' b) -- unassocE ('Right' ('Right' c)) = 'Right' c) -- @ right' :: p a b -> p (Either c a) (Either c b) right' = dimap (either Right Left) (either Right Left) . left' #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# MINIMAL left' | right' #-} #endif instance Choice (->) where left' ab (Left a) = Left (ab a) left' _ (Right c) = Right c {-# INLINE left' #-} right' = fmap {-# INLINE right' #-} instance Monad m => Choice (Kleisli m) where left' = left {-# INLINE left' #-} right' = right {-# INLINE right' #-} instance Applicative f => Choice (Star f) where left' (Star f) = Star $ either (fmap Left . f) (pure . Right) {-# INLINE left' #-} right' (Star f) = Star $ either (pure . Left) (fmap Right . f) {-# INLINE right' #-} -- | 'extract' approximates 'costrength' instance Comonad w => Choice (Cokleisli w) where left' = left {-# INLINE left' #-} right' = right {-# INLINE right' #-} -- NB: This instance is highly questionable instance Traversable w => Choice (Costar w) where left' (Costar wab) = Costar (either Right Left . fmap wab . traverse (either Right Left)) {-# INLINE left' #-} right' (Costar wab) = Costar (fmap wab . sequence) {-# INLINE right' #-} instance Choice Tagged where left' (Tagged b) = Tagged (Left b) {-# INLINE left' #-} right' (Tagged b) = Tagged (Right b) {-# INLINE right' #-} instance ArrowChoice p => Choice (WrappedArrow p) where left' (WrapArrow k) = WrapArrow (left k) {-# INLINE left' #-} right' (WrapArrow k) = WrapArrow (right k) {-# INLINE right' #-} instance Monoid r => Choice (Forget r) where left' (Forget k) = Forget (either k (const mempty)) {-# INLINE left' #-} right' (Forget k) = Forget (either (const mempty) k) {-# INLINE right' #-} instance Functor f => Choice (Joker f) where left' (Joker fb) = Joker (fmap Left fb) {-# INLINE left' #-} right' (Joker fb) = Joker (fmap Right fb) {-# INLINE right' #-} instance (Choice p, Choice q) => Choice (Product p q) where left' (Pair p q) = Pair (left' p) (left' q) {-# INLINE left' #-} right' (Pair p q) = Pair (right' p) (right' q) {-# INLINE right' #-} instance (Functor f, Choice p) => Choice (Tannen f p) where left' (Tannen fp) = Tannen (fmap left' fp) {-# INLINE left' #-} right' (Tannen fp) = Tannen (fmap right' fp) {-# INLINE right' #-} instance Choice p => Choice (Tambara p) where left' (Tambara f) = Tambara $ dimap hither yon $ left' f where hither :: (Either a b, c) -> Either (a, c) (b, c) hither (Left y, s) = Left (y, s) hither (Right z, s) = Right (z, s) yon :: Either (a, c) (b, c) -> (Either a b, c) yon (Left (y, s)) = (Left y, s) yon (Right (z, s)) = (Right z, s) ---------------------------------------------------------------------------- -- * TambaraSum ---------------------------------------------------------------------------- -- | TambaraSum is cofreely adjoins strength with respect to Either. -- -- Note: this is not dual to 'Data.Profunctor.Tambara.Tambara'. It is 'Data.Profunctor.Tambara.Tambara' with respect to a different tensor. newtype TambaraSum p a b = TambaraSum { runTambaraSum :: forall c. p (Either a c) (Either b c) } instance ProfunctorFunctor TambaraSum where promap f (TambaraSum p) = TambaraSum (f p) instance ProfunctorComonad TambaraSum where proextract (TambaraSum p) = dimap Left (\(Left a) -> a) p produplicate (TambaraSum p) = TambaraSum (TambaraSum $ dimap hither yon p) where hither :: Either (Either a b) c -> Either a (Either b c) hither (Left (Left x)) = Left x hither (Left (Right y)) = Right (Left y) hither (Right z) = Right (Right z) yon :: Either a (Either b c) -> Either (Either a b) c yon (Left x) = Left (Left x) yon (Right (Left y)) = Left (Right y) yon (Right (Right z)) = Right z instance Profunctor p => Profunctor (TambaraSum p) where dimap f g (TambaraSum p) = TambaraSum $ dimap (left f) (left g) p {-# INLINE dimap #-} instance Profunctor p => Choice (TambaraSum p) where left' = runTambaraSum . produplicate {-# INLINE left' #-} instance Category p => Category (TambaraSum p) where id = TambaraSum id TambaraSum p . TambaraSum q = TambaraSum (p . q) instance Profunctor p => Functor (TambaraSum p a) where fmap = rmap -- | -- @ -- 'tambaraSum' '.' 'untambaraSum' ≡ 'id' -- 'untambaraSum' '.' 'tambaraSum' ≡ 'id' -- @ tambaraSum :: Choice p => (p :-> q) -> p :-> TambaraSum q tambaraSum f p = TambaraSum $ f $ left' p -- | -- @ -- 'tambaraSum' '.' 'untambaraSum' ≡ 'id' -- 'untambaraSum' '.' 'tambaraSum' ≡ 'id' -- @ untambaraSum :: Profunctor q => (p :-> TambaraSum q) -> p :-> q untambaraSum f p = dimap Left (\(Left a) -> a) $ runTambaraSum $ f p ---------------------------------------------------------------------------- -- * PastroSum ---------------------------------------------------------------------------- -- | PastroSum -| TambaraSum -- -- PastroSum freely constructs strength with respect to Either. data PastroSum p a b where PastroSum :: (Either y z -> b) -> p x y -> (a -> Either x z) -> PastroSum p a b instance Profunctor (PastroSum p) where dimap f g (PastroSum l m r) = PastroSum (g . l) m (r . f) lmap f (PastroSum l m r) = PastroSum l m (r . f) rmap g (PastroSum l m r) = PastroSum (g . l) m r w #. PastroSum l m r = PastroSum (w #. l) m r PastroSum l m r .# w = PastroSum l m (r .# w) instance ProfunctorAdjunction PastroSum TambaraSum where counit (PastroSum f (TambaraSum g) h) = dimap h f g unit p = TambaraSum $ PastroSum id p id instance ProfunctorFunctor PastroSum where promap f (PastroSum l m r) = PastroSum l (f m) r instance ProfunctorMonad PastroSum where proreturn p = PastroSum (\(Left a)-> a) p Left projoin (PastroSum l (PastroSum m n o) q) = PastroSum lm n oq where oq a = case q a of Left b -> Left <$> o b Right z -> Right (Right z) lm (Left x) = l $ Left $ m $ Left x lm (Right (Left y)) = l $ Left $ m $ Right y lm (Right (Right z)) = l $ Right z instance Choice (PastroSum p) where left' (PastroSum l m r) = PastroSum l' m r' where r' = either (fmap Left . r) (Right . Right) l' (Left y) = Left (l (Left y)) l' (Right (Left z)) = Left (l (Right z)) l' (Right (Right c)) = Right c right' (PastroSum l m r) = PastroSum l' m r' where r' = either (Right . Left) (fmap Right . r) l' (Right (Left c)) = Left c l' (Right (Right z)) = Right (l (Right z)) l' (Left y) = Right (l (Left y)) -------------------------------------------------------------------------------- -- * Costrength for Either -------------------------------------------------------------------------------- class Profunctor p => Cochoice p where -- | Laws: -- -- @ -- 'unleft' ≡ 'unright' '.' 'dimap' swapE swapE where -- swapE :: 'Either' a b -> 'Either' b a -- swapE = 'either' 'Right' 'Left' -- 'rmap' ('either' 'id' 'absurd') ≡ 'unleft' '.' 'lmap' ('either' 'id' 'absurd') -- 'unfirst' '.' 'rmap' ('second' f) ≡ 'unfirst' '.' 'lmap' ('second' f) -- 'unleft' '.' 'unleft' ≡ 'unleft' '.' 'dimap' assocE unassocE where -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c) -- assocE ('Left' ('Left' a)) = 'Left' a -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b) -- assocE ('Right' c) = 'Right' ('Right' c) -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c -- unassocE ('Left' a) = 'Left' ('Left' a) -- unassocE ('Right' ('Left' b) = 'Left' ('Right' b) -- unassocE ('Right' ('Right' c)) = 'Right' c) -- @ unleft :: p (Either a d) (Either b d) -> p a b unleft = unright . dimap (either Right Left) (either Right Left) -- | Laws: -- -- @ -- 'unright' ≡ 'unleft' '.' 'dimap' swapE swapE where -- swapE :: 'Either' a b -> 'Either' b a -- swapE = 'either' 'Right' 'Left' -- 'rmap' ('either' 'absurd' 'id') ≡ 'unright' '.' 'lmap' ('either' 'absurd' 'id') -- 'unsecond' '.' 'rmap' ('first' f) ≡ 'unsecond' '.' 'lmap' ('first' f) -- 'unright' '.' 'unright' ≡ 'unright' '.' 'dimap' unassocE assocE where -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c) -- assocE ('Left' ('Left' a)) = 'Left' a -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b) -- assocE ('Right' c) = 'Right' ('Right' c) -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c -- unassocE ('Left' a) = 'Left' ('Left' a) -- unassocE ('Right' ('Left' b) = 'Left' ('Right' b) -- unassocE ('Right' ('Right' c)) = 'Right' c) -- @ unright :: p (Either d a) (Either d b) -> p a b unright = unleft . dimap (either Right Left) (either Right Left) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# MINIMAL unleft | unright #-} #endif instance Cochoice (->) where unleft f = go . Left where go = either id (go . Right) . f unright f = go . Right where go = either (go . Left) id . f instance Applicative f => Cochoice (Costar f) where unleft (Costar f) = Costar (go . fmap Left) where go = either id (go . pure . Right) . f -- NB: Another instance that's highly questionable instance Traversable f => Cochoice (Star f) where unright (Star f) = Star (go . Right) where go = either (go . Left) id . sequence . f instance (Functor f, Cochoice p) => Cochoice (Tannen f p) where unleft (Tannen fp) = Tannen (fmap unleft fp) {-# INLINE unleft #-} unright (Tannen fp) = Tannen (fmap unright fp) {-# INLINE unright #-} instance (Cochoice p, Cochoice q) => Cochoice (Product p q) where unleft (Pair p q) = Pair (unleft p) (unleft q) unright (Pair p q) = Pair (unright p) (unright q) ---------------------------------------------------------------------------- -- * CotambaraSum ---------------------------------------------------------------------------- -- | 'CotambaraSum' cofreely constructs costrength with respect to 'Either' (aka 'Choice') data CotambaraSum q a b where CotambaraSum :: Cochoice r => (r :-> q) -> r a b -> CotambaraSum q a b instance Profunctor (CotambaraSum p) where lmap f (CotambaraSum n p) = CotambaraSum n (lmap f p) rmap g (CotambaraSum n p) = CotambaraSum n (rmap g p) dimap f g (CotambaraSum n p) = CotambaraSum n (dimap f g p) instance ProfunctorFunctor CotambaraSum where promap f (CotambaraSum n p) = CotambaraSum (f . n) p instance ProfunctorComonad CotambaraSum where proextract (CotambaraSum n p) = n p produplicate (CotambaraSum n p) = CotambaraSum id (CotambaraSum n p) instance Cochoice (CotambaraSum p) where unleft (CotambaraSum n p) = CotambaraSum n (unleft p) unright (CotambaraSum n p) = CotambaraSum n (unright p) instance Functor (CotambaraSum p a) where fmap = rmap -- | -- @ -- 'cotambaraSum' '.' 'uncotambaraSum' ≡ 'id' -- 'uncotambaraSum' '.' 'cotambaraSum' ≡ 'id' -- @ cotambaraSum :: Cochoice p => (p :-> q) -> p :-> CotambaraSum q cotambaraSum = CotambaraSum -- | -- @ -- 'cotambaraSum' '.' 'uncotambaraSum' ≡ 'id' -- 'uncotambaraSum' '.' 'cotambaraSum' ≡ 'id' -- @ uncotambaraSum :: Profunctor q => (p :-> CotambaraSum q) -> p :-> q uncotambaraSum f p = proextract (f p) ---------------------------------------------------------------------------- -- * Copastro ---------------------------------------------------------------------------- -- | CopastroSum -| CotambaraSum -- -- 'CopastroSum' freely constructs costrength with respect to 'Either' (aka 'Choice') newtype CopastroSum p a b = CopastroSum { runCopastroSum :: forall r. Cochoice r => (forall x y. p x y -> r x y) -> r a b } instance Profunctor (CopastroSum p) where dimap f g (CopastroSum h) = CopastroSum $ \ n -> dimap f g (h n) lmap f (CopastroSum h) = CopastroSum $ \ n -> lmap f (h n) rmap g (CopastroSum h) = CopastroSum $ \ n -> rmap g (h n) instance ProfunctorAdjunction CopastroSum CotambaraSum where unit p = CotambaraSum id (proreturn p) counit (CopastroSum h) = proextract (h id) instance ProfunctorFunctor CopastroSum where promap f (CopastroSum h) = CopastroSum $ \n -> h (n . f) instance ProfunctorMonad CopastroSum where proreturn p = CopastroSum $ \n -> n p projoin p = CopastroSum $ \c -> runCopastroSum p (\x -> runCopastroSum x c) instance Cochoice (CopastroSum p) where unleft (CopastroSum p) = CopastroSum $ \n -> unleft (p n) unright (CopastroSum p) = CopastroSum $ \n -> unright (p n) profunctors-5.2.1/src/Data/Profunctor/Cayley.hs0000644000000000000000000001067313136741523017670 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- 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) mapCayley :: (forall a. f a -> g a) -> Cayley f p x y -> Cayley g p x y mapCayley f (Cayley g) = Cayley (f g) -- instance Adjunction f g => ProfunctorAdjunction (Cayley f) (Cayley g) where {- newtype Uncayley p a = Uncayley (p () a) instance Profunctor p => Functor (Uncayley p) where fmap f (Uncayley p) = Uncayley (rmap f p) smash :: Strong p => Cayley (Uncayley p) (->) a b -> p a b smash (Cayley (Uncayley pab)) = dimap ((,)()) (uncurry id) (first' pab) unsmash :: Closed p => p a b -> Cayley (Uncayley p) (->) a b unsmash = Cayley . Uncayley . curry' . lmap snd type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) -- pastro and street's strong tambara module class (Strong p, Closed p) => Stronger p -- only a true iso for Stronger p and q, no? _Smash :: (Strong p, Closed q) => Iso (Cayley (Uncayley p) (->) a b) (Cayley (Uncayley q) (->) c d) (p a b) (q c d) _Smash = dimap hither (fmap yon) where hither (Cayley (Uncayley pab)) = dimap ((,)()) (uncurry id) (first' pab) yon = Cayley . Uncayley . curry' . lmap snd fsmash :: (forall x y. p x y -> q x y) -> Cayley (Uncayley p) (->) a b -> Cayley (Uncayley q) (->) a b fsmash f (Cayley (Uncayley puab)) = Cayley (Uncayley (f puab)) -- | proposition 4.3 from pastro and street is that fsmash and funsmash form an equivalence of categories funsmash :: (Closed p, Strong q) => (forall x y. Cayley (Uncayley p) (->) x y -> Cayley (Uncayley q) (->) x y) -> p a b -> q a b funsmash k = smash . k . unsmash -} profunctors-5.2.1/src/Data/Profunctor/Ran.hs0000644000000000000000000001055213136741523017156 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013-2015 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 , Codensity(..) , decomposeCodensity ) where import Control.Category import Data.Profunctor import Data.Profunctor.Composition import Data.Profunctor.Monad import Data.Profunctor.Unsafe import Prelude hiding (id,(.)) -------------------------------------------------------------------------------- -- * Ran -------------------------------------------------------------------------------- -- | This represents the right Kan extension of a 'Profunctor' @q@ along a 'Profunctor' @p@ in a limited version of the 2-category of Profunctors where the only object is the category Hask, 1-morphisms are profunctors composed and compose with Profunctor composition, and 2-morphisms are just natural transformations. newtype Ran p q a b = Ran { runRan :: forall x. p x a -> q x b } 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 #-} -------------------------------------------------------------------------------- -- * Codensity -------------------------------------------------------------------------------- -- | This represents the right Kan extension of a 'Profunctor' @p@ along itself. This provides a generalization of the \"difference list\" trick to profunctors. newtype Codensity p a b = Codensity { runCodensity :: forall x. p x a -> p x b } instance Profunctor p => Profunctor (Codensity p) where dimap ca bd f = Codensity (rmap bd . runCodensity f . rmap ca) {-# INLINE dimap #-} lmap ca f = Codensity (runCodensity f . rmap ca) {-# INLINE lmap #-} rmap bd f = Codensity (rmap bd . runCodensity f) {-# INLINE rmap #-} bd #. f = Codensity (\p -> bd #. runCodensity f p) {-# INLINE ( #. ) #-} f .# ca = Codensity (\p -> runCodensity f (ca #. p)) {-# INLINE (.#) #-} instance Profunctor p => Functor (Codensity p a) where fmap bd f = Codensity (rmap bd . runCodensity f) {-# INLINE fmap #-} instance Category (Codensity p) where id = Codensity id {-# INLINE id #-} Codensity f . Codensity g = Codensity (f . g) {-# INLINE (.) #-} decomposeCodensity :: Procompose (Codensity p) p a b -> p a b decomposeCodensity (Procompose (Codensity pp) p) = pp p {-# INLINE decomposeCodensity #-} profunctors-5.2.1/src/Data/Profunctor/Sieve.hs0000644000000000000000000000446413136741523017516 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.2.1/src/Data/Profunctor/Traversing.hs0000644000000000000000000001476113136741523020570 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveFunctor #-} module Data.Profunctor.Traversing ( Traversing(..) , CofreeTraversing(..) , FreeTraversing(..) -- * Profunctor in terms of Traversing , dimapWandering , lmapWandering , rmapWandering -- * Strong in terms of Traversing , firstTraversing , secondTraversing -- * Choice in terms of Traversing , leftTraversing , rightTraversing ) where import Control.Applicative import Control.Arrow (Kleisli(..)) import Data.Functor.Compose import Data.Functor.Identity import Data.Orphans () import Data.Profunctor.Choice import Data.Profunctor.Monad import Data.Profunctor.Strong import Data.Profunctor.Types import Data.Profunctor.Unsafe import Data.Traversable import Data.Tuple (swap) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid) import Data.Foldable import Prelude hiding (mapM) #endif firstTraversing :: Traversing p => p a b -> p (a, c) (b, c) firstTraversing = dimap swap swap . traverse' secondTraversing :: Traversing p => p a b -> p (c, a) (c, b) secondTraversing = traverse' swapE :: Either a b -> Either b a swapE = either Right Left -- | A definition of 'dimap' for 'Traversing' instances that define -- an explicit 'wander'. dimapWandering :: Traversing p => (a' -> a) -> (b -> b') -> p a b -> p a' b' dimapWandering f g = wander (\afb a' -> g <$> afb (f a')) -- | 'lmapWandering' may be a more efficient implementation -- of 'lmap' than the default produced from 'dimapWandering'. lmapWandering :: Traversing p => (a -> b) -> p b c -> p a c lmapWandering f = wander (\afb a' -> afb (f a')) -- | 'rmapWandering' is the same as the default produced from -- 'dimapWandering'. rmapWandering :: Traversing p => (b -> c) -> p a b -> p a c rmapWandering g = wander (\afb a' -> g <$> afb a') leftTraversing :: Traversing p => p a b -> p (Either a c) (Either b c) leftTraversing = dimap swapE swapE . traverse' rightTraversing :: Traversing p => p a b -> p (Either c a) (Either c b) rightTraversing = traverse' newtype Bazaar a b t = Bazaar { runBazaar :: forall f. Applicative f => (a -> f b) -> f t } deriving Functor instance Applicative (Bazaar a b) where pure a = Bazaar $ \_ -> pure a mf <*> ma = Bazaar $ \k -> runBazaar mf k <*> runBazaar ma k instance Profunctor (Bazaar a) where dimap f g m = Bazaar $ \k -> g <$> runBazaar m (fmap f . k) sell :: a -> Bazaar a b b sell a = Bazaar $ \k -> k a newtype Baz t b a = Baz { runBaz :: forall f. Applicative f => (a -> f b) -> f t } deriving Functor -- bsell :: a -> Baz b b a -- bsell a = Baz $ \k -> k a -- aar :: Bazaar a b t -> Baz t b a -- aar (Bazaar f) = Baz f sold :: Baz t a a -> t sold m = runIdentity (runBaz m Identity) instance Foldable (Baz t b) where foldMap = foldMapDefault instance Traversable (Baz t b) where traverse f bz = fmap (\m -> Baz (runBazaar m)) . getCompose . runBaz bz $ \x -> Compose $ sell <$> f x instance Profunctor (Baz t) where dimap f g m = Baz $ \k -> runBaz m (fmap f . k . g) -- | Note: Definitions in terms of 'wander' are much more efficient! class (Choice p, Strong p) => Traversing p where -- | Laws: -- -- @ -- 'traverse'' ≡ 'wander' 'traverse' -- 'traverse'' '.' 'rmap' f ≡ 'rmap' ('fmap' f) '.' 'traverse'' -- 'traverse'' '.' 'traverse'' ≡ 'dimap' 'Compose' 'getCompose' '.' 'traverse'' -- 'dimap' 'Identity' 'runIdentity' '.' 'traverse'' ≡ 'id' -- @ traverse' :: Traversable f => p a b -> p (f a) (f b) traverse' = wander traverse -- | This combinator is mutually defined in terms of 'traverse'' wander :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> p a b -> p s t wander f pab = dimap (\s -> Baz $ \afb -> f afb s) sold (traverse' pab) #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL wander | traverse' #-} #endif instance Traversing (->) where traverse' = fmap wander f ab = runIdentity #. f (Identity #. ab) instance Monoid m => Traversing (Forget m) where traverse' (Forget h) = Forget (foldMap h) wander f (Forget h) = Forget (getConst . f (Const . h)) instance Monad m => Traversing (Kleisli m) where traverse' (Kleisli m) = Kleisli (mapM m) wander f (Kleisli amb) = Kleisli $ unwrapMonad #. f (WrapMonad #. amb) instance Applicative m => Traversing (Star m) where traverse' (Star m) = Star (traverse m) wander f (Star amb) = Star (f amb) newtype CofreeTraversing p a b = CofreeTraversing { runCofreeTraversing :: forall f. Traversable f => p (f a) (f b) } instance Profunctor p => Profunctor (CofreeTraversing p) where lmap f (CofreeTraversing p) = CofreeTraversing (lmap (fmap f) p) rmap g (CofreeTraversing p) = CofreeTraversing (rmap (fmap g) p) dimap f g (CofreeTraversing p) = CofreeTraversing (dimap (fmap f) (fmap g) p) instance Profunctor p => Strong (CofreeTraversing p) where second' = traverse' instance Profunctor p => Choice (CofreeTraversing p) where right' = traverse' instance Profunctor p => Traversing (CofreeTraversing p) where -- !@(#*&() Compose isn't representational in its second arg or we could use #. and .# traverse' (CofreeTraversing p) = CofreeTraversing (dimap Compose getCompose p) instance ProfunctorFunctor CofreeTraversing where promap f (CofreeTraversing p) = CofreeTraversing (f p) instance ProfunctorComonad CofreeTraversing where proextract (CofreeTraversing p) = runIdentity #. p .# Identity produplicate (CofreeTraversing p) = CofreeTraversing (CofreeTraversing (dimap Compose getCompose p)) -- | @FreeTraversing -| CofreeTraversing@ data FreeTraversing p a b where FreeTraversing :: Traversable f => (f y -> b) -> p x y -> (a -> f x) -> FreeTraversing p a b instance Profunctor (FreeTraversing p) where lmap f (FreeTraversing l m r) = FreeTraversing l m (r . f) rmap g (FreeTraversing l m r) = FreeTraversing (g . l) m r dimap f g (FreeTraversing l m r) = FreeTraversing (g . l) m (r . f) g #. FreeTraversing l m r = FreeTraversing (g #. l) m r FreeTraversing l m r .# f = FreeTraversing l m (r .# f) instance Strong (FreeTraversing p) where second' = traverse' instance Choice (FreeTraversing p) where right' = traverse' instance Traversing (FreeTraversing p) where traverse' (FreeTraversing l m r) = FreeTraversing (fmap l .# getCompose) m (Compose #. fmap r) instance ProfunctorFunctor FreeTraversing where promap f (FreeTraversing l m r) = FreeTraversing l (f m) r instance ProfunctorMonad FreeTraversing where proreturn p = FreeTraversing runIdentity p Identity projoin (FreeTraversing l (FreeTraversing l' m r') r) = FreeTraversing ((l . fmap l') .# getCompose) m (Compose #. (fmap r' . r)) profunctors-5.2.1/src/Data/Profunctor/Unsafe.hs0000644000000000000000000002162713136741523017664 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Trustworthy #-} #elif __GLASGOW_HASKELL >= 704 {-# LANGUAGE Unsafe #-} #endif {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 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.Biff (Biff(..)) import Data.Bifunctor.Clown (Clown(..)) import Data.Bifunctor.Joker (Joker(..)) import Data.Bifunctor.Product (Product(..)) import Data.Bifunctor.Tannen (Tannen(..)) #if __GLASGOW_HASKELL__ < 710 import Data.Functor #endif import Data.Functor.Contravariant (Contravariant(..)) import Data.Tagged import Prelude hiding (id,(.),sequence) #if __GLASGOW_HASKELL__ >= 708 import Data.Coerce #else import Unsafe.Coerce #endif #ifdef HLINT {-# ANN module "Hlint: ignore Redundant lambda" #-} {-# ANN module "Hlint: ignore Collapse lambdas" #-} #endif 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 #-} instance (Profunctor p, Functor f, Functor g) => Profunctor (Biff p f g) where lmap f (Biff p) = Biff (lmap (fmap f) p) rmap g (Biff p) = Biff (rmap (fmap g) p) dimap f g (Biff p) = Biff (dimap (fmap f) (fmap g) p) instance (Profunctor p, Profunctor q) => Profunctor (Product p q) where lmap f (Pair p q) = Pair (lmap f p) (lmap f q) {-# INLINE lmap #-} rmap g (Pair p q) = Pair (rmap g p) (rmap g q) {-# INLINE rmap #-} dimap f g (Pair p q) = Pair (dimap f g p) (dimap f g q) {-# INLINE dimap #-} ( #. ) f (Pair p q) = Pair (f #. p) (f #. q) {-# INLINE ( #. ) #-} ( .# ) (Pair p q) f = Pair (p .# f) (q .# f) {-# INLINE ( .# ) #-} instance (Functor f, Profunctor p) => Profunctor (Tannen f p) where lmap f (Tannen h) = Tannen (lmap f <$> h) {-# INLINE lmap #-} rmap g (Tannen h) = Tannen (rmap g <$> h) {-# INLINE rmap #-} dimap f g (Tannen h) = Tannen (dimap f g <$> h) {-# INLINE dimap #-} ( #. ) f (Tannen h) = Tannen ((f #.) <$> h) {-# INLINE ( #. ) #-} ( .# ) (Tannen h) f = Tannen ((.# f) <$> h) {-# INLINE ( .# ) #-} profunctors-5.2.1/src/Data/Profunctor/Yoneda.hs0000644000000000000000000001716113136741523017660 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2017 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types, TFs -- ---------------------------------------------------------------------------- module Data.Profunctor.Yoneda ( Yoneda(..), extractYoneda, duplicateYoneda , Coyoneda(..), returnCoyoneda, joinCoyoneda ) where import Control.Category import Data.Profunctor import Data.Profunctor.Monad import Data.Profunctor.Traversing import Data.Profunctor.Unsafe import Prelude hiding (id,(.)) #if __GLASGOW_HASKELL__ >= 708 import Data.Coerce #else import Unsafe.Coerce #endif -------------------------------------------------------------------------------- -- * Yoneda -------------------------------------------------------------------------------- -- | This is the cofree profunctor given a data constructor of kind @* -> * -> *@ newtype Yoneda p a b = Yoneda { runYoneda :: forall x y. (x -> a) -> (b -> y) -> p x y } -- Yoneda is a comonad on |*| -> Nat(|*|,*), we don't need the profunctor constraint to extract or duplicate -- | -- @ -- 'projoin' '.' 'extractYoneda' ≡ 'id' -- 'extractYoneda' '.' 'projoin' ≡ 'id' -- 'projoin' ≡ 'extractYoneda' -- @ extractYoneda :: Yoneda p a b -> p a b extractYoneda p = runYoneda p id id -- | -- @ -- 'projoin' '.' 'duplicateYoneda' ≡ 'id' -- 'duplicateYoneda' '.' 'projoin' ≡ 'id' -- 'duplicateYoneda' = 'proreturn' -- @ duplicateYoneda :: Yoneda p a b -> Yoneda (Yoneda p) a b duplicateYoneda p = Yoneda $ \l r -> dimap l r p instance Profunctor (Yoneda p) where dimap l r p = Yoneda $ \l' r' -> runYoneda p (l . l') (r' . r) {-# INLINE dimap #-} lmap l p = Yoneda $ \l' r -> runYoneda p (l . l') r {-# INLINE lmap #-} rmap r p = Yoneda $ \l r' -> runYoneda p l (r' . r) {-# INLINE rmap #-} #if __GLASGOW_HASKELL__ >= 708 ( .# ) p _ = coerce p {-# INLINE ( .# ) #-} ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b {-# INLINE ( #. ) #-} #else ( .# ) p _ = unsafeCoerce p {-# INLINE ( .# ) #-} ( #. ) _ = unsafeCoerce {-# INLINE ( #. ) #-} #endif instance Functor (Yoneda p a) where fmap f p = Yoneda $ \l r -> runYoneda p l (r . f) {-# INLINE fmap #-} instance ProfunctorFunctor Yoneda where promap f p = Yoneda $ \l r -> f (runYoneda p l r) {-# INLINE promap #-} instance ProfunctorComonad Yoneda where proextract p = runYoneda p id id {-# INLINE proextract #-} produplicate p = Yoneda $ \l r -> dimap l r p {-# INLINE produplicate #-} instance ProfunctorMonad Yoneda where proreturn p = Yoneda $ \l r -> dimap l r p {-# INLINE proreturn #-} projoin p = runYoneda p id id {-# INLINE projoin #-} instance (Category p, Profunctor p) => Category (Yoneda p) where id = Yoneda $ \l r -> dimap l r id {-# INLINE id #-} p . q = Yoneda $ \ l r -> runYoneda p id r . runYoneda q l id {-# INLINE (.) #-} instance Strong p => Strong (Yoneda p) where first' = proreturn . first' . extractYoneda {-# INLINE first' #-} second' = proreturn . second' . extractYoneda {-# INLINE second' #-} instance Choice p => Choice (Yoneda p) where left' = proreturn . left' . extractYoneda {-# INLINE left' #-} right' = proreturn . right' . extractYoneda {-# INLINE right' #-} instance Costrong p => Costrong (Yoneda p) where unfirst = proreturn . unfirst . extractYoneda {-# INLINE unfirst #-} unsecond = proreturn . unsecond . extractYoneda {-# INLINE unsecond #-} instance Cochoice p => Cochoice (Yoneda p) where unleft = proreturn . unleft . extractYoneda {-# INLINE unleft #-} unright = proreturn . unright . extractYoneda {-# INLINE unright #-} instance Closed p => Closed (Yoneda p) where closed = proreturn . closed . extractYoneda {-# INLINE closed #-} instance Mapping p => Mapping (Yoneda p) where map' = proreturn . map' . extractYoneda {-# INLINE map' #-} instance Traversing p => Traversing (Yoneda p) where traverse' = proreturn . traverse' . extractYoneda {-# INLINE traverse' #-} wander f = proreturn . wander f . extractYoneda {-# INLINE wander #-} -------------------------------------------------------------------------------- -- * Coyoneda -------------------------------------------------------------------------------- data Coyoneda p a b where Coyoneda :: (a -> x) -> (y -> b) -> p x y -> Coyoneda p a b -- Coyoneda is a Monad on |*| -> Nat(|*|,*), we don't need the profunctor constraint to extract or duplicate -- | -- @ -- 'returnCoyoneda' '.' 'proextract' ≡ 'id' -- 'proextract' '.' 'returnCoyoneda' ≡ 'id' -- 'produplicate' ≡ 'returnCoyoneda' -- @ returnCoyoneda :: p a b -> Coyoneda p a b returnCoyoneda = Coyoneda id id -- | -- @ -- 'joinCoyoneda' '.' 'produplicate' ≡ 'id' -- 'produplicate' '.' 'joinCoyoneda' ≡ 'id' -- 'joinCoyoneda' ≡ 'proextract' -- @ joinCoyoneda :: Coyoneda (Coyoneda p) a b -> Coyoneda p a b joinCoyoneda (Coyoneda l r p) = dimap l r p instance Profunctor (Coyoneda p) where dimap l r (Coyoneda l' r' p) = Coyoneda (l' . l) (r . r') p {-# INLINE dimap #-} lmap l (Coyoneda l' r p) = Coyoneda (l' . l) r p {-# INLINE lmap #-} rmap r (Coyoneda l r' p) = Coyoneda l (r . r') p {-# INLINE rmap #-} #if __GLASGOW_HASKELL__ >= 708 ( .# ) p _ = coerce p {-# INLINE ( .# ) #-} ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b {-# INLINE ( #. ) #-} #else ( .# ) p _ = unsafeCoerce p {-# INLINE ( .# ) #-} ( #. ) _ = unsafeCoerce {-# INLINE ( #. ) #-} #endif instance ProfunctorFunctor Coyoneda where promap f (Coyoneda l r p) = Coyoneda l r (f p) {-# INLINE promap #-} instance ProfunctorComonad Coyoneda where proextract (Coyoneda l r p) = dimap l r p {-# INLINE proextract #-} produplicate = Coyoneda id id {-# INLINE produplicate #-} instance ProfunctorMonad Coyoneda where proreturn = returnCoyoneda {-# INLINE proreturn #-} projoin = joinCoyoneda {-# INLINE projoin #-} instance (Category p, Profunctor p) => Category (Coyoneda p) where id = Coyoneda id id id {-# INLINE id #-} Coyoneda lp rp p . Coyoneda lq rq q = Coyoneda lq rp (p . rmap (lp . rq) q) {-# INLINE (.) #-} instance Strong p => Strong (Coyoneda p) where first' = returnCoyoneda . first' . proextract {-# INLINE first' #-} second' = returnCoyoneda . second' . proextract {-# INLINE second' #-} instance Choice p => Choice (Coyoneda p) where left' = returnCoyoneda . left' . proextract {-# INLINE left' #-} right' = returnCoyoneda . right' . proextract {-# INLINE right' #-} instance Costrong p => Costrong (Coyoneda p) where unfirst = returnCoyoneda . unfirst . proextract {-# INLINE unfirst #-} unsecond = returnCoyoneda . unsecond . proextract {-# INLINE unsecond #-} instance Cochoice p => Cochoice (Coyoneda p) where unleft = returnCoyoneda . unleft . proextract {-# INLINE unleft #-} unright = returnCoyoneda . unright . proextract {-# INLINE unright #-} instance Closed p => Closed (Coyoneda p) where closed = returnCoyoneda . closed . proextract {-# INLINE closed #-} instance Mapping p => Mapping (Coyoneda p) where map' = returnCoyoneda . map' . proextract {-# INLINE map' #-} instance Traversing p => Traversing (Coyoneda p) where traverse' = returnCoyoneda . traverse' . proextract {-# INLINE traverse' #-} wander f = returnCoyoneda . wander f . proextract {-# INLINE wander #-} profunctors-5.2.1/src/Data/Profunctor/Rep.hs0000644000000000000000000001707213136741523017170 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 , closedCorep -- * 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 :: * -> * -- | Laws: -- -- @ -- 'tabulate' '.' 'sieve' ≡ 'id' -- 'sieve' '.' 'tabulate' ≡ 'id' -- @ 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 #-} {- TODO: coproducts and products instance (Representable p, Representable q) => Representable (Bifunctor.Product p q) type Rep (Bifunctor.Product p q) = Functor.Product p q instance (Corepresentable p, Corepresentable q) => Corepresentable (Bifunctor.Product p q) where type Rep (Bifunctor.Product p q) = Functor.Sum p q -} type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) -- | 'tabulate' and 'sieve' form two halves of an isomorphism. -- -- 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 :: * -> * -- | Laws: -- -- @ -- 'cotabulate' '.' 'cosieve' ≡ 'id' -- 'cosieve' '.' 'cotabulate' ≡ 'id' -- @ 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) -- | Default definition for 'closed' given that @p@ is 'Corepresentable' closedCorep :: Corepresentable p => p a b -> p (x -> a) (x -> b) closedCorep p = cotabulate $ \fs x -> cosieve p (fmap ($x) fs) instance Corepresentable (->) where type Corep (->) = Identity 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.2.1/src/Data/Profunctor/Adjunction.hs0000644000000000000000000000157713136741523020543 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable, MPTCs, fundeps -- ---------------------------------------------------------------------------- module Data.Profunctor.Adjunction where import Data.Profunctor.Types import Data.Profunctor.Monad -- | Laws: -- -- @ -- 'unit' '.' 'counit' ≡ 'id' -- 'counit' '.' 'unit' ≡ 'id' -- @ class (ProfunctorFunctor f, ProfunctorFunctor u) => ProfunctorAdjunction f u | f -> u, u -> f where unit :: Profunctor p => p :-> u (f p) counit :: Profunctor p => f (u p) :-> p profunctors-5.2.1/src/Data/Profunctor/Types.hs0000644000000000000000000001544113136741523017544 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2015 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.Types ( Profunctor(dimap, lmap, rmap) , Star(..) , Costar(..) , WrappedArrow(..) , Forget(..) #ifndef HLINT , (:->) #endif ) where import Control.Applicative hiding (WrappedArrow(..)) import Control.Arrow import Control.Category import Control.Comonad import Control.Monad (MonadPlus(..)) import Data.Distributive import Data.Foldable import Data.Monoid hiding (Product) import Data.Profunctor.Unsafe import Data.Traversable import Prelude hiding (id,(.),sequence) #if __GLASGOW_HASKELL__ >= 708 import Data.Coerce #else import Unsafe.Coerce #endif infixr 0 :-> type p :-> q = forall a b. p a b -> q a b ------------------------------------------------------------------------------ -- Star ------------------------------------------------------------------------------ -- | Lift a 'Functor' into a 'Profunctor' (forwards). newtype Star f d c = Star { runStar :: d -> f c } instance Functor f => Profunctor (Star f) where dimap ab cd (Star bfc) = Star (fmap cd . bfc . ab) {-# INLINE dimap #-} lmap k (Star f) = Star (f . k) {-# INLINE lmap #-} rmap k (Star f) = Star (fmap k . f) {-# INLINE rmap #-} -- We cannot safely overload ( #. ) because we didn't write the 'Functor'. #if __GLASGOW_HASKELL__ >= 708 p .# _ = coerce p #else p .# _ = unsafeCoerce p #endif {-# INLINE ( .# ) #-} instance Functor f => Functor (Star f a) where fmap = rmap {-# INLINE fmap #-} instance Applicative f => Applicative (Star f a) where pure a = Star $ \_ -> pure a Star ff <*> Star fx = Star $ \a -> ff a <*> fx a Star ff *> Star fx = Star $ \a -> ff a *> fx a Star ff <* Star fx = Star $ \a -> ff a <* fx a instance Alternative f => Alternative (Star f a) where empty = Star $ \_ -> empty Star f <|> Star g = Star $ \a -> f a <|> g a instance Monad f => Monad (Star f a) where #if __GLASGOW_HASKELL__ < 710 return a = Star $ \_ -> return a #endif Star m >>= f = Star $ \ e -> do a <- m e runStar (f a) e instance MonadPlus f => MonadPlus (Star f a) where mzero = Star $ \_ -> mzero Star f `mplus` Star g = Star $ \a -> f a `mplus` g a instance Distributive f => Distributive (Star f a) where distribute fs = Star $ \a -> collect (($ a) .# runStar) fs instance Monad f => Category (Star f) where id = Star return Star f . Star g = Star $ \a -> g a >>= f ------------------------------------------------------------------------------ -- 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 #-} profunctors-5.2.1/src/Data/Profunctor/Strong.hs0000644000000000000000000003357513136741523017724 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : Rank2Types -- ---------------------------------------------------------------------------- module Data.Profunctor.Strong ( -- * Strength Strong(..) , uncurry' , Tambara(..) , tambara, untambara , Pastro(..) , pastro, unpastro -- * Costrength , Costrong(..) , Cotambara(..) , cotambara, uncotambara , Copastro(..) ) where import Control.Applicative hiding (WrappedArrow(..)) import Control.Arrow import Control.Category import Control.Comonad import Control.Monad (liftM) import Control.Monad.Fix import Data.Bifunctor.Clown (Clown(..)) import Data.Bifunctor.Product (Product(..)) import Data.Bifunctor.Tannen (Tannen(..)) import Data.Functor.Contravariant (Contravariant(..)) import Data.Monoid hiding (Product) import Data.Profunctor.Adjunction import Data.Profunctor.Monad import Data.Profunctor.Types import Data.Profunctor.Unsafe import Data.Tagged import Data.Tuple import Prelude hiding (id,(.)) ------------------------------------------------------------------------------ -- Strong ------------------------------------------------------------------------------ -- | Generalizing 'Star' of a strong 'Functor' -- -- /Note:/ Every 'Functor' in Haskell is strong with respect to @(,)@. -- -- This describes profunctor strength with respect to the product structure -- of Hask. -- -- -- class Profunctor p => Strong p where -- | Laws: -- -- @ -- 'first'' ≡ 'dimap' 'swap' 'swap' '.' 'second'' -- 'lmap' 'fst' ≡ 'rmap' 'fst' '.' 'first'' -- 'lmap' ('second' f) '.' 'first'' ≡ 'rmap' ('second' f) '.' 'first' -- 'first'' '.' 'first'' ≡ 'dimap' assoc unassoc '.' 'first'' where -- assoc ((a,b),c) = (a,(b,c)) -- unassoc (a,(b,c)) = ((a,b),c) -- @ first' :: p a b -> p (a, c) (b, c) first' = dimap swap swap . second' -- | Laws: -- -- @ -- 'second'' ≡ 'dimap' 'swap' 'swap' '.' 'first'' -- 'lmap' 'snd' ≡ 'rmap' 'snd' '.' 'second'' -- 'lmap' ('first' f) '.' 'second'' ≡ 'rmap' ('first' f) '.' 'second'' -- 'second'' '.' 'second'' ≡ 'dimap' unassoc assoc '.' 'second'' where -- assoc ((a,b),c) = (a,(b,c)) -- unassoc (a,(b,c)) = ((a,b),c) -- @ second' :: p a b -> p (c, a) (c, b) second' = dimap swap swap . first' #if __GLASGOW_HASKELL__ >= 708 {-# MINIMAL first' | second' #-} #endif uncurry' :: Strong p => p a (b -> c) -> p (a, b) c uncurry' = rmap (\(f,x) -> f x) . first' {-# INLINE uncurry' #-} instance Strong (->) where first' ab ~(a, c) = (ab a, c) {-# INLINE first' #-} second' ab ~(c, a) = (c, ab a) {-# INLINE second' #-} instance Monad m => Strong (Kleisli m) where first' (Kleisli f) = Kleisli $ \ ~(a, c) -> do b <- f a return (b, c) {-# INLINE first' #-} second' (Kleisli f) = Kleisli $ \ ~(c, a) -> do b <- f a return (c, b) {-# INLINE second' #-} instance Functor m => Strong (Star m) where first' (Star f) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a {-# INLINE first' #-} second' (Star f) = Star $ \ ~(c, a) -> (,) c <$> f a {-# INLINE second' #-} -- | 'Arrow' is 'Strong' 'Category' instance Arrow p => Strong (WrappedArrow p) where first' (WrapArrow k) = WrapArrow (first k) {-# INLINE first' #-} second' (WrapArrow k) = WrapArrow (second k) {-# INLINE second' #-} instance Strong (Forget r) where first' (Forget k) = Forget (k . fst) {-# INLINE first' #-} second' (Forget k) = Forget (k . snd) {-# INLINE second' #-} instance Contravariant f => Strong (Clown f) where first' (Clown fa) = Clown (contramap fst fa) {-# INLINE first' #-} second' (Clown fa) = Clown (contramap snd fa) {-# INLINE second' #-} instance (Strong p, Strong q) => Strong (Product p q) where first' (Pair p q) = Pair (first' p) (first' q) {-# INLINE first' #-} second' (Pair p q) = Pair (second' p) (second' q) {-# INLINE second' #-} instance (Functor f, Strong p) => Strong (Tannen f p) where first' (Tannen fp) = Tannen (fmap first' fp) {-# INLINE first' #-} second' (Tannen fp) = Tannen (fmap second' fp) {-# INLINE second' #-} ---------------------------------------------------------------------------- -- * Tambara ---------------------------------------------------------------------------- -- | 'Tambara' cofreely makes any 'Profunctor' 'Strong'. newtype Tambara p a b = Tambara { runTambara :: forall c. p (a, c) (b, c) } instance Profunctor p => Profunctor (Tambara p) where dimap f g (Tambara p) = Tambara $ dimap (first f) (first g) p {-# INLINE dimap #-} instance ProfunctorFunctor Tambara where promap f (Tambara p) = Tambara (f p) instance ProfunctorComonad Tambara where proextract (Tambara p) = dimap (\a -> (a,())) fst p produplicate (Tambara p) = Tambara (Tambara $ dimap hither yon p) where hither :: ((a, b), c) -> (a, (b, c)) hither ~(~(x,y),z) = (x,(y,z)) yon :: (a, (b, c)) -> ((a, b), c) yon ~(x,~(y,z)) = ((x,y),z) instance Profunctor p => Strong (Tambara p) where first' = runTambara . produplicate {-# INLINE first' #-} instance Category p => Category (Tambara p) where id = Tambara id Tambara p . Tambara q = Tambara (p . q) instance Arrow p => Arrow (Tambara p) where arr f = Tambara $ arr $ first f first (Tambara f) = Tambara (arr go . first f . arr go) where go :: ((a, b), c) -> ((a, c), b) go ~(~(x,y),z) = ((x,z),y) instance ArrowChoice p => ArrowChoice (Tambara p) where left (Tambara f) = Tambara (arr yon . left f . arr hither) where hither :: (Either a b, c) -> Either (a, c) (b, c) hither (Left y, s) = Left (y, s) hither (Right z, s) = Right (z, s) yon :: Either (a, c) (b, c) -> (Either a b, c) yon (Left (y, s)) = (Left y, s) yon (Right (z, s)) = (Right z, s) instance ArrowApply p => ArrowApply (Tambara p) where app = Tambara $ app . arr (\((Tambara f, x), s) -> (f, (x, s))) instance ArrowLoop p => ArrowLoop (Tambara p) where loop (Tambara f) = Tambara (loop (arr go . f . arr go)) where go :: ((a, b), c) -> ((a, c), b) go ~(~(x,y),z) = ((x,z),y) instance ArrowZero p => ArrowZero (Tambara p) where zeroArrow = Tambara zeroArrow instance ArrowPlus p => ArrowPlus (Tambara p) where Tambara f <+> Tambara g = Tambara (f <+> g) instance Profunctor p => Functor (Tambara p a) where fmap = rmap instance (Profunctor p, Arrow p) => Applicative (Tambara p a) where pure x = arr (const x) f <*> g = arr (uncurry id) . (f &&& g) instance (Profunctor p, ArrowPlus p) => Alternative (Tambara p a) where empty = zeroArrow f <|> g = f <+> g instance ArrowPlus p => Monoid (Tambara p a b) where mempty = zeroArrow mappend f g = f <+> g -- | -- @ -- 'tambara' ('untambara' f) ≡ f -- 'untambara' ('tambara' f) ≡ f -- @ tambara :: Strong p => (p :-> q) -> p :-> Tambara q tambara f p = Tambara $ f $ first' p -- | -- @ -- 'tambara' ('untambara' f) ≡ f -- 'untambara' ('tambara' f) ≡ f -- @ untambara :: Profunctor q => (p :-> Tambara q) -> p :-> q untambara f p = dimap (\a -> (a,())) fst $ runTambara $ f p ---------------------------------------------------------------------------- -- * Pastro ---------------------------------------------------------------------------- -- | Pastro -| Tambara -- -- @ -- Pastro p ~ exists z. Costar ((,)z) `Procompose` p `Procompose` Star ((,)z) -- @ -- -- 'Pastro' freely makes any 'Profunctor' 'Strong'. data Pastro p a b where Pastro :: ((y, z) -> b) -> p x y -> (a -> (x, z)) -> Pastro p a b instance Profunctor (Pastro p) where dimap f g (Pastro l m r) = Pastro (g . l) m (r . f) lmap f (Pastro l m r) = Pastro l m (r . f) rmap g (Pastro l m r) = Pastro (g . l) m r w #. Pastro l m r = Pastro (w #. l) m r Pastro l m r .# w = Pastro l m (r .# w) instance ProfunctorFunctor Pastro where promap f (Pastro l m r) = Pastro l (f m) r instance ProfunctorMonad Pastro where proreturn p = Pastro fst p $ \a -> (a,()) projoin (Pastro l (Pastro m n o) p) = Pastro lm n op where op a = case p a of (b, f) -> case o b of (c, g) -> (c, (f, g)) lm (d, (f, g)) = l (m (d, g), f) instance ProfunctorAdjunction Pastro Tambara where counit (Pastro g (Tambara p) f) = dimap f g p unit p = Tambara (Pastro id p id) instance Strong (Pastro p) where first' (Pastro l m r) = Pastro l' m r' where r' (a,c) = case r a of (x,z) -> (x,(z,c)) l' (y,(z,c)) = (l (y,z), c) second' (Pastro l m r) = Pastro l' m r' where r' (c,a) = case r a of (x,z) -> (x,(c,z)) l' (y,(c,z)) = (c,l (y,z)) -- | -- @ -- 'pastro' ('unpastro' f) ≡ f -- 'unpastro' ('pastro' f) ≡ f -- @ pastro :: Strong q => (p :-> q) -> Pastro p :-> q pastro f (Pastro r g l) = dimap l r (first' (f g)) -- | -- @ -- 'pastro' ('unpastro' f) ≡ f -- 'unpastro' ('pastro' f) ≡ f -- @ unpastro :: (Pastro p :-> q) -> p :-> q unpastro f p = f (Pastro fst p (\a -> (a, ()))) -------------------------------------------------------------------------------- -- * Costrength for (,) -------------------------------------------------------------------------------- -- | Analogous to 'ArrowLoop', 'loop' = 'unfirst' class Profunctor p => Costrong p where -- | Laws: -- -- @ -- 'unfirst' ≡ 'unsecond' '.' 'dimap' 'swap' 'swap' -- 'lmap' (,()) ≡ 'unfirst' '.' 'rmap' (,()) -- 'unfirst' '.' 'lmap' ('second' f) ≡ 'unfirst' '.' 'rmap' ('second' f) -- 'unfirst' '.' 'unfirst' = 'unfirst' '.' 'dimap' assoc unassoc where -- assoc ((a,b),c) = (a,(b,c)) -- unassoc (a,(b,c)) = ((a,b),c) -- @ unfirst :: p (a, d) (b, d) -> p a b unfirst = unsecond . dimap swap swap -- | Laws: -- -- @ -- 'unsecond' ≡ 'unfirst' '.' 'dimap' 'swap' 'swap' -- 'lmap' ((),) ≡ 'unsecond' '.' 'rmap' ((),) -- 'unsecond' '.' 'lmap' ('first' f) ≡ 'unsecond' '.' 'rmap' ('first' f) -- 'unsecond' '.' 'unsecond' = 'unsecond' '.' 'dimap' unassoc assoc where -- assoc ((a,b),c) = (a,(b,c)) -- unassoc (a,(b,c)) = ((a,b),c) -- @ unsecond :: p (d, a) (d, b) -> p a b unsecond = unfirst . dimap swap swap #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# MINIMAL unfirst | unsecond #-} #endif instance Costrong (->) where unfirst f a = b where (b, d) = f (a, d) unsecond f a = b where (d, b) = f (d, a) instance Functor f => Costrong (Costar f) where unfirst (Costar f) = Costar f' where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa) unsecond (Costar f) = Costar f' where f' fa = b where (d, b) = f ((,) d <$> fa) instance Costrong Tagged where unfirst (Tagged bd) = Tagged (fst bd) unsecond (Tagged db) = Tagged (snd db) instance ArrowLoop p => Costrong (WrappedArrow p) where unfirst (WrapArrow k) = WrapArrow (loop k) instance MonadFix m => Costrong (Kleisli m) where unfirst (Kleisli f) = Kleisli (liftM fst . mfix . f') where f' x y = f (x, snd y) instance Functor f => Costrong (Cokleisli f) where unfirst (Cokleisli f) = Cokleisli f' where f' fa = b where (b, d) = f ((\a -> (a, d)) <$> fa) instance (Functor f, Costrong p) => Costrong (Tannen f p) where unfirst (Tannen fp) = Tannen (fmap unfirst fp) unsecond (Tannen fp) = Tannen (fmap unsecond fp) instance (Costrong p, Costrong q) => Costrong (Product p q) where unfirst (Pair p q) = Pair (unfirst p) (unfirst q) unsecond (Pair p q) = Pair (unsecond p) (unsecond q) ---------------------------------------------------------------------------- -- * Cotambara ---------------------------------------------------------------------------- -- | Cotambara cofreely constructs costrength data Cotambara q a b where Cotambara :: Costrong r => (r :-> q) -> r a b -> Cotambara q a b instance Profunctor (Cotambara p) where lmap f (Cotambara n p) = Cotambara n (lmap f p) rmap g (Cotambara n p) = Cotambara n (rmap g p) dimap f g (Cotambara n p) = Cotambara n (dimap f g p) instance ProfunctorFunctor Cotambara where promap f (Cotambara n p) = Cotambara (f . n) p instance ProfunctorComonad Cotambara where proextract (Cotambara n p) = n p produplicate (Cotambara n p) = Cotambara id (Cotambara n p) instance Costrong (Cotambara p) where unfirst (Cotambara n p) = Cotambara n (unfirst p) instance Functor (Cotambara p a) where fmap = rmap -- | -- @ -- 'cotambara' '.' 'uncotambara' ≡ 'id' -- 'uncotambara' '.' 'cotambara' ≡ 'id' -- @ cotambara :: Costrong p => (p :-> q) -> p :-> Cotambara q cotambara = Cotambara -- | -- @ -- 'cotambara' '.' 'uncotambara' ≡ 'id' -- 'uncotambara' '.' 'cotambara' ≡ 'id' -- @ uncotambara :: Profunctor q => (p :-> Cotambara q) -> p :-> q uncotambara f p = proextract (f p) ---------------------------------------------------------------------------- -- * Copastro ---------------------------------------------------------------------------- -- | Copastro -| Cotambara -- -- Copastro freely constructs costrength newtype Copastro p a b = Copastro { runCopastro :: forall r. Costrong r => (forall x y. p x y -> r x y) -> r a b } instance Profunctor (Copastro p) where dimap f g (Copastro h) = Copastro $ \ n -> dimap f g (h n) lmap f (Copastro h) = Copastro $ \ n -> lmap f (h n) rmap g (Copastro h) = Copastro $ \ n -> rmap g (h n) instance ProfunctorAdjunction Copastro Cotambara where unit p = Cotambara id (proreturn p) counit (Copastro h) = proextract (h id) instance ProfunctorFunctor Copastro where promap f (Copastro h) = Copastro $ \n -> h (n . f) instance ProfunctorMonad Copastro where proreturn p = Copastro $ \n -> n p projoin p = Copastro $ \c -> runCopastro p (\x -> runCopastro x c) instance Costrong (Copastro p) where unfirst (Copastro p) = Copastro $ \n -> unfirst (p n) unsecond (Copastro p) = Copastro $ \n -> unsecond (p n) profunctors-5.2.1/src/Data/Profunctor/Closed.hs0000644000000000000000000001477513136741523017662 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Profunctor.Closed ( Closed(..) , Closure(..) , close , unclose , Environment(..) , curry' ) where import Control.Applicative import Control.Arrow import Control.Category import Control.Comonad import Data.Bifunctor.Product (Product(..)) import Data.Bifunctor.Tannen (Tannen(..)) import Data.Distributive import Data.Monoid hiding (Product) import Data.Profunctor.Adjunction import Data.Profunctor.Monad import Data.Profunctor.Strong import Data.Profunctor.Types import Data.Profunctor.Unsafe import Data.Tagged import Data.Tuple import Prelude hiding ((.),id) -------------------------------------------------------------------------------- -- * 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 -- | Laws: -- -- @ -- 'lmap' ('.' f) '.' 'closed' ≡ 'rmap' ('.' f) '.' 'closed' -- 'closed' '.' 'closed' ≡ 'dimap' 'uncurry' 'curry' '.' 'closed' -- 'dimap' 'const' ('$'()) '.' 'closed' ≡ 'id' -- @ closed :: p a b -> p (x -> a) (x -> b) instance Closed Tagged where 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 (Closed p, Closed q) => Closed (Product p q) where closed (Pair p q) = Pair (closed p) (closed q) instance (Functor f, Closed p) => Closed (Tannen f p) where closed (Tannen fp) = Tannen (fmap closed fp) -- instance Monoid r => Closed (Forget r) where -- closed _ = Forget $ \_ -> mempty curry' :: Closed p => p (a, b) c -> p a (b -> c) curry' = lmap (,) . closed -------------------------------------------------------------------------------- -- * Closure -------------------------------------------------------------------------------- -- | '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 (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) instance Closed (Environment p) where closed (Environment l m r) = Environment l' m r' where r' wa (z,w) = r (wa w) z l' zx2y x = l (\z -> zx2y (z,x)) profunctors-5.2.1/src/Data/Profunctor/Composition.hs0000644000000000000000000002716513136741523020751 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-2015 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 -- * Categories as monoid objects , eta , mu -- * 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.Mapping import Data.Profunctor.Monad import Data.Profunctor.Rep import Data.Profunctor.Sieve import Data.Profunctor.Traversing import Data.Profunctor.Unsafe import Prelude hiding ((.),id) 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 (Traversing p, Traversing q) => Traversing (Procompose p q) where traverse' (Procompose p q) = Procompose (traverse' p) (traverse' q) {-# INLINE traverse' #-} instance (Mapping p, Mapping q) => Mapping (Procompose p q) where map' (Procompose p q) = Procompose (map' p) (map' q) {-# INLINE map' #-} instance (Corepresentable p, Corepresentable q) => Costrong (Procompose p q) where unfirst = unfirstCorep {-# INLINE unfirst #-} unsecond = unsecondCorep {-# INLINE unsecond #-} -- * Lax identity -- | @(->)@ 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 ---------------------------------------------------------------------------- -- * Monoids ---------------------------------------------------------------------------- -- | a 'Category' that is also a 'Profunctor' is a 'Monoid' in @Prof@ eta :: (Profunctor p, Category p) => (->) :-> p eta f = rmap f id mu :: Category p => Procompose p p :-> p mu (Procompose f g) = f . g profunctors-5.2.1/src/Data/Profunctor/Monad.hs0000644000000000000000000000466313136741523017502 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Profunctor.Monad where import Control.Comonad import Data.Bifunctor.Tannen import Data.Bifunctor.Product import Data.Bifunctor.Sum import Data.Profunctor.Types class ProfunctorFunctor t where -- | Laws: -- -- @ -- 'promap' f '.' 'promap' g ≡ 'promap' (f '.' g) -- 'promap' 'id' ≡ 'id' -- @ promap :: Profunctor p => (p :-> q) -> t p :-> t q instance Functor f => ProfunctorFunctor (Tannen f) where promap f (Tannen g) = Tannen (fmap f g) instance ProfunctorFunctor (Product p) where promap f (Pair p q) = Pair p (f q) instance ProfunctorFunctor (Sum p) where promap _ (L2 p) = L2 p promap f (R2 q) = R2 (f q) -- | Laws: -- -- @ -- 'promap' f '.' 'proreturn' ≡ 'proreturn' '.' f -- 'projoin' '.' 'proreturn' ≡ 'id' -- 'projoin' '.' 'promap' 'proreturn' ≡ 'id' -- 'projoin' '.' 'projoin' ≡ 'projoin' '.' 'promap' 'projoin' -- @ class ProfunctorFunctor t => ProfunctorMonad t where proreturn :: Profunctor p => p :-> t p projoin :: Profunctor p => t (t p) :-> t p #if __GLASGOW_HASKELL__ < 710 instance (Functor f, Monad f) => ProfunctorMonad (Tannen f) where #else instance Monad f => ProfunctorMonad (Tannen f) where #endif proreturn = Tannen . return projoin (Tannen m) = Tannen $ m >>= runTannen instance ProfunctorMonad (Sum p) where proreturn = R2 projoin (L2 p) = L2 p projoin (R2 m) = m -- | Laws: -- -- @ -- 'proextract' '.' 'promap' f ≡ f '.' 'proextract' -- 'proextract' '.' 'produplicate' ≡ 'id' -- 'promap' 'proextract' '.' 'produplicate' ≡ 'id' -- 'produplicate' '.' 'produplicate' ≡ 'promap' 'produplicate' '.' 'produplicate' -- @ class ProfunctorFunctor t => ProfunctorComonad t where proextract :: Profunctor p => t p :-> p produplicate :: Profunctor p => t p :-> t (t p) instance Comonad f => ProfunctorComonad (Tannen f) where proextract = extract . runTannen produplicate (Tannen w) = Tannen $ extend Tannen w instance ProfunctorComonad (Product p) where proextract (Pair _ q) = q produplicate pq@(Pair p _) = Pair p pq profunctors-5.2.1/src/Data/Profunctor/Mapping.hs0000644000000000000000000000741013136741523020030 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} module Data.Profunctor.Mapping ( Mapping(..) , CofreeMapping(..) , FreeMapping(..) -- * Closed in terms of Mapping , traverseMapping , closedMapping ) where import Control.Arrow (Kleisli(..)) import Data.Distributive import Data.Functor.Compose import Data.Functor.Identity import Data.Profunctor.Choice import Data.Profunctor.Closed import Data.Profunctor.Monad import Data.Profunctor.Strong import Data.Profunctor.Traversing import Data.Profunctor.Types import Data.Profunctor.Unsafe #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif class (Traversing p, Closed p) => Mapping p where -- | Laws: -- -- @ -- 'map'' '.' 'rmap' f ≡ 'rmap' ('fmap' f) '.' 'map'' -- 'map'' '.' 'map'' ≡ 'dimap' 'Data.Functor.Compose.Compose' 'Data.Functor.Compose.getCompose' '.' 'map'' -- 'dimap' 'Data.Functor.Identity.Identity' 'Data.Functor.Identity.runIdentity' '.' 'map'' ≡ 'id' -- @ map' :: Functor f => p a b -> p (f a) (f b) instance Mapping (->) where map' = fmap instance (Monad m, Distributive m) => Mapping (Kleisli m) where map' (Kleisli f) = Kleisli (collect f) -- see instance (Applicative m, Distributive m) => Mapping (Star m) where map' (Star f) = Star (collect f) traverseMapping :: (Mapping p, Functor f) => p a b -> p (f a) (f b) traverseMapping = map' closedMapping :: Mapping p => p a b -> p (x -> a) (x -> b) closedMapping = map' newtype CofreeMapping p a b = CofreeMapping { runCofreeMapping :: forall f. Functor f => p (f a) (f b) } instance Profunctor p => Profunctor (CofreeMapping p) where lmap f (CofreeMapping p) = CofreeMapping (lmap (fmap f) p) rmap g (CofreeMapping p) = CofreeMapping (rmap (fmap g) p) dimap f g (CofreeMapping p) = CofreeMapping (dimap (fmap f) (fmap g) p) instance Profunctor p => Strong (CofreeMapping p) where second' = map' instance Profunctor p => Choice (CofreeMapping p) where right' = map' instance Profunctor p => Closed (CofreeMapping p) where closed = map' instance Profunctor p => Traversing (CofreeMapping p) where traverse' = map' instance Profunctor p => Mapping (CofreeMapping p) where -- !@(#*&() Compose isn't representational in its second arg or we could use #. and .# map' (CofreeMapping p) = CofreeMapping (dimap Compose getCompose p) instance ProfunctorFunctor CofreeMapping where promap f (CofreeMapping p) = CofreeMapping (f p) instance ProfunctorComonad CofreeMapping where proextract (CofreeMapping p) = runIdentity #. p .# Identity produplicate (CofreeMapping p) = CofreeMapping (CofreeMapping (dimap Compose getCompose p)) -- | @FreeMapping -| CofreeMapping@ data FreeMapping p a b where FreeMapping :: Functor f => (f y -> b) -> p x y -> (a -> f x) -> FreeMapping p a b instance Profunctor (FreeMapping p) where lmap f (FreeMapping l m r) = FreeMapping l m (r . f) rmap g (FreeMapping l m r) = FreeMapping (g . l) m r dimap f g (FreeMapping l m r) = FreeMapping (g . l) m (r . f) g #. FreeMapping l m r = FreeMapping (g #. l) m r FreeMapping l m r .# f = FreeMapping l m (r .# f) instance Strong (FreeMapping p) where second' = map' instance Choice (FreeMapping p) where right' = map' instance Closed (FreeMapping p) where closed = map' instance Traversing (FreeMapping p) where traverse' = map' instance Mapping (FreeMapping p) where map' (FreeMapping l m r) = FreeMapping (fmap l .# getCompose) m (Compose #. fmap r) instance ProfunctorFunctor FreeMapping where promap f (FreeMapping l m r) = FreeMapping l (f m) r instance ProfunctorMonad FreeMapping where proreturn p = FreeMapping runIdentity p Identity projoin (FreeMapping l (FreeMapping l' m r') r) = FreeMapping ((l . fmap l') .# getCompose) m (Compose #. (fmap r' . r))