diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,1 @@ +:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,1 +1,28 @@ language: haskell +before_install: + # Uncomment whenever hackage is down. + # - mkdir -p ~/.cabal && cp config ~/.cabal/config && cabal update + + # Try installing some of the build-deps with apt-get for speed. + - ./travis-cabal-apt-install --only-dependencies --force-reinstall $mode + + - sudo apt-get -q -y install hlint || cabal install hlint + +install: + - cabal configure $mode + - cabal build + +script: + - $script + - hlint src --cpp-define HLINT + +notifications: + irc: + channels: + - "irc.freenode.org#haskell-lens" + skip_join: true + template: + - "\x0313profunctor-extras\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" + +env: + - mode="--enable-tests" script="cabal test" diff --git a/.vim.custom b/.vim.custom new file mode 100644 --- /dev/null +++ b/.vim.custom @@ -0,0 +1,31 @@ +" 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" diff --git a/profunctor-extras.cabal b/profunctor-extras.cabal --- a/profunctor-extras.cabal +++ b/profunctor-extras.cabal @@ -1,6 +1,6 @@ name: profunctor-extras category: Control, Categories -version: 3.0.1 +version: 3.1 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE @@ -11,9 +11,15 @@ bug-reports: http://github.com/ekmett/profunctor-extras/issues copyright: Copyright (C) 2011 Edward A. Kmett synopsis: Profunctor extras -description: Profunctor extras +description: + This package provides a number of utilities and constructions that arise + when working with profunctors that require minor extensions to Haskell 98. build-type: Simple -extra-source-files: .travis.yml +extra-source-files: + .travis.yml + .vim.custom + .ghci + travis-cabal-apt-install source-repository head type: git @@ -30,14 +36,17 @@ build-depends: base == 4.*, + comonad == 3.0.*, semigroupoids == 3.0.*, semigroupoid-extras == 3.0.*, - comonad == 3.0.*, - profunctors >= 3.0 && < 3.2 + profunctors >= 3.1.2 && < 3.2, + tagged >= 0.4.4 && < 0.5, + transformers >= 0.2 && < 0.4 exposed-modules: Data.Profunctor.Composition Data.Profunctor.Collage + Data.Profunctor.Rep Data.Profunctor.Trace ghc-options: -Wall diff --git a/src/Data/Profunctor/Collage.hs b/src/Data/Profunctor/Collage.hs --- a/src/Data/Profunctor/Collage.hs +++ b/src/Data/Profunctor/Collage.hs @@ -1,6 +1,20 @@ -{-# LANGUAGE GADTs, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -module Data.Profunctor.Collage +----------------------------------------------------------------------------- +-- | +-- Module : Data.Profunctor.Collage +-- Copyright : (C) 2011-2012 Edward Kmett, +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : MPTCs +-- +---------------------------------------------------------------------------- +module Data.Profunctor.Collage ( Collage(..) ) where @@ -14,10 +28,10 @@ L :: (b -> b') -> Collage k (L b) (L b') R :: (a -> a') -> Collage k (R a) (R a') C :: k b a -> Collage k (L b) (R a) - + instance Profunctor k => Semigroupoid (Collage k) where L f `o` L g = L (f . g) - R f `o` R g = R (f . g) + R f `o` R g = R (f . g) R f `o` C g = C (rmap f g) C f `o` L g = C (lmap g f) diff --git a/src/Data/Profunctor/Composition.hs b/src/Data/Profunctor/Composition.hs --- a/src/Data/Profunctor/Composition.hs +++ b/src/Data/Profunctor/Composition.hs @@ -1,32 +1,126 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} -module Data.Profunctor.Composition - ( Procompose(..) - , proidl - , proidr - , coproidl - , coproidr +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Profunctor.Composition +-- Copyright : (C) 2011-2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : GADTs +-- +---------------------------------------------------------------------------- +module Data.Profunctor.Composition + ( + -- * Profunctor Composition + Procompose(..) + -- * Lax identity + , idl + , idr + -- * Generalized Composition + , upstars, kleislis + , downstars, cokleislis ) where +import Control.Arrow +import Control.Comonad +import Control.Monad (liftM) +import Data.Functor.Compose import Data.Profunctor +import Data.Profunctor.Unsafe -data Procompose f g d c where - Procompose :: f d a -> g a c -> Procompose f g d c +-- * Profunctor Composition -instance (Profunctor f, Profunctor g) => Profunctor (Procompose f g) where +-- | @'Procompose' p q@ is the 'Profunctor' composition of the profunctors @p@ and @q@. +-- +-- For a good explanation of profunctor composition in Haskell +-- see Dan Piponi's article: +-- +-- +data Procompose p q d c where + Procompose :: p d a -> q a c -> Procompose p q d c + +instance (Profunctor p, Profunctor q) => Profunctor (Procompose p q) where lmap k (Procompose f g) = Procompose (lmap k f) g rmap k (Procompose f g) = Procompose f (rmap k g) + k #. Procompose f g = Procompose f (k #. g) + Procompose f g .# k = Procompose (f .# k) g -instance Profunctor g => Functor (Procompose f g a) where +instance Profunctor q => Functor (Procompose p q a) where fmap k (Procompose f g) = Procompose f (rmap k g) -proidl :: Profunctor g => Procompose (->) g d c -> g d c -proidl (Procompose f g) = lmap f g +-- * Lax identity -proidr :: Profunctor f => Procompose f (->) d c -> f d c -proidr (Procompose f g) = rmap g f +-- | @(->)@ functions as a lax identity for profunctor composition. +-- +-- This provides an 'Iso' for the @lens@ package that witnesses the +-- isomorphism between @'Procompose' (->) q d c@ and @q d c@, which +-- is the left identity law. +-- +-- @ +-- 'idl' :: 'Profunctor' q => Iso' ('Procompose' (->) q d c) (q d c) +-- @ +idl :: (Profunctor p, Profunctor q, Functor f) + => p (q d c) (f (r d' c')) -> p (Procompose (->) q d c) (f (Procompose (->) r d' c')) +idl = dimap (\(Procompose f g) -> lmap f g) (fmap (Procompose id)) -coproidl :: g d c -> Procompose (->) g d c -coproidl = Procompose id +-- | @(->)@ functions as a lax identity for profunctor composition. +-- +-- This provides an 'Iso' for the @lens@ package that witnesses the +-- isomorphism between @'Procompose' q (->) d c@ and @q d c@, which +-- is the right identity law. +-- +-- @ +-- 'idr' :: 'Profunctor' q => Iso' ('Procompose' q (->) d c) (q d c) +-- @ +idr :: (Profunctor p, Profunctor q, Functor f) + => p (q d c) (f (r d' c')) -> p (Procompose q (->) d c) (f (Procompose r (->) d' c')) +idr = dimap (\(Procompose f g) -> rmap g f) (fmap (`Procompose` id)) -coproidr :: f d c -> Procompose f (->) d c -coproidr g = Procompose g id +-- | Profunctor composition generalizes functor composition in two ways. +-- +-- This is the first, which shows that @exists b. (a -> f b, b -> g c)@ is isomorphic to @a -> f (g c)@. +-- +-- @'upstars' :: 'Functor' f => Iso' ('Procompose' ('UpStar' f) ('UpStar' g) d c) ('UpStar' ('Compose' f g) d c)@ +upstars :: (Profunctor p, Functor f, Functor h) + => p (UpStar (Compose f g) d c) (h (UpStar (Compose f' g') d' c')) + -> p (Procompose (UpStar f) (UpStar g) d c) (h (Procompose (UpStar f') (UpStar g') d' c')) +upstars = dimap hither (fmap yon) where + hither (Procompose (UpStar dfx) (UpStar xgc)) = UpStar (Compose . fmap xgc . dfx) + yon (UpStar dfgc) = Procompose (UpStar (getCompose . dfgc)) (UpStar id) + +-- | Profunctor composition generalizes functor composition in two ways. +-- +-- This is the second, which shows that @exists b. (f a -> b, g b -> c)@ is isomorphic to @g (f a) -> c@. +-- +-- @'downstars' :: 'Functor' f => Iso' ('Procompose' ('DownStar' f) ('DownStar' g) d c) ('DownStar' ('Compose' g f) d c)@ +downstars :: (Profunctor p, Functor g, Functor h) + => p (DownStar (Compose g f) d c) (h (DownStar (Compose g' f') d' c')) + -> p (Procompose (DownStar f) (DownStar g) d c) (h (Procompose (DownStar f') (DownStar g') d' c')) +downstars = dimap hither (fmap yon) where + hither (Procompose (DownStar fdx) (DownStar gxc)) = DownStar (gxc . fmap fdx . getCompose) + yon (DownStar dgfc) = Procompose (DownStar id) (DownStar (dgfc . Compose)) + +-- | This is a variant on 'upstars' that uses 'Kleisli' instead of 'UpStar'. +-- +-- @'kleislis' :: 'Monad' f => Iso' ('Procompose' ('Kleisli' f) ('Kleisli' g) d c) ('Kleisli' ('Compose' f g) d c)@ +kleislis :: (Profunctor p, Monad f, Functor h) + => p (Kleisli (Compose f g) d c) (h (Kleisli (Compose f' g') d' c')) + -> p (Procompose (Kleisli f) (Kleisli g) d c) (h (Procompose (Kleisli f') (Kleisli g') d' c')) +kleislis = dimap hither (fmap yon) where + hither (Procompose (Kleisli dfx) (Kleisli xgc)) = Kleisli (Compose . liftM xgc . dfx) + yon (Kleisli dfgc) = Procompose (Kleisli (getCompose . dfgc)) (Kleisli id) + +-- | This is a variant on 'downstars' that uses 'Cokleisli' instead of 'DownStar'. +-- +-- @'cokleislis' :: 'Functor' f => Iso' ('Procompose' ('Cokleisli' f) ('Cokleisli' g) d c) ('Cokleisli' ('Compose' g f) d c)@ +cokleislis :: (Profunctor p, Functor g, Functor h) + => p (Cokleisli (Compose g f) d c) (h (Cokleisli (Compose g' f') d' c')) + -> p (Procompose (Cokleisli f) (Cokleisli g) d c) (h (Procompose (Cokleisli f') (Cokleisli g') d' c')) +cokleislis = dimap hither (fmap yon) where + hither (Procompose (Cokleisli fdx) (Cokleisli gxc)) = Cokleisli (gxc . fmap fdx . getCompose) + yon (Cokleisli dgfc) = Procompose (Cokleisli id) (Cokleisli (dgfc . Compose)) diff --git a/src/Data/Profunctor/Rep.hs b/src/Data/Profunctor/Rep.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Rep.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Profunctor.Rep +-- Copyright : (C) 2011-2012 Edward Kmett, +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : MPTCs +-- +---------------------------------------------------------------------------- +module Data.Profunctor.Rep + ( + -- * Representable Profunctors + Rep(..), tabulated + -- * Corepresentable Profunctors + , Corep(..), cotabulated + ) where + +import Control.Arrow +import Control.Comonad +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Profunctor +import Data.Profunctor.Composition +import Data.Proxy +import Data.Tagged + +-- * Representable Profunctors + +-- | A 'Profunctor' @p@ is representable if there exists a 'Functor' @f@ such that +-- @p d c@ is isomorphic to @d -> f c@. +class (Functor f, Profunctor p) => Rep f p where + tabulate :: (d -> f c) -> p d c + rep :: p d c -> d -> f c + +instance Rep Identity (->) where + tabulate f = runIdentity . f + rep f = Identity . f + +instance (Monad m, Functor m) => Rep m (Kleisli m) where + tabulate = Kleisli + rep = runKleisli + +instance Functor f => Rep f (UpStar f) where + tabulate = UpStar + rep = runUpStar + +-- | The composition of two representable profunctors is representable by the composition of their representations. +instance (Rep f p, Rep g q) => Rep (Compose f g) (Procompose p q) where + tabulate f = Procompose (tabulate (getCompose . f)) (tabulate id) + rep (Procompose f g) d = Compose $ rep g <$> rep f d + +-- | 'tabulate' and 'rep' form two halves of an isomorphism. +-- +-- This can be used with the combinators from the @lens@ package. +-- +-- @'tabulated' :: 'Rep' f p => 'Iso'' (d -> f c) (p d c)@ +tabulated :: (Profunctor r, Functor h, Rep f p, Rep g q) + => r (p d c) (h (q d' c')) + -> r (d -> f c) (h (d' -> g c')) +tabulated = dimap tabulate (fmap rep) + +-- * Corepresentable Profunctors + +-- | A 'Profunctor' @p@ is representable if there exists a 'Functor' @f@ such that +-- @p d c@ is isomorphic to @d -> f c@. +class (Functor f, Profunctor p) => Corep f p where + cotabulate :: (f d -> c) -> p d c + corep :: p d c -> f d -> c + +instance Corep Identity (->) where + cotabulate f = f . Identity + corep f (Identity d) = f d + +instance Functor w => Corep w (Cokleisli w) where + cotabulate = Cokleisli + corep = runCokleisli + +instance Corep Proxy Tagged where + cotabulate f = Tagged (f Proxy) + corep (Tagged a) _ = a + +instance Functor f => Corep f (DownStar f) where + cotabulate = DownStar + corep = runDownStar + +instance (Corep f p, Corep g q) => Corep (Compose g f) (Procompose p q) where + cotabulate f = Procompose (cotabulate id) (cotabulate (f . Compose)) + corep (Procompose f g) (Compose d) = corep g $ corep f <$> d + +-- | 'cotabulate' and 'corep' form two halves of an isomorphism. +-- +-- This can be used with the combinators from the @lens@ package. +-- +-- @'tabulated' :: 'Corep' f p => 'Iso'' (f d -> c) (p d c)@ +cotabulated :: (Profunctor r, Functor h, Corep f p, Corep g q) + => r (p d c) (h (q d' c')) + -> r (f d -> c) (h (g d' -> c')) +cotabulated = dimap cotabulate (fmap corep) diff --git a/src/Data/Profunctor/Trace.hs b/src/Data/Profunctor/Trace.hs --- a/src/Data/Profunctor/Trace.hs +++ b/src/Data/Profunctor/Trace.hs @@ -1,8 +1,19 @@ {-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Profunctor.Trace +-- Copyright : (C) 2011-2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : GADTs +-- +---------------------------------------------------------------------------- module Data.Profunctor.Trace ( Trace(..) ) where --- | Coend of profunctor from Hask -> Hask +-- | Coend of 'Data.Profunctor.Profunctor' from @Hask -> Hask@ data Trace f where Trace :: f a a -> Trace f diff --git a/travis-cabal-apt-install b/travis-cabal-apt-install new file mode 100644 --- /dev/null +++ b/travis-cabal-apt-install @@ -0,0 +1,16 @@ +#!/bin/sh +set -eu + +sudo apt-get -q update +sudo apt-get -q -y install dctrl-tools + +# Try installing some of the build-deps with apt-get for speed. +eval "$( + printf '%s' "grep-aptavail -n -sPackage '(' -FFALSE -X FALSE ')'" + 2>/dev/null cabal install "$@" --dry-run -v | \ + sed -nre "s/^([^ ]+)-[0-9.]+ \(.*$/ -o '(' -FPackage -X libghc-\1-dev ')'/p" | \ + xargs -d'\n' +)" | sort -u | xargs -d'\n' sudo apt-get -q -y install -- libghc-quickcheck2-dev + +# Install whatever is still needed with cabal. +cabal install "$@"