adjunctions-4.3/0000755000000000000000000000000012646575273012110 5ustar0000000000000000adjunctions-4.3/.ghci0000644000000000000000000000012512646575273013021 0ustar0000000000000000:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h adjunctions-4.3/.gitignore0000644000000000000000000000010412646575273014073 0ustar0000000000000000dist docs wiki TAGS tags wip .DS_Store .*.swp .*.swo *.o *.hi *~ *# adjunctions-4.3/.travis.yml0000644000000000000000000000765312646575273014234 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.24 GHCVER=7.4.2 compiler: ": #GHC 7.4.2" addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.24 GHCVER=7.6.3 compiler: ": #GHC 7.6.3" addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.18 GHCVER=7.8.4 compiler: ": #GHC 7.8.4" addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.22 GHCVER=7.10.1 compiler: ": #GHC 7.10.1" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} - env: CABALVER=1.22 GHCVER=7.10.2 compiler: ": #GHC 7.10.2" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} before_install: - unset CC - export HAPPYVER=1.19.5 - export ALEXVER=3.1.4 - export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH install: - cabal --version - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; then zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; fi - travis_retry cabal update - "sed -i 's/^jobs:.*$/jobs: 2/' $HOME/.cabal/config" - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt # check whether current requested install-plan matches cached package-db snapshot - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; then echo "cabal build-cache HIT"; rm -rfv .ghc; cp -a $HOME/.cabsnap/ghc $HOME/.ghc; cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; else echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; cabal install --only-dependencies --enable-tests --enable-benchmarks; if [ "$GHCVER" = "7.10.1" ]; then cabal install Cabal-1.22.4.0; fi; fi # snapshot package-db on cache miss - if [ ! -d $HOME/.cabsnap ]; then echo "snapshotting package-db to build-cache"; mkdir $HOME/.cabsnap; cp -a $HOME/.ghc $HOME/.cabsnap/ghc; cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; fi # Here starts the actual work to be performed for the package under test; # any command which exits with a non-zero exit code causes the build to fail. script: - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging - cabal build # this builds all libraries and executables (including tests) - cabal test - cabal bench || true # expected result: these will crash - cabal sdist || true # tests that a source-distribution can be generated # Check that the resulting source distribution can be built & installed. # If there are no other `.tar.gz` files in `dist`, this can be even simpler: # `cabal install --force-reinstalls dist/*-*.tar.gz` - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && (cd dist && cabal install --force-reinstalls "$SRC_TGZ") notifications: irc: channels: - "irc.freenode.org#haskell-lens" skip_join: true template: - "\x0313adjunctions\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" # EOF adjunctions-4.3/.vim.custom0000644000000000000000000000137712646575273014225 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" adjunctions-4.3/adjunctions.cabal0000644000000000000000000000404112646575273015414 0ustar0000000000000000name: adjunctions category: Data Structures, Adjunctions version: 4.3 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett stability: provisional homepage: http://github.com/ekmett/adjunctions/ bug-reports: http://github.com/ekmett/adjunctions/issues copyright: Copyright (C) 2011-2014 Edward A. Kmett synopsis: Adjunctions and representable functors description: Adjunctions and representable functors build-type: Simple extra-source-files: .ghci .gitignore .travis.yml .vim.custom travis/cabal-apt-install travis/config HLint.hs CHANGELOG.markdown README.markdown source-repository head type: git location: git://github.com/ekmett/adjunctions.git library hs-source-dirs: src other-extensions: CPP FunctionalDependencies FlexibleContexts MultiParamTypeClasses Rank2Types UndecidableInstances build-depends: array >= 0.3.0.2 && < 0.7, base >= 4 && < 5, comonad >= 4 && < 6, containers >= 0.3 && < 0.6, contravariant >= 1 && < 2, distributive >= 0.4 && < 1, free >= 4 && < 5, mtl >= 2.0.1 && < 2.3, profunctors >= 4 && < 6, tagged >= 0.7 && < 1, semigroupoids >= 4 && < 6, semigroups >= 0.11 && < 1, transformers >= 0.2 && < 0.6, transformers-compat >= 0.3 && < 1, void >= 0.5.5.1 && < 1 exposed-modules: Control.Comonad.Representable.Store Control.Comonad.Trans.Adjoint Control.Monad.Representable.Reader Control.Monad.Representable.State Control.Monad.Trans.Adjoint Control.Monad.Trans.Contravariant.Adjoint Control.Monad.Trans.Conts Data.Functor.Adjunction Data.Functor.Contravariant.Adjunction Data.Functor.Contravariant.Rep Data.Functor.Rep ghc-options: -Wall adjunctions-4.3/CHANGELOG.markdown0000644000000000000000000000276612646575273015156 0ustar00000000000000004.3 --- * Removed a spurious superclass constraint for `Applicative (StoreT g w)` * GHC 8 support * `comonad` 5 support 4.2.2 ----- * Builds clean on GHC 7.10 4.2.1 ----- * `semigroupoids` 5 support. * `profunctors` 5 support. 4.2 --- * `contravariant` 1.0 support. `Day` convolution moves to `kan-extensions`. 4.0.3 ----- * Silenced `Control.Monad.Instances` deprecation warnings on GHC 7.8 4.0.2 ----- * Added `mfixRep` to make it easier to define representable `MonadFix` instances. * Added `mzipRep` and `mzipWithRep` to make it easier to define representable `MonadZip` instances. * Added `duplicateRepBy`, `extendRepBy` and `extractRepBy` to make it easier to pick your own `Monoid`. * Minor documentation fixes. 4.0.1 ----- * Increased lower bound on `contravariant` to match the actual requirement. 4.0 --- * Merged the contents of `representable-functors`. * Removed the dependency on `keys`. * Moved `Data.Functor.Contravariant.Representable` to `Data.Functor.Contravariant.Rep` and made the API mimic `Data.Profunctor.Rep`. * Moved `Data.Functor.Representable` to `Data.Functor.Rep` and made the API mimic `Data.Profunctor.Rep`. * Added `Tagged` and `Proxy` instances for `Data.Functor.Rep.Representable` * Added a `Proxy` instance for `Data.Functor.Contravariant.Rep.Representable` 3.2.1.1 ------- * Updated the `array` dependency 3.2.1 ----- * Marked modules appropriately `Trustworthy`. 3.2 --- * Updated to `representable-functors` 3.1, which changed the API for contravariant representable functors. adjunctions-4.3/HLint.hs0000644000000000000000000000012712646575273013462 0ustar0000000000000000import "hint" HLint.Default ignore "Warning: Avoid lambda" ignore "Warning: Use &&&" adjunctions-4.3/LICENSE0000644000000000000000000000236412646575273013122 0ustar0000000000000000Copyright 2011-2014 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. 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. adjunctions-4.3/README.markdown0000644000000000000000000000077512646575273014622 0ustar0000000000000000adjunctions ========== [![Hackage](https://img.shields.io/hackage/v/adjunctions.svg)](https://hackage.haskell.org/package/adjunctions) [![Build Status](https://secure.travis-ci.org/ekmett/adjunctions.png?branch=master)](http://travis-ci.org/ekmett/adjunctions) This package provides adjunctions for Haskell. Contact Information ------------------- Contributions and bug reports are welcome! Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. -Edward Kmett adjunctions-4.3/Setup.lhs0000644000000000000000000000016512646575273013722 0ustar0000000000000000#!/usr/bin/runhaskell > module Main (main) where > import Distribution.Simple > main :: IO () > main = defaultMain adjunctions-4.3/src/0000755000000000000000000000000012646575273012677 5ustar0000000000000000adjunctions-4.3/src/Control/0000755000000000000000000000000012646575273014317 5ustar0000000000000000adjunctions-4.3/src/Control/Comonad/0000755000000000000000000000000012646575273015677 5ustar0000000000000000adjunctions-4.3/src/Control/Comonad/Representable/0000755000000000000000000000000012646575273020472 5ustar0000000000000000adjunctions-4.3/src/Control/Comonad/Representable/Store.hs0000644000000000000000000001053612646575273022127 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} ---------------------------------------------------------------------- -- | -- Module : Control.Comonad.Representable.Store -- Copyright : (c) Edward Kmett & Sjoerd Visscher 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- This is a generalized 'Store' 'Comonad', parameterized by a 'Representable' 'Functor'. -- The representation of that 'Functor' serves as the index of the store. -- -- This can be useful if the representable functor serves to memoize its -- contents and will be inspected often. ---------------------------------------------------------------------- module Control.Comonad.Representable.Store ( Store , store , runStore , StoreT(..) , storeT , runStoreT , ComonadStore(..) ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.Comonad.Cofree.Class import Control.Comonad.Env.Class import Control.Comonad.Hoist.Class import Control.Comonad.Store.Class import Control.Comonad.Traced.Class import Control.Comonad.Trans.Class import Control.Monad.Identity import Data.Functor.Apply import Data.Functor.Extend import Data.Functor.Rep import Data.Semigroup -- | A memoized store comonad parameterized by a representable functor @g@, where -- the representatation of @g@, @Rep g@ is the index of the store. -- type Store g = StoreT g Identity -- | Construct a store comonad computation from a function and a current index. -- (The inverse of 'runStore'.) store :: Representable g => (Rep g -> a) -- ^ computation -> Rep g -- ^ index -> Store g a store = storeT . Identity -- | Unwrap a state monad computation as a function. -- (The inverse of 'state'.) runStore :: Representable g => Store g a -- ^ a store to access -> (Rep g -> a, Rep g) -- ^ initial state runStore (StoreT (Identity ga) k) = (index ga, k) -- --------------------------------------------------------------------------- -- | A store transformer comonad parameterized by: -- -- * @g@ - A representable functor used to memoize results for an index @Rep g@ -- -- * @w@ - The inner comonad. data StoreT g w a = StoreT (w (g a)) (Rep g) storeT :: (Functor w, Representable g) => w (Rep g -> a) -> Rep g -> StoreT g w a storeT = StoreT . fmap tabulate runStoreT :: (Functor w, Representable g) => StoreT g w a -> (w (Rep g -> a), Rep g) runStoreT (StoreT w s) = (index <$> w, s) instance (Comonad w, Representable g, Rep g ~ s) => ComonadStore s (StoreT g w) where pos (StoreT _ s) = s peek s (StoreT w _) = extract w `index` s peeks f (StoreT w s) = extract w `index` f s seek s (StoreT w _) = StoreT w s seeks f (StoreT w s) = StoreT w (f s) instance (Functor w, Functor g) => Functor (StoreT g w) where fmap f (StoreT w s) = StoreT (fmap (fmap f) w) s instance (Apply w, Semigroup (Rep g), Representable g) => Apply (StoreT g w) where StoreT ff m <.> StoreT fa n = StoreT (apRep <$> ff <.> fa) (m <> n) instance (ComonadApply w, Semigroup (Rep g), Representable g) => ComonadApply (StoreT g w) where StoreT ff m <@> StoreT fa n = StoreT (apRep <$> ff <@> fa) (m <> n) instance (Applicative w, Monoid (Rep g), Representable g) => Applicative (StoreT g w) where pure a = StoreT (pure (pureRep a)) mempty StoreT ff m <*> StoreT fa n = StoreT (apRep <$> ff <*> fa) (m `mappend` n) instance (Extend w, Representable g) => Extend (StoreT g w) where duplicated (StoreT wf s) = StoreT (extended (tabulate . StoreT) wf) s instance (Comonad w, Representable g) => Comonad (StoreT g w) where duplicate (StoreT wf s) = StoreT (extend (tabulate . StoreT) wf) s extract (StoreT wf s) = index (extract wf) s instance Representable g => ComonadTrans (StoreT g) where lower (StoreT w s) = fmap (`index` s) w instance ComonadHoist (StoreT g) where cohoist f (StoreT w s) = StoreT (f w) s instance (ComonadTraced m w, Representable g) => ComonadTraced m (StoreT g w) where trace m = trace m . lower instance (ComonadEnv m w, Representable g) => ComonadEnv m (StoreT g w) where ask = ask . lower instance (Representable g, ComonadCofree f w) => ComonadCofree f (StoreT g w) where unwrap (StoreT w s) = fmap (`StoreT` s) (unwrap w) adjunctions-4.3/src/Control/Comonad/Trans/0000755000000000000000000000000012646575273016766 5ustar0000000000000000adjunctions-4.3/src/Control/Comonad/Trans/Adjoint.hs0000644000000000000000000000371512646575273020720 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- ---------------------------------------------------------------------------- module Control.Comonad.Trans.Adjoint ( Adjoint , runAdjoint , adjoint , AdjointT(..) ) where import Prelude hiding (sequence) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.Comonad.Trans.Class import Data.Functor.Adjunction import Data.Functor.Extend import Data.Functor.Identity import Data.Distributive type Adjoint f g = AdjointT f g Identity newtype AdjointT f g w a = AdjointT { runAdjointT :: f (w (g a)) } adjoint :: Functor f => f (g a) -> Adjoint f g a adjoint = AdjointT . fmap Identity runAdjoint :: Functor f => Adjoint f g a -> f (g a) runAdjoint = fmap runIdentity . runAdjointT instance (Adjunction f g, Functor w) => Functor (AdjointT f g w) where fmap f (AdjointT g) = AdjointT $ fmap (fmap (fmap f)) g b <$ (AdjointT g) = AdjointT $ fmap (fmap (b <$)) g instance (Adjunction f g, Extend w) => Extend (AdjointT f g w) where extended f (AdjointT m) = AdjointT $ fmap (extended $ leftAdjunct (f . AdjointT)) m instance (Adjunction f g, Comonad w) => Comonad (AdjointT f g w) where extend f (AdjointT m) = AdjointT $ fmap (extend $ leftAdjunct (f . AdjointT)) m extract = rightAdjunct extract . runAdjointT {- instance (Adjunction f g, Monad m) => Applicative (AdjointT f g m) where pure = AdjointT . leftAdjunct return (<*>) = ap -} instance (Adjunction f g, Distributive g) => ComonadTrans (AdjointT f g) where lower = counit . fmap distribute . runAdjointT adjunctions-4.3/src/Control/Monad/0000755000000000000000000000000012646575273015355 5ustar0000000000000000adjunctions-4.3/src/Control/Monad/Representable/0000755000000000000000000000000012646575273020150 5ustar0000000000000000adjunctions-4.3/src/Control/Monad/Representable/Reader.hs0000644000000000000000000001135412646575273021712 0ustar0000000000000000{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, TypeSynonymInstances #-} {-# OPTIONS_GHC -fenable-rewrite-rules -fno-warn-orphans #-} ---------------------------------------------------------------------- -- | -- Module : Control.Monad.Representable.Reader -- Copyright : (c) Edward Kmett 2011, -- (c) Conal Elliott 2008 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- Representable functors on Hask are all monads, because they are isomorphic to -- a 'Reader' monad. ---------------------------------------------------------------------- module Control.Monad.Representable.Reader ( -- * Representable functor monad Reader , runReader -- * Monad Transformer , ReaderT(..), readerT, runReaderT , MonadReader(..) , module Data.Functor.Rep ) where import Control.Applicative import Control.Comonad import Control.Monad.Reader.Class import Control.Monad.Writer.Class as Writer import Control.Monad.Trans.Class import Control.Monad.IO.Class import Data.Distributive import Data.Functor.Bind import Data.Functor.Extend import Data.Functor.Identity import Data.Functor.Rep import Data.Foldable import Data.Traversable import Data.Semigroup import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Prelude hiding (lookup,zipWith) type Reader f = ReaderT f Identity runReader :: Representable f => Reader f b -> Rep f -> b runReader = fmap runIdentity . runReaderT -- * This 'representable monad transformer' transforms any monad @m@ with a 'Representable' 'Monad'. -- This monad in turn is also representable if @m@ is 'Representable'. newtype ReaderT f m b = ReaderT { getReaderT :: f (m b) } readerT :: Representable f => (Rep f -> m b) -> ReaderT f m b readerT = ReaderT . tabulate runReaderT :: Representable f => ReaderT f m b -> Rep f -> m b runReaderT = index . getReaderT instance (Functor f, Functor m) => Functor (ReaderT f m) where fmap f = ReaderT . fmap (fmap f) . getReaderT instance (Representable f, Representable m) => Representable (ReaderT f m) where type Rep (ReaderT f m) = (Rep f, Rep m) tabulate = ReaderT . tabulate . fmap tabulate . curry index = uncurry . fmap index . index . getReaderT instance (Representable f, Apply m) => Apply (ReaderT f m) where ReaderT ff <.> ReaderT fa = ReaderT (unCo ((<.>) <$> Co ff <.> Co fa)) instance (Representable f, Applicative m) => Applicative (ReaderT f m) where pure = ReaderT . pureRep . pure ReaderT ff <*> ReaderT fa = ReaderT (unCo ((<*>) <$> Co ff <*> Co fa)) instance (Representable f, Bind m) => Bind (ReaderT f m) where ReaderT fm >>- f = ReaderT $ tabulate (\a -> index fm a >>- flip index a . getReaderT . f) instance (Representable f, Monad m) => Monad (ReaderT f m) where #if __GLASGOW_HASKELL__ < 710 return = ReaderT . pureRep . return #endif ReaderT fm >>= f = ReaderT $ tabulate (\a -> index fm a >>= flip index a . getReaderT . f) #if __GLASGOW_HASKELL >= 704 instance (Representable f, Monad m, Rep f ~ e) => MonadReader e (ReaderT f m) where ask = ReaderT (tabulate return) local f m = readerT $ \r -> runReaderT m (f r) #if MIN_VERSION_transformers(0,3,0) reader = readerT . fmap return #endif #endif instance Representable f => MonadTrans (ReaderT f) where lift = ReaderT . pureRep instance (Representable f, Distributive m) => Distributive (ReaderT f m) where distribute = ReaderT . fmapRep distribute . unCo . collect (Co . getReaderT) instance (Representable f, Representable m, Semigroup (Rep f), Semigroup (Rep m)) => Extend (ReaderT f m) where extended = extendedRep duplicated = duplicatedRep instance (Representable f, Representable m, Monoid (Rep f), Monoid (Rep m)) => Comonad (ReaderT f m) where extend = extendRep duplicate = duplicateRep extract = extractRep instance (Representable f, MonadIO m) => MonadIO (ReaderT f m) where liftIO = lift . liftIO instance (Representable f, MonadWriter w m) => MonadWriter w (ReaderT f m) where tell = lift . tell listen (ReaderT m) = ReaderT $ tabulate $ Writer.listen . index m pass (ReaderT m) = ReaderT $ tabulate $ Writer.pass . index m -- misc. instances that can exist, but aren't particularly about representability instance (Foldable f, Foldable m) => Foldable (ReaderT f m) where foldMap f = foldMap (foldMap f) . getReaderT instance (Foldable1 f, Foldable1 m) => Foldable1 (ReaderT f m) where foldMap1 f = foldMap1 (foldMap1 f) . getReaderT instance (Traversable f, Traversable m) => Traversable (ReaderT f m) where traverse f = fmap ReaderT . traverse (traverse f) . getReaderT instance (Traversable1 f, Traversable1 m) => Traversable1 (ReaderT f m) where traverse1 f = fmap ReaderT . traverse1 (traverse1 f) . getReaderT adjunctions-4.3/src/Control/Monad/Representable/State.hs0000644000000000000000000001662112646575273021572 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} ---------------------------------------------------------------------- -- | -- Module : Control.Monad.Representable.State -- Copyright : (c) Edward Kmett & Sjoerd Visscher 2011 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- A generalized State monad, parameterized by a Representable functor. -- The representation of that functor serves as the state. ---------------------------------------------------------------------- module Control.Monad.Representable.State ( State , runState , evalState , execState , mapState , StateT(..) , stateT , runStateT , evalStateT , execStateT , mapStateT , liftCallCC , liftCallCC' , MonadState(..) ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad import Data.Functor.Bind import Data.Functor.Bind.Trans import Control.Monad.State.Class import Control.Monad.Cont.Class import Control.Monad.Reader.Class import Control.Monad.Writer.Class import Control.Monad.Free.Class import Control.Monad.Trans.Class import Data.Functor.Identity import Data.Functor.Rep -- --------------------------------------------------------------------------- -- | A memoized state monad parameterized by a representable functor @g@, where -- the representatation of @g@, @Rep g@ is the state to carry. -- -- The 'return' function leaves the state unchanged, while @>>=@ uses -- the final state of the first computation as the initial state of -- the second. type State g = StateT g Identity -- | Unwrap a state monad computation as a function. -- (The inverse of 'state'.) runState :: Representable g => State g a -- ^ state-passing computation to execute -> Rep g -- ^ initial state -> (a, Rep g) -- ^ return value and final state runState m = runIdentity . runStateT m -- | Evaluate a state computation with the given initial state -- and return the final value, discarding the final state. -- -- * @'evalState' m s = 'fst' ('runState' m s)@ evalState :: Representable g => State g a -- ^state-passing computation to execute -> Rep g -- ^initial value -> a -- ^return value of the state computation evalState m s = fst (runState m s) -- | Evaluate a state computation with the given initial state -- and return the final state, discarding the final value. -- -- * @'execState' m s = 'snd' ('runState' m s)@ execState :: Representable g => State g a -- ^state-passing computation to execute -> Rep g -- ^initial value -> Rep g -- ^final state execState m s = snd (runState m s) -- | Map both the return value and final state of a computation using -- the given function. -- -- * @'runState' ('mapState' f m) = f . 'runState' m@ mapState :: Functor g => ((a, Rep g) -> (b, Rep g)) -> State g a -> State g b mapState f = mapStateT (Identity . f . runIdentity) -- --------------------------------------------------------------------------- -- | A state transformer monad parameterized by: -- -- * @g@ - A representable functor used to memoize results for a state @Rep g@ -- -- * @m@ - The inner monad. -- -- The 'return' function leaves the state unchanged, while @>>=@ uses -- the final state of the first computation as the initial state of -- the second. newtype StateT g m a = StateT { getStateT :: g (m (a, Rep g)) } stateT :: Representable g => (Rep g -> m (a, Rep g)) -> StateT g m a stateT = StateT . tabulate runStateT :: Representable g => StateT g m a -> Rep g -> m (a, Rep g) runStateT (StateT m) = index m mapStateT :: Functor g => (m (a, Rep g) -> n (b, Rep g)) -> StateT g m a -> StateT g n b mapStateT f (StateT m) = StateT (fmap f m) -- | Evaluate a state computation with the given initial state -- and return the final value, discarding the final state. -- -- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ evalStateT :: (Representable g, Monad m) => StateT g m a -> Rep g -> m a evalStateT m s = do (a, _) <- runStateT m s return a -- | Evaluate a state computation with the given initial state -- and return the final state, discarding the final value. -- -- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ execStateT :: (Representable g, Monad m) => StateT g m a -> Rep g -> m (Rep g) execStateT m s = do (_, s') <- runStateT m s return s' instance (Functor g, Functor m) => Functor (StateT g m) where fmap f = StateT . fmap (fmap (\ ~(a, s) -> (f a, s))) . getStateT instance (Representable g, Bind m) => Apply (StateT g m) where mf <.> ma = mf >>- \f -> fmap f ma instance (Representable g, Functor m, Monad m) => Applicative (StateT g m) where pure = StateT . leftAdjunctRep return mf <*> ma = mf >>= \f -> fmap f ma instance (Representable g, Bind m) => Bind (StateT g m) where StateT m >>- f = StateT $ fmap (>>- rightAdjunctRep (runStateT . f)) m instance (Representable g, Monad m) => Monad (StateT g m) where #if __GLASGOW_VERSION__ < 710 return = StateT . leftAdjunctRep return #endif StateT m >>= f = StateT $ fmap (>>= rightAdjunctRep (runStateT . f)) m instance Representable f => BindTrans (StateT f) where liftB m = stateT $ \s -> fmap (\a -> (a, s)) m instance Representable f => MonadTrans (StateT f) where lift m = stateT $ \s -> liftM (\a -> (a, s)) m instance (Representable g, Monad m, Rep g ~ s) => MonadState s (StateT g m) where get = stateT $ \s -> return (s, s) put s = StateT $ pureRep $ return ((),s) #if MIN_VERSION_transformers(0,3,0) state f = stateT (return . f) #endif instance (Representable g, MonadReader e m) => MonadReader e (StateT g m) where ask = lift ask local = mapStateT . local instance (Representable g, MonadWriter w m) => MonadWriter w (StateT g m) where tell = lift . tell listen = mapStateT $ \ma -> do ((a,s'), w) <- listen ma return ((a,w), s') pass = mapStateT $ \ma -> pass $ do ((a, f), s') <- ma return ((a, s'), f) instance (Representable g, MonadCont m) => MonadCont (StateT g m) where callCC = liftCallCC' callCC instance (Functor f, Representable g, MonadFree f m) => MonadFree f (StateT g m) where wrap as = stateT $ \s -> wrap (fmap (`runStateT` s) as) leftAdjunctRep :: Representable u => ((a, Rep u) -> b) -> a -> u b leftAdjunctRep f a = tabulate (\s -> f (a,s)) rightAdjunctRep :: Representable u => (a -> u b) -> (a, Rep u) -> b rightAdjunctRep f ~(a, k) = f a `index` k -- | Uniform lifting of a @callCC@ operation to the new monad. -- This version rolls back to the original state on entering the -- continuation. liftCallCC :: Representable g => ((((a,Rep g) -> m (b,Rep g)) -> m (a,Rep g)) -> m (a,Rep g)) -> ((a -> StateT g m b) -> StateT g m a) -> StateT g m a liftCallCC callCC' f = stateT $ \s -> callCC' $ \c -> runStateT (f (\a -> StateT $ pureRep $ c (a, s))) s -- | In-situ lifting of a @callCC@ operation to the new monad. -- This version uses the current state on entering the continuation. -- It does not satisfy the laws of a monad transformer. liftCallCC' :: Representable g => ((((a,Rep g) -> m (b,Rep g)) -> m (a,Rep g)) -> m (a,Rep g)) -> ((a -> StateT g m b) -> StateT g m a) -> StateT g m a liftCallCC' callCC' f = stateT $ \s -> callCC' $ \c -> runStateT (f (\a -> stateT $ \s' -> c (a, s'))) s adjunctions-4.3/src/Control/Monad/Trans/0000755000000000000000000000000012646575273016444 5ustar0000000000000000adjunctions-4.3/src/Control/Monad/Trans/Adjoint.hs0000644000000000000000000000351512646575273020374 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- ---------------------------------------------------------------------------- module Control.Monad.Trans.Adjoint ( Adjoint , runAdjoint , adjoint , AdjointT(..) ) where import Prelude hiding (sequence) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad (ap, liftM) import Control.Monad.Trans.Class import Data.Traversable import Data.Functor.Adjunction import Data.Functor.Identity type Adjoint f g = AdjointT f g Identity newtype AdjointT f g m a = AdjointT { runAdjointT :: g (m (f a)) } adjoint :: Functor g => g (f a) -> Adjoint f g a adjoint = AdjointT . fmap Identity runAdjoint :: Functor g => Adjoint f g a -> g (f a) runAdjoint = fmap runIdentity . runAdjointT instance (Adjunction f g, Monad m) => Functor (AdjointT f g m) where fmap f (AdjointT g) = AdjointT $ fmap (liftM (fmap f)) g b <$ AdjointT g = AdjointT $ fmap (liftM (b <$)) g instance (Adjunction f g, Monad m) => Applicative (AdjointT f g m) where pure = AdjointT . leftAdjunct return (<*>) = ap instance (Adjunction f g, Monad m) => Monad (AdjointT f g m) where return = pure AdjointT m >>= f = AdjointT $ fmap (>>= rightAdjunct (runAdjointT . f)) m -- | Exploiting this instance requires that we have the missing Traversables for Identity, (,)e and IdentityT instance (Adjunction f g, Traversable f) => MonadTrans (AdjointT f g) where lift = AdjointT . fmap sequence . unit adjunctions-4.3/src/Control/Monad/Trans/Conts.hs0000644000000000000000000000500112646575273020062 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- -- > Cont r ~ Contravariant.Adjoint (Op r) (Op r) -- > Conts r ~ Contravariant.AdjointT (Op r) (Op r) -- > ContsT r w m ~ Contravariant.AdjointT (Op (m r)) (Op (m r)) w ---------------------------------------------------------------------------- module Control.Monad.Trans.Conts ( -- * Continuation passing style Cont , cont , runCont -- * Multiple-continuation passing style , Conts , runConts , conts -- * Multiple-continuation passing style transformer , ContsT(..) , callCC ) where import Prelude hiding (sequence) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.Monad.Trans.Class import Control.Monad (ap) import Data.Functor.Apply import Data.Functor.Identity type Cont r = ContsT r Identity Identity cont :: ((a -> r) -> r) -> Cont r a cont f = ContsT $ \ (Identity k) -> Identity $ f $ runIdentity . k runCont :: Cont r a -> (a -> r) -> r runCont (ContsT k) f = runIdentity $ k $ Identity (Identity . f) type Conts r w = ContsT r w Identity conts :: Functor w => (w (a -> r) -> r) -> Conts r w a conts k = ContsT $ Identity . k . fmap (runIdentity .) runConts :: Functor w => Conts r w a -> w (a -> r) -> r runConts (ContsT k) = runIdentity . k . fmap (Identity .) newtype ContsT r w m a = ContsT { runContsT :: w (a -> m r) -> m r } instance Functor w => Functor (ContsT r w m) where fmap f (ContsT k) = ContsT $ k . fmap (. f) instance Comonad w => Apply (ContsT r w m) where (<.>) = ap instance Comonad w => Applicative (ContsT r w m) where pure x = ContsT $ \f -> extract f x (<*>) = ap instance Comonad w => Monad (ContsT r w m) where return = pure ContsT k >>= f = ContsT $ k . extend (\wa a -> runContsT (f a) wa) callCC :: Comonad w => ((a -> ContsT r w m b) -> ContsT r w m a) -> ContsT r w m a callCC f = ContsT $ \wamr -> runContsT (f (\a -> ContsT $ \_ -> extract wamr a)) wamr {- callCCs :: Comonad w => (w (a -> ContsT r w m b) -> ContsT r w m a) -> ContsT r w m a callCCs f = -} instance Comonad w => MonadTrans (ContsT r w) where lift m = ContsT $ extract . fmap (m >>=) adjunctions-4.3/src/Control/Monad/Trans/Contravariant/0000755000000000000000000000000012646575273021257 5ustar0000000000000000adjunctions-4.3/src/Control/Monad/Trans/Contravariant/Adjoint.hs0000644000000000000000000000377312646575273023215 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 710 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.Trans.Contravariant.Adjoint -- Copyright : (C) 2011 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs, fundeps -- -- Uses a contravariant adjunction: -- -- f -| g : Hask^op -> Hask -- -- to build a 'Comonad' to 'Monad' transformer. Sadly, the dual construction, -- which builds a 'Comonad' out of a 'Monad', is uninhabited, because any -- 'Adjunction' of the form -- -- > f -| g : Hask -> Hask^op -- -- would trivially admit unsafePerformIO. -- ---------------------------------------------------------------------------- module Control.Monad.Trans.Contravariant.Adjoint ( Adjoint , runAdjoint , adjoint , AdjointT(..) ) where import Prelude hiding (sequence) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Comonad import Control.Monad (ap) import Data.Functor.Identity import Data.Functor.Contravariant import Data.Functor.Contravariant.Adjunction type Adjoint f g = AdjointT f g Identity newtype AdjointT f g w a = AdjointT { runAdjointT :: g (w (f a)) } adjoint :: Contravariant g => g (f a) -> Adjoint f g a adjoint = AdjointT . contramap runIdentity runAdjoint :: Contravariant g => Adjoint f g a -> g (f a) runAdjoint = contramap Identity . runAdjointT instance (Adjunction f g, Functor w) => Functor (AdjointT f g w) where fmap f (AdjointT g) = AdjointT $ contramap (fmap (contramap f)) g instance (Adjunction f g, Comonad w) => Applicative (AdjointT f g w) where pure = AdjointT . leftAdjunct extract (<*>) = ap instance (Adjunction f g, Comonad w) => Monad (AdjointT f g w) where return = pure AdjointT m >>= f = AdjointT $ contramap (extend (rightAdjunct (runAdjointT . f))) m adjunctions-4.3/src/Data/0000755000000000000000000000000012646575273013550 5ustar0000000000000000adjunctions-4.3/src/Data/Functor/0000755000000000000000000000000012646575273015170 5ustar0000000000000000adjunctions-4.3/src/Data/Functor/Adjunction.hs0000644000000000000000000001443512646575273017631 0ustar0000000000000000{-# LANGUAGE Rank2Types , MultiParamTypeClasses , FunctionalDependencies , UndecidableInstances #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------------------------- -- | -- Copyright : 2008-2013 Edward Kmett -- License : BSD -- -- Maintainer : Edward Kmett -- Stability : experimental -- Portability : rank 2 types, MPTCs, fundeps -- ------------------------------------------------------------------------------------------- module Data.Functor.Adjunction ( Adjunction(..) , adjuncted , tabulateAdjunction , indexAdjunction , zapWithAdjunction , zipR, unzipR , unabsurdL, absurdL , cozipL, uncozipL , extractL, duplicateL , splitL, unsplitL ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Arrow ((&&&), (|||)) import Control.Monad.Free #if __GLASGOW_HASKELL__ < 707 import Control.Monad.Instances () #endif import Control.Monad.Trans.Identity import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer import Control.Comonad import Control.Comonad.Cofree import Control.Comonad.Trans.Env import Control.Comonad.Trans.Traced import Data.Functor.Identity import Data.Functor.Compose import Data.Functor.Product import Data.Functor.Rep import Data.Functor.Sum import Data.Profunctor import Data.Void -- | An adjunction between Hask and Hask. -- -- Minimal definition: both 'unit' and 'counit' or both 'leftAdjunct' -- and 'rightAdjunct', subject to the constraints imposed by the -- default definitions that the following laws should hold. -- -- > unit = leftAdjunct id -- > counit = rightAdjunct id -- > leftAdjunct f = fmap f . unit -- > rightAdjunct f = counit . fmap f -- -- Any implementation is required to ensure that 'leftAdjunct' and -- 'rightAdjunct' witness an isomorphism from @Nat (f a, b)@ to -- @Nat (a, g b)@ -- -- > rightAdjunct unit = id -- > leftAdjunct counit = id class (Functor f, Representable u) => Adjunction f u | f -> u, u -> f where unit :: a -> u (f a) counit :: f (u a) -> a leftAdjunct :: (f a -> b) -> a -> u b rightAdjunct :: (a -> u b) -> f a -> b unit = leftAdjunct id counit = rightAdjunct id leftAdjunct f = fmap f . unit rightAdjunct f = counit . fmap f -- | 'leftAdjunct' and 'rightAdjunct' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'adjuncted' :: 'Adjunction' f u => 'Iso'' (f a -> b) (a -> u b)@ adjuncted :: (Adjunction f u, Profunctor p, Functor g) => p (a -> u b) (g (c -> u d)) -> p (f a -> b) (g (f c -> d)) adjuncted = dimap leftAdjunct (fmap rightAdjunct) {-# INLINE adjuncted #-} -- | Every right adjoint is representable by its left adjoint -- applied to a unit element -- -- Use this definition and the primitives in -- Data.Functor.Representable to meet the requirements of the -- superclasses of Representable. tabulateAdjunction :: Adjunction f u => (f () -> b) -> u b tabulateAdjunction f = leftAdjunct f () -- | This definition admits a default definition for the -- 'index' method of 'Index", one of the superclasses of -- Representable. indexAdjunction :: Adjunction f u => u b -> f a -> b indexAdjunction = rightAdjunct . const zapWithAdjunction :: Adjunction f u => (a -> b -> c) -> u a -> f b -> c zapWithAdjunction f ua = rightAdjunct (\b -> fmap (flip f b) ua) splitL :: Adjunction f u => f a -> (a, f ()) splitL = rightAdjunct (flip leftAdjunct () . (,)) unsplitL :: Functor f => a -> f () -> f a unsplitL = (<$) extractL :: Adjunction f u => f a -> a extractL = fst . splitL duplicateL :: Adjunction f u => f a -> f (f a) duplicateL as = as <$ as -- | A right adjoint functor admits an intrinsic -- notion of zipping zipR :: Adjunction f u => (u a, u b) -> u (a, b) zipR = leftAdjunct (rightAdjunct fst &&& rightAdjunct snd) -- | Every functor in Haskell permits unzipping unzipR :: Functor u => u (a, b) -> (u a, u b) unzipR = fmap fst &&& fmap snd absurdL :: Void -> f Void absurdL = absurd -- | A left adjoint must be inhabited, or we can derive bottom. unabsurdL :: Adjunction f u => f Void -> Void unabsurdL = rightAdjunct absurd -- | And a left adjoint must be inhabited by exactly one element cozipL :: Adjunction f u => f (Either a b) -> Either (f a) (f b) cozipL = rightAdjunct (leftAdjunct Left ||| leftAdjunct Right) -- | Every functor in Haskell permits 'uncozipping' uncozipL :: Functor f => Either (f a) (f b) -> f (Either a b) uncozipL = fmap Left ||| fmap Right -- Requires deprecated Impredicative types -- limitR :: Adjunction f u => (forall a. u a) -> u (forall a. a) -- limitR = leftAdjunct (rightAdjunct (\(x :: forall a. a) -> x)) instance Adjunction ((,) e) ((->) e) where leftAdjunct f a e = f (e, a) rightAdjunct f ~(e, a) = f a e instance Adjunction Identity Identity where leftAdjunct f = Identity . f . Identity rightAdjunct f = runIdentity . f . runIdentity instance Adjunction f g => Adjunction (IdentityT f) (IdentityT g) where unit = IdentityT . leftAdjunct IdentityT counit = rightAdjunct runIdentityT . runIdentityT instance Adjunction w m => Adjunction (EnvT e w) (ReaderT e m) where unit = ReaderT . flip fmap EnvT . flip leftAdjunct counit (EnvT e w) = rightAdjunct (flip runReaderT e) w instance Adjunction m w => Adjunction (WriterT s m) (TracedT s w) where unit = TracedT . leftAdjunct (\ma s -> WriterT (fmap (\a -> (a, s)) ma)) counit = rightAdjunct (\(t, s) -> ($s) <$> runTracedT t) . runWriterT instance (Adjunction f g, Adjunction f' g') => Adjunction (Compose f' f) (Compose g g') where unit = Compose . leftAdjunct (leftAdjunct Compose) counit = rightAdjunct (rightAdjunct getCompose) . getCompose instance (Adjunction f g, Adjunction f' g') => Adjunction (Sum f f') (Product g g') where unit a = Pair (leftAdjunct InL a) (leftAdjunct InR a) counit (InL l) = rightAdjunct (\(Pair x _) -> x) l counit (InR r) = rightAdjunct (\(Pair _ x) -> x) r instance Adjunction f u => Adjunction (Free f) (Cofree u) where unit a = return a :< tabulateAdjunction (\k -> leftAdjunct (wrap . flip unsplitL k) a) counit (Pure a) = extract a counit (Free k) = rightAdjunct (flip indexAdjunction k . unwrap) (extractL k) adjunctions-4.3/src/Data/Functor/Rep.hs0000644000000000000000000002107112646575273016253 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -fenable-rewrite-rules #-} ---------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2011-2014 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- Representable endofunctors over the category of Haskell types are -- isomorphic to the reader monad and so inherit a very large number -- of properties for free. ---------------------------------------------------------------------- module Data.Functor.Rep ( -- * Representable Functors Representable(..) , tabulated -- * Wrapped representable functors , Co(..) -- * Default definitions -- ** Functor , fmapRep -- ** Distributive , distributeRep -- ** Apply/Applicative , apRep , pureRep , liftR2 , liftR3 -- ** Bind/Monad , bindRep -- ** MonadFix , mfixRep -- ** MonadZip , mzipRep , mzipWithRep -- ** MonadReader , askRep , localRep -- ** Extend , duplicatedRep , extendedRep -- ** Comonad , duplicateRep , extendRep , extractRep -- ** Comonad, with user-specified monoid , duplicateRepBy , extendRepBy , extractRepBy ) where import Control.Applicative import Control.Arrow ((&&&)) import Control.Comonad import Control.Comonad.Trans.Class import Control.Comonad.Trans.Traced import Control.Comonad.Cofree import Control.Monad.Trans.Identity import Control.Monad.Reader #if MIN_VERSION_base(4,4,0) import Data.Complex #endif import Data.Distributive import Data.Functor.Bind import Data.Functor.Identity import Data.Functor.Compose import Data.Functor.Extend import Data.Functor.Product import qualified Data.Monoid as Monoid import Data.Profunctor import Data.Proxy import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Semigroup hiding (Product) import Data.Tagged import Data.Void import Prelude hiding (lookup) -- | A 'Functor' @f@ is 'Representable' if 'tabulate' and 'index' witness an isomorphism to @(->) x@. -- -- Every 'Distributive' 'Functor' is actually 'Representable'. -- -- Every 'Representable' 'Functor' from Hask to Hask is a right adjoint. -- -- @ -- 'tabulate' . 'index' ≡ id -- 'index' . 'tabulate' ≡ id -- 'tabulate' . 'return' ≡ 'return' -- @ class Distributive f => Representable f where type Rep f :: * -- | -- @ -- 'fmap' f . 'tabulate' ≡ 'tabulate' . 'fmap' f -- @ tabulate :: (Rep f -> a) -> f a index :: f a -> Rep f -> a {-# RULES "tabulate/index" forall t. tabulate (index t) = t #-} -- | 'tabulate' and 'index' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'tabulated' :: 'Representable' f => 'Iso'' ('Rep' f -> a) (f a)@ tabulated :: (Representable f, Representable g, Profunctor p, Functor h) => p (f a) (h (g b)) -> p (Rep f -> a) (h (Rep g -> b)) tabulated = dimap tabulate (fmap index) {-# INLINE tabulated #-} -- * Default definitions fmapRep :: Representable f => (a -> b) -> f a -> f b fmapRep f = tabulate . fmap f . index pureRep :: Representable f => a -> f a pureRep = tabulate . const bindRep :: Representable f => f a -> (a -> f b) -> f b bindRep m f = tabulate $ \a -> index (f (index m a)) a mfixRep :: Representable f => (a -> f a) -> f a mfixRep = tabulate . mfix . fmap index mzipWithRep :: Representable f => (a -> b -> c) -> f a -> f b -> f c mzipWithRep f as bs = tabulate $ \k -> f (index as k) (index bs k) mzipRep :: Representable f => f a -> f b -> f (a, b) mzipRep as bs = tabulate (index as &&& index bs) askRep :: Representable f => f (Rep f) askRep = tabulate id localRep :: Representable f => (Rep f -> Rep f) -> f a -> f a localRep f m = tabulate (index m . f) apRep :: Representable f => f (a -> b) -> f a -> f b apRep f g = tabulate (index f <*> index g) distributeRep :: (Representable f, Functor w) => w (f a) -> f (w a) distributeRep wf = tabulate (\k -> fmap (`index` k) wf) duplicateRepBy :: Representable f => (Rep f -> Rep f -> Rep f) -> f a -> f (f a) duplicateRepBy plus w = tabulate (\m -> tabulate (index w . plus m)) extendRepBy :: Representable f => (Rep f -> Rep f -> Rep f) -> (f a -> b) -> f a -> f b extendRepBy plus f w = tabulate (\m -> f (tabulate (index w . plus m))) extractRepBy :: Representable f => (Rep f) -> f a -> a extractRepBy = flip index duplicatedRep :: (Representable f, Semigroup (Rep f)) => f a -> f (f a) duplicatedRep = duplicateRepBy (<>) extendedRep :: (Representable f, Semigroup (Rep f)) => (f a -> b) -> f a -> f b extendedRep = extendRepBy (<>) duplicateRep :: (Representable f, Monoid (Rep f)) => f a -> f (f a) duplicateRep = duplicateRepBy mappend extendRep :: (Representable f, Monoid (Rep f)) => (f a -> b) -> f a -> f b extendRep = extendRepBy mappend extractRep :: (Representable f, Monoid (Rep f)) => f a -> a extractRep = extractRepBy mempty -- * Instances instance Representable Proxy where type Rep Proxy = Void index Proxy = absurd tabulate _ = Proxy instance Representable Identity where type Rep Identity = () index (Identity a) () = a tabulate f = Identity (f ()) instance Representable (Tagged t) where type Rep (Tagged t) = () index (Tagged a) () = a tabulate f = Tagged (f ()) instance Representable m => Representable (IdentityT m) where type Rep (IdentityT m) = Rep m index (IdentityT m) i = index m i tabulate = IdentityT . tabulate instance Representable ((->) e) where type Rep ((->) e) = e index = id tabulate = id instance Representable m => Representable (ReaderT e m) where type Rep (ReaderT e m) = (e, Rep m) index (ReaderT f) (e,k) = index (f e) k tabulate = ReaderT . fmap tabulate . curry instance (Representable f, Representable g) => Representable (Compose f g) where type Rep (Compose f g) = (Rep f, Rep g) index (Compose fg) (i,j) = index (index fg i) j tabulate = Compose . tabulate . fmap tabulate . curry instance Representable w => Representable (TracedT s w) where type Rep (TracedT s w) = (s, Rep w) index (TracedT w) (e,k) = index w k e tabulate = TracedT . unCo . collect (Co . tabulate) . curry instance (Representable f, Representable g) => Representable (Product f g) where type Rep (Product f g) = Either (Rep f) (Rep g) index (Pair a _) (Left i) = index a i index (Pair _ b) (Right j) = index b j tabulate f = Pair (tabulate (f . Left)) (tabulate (f . Right)) instance Representable f => Representable (Cofree f) where type Rep (Cofree f) = Seq (Rep f) index (a :< as) key = case Seq.viewl key of Seq.EmptyL -> a k Seq.:< ks -> index (index as k) ks tabulate f = f Seq.empty :< tabulate (\k -> tabulate (f . (k Seq.<|))) instance Representable Monoid.Dual where type Rep Monoid.Dual = () index (Monoid.Dual d) () = d tabulate f = Monoid.Dual (f ()) instance Representable Monoid.Product where type Rep Monoid.Product = () index (Monoid.Product p) () = p tabulate f = Monoid.Product (f ()) instance Representable Monoid.Sum where type Rep Monoid.Sum = () index (Monoid.Sum s) () = s tabulate f = Monoid.Sum (f ()) #if MIN_VERSION_base(4,4,0) instance Representable Complex where type Rep Complex = Bool index (r :+ i) key = if key then i else r tabulate f = f False :+ f True #endif newtype Co f a = Co { unCo :: f a } deriving Functor instance Representable f => Representable (Co f) where type Rep (Co f) = Rep f tabulate = Co . tabulate index (Co f) i = index f i instance Representable f => Apply (Co f) where (<.>) = apRep instance Representable f => Applicative (Co f) where pure = pureRep (<*>) = apRep instance Representable f => Distributive (Co f) where distribute = distributeRep instance Representable f => Bind (Co f) where (>>-) = bindRep instance Representable f => Monad (Co f) where return = pure (>>=) = bindRep #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 instance (Representable f, Rep f ~ a) => MonadReader a (Co f) where ask = askRep local = localRep #endif instance (Representable f, Semigroup (Rep f)) => Extend (Co f) where extended = extendedRep instance (Representable f, Monoid (Rep f)) => Comonad (Co f) where extend = extendRep extract = extractRep instance ComonadTrans Co where lower (Co f) = f liftR2 :: Representable f => (a -> b -> c) -> f a -> f b -> f c liftR2 f fa fb = tabulate $ \i -> f (index fa i) (index fb i) liftR3 :: Representable f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d liftR3 f fa fb fc = tabulate $ \i -> f (index fa i) (index fb i) (index fc i) adjunctions-4.3/src/Data/Functor/Contravariant/0000755000000000000000000000000012646575273020003 5ustar0000000000000000adjunctions-4.3/src/Data/Functor/Contravariant/Adjunction.hs0000644000000000000000000000500712646575273022437 0ustar0000000000000000{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2011-2013 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : MPTCs -- ---------------------------------------------------------------------------- module Data.Functor.Contravariant.Adjunction ( Adjunction(..) , adjuncted , contrarepAdjunction , coindexAdjunction ) where #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 import Control.Monad.Instances () #endif import Data.Functor.Contravariant import Data.Functor.Contravariant.Rep import Data.Profunctor -- | An adjunction from @Hask^op@ to @Hask@ -- -- @'Op' (f a) b ~ 'Hask' a (g b)@ -- -- @ -- 'rightAdjunct' 'unit' = 'id' -- 'leftAdjunct' 'counit' = 'id' -- @ -- -- Any adjunction from @Hask@ to @Hask^op@ would indirectly -- permit @unsafePerformIO@, and therefore does not exist. class (Contravariant f, Representable g) => Adjunction f g | f -> g, g -> f where unit :: a -> g (f a) -- monad in Hask counit :: a -> f (g a) -- comonad in Hask^op leftAdjunct :: (b -> f a) -> a -> g b rightAdjunct :: (a -> g b) -> b -> f a unit = leftAdjunct id counit = rightAdjunct id leftAdjunct f = contramap f . unit rightAdjunct f = contramap f . counit -- | 'leftAdjunct' and 'rightAdjunct' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'adjuncted' :: 'Adjunction' f g => 'Iso'' (b -> f a) (a -> g b)@ adjuncted :: (Adjunction f g, Profunctor p, Functor h) => p (a -> g b) (h (c -> g d)) -> p (b -> f a) (h (d -> f c)) adjuncted = dimap leftAdjunct (fmap rightAdjunct) {-# INLINE adjuncted #-} -- | This 'Adjunction' gives rise to the @Cont@ 'Monad' instance Adjunction (Op r) (Op r) where unit a = Op (\k -> getOp k a) counit = unit -- | This gives rise to the @Cont Bool@ 'Monad' instance Adjunction Predicate Predicate where unit a = Predicate (\k -> getPredicate k a) counit = unit -- | Represent a 'Contravariant' functor that has a left adjoint contrarepAdjunction :: Adjunction f g => (a -> f ()) -> g a contrarepAdjunction = flip leftAdjunct () coindexAdjunction :: Adjunction f g => g a -> a -> f () coindexAdjunction = rightAdjunct . const adjunctions-4.3/src/Data/Functor/Contravariant/Rep.hs0000644000000000000000000000534012646575273021067 0ustar0000000000000000{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances #-} {-# OPTIONS_GHC -fenable-rewrite-rules #-} ---------------------------------------------------------------------- -- | -- Copyright : (c) Edward Kmett 2011-2014 -- License : BSD3 -- -- Maintainer : ekmett@gmail.com -- Stability : experimental -- -- Representable contravariant endofunctors over the category of Haskell -- types are isomorphic to @(_ -> r)@ and resemble mappings to a -- fixed range. ---------------------------------------------------------------------- module Data.Functor.Contravariant.Rep ( -- * Representable Contravariant Functors Representable(..) , tabulated -- * Default definitions , contramapRep ) where import Control.Monad.Reader import Data.Functor.Contravariant import Data.Functor.Product import Data.Profunctor import Data.Proxy import Prelude hiding (lookup) -- | A 'Contravariant' functor @f@ is 'Representable' if 'tabulate' and 'index' witness an isomorphism to @(_ -> Rep f)@. -- -- @ -- 'tabulate' . 'index' ≡ id -- 'index' . 'tabulate' ≡ id -- @ class Contravariant f => Representable f where type Rep f :: * -- | -- @ -- 'contramap' f ('tabulate' g) = 'tabulate' (g . f) -- @ tabulate :: (a -> Rep f) -> f a index :: f a -> a -> Rep f -- | -- @ -- 'contramapWithRep' f p ≡ 'tabulate' $ 'either' ('index' p) 'id' . f -- @ contramapWithRep :: (b -> Either a (Rep f)) -> f a -> f b contramapWithRep f p = tabulate $ either (index p) id . f {-# RULES "tabulate/index" forall t. tabulate (index t) = t #-} -- | 'tabulate' and 'index' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'tabulated' :: 'Representable' f => 'Iso'' (a -> 'Rep' f) (f a)@ tabulated :: (Representable f, Representable g, Profunctor p, Functor h) => p (f a) (h (g b)) -> p (a -> Rep f) (h (b -> Rep g)) tabulated = dimap tabulate (fmap index) {-# INLINE tabulated #-} contramapRep :: Representable f => (a -> b) -> f b -> f a contramapRep f = tabulate . (. f) . index instance Representable Proxy where type Rep Proxy = () tabulate _ = Proxy index Proxy _ = () contramapWithRep _ Proxy = Proxy instance Representable (Op r) where type Rep (Op r) = r tabulate = Op index = getOp instance Representable Predicate where type Rep Predicate = Bool tabulate = Predicate index = getPredicate instance (Representable f, Representable g) => Representable (Product f g) where type Rep (Product f g) = (Rep f, Rep g) tabulate f = Pair (tabulate (fst . f)) (tabulate (snd . f)) index (Pair f g) a = (index f a, index g a) contramapWithRep h (Pair f g) = Pair (contramapWithRep (fmap fst . h) f) (contramapWithRep (fmap snd . h) g) adjunctions-4.3/travis/0000755000000000000000000000000012646575273013420 5ustar0000000000000000adjunctions-4.3/travis/cabal-apt-install0000755000000000000000000000127212646575273016640 0ustar0000000000000000#! /bin/bash set -eu APT="sudo apt-get -q -y" CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" $APT update $APT install dctrl-tools # Find potential system packages to satisfy cabal dependencies deps() { local M='^\([^ ]\+\)-[0-9.]\+ (.*$' local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ | sed -ne "s/$M/$G/p" | sort -u)" grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u } $APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special $CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage if ! $APT install hlint ; then $APT install $(deps hlint) cabal install hlint fi adjunctions-4.3/travis/config0000644000000000000000000000120612646575273014607 0ustar0000000000000000-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix -- -- This is particularly useful for travis-ci to get it to stop complaining -- about a broken build when everything is still correct on our end. -- -- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead -- -- To enable this, uncomment the before_script in .travis.yml remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive remote-repo-cache: ~/.cabal/packages world-file: ~/.cabal/world build-summary: ~/.cabal/logs/build.log remote-build-reporting: anonymous install-dirs user install-dirs global