profunctors 4.4.1 → 5
raw patch · 11 files changed
+214/−172 lines, 11 filesdep −semigroupoids
Dependencies removed: semigroupoids
Files
- .travis.yml +6/−2
- CHANGELOG.markdown +7/−0
- HLint.hs +1/−0
- profunctors.cabal +5/−4
- src/Data/Profunctor.hs +59/−54
- src/Data/Profunctor/Closed.hs +4/−4
- src/Data/Profunctor/Collage.hs +0/−46
- src/Data/Profunctor/Composition.hs +33/−27
- src/Data/Profunctor/Rep.hs +19/−34
- src/Data/Profunctor/Sieve.hs +79/−0
- src/Data/Profunctor/Unsafe.hs +1/−1
.travis.yml view
@@ -2,8 +2,9 @@ # See also https://github.com/hvr/multi-ghc-travis for more information env:- # we have to use CABALVER=1.16 for GHC<7.6 as well, as there's- # no package for earlier cabal versions in the PPA+ - GHCVER=7.0.1 CABALVER=1.16+ - GHCVER=7.0.4 CABALVER=1.16+ - GHCVER=7.2.2 CABALVER=1.16 - GHCVER=7.4.2 CABALVER=1.16 - GHCVER=7.6.3 CABALVER=1.16 - GHCVER=7.8.4 CABALVER=1.18@@ -12,6 +13,9 @@ matrix: allow_failures:+ - env: GHCVER=7.0.1 CABALVER=1.16+ - env: GHCVER=7.0.4 CABALVER=1.16+ - env: GHCVER=7.2.2 CABALVER=1.16 - env: GHCVER=head CABALVER=1.22 # Note: the distinction between `before_install` and `install` is not
CHANGELOG.markdown view
@@ -1,3 +1,10 @@+5+-+* `UpStar` and `DownStar` have become `Star` and `Costar`. `Star` is analogous to `Kleisli`, `Costar` is analogous to `Cokleisli`.+* Split representability into sieves and representability.+* Moved `Data.Profunctor.Collage` to `semigroupoids` 5, and removed the `semigroupoids` dependency. +* Rather greatly widened the range of GHC versions we can support.+ 4.4.1 ------- * Using `SafeHaskell`, GHC 7.8+ `Data.Profunctor.Unsafe` now infers as `Trustworthy` and
+ HLint.hs view
@@ -0,0 +1,1 @@+ignore "use const"
profunctors.cabal view
@@ -1,6 +1,6 @@ name: profunctors category: Control, Categories-version: 4.4.1+version: 5 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE@@ -9,9 +9,10 @@ stability: experimental homepage: http://github.com/ekmett/profunctors/ bug-reports: http://github.com/ekmett/profunctors/issues-copyright: Copyright (C) 2011-2014 Edward A. Kmett+copyright: Copyright (C) 2011-2015 Edward A. Kmett synopsis: Profunctors description: Profunctors+tested-with: GHC==7.0.1, GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 build-type: Simple extra-source-files: .ghci@@ -20,6 +21,7 @@ .vim.custom README.markdown CHANGELOG.markdown+ HLint.hs source-repository head type: git@@ -30,7 +32,6 @@ base >= 4 && < 5, comonad >= 4 && < 5, distributive >= 0.4.4 && < 1,- semigroupoids >= 4 && < 5, tagged >= 0.4.4 && < 1, transformers >= 0.2 && < 0.5 @@ -41,11 +42,11 @@ Data.Profunctor.Closed Data.Profunctor.Codensity Data.Profunctor.Composition- Data.Profunctor.Collage Data.Profunctor.Monad Data.Profunctor.Monoid Data.Profunctor.Ran Data.Profunctor.Rep+ Data.Profunctor.Sieve Data.Profunctor.Tambara Data.Profunctor.Trace Data.Profunctor.Unsafe
src/Data/Profunctor.hs view
@@ -33,8 +33,8 @@ , Costrong(..) , Cochoice(..) -- ** Common Profunctors- , UpStar(..)- , DownStar(..)+ , Star(..)+ , Costar(..) , WrappedArrow(..) , Forget(..) #ifndef HLINT@@ -48,6 +48,7 @@ import Control.Comonad import Control.Monad (liftM, MonadPlus(..)) import Control.Monad.Fix+import Data.Distributive import Data.Foldable import Data.Monoid import Data.Tagged@@ -66,18 +67,18 @@ type p :-> q = forall a b. p a b -> q a b --------------------------------------------------------------------------------- UpStar+-- Star ------------------------------------------------------------------------------ -- | Lift a 'Functor' into a 'Profunctor' (forwards).-newtype UpStar f d c = UpStar { runUpStar :: d -> f c }+newtype Star f d c = Star { runStar :: d -> f c } -instance Functor f => Profunctor (UpStar f) where- dimap ab cd (UpStar bfc) = UpStar (fmap cd . bfc . ab)+instance Functor f => Profunctor (Star f) where+ dimap ab cd (Star bfc) = Star (fmap cd . bfc . ab) {-# INLINE dimap #-}- lmap k (UpStar f) = UpStar (f . k)+ lmap k (Star f) = Star (f . k) {-# INLINE lmap #-}- rmap k (UpStar f) = UpStar (fmap k . f)+ rmap k (Star f) = Star (fmap k . f) {-# INLINE rmap #-} -- We cannot safely overload ( #. ) because we didn't write the 'Functor'. #if __GLASGOW_HASKELL__ >= 708@@ -87,43 +88,46 @@ #endif {-# INLINE ( .# ) #-} -instance Functor f => Functor (UpStar f a) where+instance Functor f => Functor (Star f a) where fmap = rmap {-# INLINE fmap #-} -instance Applicative f => Applicative (UpStar f a) where- pure a = UpStar $ \_ -> pure a- UpStar ff <*> UpStar fx = UpStar $ \a -> ff a <*> fx a- UpStar ff *> UpStar fx = UpStar $ \a -> ff a *> fx a- UpStar ff <* UpStar fx = UpStar $ \a -> ff a <* fx a+instance Applicative f => Applicative (Star f a) where+ pure a = Star $ \_ -> pure a+ Star ff <*> Star fx = Star $ \a -> ff a <*> fx a+ Star ff *> Star fx = Star $ \a -> ff a *> fx a+ Star ff <* Star fx = Star $ \a -> ff a <* fx a -instance Alternative f => Alternative (UpStar f a) where- empty = UpStar $ \_ -> empty- UpStar f <|> UpStar g = UpStar $ \a -> f a <|> g a+instance Alternative f => Alternative (Star f a) where+ empty = Star $ \_ -> empty+ Star f <|> Star g = Star $ \a -> f a <|> g a -instance Monad f => Monad (UpStar f a) where- return a = UpStar $ \_ -> return a- UpStar m >>= f = UpStar $ \ e -> do+instance Monad f => Monad (Star f a) where+ return a = Star $ \_ -> return a+ Star m >>= f = Star $ \ e -> do a <- m e- runUpStar (f a) e+ runStar (f a) e -instance MonadPlus f => MonadPlus (UpStar f a) where- mzero = UpStar $ \_ -> mzero- UpStar f `mplus` UpStar g = UpStar $ \a -> f a `mplus` g a+instance MonadPlus f => MonadPlus (Star f a) where+ mzero = Star $ \_ -> mzero+ Star f `mplus` Star g = Star $ \a -> f a `mplus` g a +instance Distributive f => Distributive (Star f a) where+ distribute fs = Star $ \a -> collect (($ a) .# runStar) fs+ --------------------------------------------------------------------------------- DownStar+-- Costar ------------------------------------------------------------------------------ -- | Lift a 'Functor' into a 'Profunctor' (backwards).-newtype DownStar f d c = DownStar { runDownStar :: f d -> c }+newtype Costar f d c = Costar { runCostar :: f d -> c } -instance Functor f => Profunctor (DownStar f) where- dimap ab cd (DownStar fbc) = DownStar (cd . fbc . fmap ab)+instance Functor f => Profunctor (Costar f) where+ dimap ab cd (Costar fbc) = Costar (cd . fbc . fmap ab) {-# INLINE dimap #-}- lmap k (DownStar f) = DownStar (f . fmap k)+ lmap k (Costar f) = Costar (f . fmap k) {-# INLINE lmap #-}- rmap k (DownStar f) = DownStar (k . f)+ rmap k (Costar f) = Costar (k . f) {-# INLINE rmap #-} #if __GLASGOW_HASKELL__ >= 708 ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b@@ -133,21 +137,24 @@ {-# INLINE ( #. ) #-} -- We cannot overload ( .# ) because we didn't write the 'Functor'. -instance Functor (DownStar f a) where- fmap k (DownStar f) = DownStar (k . f)+instance Distributive (Costar f d) where+ distribute fs = Costar $ \gd -> fmap (($ gd) .# runCostar) fs++instance Functor (Costar f a) where+ fmap k (Costar f) = Costar (k . f) {-# INLINE fmap #-}- a <$ _ = DownStar $ \_ -> a+ a <$ _ = Costar $ \_ -> a {-# INLINE (<$) #-} -instance Applicative (DownStar f a) where- pure a = DownStar $ \_ -> a- DownStar ff <*> DownStar fx = DownStar $ \a -> ff a (fx a)+instance Applicative (Costar f a) where+ pure a = Costar $ \_ -> a+ Costar ff <*> Costar fx = Costar $ \a -> ff a (fx a) _ *> m = m m <* _ = m -instance Monad (DownStar f a) where- return a = DownStar $ \_ -> a- DownStar m >>= f = DownStar $ \ x -> runDownStar (f (m x)) x+instance Monad (Costar f a) where+ return a = Costar $ \_ -> a+ Costar m >>= f = Costar $ \ x -> runCostar (f (m x)) x ------------------------------------------------------------------------------ -- Wrapped Profunctors@@ -233,9 +240,9 @@ -- Strong ------------------------------------------------------------------------------ --- | Generalizing 'UpStar' of a strong 'Functor'+-- | Generalizing 'Star' of a strong 'Functor' ----- /Note:/ Every 'Functor' in Haskell is strong with respect to (,).+-- /Note:/ Every 'Functor' in Haskell is strong with respect to @(,)@. -- -- This describes profunctor strength with respect to the product structure -- of Hask.@@ -268,13 +275,13 @@ return (c, b) {-# INLINE second' #-} -instance Functor m => Strong (UpStar m) where- first' (UpStar f) = UpStar $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a+instance Functor m => Strong (Star m) where+ first' (Star f) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> f a {-# INLINE first' #-}- second' (UpStar f) = UpStar $ \ ~(c, a) -> (,) c <$> f a+ second' (Star f) = Star $ \ ~(c, a) -> (,) c <$> f a {-# INLINE second' #-} --- | Every Arrow is a Strong Monad in Prof+-- | 'Arrow' is 'Strong' 'Category' instance Arrow p => Strong (WrappedArrow p) where first' (WrapArrow k) = WrapArrow (first k) {-# INLINE first' #-}@@ -291,7 +298,7 @@ -- Choice ------------------------------------------------------------------------------ --- | The generalization of 'DownStar' of 'Functor' that is strong with respect+-- | The generalization of 'Costar' of 'Functor' that is strong with respect -- to 'Either'. -- -- Note: This is also a notion of strength, except with regards to another monoidal @@ -320,10 +327,10 @@ right' = right {-# INLINE right' #-} -instance Applicative f => Choice (UpStar f) where- left' (UpStar f) = UpStar $ either (fmap Left . f) (fmap Right . pure)+instance Applicative f => Choice (Star f) where+ left' (Star f) = Star $ either (fmap Left . f) (fmap Right . pure) {-# INLINE left' #-}- right' (UpStar f) = UpStar $ either (fmap Left . pure) (fmap Right . f)+ right' (Star f) = Star $ either (fmap Left . pure) (fmap Right . f) {-# INLINE right' #-} -- | 'extract' approximates 'costrength'@@ -334,10 +341,10 @@ {-# INLINE right' #-} -- NB: This instance is highly questionable-instance Traversable w => Choice (DownStar w) where- left' (DownStar wab) = DownStar (either Right Left . fmap wab . traverse (either Right Left))+instance Traversable w => Choice (Costar w) where+ left' (Costar wab) = Costar (either Right Left . fmap wab . traverse (either Right Left)) {-# INLINE left' #-}- right' (DownStar wab) = DownStar (fmap wab . sequence)+ right' (Costar wab) = Costar (fmap wab . sequence) {-# INLINE right' #-} instance Choice Tagged where@@ -363,8 +370,6 @@ -------------------------------------------------------------------------------- -- | Analogous to 'ArrowLoop', 'loop' = 'unfirst'--- --- unfirst . unfirst = class Profunctor p => Costrong p where unfirst :: p (a, d) (b, d) -> p a b unfirst = unsecond . dimap swap swap
src/Data/Profunctor/Closed.hs view
@@ -44,14 +44,14 @@ instance Closed (->) where closed = (.) -instance Functor f => Closed (DownStar f) where- closed (DownStar fab) = DownStar $ \fxa x -> fab (fmap ($x) fxa)+instance Functor f => Closed (Costar f) where+ closed (Costar fab) = Costar $ \fxa x -> fab (fmap ($x) fxa) instance Functor f => Closed (Cokleisli f) where closed (Cokleisli fab) = Cokleisli $ \fxa x -> fab (fmap ($x) fxa) -instance Distributive f => Closed (UpStar f) where- closed (UpStar afb) = UpStar $ \xa -> distribute $ \x -> afb (xa x)+instance Distributive f => Closed (Star f) where+ closed (Star afb) = Star $ \xa -> distribute $ \x -> afb (xa x) instance (Distributive f, Monad f) => Closed (Kleisli f) where closed (Kleisli afb) = Kleisli $ \xa -> distribute $ \x -> afb (xa x)
− src/Data/Profunctor/Collage.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Module : Data.Profunctor.Collage--- Copyright : (C) 2011-2012 Edward Kmett,--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- 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
src/Data/Profunctor/Composition.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE Trustworthy #-} #endif@@ -28,8 +29,8 @@ , idr , assoc -- * Generalized Composition- , upstars, kleislis- , downstars, cokleislis+ , stars, kleislis+ , costars, cokleislis -- * Right Kan Lift , Rift(..) , decomposeRift@@ -45,6 +46,7 @@ import Data.Profunctor.Closed import Data.Profunctor.Monad import Data.Profunctor.Rep+import Data.Profunctor.Sieve import Data.Profunctor.Unsafe import Prelude hiding ((.),id) @@ -89,21 +91,25 @@ fmap k (Procompose f g) = Procompose (rmap k f) g {-# INLINE fmap #-} +instance (Sieve p f, Sieve q g) => Sieve (Procompose p q) (Compose g f) where+ sieve (Procompose g f) d = Compose $ sieve g <$> sieve f d+ {-# INLINE sieve #-}+ -- | 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 q) (Rep p) tabulate f = Procompose (tabulate id) (tabulate (getCompose . f)) {-# INLINE tabulate #-}- rep (Procompose g f) d = Compose $ rep g <$> rep f d- {-# INLINE rep #-} +instance (Cosieve p f, Cosieve q g) => Cosieve (Procompose p q) (Compose f g) where+ cosieve (Procompose g f) (Compose d) = cosieve g $ cosieve f <$> d+ {-# INLINE cosieve #-}+ instance (Corepresentable p, Corepresentable q) => Corepresentable (Procompose p q) where type Corep (Procompose p q) = Compose (Corep p) (Corep q) cotabulate f = Procompose (cotabulate (f . Compose)) (cotabulate id) {-# INLINE cotabulate #-}- corep (Procompose g f) (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)@@ -164,32 +170,32 @@ -- 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 :: Functor g- => Iso (Procompose (UpStar f ) (UpStar g ) d c )- (Procompose (UpStar f') (UpStar g') d' c')- (UpStar (Compose g f ) d c )- (UpStar (Compose g' f') d' c')-upstars = dimap hither (fmap yon) where- hither (Procompose (UpStar xgc) (UpStar dfx)) = UpStar (Compose . fmap xgc . dfx)- yon (UpStar dfgc) = Procompose (UpStar id) (UpStar (getCompose . dfgc))+-- @'stars' :: 'Functor' f => Iso' ('Procompose' ('Star' f) ('Star' g) d c) ('Star' ('Compose' f g) d c)@+stars :: Functor g+ => Iso (Procompose (Star f ) (Star g ) d c )+ (Procompose (Star f') (Star g') d' c')+ (Star (Compose g f ) d c )+ (Star (Compose g' f') d' c')+stars = dimap hither (fmap yon) where+ hither (Procompose (Star xgc) (Star dfx)) = Star (Compose . fmap xgc . dfx)+ yon (Star dfgc) = Procompose (Star id) (Star (getCompose . dfgc)) -- | '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 :: Functor f- => Iso (Procompose (DownStar f ) (DownStar g ) d c )- (Procompose (DownStar f') (DownStar g') d' c')- (DownStar (Compose f g ) d c )- (DownStar (Compose f' g') d' c')-downstars = dimap hither (fmap yon) where- hither (Procompose (DownStar gxc) (DownStar fdx)) = DownStar (gxc . fmap fdx . getCompose)- yon (DownStar dgfc) = Procompose (DownStar (dgfc . Compose)) (DownStar id)+-- @'costars' :: 'Functor' f => Iso' ('Procompose' ('Costar' f) ('Costar' g) d c) ('Costar' ('Compose' g f) d c)@+costars :: Functor f+ => Iso (Procompose (Costar f ) (Costar g ) d c )+ (Procompose (Costar f') (Costar g') d' c')+ (Costar (Compose f g ) d c )+ (Costar (Compose f' g') d' c')+costars = dimap hither (fmap yon) where+ hither (Procompose (Costar gxc) (Costar fdx)) = Costar (gxc . fmap fdx . getCompose)+ yon (Costar dgfc) = Procompose (Costar (dgfc . Compose)) (Costar id) --- | This is a variant on 'upstars' that uses 'Kleisli' instead of 'UpStar'.+-- | This is a variant on 'stars' that uses 'Kleisli' instead of 'Star'. -- -- @'kleislis' :: 'Monad' f => Iso' ('Procompose' ('Kleisli' f) ('Kleisli' g) d c) ('Kleisli' ('Compose' f g) d c)@ kleislis :: Monad g@@ -201,8 +207,8 @@ hither (Procompose (Kleisli xgc) (Kleisli dfx)) = Kleisli (Compose . liftM xgc . dfx) yon (Kleisli dfgc) = Procompose (Kleisli id) (Kleisli (getCompose . dfgc)) --- | This is a variant on 'downstars' that uses 'Cokleisli' instead--- of 'DownStar'.+-- | This is a variant on 'costars' that uses 'Cokleisli' instead+-- of 'Costar'. -- -- @'cokleislis' :: 'Functor' f => Iso' ('Procompose' ('Cokleisli' f) ('Cokleisli' g) d c) ('Cokleisli' ('Compose' g f) d c)@ cokleislis :: Functor f
src/Data/Profunctor/Rep.hs view
@@ -21,10 +21,12 @@ module Data.Profunctor.Rep ( -- * Representable Profunctors- Representable(..), tabulated+ Representable(..)+ , tabulated , firstRep, secondRep -- * Corepresentable Profunctors- , Corepresentable(..), cotabulated+ , Corepresentable(..)+ , cotabulated ) where import Control.Applicative@@ -32,6 +34,7 @@ import Control.Comonad import Data.Functor.Identity import Data.Profunctor+import Data.Profunctor.Sieve import Data.Proxy import Data.Tagged @@ -39,100 +42,82 @@ -- | 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), Strong p) => Representable p where+class (Sieve p (Rep p), Strong p) => Representable p where type Rep p :: * -> * tabulate :: (d -> Rep p c) -> p d c- rep :: p d c -> d -> Rep p c -- | Default definition for 'first'' given that p is 'Representable'. firstRep :: Representable p => p a b -> p (a, c) (b, c)-firstRep p = tabulate $ \(a,c) -> (\b -> (b, c)) <$> rep p a+firstRep p = tabulate $ \(a,c) -> (\b -> (b, c)) <$> sieve p a -- | Default definition for 'second'' given that p is 'Representable'. secondRep :: Representable p => p a b -> p (c, a) (c, b)-secondRep p = tabulate $ \(c,a) -> (,) c <$> rep p a+secondRep p = tabulate $ \(c,a) -> (,) c <$> sieve p a 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+instance Functor f => Representable (Star f) where+ type Rep (Star f) = f+ tabulate = Star {-# INLINE tabulate #-}- rep = runUpStar- {-# INLINE rep #-} instance Representable (Forget r) where type Rep (Forget r) = Const r tabulate = Forget . (getConst .) {-# INLINE tabulate #-}- rep = (Const .) . runForget- {-# INLINE rep #-} type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) --- | 'tabulate' and 'rep' form two halves of an isomorphism.+-- | 'tabulate' and 'sieve' 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 :: (Representable p, Representable q) => Iso (d -> Rep p c) (d' -> Rep q c') (p d c) (q d' c')-tabulated = dimap tabulate (fmap rep)+tabulated = dimap tabulate (fmap sieve) {-# 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+class Cosieve p (Corep 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+instance Functor f => Corepresentable (Costar f) where+ type Corep (Costar f) = f+ cotabulate = Costar {-# INLINE cotabulate #-}- corep = runDownStar- {-# INLINE corep #-} --- | 'cotabulate' and 'corep' form two halves of an isomorphism.+-- | 'cotabulate' and 'cosieve' form two halves of an isomorphism. -- -- This can be used with the combinators from the @lens@ package. -- -- @'cotabulated' :: 'Corep' f p => 'Iso'' (f d -> c) (p d c)@ cotabulated :: (Corepresentable p, Corepresentable q) => Iso (Corep p d -> c) (Corep q d' -> c') (p d c) (q d' c')-cotabulated = dimap cotabulate (fmap corep)+cotabulated = dimap cotabulate (fmap cosieve) {-# INLINE cotabulated #-}
+ src/Data/Profunctor/Sieve.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Copyright : (C) 2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : MPTCs, fundeps+--+----------------------------------------------------------------------------+module Data.Profunctor.Sieve+ ( Sieve(..)+ , Cosieve(..)+ ) where++import Control.Applicative+import Control.Arrow+import Control.Comonad+import Data.Functor.Identity+import Data.Profunctor+import Data.Proxy+import Data.Tagged++-- | A 'Profunctor' @p@ is a 'Sieve' __on__ @f@ if it is a subprofunctor of @'Star' f@.+--+-- That is to say it is a subset of @Hom(-,f=)@ closed under 'lmap' and 'rmap'.+--+-- Alternately, you can view it as a sieve __in__ the comma category @Hask/f@.+class (Profunctor p, Functor f) => Sieve p f | p -> f where+ sieve :: p a b -> a -> f b++instance Sieve (->) Identity where+ sieve f = Identity . f+ {-# INLINE sieve #-}++instance (Monad m, Functor m) => Sieve (Kleisli m) m where+ sieve = runKleisli+ {-# INLINE sieve #-}++instance Functor f => Sieve (Star f) f where+ sieve = runStar+ {-# INLINE sieve #-}++instance Sieve (Forget r) (Const r) where+ sieve = (Const .) . runForget+ {-# INLINE sieve #-}++-- | A 'Profunctor' @p@ is a 'Sieve' __on__ @f@ if it is a subprofunctor of @'Costar' f@.+--+-- That is to say it is a subset of @Hom(f-,=)@ closed under 'lmap' and 'rmap'.+--+-- Alternately, you can view it as a cosieve __in__ the comma category @f/Hask@.+class (Profunctor p, Functor f) => Cosieve p f | p -> f where+ cosieve :: p a b -> f a -> b++instance Cosieve (->) Identity where+ cosieve f (Identity d) = f d+ {-# INLINE cosieve #-}++instance Functor w => Cosieve (Cokleisli w) w where+ cosieve = runCokleisli+ {-# INLINE cosieve #-}++instance Cosieve Tagged Proxy where+ cosieve (Tagged a) _ = a+ {-# INLINE cosieve #-}++instance Functor f => Cosieve (Costar f) f where+ cosieve = runCostar+ {-# INLINE cosieve #-}
src/Data/Profunctor/Unsafe.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE Trustworthy #-}-#elif __GLASGOW_HASKELL__ >= 702+#else {-# LANGUAGE Unsafe #-} #endif {-# LANGUAGE ScopedTypeVariables #-}