kan-extensions-5.2/0000755000000000000000000000000013316662462012525 5ustar0000000000000000kan-extensions-5.2/.ghci0000644000000000000000000000012513316662462013436 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h kan-extensions-5.2/CHANGELOG.markdown0000644000000000000000000000637513316662462015573 0ustar00000000000000005.2 [2018.07.03] ---------------- * Make `Codensity` levity polymorphic. * Add the `Data.Functor.Invariant.Day` module, which combines the covariant and contravariant versions of `Day`. As a result, `kan-extensions` now depends on the `invariant` package. * Add a `wrapCodensity` function. * More efficient `Eq1`, `Ord1`, and `Adjunction` instances for `Coyoneda`. * Add `INLINE` pragmas on more functions. * Allow building with `containers-0.6`. 5.1 [2018.01.28] ---------------- * Make `Density`, `Codensity`, `Kan` and `Lan` polykinded. * Add `Eq1`, `Ord1`, `Read1` and `Show1` instances for `Coyoneda` and `Yoneda`. * Change contexts of `Eq` and `Ord` instances of `Coyoneda` and `Yoneda` (and the `Show` instance for `Coyoneda`) to require lifted class instances, e.g. `Eq1 f, Eq a`. * Allow `free-5`. 5.0.2 ----- * Added `hoistCoyoneda` 5.0.1 ----- * Removed some redundant constraints 5 ----- * Move `Data.Functor.Kan.Rift` to `Data.Functor.Day.Curried` 4.2.3 ----- * Builds clean on GHC 7.10 4.2.2 ----- * `semigroupoids` 5 support 4.2.1 --- * Add `liftRift` and `lowerRift` 4.2 --- * Remove pointed dependency 4.1.1 --- * Added `Applicative` instance for `Day` * Added `Typeable` instance for `Codensity` 4.1.0.1 ---- * Added `tagged` dependency 4.1 --- * Moved co- and contra- variant `Day` convolution from `contravariant` to here. Day convolution is intimately connected to `Rift`. 4.0.3 ----- * Added `liftCoT0M`, `liftCoT1M`, `diter` and `dctrlM` for using `CoT w m` to model a state machine with states in `w` and effects in `m`. 4.0.2 ----- * Made fixes necessary to work around changes in `ImpredicativeTypes` for GHC 7.8.1rc2 4.0.1 ----- * Bug fix so we can compile on GHC 7.4 4.0 --- * Removed `keys` dependency * Now compatible with `adjunctions` 4.0 3.7 --- * Moved all the `Yoneda` variants around again. * Improved haddocks 3.6.2 ----- * Added `Data.Functor.Contravariant.Yoneda` to complete the set of Yoneda embeddings/reductions. 3.6.1 ----- * Added several missing isomorphisms 3.6 --- * `instance Monad m => MonadSpec (Yoneda m)` 3.5.1 ----- * Fixed a bug in the signature for `composedRepToCodensity`. 3.5 --- * More combinators for `Rift`/`Lift`. * Added combinators for working with representable functors rather than just adjoint functors. * Split `Data.Functor.KanExtension` into `Data.Functor.Kan.Ran` and `Data.Functor.Kan.Lan` * Split `Data.Functor.KanLift` into `Data.Functor.Kan.Rift` and `Data.Functor.Kan.Lift` * Moved from `Data.Functor.Yoneda.Contravariant` to `Data.Functor.Yoneda.Reduction` adopting terminology from Todd Trimble. * Added various missing isomorphisms. * Greatly improved the Haddocks for this package stating laws and derivations where we can (especially for 'Rift' and 'Ran'). 3.3 --- * Rift is now `Applicative`. Added `rap`. 3.2 --- * Added right and left Kan lifts under `Data.Functor.KanLift`. * Decreased reliance on the `Composition` class where unnecessary in the API 3.1.2 ----- * Marked modules `Trustworthy` as required for `SafeHaskell` in the presence of these extensions. 3.1.1 ----- * Refactored build system * IRC build-bot notification * Removed upper bounds on dependencies on my other packages 3.1 --- * Moved `Control.Monad.Free.Church` over to the `free` package instead and removed it from `kan-extensions` kan-extensions-5.2/kan-extensions.cabal0000644000000000000000000000532313316662462016462 0ustar0000000000000000name: kan-extensions category: Data Structures, Monads, Comonads, Functors version: 5.2 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/kan-extensions/ bug-reports: http://github.com/ekmett/kan-extensions/issues copyright: Copyright (C) 2008-2016 Edward A. Kmett synopsis: Kan extensions, Kan lifts, the Yoneda lemma, and (co)density (co)monads description: Kan extensions, Kan lifts, various forms of the Yoneda lemma, and (co)density (co)monads. build-type: Simple tested-with: GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.3 , GHC == 8.6.1 extra-source-files: .travis.yml .gitignore .ghci .vim.custom CHANGELOG.markdown README.markdown include/kan-extensions-common.h source-repository head type: git location: git://github.com/ekmett/kan-extensions.git library hs-source-dirs: src include-dirs: include includes: kan-extensions-common.h other-extensions: CPP MultiParamTypeClasses GADTs Rank2Types, FlexibleInstances FlexibleContexts UndecidableInstances TypeFamilies build-depends: adjunctions >= 4.2 && < 5, array >= 0.3.0.2 && < 0.6, base >= 4.4 && < 5, comonad >= 4 && < 6, containers >= 0.4 && < 0.7, contravariant >= 1 && < 2, distributive >= 0.2.2 && < 1, invariant >= 0.1 && < 1, free >= 4 && < 6, mtl >= 2.0.1 && < 2.3, profunctors >= 5 && < 6, semigroupoids >= 4 && < 6, tagged >= 0.7.2 && < 1, transformers >= 0.2 && < 0.6, transformers-compat >= 0.3 && < 0.7 exposed-modules: Control.Comonad.Density Control.Monad.Co Control.Monad.Codensity Data.Functor.Contravariant.Day Data.Functor.Contravariant.Yoneda Data.Functor.Contravariant.Coyoneda Data.Functor.Day Data.Functor.Day.Curried Data.Functor.Invariant.Day Data.Functor.Kan.Lan Data.Functor.Kan.Ran Data.Functor.Yoneda Data.Functor.Coyoneda ghc-options: -Wall if impl(ghc >= 7.10) ghc-options: -fno-warn-trustworthy-safe -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0 if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances else build-depends: fail >= 4.9 && < 5 kan-extensions-5.2/README.markdown0000644000000000000000000000174613316662462015236 0ustar0000000000000000kan-extensions ============== [![Hackage](https://img.shields.io/hackage/v/kan-extensions.svg)](https://hackage.haskell.org/package/kan-extensions) [![Build Status](https://secure.travis-ci.org/ekmett/kan-extensions.png?branch=master)](http://travis-ci.org/ekmett/kan-extensions) This package provides tools for working with various Kan extensions and Kan lifts in Haskell. Among the interesting bits included are: * Right and left Kan extensions (`Ran` and `Lan`) * Right and left Kan lifts (`Rift` and `Lift`) * Multiple forms of the Yoneda lemma (`Yoneda`) * The `Codensity` monad, which can be used to improve the asymptotic complexity of code over free monads (`Codensity`, `Density`) * A "comonad to monad-transformer transformer" that is a special case of a right Kan lift. (`CoT`, `Co`) 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 kan-extensions-5.2/Setup.lhs0000644000000000000000000000016513316662462014337 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain kan-extensions-5.2/.vim.custom0000644000000000000000000000137713316662462014642 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" kan-extensions-5.2/.travis.yml0000644000000000000000000001533313316662462014643 0ustar0000000000000000# This Travis job script has been generated by a script via # # runghc make_travis_yml_2.hs '-o' '.travis.yml' '--ghc-head' '--irc-channel=irc.freenode.org#haskell-lens' '--no-no-tests-no-bench' '--no-unconstrained' 'cabal.project' # # For more information, see https://github.com/hvr/multi-ghc-travis # language: c sudo: false git: submodules: false # whether to recursively clone submodules notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313kan-extensions\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx - rm -rfv $HOME/.cabal/packages/head.hackage matrix: include: - compiler: "ghc-8.6.1" env: GHCHEAD=true addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}} - compiler: "ghc-8.4.3" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}} - compiler: "ghc-8.2.2" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}} - compiler: "ghc-8.0.2" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}} - compiler: "ghc-7.10.3" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}} - compiler: "ghc-7.8.4" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.8.4], sources: [hvr-ghc]}} - compiler: "ghc-7.6.3" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.6.3], sources: [hvr-ghc]}} - compiler: "ghc-7.4.2" # env: TEST=--disable-tests BENCH=--disable-benchmarks addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.4.2], sources: [hvr-ghc]}} - compiler: "ghc-head" env: GHCHEAD=true addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} allow_failures: - compiler: "ghc-head" - compiler: "ghc-8.6.1" before_install: - HC=${CC} - HCPKG=${HC/ghc/ghc-pkg} - unset CC - ROOTDIR=$(pwd) - mkdir -p $HOME/.local/bin - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - echo $HCNUMVER install: - cabal --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - BENCH=${BENCH---enable-benchmarks} - TEST=${TEST---enable-tests} - HADDOCK=${HADDOCK-true} - UNCONSTRAINED=${UNCONSTRAINED-true} - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false} - GHCHEAD=${GHCHEAD-false} - travis_retry cabal update -v - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" - rm -fv cabal.project cabal.project.local # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage - | if $GHCHEAD; then sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done echo 'repository head.hackage' >> ${HOME}/.cabal/config echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config echo ' secure: True' >> ${HOME}/.cabal/config echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config echo ' key-threshold: 3' >> ${HOME}/.cabal.config grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' cabal new-update head.hackage -v fi - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - "printf 'packages: \".\"\\n' > cabal.project" - touch cabal.project.local - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" - cat cabal.project || true - cat cabal.project.local || true - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - rm -f cabal.project.freeze - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all - rm -rf .ghc.environment.* "."/dist - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # 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: # test that source-distributions can be generated - (cd "." && cabal sdist) - mv "."/dist/kan-extensions-*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - "printf 'packages: kan-extensions-*/*.cabal\\n' > cabal.project" - touch cabal.project.local - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" - cat cabal.project || true - cat cabal.project.local || true # build & run tests, build benchmarks - cabal new-build -w ${HC} ${TEST} ${BENCH} all # cabal check - (cd kan-extensions-* && cabal check) # haddock - rm -rf ./dist-newstyle - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi # REGENDATA ["-o",".travis.yml","--ghc-head","--irc-channel=irc.freenode.org#haskell-lens","--no-no-tests-no-bench","--no-unconstrained","cabal.project"] # EOF kan-extensions-5.2/.gitignore0000644000000000000000000000047013316662462014516 0ustar0000000000000000dist dist-newstyle docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# .stack-work/ cabal-dev *.chi *.chs.h *.dyn_o *.dyn_hi .hpc .hsenv .cabal-sandbox/ cabal.sandbox.config *.prof *.aux *.hp *.eventlog cabal.project.local cabal.project.local~ .HTF/ .ghc.environment.* /default.nix /shell.nix /result kan-extensions-5.2/LICENSE0000644000000000000000000000266013316662462013536 0ustar0000000000000000Copyright 2008-2016 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. kan-extensions-5.2/include/0000755000000000000000000000000013316662462014150 5ustar0000000000000000kan-extensions-5.2/include/kan-extensions-common.h0000644000000000000000000000062713316662462020562 0ustar0000000000000000#ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_mtl #define MIN_VERSION_mtl(x,y,z) 1 #endif #if MIN_VERSION_base(4,9,0) #define LIFTED_FUNCTOR_CLASSES 1 #else #if MIN_VERSION_transformers(0,5,0) #define LIFTED_FUNCTOR_CLASSES 1 #else #if MIN_VERSION_transformers_compat(0,5,0) && !MIN_VERSION_transformers(0,4,0) #define LIFTED_FUNCTOR_CLASSES 1 #endif #endif #endif kan-extensions-5.2/src/0000755000000000000000000000000013316662462013314 5ustar0000000000000000kan-extensions-5.2/src/Control/0000755000000000000000000000000013316662462014734 5ustar0000000000000000kan-extensions-5.2/src/Control/Monad/0000755000000000000000000000000013316662462015772 5ustar0000000000000000kan-extensions-5.2/src/Control/Monad/Codensity.hs0000644000000000000000000002116713316662462020276 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 802) {-# LANGUAGE DeriveDataTypeable #-} #endif #if __GLASGOW_HASKELL__ >= 802 {-# LANGUAGE TypeInType #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Codensity -- Copyright : (C) 2008-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable (rank-2 polymorphism) -- ---------------------------------------------------------------------------- module Control.Monad.Codensity ( Codensity(..) , lowerCodensity , codensityToAdjunction, adjunctionToCodensity , codensityToRan, ranToCodensity , codensityToComposedRep, composedRepToCodensity , wrapCodensity , improve ) where import Control.Applicative import Control.Monad (MonadPlus(..)) import qualified Control.Monad.Fail as Fail import Control.Monad.Free import Control.Monad.IO.Class import Control.Monad.Reader.Class import Control.Monad.State.Class import Control.Monad.Trans.Class import Data.Functor.Adjunction import Data.Functor.Apply import Data.Functor.Kan.Ran import Data.Functor.Plus import Data.Functor.Rep #if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 800) import Data.Typeable #endif #if __GLASGOW_HASKELL__ >= 802 import GHC.Exts (TYPE) #endif -- | -- @'Codensity' f@ is the Monad generated by taking the right Kan extension -- of any 'Functor' @f@ along itself (@Ran f f@). -- -- This can often be more \"efficient\" to construct than @f@ itself using -- repeated applications of @(>>=)@. -- -- See \"Asymptotic Improvement of Computations over Free Monads\" by Janis -- Voigtländer for more information about this type. -- -- #if __GLASGOW_HASKELL__ >= 802 newtype Codensity (m :: k -> TYPE rep) a = Codensity -- Note: we *could* generalize @a@ to @TYPE repa@, but the 'Functor' -- instance wouldn't carry that, so it doesn't really seem worth -- the complication. #else newtype Codensity m a = Codensity #endif { runCodensity :: forall b. (a -> m b) -> m b } #if (__GLASGOW_HASKELL__ >= 708) && (__GLASGOW_HASKELL__ < 800) deriving Typeable #endif #if __GLASGOW_HASKELL__ >= 802 instance Functor (Codensity (k :: j -> TYPE rep)) where #else instance Functor (Codensity k) where #endif fmap f (Codensity m) = Codensity (\k -> m (\x -> k (f x))) {-# INLINE fmap #-} #if __GLASGOW_HASKELL__ >= 802 instance Apply (Codensity (f :: k -> TYPE rep)) where #else instance Apply (Codensity f) where #endif (<.>) = (<*>) {-# INLINE (<.>) #-} #if __GLASGOW_HASKELL__ >= 802 instance Applicative (Codensity (f :: k -> TYPE rep)) where #else instance Applicative (Codensity f) where #endif pure x = Codensity (\k -> k x) {-# INLINE pure #-} Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (\x -> bfr (ab x)))) {-# INLINE (<*>) #-} #if __GLASGOW_HASKELL__ >= 802 instance Monad (Codensity (f :: k -> TYPE rep)) where #else instance Monad (Codensity f) where #endif return = pure {-# INLINE return #-} m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c)) {-# INLINE (>>=) #-} instance Fail.MonadFail f => Fail.MonadFail (Codensity f) where fail msg = Codensity $ \ _ -> Fail.fail msg {-# INLINE fail #-} instance MonadIO m => MonadIO (Codensity m) where liftIO = lift . liftIO {-# INLINE liftIO #-} instance MonadTrans Codensity where lift m = Codensity (m >>=) {-# INLINE lift #-} instance Alt v => Alt (Codensity v) where Codensity m Codensity n = Codensity (\k -> m k n k) {-# INLINE () #-} instance Plus v => Plus (Codensity v) where zero = Codensity (const zero) {-# INLINE zero #-} {- instance Plus v => Alternative (Codensity v) where empty = zero (<|>) = () instance Plus v => MonadPlus (Codensity v) where mzero = zero mplus = () -} instance Alternative v => Alternative (Codensity v) where empty = Codensity (\_ -> empty) {-# INLINE empty #-} Codensity m <|> Codensity n = Codensity (\k -> m k <|> n k) {-# INLINE (<|>) #-} #if __GLASGOW_HASKELL__ >= 710 instance Alternative v => MonadPlus (Codensity v) #else instance MonadPlus v => MonadPlus (Codensity v) where mzero = Codensity (\_ -> mzero) {-# INLINE mzero #-} Codensity m `mplus` Codensity n = Codensity (\k -> m k `mplus` n k) {-# INLINE mplus #-} #endif -- | -- This serves as the *left*-inverse (retraction) of 'lift'. -- -- -- @ -- 'lowerCodensity' . 'lift' ≡ 'id' -- @ -- -- In general this is not a full 2-sided inverse, merely a retraction, as -- @'Codensity' m@ is often considerably "larger" than @m@. -- -- e.g. @'Codensity' ((->) s)) a ~ forall r. (a -> s -> r) -> s -> r@ -- could support a full complement of @'MonadState' s@ actions, while @(->) s@ -- is limited to @'MonadReader' s@ actions. #if __GLASGOW_HASKELL__ >= 710 lowerCodensity :: Applicative f => Codensity f a -> f a lowerCodensity a = runCodensity a pure #else lowerCodensity :: Monad m => Codensity m a -> m a lowerCodensity a = runCodensity a return #endif {-# INLINE lowerCodensity #-} -- | The 'Codensity' monad of a right adjoint is isomorphic to the -- monad obtained from the 'Adjunction'. -- -- @ -- 'codensityToAdjunction' . 'adjunctionToCodensity' ≡ 'id' -- 'adjunctionToCodensity' . 'codensityToAdjunction' ≡ 'id' -- @ codensityToAdjunction :: Adjunction f g => Codensity g a -> g (f a) codensityToAdjunction r = runCodensity r unit {-# INLINE codensityToAdjunction #-} adjunctionToCodensity :: Adjunction f g => g (f a) -> Codensity g a adjunctionToCodensity f = Codensity (\a -> fmap (rightAdjunct a) f) {-# INLINE adjunctionToCodensity #-} -- | The 'Codensity' monad of a representable 'Functor' is isomorphic to the -- monad obtained from the 'Adjunction' for which that 'Functor' is the right -- adjoint. -- -- @ -- 'codensityToComposedRep' . 'composedRepToCodensity' ≡ 'id' -- 'composedRepToCodensity' . 'codensityToComposedRep' ≡ 'id' -- @ -- -- @ -- codensityToComposedRep = 'ranToComposedRep' . 'codensityToRan' -- @ codensityToComposedRep :: Representable u => Codensity u a -> u (Rep u, a) codensityToComposedRep (Codensity f) = f (\a -> tabulate $ \e -> (e, a)) {-# INLINE codensityToComposedRep #-} -- | -- -- @ -- 'composedRepToCodensity' = 'ranToCodensity' . 'composedRepToRan' -- @ composedRepToCodensity :: Representable u => u (Rep u, a) -> Codensity u a composedRepToCodensity hfa = Codensity $ \k -> fmap (\(e, a) -> index (k a) e) hfa {-# INLINE composedRepToCodensity #-} -- | The 'Codensity' 'Monad' of a 'Functor' @g@ is the right Kan extension ('Ran') -- of @g@ along itself. -- -- @ -- 'codensityToRan' . 'ranToCodensity' ≡ 'id' -- 'ranToCodensity' . 'codensityToRan' ≡ 'id' -- @ codensityToRan :: Codensity g a -> Ran g g a codensityToRan (Codensity m) = Ran m {-# INLINE codensityToRan #-} ranToCodensity :: Ran g g a -> Codensity g a ranToCodensity (Ran m) = Codensity m {-# INLINE ranToCodensity #-} instance (Functor f, MonadFree f m) => MonadFree f (Codensity m) where wrap t = Codensity (\h -> wrap (fmap (\p -> runCodensity p h) t)) {-# INLINE wrap #-} instance MonadReader r m => MonadState r (Codensity m) where get = Codensity (ask >>=) {-# INLINE get #-} put s = Codensity (\k -> local (const s) (k ())) {-# INLINE put #-} instance MonadReader r m => MonadReader r (Codensity m) where ask = Codensity (ask >>=) {-# INLINE ask #-} local f m = Codensity $ \c -> ask >>= \r -> local f . runCodensity m $ local (const r) . c {-# INLINE local #-} -- | Right associate all binds in a computation that generates a free monad -- -- This can improve the asymptotic efficiency of the result, while preserving -- semantics. -- -- See \"Asymptotic Improvement of Computations over Free Monads\" by Janis -- Voightländer for more information about this combinator. -- -- improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a improve m = lowerCodensity m {-# INLINE improve #-} -- | Wrap the remainder of the 'Codensity' action using the given -- function. -- -- This function can be used to register cleanup actions that will be -- executed at the end. Example: -- -- > wrapCodensity (`finally` putStrLn "Done.") wrapCodensity :: (forall a. m a -> m a) -> Codensity m () wrapCodensity f = Codensity (\k -> f (k ())) kan-extensions-5.2/src/Control/Monad/Co.hs0000644000000000000000000001422113316662462016667 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : non-portable (rank-2 polymorphism) -- -- Monads from Comonads -- -- -- -- 'Co' can be viewed as a right Kan lift along a 'Comonad'. -- -- In general you can \"sandwich\" a monad in between two halves of an adjunction. -- That is to say, if you have an adjunction @F -| G : C -> D @ then not only does @GF@ -- form a monad, but @GMF@ forms a monad for @M@ a monad in @D@. Therefore if we -- have an adjunction @F -| G : Hask -> Hask^op@ then we can lift a 'Comonad' in @Hask@ -- which is a 'Monad' in @Hask^op@ to a 'Monad' in 'Hask'. -- -- For any @r@, the 'Contravariant' functor / presheaf @(-> r)@ :: Hask^op -> Hask is adjoint to the \"same\" -- 'Contravariant' functor @(-> r) :: Hask -> Hask^op@. So we can sandwich a -- Monad in Hask^op in the middle to obtain @w (a -> r-) -> r+@, and then take a coend over -- @r@ to obtain @forall r. w (a -> r) -> r@. This gives rise to 'Co'. If we observe that -- we didn't care what the choices we made for @r@ were to finish this construction, we can -- upgrade to @forall r. w (a -> m r) -> m r@ in a manner similar to how @ContT@ is constructed -- yielding 'CoT'. -- -- We could consider unifying the definition of 'Co' and 'Rift', but -- there are many other arguments for which 'Rift' can form a 'Monad', and this -- wouldn't give rise to 'CoT'. ---------------------------------------------------------------------------- module Control.Monad.Co ( -- * Monads from Comonads Co, co, runCo -- * Monad Transformers from Comonads , CoT(..) -- * Klesili from CoKleisli , liftCoT0, liftCoT0M, lowerCoT0, lowerCo0 , liftCoT1, liftCoT1M, lowerCoT1, lowerCo1 , diter, dctrlM , posW, peekW, peeksW , askW, asksW, traceW )where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.Comonad.Cofree import Control.Comonad.Density import Control.Comonad.Env.Class as Env import Control.Comonad.Store.Class import Control.Comonad.Traced.Class as Traced import Control.Monad.Error.Class import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class import Control.Monad.Identity import Control.Monad.Reader.Class as Reader import Control.Monad.State.Class import Control.Monad.Trans.Class import Control.Monad.Writer.Class as Writer import Data.Functor.Bind import Data.Functor.Extend type Co w = CoT w Identity co :: Functor w => (forall r. w (a -> r) -> r) -> Co w a co f = CoT (Identity . f . fmap (fmap runIdentity)) runCo :: Functor w => Co w a -> w (a -> r) -> r runCo m = runIdentity . runCoT m . fmap (fmap Identity) -- | -- @ -- 'Co' w a ~ 'Data.Functor.Kan.Rift.Rift' w 'Identity' a -- @ newtype CoT w m a = CoT { runCoT :: forall r. w (a -> m r) -> m r } instance Functor w => Functor (CoT w m) where fmap f (CoT w) = CoT (w . fmap (. f)) instance Extend w => Apply (CoT w m) where mf <.> ma = mf >>- \f -> fmap f ma instance Extend w => Bind (CoT w m) where CoT k >>- f = CoT (k . extended (\wa a -> runCoT (f a) wa)) instance Comonad w => Applicative (CoT w m) where pure a = CoT (`extract` a) mf <*> ma = mf >>= \f -> fmap f ma instance Comonad w => Monad (CoT w m) where return = pure CoT k >>= f = CoT (k . extend (\wa a -> runCoT (f a) wa)) instance (Comonad w, Fail.MonadFail m) => Fail.MonadFail (CoT w m) where fail msg = CoT $ \ _ -> Fail.fail msg instance Comonad w => MonadTrans (CoT w) where lift m = CoT (extract . fmap (m >>=)) instance (Comonad w, MonadIO m) => MonadIO (CoT w m) where liftIO = lift . liftIO liftCoT0 :: Comonad w => (forall a. w a -> s) -> CoT w m s liftCoT0 f = CoT (extract <*> f) lowerCoT0 :: (Functor w, Monad m) => CoT w m s -> w a -> m s lowerCoT0 m = runCoT m . (return <$) lowerCo0 :: Functor w => Co w s -> w a -> s lowerCo0 m = runIdentity . runCoT m . (return <$) liftCoT1 :: (forall a. w a -> a) -> CoT w m () liftCoT1 f = CoT (`f` ()) lowerCoT1 :: (Functor w, Monad m) => CoT w m () -> w a -> m a lowerCoT1 m = runCoT m . fmap (const . return) lowerCo1 :: Functor w => Co w () -> w a -> a lowerCo1 m = runIdentity . runCoT m . fmap (const . return) posW :: ComonadStore s w => CoT w m s posW = liftCoT0 pos peekW :: ComonadStore s w => s -> CoT w m () peekW s = liftCoT1 (peek s) peeksW :: ComonadStore s w => (s -> s) -> CoT w m () peeksW f = liftCoT1 (peeks f) askW :: ComonadEnv e w => CoT w m e askW = liftCoT0 (Env.ask) asksW :: ComonadEnv e w => (e -> a) -> CoT w m a asksW f = liftCoT0 (Env.asks f) traceW :: ComonadTraced e w => e -> CoT w m () traceW e = liftCoT1 (Traced.trace e) liftCoT0M :: (Comonad w, Monad m) => (forall a. w a -> m s) -> CoT w m s liftCoT0M f = CoT (\wa -> extract wa =<< f wa) liftCoT1M :: Monad m => (forall a. w a -> m a) -> CoT w m () liftCoT1M f = CoT (($ ()) <=< f) diter :: Functor f => a -> (a -> f a) -> Density (Cofree f) a diter x y = liftDensity . coiter y $ x dctrlM :: Monad m => (forall a. w a -> m (w a)) -> CoT (Density w) m () dctrlM k = liftCoT1M (\(Density w a) -> liftM w (k a)) instance (Comonad w, MonadReader e m) => MonadReader e (CoT w m) where ask = lift Reader.ask local f m = CoT (local f . runCoT m) instance (Comonad w, MonadState s m) => MonadState s (CoT w m) where get = lift get put = lift . put instance (Comonad w, MonadWriter e m) => MonadWriter e (CoT w m) where tell = lift . tell pass m = CoT (pass . runCoT m . fmap aug) where aug f (a,e) = liftM (\r -> (r,e)) (f a) listen = error "Control.Monad.Co.listen: TODO" instance (Comonad w, MonadError e m) => MonadError e (CoT w m) where throwError = lift . throwError catchError = error "Control.Monad.Co.catchError: TODO" kan-extensions-5.2/src/Control/Comonad/0000755000000000000000000000000013316662462016314 5ustar0000000000000000kan-extensions-5.2/src/Control/Comonad/Density.hs0000644000000000000000000000737713316662462020305 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Density -- Copyright : (C) 2008-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : non-portable (GADTs, MPTCs) -- -- The 'Density' 'Comonad' for a 'Functor' (aka the 'Comonad generated by a 'Functor') -- The 'Density' term dates back to Dubuc''s 1974 thesis. The term -- 'Monad' generated by a 'Functor' dates back to 1972 in Street''s -- ''Formal Theory of Monads''. -- -- The left Kan extension of a 'Functor' along itself (@'Lan' f f@) forms a 'Comonad'. This is -- that 'Comonad'. ---------------------------------------------------------------------------- module Control.Comonad.Density ( Density(..) , liftDensity , densityToAdjunction, adjunctionToDensity , densityToLan, lanToDensity ) where import Control.Applicative import Control.Comonad import Control.Comonad.Trans.Class import Data.Functor.Apply import Data.Functor.Adjunction import Data.Functor.Extend import Data.Functor.Kan.Lan data Density k a where Density :: (k b -> a) -> k b -> Density k a instance Functor (Density f) where fmap f (Density g h) = Density (f . g) h {-# INLINE fmap #-} instance Extend (Density f) where duplicated (Density f ws) = Density (Density f) ws {-# INLINE duplicated #-} instance Comonad (Density f) where duplicate (Density f ws) = Density (Density f) ws {-# INLINE duplicate #-} extract (Density f a) = f a {-# INLINE extract #-} instance ComonadTrans Density where lower (Density f c) = extend f c {-# INLINE lower #-} instance Apply f => Apply (Density f) where Density kxf x <.> Density kya y = Density (\k -> kxf (fmap fst k) (kya (fmap snd k))) ((,) <$> x <.> y) {-# INLINE (<.>) #-} instance Applicative f => Applicative (Density f) where pure a = Density (const a) (pure ()) {-# INLINE pure #-} Density kxf x <*> Density kya y = Density (\k -> kxf (fmap fst k) (kya (fmap snd k))) (liftA2 (,) x y) {-# INLINE (<*>) #-} -- | The natural transformation from a @'Comonad' w@ to the 'Comonad' generated by @w@ (forwards). -- -- This is merely a right-inverse (section) of 'lower', rather than a full inverse. -- -- @ -- 'lower' . 'liftDensity' ≡ 'id' -- @ liftDensity :: Comonad w => w a -> Density w a liftDensity = Density extract {-# INLINE liftDensity #-} -- | The Density 'Comonad' of a left adjoint is isomorphic to the 'Comonad' formed by that 'Adjunction'. -- -- This isomorphism is witnessed by 'densityToAdjunction' and 'adjunctionToDensity'. -- -- @ -- 'densityToAdjunction' . 'adjunctionToDensity' ≡ 'id' -- 'adjunctionToDensity' . 'densityToAdjunction' ≡ 'id' -- @ densityToAdjunction :: Adjunction f g => Density f a -> f (g a) densityToAdjunction (Density f v) = fmap (leftAdjunct f) v {-# INLINE densityToAdjunction #-} adjunctionToDensity :: Adjunction f g => f (g a) -> Density f a adjunctionToDensity = Density counit {-# INLINE adjunctionToDensity #-} -- | The 'Density' 'Comonad' of a 'Functor' @f@ is obtained by taking the left Kan extension -- ('Lan') of @f@ along itself. This isomorphism is witnessed by 'lanToDensity' and 'densityToLan' -- -- @ -- 'lanToDensity' . 'densityToLan' ≡ 'id' -- 'densityToLan' . 'lanToDensity' ≡ 'id' -- @ lanToDensity :: Lan f f a -> Density f a lanToDensity (Lan f v) = Density f v {-# INLINE lanToDensity #-} densityToLan :: Density f a -> Lan f f a densityToLan (Density f v) = Lan f v {-# INLINE densityToLan #-} kan-extensions-5.2/src/Data/0000755000000000000000000000000013316662462014165 5ustar0000000000000000kan-extensions-5.2/src/Data/Functor/0000755000000000000000000000000013316662462015605 5ustar0000000000000000kan-extensions-5.2/src/Data/Functor/Day.hs0000644000000000000000000001526713316662462016671 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- Eitan Chatav first introduced me to this construction -- -- The Day convolution of two covariant functors is a covariant functor. -- -- Day convolution is usually defined in terms of contravariant functors, -- however, it just needs a monoidal category, and Hask^op is also monoidal. -- -- Day convolution can be used to nicely describe monoidal functors as monoid -- objects w.r.t this product. -- -- ---------------------------------------------------------------------------- module Data.Functor.Day ( Day(..) , day , dap , assoc, disassoc , swapped , intro1, intro2 , elim1, elim2 , trans1, trans2 , cayley, dayley ) where import Control.Applicative import Control.Category import Control.Comonad import Control.Comonad.Trans.Class import Data.Distributive import Data.Profunctor.Cayley (Cayley(..)) import Data.Profunctor.Composition (Procompose(..)) import Data.Functor.Identity import Data.Functor.Rep #ifdef __GLASGOW_HASKELL__ import Data.Typeable #endif import Prelude hiding (id,(.)) -- | The Day convolution of two covariant functors. data Day f g a = forall b c. Day (f b) (g c) (b -> c -> a) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 deriving Typeable #endif -- | Construct the Day convolution day :: f (a -> b) -> g a -> Day f g b day fa gb = Day fa gb id #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 instance (Typeable1 f, Typeable1 g) => Typeable1 (Day f g) where typeOf1 tfga = mkTyConApp dayTyCon [typeOf1 (fa tfga), typeOf1 (ga tfga)] where fa :: t f (g :: * -> *) a -> f a fa = undefined ga :: t (f :: * -> *) g a -> g a ga = undefined dayTyCon :: TyCon #if MIN_VERSION_base(4,4,0) dayTyCon = mkTyCon3 "contravariant" "Data.Functor.Day" "Day" #else dayTyCon = mkTyCon "Data.Functor.Day.Day" #endif #endif instance Functor (Day f g) where fmap f (Day fb gc bca) = Day fb gc $ \b c -> f (bca b c) instance (Applicative f, Applicative g) => Applicative (Day f g) where pure x = Day (pure ()) (pure ()) (\_ _ -> x) (Day fa fb u) <*> (Day gc gd v) = Day ((,) <$> fa <*> gc) ((,) <$> fb <*> gd) (\(a,c) (b,d) -> u a b (v c d)) instance (Representable f, Representable g) => Distributive (Day f g) where distribute f = Day (tabulate id) (tabulate id) $ \x y -> fmap (\(Day m n o) -> o (index m x) (index n y)) f collect g f = Day (tabulate id) (tabulate id) $ \x y -> fmap (\q -> case g q of Day m n o -> o (index m x) (index n y)) f instance (Representable f, Representable g) => Representable (Day f g) where type Rep (Day f g) = (Rep f, Rep g) tabulate f = Day (tabulate id) (tabulate id) (curry f) index (Day m n o) (x,y) = o (index m x) (index n y) instance (Comonad f, Comonad g) => Comonad (Day f g) where extract (Day fb gc bca) = bca (extract fb) (extract gc) duplicate (Day fb gc bca) = Day (duplicate fb) (duplicate gc) (\fb' gc' -> Day fb' gc' bca) instance (ComonadApply f, ComonadApply g) => ComonadApply (Day f g) where Day fa fb u <@> Day gc gd v = Day ((,) <$> fa <@> gc) ((,) <$> fb <@> gd) (\(a,c) (b,d) -> u a b (v c d)) instance Comonad f => ComonadTrans (Day f) where lower (Day fb gc bca) = bca (extract fb) <$> gc -- | Day convolution provides a monoidal product. The associativity -- of this monoid is witnessed by 'assoc' and 'disassoc'. -- -- @ -- 'assoc' . 'disassoc' = 'id' -- 'disassoc' . 'assoc' = 'id' -- 'fmap' f '.' 'assoc' = 'assoc' '.' 'fmap' f -- @ assoc :: Day f (Day g h) a -> Day (Day f g) h a assoc (Day fb (Day gd he dec) bca) = Day (Day fb gd (,)) he $ \ (b,d) e -> bca b (dec d e) -- | Day convolution provides a monoidal product. The associativity -- of this monoid is witnessed by 'assoc' and 'disassoc'. -- -- @ -- 'assoc' . 'disassoc' = 'id' -- 'disassoc' . 'assoc' = 'id' -- 'fmap' f '.' 'disassoc' = 'disassoc' '.' 'fmap' f -- @ disassoc :: Day (Day f g) h a -> Day f (Day g h) a disassoc (Day (Day fb gc bce) hd eda) = Day fb (Day gc hd (,)) $ \ b (c,d) -> eda (bce b c) d -- | The monoid for 'Day' convolution on the cartesian monoidal structure is symmetric. -- -- @ -- 'fmap' f '.' 'swapped' = 'swapped' '.' 'fmap' f -- @ swapped :: Day f g a -> Day g f a swapped (Day fb gc abc) = Day gc fb (flip abc) -- | 'Identity' is the unit of 'Day' convolution -- -- @ -- 'intro1' '.' 'elim1' = 'id' -- 'elim1' '.' 'intro1' = 'id' -- @ intro1 :: f a -> Day Identity f a intro1 fa = Day (Identity ()) fa $ \_ a -> a -- | 'Identity' is the unit of 'Day' convolution -- -- @ -- 'intro2' '.' 'elim2' = 'id' -- 'elim2' '.' 'intro2' = 'id' -- @ intro2 :: f a -> Day f Identity a intro2 fa = Day fa (Identity ()) const -- | 'Identity' is the unit of 'Day' convolution -- -- @ -- 'intro1' '.' 'elim1' = 'id' -- 'elim1' '.' 'intro1' = 'id' -- @ elim1 :: Functor f => Day Identity f a -> f a elim1 (Day (Identity b) fc bca) = bca b <$> fc -- | 'Identity' is the unit of 'Day' convolution -- -- @ -- 'intro2' '.' 'elim2' = 'id' -- 'elim2' '.' 'intro2' = 'id' -- @ elim2 :: Functor f => Day f Identity a -> f a elim2 (Day fb (Identity c) bca) = flip bca c <$> fb -- | Collapse via a monoidal functor. -- -- @ -- 'dap' ('day' f g) = f '<*>' g -- @ dap :: Applicative f => Day f f a -> f a dap (Day fb fc abc) = liftA2 abc fb fc -- | Apply a natural transformation to the left-hand side of a Day convolution. -- -- This respects the naturality of the natural transformation you supplied: -- -- @ -- 'fmap' f '.' 'trans1' fg = 'trans1' fg '.' 'fmap' f -- @ trans1 :: (forall x. f x -> g x) -> Day f h a -> Day g h a trans1 fg (Day fb hc bca) = Day (fg fb) hc bca -- | Apply a natural transformation to the right-hand side of a Day convolution. -- -- This respects the naturality of the natural transformation you supplied: -- -- @ -- 'fmap' f '.' 'trans2' fg = 'trans2' fg '.' 'fmap' f -- @ trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a trans2 gh (Day fb gc bca) = Day fb (gh gc) bca cayley :: Procompose (Cayley f p) (Cayley g q) a b -> Cayley (Day f g) (Procompose p q) a b cayley (Procompose (Cayley p) (Cayley q)) = Cayley $ Day p q Procompose -- | Proposition 4.1 from Pastro and Street dayley :: Category p => Procompose (Cayley f p) (Cayley g p) a b -> Cayley (Day f g) p a b dayley (Procompose (Cayley p) (Cayley q)) = Cayley $ Day p q (.) kan-extensions-5.2/src/Data/Functor/Yoneda.hs0000644000000000000000000002202113316662462017355 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #include "kan-extensions-common.h" ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Yoneda -- Copyright : (C) 2011-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- -- The covariant form of the Yoneda lemma states that @f@ is naturally -- isomorphic to @Yoneda f@. -- -- This is described in a rather intuitive fashion by Dan Piponi in -- -- ---------------------------------------------------------------------------- module Data.Functor.Yoneda ( Yoneda(..) , liftYoneda, lowerYoneda , maxF, minF, maxM, minM -- * as a right Kan extension , yonedaToRan, ranToYoneda ) where import Control.Applicative import Control.Monad (MonadPlus(..), liftM) import Control.Monad.Fix import Control.Monad.Free.Class import Control.Monad.Trans.Class import Control.Comonad import Control.Comonad.Trans.Class import Data.Distributive import Data.Foldable import Data.Functor.Adjunction import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Kan.Ran import Data.Functor.Plus import Data.Functor.Rep import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Traversable import Text.Read hiding (lift) import Prelude hiding (sequence, lookup, zipWith) -- | @Yoneda f a@ can be viewed as the partial application of 'fmap' to its second argument. newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b } -- | The natural isomorphism between @f@ and @'Yoneda' f@ given by the Yoneda lemma -- is witnessed by 'liftYoneda' and 'lowerYoneda' -- -- @ -- 'liftYoneda' . 'lowerYoneda' ≡ 'id' -- 'lowerYoneda' . 'liftYoneda' ≡ 'id' -- @ -- -- @ -- lowerYoneda (liftYoneda fa) = -- definition -- lowerYoneda (Yoneda (\f -> fmap f a)) -- definition -- (\f -> fmap f fa) id -- beta reduction -- fmap id fa -- functor law -- fa -- @ -- -- @ -- 'lift' = 'liftYoneda' -- @ liftYoneda :: Functor f => f a -> Yoneda f a liftYoneda a = Yoneda (\f -> fmap f a) {-# INLINE liftYoneda #-} lowerYoneda :: Yoneda f a -> f a lowerYoneda (Yoneda f) = f id {-# INLINE lowerYoneda #-} -- TODO: coerce -- {-# RULES "lower/lift=id" liftYoneda . lowerYoneda = id #-} -- {-# RULES "lift/lower=id" lowerYoneda . liftYoneda = id #-} -- | @Yoneda f@ can be viewed as the right Kan extension of @f@ along the 'Identity' functor. -- -- @ -- 'yonedaToRan' . 'ranToYoneda' ≡ 'id' -- 'ranToYoneda' . 'yonedaToRan' ≡ 'id' -- @ yonedaToRan :: Yoneda f a -> Ran Identity f a yonedaToRan (Yoneda m) = Ran (m . fmap runIdentity) {-# INLINE yonedaToRan #-} ranToYoneda :: Ran Identity f a -> Yoneda f a ranToYoneda (Ran m) = Yoneda (m . fmap Identity) {-# INLINE ranToYoneda #-} -- {-# RULES "yonedaToRan/ranToYoneda=id" yonedaToRan . ranToYoneda = id #-} -- {-# RULES "ranToYoneda/yonedaToRan=id" ranToYoneda . yonedaToRan = id #-} instance Functor (Yoneda f) where fmap f m = Yoneda (\k -> runYoneda m (k . f)) {-# INLINE fmap #-} instance Apply f => Apply (Yoneda f) where Yoneda m <.> Yoneda n = Yoneda (\f -> m (f .) <.> n id) {-# INLINE (<.>) #-} instance Applicative f => Applicative (Yoneda f) where pure a = Yoneda (\f -> pure (f a)) {-# INLINE pure #-} Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id) {-# INLINE (<*>) #-} instance Foldable f => Foldable (Yoneda f) where foldMap f = foldMap f . lowerYoneda {-# INLINE foldMap #-} instance Foldable1 f => Foldable1 (Yoneda f) where foldMap1 f = foldMap1 f . lowerYoneda {-# INLINE foldMap1 #-} instance Traversable f => Traversable (Yoneda f) where traverse f = fmap liftYoneda . traverse f . lowerYoneda {-# INLINE traverse #-} instance Traversable1 f => Traversable1 (Yoneda f) where traverse1 f = fmap liftYoneda . traverse1 f . lowerYoneda {-# INLINE traverse1 #-} instance Distributive f => Distributive (Yoneda f) where collect f = liftYoneda . collect (lowerYoneda . f) {-# INLINE collect #-} instance Representable g => Representable (Yoneda g) where type Rep (Yoneda g) = Rep g tabulate = liftYoneda . tabulate {-# INLINE tabulate #-} index = index . lowerYoneda {-# INLINE index #-} instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where unit = liftYoneda . fmap liftYoneda . unit {-# INLINE unit #-} counit (Yoneda m) = counit (m lowerYoneda) {-# INLINE counit #-} instance Show1 f => Show1 (Yoneda f) where #if LIFTED_FUNCTOR_CLASSES liftShowsPrec sp sl d (Yoneda f) = showsUnaryWith (liftShowsPrec sp sl) "liftYoneda" d (f id) #else showsPrec1 d (Yoneda f) = showParen (d > 10) $ showString "liftYoneda " . showsPrec1 11 (f id) #endif instance (Read1 f, Functor f) => Read1 (Yoneda f) where #if LIFTED_FUNCTOR_CLASSES liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "liftYoneda" liftYoneda #else readsPrec1 d = readParen (d > 10) $ \r' -> [ (liftYoneda f, t) | ("liftYoneda", s) <- lex r' , (f, t) <- readsPrec1 11 s ] #endif instance Show (f a) => Show (Yoneda f a) where showsPrec d (Yoneda f) = showParen (d > 10) $ showString "liftYoneda " . showsPrec 11 (f id) instance (Functor f, Read (f a)) => Read (Yoneda f a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "liftYoneda" <- lexP liftYoneda <$> step readPrec #else readsPrec d = readParen (d > 10) $ \r' -> [ (liftYoneda f, t) | ("liftYoneda", s) <- lex r' , (f, t) <- readsPrec 11 s ] #endif infixl 0 `on1` on1 :: (g a -> g b -> c) -> (forall x. f x -> g x) -> f a -> f b -> c (.*.) `on1` f = \x y -> f x .*. f y instance Eq1 f => Eq1 (Yoneda f) where #if LIFTED_FUNCTOR_CLASSES liftEq eq = liftEq eq `on1` lowerYoneda {-# INLINE liftEq #-} #else eq1 = eq1 `on1` lowerYoneda {-# INLINE eq1 #-} #endif instance Ord1 f => Ord1 (Yoneda f) where #if LIFTED_FUNCTOR_CLASSES liftCompare cmp = liftCompare cmp `on1` lowerYoneda {-# INLINE liftCompare #-} #else compare1 = compare1 `on1` lowerYoneda {-# INLINE compare1 #-} #endif instance (Eq1 f, Eq a) => Eq (Yoneda f a) where (==) = eq1 {-# INLINE (==) #-} instance (Ord1 f, Ord a) => Ord (Yoneda f a) where compare = compare1 {-# INLINE compare #-} maxF :: (Functor f, Ord (f a)) => Yoneda f a -> Yoneda f a -> Yoneda f a Yoneda f `maxF` Yoneda g = liftYoneda $ f id `max` g id -- {-# RULES "max/maxF" max = maxF #-} {-# INLINE maxF #-} minF :: (Functor f, Ord (f a)) => Yoneda f a -> Yoneda f a -> Yoneda f a Yoneda f `minF` Yoneda g = liftYoneda $ f id `max` g id -- {-# RULES "min/minF" min = minF #-} {-# INLINE minF #-} maxM :: (Monad m, Ord (m a)) => Yoneda m a -> Yoneda m a -> Yoneda m a Yoneda f `maxM` Yoneda g = lift $ f id `max` g id -- {-# RULES "max/maxM" max = maxM #-} {-# INLINE maxM #-} minM :: (Monad m, Ord (m a)) => Yoneda m a -> Yoneda m a -> Yoneda m a Yoneda f `minM` Yoneda g = lift $ f id `min` g id -- {-# RULES "min/minM" min = minM #-} {-# INLINE minM #-} instance Alt f => Alt (Yoneda f) where Yoneda f Yoneda g = Yoneda (\k -> f k g k) {-# INLINE () #-} instance Plus f => Plus (Yoneda f) where zero = Yoneda $ const zero {-# INLINE zero #-} instance Alternative f => Alternative (Yoneda f) where empty = Yoneda $ const empty {-# INLINE empty #-} Yoneda f <|> Yoneda g = Yoneda (\k -> f k <|> g k) {-# INLINE (<|>) #-} instance Bind m => Bind (Yoneda m) where Yoneda m >>- k = Yoneda (\f -> m id >>- \a -> runYoneda (k a) f) {-# INLINE (>>-) #-} instance Monad m => Monad (Yoneda m) where #if __GLASGOW_HASKELL__ < 710 return a = Yoneda (\f -> return (f a)) {-# INLINE return #-} #endif Yoneda m >>= k = Yoneda (\f -> m id >>= \a -> runYoneda (k a) f) {-# INLINE (>>=) #-} instance MonadFix m => MonadFix (Yoneda m) where mfix f = lift $ mfix (lowerYoneda . f) {-# INLINE mfix #-} instance MonadPlus m => MonadPlus (Yoneda m) where mzero = Yoneda (const mzero) {-# INLINE mzero #-} Yoneda f `mplus` Yoneda g = Yoneda (\k -> f k `mplus` g k) {-# INLINE mplus #-} instance MonadTrans Yoneda where lift a = Yoneda (\f -> liftM f a) {-# INLINE lift #-} instance (Functor f, MonadFree f m) => MonadFree f (Yoneda m) where wrap = lift . wrap . fmap lowerYoneda {-# INLINE wrap #-} instance Extend w => Extend (Yoneda w) where extended k (Yoneda m) = Yoneda (\f -> extended (f . k . liftYoneda) (m id)) {-# INLINE extended #-} instance Comonad w => Comonad (Yoneda w) where extend k (Yoneda m) = Yoneda (\f -> extend (f . k . liftYoneda) (m id)) {-# INLINE extend #-} extract = extract . lowerYoneda {-# INLINE extract #-} instance ComonadTrans Yoneda where lower = lowerYoneda {-# INLINE lower #-} kan-extensions-5.2/src/Data/Functor/Coyoneda.hs0000644000000000000000000002534013316662462017706 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #include "kan-extensions-common.h" ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : GADTs, MPTCs, fundeps -- -- The co-Yoneda lemma for a covariant 'Functor' @f@ states that @'Coyoneda' f@ -- is naturally isomorphic to @f@. ---------------------------------------------------------------------------- module Data.Functor.Coyoneda ( Coyoneda(..) , liftCoyoneda, lowerCoyoneda, lowerM, hoistCoyoneda -- * as a Left Kan extension , coyonedaToLan, lanToCoyoneda ) where import Control.Applicative as A import Control.Monad (MonadPlus(..), liftM) import Control.Monad.Fix import Control.Monad.Trans.Class import Control.Comonad import Control.Comonad.Trans.Class import Data.Distributive #if !LIFTED_FUNCTOR_CLASSES import Data.Function (on) #endif import Data.Functor.Adjunction import Data.Functor.Bind import Data.Functor.Classes import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Kan.Lan import Data.Functor.Plus import Data.Functor.Rep import Data.Foldable import Data.Traversable import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Prelude hiding (sequence, lookup, zipWith) import Text.Read hiding (lift) -- | A covariant 'Functor' suitable for Yoneda reduction -- data Coyoneda f a where Coyoneda :: (b -> a) -> f b -> Coyoneda f a -- | @Coyoneda f@ is the left Kan extension of @f@ along the 'Identity' functor. -- -- @Coyoneda f@ is always a functor, even if @f@ is not. In this case, it -- is called the /free functor over @f@/. Note the following categorical fine -- print: If @f@ is not a functor, @Coyoneda f@ is actually not the left Kan -- extension of @f@ along the 'Identity' functor, but along the inclusion -- functor from the discrete subcategory of /Hask/ which contains only identity -- functions as morphisms to the full category /Hask/. (This is because @f@, -- not being a proper functor, can only be interpreted as a categorical functor -- by restricting the source category to only contain identities.) -- -- @ -- 'coyonedaToLan' . 'lanToCoyoneda' ≡ 'id' -- 'lanToCoyoneda' . 'coyonedaToLan' ≡ 'id' -- @ coyonedaToLan :: Coyoneda f a -> Lan Identity f a coyonedaToLan (Coyoneda ba fb) = Lan (ba . runIdentity) fb {-# INLINE coyonedaToLan #-} lanToCoyoneda :: Lan Identity f a -> Coyoneda f a lanToCoyoneda (Lan iba fb) = Coyoneda (iba . Identity) fb {-# INLINE lanToCoyoneda #-} -- {-# RULES "coyonedaToLan/lanToCoyoneda=id" coyonedaToLan . lanToCoyoneda = id #-} -- {-# RULES "lanToCoyoneda/coyonedaToLan=id" lanToCoyoneda . coyonedaToLan = id #-} instance Functor (Coyoneda f) where fmap f (Coyoneda g v) = Coyoneda (f . g) v {-# INLINE fmap #-} instance Apply f => Apply (Coyoneda f) where Coyoneda mf m <.> Coyoneda nf n = liftCoyoneda $ (\mres nres -> mf mres (nf nres)) <$> m <.> n {-# INLINE (<.>) #-} Coyoneda _ m .> Coyoneda g n = Coyoneda g (m .> n) {-# INLINE (.>) #-} Coyoneda f m <. Coyoneda _ n = Coyoneda f (m <. n) {-# INLINE (<.) #-} instance Applicative f => Applicative (Coyoneda f) where pure = liftCoyoneda . pure {-# INLINE pure #-} Coyoneda mf m <*> Coyoneda nf n = liftCoyoneda $ (\mres nres -> mf mres (nf nres)) <$> m <*> n {-# INLINE (<*>) #-} Coyoneda _ m *> Coyoneda g n = Coyoneda g (m *> n) {-# INLINE (*>) #-} Coyoneda f m <* Coyoneda _ n = Coyoneda f (m <* n) {-# INLINE (<*) #-} instance Alternative f => Alternative (Coyoneda f) where empty = liftCoyoneda empty {-# INLINE empty #-} m <|> n = liftCoyoneda $ lowerCoyoneda m <|> lowerCoyoneda n {-# INLINE (<|>) #-} some = liftCoyoneda . A.some . lowerCoyoneda {-# INLINE some #-} many = liftCoyoneda . A.many . lowerCoyoneda {-# INLINE many #-} {- -- These are slightly optimized versions of the *default* -- `some` and `many` definitions for `Coyoneda`. I don't -- know if it's worth the clutter to expose them. someDefault (Coyoneda vf vb) = liftCoyoneda some_v where many_v = some_v <|> pure [] some_v = (:) . vf <$> vb <*> many_v {-# INLINE someDefault #-} manyDefault (Coyoneda vf vb) = liftCoyoneda many_v where many_v = some_v <|> pure [] some_v = (:) . vf <$> vb <*> many_v {-# INLINE many #-} -} instance Alt f => Alt (Coyoneda f) where m n = liftCoyoneda $ lowerCoyoneda m lowerCoyoneda n {-# INLINE () #-} instance Plus f => Plus (Coyoneda f) where zero = liftCoyoneda zero {-# INLINE zero #-} instance Bind m => Bind (Coyoneda m) where Coyoneda f v >>- k = liftCoyoneda (v >>- lowerCoyoneda . k . f) {-# INLINE (>>-) #-} instance Monad m => Monad (Coyoneda m) where #if __GLASGOW_HASKELL__ < 710 -- pre-AMP return = Coyoneda id . return {-# INLINE return #-} Coyoneda _ m >> Coyoneda g n = Coyoneda g (m >> n) {-# INLINE (>>) #-} #else -- post-AMP (>>) = (*>) {-# INLINE (>>) #-} #endif Coyoneda f v >>= k = lift (v >>= lowerM . k . f) {-# INLINE (>>=) #-} instance MonadTrans Coyoneda where lift = Coyoneda id {-# INLINE lift #-} instance MonadFix f => MonadFix (Coyoneda f) where mfix f = lift $ mfix (lowerM . f) {-# INLINE mfix #-} instance MonadPlus f => MonadPlus (Coyoneda f) where mzero = lift mzero {-# INLINE mzero #-} m `mplus` n = lift $ lowerM m `mplus` lowerM n {-# INLINE mplus #-} instance Representable f => Representable (Coyoneda f) where type Rep (Coyoneda f) = Rep f tabulate = liftCoyoneda . tabulate {-# INLINE tabulate #-} index = index . lowerCoyoneda {-# INLINE index #-} instance Extend w => Extend (Coyoneda w) where extended k (Coyoneda f v) = Coyoneda id $ extended (k . Coyoneda f) v {-# INLINE extended #-} instance Comonad w => Comonad (Coyoneda w) where extend k (Coyoneda f v) = Coyoneda id $ extend (k . Coyoneda f) v {-# INLINE extend #-} extract (Coyoneda f v) = f (extract v) {-# INLINE extract #-} instance ComonadTrans Coyoneda where lower (Coyoneda f a) = fmap f a {-# INLINE lower #-} instance Foldable f => Foldable (Coyoneda f) where foldMap f (Coyoneda k a) = foldMap (f . k) a {-# INLINE foldMap #-} instance Foldable1 f => Foldable1 (Coyoneda f) where foldMap1 f (Coyoneda k a) = foldMap1 (f . k) a {-# INLINE foldMap1 #-} instance Traversable f => Traversable (Coyoneda f) where traverse f (Coyoneda k a) = Coyoneda id <$> traverse (f . k) a {-# INLINE traverse #-} instance Traversable1 f => Traversable1 (Coyoneda f) where traverse1 f (Coyoneda k a) = Coyoneda id <$> traverse1 (f . k) a {-# INLINE traverse1 #-} instance Distributive f => Distributive (Coyoneda f) where collect f = liftCoyoneda . collect (lowerCoyoneda . f) {-# INLINE collect #-} instance (Functor f, Show1 f) => Show1 (Coyoneda f) where #if LIFTED_FUNCTOR_CLASSES liftShowsPrec sp sl d (Coyoneda f a) = showsUnaryWith (liftShowsPrec sp sl) "liftCoyoneda" d (fmap f a) {-# INLINE liftShowsPrec #-} #else showsPrec1 d (Coyoneda f a) = showParen (d > 10) $ showString "liftCoyoneda " . showsPrec1 11 (fmap f a) {-# INLINE showsPrec1 #-} #endif instance (Read1 f) => Read1 (Coyoneda f) where #if LIFTED_FUNCTOR_CLASSES liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "liftCoyoneda" liftCoyoneda {-# INLINE liftReadsPrec #-} #else readsPrec1 d = readParen (d > 10) $ \r' -> [ (liftCoyoneda f, t) | ("liftCoyoneda", s) <- lex r' , (f, t) <- readsPrec1 11 s ] {-# INLINE readsPrec1 #-} #endif instance (Functor f, Show1 f, Show a) => Show (Coyoneda f a) where showsPrec = showsPrec1 {-# INLINE showsPrec #-} instance Read (f a) => Read (Coyoneda f a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "liftCoyoneda" <- lexP liftCoyoneda <$> step readPrec {-# INLINE readPrec #-} #else readsPrec d = readParen (d > 10) $ \r' -> [ (liftCoyoneda f, t) | ("liftCoyoneda", s) <- lex r' , (f, t) <- readsPrec 11 s ] {-# INLINE readsPrec #-} #endif #if LIFTED_FUNCTOR_CLASSES instance Eq1 f => Eq1 (Coyoneda f) where liftEq eq (Coyoneda f xs) (Coyoneda g ys) = liftEq (\x y -> eq (f x) (g y)) xs ys {-# INLINE liftEq #-} #else instance (Functor f, Eq1 f) => Eq1 (Coyoneda f) where eq1 = eq1 `on` lowerCoyoneda {-# INLINE eq1 #-} #endif #if LIFTED_FUNCTOR_CLASSES instance Ord1 f => Ord1 (Coyoneda f) where liftCompare cmp (Coyoneda f xs) (Coyoneda g ys) = liftCompare (\x y -> cmp (f x) (g y)) xs ys {-# INLINE liftCompare #-} #else instance (Functor f, Ord1 f) => Ord1 (Coyoneda f) where compare1 = compare1 `on` lowerCoyoneda {-# INLINE compare1 #-} #endif instance (Functor f, Eq1 f, Eq a) => Eq (Coyoneda f a) where (==) = eq1 {-# INLINE (==) #-} instance (Functor f, Ord1 f, Ord a) => Ord (Coyoneda f a) where compare = compare1 {-# INLINE compare #-} instance Adjunction f g => Adjunction (Coyoneda f) (Coyoneda g) where unit = liftCoyoneda . leftAdjunct liftCoyoneda {-# INLINE unit #-} counit = rightAdjunct lowerCoyoneda . lowerCoyoneda {-# INLINE counit #-} -- | Yoneda \"expansion\" -- -- @ -- 'liftCoyoneda' . 'lowerCoyoneda' ≡ 'id' -- 'lowerCoyoneda' . 'liftCoyoneda' ≡ 'id' -- @ -- -- @ -- lowerCoyoneda (liftCoyoneda fa) = -- by definition -- lowerCoyoneda (Coyoneda id fa) = -- by definition -- fmap id fa = -- functor law -- fa -- @ -- -- @ -- 'lift' = 'liftCoyoneda' -- @ liftCoyoneda :: f a -> Coyoneda f a liftCoyoneda = Coyoneda id {-# INLINE liftCoyoneda #-} -- | Yoneda reduction lets us walk under the existential and apply 'fmap'. -- -- Mnemonically, \"Yoneda reduction\" sounds like and works a bit like β-reduction. -- -- -- -- You can view 'Coyoneda' as just the arguments to 'fmap' tupled up. -- -- @ -- 'lower' = 'lowerM' = 'lowerCoyoneda' -- @ lowerCoyoneda :: Functor f => Coyoneda f a -> f a lowerCoyoneda (Coyoneda f m) = fmap f m {-# INLINE lowerCoyoneda #-} -- | Yoneda reduction given a 'Monad' lets us walk under the existential and apply 'liftM'. -- -- You can view 'Coyoneda' as just the arguments to 'liftM' tupled up. -- -- @ -- 'lower' = 'lowerM' = 'lowerCoyoneda' -- @ lowerM :: Monad f => Coyoneda f a -> f a lowerM (Coyoneda f m) = liftM f m {-# INLINE lowerM #-} -- | Lift a natural transformation from @f@ to @g@ to a natural transformation -- from @Coyoneda f@ to @Coyoneda g@. hoistCoyoneda :: (forall a. f a -> g a) -> (Coyoneda f b -> Coyoneda g b) hoistCoyoneda f (Coyoneda g x) = Coyoneda g (f x) {-# INLINE hoistCoyoneda #-} kan-extensions-5.2/src/Data/Functor/Day/0000755000000000000000000000000013316662462016322 5ustar0000000000000000kan-extensions-5.2/src/Data/Functor/Day/Curried.hs0000644000000000000000000001123313316662462020253 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------------------- -- | -- Copyright : 2013-2016 Edward Kmett and Dan Doel -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : rank N types -- -- @'Day' f -| 'Curried' f@ -- -- @'Day' f ~ 'Compose' f@ when f preserves colimits / is a left adjoint. (Due in part to the -- strength of all functors in Hask.) -- -- So by the uniqueness of adjoints, when f is a left adjoint, @'Curried' f ~ 'Rift' f@ ------------------------------------------------------------------------------------------- module Data.Functor.Day.Curried ( -- * Right Kan lifts Curried(..) , toCurried, fromCurried, applied, unapplied , adjointToCurried, curriedToAdjoint , composedAdjointToCurried, curriedToComposedAdjoint , liftCurried, lowerCurried, rap ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Data.Functor.Adjunction import Data.Functor.Day import Data.Functor.Identity newtype Curried g h a = Curried { runCurried :: forall r. g (a -> r) -> h r } instance Functor g => Functor (Curried g h) where fmap f (Curried g) = Curried (g . fmap (.f)) {-# INLINE fmap #-} instance (Functor g, g ~ h) => Applicative (Curried g h) where pure a = Curried (fmap ($a)) {-# INLINE pure #-} Curried mf <*> Curried ma = Curried (ma . mf . fmap (.)) {-# INLINE (<*>) #-} -- | The natural isomorphism between @f@ and @Curried f f@. -- @ -- 'lowerCurried' '.' 'liftCurried' ≡ 'id' -- 'liftCurried' '.' 'lowerCurried' ≡ 'id' -- @ -- -- @ -- 'lowerCurried' ('liftCurried' x) -- definition -- 'lowerCurried' ('Curried' ('<*>' x)) -- definition -- ('<*>' x) ('pure' 'id') -- beta reduction -- 'pure' 'id' '<*>' x -- Applicative identity law -- x -- @ liftCurried :: Applicative f => f a -> Curried f f a liftCurried fa = Curried (<*> fa) {-# INLINE liftCurried #-} -- | Lower 'Curried' by applying 'pure' 'id' to the continuation. -- -- See 'liftCurried'. lowerCurried :: Applicative f => Curried f g a -> g a lowerCurried (Curried f) = f (pure id) {-# INLINE lowerCurried #-} -- | Indexed applicative composition of right Kan lifts. rap :: Functor f => Curried f g (a -> b) -> Curried g h a -> Curried f h b rap (Curried mf) (Curried ma) = Curried (ma . mf . fmap (.)) {-# INLINE rap #-} -- | This is the counit of the @Day f -| Curried f@ adjunction applied :: Functor f => Day f (Curried f g) a -> g a applied (Day fb (Curried fg) bca) = fg (bca <$> fb) {-# INLINE applied #-} -- | This is the unit of the @Day f -| Curried f@ adjunction unapplied :: g a -> Curried f (Day f g) a unapplied ga = Curried $ \ fab -> Day fab ga id {-# INLINE unapplied #-} -- | The universal property of 'Curried' toCurried :: (forall x. Day g k x -> h x) -> k a -> Curried g h a toCurried h ka = Curried $ \gar -> h (Day gar ka id) {-# INLINE toCurried #-} -- | -- @ -- 'toCurried' . 'fromCurried' ≡ 'id' -- 'fromCurried' . 'toCurried' ≡ 'id' -- @ fromCurried :: Functor f => (forall a. k a -> Curried f h a) -> Day f k b -> h b fromCurried f (Day fc kd cdb) = runCurried (f kd) (cdb <$> fc) {-# INLINE fromCurried #-} -- | @Curried f Identity a@ is isomorphic to the right adjoint to @f@ if one exists. -- -- @ -- 'adjointToCurried' . 'curriedToAdjoint' ≡ 'id' -- 'curriedToAdjoint' . 'adjointToCurried' ≡ 'id' -- @ adjointToCurried :: Adjunction f u => u a -> Curried f Identity a adjointToCurried ua = Curried (Identity . rightAdjunct (<$> ua)) {-# INLINE adjointToCurried #-} -- | @Curried f Identity a@ is isomorphic to the right adjoint to @f@ if one exists. curriedToAdjoint :: Adjunction f u => Curried f Identity a -> u a curriedToAdjoint (Curried m) = leftAdjunct (runIdentity . m) id {-# INLINE curriedToAdjoint #-} -- | @Curried f h a@ is isomorphic to the post-composition of the right adjoint of @f@ onto @h@ if such a right adjoint exists. -- -- @ -- 'curriedToComposedAdjoint' . 'composedAdjointToCurried' ≡ 'id' -- 'composedAdjointToCurried' . 'curriedToComposedAdjoint' ≡ 'id' -- @ curriedToComposedAdjoint :: Adjunction f u => Curried f h a -> u (h a) curriedToComposedAdjoint (Curried m) = leftAdjunct m id {-# INLINE curriedToComposedAdjoint #-} -- | @Curried f h a@ is isomorphic to the post-composition of the right adjoint of @f@ onto @h@ if such a right adjoint exists. composedAdjointToCurried :: (Functor h, Adjunction f u) => u (h a) -> Curried f h a composedAdjointToCurried uha = Curried $ rightAdjunct (\b -> fmap b <$> uha) {-# INLINE composedAdjointToCurried #-} kan-extensions-5.2/src/Data/Functor/Invariant/0000755000000000000000000000000013316662462017540 5ustar0000000000000000kan-extensions-5.2/src/Data/Functor/Invariant/Day.hs0000644000000000000000000001072113316662462020612 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2018 Brian Mckenna -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- The Day convolution of two invariant functors is an invariant -- functor. -- -- ---------------------------------------------------------------------------- module Data.Functor.Invariant.Day ( Day(..) , day , assoc, disassoc , swapped , intro1, intro2 , elim1, elim2 , trans1, trans2 , toContravariant, toCovariant ) where import qualified Data.Functor.Contravariant.Day as Contravariant import qualified Data.Functor.Day as Covariant import Data.Functor.Identity import Data.Functor.Invariant -- | The Day convolution of two invariant functors. data Day f g a = forall b c. Day (f b) (g c) (b -> c -> a) (a -> (b, c)) instance Invariant (Day f g) where invmap f g (Day fb gc bca abc) = Day fb gc ((f .) . bca) (abc . g) -- | Construct the Day convolution day :: f a -> g b -> Day f g (a, b) day fa gb = Day fa gb (,) id -- | Day convolution provides a monoidal product. The associativity -- of this monoid is witnessed by 'assoc' and 'disassoc'. -- -- @ -- 'assoc' . 'disassoc' = 'id' -- 'disassoc' . 'assoc' = 'id' -- 'invmap' f g '.' 'assoc' = 'assoc' '.' 'invmap' f g -- @ assoc :: Day f (Day g h) a -> Day (Day f g) h a assoc (Day fb (Day gd he dec cde) bca abc) = flip (Day (Day fb gd (,) id) he) f g where f a = let (b,c) = abc a (d,e) = cde c in ((b,d),e) g (b,d) e = bca b (dec d e) -- | Day convolution provides a monoidal product. The associativity -- of this monoid is witnessed by 'assoc' and 'disassoc'. -- -- @ -- 'assoc' . 'disassoc' = 'id' -- 'disassoc' . 'assoc' = 'id' -- 'invmap' f g '.' 'disassoc' = 'disassoc' '.' 'invmap' f g -- @ disassoc :: Day (Day f g) h a -> Day f (Day g h) a disassoc (Day (Day fb gc deb bde) hd bca abc) = Day fb (Day gc hd (,) id) f g where f e (d,c) = bca (deb e d) c g a = let (b,c) = abc a (d,e) = bde b in (d,(e,c)) -- | The monoid for 'Day' convolution on the cartesian monoidal structure is symmetric. -- -- @ -- 'invmap' f g '.' 'swapped' = 'swapped' '.' 'invmap' f g -- @ swapped :: Day f g a -> Day g f a swapped (Day fb gc bca abc) = Day gc fb (flip bca) (\a -> let (b, c) = abc a in (c, b)) -- | 'Identity' is the unit of 'Day' convolution -- -- @ -- 'intro1' '.' 'elim1' = 'id' -- 'elim1' '.' 'intro1' = 'id' -- @ intro1 :: f a -> Day Identity f a intro1 fa = Day (Identity ()) fa (\_ a -> a) ((,) ()) -- | 'Identity' is the unit of 'Day' convolution -- -- @ -- 'intro2' '.' 'elim2' = 'id' -- 'elim2' '.' 'intro2' = 'id' -- @ intro2 :: f a -> Day f Identity a intro2 fa = Day fa (Identity ()) const (flip (,) ()) -- | 'Identity' is the unit of 'Day' convolution -- -- @ -- 'intro1' '.' 'elim1' = 'id' -- 'elim1' '.' 'intro1' = 'id' -- @ elim1 :: Invariant f => Day Identity f a -> f a elim1 (Day (Identity b) fc bca abc) = invmap (bca b) (snd . abc) fc -- | 'Identity' is the unit of 'Day' convolution -- -- @ -- 'intro2' '.' 'elim2' = 'id' -- 'elim2' '.' 'intro2' = 'id' -- @ elim2 :: Invariant f => Day f Identity a -> f a elim2 (Day fb (Identity c) bca abc) = invmap (flip bca c) (fst . abc) fb -- | Apply a natural transformation to the left-hand side of a Day convolution. -- -- This respects the naturality of the natural transformation you supplied: -- -- @ -- 'invmap' f g '.' 'trans1' fg = 'trans1' fg '.' 'invmap' f g -- @ trans1 :: (forall x. f x -> g x) -> Day f h a -> Day g h a trans1 fg (Day fb hc bca abc) = Day (fg fb) hc bca abc -- | Apply a natural transformation to the right-hand side of a Day convolution. -- -- This respects the naturality of the natural transformation you supplied: -- -- @ -- 'invmap' f g '.' 'trans2' fg = 'trans2' fg '.' 'invmap' f g -- @ trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a trans2 gh (Day fb gc bca abc) = Day fb (gh gc) bca abc -- | Drop the covariant part of the Day convolution. toContravariant :: Day f g a -> Contravariant.Day f g a toContravariant (Day fb gc _ abc) = Contravariant.Day fb gc abc -- | Drop the contravariant part of the Day convolution. toCovariant :: Day f g a -> Covariant.Day f g a toCovariant (Day fb gc bca _) = Covariant.Day fb gc bca kan-extensions-5.2/src/Data/Functor/Kan/0000755000000000000000000000000013316662462016316 5ustar0000000000000000kan-extensions-5.2/src/Data/Functor/Kan/Ran.hs0000644000000000000000000001276513316662462017405 0ustar0000000000000000{-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------------------- -- | -- Copyright : 2008-2016 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : rank 2 types -- -- * Right Kan Extensions ------------------------------------------------------------------------------------------- module Data.Functor.Kan.Ran ( Ran(..) , toRan, fromRan , gran , composeRan, decomposeRan , adjointToRan, ranToAdjoint , composedAdjointToRan, ranToComposedAdjoint , repToRan, ranToRep , composedRepToRan, ranToComposedRep ) where import Data.Functor.Adjunction import Data.Functor.Composition import Data.Functor.Identity import Data.Functor.Rep -- | The right Kan extension of a 'Functor' h along a 'Functor' g. -- -- We can define a right Kan extension in several ways. The definition here is obtained by reading off -- the definition in of a right Kan extension in terms of an End, but we can derive an equivalent definition -- from the universal property. -- -- Given a 'Functor' @h : C -> D@ and a 'Functor' @g : C -> C'@, we want to extend @h@ /back/ along @g@ -- to give @Ran g h : C' -> D@, such that the natural transformation @'gran' :: Ran g h (g a) -> h a@ exists. -- -- In some sense this is trying to approximate the inverse of @g@ by using one of -- its adjoints, because if the adjoint and the inverse both exist, they match! -- -- > Hask -h-> Hask -- > | + -- > g / -- > | Ran g h -- > v / -- > Hask -' -- -- The Right Kan extension is unique (up to isomorphism) by taking this as its universal property. -- -- That is to say given any @K : C' -> D@ such that we have a natural transformation from @k.g@ to @h@ -- @(forall x. k (g x) -> h x)@ there exists a canonical natural transformation from @k@ to @Ran g h@. -- @(forall x. k x -> Ran g h x)@. -- -- We could literally read this off as a valid Rank-3 definition for 'Ran': -- -- @ -- data Ran' g h a = forall z. 'Functor' z => Ran' (forall x. z (g x) -> h x) (z a) -- @ -- -- This definition is isomorphic the simpler Rank-2 definition we use below as witnessed by the -- -- @ -- ranIso1 :: Ran g f x -> Ran' g f x -- ranIso1 (Ran e) = Ran' e id -- @ -- -- @ -- ranIso2 :: Ran' g f x -> Ran g f x -- ranIso2 (Ran' h z) = Ran $ \\k -> h (k \<$\> z) -- @ -- -- @ -- ranIso2 (ranIso1 (Ran e)) ≡ -- by definition -- ranIso2 (Ran' e id) ≡ -- by definition -- Ran $ \\k -> e (k \<$\> id) -- by definition -- Ran $ \\k -> e (k . id) -- f . id = f -- Ran $ \\k -> e k -- eta reduction -- Ran e -- @ -- -- The other direction is left as an exercise for the reader. newtype Ran g h a = Ran { runRan :: forall b. (a -> g b) -> h b } instance Functor (Ran g h) where fmap f m = Ran (\k -> runRan m (k . f)) {-# INLINE fmap #-} -- | The universal property of a right Kan extension. toRan :: Functor k => (forall a. k (g a) -> h a) -> k b -> Ran g h b toRan s t = Ran (s . flip fmap t) {-# INLINE toRan #-} -- | 'toRan' and 'fromRan' witness a higher kinded adjunction. from @(`'Compose'` g)@ to @'Ran' g@ -- -- @ -- 'toRan' . 'fromRan' ≡ 'id' -- 'fromRan' . 'toRan' ≡ 'id' -- @ fromRan :: (forall a. k a -> Ran g h a) -> k (g b) -> h b fromRan s = flip runRan id . s {-# INLINE fromRan #-} -- | -- @ -- 'composeRan' . 'decomposeRan' ≡ 'id' -- 'decomposeRan' . 'composeRan' ≡ 'id' -- @ composeRan :: Composition compose => Ran f (Ran g h) a -> Ran (compose f g) h a composeRan r = Ran (\f -> runRan (runRan r (decompose . f)) id) {-# INLINE composeRan #-} decomposeRan :: (Composition compose, Functor f) => Ran (compose f g) h a -> Ran f (Ran g h) a decomposeRan r = Ran (\f -> Ran (\g -> runRan r (compose . fmap g . f))) {-# INLINE decomposeRan #-} -- | -- -- @ -- 'adjointToRan' . 'ranToAdjoint' ≡ 'id' -- 'ranToAdjoint' . 'adjointToRan' ≡ 'id' -- @ adjointToRan :: Adjunction f g => f a -> Ran g Identity a adjointToRan f = Ran (\a -> Identity $ rightAdjunct a f) {-# INLINE adjointToRan #-} ranToAdjoint :: Adjunction f g => Ran g Identity a -> f a ranToAdjoint r = runIdentity (runRan r unit) {-# INLINE ranToAdjoint #-} -- | -- -- @ -- 'composedAdjointToRan' . 'ranToComposedAdjoint' ≡ 'id' -- 'ranToComposedAdjoint' . 'composedAdjointToRan' ≡ 'id' -- @ ranToComposedAdjoint :: Adjunction f g => Ran g h a -> h (f a) ranToComposedAdjoint r = runRan r unit {-# INLINE ranToComposedAdjoint #-} composedAdjointToRan :: (Adjunction f g, Functor h) => h (f a) -> Ran g h a composedAdjointToRan f = Ran (\a -> fmap (rightAdjunct a) f) {-# INLINE composedAdjointToRan #-} -- | This is the natural transformation that defines a Right Kan extension. gran :: Ran g h (g a) -> h a gran (Ran f) = f id {-# INLINE gran #-} repToRan :: Representable u => Rep u -> a -> Ran u Identity a repToRan e a = Ran $ \k -> Identity $ index (k a) e {-# INLINE repToRan #-} ranToRep :: Representable u => Ran u Identity a -> (Rep u, a) ranToRep (Ran f) = runIdentity $ f (\a -> tabulate $ \e -> (e, a)) {-# INLINE ranToRep #-} ranToComposedRep :: Representable u => Ran u h a -> h (Rep u, a) ranToComposedRep (Ran f) = f (\a -> tabulate $ \e -> (e, a)) {-# INLINE ranToComposedRep #-} composedRepToRan :: (Representable u, Functor h) => h (Rep u, a) -> Ran u h a composedRepToRan hfa = Ran $ \k -> fmap (\(e, a) -> index (k a) e) hfa {-# INLINE composedRepToRan #-} kan-extensions-5.2/src/Data/Functor/Kan/Lan.hs0000644000000000000000000000721213316662462017366 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------------------- -- | -- Copyright : 2008-2016 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : rank 2 types -- -- Left Kan Extensions ------------------------------------------------------------------------------------------- module Data.Functor.Kan.Lan ( -- * Left Kan Extensions Lan(..) , toLan, fromLan , glan , composeLan, decomposeLan , adjointToLan, lanToAdjoint , composedAdjointToLan, lanToComposedAdjoint ) where import Control.Applicative import Data.Functor.Adjunction import Data.Functor.Apply import Data.Functor.Composition import Data.Functor.Identity -- | The left Kan extension of a 'Functor' @h@ along a 'Functor' @g@. data Lan g h a where Lan :: (g b -> a) -> h b -> Lan g h a instance Functor (Lan f g) where fmap f (Lan g h) = Lan (f . g) h {-# INLINE fmap #-} instance (Functor g, Apply h) => Apply (Lan g h) where Lan kxf x <.> Lan kya y = Lan (\k -> kxf (fmap fst k) (kya (fmap snd k))) ((,) <$> x <.> y) {-# INLINE (<.>) #-} instance (Functor g, Applicative h) => Applicative (Lan g h) where pure a = Lan (const a) (pure ()) {-# INLINE pure #-} Lan kxf x <*> Lan kya y = Lan (\k -> kxf (fmap fst k) (kya (fmap snd k))) (liftA2 (,) x y) {-# INLINE (<*>) #-} -- | The universal property of a left Kan extension. toLan :: Functor f => (forall a. h a -> f (g a)) -> Lan g h b -> f b toLan s (Lan f v) = fmap f (s v) {-# INLINE toLan #-} -- | 'fromLan' and 'toLan' witness a (higher kinded) adjunction between @'Lan' g@ and @(`Compose` g)@ -- -- @ -- 'toLan' . 'fromLan' ≡ 'id' -- 'fromLan' . 'toLan' ≡ 'id' -- @ fromLan :: (forall a. Lan g h a -> f a) -> h b -> f (g b) fromLan s = s . glan {-# INLINE fromLan #-} -- | -- -- @ -- 'adjointToLan' . 'lanToAdjoint' ≡ 'id' -- 'lanToAdjoint' . 'adjointToLan' ≡ 'id' -- @ adjointToLan :: Adjunction f g => g a -> Lan f Identity a adjointToLan = Lan counit . Identity {-# INLINE adjointToLan #-} lanToAdjoint :: Adjunction f g => Lan f Identity a -> g a lanToAdjoint (Lan f v) = leftAdjunct f (runIdentity v) {-# INLINE lanToAdjoint #-} -- | 'lanToComposedAdjoint' and 'composedAdjointToLan' witness the natural isomorphism between @Lan f h@ and @Compose h g@ given @f -| g@ -- -- @ -- 'composedAdjointToLan' . 'lanToComposedAdjoint' ≡ 'id' -- 'lanToComposedAdjoint' . 'composedAdjointToLan' ≡ 'id' -- @ lanToComposedAdjoint :: (Functor h, Adjunction f g) => Lan f h a -> h (g a) lanToComposedAdjoint (Lan f v) = fmap (leftAdjunct f) v {-# INLINE lanToComposedAdjoint #-} composedAdjointToLan :: Adjunction f g => h (g a) -> Lan f h a composedAdjointToLan = Lan counit {-# INLINE composedAdjointToLan #-} -- | 'composeLan' and 'decomposeLan' witness the natural isomorphism from @Lan f (Lan g h)@ and @Lan (f `o` g) h@ -- -- @ -- 'composeLan' . 'decomposeLan' ≡ 'id' -- 'decomposeLan' . 'composeLan' ≡ 'id' -- @ composeLan :: (Composition compose, Functor f) => Lan f (Lan g h) a -> Lan (compose f g) h a composeLan (Lan f (Lan g h)) = Lan (f . fmap g . decompose) h {-# INLINE composeLan #-} decomposeLan :: Composition compose => Lan (compose f g) h a -> Lan f (Lan g h) a decomposeLan (Lan f h) = Lan (f . compose) (Lan id h) {-# INLINE decomposeLan #-} -- | This is the natural transformation that defines a Left Kan extension. glan :: h a -> Lan g h (g a) glan = Lan id {-# INLINE glan #-} kan-extensions-5.2/src/Data/Functor/Contravariant/0000755000000000000000000000000013316662462020420 5ustar0000000000000000kan-extensions-5.2/src/Data/Functor/Contravariant/Day.hs0000644000000000000000000001436013316662462021475 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 707 {-# LANGUAGE KindSignatures #-} #endif #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013-2016 Edward Kmett, Gershom Bazerman and Derek Elkins -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- The Day convolution of two contravariant functors is a contravariant -- functor. -- -- ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Day ( Day(..) , day , runDay , assoc, disassoc , swapped , intro1, intro2 , day1, day2 , diag , trans1, trans2 ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Data.Functor.Contravariant import Data.Functor.Contravariant.Rep import Data.Proxy import Data.Tuple (swap) #ifdef __GLASGOW_HASKELL__ import Data.Typeable #endif -- | The Day convolution of two contravariant functors. data Day f g a = forall b c. Day (f b) (g c) (a -> (b, c)) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 deriving Typeable #endif -- | Construct the Day convolution -- -- @ -- 'day1' ('day' f g) = f -- 'day2' ('day' f g) = g -- @ day :: f a -> g b -> Day f g (a, b) day fa gb = Day fa gb id #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 instance (Typeable1 f, Typeable1 g) => Typeable1 (Day f g) where typeOf1 tfga = mkTyConApp dayTyCon [typeOf1 (fa tfga), typeOf1 (ga tfga)] where fa :: t f (g :: * -> *) a -> f a fa = undefined ga :: t (f :: * -> *) g a -> g a ga = undefined dayTyCon :: TyCon #if MIN_VERSION_base(4,4,0) dayTyCon = mkTyCon3 "contravariant" "Data.Functor.Contravariant.Day" "Day" #else dayTyCon = mkTyCon "Data.Functor.Contravariant.Day.Day" #endif #endif instance Contravariant (Day f g) where contramap f (Day fb gc abc) = Day fb gc (abc . f) instance (Representable f, Representable g) => Representable (Day f g) where type Rep (Day f g) = (Rep f, Rep g) tabulate a2fg = Day (tabulate fst) (tabulate snd) $ \a -> let b = a2fg a in (b,b) index (Day fb gc abc) a = case abc a of (b, c) -> (index fb b, index gc c) {-# INLINE index #-} contramapWithRep d2eafg (Day fb gc abc) = Day (contramapWithRep id fb) (contramapWithRep id gc) $ \d -> case d2eafg d of Left a -> case abc a of (b, c) -> (Left b, Left c) Right (vf, vg) -> (Right vf, Right vg) {-# INLINE tabulate #-} -- | Break apart the Day convolution of two contravariant functors. runDay :: (Contravariant f, Contravariant g) => Day f g a -> (f a, g a) runDay (Day fb gc abc) = ( contramap (fst . abc) fb , contramap (snd . abc) gc ) -- | Day convolution provides a monoidal product. The associativity -- of this monoid is witnessed by 'assoc' and 'disassoc'. -- -- @ -- 'assoc' . 'disassoc' = 'id' -- 'disassoc' . 'assoc' = 'id' -- 'contramap' f '.' 'assoc' = 'assoc' '.' 'contramap' f -- @ assoc :: Day f (Day g h) a -> Day (Day f g) h a assoc (Day fb (Day gd he cde) abc) = Day (Day fb gd id) he $ \a -> case cde <$> abc a of (b, (d, e)) -> ((b, d), e) -- | Day convolution provides a monoidal product. The associativity -- of this monoid is witnessed by 'assoc' and 'disassoc'. -- -- @ -- 'assoc' . 'disassoc' = 'id' -- 'disassoc' . 'assoc' = 'id' -- 'contramap' f '.' 'disassoc' = 'disassoc' '.' 'contramap' f -- @ disassoc :: Day (Day f g) h a -> Day f (Day g h) a disassoc (Day (Day fd ge bde) hc abc) = Day fd (Day ge hc id) $ \a -> case abc a of (b, c) -> case bde b of (d, e) -> (d, (e, c)) -- | The monoid for Day convolution /in Haskell/ is symmetric. -- -- @ -- 'contramap' f '.' 'swapped' = 'swapped' '.' 'contramap' f -- @ swapped :: Day f g a -> Day g f a swapped (Day fb gc abc) = Day gc fb (swap . abc) -- | Proxy serves as the unit of Day convolution. -- -- @ -- 'day1' '.' 'intro1' = 'id' -- 'contramap' f '.' 'intro1' = 'intro1' '.' 'contramap' f -- @ intro1 :: f a -> Day Proxy f a intro1 fa = Day Proxy fa $ \a -> ((),a) -- | Proxy serves as the unit of Day convolution. -- -- @ -- 'day2' '.' 'intro2' = 'id' -- 'contramap' f '.' 'intro2' = 'intro2' '.' 'contramap' f -- @ intro2 :: f a -> Day f Proxy a intro2 fa = Day fa Proxy $ \a -> (a,()) -- | In Haskell we can do general purpose elimination, but in a more general setting -- it is only possible to eliminate the unit. -- -- @ -- 'day1' '.' 'intro1' = 'id' -- 'day1' = 'fst' '.' 'runDay' -- 'contramap' f '.' 'day1' = 'day1' '.' 'contramap' f -- @ day1 :: Contravariant f => Day f g a -> f a day1 (Day fb _ abc) = contramap (fst . abc) fb -- | In Haskell we can do general purpose elimination, but in a more general setting -- it is only possible to eliminate the unit. -- @ -- 'day2' '.' 'intro2' = 'id' -- 'day2' = 'snd' '.' 'runDay' -- 'contramap' f '.' 'day2' = 'day2' '.' 'contramap' f -- @ day2 :: Contravariant g => Day f g a -> g a day2 (Day _ gc abc) = contramap (snd . abc) gc -- | Diagonalize the Day convolution: -- -- @ -- 'day1' '.' 'diag' = 'id' -- 'day2' '.' 'diag' = 'id' -- 'runDay' '.' 'diag' = \a -> (a,a) -- 'contramap' f . 'diag' = 'diag' . 'contramap' f -- @ diag :: f a -> Day f f a diag fa = Day fa fa $ \a -> (a,a) -- | Apply a natural transformation to the left-hand side of a Day convolution. -- -- This respects the naturality of the natural transformation you supplied: -- -- @ -- 'contramap' f '.' 'trans1' fg = 'trans1' fg '.' 'contramap' f -- @ trans1 :: (forall x. f x -> g x) -> Day f h a -> Day g h a trans1 fg (Day fb hc abc) = Day (fg fb) hc abc -- | Apply a natural transformation to the right-hand side of a Day convolution. -- -- This respects the naturality of the natural transformation you supplied: -- -- @ -- 'contramap' f '.' 'trans2' fg = 'trans2' fg '.' 'contramap' f -- @ trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a trans2 gh (Day fb gc abc) = Day fb (gh gc) abc kan-extensions-5.2/src/Data/Functor/Contravariant/Yoneda.hs0000644000000000000000000000370013316662462022173 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UndecidableInstances #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : GADTs, TFs, MPTCs -- ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Yoneda ( Yoneda(..) , liftYoneda, lowerYoneda ) where import Data.Functor.Contravariant import Data.Functor.Contravariant.Adjunction import Data.Functor.Contravariant.Rep -- | Yoneda embedding for a presheaf newtype Yoneda f a = Yoneda { runYoneda :: forall r. (r -> a) -> f r } -- | -- -- @ -- 'liftYoneda' . 'lowerYoneda' ≡ 'id' -- 'lowerYoneda' . 'liftYoneda' ≡ 'id' -- @ liftYoneda :: Contravariant f => f a -> Yoneda f a liftYoneda fa = Yoneda $ \ra -> contramap ra fa {-# INLINE liftYoneda #-} lowerYoneda :: Yoneda f a -> f a lowerYoneda f = runYoneda f id {-# INLINE lowerYoneda #-} instance Contravariant (Yoneda f) where contramap ab (Yoneda m) = Yoneda (m . fmap ab) {-# INLINE contramap #-} instance Representable f => Representable (Yoneda f) where type Rep (Yoneda f) = Rep f tabulate = liftYoneda . tabulate {-# INLINE tabulate #-} index m a = index (lowerYoneda m) a {-# INLINE index #-} contramapWithRep beav = liftYoneda . contramapWithRep beav . lowerYoneda {-# INLINE contramapWithRep #-} instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where leftAdjunct f = liftYoneda . leftAdjunct (lowerYoneda . f) {-# INLINE leftAdjunct #-} rightAdjunct f = liftYoneda . rightAdjunct (lowerYoneda . f) {-# INLINE rightAdjunct #-} kan-extensions-5.2/src/Data/Functor/Contravariant/Coyoneda.hs0000644000000000000000000000441113316662462022515 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013-2016 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : GADTs, TFs, MPTCs -- -- The co-Yoneda lemma for presheafs states that @f@ is naturally isomorphic to @'Coyoneda' f@. -- ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Coyoneda ( Coyoneda(..) , liftCoyoneda , lowerCoyoneda ) where import Control.Arrow import Data.Functor.Contravariant import Data.Functor.Contravariant.Adjunction import Data.Functor.Contravariant.Rep -- | A 'Contravariant' functor (aka presheaf) suitable for Yoneda reduction. -- -- data Coyoneda f a where Coyoneda :: (a -> b) -> f b -> Coyoneda f a instance Contravariant (Coyoneda f) where contramap f (Coyoneda g m) = Coyoneda (g.f) m {-# INLINE contramap #-} instance Representable f => Representable (Coyoneda f) where type Rep (Coyoneda f) = Rep f tabulate = liftCoyoneda . tabulate {-# INLINE tabulate #-} index (Coyoneda ab fb) a = index fb (ab a) {-# INLINE index #-} contramapWithRep beav (Coyoneda ac fc) = Coyoneda (left ac . beav) (contramapWithRep id fc) {-# INLINE contramapWithRep #-} instance Adjunction f g => Adjunction (Coyoneda f) (Coyoneda g) where leftAdjunct f = liftCoyoneda . leftAdjunct (lowerCoyoneda . f) {-# INLINE leftAdjunct #-} rightAdjunct f = liftCoyoneda . rightAdjunct (lowerCoyoneda . f) {-# INLINE rightAdjunct #-} -- | Coyoneda "expansion" of a presheaf -- -- @ -- 'liftCoyoneda' . 'lowerCoyoneda' ≡ 'id' -- 'lowerCoyoneda' . 'liftCoyoneda' ≡ 'id' -- @ liftCoyoneda :: f a -> Coyoneda f a liftCoyoneda = Coyoneda id {-# INLINE liftCoyoneda #-} -- | Coyoneda reduction on a presheaf lowerCoyoneda :: Contravariant f => Coyoneda f a -> f a lowerCoyoneda (Coyoneda f m) = contramap f m {-# INLINE lowerCoyoneda #-}