kan-extensions-5.0.1/0000755000000000000000000000000012646577011012662 5ustar0000000000000000kan-extensions-5.0.1/.ghci0000644000000000000000000000012512646577010013572 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h kan-extensions-5.0.1/.gitignore0000644000000000000000000000010412646577010014644 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# kan-extensions-5.0.1/.travis.yml0000644000000000000000000001013712646577010014774 0ustar0000000000000000# This file has been generated -- see https://github.com/hvr/multi-ghc-travis language: c sudo: false cache: directories: - $HOME/.cabsnap - $HOME/.cabal/packages before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar matrix: include: - env: CABALVER=1.18 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3,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]}} - env: CABALVER=1.24 GHCVER=8.0.1 compiler: ": #GHC 8.0.1" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,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-5.0.1/.vim.custom0000644000000000000000000000137712646577010014776 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.0.1/CHANGELOG.markdown0000644000000000000000000000464712646577011015730 0ustar00000000000000005.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.0.1/kan-extensions.cabal0000644000000000000000000000361712646577010016622 0ustar0000000000000000name: kan-extensions category: Data Structures, Monads, Comonads, Functors version: 5.0.1 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, 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 && < 6, 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.6 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.Kan.Lan Data.Functor.Kan.Ran Data.Functor.Yoneda Data.Functor.Coyoneda ghc-options: -Wall kan-extensions-5.0.1/LICENSE0000644000000000000000000000266012646577010013672 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.0.1/README.markdown0000644000000000000000000000174612646577011015373 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.0.1/Setup.lhs0000644000000000000000000000016512646577010014473 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain kan-extensions-5.0.1/src/0000755000000000000000000000000012646577010013450 5ustar0000000000000000kan-extensions-5.0.1/src/Control/0000755000000000000000000000000012646577010015070 5ustar0000000000000000kan-extensions-5.0.1/src/Control/Comonad/0000755000000000000000000000000012646577010016450 5ustar0000000000000000kan-extensions-5.0.1/src/Control/Comonad/Density.hs0000644000000000000000000000730012646577010020423 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# 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' 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-5.0.1/src/Control/Monad/0000755000000000000000000000000012646577010016126 5ustar0000000000000000kan-extensions-5.0.1/src/Control/Monad/Co.hs0000644000000000000000000001366312646577010017034 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-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 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.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 => 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.0.1/src/Control/Monad/Codensity.hs0000644000000000000000000001610412646577010020425 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DeriveDataTypeable #-} #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 , improve ) where import Control.Applicative import Control.Monad (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 __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 -- Voigtländer for more information about this type. -- -- newtype Codensity m a = Codensity { runCodensity :: forall b. (a -> m b) -> m b } #if __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 (<.>) = (<*>) {-# INLINE (<.>) #-} instance Applicative (Codensity f) where pure x = Codensity (\k -> k x) {-# INLINE pure #-} Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (bfr . ab))) {-# INLINE (<*>) #-} instance Monad (Codensity f) where return = pure {-# 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 (<|>) #-} #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 #-} kan-extensions-5.0.1/src/Data/0000755000000000000000000000000012646577010014321 5ustar0000000000000000kan-extensions-5.0.1/src/Data/Functor/0000755000000000000000000000000012646577010015741 5ustar0000000000000000kan-extensions-5.0.1/src/Data/Functor/Coyoneda.hs0000644000000000000000000001733012646577010020042 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-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 -- * as a Left Kan extension , coyonedaToLan, lanToCoyoneda ) 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.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 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 #-} 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 #if __GLASGOW_HASKELL__ < 710 return = Coyoneda id . return {-# INLINE return #-} #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, 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-5.0.1/src/Data/Functor/Day.hs0000644000000000000000000001304412646577010017014 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 ) 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-5.0.1/src/Data/Functor/Yoneda.hs0000644000000000000000000001574112646577010017524 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-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.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.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 #-} 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 #if __GLASGOW_HASKELL__ < 710 return a = Yoneda (\f -> return (f a)) #endif 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-5.0.1/src/Data/Functor/Contravariant/0000755000000000000000000000000012646577010020554 5ustar0000000000000000kan-extensions-5.0.1/src/Data/Functor/Contravariant/Coyoneda.hs0000644000000000000000000000441112646577010022651 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 #-} kan-extensions-5.0.1/src/Data/Functor/Contravariant/Day.hs0000644000000000000000000001436012646577010021631 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.0.1/src/Data/Functor/Contravariant/Yoneda.hs0000644000000000000000000000370012646577010022327 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.0.1/src/Data/Functor/Day/0000755000000000000000000000000012646577010016456 5ustar0000000000000000kan-extensions-5.0.1/src/Data/Functor/Day/Curried.hs0000644000000000000000000001123312646577010020407 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.0.1/src/Data/Functor/Kan/0000755000000000000000000000000012646577010016452 5ustar0000000000000000kan-extensions-5.0.1/src/Data/Functor/Kan/Lan.hs0000644000000000000000000000711112646577010017520 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} #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.0.1/src/Data/Functor/Kan/Ran.hs0000644000000000000000000001266412646577010017537 0ustar0000000000000000{-# LANGUAGE Rank2Types, GADTs #-} {-# LANGUAGE CPP #-} #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' -> 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 #-}