kan-extensions-4.2.3/0000755000000000000000000000000012575401432012657 5ustar0000000000000000kan-extensions-4.2.3/.ghci0000644000000000000000000000012512575401432013570 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h kan-extensions-4.2.3/.gitignore0000644000000000000000000000010412575401432014642 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# kan-extensions-4.2.3/.travis.yml0000644000000000000000000000765612575401432015006 0ustar0000000000000000# This file has been generated -- see https://github.com/hvr/multi-ghc-travis language: c sudo: false cache: directories: - $HOME/.cabsnap - $HOME/.cabal/packages before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar matrix: include: - env: CABALVER=1.16 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.16 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.8.4 compiler: ": #GHC 7.8.4" addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.22 GHCVER=7.10.1 compiler: ": #GHC 7.10.1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.22 GHCVER=7.10.2 compiler: ": #GHC 7.10.2" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} before_install: - unset CC - export HAPPYVER=1.19.5 - export ALEXVER=3.1.4 - export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH install: - cabal --version - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; then zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; fi - travis_retry cabal update - "sed -i 's/^jobs:.*$/jobs: 2/' $HOME/.cabal/config" - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt # check whether current requested install-plan matches cached package-db snapshot - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; then echo "cabal build-cache HIT"; rm -rfv .ghc; cp -a $HOME/.cabsnap/ghc $HOME/.ghc; cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; else echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; cabal install --only-dependencies --enable-tests --enable-benchmarks; if [ "$GHCVER" = "7.10.1" ]; then cabal install Cabal-1.22.4.0; fi; fi # snapshot package-db on cache miss - if [ ! -d $HOME/.cabsnap ]; then echo "snapshotting package-db to build-cache"; mkdir $HOME/.cabsnap; cp -a $HOME/.ghc $HOME/.cabsnap/ghc; cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; fi # Here starts the actual work to be performed for the package under test; # any command which exits with a non-zero exit code causes the build to fail. script: - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging - cabal build # this builds all libraries and executables (including tests) - cabal test - cabal bench || true # expected result: these will crash - cabal sdist || true # tests that a source-distribution can be generated # Check that the resulting source distribution can be built & installed. # If there are no other `.tar.gz` files in `dist`, this can be even simpler: # `cabal install --force-reinstalls dist/*-*.tar.gz` - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ") notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313kan-extensions\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" # EOF kan-extensions-4.2.3/.vim.custom0000644000000000000000000000137712575401432014774 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-4.2.3/CHANGELOG.markdown0000644000000000000000000000445712575401432015724 0ustar00000000000000004.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-4.2.3/kan-extensions.cabal0000644000000000000000000000364612575401432016622 0ustar0000000000000000name: kan-extensions category: Data Structures, Monads, Comonads, Functors version: 4.2.3 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-2013 Edward A. Kmett synopsis: Kan extensions, Kan lifts, various forms of 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 extra-source-files: .travis.yml .gitignore .ghci .vim.custom CHANGELOG.markdown README.markdown source-repository head type: git location: git://github.com/ekmett/kan-extensions.git library hs-source-dirs: src 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 && < 5, containers >= 0.4 && < 0.6, contravariant >= 1 && < 2, distributive >= 0.2.2 && < 1, free >= 4 && < 5, mtl >= 2.0.1 && < 2.3, semigroupoids >= 4 && < 6, tagged >= 0.7.2 && < 1, transformers >= 0.2 && < 0.5 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.Kan.Lan Data.Functor.Kan.Lift Data.Functor.Kan.Ran Data.Functor.Kan.Rift Data.Functor.Yoneda Data.Functor.Coyoneda ghc-options: -Wall kan-extensions-4.2.3/LICENSE0000644000000000000000000000266012575401432013670 0ustar0000000000000000Copyright 2008-2013 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. kan-extensions-4.2.3/README.markdown0000644000000000000000000000174612575401432015370 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-4.2.3/Setup.lhs0000644000000000000000000000016512575401432014471 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain kan-extensions-4.2.3/src/0000755000000000000000000000000012575401432013446 5ustar0000000000000000kan-extensions-4.2.3/src/Control/0000755000000000000000000000000012575401432015066 5ustar0000000000000000kan-extensions-4.2.3/src/Control/Comonad/0000755000000000000000000000000012575401432016446 5ustar0000000000000000kan-extensions-4.2.3/src/Control/Comonad/Density.hs0000644000000000000000000000730012575401432020421 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Density -- Copyright : (C) 2008-2011 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' genererated 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-4.2.3/src/Control/Monad/0000755000000000000000000000000012575401432016124 5ustar0000000000000000kan-extensions-4.2.3/src/Control/Monad/Co.hs0000644000000000000000000001401312575401432017020 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011 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 sandwhich 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 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.KanLift.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 a = CoT (`extract` a) CoT k >>= f = CoT (k . extend (\wa a -> runCoT (f a) wa)) 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, Monad m) => CoT w m s posW = liftCoT0 pos peekW :: (ComonadStore s w, Monad m) => s -> CoT w m () peekW s = liftCoT1 (peek s) peeksW :: (ComonadStore s w, Monad m) => (s -> s) -> CoT w m () peeksW f = liftCoT1 (peeks f) askW :: (ComonadEnv e w, Monad m) => CoT w m e askW = liftCoT0 (Env.ask) asksW :: (ComonadEnv e w, Monad m) => (e -> a) -> CoT w m a asksW f = liftCoT0 (Env.asks f) traceW :: (ComonadTraced e w, Monad m) => 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 :: (Comonad w, 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-4.2.3/src/Control/Monad/Codensity.hs0000644000000000000000000001566112575401432020432 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Codensity -- Copyright : (C) 2008-2013 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 , improve ) where import Control.Applicative import Control.Monad (ap, MonadPlus(..)) 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 defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 import Data.Typeable #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 -- Voightländer for more information about this type. -- -- newtype Codensity m a = Codensity { runCodensity :: forall b. (a -> m b) -> m b } #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 deriving Typeable #endif instance Functor (Codensity k) where fmap f (Codensity m) = Codensity (\k -> m (k . f)) {-# INLINE fmap #-} instance Apply (Codensity f) where (<.>) = ap {-# INLINE (<.>) #-} instance Applicative (Codensity f) where pure x = Codensity (\k -> k x) {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-} instance Monad (Codensity f) where return x = Codensity (\k -> k x) {-# INLINE return #-} m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c)) {-# INLINE (>>=) #-} 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 (<|>) #-} 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 #-} -- | -- 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. lowerCodensity :: Monad m => Codensity m a -> m a lowerCodensity a = runCodensity a return {-# 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 #-} kan-extensions-4.2.3/src/Data/0000755000000000000000000000000012575401432014317 5ustar0000000000000000kan-extensions-4.2.3/src/Data/Functor/0000755000000000000000000000000012575401432015737 5ustar0000000000000000kan-extensions-4.2.3/src/Data/Functor/Coyoneda.hs0000644000000000000000000001742312575401432020043 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : 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 -- * as a Left Kan extension , coyonedaToLan, lanToCoyoneda -- * as a Left Kan lift , coyonedaToLift, liftToCoyoneda ) where import Control.Applicative 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 import Data.Function (on) import Data.Functor.Adjunction import Data.Functor.Bind import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Kan.Lan import Data.Functor.Kan.Lift 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. -- -- @ -- 'coyonedaToLan' . 'lanToCoyoneda' ≡ 'id' -- 'lanToCoyoneda' . 'coyonedaToLan' ≡ 'id' -- @ coyonedaToLan :: Coyoneda f a -> Lan Identity f a coyonedaToLan (Coyoneda ba fb) = Lan (ba . runIdentity) fb lanToCoyoneda :: Lan Identity f a -> Coyoneda f a lanToCoyoneda (Lan iba fb) = Coyoneda (iba . Identity) fb -- {-# RULES "coyonedaToLan/lanToCoyoneda=id" coyonedaToLan . lanToCoyoneda = id #-} -- {-# RULES "lanToCoyoneda/coyonedaToLan=id" lanToCoyoneda . coyonedaToLan = id #-} -- | @'Coyoneda' f@ is the left Kan lift of @f@ along the 'Identity' functor. -- -- @ -- 'coyonedaToLift' . 'liftToCoyoneda' ≡ 'id' -- 'liftToCoyoneda' . 'coyonedaToLift' ≡ 'id' -- @ coyonedaToLift :: Coyoneda f a -> Lift Identity f a coyonedaToLift (Coyoneda ba fb) = Lift $ \ f2iz -> ba <$> runIdentity (f2iz fb) liftToCoyoneda :: Functor f => Lift Identity f a -> Coyoneda f a liftToCoyoneda (Lift m) = Coyoneda id (m Identity) -- {-# RULES "coyonedaToLift/liftToCoyoneda=id" coyonedaToLift . liftToCoyoneda = id #-} -- {-# RULES "liftToCoyoneda/coyonedaToLift=id" liftToCoyoneda . coyonedaToLift = id #-} instance Functor (Coyoneda f) where fmap f (Coyoneda g v) = Coyoneda (f . g) v {-# INLINE fmap #-} instance Apply f => Apply (Coyoneda f) where m <.> n = liftCoyoneda $ lowerCoyoneda m <.> lowerCoyoneda n {-# INLINE (<.>) #-} instance Applicative f => Applicative (Coyoneda f) where pure = liftCoyoneda . pure {-# INLINE pure #-} m <*> n = liftCoyoneda $ lowerCoyoneda m <*> lowerCoyoneda n {-# INLINE (<*>) #-} instance Alternative f => Alternative (Coyoneda f) where empty = liftCoyoneda empty {-# INLINE empty #-} m <|> n = liftCoyoneda $ lowerCoyoneda m <|> lowerCoyoneda n {-# INLINE (<|>) #-} 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 return = Coyoneda id . return {-# INLINE return #-} 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, Show (f a)) => Show (Coyoneda f a) where showsPrec d (Coyoneda f a) = showParen (d > 10) $ showString "liftCoyoneda " . showsPrec 11 (fmap f a) {-# INLINE showsPrec #-} #ifdef __GLASGOW_HASKELL__ instance (Functor f, Read (f a)) => Read (Coyoneda f a) where readPrec = parens $ prec 10 $ do Ident "liftCoyoneda" <- lexP liftCoyoneda <$> step readPrec {-# INLINE readPrec #-} #endif instance (Functor f, Eq (f a)) => Eq (Coyoneda f a) where (==) = (==) `on` lowerCoyoneda {-# INLINE (==) #-} instance (Functor f, Ord (f a)) => Ord (Coyoneda f a) where compare = compare `on` lowerCoyoneda {-# INLINE compare #-} instance Adjunction f g => Adjunction (Coyoneda f) (Coyoneda g) where unit = liftCoyoneda . fmap liftCoyoneda . unit {-# INLINE unit #-} counit = counit . fmap 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 #-} kan-extensions-4.2.3/src/Data/Functor/Day.hs0000644000000000000000000001303712575401432017014 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014 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 ) where import Control.Applicative import Data.Distributive import Data.Functor.Identity import Data.Functor.Rep #ifdef __GLASGOW_HASKELL__ import Data.Typeable #endif -- | The Day convolution of two covariant functors. -- -- @Day f g a -> h a@ is isomorphic to @f a -> Rift g h a@ 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 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) -- | 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 kan-extensions-4.2.3/src/Data/Functor/Yoneda.hs0000644000000000000000000001715612575401432017524 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 ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Yoneda -- Copyright : (C) 2011-2013 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 -- * as a right Kan lift , yonedaToRift, riftToYoneda ) 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.Function (on) import Data.Functor.Adjunction import Data.Functor.Bind import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Kan.Ran import Data.Functor.Kan.Rift 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) lowerYoneda :: Yoneda f a -> f a lowerYoneda (Yoneda f) = f id -- {-# 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) ranToYoneda :: Ran Identity f a -> Yoneda f a ranToYoneda (Ran m) = Yoneda (m . fmap Identity) -- {-# RULES "yonedaToRan/ranToYoneda=id" yonedaToRan . ranToYoneda = id #-} -- {-# RULES "ranToYoneda/yonedaToRan=id" ranToYoneda . yonedaToRan = id #-} -- | @Yoneda f@ can be viewed as the right Kan lift of @f@ along the 'Identity' functor. -- -- @ -- 'yonedaToRift' . 'riftToYoneda' ≡ 'id' -- 'riftToYoneda' . 'yonedaToRift' ≡ 'id' -- @ yonedaToRift :: Yoneda f a -> Rift Identity f a yonedaToRift m = Rift (runYoneda m . runIdentity) {-# INLINE yonedaToRift #-} riftToYoneda :: Rift Identity f a -> Yoneda f a riftToYoneda m = Yoneda (runRift m . Identity) {-# INLINE riftToYoneda #-} -- {-# RULES "yonedaToRift/riftToYoneda=id" yonedaToRift . riftToYoneda = id #-} -- {-# RULES "riftToYoneda/yonedaToRift=id" riftToYoneda . yonedaToRift = id #-} instance Functor (Yoneda f) where fmap f m = Yoneda (\k -> runYoneda m (k . f)) instance Apply f => Apply (Yoneda f) where Yoneda m <.> Yoneda n = Yoneda (\f -> m (f .) <.> n id) instance Applicative f => Applicative (Yoneda f) where pure a = Yoneda (\f -> pure (f a)) Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id) instance Foldable f => Foldable (Yoneda f) where foldMap f = foldMap f . lowerYoneda instance Foldable1 f => Foldable1 (Yoneda f) where foldMap1 f = foldMap1 f . lowerYoneda instance Traversable f => Traversable (Yoneda f) where traverse f = fmap liftYoneda . traverse f . lowerYoneda instance Traversable1 f => Traversable1 (Yoneda f) where traverse1 f = fmap liftYoneda . traverse1 f . lowerYoneda instance Distributive f => Distributive (Yoneda f) where collect f = liftYoneda . collect (lowerYoneda . f) instance Representable g => Representable (Yoneda g) where type Rep (Yoneda g) = Rep g tabulate = liftYoneda . tabulate index = index . lowerYoneda instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where unit = liftYoneda . fmap liftYoneda . unit counit (Yoneda m) = counit (m lowerYoneda) -- instance Show1 f => Show1 (Yoneda f) where instance Show (f a) => Show (Yoneda f a) where showsPrec d (Yoneda f) = showParen (d > 10) $ showString "liftYoneda " . showsPrec 11 (f id) -- instance Read1 f => Read1 (Yoneda f) where #ifdef __GLASGOW_HASKELL__ instance (Functor f, Read (f a)) => Read (Yoneda f a) where readPrec = parens $ prec 10 $ do Ident "liftYoneda" <- lexP liftYoneda <$> step readPrec #endif instance Eq (f a) => Eq (Yoneda f a) where (==) = (==) `on` lowerYoneda instance Ord (f a) => Ord (Yoneda f a) where compare = compare `on` lowerYoneda 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) instance Plus f => Plus (Yoneda f) where zero = Yoneda $ const zero instance Alternative f => Alternative (Yoneda f) where empty = Yoneda $ const empty Yoneda f <|> Yoneda g = Yoneda (\k -> f k <|> g k) instance Bind m => Bind (Yoneda m) where Yoneda m >>- k = Yoneda (\f -> m id >>- \a -> runYoneda (k a) f) instance Monad m => Monad (Yoneda m) where return a = Yoneda (\f -> return (f a)) Yoneda m >>= k = Yoneda (\f -> m id >>= \a -> runYoneda (k a) f) instance MonadFix m => MonadFix (Yoneda m) where mfix f = lift $ mfix (lowerYoneda . f) instance MonadPlus m => MonadPlus (Yoneda m) where mzero = Yoneda (const mzero) Yoneda f `mplus` Yoneda g = Yoneda (\k -> f k `mplus` g k) instance MonadTrans Yoneda where lift a = Yoneda (\f -> liftM f a) instance (Functor f, MonadFree f m) => MonadFree f (Yoneda m) where wrap = lift . wrap . fmap lowerYoneda instance Extend w => Extend (Yoneda w) where extended k (Yoneda m) = Yoneda (\f -> extended (f . k . liftYoneda) (m id)) instance Comonad w => Comonad (Yoneda w) where extend k (Yoneda m) = Yoneda (\f -> extend (f . k . liftYoneda) (m id)) extract = extract . lowerYoneda instance ComonadTrans Yoneda where lower = lowerYoneda kan-extensions-4.2.3/src/Data/Functor/Contravariant/0000755000000000000000000000000012575401432020552 5ustar0000000000000000kan-extensions-4.2.3/src/Data/Functor/Contravariant/Coyoneda.hs0000644000000000000000000000440412575401432022651 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013 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 #-} kan-extensions-4.2.3/src/Data/Functor/Contravariant/Day.hs0000644000000000000000000001436012575401432021627 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-2014 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-4.2.3/src/Data/Functor/Contravariant/Yoneda.hs0000644000000000000000000000367312575401432022336 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 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-4.2.3/src/Data/Functor/Kan/0000755000000000000000000000000012575401432016450 5ustar0000000000000000kan-extensions-4.2.3/src/Data/Functor/Kan/Lan.hs0000644000000000000000000000711112575401432017516 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------------------- -- | -- Copyright : 2008-2013 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-4.2.3/src/Data/Functor/Kan/Lift.hs0000644000000000000000000001120012575401432017674 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------------------- -- | -- Copyright : 2013 Edward Kmett and Dan Doel -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : rank N types -- -- Left Kan lifts for functors over Hask, wherever they exist. -- -- ------------------------------------------------------------------------------------------- module Data.Functor.Kan.Lift ( -- * Left Kan lifts Lift(..) , toLift, fromLift, glift , composeLift, decomposeLift , adjointToLift, liftToAdjoint , liftToComposedAdjoint, composedAdjointToLift , repToLift, liftToRep , liftToComposedRep, composedRepToLift ) where import Data.Functor.Adjunction import Data.Functor.Composition import Data.Functor.Compose import Data.Functor.Identity import Data.Functor.Rep -- * Left Kan Lift -- | -- > f => g . Lift g f -- > (forall z. f => g . z) -> Lift g f => z -- couniversal -- -- Here we use the universal property directly as how we extract from our definition of 'Lift'. newtype Lift g f a = Lift { runLift :: forall z. Functor z => (forall x. f x -> g (z x)) -> z a } instance Functor (Lift g h) where fmap f (Lift g) = Lift (\x -> fmap f (g x)) {-# INLINE fmap #-} -- | -- -- @f => g ('Lift' g f a)@ glift :: Adjunction l g => k a -> g (Lift g k a) glift = leftAdjunct (\lka -> Lift (\k2gz -> rightAdjunct k2gz lka)) {-# INLINE glift #-} -- | The universal property of 'Lift' toLift :: Functor z => (forall a. f a -> g (z a)) -> Lift g f b -> z b toLift f l = runLift l f {-# INLINE toLift #-} -- | When the adjunction exists -- -- @ -- 'fromLift' . 'toLift' ≡ 'id' -- 'toLift' . 'fromLift' ≡ 'id' -- @ fromLift :: Adjunction l u => (forall a. Lift u f a -> z a) -> f b -> u (z b) fromLift f = fmap f . glift {-# INLINE fromLift #-} -- | -- -- @ -- 'composeLift' . 'decomposeLift' = 'id' -- 'decomposeLift' . 'composeLift' = 'id' -- @ composeLift :: (Composition compose, Functor f, Functor g) => Lift f (Lift g h) a -> Lift (compose g f) h a composeLift (Lift m) = Lift $ \h -> m $ decompose . toLift (fmap Compose . decompose . h) {-# INLINE composeLift #-} decomposeLift :: (Composition compose, Adjunction l g) => Lift (compose g f) h a -> Lift f (Lift g h) a decomposeLift (Lift m) = Lift $ \h -> m (compose . fmap h . glift) {-# INLINE decomposeLift #-} -- | @Lift u Identity a@ is isomorphic to the left adjoint to @u@ if one exists. -- -- @ -- 'adjointToLift' . 'liftToAdjoint' ≡ 'id' -- 'liftToAdjoint' . 'adjointToLift' ≡ 'id' -- @ adjointToLift :: Adjunction f u => f a -> Lift u Identity a adjointToLift fa = Lift $ \k -> rightAdjunct (k . Identity) fa {-# INLINE adjointToLift #-} -- | @Lift u Identity a@ is isomorphic to the left adjoint to @u@ if one exists. liftToAdjoint :: Adjunction f u => Lift u Identity a -> f a liftToAdjoint = toLift (unit . runIdentity) {-# INLINE liftToAdjoint #-} -- | -- -- @ -- 'repToLift' . 'liftToRep' ≡ 'id' -- 'liftToRep' . 'repToLift' ≡ 'id' -- @ repToLift :: Representable u => Rep u -> a -> Lift u Identity a repToLift e a = Lift $ \k -> index (k (Identity a)) e {-# INLINE repToLift #-} liftToRep :: Representable u => Lift u Identity a -> (Rep u, a) liftToRep (Lift m) = m $ \(Identity a) -> tabulate $ \e -> (e, a) {-# INLINE liftToRep #-} -- | @Lift u h a@ is isomorphic to the post-composition of the left adjoint of @u@ onto @h@ if such a left adjoint exists. -- -- @ -- 'liftToComposedAdjoint' . 'composedAdjointToLift' ≡ 'id' -- 'composedAdjointToLift' . 'liftToComposedAdjoint' ≡ 'id' -- @ liftToComposedAdjoint :: (Adjunction f u, Functor h) => Lift u h a -> f (h a) liftToComposedAdjoint (Lift m) = decompose $ m (leftAdjunct Compose) {-# INLINE liftToComposedAdjoint #-} -- | @Lift u h a@ is isomorphic to the post-composition of the left adjoint of @u@ onto @h@ if such a left adjoint exists. composedAdjointToLift :: Adjunction f u => f (h a) -> Lift u h a composedAdjointToLift = rightAdjunct glift {-# INLINE composedAdjointToLift #-} -- | -- -- @ -- 'liftToComposedRep' . 'composedRepToLift' ≡ 'id' -- 'composedRepToLift' . 'liftToComposedRep' ≡ 'id' -- @ liftToComposedRep :: (Functor h, Representable u) => Lift u h a -> (Rep u, h a) liftToComposedRep (Lift m) = decompose $ m $ \h -> tabulate $ \e -> Compose (e, h) {-# INLINE liftToComposedRep #-} composedRepToLift :: Representable u => Rep u -> h a -> Lift u h a composedRepToLift e ha = Lift $ \h2uz -> index (h2uz ha) e {-# INLINE composedRepToLift #-} kan-extensions-4.2.3/src/Data/Functor/Kan/Ran.hs0000644000000000000000000001266412575401432017535 0ustar0000000000000000{-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------------------- -- | -- Copyright : 2008-2013 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' -> C@, 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' -> C@ 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-4.2.3/src/Data/Functor/Kan/Rift.hs0000644000000000000000000001507012575401432017713 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------------------- -- | -- Copyright : 2013 Edward Kmett and Dan Doel -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : rank N types -- -- Right and Left Kan lifts for functors over Hask, where they exist. -- -- ------------------------------------------------------------------------------------------- module Data.Functor.Kan.Rift ( -- * Right Kan lifts Rift(..) , toRift, fromRift, grift , composeRift, decomposeRift , adjointToRift, riftToAdjoint , composedAdjointToRift, riftToComposedAdjoint , liftRift, lowerRift, rap ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Data.Functor.Adjunction import Data.Functor.Composition import Data.Functor.Identity -- * Right Kan Lift -- | -- -- @g . 'Rift' g f => f@ -- -- This could alternately be defined directly from the (co)universal propertly -- in which case, we'd get 'toRift' = 'UniversalRift', but then the usage would -- suffer. -- -- @ -- data 'UniversalRift' g f a = forall z. 'Functor' z => -- 'UniversalRift' (forall x. g (z x) -> f x) (z a) -- @ -- -- We can witness the isomorphism between Rift and UniversalRift using: -- -- @ -- riftIso1 :: Functor g => UniversalRift g f a -> Rift g f a -- riftIso1 (UniversalRift h z) = Rift $ \\g -> h $ fmap (\\k -> k \<$\> z) g -- @ -- -- @ -- riftIso2 :: Rift g f a -> UniversalRift g f a -- riftIso2 (Rift e) = UniversalRift e id -- @ -- -- @ -- riftIso1 (riftIso2 (Rift h)) = -- riftIso1 (UniversalRift h id) = -- by definition -- Rift $ \\g -> h $ fmap (\\k -> k \<$\> id) g -- by definition -- Rift $ \\g -> h $ fmap id g -- \<$\> = (.) and (.id) -- Rift $ \\g -> h g -- by functor law -- Rift h -- eta reduction -- @ -- -- The other direction is left as an exercise for the reader. -- -- There are several monads that we can form from @Rift@. -- -- When @g@ is corepresentable (e.g. is a right adjoint) then there exists @x@ such that @g ~ (->) x@, then it follows that -- -- @ -- Rift g g a ~ -- forall r. (x -> a -> r) -> x -> r ~ -- forall r. (a -> x -> r) -> x -> r ~ -- forall r. (a -> g r) -> g r ~ -- Codensity g r -- @ -- -- When @f@ is a left adjoint, so that @f -| g@ then -- -- @ -- Rift f f a ~ -- forall r. f (a -> r) -> f r ~ -- forall r. (a -> r) -> g (f r) ~ -- forall r. (a -> r) -> Adjoint f g r ~ -- Yoneda (Adjoint f g r) -- @ -- -- An alternative way to view that is to note that whenever @f@ is a left adjoint then @f -| 'Rift' f 'Identity'@, and since @'Rift' f f@ is isomorphic to @'Rift' f 'Identity' (f a)@, this is the 'Monad' formed by the adjunction. -- -- @'Rift' 'Identity' m@ can be a 'Monad' for any 'Monad' @m@, as it is isomorphic to @'Yoneda' m@. newtype Rift g h a = Rift { runRift :: forall r. g (a -> r) -> h r } instance Functor g => Functor (Rift g h) where fmap f (Rift g) = Rift (g . fmap (.f)) {-# INLINE fmap #-} instance (Functor g, g ~ h) => Applicative (Rift g h) where pure a = Rift (fmap ($a)) {-# INLINE pure #-} Rift mf <*> Rift ma = Rift (ma . mf . fmap (.)) {-# INLINE (<*>) #-} -- | The natural isomorphism between @f@ and @Rift f f@. -- @ -- 'lowerRift' '.' 'liftRift' ≡ 'id' -- 'liftRift' '.' 'lowerRift' ≡ 'id' -- @ -- -- @ -- 'lowerRift' ('liftRift' x) -- definition -- 'lowerRift' ('Rift' ('<*>' x)) -- definition -- ('<*>' x) ('pure' 'id') -- beta reduction -- 'pure' 'id' '<*>' x -- Applicative identity law -- x -- @ liftRift :: Applicative f => f a -> Rift f f a liftRift fa = Rift (<*> fa) {-# INLINE liftRift #-} -- | Lower 'Rift' by applying 'pure' 'id' to the continuation. -- -- See 'liftRift'. lowerRift :: Applicative f => Rift f g a -> g a lowerRift (Rift f) = f (pure id) {-# INLINE lowerRift #-} -- | Indexed applicative composition of right Kan lifts. rap :: Functor f => Rift f g (a -> b) -> Rift g h a -> Rift f h b rap (Rift mf) (Rift ma) = Rift (ma . mf . fmap (.)) {-# INLINE rap #-} grift :: Adjunction f u => f (Rift f k a) -> k a grift = rightAdjunct (\r -> leftAdjunct (runRift r) id) {-# INLINE grift #-} -- | The universal property of 'Rift' toRift :: (Functor g, Functor k) => (forall x. g (k x) -> h x) -> k a -> Rift g h a toRift h z = Rift $ \g -> h $ fmap (<$> z) g {-# INLINE toRift #-} -- | -- When @f -| u@, then @f -| Rift f Identity@ and -- -- @ -- 'toRift' . 'fromRift' ≡ 'id' -- 'fromRift' . 'toRift' ≡ 'id' -- @ fromRift :: Adjunction f u => (forall a. k a -> Rift f h a) -> f (k b) -> h b fromRift f = grift . fmap f {-# INLINE fromRift #-} -- | @Rift f Identity a@ is isomorphic to the right adjoint to @f@ if one exists. -- -- @ -- 'adjointToRift' . 'riftToAdjoint' ≡ 'id' -- 'riftToAdjoint' . 'adjointToRift' ≡ 'id' -- @ adjointToRift :: Adjunction f u => u a -> Rift f Identity a adjointToRift ua = Rift (Identity . rightAdjunct (<$> ua)) {-# INLINE adjointToRift #-} -- | @Rift f Identity a@ is isomorphic to the right adjoint to @f@ if one exists. riftToAdjoint :: Adjunction f u => Rift f Identity a -> u a riftToAdjoint (Rift m) = leftAdjunct (runIdentity . m) id {-# INLINE riftToAdjoint #-} -- | -- -- @ -- 'composeRift' . 'decomposeRift' ≡ 'id' -- 'decomposeRift' . 'composeRift' ≡ 'id' -- @ composeRift :: (Composition compose, Adjunction g u) => Rift f (Rift g h) a -> Rift (compose g f) h a composeRift (Rift f) = Rift (grift . fmap f . decompose) {-# INLINE composeRift #-} decomposeRift :: (Composition compose, Functor f, Functor g) => Rift (compose g f) h a -> Rift f (Rift g h) a decomposeRift (Rift f) = Rift $ \far -> Rift (f . compose . fmap (\rs -> fmap (rs.) far)) {-# INLINE decomposeRift #-} -- | @Rift f h a@ is isomorphic to the post-composition of the right adjoint of @f@ onto @h@ if such a right adjoint exists. -- -- @ -- 'riftToComposedAdjoint' . 'composedAdjointToRift' ≡ 'id' -- 'composedAdjointToRift' . 'riftToComposedAdjoint' ≡ 'id' -- @ riftToComposedAdjoint :: Adjunction f u => Rift f h a -> u (h a) riftToComposedAdjoint (Rift m) = leftAdjunct m id {-# INLINE riftToComposedAdjoint #-} -- | @Rift f h a@ is isomorphic to the post-composition of the right adjoint of @f@ onto @h@ if such a right adjoint exists. composedAdjointToRift :: (Functor h, Adjunction f u) => u (h a) -> Rift f h a composedAdjointToRift uha = Rift $ rightAdjunct (\b -> fmap b <$> uha) {-# INLINE composedAdjointToRift #-}