diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,14 @@ -_darcs -dist +dist/ +.hsenv/ +docs +wiki +TAGS tags +wip +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,7 @@ +4.0 +--- +* Merged the contents of `profunctor-extras` into `profunctors`. + 3.3 --- * Added `instance Choice (Upstar f)` and introduced `Forget`. diff --git a/profunctors.cabal b/profunctors.cabal --- a/profunctors.cabal +++ b/profunctors.cabal @@ -1,8 +1,8 @@ name: profunctors category: Control, Categories -version: 3.3.0.1 +version: 4.0 license: BSD3 -cabal-version: >= 1.6 +cabal-version: >= 1.10 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett @@ -10,8 +10,8 @@ homepage: http://github.com/ekmett/profunctors/ bug-reports: http://github.com/ekmett/profunctors/issues copyright: Copyright (C) 2011-2013 Edward A. Kmett -synopsis: Haskell 98 Profunctors -description: Haskell 98 Profunctors +synopsis: Profunctors +description: Profunctors build-type: Simple extra-source-files: .ghci @@ -27,13 +27,29 @@ library build-depends: - base == 4.*, - comonad >= 3 && < 4, - tagged >= 0.4.4 && < 1 + base >= 4 && < 5, + comonad >= 4 && < 5, + semigroupoids >= 4 && < 5, + tagged >= 0.4.4 && < 1, + transformers >= 0.2 && < 0.4 exposed-modules: Data.Profunctor + Data.Profunctor.Composition + Data.Profunctor.Collage + Data.Profunctor.Rep + Data.Profunctor.Rift + Data.Profunctor.Trace Data.Profunctor.Unsafe - ghc-options: -Wall + ghc-options: -Wall -O2 hs-source-dirs: src + + default-language: Haskell2010 + other-extensions: + CPP + GADTs + FlexibleContexts + FlexibleInstances + UndecidableInstances + TypeFamilies diff --git a/src/Data/Profunctor/Collage.hs b/src/Data/Profunctor/Collage.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Collage.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- 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 + +import Data.Semigroupoid +import Data.Semigroupoid.Ob +import Data.Semigroupoid.Coproduct (L, R) +import Data.Profunctor + +-- | The cograph of a 'Profunctor'. +data Collage k b a where + 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` C g = C (rmap f g) + C f `o` L g = C (lmap g f) + +instance Profunctor k => Ob (Collage k) (L a) where + semiid = L semiid + +instance Profunctor k => Ob (Collage k) (R a) where + semiid = R semiid diff --git a/src/Data/Profunctor/Composition.hs b/src/Data/Profunctor/Composition.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Composition.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +#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(..) + , procomposed + -- * Lax identity + , idl + , idr + -- * Generalized Composition + , upstars, kleislis + , downstars, cokleislis + ) where + +import Control.Arrow +import Control.Category +import Control.Comonad +import Control.Monad (liftM) +import Data.Functor.Compose +import Data.Profunctor +import Data.Profunctor.Rep +import Data.Profunctor.Unsafe +import Prelude hiding ((.),id) + +-- * Profunctor Composition + +-- | @'Procompose' p q@ is the 'Profunctor' composition of the +-- 'Profunctor's @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 + +procomposed :: Category p => Procompose p p a b -> p a b +procomposed (Procompose pda pac) = pac . pda +{-# INLINE procomposed #-} + + +instance (Profunctor p, Profunctor q) => Profunctor (Procompose p q) where + dimap l r (Procompose f g) = Procompose (lmap l f) (rmap r g) + {-# INLINE dimap #-} + lmap k (Procompose f g) = Procompose (lmap k f) g + {-# INLINE rmap #-} + rmap k (Procompose f g) = Procompose f (rmap k g) + {-# INLINE lmap #-} + k #. Procompose f g = Procompose f (k #. g) + {-# INLINE ( #. ) #-} + Procompose f g .# k = Procompose (f .# k) g + {-# INLINE ( .# ) #-} + +instance Profunctor q => Functor (Procompose p q a) where + fmap k (Procompose f g) = Procompose f (rmap k g) + {-# INLINE fmap #-} + +-- | The composition of two 'Representable' 'Profunctor's is 'Representable' by +-- the composition of their representations. +instance (Representable p, Representable q) => Representable (Procompose p q) where + type Rep (Procompose p q) = Compose (Rep p) (Rep q) + tabulate f = Procompose (tabulate (getCompose . f)) (tabulate id) + {-# INLINE tabulate #-} + rep (Procompose f g) d = Compose $ rep g <$> rep f d + {-# INLINE rep #-} + +instance (Corepresentable p, Corepresentable q) => Corepresentable (Procompose p q) where + type Corep (Procompose p q) = Compose (Corep q) (Corep p) + cotabulate f = Procompose (cotabulate id) (cotabulate (f . Compose)) + {-# INLINE cotabulate #-} + corep (Procompose f g) (Compose d) = corep g $ corep f <$> d + {-# INLINE corep #-} + +instance (Strong p, Strong q) => Strong (Procompose p q) where + first' (Procompose x y) = Procompose (first' x) (first' y) + {-# INLINE first' #-} + second' (Procompose x y) = Procompose (second' x) (second' y) + {-# INLINE second' #-} + +instance (Choice p, Choice q) => Choice (Procompose p q) where + left' (Procompose x y) = Procompose (left' x) (left' y) + {-# INLINE left' #-} + right' (Procompose x y) = Procompose (right' x) (right' y) + {-# INLINE right' #-} + + +-- * Lax identity + +-- | @(->)@ 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)) + +-- | @(->)@ 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)) + +-- | '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,122 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Data.Profunctor.Rep +-- Copyright : (C) 2011-2012 Edward Kmett, +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : Type-Families +-- +---------------------------------------------------------------------------- +module Data.Profunctor.Rep + ( + -- * Representable Profunctors + Representable(..), tabulated + -- * Corepresentable Profunctors + , Corepresentable(..), cotabulated + ) where + +import Control.Arrow +import Control.Comonad +import Data.Functor.Identity +import Data.Profunctor +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 (Rep p), Profunctor p) => Representable p where + type Rep p :: * -> * + tabulate :: (d -> Rep p c) -> p d c + rep :: p d c -> d -> Rep p c + +instance Representable (->) where + type Rep (->) = Identity + tabulate f = runIdentity . f + {-# INLINE tabulate #-} + rep f = Identity . f + {-# INLINE rep #-} + +instance (Monad m, Functor m) => Representable (Kleisli m) where + type Rep (Kleisli m) = m + tabulate = Kleisli + {-# INLINE tabulate #-} + rep = runKleisli + {-# INLINE rep #-} + +instance Functor f => Representable (UpStar f) where + type Rep (UpStar f) = f + tabulate = UpStar + {-# INLINE tabulate #-} + rep = runUpStar + {-# INLINE rep #-} + +-- | 'tabulate' and 'rep' form two halves of an isomorphism. +-- +-- This can be used with the combinators from the @lens@ package. +-- +-- @'tabulated' :: 'Representable' p => 'Iso'' (d -> 'Rep' p c) (p d c)@ +tabulated :: (Profunctor r, Functor f, Representable p, Representable q) + => r (p d c) (f (q d' c')) + -> r (d -> Rep p c) (f (d' -> Rep q c')) +tabulated = dimap tabulate (fmap rep) +{-# INLINE tabulated #-} + +-- * Corepresentable Profunctors + +-- | A 'Profunctor' @p@ is 'Corepresentable' if there exists a 'Functor' @f@ such that +-- @p d c@ is isomorphic to @f d -> c@. +class (Functor (Corep p), Profunctor p) => Corepresentable p where + type Corep p :: * -> * + cotabulate :: (Corep p d -> c) -> p d c + corep :: p d c -> Corep p d -> c + +instance Corepresentable (->) where + type Corep (->) = Identity + cotabulate f = f . Identity + {-# INLINE cotabulate #-} + corep f (Identity d) = f d + {-# INLINE corep #-} + +instance Functor w => Corepresentable (Cokleisli w) where + type Corep (Cokleisli w) = w + cotabulate = Cokleisli + {-# INLINE cotabulate #-} + corep = runCokleisli + {-# INLINE corep #-} + +instance Corepresentable Tagged where + type Corep Tagged = Proxy + cotabulate f = Tagged (f Proxy) + {-# INLINE cotabulate #-} + corep (Tagged a) _ = a + {-# INLINE corep #-} + +instance Functor f => Corepresentable (DownStar f) where + type Corep (DownStar f) = f + cotabulate = DownStar + {-# INLINE cotabulate #-} + corep = runDownStar + {-# INLINE corep #-} + +-- | '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, Corepresentable p, Corepresentable q) + => r (p d c) (h (q d' c')) + -> r (Corep p d -> c) (h (Corep q d' -> c')) +cotabulated = dimap cotabulate (fmap corep) +{-# INLINE cotabulated #-} diff --git a/src/Data/Profunctor/Rift.hs b/src/Data/Profunctor/Rift.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Rift.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2013 Edward Kmett and Dan Doel +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : Rank2Types +-- +---------------------------------------------------------------------------- +module Data.Profunctor.Rift + ( Rift(..) + , decomposeRift + , precomposeRift + ) where + +import Control.Category +import Data.Profunctor.Unsafe +import Data.Profunctor.Composition +import Prelude hiding (id,(.)) + +-- | This represents the right Kan lift of a 'Profunctor' @q@ along a 'Profunctor' @p@ in a limited version of the 2-category of Profunctors where the only object is the category Hask, 1-morphisms are profunctors composed and compose with Profunctor composition, and 2-morphisms are just natural transformations. +newtype Rift p q a b = Rift { runRift :: forall x. p x a -> q x b } + +-- Ran f g a = forall b. (a -> f b) -> g b + +instance (Profunctor p, Profunctor q) => Profunctor (Rift p q) where + dimap ca bd f = Rift (rmap bd . runRift f . rmap ca) + {-# INLINE dimap #-} + lmap ca f = Rift (runRift f . rmap ca) + {-# INLINE lmap #-} + rmap bd f = Rift (rmap bd . runRift f) + {-# INLINE rmap #-} + bd #. f = Rift (\p -> bd #. runRift f p) + {-# INLINE ( #. ) #-} + f .# ca = Rift (\p -> runRift f (ca #. p)) + {-# INLINE (.#) #-} + +instance Profunctor q => Functor (Rift p q a) where + fmap bd f = Rift (rmap bd . runRift f) + {-# INLINE fmap #-} + +-- | @'Rift' p p@ forms a 'Monad' in the 'Profunctor' 2-category, which is isomorphic to a Haskell 'Category' instance. +instance p ~ q => Category (Rift p q) where + id = Rift id + {-# INLINE id #-} + Rift f . Rift g = Rift (f . g) + {-# INLINE (.) #-} + +-- | The 2-morphism that defines a right Kan lift. +-- +-- Note: When @f@ is left adjoint to @'Rift' f (->)@ then 'decomposeRift' is the 'counit' of the adjunction. +decomposeRift :: Procompose q (Rift q p) a b -> p a b +decomposeRift (Procompose q (Rift qp)) = qp q +{-# INLINE decomposeRift #-} + +precomposeRift :: Profunctor q => Procompose (Rift p (->)) q a b -> Rift p q a b +precomposeRift (Procompose pf p) = Rift (\pxa -> runRift pf pxa `lmap` p) +{-# INLINE precomposeRift #-} diff --git a/src/Data/Profunctor/Trace.hs b/src/Data/Profunctor/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Data/Profunctor/Trace.hs @@ -0,0 +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 'Data.Profunctor.Profunctor' from @Hask -> Hask@. +data Trace f where + Trace :: f a a -> Trace f