kan-extensions 5.0.2 → 5.2.8
raw patch · 19 files changed
Files
- .ghci +0/−1
- .gitignore +22/−0
- .travis.yml +0/−108
- CHANGELOG.markdown +66/−0
- README.markdown +1/−1
- kan-extensions.cabal +34/−21
- src/Control/Comonad/Density.hs +4/−4
- src/Control/Monad/Co.hs +4/−9
- src/Control/Monad/Codensity.hs +78/−41
- src/Data/Functor/Contravariant/Coyoneda.hs +8/−4
- src/Data/Functor/Contravariant/Day.hs +13/−35
- src/Data/Functor/Contravariant/Yoneda.hs +0/−3
- src/Data/Functor/Coyoneda.hs +36/−22
- src/Data/Functor/Day.hs +23/−28
- src/Data/Functor/Day/Curried.hs +13/−10
- src/Data/Functor/Invariant/Day.hs +150/−0
- src/Data/Functor/Kan/Lan.hs +3/−3
- src/Data/Functor/Kan/Ran.hs +4/−6
- src/Data/Functor/Yoneda.hs +64/−15
− .ghci
@@ -1,1 +0,0 @@-:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
.gitignore view
@@ -1,4 +1,5 @@ dist+dist-newstyle docs wiki TAGS@@ -11,3 +12,24 @@ *.hi *~ *#+.stack-work/+cabal-dev+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+.cabal-sandbox/+cabal.sandbox.config+*.prof+*.aux+*.hp+*.eventlog+cabal.project.local+cabal.project.local~+.HTF/+.ghc.environment.*+/default.nix+/shell.nix+/result
− .travis.yml
@@ -1,108 +0,0 @@-# 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.3- compiler: ": #GHC 7.10.3"- addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=1.24 GHCVER=8.0.2- compiler: ": #GHC 8.0.2"- addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=2.0 GHCVER=8.2.1- compiler: ": #GHC 8.2.1"- addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}- - env: CABALVER=head GHCVER=head- compiler: ": #GHC head"- addons: {apt: {packages: [cabal-install-head,ghc-head,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}}-- allow_failures:- - env: CABALVER=head GHCVER=head--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;- 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
CHANGELOG.markdown view
@@ -1,3 +1,69 @@+5.2.8 [2026.01.10]+------------------+* Add `MonadThrow` instance for `Codensity`.+* Remove unused `array`, `containers`, and `tagged` dependencies.++5.2.7 [2025.06.17]+------------------+* Make the implementations of `(.>)` and `(*>)` for `Data.Functor.Yoneda` more+ stack-efficient.++5.2.6 [2024.05.04]+------------------+* Drop support for GHC 8.2 and earlier.+* Generalize instances in `Control.Monad.Codensity` to be of the form:++ ```hs+ instance (f ~~ f', MonadFail f') => MonadFail (Codensity (f :: k -> TYPE rep))+ ```++ This avoids having to constrain `k ~ Type` and `rep ~ LiftedRep`, which could potentially harm type inference.+* Explicitly implement `liftA2` in the `Applicative` instance for `Data.Functor.Day.Curried`.+* Add an `Adjunction` instance for `Data.Functor.Day`.+* Add `Adjunction` and `Divisible` instances for `Data.Functor.Contravariant.Day`.+* Add an `Apply` instance for `Data.Functor.Day.Curried`.++5.2.5 [2022.06.26]+------------------+* Only require a `Functor` constraint in the `Eq` and `Ord` instances for+ `Coyoneda` when building against `transformers-0.4.*`.++5.2.4 [2022.05.07]+------------------+* Allow building with `transformers-0.6.*` and `mtl-2.3.*`.++5.2.3 [2021.07.27]+------------------+* Add `shift` and `reset` to `Control.Monad.Codensity`.++5.2.2 [2021.02.17]+------------------+* Add `hoistCoyoneda` to `Data.Functor.Contravariant.Coyoneda`.++5.2.1 [2020.10.01]+------------------+* Allow building with GHC 9.0.++5.2 [2018.07.03]+----------------+* Make `Codensity` levity polymorphic.+* Add the `Data.Functor.Invariant.Day` module, which combines the covariant and+ contravariant versions of `Day`. As a result, `kan-extensions` now depends on+ the `invariant` package.+* Add a `wrapCodensity` function.+* More efficient `Eq1`, `Ord1`, and `Adjunction` instances for `Coyoneda`.+* Add `INLINE` pragmas on more functions.+* Allow building with `containers-0.6`.++5.1 [2018.01.28]+----------------+* Make `Density`, `Codensity`, `Kan` and `Lan` polykinded.+* Add `Eq1`, `Ord1`, `Read1` and `Show1` instances for `Coyoneda` and `Yoneda`.+* Change contexts of `Eq` and `Ord` instances of `Coyoneda` and `Yoneda`+ (and the `Show` instance for `Coyoneda`) to require lifted class instances,+ e.g. `Eq1 f, Eq a`.+* Allow `free-5`.+ 5.0.2 ----- * Added `hoistCoyoneda`
README.markdown view
@@ -1,7 +1,7 @@ kan-extensions ============== -[](https://hackage.haskell.org/package/kan-extensions) [](http://travis-ci.org/ekmett/kan-extensions)+[](https://hackage.haskell.org/package/kan-extensions) [](https://github.com/ekmett/kan-extensions/actions?query=workflow%3AHaskell-CI) This package provides tools for working with various Kan extensions and Kan lifts in Haskell.
kan-extensions.cabal view
@@ -1,8 +1,8 @@ name: kan-extensions category: Data Structures, Monads, Comonads, Functors-version: 5.0.2+version: 5.2.8 license: BSD3-cabal-version: >= 1.6+cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com>@@ -10,21 +10,31 @@ 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+synopsis: Kan extensions, Kan lifts, the Yoneda lemma, and (co)density (co)monads+description: Kan extensions, Kan lifts, various forms of the Yoneda lemma, and (co)density (co)monads. build-type: Simple+tested-with: GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.3+ , GHC == 9.12.2+ , GHC == 9.14.1 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+ location: https://github.com/ekmett/kan-extensions.git library hs-source-dirs: src@@ -40,19 +50,18 @@ 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,- fail >= 4.9 && < 5,- free >= 4 && < 5,- mtl >= 2.0.1 && < 2.3,- semigroupoids >= 4 && < 6,- tagged >= 0.7.2 && < 1,- transformers >= 0.2 && < 0.6+ adjunctions >= 4.2 && < 5,+ base >= 4.11 && < 5,+ comonad >= 4 && < 6,+ contravariant >= 1 && < 2,+ distributive >= 0.2.2 && < 1,+ exceptions >= 0.10 && < 0.11,+ invariant >= 0.1 && < 1,+ free >= 4 && < 6,+ mtl >= 2.2.1 && < 2.4,+ profunctors >= 5 && < 6,+ semigroupoids >= 5.2.2 && < 7,+ transformers >= 0.5 && < 0.7 exposed-modules: Control.Comonad.Density@@ -63,10 +72,14 @@ Data.Functor.Contravariant.Coyoneda Data.Functor.Day Data.Functor.Day.Curried+ Data.Functor.Invariant.Day Data.Functor.Kan.Lan Data.Functor.Kan.Ran Data.Functor.Yoneda Data.Functor.Coyoneda - ghc-options: -Wall+ ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -Wno-trustworthy-safe+ if !impl(ghc >= 8.8)+ ghc-options: -Wnoncanonical-monadfail-instances + default-language: Haskell2010
src/Control/Comonad/Density.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710-{-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Comonad.Density@@ -16,7 +14,7 @@ -- -- 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+-- 'Monad' generated by a 'Functor' dates back to 1972 in Street''s -- ''Formal Theory of Monads''. -- -- The left Kan extension of a 'Functor' along itself (@'Lan' f f@) forms a 'Comonad'. This is@@ -29,7 +27,9 @@ , densityToLan, lanToDensity ) where +#if !(MIN_VERSION_base(4,18,0)) import Control.Applicative+#endif import Control.Comonad import Control.Comonad.Trans.Class import Data.Functor.Apply
src/Control/Monad/Co.hs view
@@ -1,12 +1,9 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE PolyKinds #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2016 Edward Kmett@@ -29,7 +26,7 @@ -- 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+-- 'Contravariant' functor @(-> r) :: Hask -> Hask^op@. So we can sandwich a -- Monad in Hask^op in the middle to obtain @w (a -> r-) -> r+@, and then take a coend over -- @r@ to obtain @forall r. w (a -> r) -> r@. This gives rise to 'Co'. If we observe that -- we didn't care what the choices we made for @r@ were to finish this construction, we can@@ -54,19 +51,17 @@ , 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 ((<=<), liftM) import Control.Monad.Error.Class import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class-import Control.Monad.Identity+import Control.Monad.Identity (Identity(..)) import Control.Monad.Reader.Class as Reader import Control.Monad.State.Class import Control.Monad.Trans.Class
src/Control/Monad/Codensity.hs view
@@ -1,13 +1,15 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#if __GLASGOW_HASKELL__ < 806+{-# LANGUAGE TypeInType #-} #endif -----------------------------------------------------------------------------@@ -27,11 +29,16 @@ , codensityToAdjunction, adjunctionToCodensity , codensityToRan, ranToCodensity , codensityToComposedRep, composedRepToCodensity+ , wrapCodensity , improve+ -- ** Delimited continuations+ , reset+ , shift ) where import Control.Applicative import Control.Monad (MonadPlus(..))+import Control.Monad.Catch (MonadThrow(..)) import qualified Control.Monad.Fail as Fail import Control.Monad.Free import Control.Monad.IO.Class@@ -43,9 +50,8 @@ import Data.Functor.Kan.Ran import Data.Functor.Plus import Data.Functor.Rep-#if __GLASGOW_HASKELL__ >= 708-import Data.Typeable-#endif+import Data.Type.Equality (type (~~))+import GHC.Exts (TYPE) -- | -- @'Codensity' f@ is the Monad generated by taking the right Kan extension@@ -57,39 +63,50 @@ -- See \"Asymptotic Improvement of Computations over Free Monads\" by Janis -- Voigtländer for more information about this type. ----- <http://www.iai.uni-bonn.de/~jv/mpc08.pdf>-newtype Codensity m a = Codensity+-- <https://www.janis-voigtlaender.eu/papers/AsymptoticImprovementOfComputationsOverFreeMonads.pdf>+newtype Codensity (m :: k -> TYPE rep) a = Codensity+-- Note: we *could* generalize @a@ to @TYPE repa@, but the 'Functor'+-- instance wouldn't carry that, so it doesn't really seem worth+-- the complication. { 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))+instance Functor (Codensity (k :: j -> TYPE rep)) where+ fmap f (Codensity m) = Codensity (\k -> m (\x -> k (f x))) {-# INLINE fmap #-} -instance Apply (Codensity f) where+instance Apply (Codensity (f :: k -> TYPE rep)) where (<.>) = (<*>) {-# INLINE (<.>) #-} -instance Applicative (Codensity f) where+instance Applicative (Codensity (f :: k -> TYPE rep)) where pure x = Codensity (\k -> k x) {-# INLINE pure #-}- Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (bfr . ab)))+ Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (\x -> bfr (ab x)))) {-# INLINE (<*>) #-} -instance Monad (Codensity f) where+instance Monad (Codensity (f :: k -> TYPE rep)) where return = pure {-# INLINE return #-} m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c)) {-# INLINE (>>=) #-} -instance (Fail.MonadFail f) => Fail.MonadFail (Codensity f) where+-- Writing instances like+-- instance MonadFail f => MonadFail (Codensity f)+-- leads to some hidden flexible instances. Haddock will show things like+--+-- MonadFail f => MonadFail (Codensity * LiftedRep f)+--+-- Since FlexibleInstances are bad for inference, we avoid them when+-- we can by carefully pushing kind constraints to the left.++instance (f ~~ f', Fail.MonadFail f')+ => Fail.MonadFail (Codensity (f :: k -> TYPE rep)) where fail msg = Codensity $ \ _ -> Fail.fail msg {-# INLINE fail #-} -instance MonadIO m => MonadIO (Codensity m) where+instance (m ~~ m', MonadIO m')+ => MonadIO (Codensity (m :: k -> TYPE rep)) where liftIO = lift . liftIO {-# INLINE liftIO #-} @@ -97,11 +114,12 @@ lift m = Codensity (m >>=) {-# INLINE lift #-} -instance Alt v => Alt (Codensity v) where+instance (v ~~ v', Alt v')+ => Alt (Codensity (v :: k -> TYPE rep)) where Codensity m <!> Codensity n = Codensity (\k -> m k <!> n k) {-# INLINE (<!>) #-} -instance Plus v => Plus (Codensity v) where+instance (v ~~ v', Plus v') => Plus (Codensity (v :: k -> TYPE rep)) where zero = Codensity (const zero) {-# INLINE zero #-} @@ -115,22 +133,19 @@ mplus = (<!>) -} -instance Alternative v => Alternative (Codensity v) where+instance (v ~~ v', Alternative v')+ => Alternative (Codensity (v :: k -> TYPE rep)) 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+instance (v ~~ v', Alternative v')+ => MonadPlus (Codensity (v :: k -> TYPE rep)) +instance MonadThrow m => MonadThrow (Codensity m) where+ throwM = lift . throwM+ -- | -- This serves as the *left*-inverse (retraction) of 'lift'. --@@ -145,13 +160,8 @@ -- 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@@ -210,17 +220,20 @@ ranToCodensity (Ran m) = Codensity m {-# INLINE ranToCodensity #-} -instance (Functor f, MonadFree f m) => MonadFree f (Codensity m) where+instance (m ~~ m', Functor f, MonadFree f m')+ => MonadFree f (Codensity (m :: k -> TYPE rep)) where wrap t = Codensity (\h -> wrap (fmap (\p -> runCodensity p h) t)) {-# INLINE wrap #-} -instance MonadReader r m => MonadState r (Codensity m) where+instance (m ~~ m', MonadReader r m')+ => MonadState r (Codensity (m :: k -> TYPE rep)) 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+instance (m ~~ m', MonadReader r m')+ => MonadReader r (Codensity (m :: k -> TYPE rep)) where ask = Codensity (ask >>=) {-# INLINE ask #-} local f m = Codensity $ \c -> ask >>= \r -> local f . runCodensity m $ local (const r) . c@@ -238,3 +251,27 @@ improve :: Functor f => (forall m. MonadFree f m => m a) -> Free f a improve m = lowerCodensity m {-# INLINE improve #-}+++-- | Wrap the remainder of the 'Codensity' action using the given+-- function.+--+-- This function can be used to register cleanup actions that will be+-- executed at the end. Example:+--+-- > wrapCodensity (`finally` putStrLn "Done.")+wrapCodensity :: (forall a. m a -> m a) -> Codensity m ()+wrapCodensity f = Codensity (\k -> f (k ()))++-- | @'reset' m@ delimits the continuation of any 'shift' inside @m@.+--+-- * @'reset' ('return' m) = 'return' m@+reset :: Monad m => Codensity m a -> Codensity m a+reset = lift . lowerCodensity++-- | @'shift' f@ captures the continuation up to the nearest enclosing+-- 'reset' and passes it to @f@:+--+-- * @'reset' ('shift' f >>= k) = 'reset' (f ('lowerCodensity' . k))@+shift :: Applicative m => (forall b. (a -> m b) -> Codensity m b) -> Codensity m a+shift f = Codensity $ lowerCodensity . f
src/Data/Functor/Contravariant/Coyoneda.hs view
@@ -1,12 +1,9 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- |@@ -24,6 +21,7 @@ ( Coyoneda(..) , liftCoyoneda , lowerCoyoneda+ , hoistCoyoneda ) where import Control.Arrow@@ -71,3 +69,9 @@ lowerCoyoneda :: Contravariant f => Coyoneda f a -> f a lowerCoyoneda (Coyoneda f m) = contramap f m {-# INLINE lowerCoyoneda #-}++-- | Lift a natural transformation from @f@ to @g@ to a natural transformation+-- from @Coyoneda f@ to @Coyoneda g@.+hoistCoyoneda :: (forall a. f a -> g a) -> (Coyoneda f b -> Coyoneda g b)+hoistCoyoneda f (Coyoneda g x) = Coyoneda g (f x)+{-# INLINE hoistCoyoneda #-}
src/Data/Functor/Contravariant/Day.hs view
@@ -1,16 +1,9 @@-{-# 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 MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE KindSignatures #-}-#endif-#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710-{-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2013-2016 Edward Kmett, Gershom Bazerman and Derek Elkins@@ -38,22 +31,16 @@ , trans1, trans2 ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif+import Control.Arrow ((***)) import Data.Functor.Contravariant import Data.Functor.Contravariant.Rep+import Data.Functor.Contravariant.Adjunction+import Data.Functor.Contravariant.Divisible 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 --@@ -64,26 +51,14 @@ 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 (Divisible f, Divisible g) => Divisible (Day f g) where+ divide h (Day f g l) (Day f' g' r) = Day (divided f f') (divided g g') (intertwine . (l *** r) . h)+ where intertwine ((a, b), (c, d)) = ((a, c), (b, d))+ conquer = Day conquer conquer (\a -> (a, a))+ instance (Representable f, Representable g) => Representable (Day f g) where type Rep (Day f g) = (Rep f, Rep g) @@ -99,6 +74,9 @@ Right (vf, vg) -> (Right vf, Right vg) {-# INLINE tabulate #-} +instance (Adjunction f u, Adjunction f' u') => Adjunction (Day f f') (Day u u') where+ unit a = Day (unit a) (unit a) (\(Day f f' g) -> (contramap (fst . g) f, contramap (snd . g) f'))+ counit a = Day (counit a) (counit a) (\(Day u u' g) -> (contramap (fst . g) u, contramap (snd . g) u')) -- | Break apart the Day convolution of two contravariant functors. runDay :: (Contravariant f, Contravariant g) => Day f g a -> (f a, g a)
src/Data/Functor/Contravariant/Yoneda.hs view
@@ -1,12 +1,9 @@-{-# 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
src/Data/Functor/Coyoneda.hs view
@@ -1,14 +1,10 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-}--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- |@@ -19,6 +15,7 @@ -- Stability : provisional -- Portability : GADTs, MPTCs, fundeps --+-- @'Coyoneda' f@ is the "free functor" over @f@. -- The co-Yoneda lemma for a covariant 'Functor' @f@ states that @'Coyoneda' f@ -- is naturally isomorphic to @f@. ----------------------------------------------------------------------------@@ -36,9 +33,9 @@ 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.Classes import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Kan.Lan@@ -73,9 +70,11 @@ -- @ coyonedaToLan :: Coyoneda f a -> Lan Identity f a coyonedaToLan (Coyoneda ba fb) = Lan (ba . runIdentity) fb+{-# INLINE coyonedaToLan #-} lanToCoyoneda :: Lan Identity f a -> Coyoneda f a lanToCoyoneda (Lan iba fb) = Coyoneda (iba . Identity) fb+{-# INLINE lanToCoyoneda #-} -- {-# RULES "coyonedaToLan/lanToCoyoneda=id" coyonedaToLan . lanToCoyoneda = id #-} -- {-# RULES "lanToCoyoneda/coyonedaToLan=id" lanToCoyoneda . coyonedaToLan = id #-}@@ -144,14 +143,11 @@ {-# INLINE (>>-) #-} instance Monad m => Monad (Coyoneda m) where-#if __GLASGOW_HASKELL__ < 710- return = Coyoneda id . return- {-# INLINE return #-}-#endif+ (>>) = (*>)+ {-# INLINE (>>) #-}+ Coyoneda f v >>= k = lift (v >>= lowerM . k . f) {-# INLINE (>>=) #-}- Coyoneda _ m >> Coyoneda g n = Coyoneda g (m >> n)- {-# INLINE (>>) #-} instance MonadTrans Coyoneda where lift = Coyoneda id@@ -208,31 +204,48 @@ 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)+instance (Functor f, Show1 f) => Show1 (Coyoneda f) where+ liftShowsPrec sp sl d (Coyoneda f a) =+ showsUnaryWith (liftShowsPrec sp sl) "liftCoyoneda" d (fmap f a)+ {-# INLINE liftShowsPrec #-}++instance (Read1 f) => Read1 (Coyoneda f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "liftCoyoneda" liftCoyoneda+ {-# INLINE liftReadsPrec #-}++instance (Functor f, Show1 f, Show a) => Show (Coyoneda f a) where+ showsPrec = showsPrec1 {-# INLINE showsPrec #-} -#ifdef __GLASGOW_HASKELL__ instance 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+instance Eq1 f => Eq1 (Coyoneda f) where+ liftEq eq (Coyoneda f xs) (Coyoneda g ys) =+ liftEq (\x y -> eq (f x) (g y)) xs ys+ {-# INLINE liftEq #-}++instance Ord1 f => Ord1 (Coyoneda f) where+ liftCompare cmp (Coyoneda f xs) (Coyoneda g ys) =+ liftCompare (\x y -> cmp (f x) (g y)) xs ys+ {-# INLINE liftCompare #-}++instance (Eq1 f, Eq a) => Eq (Coyoneda f a) where+ (==) = eq1 {-# INLINE (==) #-} -instance (Functor f, Ord (f a)) => Ord (Coyoneda f a) where- compare = compare `on` lowerCoyoneda+instance (Ord1 f, Ord a) => Ord (Coyoneda f a) where+ compare = compare1 {-# INLINE compare #-} instance Adjunction f g => Adjunction (Coyoneda f) (Coyoneda g) where- unit = liftCoyoneda . fmap liftCoyoneda . unit+ unit = liftCoyoneda . leftAdjunct liftCoyoneda {-# INLINE unit #-}- counit = counit . fmap lowerCoyoneda . lowerCoyoneda+ counit = rightAdjunct lowerCoyoneda . lowerCoyoneda {-# INLINE counit #-} -- | Yoneda \"expansion\"@@ -286,3 +299,4 @@ -- from @Coyoneda f@ to @Coyoneda g@. hoistCoyoneda :: (forall a. f a -> g a) -> (Coyoneda f b -> Coyoneda g b) hoistCoyoneda f (Coyoneda g x) = Coyoneda g (f x)+{-# INLINE hoistCoyoneda #-}
src/Data/Functor/Day.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2014-2016 Edward Kmett@@ -35,47 +35,28 @@ , intro1, intro2 , elim1, elim2 , trans1, trans2+ , cayley, dayley ) where import Control.Applicative+import Control.Category import Control.Comonad import Control.Comonad.Trans.Class import Data.Distributive+import Data.Profunctor.Cayley (Cayley(..))+import Data.Profunctor.Composition (Procompose(..))+import Data.Functor.Adjunction import Data.Functor.Identity import Data.Functor.Rep-#ifdef __GLASGOW_HASKELL__-import Data.Typeable-#endif+import Prelude hiding (id,(.)) -- | The Day convolution of two covariant functors.------ @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) @@ -97,6 +78,13 @@ tabulate f = Day (tabulate id) (tabulate id) (curry f) index (Day m n o) (x,y) = o (index m x) (index n y) +instance (Adjunction f u, Adjunction f' u') => Adjunction (Day f f') (Day u u') where+ unit a = Day (unit ()) (unit ()) (\f f' -> Day f f' (\() () -> a))+ counit (Day f f' h) = case h a a' of Day u u' g -> g (indexAdjunction u f_) (indexAdjunction u' f_')+ where+ (a, f_) = splitL f+ (a', f_') = splitL f'+ instance (Comonad f, Comonad g) => Comonad (Day f g) where extract (Day fb gc bca) = bca (extract fb) (extract gc) duplicate (Day fb gc bca) = Day (duplicate fb) (duplicate gc) (\fb' gc' -> Day fb' gc' bca)@@ -179,7 +167,7 @@ -- | Collapse via a monoidal functor. ----- @ +-- @ -- 'dap' ('day' f g) = f '<*>' g -- @ dap :: Applicative f => Day f f a -> f a@@ -204,3 +192,10 @@ -- @ trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a trans2 gh (Day fb gc bca) = Day fb (gh gc) bca++cayley :: Procompose (Cayley f p) (Cayley g q) a b -> Cayley (Day f g) (Procompose p q) a b+cayley (Procompose (Cayley p) (Cayley q)) = Cayley $ Day p q Procompose++-- | Proposition 4.1 from Pastro and Street+dayley :: Category p => Procompose (Cayley f p) (Cayley g p) a b -> Cayley (Day f g) p a b+dayley (Procompose (Cayley p) (Cayley q)) = Cayley $ Day p q (.)
src/Data/Functor/Day/Curried.hs view
@@ -1,10 +1,6 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-}--#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------------------- -- | -- Copyright : 2013-2016 Edward Kmett and Dan Doel@@ -31,12 +27,11 @@ , liftCurried, lowerCurried, rap ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif+import qualified Control.Applicative as App import Data.Functor.Adjunction import Data.Functor.Day import Data.Functor.Identity+import Data.Functor.Apply newtype Curried g h a = Curried { runCurried :: forall r. g (a -> r) -> h r }@@ -45,11 +40,19 @@ 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))+instance (Functor g, g ~ h) => Apply (Curried g h) where+ Curried mf <.> Curried ma = Curried (ma . mf . fmap (.))+ {-# INLINE (<.>) #-}+ liftF2 f (Curried g) (Curried ma) = Curried (ma . g . fmap (\p q -> p . f q))+ {-# INLINE liftF2 #-}++instance (Functor g, g ~ h) => App.Applicative (Curried g h) where+ pure a = Curried (fmap ($ a)) {-# INLINE pure #-} Curried mf <*> Curried ma = Curried (ma . mf . fmap (.)) {-# INLINE (<*>) #-}+ liftA2 f (Curried g) (Curried ma) = Curried (ma . g . fmap (\p q -> p . f q))+ {-# INLINE liftA2 #-} -- | The natural isomorphism between @f@ and @Curried f f@. -- @
+ src/Data/Functor/Invariant/Day.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2018 Brian Mckenna+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- The Day convolution of two invariant functors is an invariant+-- functor.+--+-- <http://ncatlab.org/nlab/show/Day+convolution>+----------------------------------------------------------------------------++module Data.Functor.Invariant.Day+ ( Day(..)+ , day+ , assoc, disassoc+ , swapped+ , intro1, intro2+ , elim1, elim2+ , trans1, trans2+ , toContravariant, toCovariant+ ) where++import qualified Data.Functor.Contravariant.Day as Contravariant+import qualified Data.Functor.Day as Covariant+import Data.Functor.Identity+import Data.Functor.Invariant++-- | The Day convolution of two invariant functors.+data Day f g a = forall b c. Day (f b) (g c) (b -> c -> a) (a -> (b, c))++instance Invariant (Day f g) where+ invmap f g (Day fb gc bca abc) = Day fb gc ((f .) . bca) (abc . g)++-- | Construct the Day convolution+day :: f a -> g b -> Day f g (a, b)+day fa gb = Day fa gb (,) id++-- | Day convolution provides a monoidal product. The associativity+-- of this monoid is witnessed by 'assoc' and 'disassoc'.+--+-- @+-- 'assoc' . 'disassoc' = 'id'+-- 'disassoc' . 'assoc' = 'id'+-- 'invmap' f g '.' 'assoc' = 'assoc' '.' 'invmap' f g+-- @+assoc :: Day f (Day g h) a -> Day (Day f g) h a+assoc (Day fb (Day gd he dec cde) bca abc) = flip (Day (Day fb gd (,) id) he) f g+ where+ f a =+ let (b,c) = abc a+ (d,e) = cde c+ in ((b,d),e)+ g (b,d) e =+ bca b (dec d e)++-- | Day convolution provides a monoidal product. The associativity+-- of this monoid is witnessed by 'assoc' and 'disassoc'.+--+-- @+-- 'assoc' . 'disassoc' = 'id'+-- 'disassoc' . 'assoc' = 'id'+-- 'invmap' f g '.' 'disassoc' = 'disassoc' '.' 'invmap' f g+-- @+disassoc :: Day (Day f g) h a -> Day f (Day g h) a+disassoc (Day (Day fb gc deb bde) hd bca abc) = Day fb (Day gc hd (,) id) f g+ where+ f e (d,c) =+ bca (deb e d) c+ g a =+ let (b,c) = abc a+ (d,e) = bde b+ in (d,(e,c))++-- | The monoid for 'Day' convolution on the cartesian monoidal structure is symmetric.+--+-- @+-- 'invmap' f g '.' 'swapped' = 'swapped' '.' 'invmap' f g+-- @+swapped :: Day f g a -> Day g f a+swapped (Day fb gc bca abc) = Day gc fb (flip bca) (\a -> let (b, c) = abc a in (c, b))++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro1' '.' 'elim1' = 'id'+-- 'elim1' '.' 'intro1' = 'id'+-- @+intro1 :: f a -> Day Identity f a+intro1 fa = Day (Identity ()) fa (\_ a -> a) ((,) ())++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro2' '.' 'elim2' = 'id'+-- 'elim2' '.' 'intro2' = 'id'+-- @+intro2 :: f a -> Day f Identity a+intro2 fa = Day fa (Identity ()) const (flip (,) ())++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro1' '.' 'elim1' = 'id'+-- 'elim1' '.' 'intro1' = 'id'+-- @+elim1 :: Invariant f => Day Identity f a -> f a+elim1 (Day (Identity b) fc bca abc) = invmap (bca b) (snd . abc) fc++-- | 'Identity' is the unit of 'Day' convolution+--+-- @+-- 'intro2' '.' 'elim2' = 'id'+-- 'elim2' '.' 'intro2' = 'id'+-- @+elim2 :: Invariant f => Day f Identity a -> f a+elim2 (Day fb (Identity c) bca abc) = invmap (flip bca c) (fst . abc) fb++-- | Apply a natural transformation to the left-hand side of a Day convolution.+--+-- This respects the naturality of the natural transformation you supplied:+--+-- @+-- 'invmap' f g '.' 'trans1' fg = 'trans1' fg '.' 'invmap' f g+-- @+trans1 :: (forall x. f x -> g x) -> Day f h a -> Day g h a+trans1 fg (Day fb hc bca abc) = Day (fg fb) hc bca abc++-- | Apply a natural transformation to the right-hand side of a Day convolution.+--+-- This respects the naturality of the natural transformation you supplied:+--+-- @+-- 'invmap' f g '.' 'trans2' fg = 'trans2' fg '.' 'invmap' f g+-- @+trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a+trans2 gh (Day fb gc bca abc) = Day fb (gh gc) bca abc++-- | Drop the covariant part of the Day convolution.+toContravariant :: Day f g a -> Contravariant.Day f g a+toContravariant (Day fb gc _ abc) = Contravariant.Day fb gc abc++-- | Drop the contravariant part of the Day convolution.+toCovariant :: Day f g a -> Covariant.Day f g a+toCovariant (Day fb gc bca _) = Covariant.Day fb gc bca
src/Data/Functor/Kan/Lan.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-}-#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE PolyKinds #-} ------------------------------------------------------------------------------------------- -- | -- Copyright : 2008-2016 Edward Kmett@@ -26,7 +24,9 @@ , composedAdjointToLan, lanToComposedAdjoint ) where +#if !(MIN_VERSION_base(4,18,0)) import Control.Applicative+#endif import Data.Functor.Adjunction import Data.Functor.Apply import Data.Functor.Composition
src/Data/Functor/Kan/Ran.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE Rank2Types, GADTs #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-}-#endif ------------------------------------------------------------------------------------------- -- | -- Copyright : 2008-2016 Edward Kmett@@ -38,7 +36,7 @@ -- 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.+-- to give @Ran g h : C' -> D@, such that the natural transformation @'gran' :: Ran g h (g a) -> h a@ exists. -- -- In some sense this is trying to approximate the inverse of @g@ by using one of -- its adjoints, because if the adjoint and the inverse both exist, they match!@@ -52,7 +50,7 @@ -- -- 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@+-- That is to say given any @K : C' -> D@ such that we have a natural transformation from @k.g@ to @h@ -- @(forall x. k (g x) -> h x)@ there exists a canonical natural transformation from @k@ to @Ran g h@. -- @(forall x. k x -> Ran g h x)@. --@@ -102,7 +100,7 @@ -- 'fromRan' . 'toRan' ≡ 'id' -- @ fromRan :: (forall a. k a -> Ran g h a) -> k (g b) -> h b-fromRan s = flip runRan id . s+fromRan s kgb = runRan (s kgb) id {-# INLINE fromRan #-} -- |
src/Data/Functor/Yoneda.hs view
@@ -1,13 +1,10 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- |@@ -44,9 +41,9 @@ 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.Classes import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Kan.Ran@@ -82,10 +79,13 @@ -- @ liftYoneda :: Functor f => f a -> Yoneda f a liftYoneda a = Yoneda (\f -> fmap f a)+{-# INLINE liftYoneda #-} lowerYoneda :: Yoneda f a -> f a lowerYoneda (Yoneda f) = f id+{-# INLINE lowerYoneda #-} +-- TODO: coerce -- {-# RULES "lower/lift=id" liftYoneda . lowerYoneda = id #-} -- {-# RULES "lift/lower=id" lowerYoneda . liftYoneda = id #-} @@ -97,66 +97,103 @@ -- @ yonedaToRan :: Yoneda f a -> Ran Identity f a yonedaToRan (Yoneda m) = Ran (m . fmap runIdentity)+{-# INLINE yonedaToRan #-} ranToYoneda :: Ran Identity f a -> Yoneda f a ranToYoneda (Ran m) = Yoneda (m . fmap Identity)+{-# INLINE ranToYoneda #-} -- {-# RULES "yonedaToRan/ranToYoneda=id" yonedaToRan . ranToYoneda = id #-} -- {-# RULES "ranToYoneda/yonedaToRan=id" ranToYoneda . yonedaToRan = id #-} instance Functor (Yoneda f) where fmap f m = Yoneda (\k -> runYoneda m (k . f))+ {-# INLINE fmap #-} instance Apply f => Apply (Yoneda f) where Yoneda m <.> Yoneda n = Yoneda (\f -> m (f .) <.> n id)+ {-# INLINE (<.>) #-}+ Yoneda m .> Yoneda n = Yoneda (\f -> m id .> n f)+ {-# INLINE (.>) #-} instance Applicative f => Applicative (Yoneda f) where pure a = Yoneda (\f -> pure (f a))+ {-# INLINE pure #-} Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)+ {-# INLINE (<*>) #-}+ Yoneda m *> Yoneda n = Yoneda (\f -> m id *> n f)+ {-# INLINE (*>) #-} instance Foldable f => Foldable (Yoneda f) where foldMap f = foldMap f . lowerYoneda+ {-# INLINE foldMap #-} instance Foldable1 f => Foldable1 (Yoneda f) where foldMap1 f = foldMap1 f . lowerYoneda+ {-# INLINE foldMap1 #-} instance Traversable f => Traversable (Yoneda f) where traverse f = fmap liftYoneda . traverse f . lowerYoneda+ {-# INLINE traverse #-} instance Traversable1 f => Traversable1 (Yoneda f) where traverse1 f = fmap liftYoneda . traverse1 f . lowerYoneda+ {-# INLINE traverse1 #-} instance Distributive f => Distributive (Yoneda f) where collect f = liftYoneda . collect (lowerYoneda . f)+ {-# INLINE collect #-} instance Representable g => Representable (Yoneda g) where type Rep (Yoneda g) = Rep g tabulate = liftYoneda . tabulate+ {-# INLINE tabulate #-} index = index . lowerYoneda+ {-# INLINE index #-} instance Adjunction f g => Adjunction (Yoneda f) (Yoneda g) where unit = liftYoneda . fmap liftYoneda . unit+ {-# INLINE unit #-} counit (Yoneda m) = counit (m lowerYoneda)+ {-# INLINE counit #-} --- instance Show1 f => Show1 (Yoneda f) where+instance Show1 f => Show1 (Yoneda f) where+ liftShowsPrec sp sl d (Yoneda f) =+ showsUnaryWith (liftShowsPrec sp sl) "liftYoneda" d (f id)++instance (Read1 f, Functor f) => Read1 (Yoneda f) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp rl) "liftYoneda" liftYoneda+ 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+infixl 0 `on1`+on1 :: (g a -> g b -> c) -> (forall x. f x -> g x) -> f a -> f b -> c+(.*.) `on1` f = \x y -> f x .*. f y -instance Ord (f a) => Ord (Yoneda f a) where- compare = compare `on` lowerYoneda+instance Eq1 f => Eq1 (Yoneda f) where+ liftEq eq = liftEq eq `on1` lowerYoneda+ {-# INLINE liftEq #-} +instance Ord1 f => Ord1 (Yoneda f) where+ liftCompare cmp = liftCompare cmp `on1` lowerYoneda+ {-# INLINE liftCompare #-}++instance (Eq1 f, Eq a) => Eq (Yoneda f a) where+ (==) = eq1+ {-# INLINE (==) #-}++instance (Ord1 f, Ord a) => Ord (Yoneda f a) where+ compare = compare1+ {-# INLINE compare #-}+ maxF :: (Functor f, Ord (f a)) => Yoneda f a -> Yoneda f a -> Yoneda f a Yoneda f `maxF` Yoneda g = liftYoneda $ f id `max` g id -- {-# RULES "max/maxF" max = maxF #-}@@ -179,42 +216,54 @@ instance Alt f => Alt (Yoneda f) where Yoneda f <!> Yoneda g = Yoneda (\k -> f k <!> g k)+ {-# INLINE (<!>) #-} instance Plus f => Plus (Yoneda f) where zero = Yoneda $ const zero+ {-# INLINE zero #-} instance Alternative f => Alternative (Yoneda f) where empty = Yoneda $ const empty+ {-# INLINE empty #-} Yoneda f <|> Yoneda g = Yoneda (\k -> f k <|> g k)+ {-# INLINE (<|>) #-} instance Bind m => Bind (Yoneda m) where Yoneda m >>- k = Yoneda (\f -> m id >>- \a -> runYoneda (k a) f)+ {-# INLINE (>>-) #-} instance Monad m => Monad (Yoneda m) where-#if __GLASGOW_HASKELL__ < 710- return a = Yoneda (\f -> return (f a))-#endif Yoneda m >>= k = Yoneda (\f -> m id >>= \a -> runYoneda (k a) f)+ {-# INLINE (>>=) #-} instance MonadFix m => MonadFix (Yoneda m) where mfix f = lift $ mfix (lowerYoneda . f)+ {-# INLINE mfix #-} instance MonadPlus m => MonadPlus (Yoneda m) where mzero = Yoneda (const mzero)+ {-# INLINE mzero #-} Yoneda f `mplus` Yoneda g = Yoneda (\k -> f k `mplus` g k)+ {-# INLINE mplus #-} instance MonadTrans Yoneda where lift a = Yoneda (\f -> liftM f a)+ {-# INLINE lift #-} instance (Functor f, MonadFree f m) => MonadFree f (Yoneda m) where wrap = lift . wrap . fmap lowerYoneda+ {-# INLINE wrap #-} instance Extend w => Extend (Yoneda w) where extended k (Yoneda m) = Yoneda (\f -> extended (f . k . liftYoneda) (m id))+ {-# INLINE extended #-} instance Comonad w => Comonad (Yoneda w) where extend k (Yoneda m) = Yoneda (\f -> extend (f . k . liftYoneda) (m id))+ {-# INLINE extend #-} extract = extract . lowerYoneda+ {-# INLINE extract #-} instance ComonadTrans Yoneda where lower = lowerYoneda+ {-# INLINE lower #-}