contravariant 1.2.0.1 → 1.2.1
raw patch · 9 files changed
+603/−532 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.Functor.Contravariant: phantom :: (Functor f, Contravariant f) => f a -> f b
Files
- CHANGELOG.markdown +7/−0
- Data/Functor/Contravariant.hs +0/−289
- Data/Functor/Contravariant/Compose.hs +0/−60
- Data/Functor/Contravariant/Divisible.hs +0/−179
- LICENSE +1/−1
- contravariant.cabal +14/−3
- src/Data/Functor/Contravariant.hs +342/−0
- src/Data/Functor/Contravariant/Compose.hs +60/−0
- src/Data/Functor/Contravariant/Divisible.hs +179/−0
CHANGELOG.markdown view
@@ -1,3 +1,10 @@+1.2.1+-----+* Added `phantom` to `Data.Functor.Contravariant`. This combinator was formerly called `coerce` in the `lens` package, but+ GHC 7.8 added a `coerce` method to base with a different meaning.+* Added an unsupported `-f-semigroups` build flag that disables support for the `semigroups` package.+* Minor documentation improvements.+ 1.2.0.1 ----- * Fix build on GHC 7.0.4
− Data/Functor/Contravariant.hs
@@ -1,289 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators #-}--#ifdef __GLASGOW_HASKELL__-#define LANGUAGE_DeriveDataTypeable-{-# LANGUAGE DeriveDataTypeable #-}-#endif--#ifndef MIN_VERSION_tagged-#define MIN_VERSION_tagged(x,y,z) 1-#endif--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-#if MIN_VERSION_transformers(0,3,0) && MIN_VERSION_tagged(0,6,1)-{-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif-#endif---------------------------------------------------------------------------------- |--- Module : Data.Functor.Contravariant--- Copyright : (C) 2007-2014 Edward Kmett--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : provisional--- Portability : portable------ 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,--- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'--- the definition of 'Contravariant' for a given ADT is unambiguous.-------------------------------------------------------------------------------module Data.Functor.Contravariant (- -- * Contravariant Functors- Contravariant(..)-- -- * Operators- , (>$<), (>$$<)-- -- * Predicates- , Predicate(..)-- -- * Comparisons- , Comparison(..)- , defaultComparison-- -- * Equivalence Relations- , Equivalence(..)- , defaultEquivalence- , comparisonEquivalence-- -- * Dual arrows- , Op(..)- ) where--import Control.Applicative-import Control.Applicative.Backwards--import Control.Category--import Data.Functor.Product-import Data.Functor.Sum-import Data.Functor.Constant-import Data.Functor.Compose-import Data.Functor.Reverse--import Data.Semigroup (Semigroup(..), Monoid(..))--#ifdef LANGUAGE_DeriveDataTypeable-import Data.Typeable-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 && defined(VERSION_tagged)-import Data.Proxy-#endif--#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-#define GHC_GENERICS-import GHC.Generics-#endif--import Prelude hiding ((.),id)---- | Any instance should be subject to the following laws:------ > contramap id = id--- > contramap f . contramap g = contramap (g . f)------ Note, that the second law follows from the free theorem of the type of--- 'contramap' and the first law, so you need only check that the former--- condition holds.--class Contravariant f where- contramap :: (a -> b) -> f b -> f a-- -- | Replace all locations in the output with the same value.- -- The default definition is @'contramap' . 'const'@, but this may be- -- overridden with a more efficient version.- (>$) :: b -> f b -> f a- (>$) = contramap . const--infixl 4 >$, >$<, >$$<--(>$<) :: Contravariant f => (a -> b) -> f b -> f a-(>$<) = contramap-{-# INLINE (>$<) #-}--(>$$<) :: Contravariant f => f b -> (a -> b) -> f a-(>$$<) = flip contramap-{-# INLINE (>$$<) #-}--#ifdef GHC_GENERICS-instance Contravariant V1 where- contramap _ x = x `seq` undefined--instance Contravariant U1 where- contramap _ U1 = U1--instance Contravariant f => Contravariant (Rec1 f) where- contramap f (Rec1 fp)= Rec1 (contramap f fp)--instance Contravariant f => Contravariant (M1 i c f) where- contramap f (M1 fp) = M1 (contramap f fp)--instance Contravariant (K1 i c) where- contramap _ (K1 c) = K1 c--instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where- contramap f (xs :*: ys) = contramap f xs :*: contramap f ys--instance (Functor f, Contravariant g) => Contravariant (f :.: g) where- contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)- {-# INLINE contramap #-}--instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where- contramap f (L1 xs) = L1 (contramap f xs)- contramap f (R1 ys) = R1 (contramap f ys)-#endif--instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where- contramap f (InL xs) = InL (contramap f xs)- contramap f (InR ys) = InR (contramap f ys)--instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where- contramap f (Pair a b) = Pair (contramap f a) (contramap f b)--instance Contravariant (Constant a) where- contramap _ (Constant a) = Constant a--instance Contravariant (Const a) where- contramap _ (Const a) = Const a--instance (Functor f, Contravariant g) => Contravariant (Compose f g) where- contramap f (Compose fga) = Compose (fmap (contramap f) fga)- {-# INLINE contramap #-}--instance Contravariant f => Contravariant (Backwards f) where- contramap f = Backwards . contramap f . forwards- {-# INLINE contramap #-}--instance Contravariant f => Contravariant (Reverse f) where- contramap f = Reverse . contramap f . getReverse- {-# INLINE contramap #-}--#if (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707) || defined(VERSION_tagged)-instance Contravariant Proxy where- contramap _ Proxy = Proxy-#endif--newtype Predicate a = Predicate { getPredicate :: a -> Bool }-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif---- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can--- apply its function argument to the input of the predicate.-instance Contravariant Predicate where- contramap f g = Predicate $ getPredicate g . f---- | Defines a total ordering on a type as per 'compare'-newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif---- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can--- apply its function argument to each input to each input to the--- comparison function.-instance Contravariant Comparison where- contramap f g = Comparison $ \a b -> getComparison g (f a) (f b)--instance Semigroup (Comparison a) where- Comparison p <> Comparison q = Comparison $ mappend p q--instance Monoid (Comparison a) where- mempty = Comparison (\_ _ -> EQ)- mappend (Comparison p) (Comparison q) = Comparison $ mappend p q---- | Compare using 'compare'-defaultComparison :: Ord a => Comparison a-defaultComparison = Comparison compare---- | Define an equivalence relation-newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif---- | Equivalence relations are 'Contravariant', because you can--- apply the contramapped function to each input to the equivalence--- relation.-instance Contravariant Equivalence where- contramap f g = Equivalence $ \a b -> getEquivalence g (f a) (f b)--instance Semigroup (Equivalence a) where- Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b--instance Monoid (Equivalence a) where- mempty = Equivalence (\_ _ -> True)- mappend (Equivalence p) (Equivalence q) = Equivalence $ \a b -> p a b && q a b---- | Check for equivalence with '=='-defaultEquivalence :: Eq a => Equivalence a-defaultEquivalence = Equivalence (==)--comparisonEquivalence :: Comparison a -> Equivalence a-comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ---- | Dual function arrows.-newtype Op a b = Op { getOp :: b -> a }-#ifdef LANGUAGE_DeriveDataTypeable- deriving Typeable-#endif--instance Category Op where- id = Op id- Op f . Op g = Op (g . f)--instance Contravariant (Op a) where- contramap f g = Op (getOp g . f)--instance Semigroup a => Semigroup (Op a b) where- Op p <> Op q = Op $ \a -> p a <> q a--instance Monoid a => Monoid (Op a b) where- mempty = Op (const mempty)- mappend (Op p) (Op q) = Op $ \a -> mappend (p a) (q a)--#if MIN_VERSION_base(4,5,0)-instance Num a => Num (Op a b) where- Op f + Op g = Op $ \a -> f a + g a- Op f * Op g = Op $ \a -> f a * g a- Op f - Op g = Op $ \a -> f a - g a- abs (Op f) = Op $ abs . f- signum (Op f) = Op $ signum . f- fromInteger = Op . const . fromInteger--instance Fractional a => Fractional (Op a b) where- Op f / Op g = Op $ \a -> f a / g a- recip (Op f) = Op $ recip . f- fromRational = Op . const . fromRational--instance Floating a => Floating (Op a b) where- pi = Op $ const pi- exp (Op f) = Op $ exp . f- sqrt (Op f) = Op $ sqrt . f- log (Op f) = Op $ log . f- sin (Op f) = Op $ sin . f- tan (Op f) = Op $ tan . f- cos (Op f) = Op $ cos . f- asin (Op f) = Op $ asin . f- atan (Op f) = Op $ atan . f- acos (Op f) = Op $ acos . f- sinh (Op f) = Op $ sinh . f- tanh (Op f) = Op $ tanh . f- cosh (Op f) = Op $ cosh . f- asinh (Op f) = Op $ asinh . f- atanh (Op f) = Op $ atanh . f- acosh (Op f) = Op $ acosh . f- Op f ** Op g = Op $ \a -> f a ** g a- logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a)-#endif
− Data/Functor/Contravariant/Compose.hs
@@ -1,60 +0,0 @@--- |--- Module : Data.Functor.Contravariant.Compose--- Copyright : (c) Edward Kmett 2010--- License : BSD3------ Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : portable------ Composition of contravariant functors.--module Data.Functor.Contravariant.Compose- ( Compose(..)- , ComposeFC(..)- , ComposeCF(..)- ) where--import Control.Arrow-import Control.Applicative-import Data.Functor.Contravariant-import Data.Functor.Contravariant.Divisible---- | Composition of two contravariant functors-newtype Compose f g a = Compose { getCompose :: f (g a) }--instance (Contravariant f, Contravariant g) => Functor (Compose f g) where- fmap f (Compose x) = Compose (contramap (contramap f) x)---- | Composition of covariant and contravariant functors-newtype ComposeFC f g a = ComposeFC { getComposeFC :: f (g a) }--instance (Functor f, Contravariant g) => Contravariant (ComposeFC f g) where- contramap f (ComposeFC x) = ComposeFC (fmap (contramap f) x)--instance (Functor f, Functor g) => Functor (ComposeFC f g) where- fmap f (ComposeFC x) = ComposeFC (fmap (fmap f) x)--instance (Applicative f, Divisible g) => Divisible (ComposeFC f g) where- conquer = ComposeFC $ pure conquer- divide abc (ComposeFC fb) (ComposeFC fc) = ComposeFC $ divide abc <$> fb <*> fc--instance (Applicative f, Decidable g) => Decidable (ComposeFC f g) where- lose f = ComposeFC $ pure (lose f)- choose abc (ComposeFC fb) (ComposeFC fc) = ComposeFC $ choose abc <$> fb <*> fc---- | Composition of contravariant and covariant functors-newtype ComposeCF f g a = ComposeCF { getComposeCF :: f (g a) }--instance (Contravariant f, Functor g) => Contravariant (ComposeCF f g) where- contramap f (ComposeCF x) = ComposeCF (contramap (fmap f) x)--instance (Functor f, Functor g) => Functor (ComposeCF f g) where- fmap f (ComposeCF x) = ComposeCF (fmap (fmap f) x)--instance (Divisible f, Applicative g) => Divisible (ComposeCF f g) where- conquer = ComposeCF conquer- divide abc (ComposeCF fb) (ComposeCF fc) = ComposeCF $ divide (funzip . fmap abc) fb fc--funzip :: Functor f => f (a, b) -> (f a, f b)-funzip = fmap fst &&& fmap snd
− Data/Functor/Contravariant/Divisible.hs
@@ -1,179 +0,0 @@-module Data.Functor.Contravariant.Divisible- (- -- * Contravariant Applicative- Divisible(..), divided, conquered, liftD- -- * Contravariant Alternative- , Decidable(..), chosen, lost- ) where--import Data.Functor.Contravariant-import Data.Monoid-import Data.Void------------------------------------------------------------------------------------- * Contravariant Applicative------------------------------------------------------------------------------------- |------ A 'Divisible' contravariant functor is the contravariant analogue of 'Applicative'.------ In denser jargon, a 'Divisible' contravariant functor is a monoid object in the category--- of presheaves from Hask to Hask, equipped with Day convolution mapping the Cartesian--- product of the source to the Cartesian product of the target.------ By way of contrast, an 'Applicative' functor can be viewed as a monoid object in the--- category of copresheaves from Hask to Hask, equipped with Day convolution mapping the--- Cartesian product of the source to the Cartesian product of the target.------ Given the canonical diagonal morphism:------ @--- delta a = (a,a)--- @--- --- @'divide' 'delta'@ should be associative with 'conquer' as a unit------ @--- 'divide' 'delta' m 'conquer' = m--- 'divide' 'delta' 'conquer' m = m--- 'divide' 'delta' ('divide' 'delta' m n) o = 'divide' 'delta' m ('divide' 'delta' n o)--- @------ With more general arguments you'll need to reassociate and project using the monoidal--- structure of the source category. (Here fst and snd are used in lieu of the more restricted--- lambda and rho, but this construction works with just a monoidal category.)------ @--- 'divide' f m 'conquer' = 'contramap' ('fst' . f) m--- 'divide' f 'conquer' m = 'contramap' ('snd' . f) m--- 'divide' f ('divide' g m n) o = 'divide' f' m ('divide' 'id' n o) where--- f' a = case f a of (bc,d) -> case g bc of (b,c) -> (a,(b,c))--- @-class Contravariant f => Divisible f where- divide :: (a -> (b, c)) -> f b -> f c -> f a- -- | The underlying theory would suggest that this should be:- --- -- @- -- conquer :: (a -> ()) -> f a- -- @- --- -- However, as we are working over a Cartesian category (Hask) and the Cartesian product, such an input- -- morphism is uniquely determined to be @'const' 'mempty'@, so we elide it.- conquer :: f a---- |--- @--- 'divided' = 'divide' 'id'--- @-divided :: Divisible f => f a -> f b -> f (a, b)-divided = divide id---- | Redundant, but provided for symmetry.------ @--- 'conquered' = 'conquer--- @-conquered :: Divisible f => f ()-conquered = conquer----- |--- This is the divisible analogue of 'liftA'. It gives a viable default definition for 'contramap' in terms--- of the members of 'Divisible'.------ @--- 'liftD' f = 'divide' ((,) () . f) 'conquer'--- @-liftD :: Divisible f => (a -> b) -> f b -> f a-liftD f = divide ((,) () . f) conquer- -instance Monoid r => Divisible (Op r) where- divide f (Op g) (Op h) = Op $ \a -> case f a of- (b, c) -> g b `mappend` h c- conquer = Op $ const mempty--instance Divisible Comparison where- divide f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of- (a',a'') -> case f b of- (b',b'') -> g a' b' `mappend` h a'' b''- conquer = Comparison $ \_ _ -> EQ--instance Divisible Equivalence where- divide f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of- (a',a'') -> case f b of- (b',b'') -> g a' b' && h a'' b''- conquer = Equivalence $ \_ _ -> True--instance Divisible Predicate where- divide f (Predicate g) (Predicate h) = Predicate $ \a -> case f a of- (b, c) -> g b && h c- conquer = Predicate $ const True------------------------------------------------------------------------------------- * Contravariant Alternative------------------------------------------------------------------------------------- |------ A 'Divisible' contravariant functor is a monoid object in the category of presheaves --- from Hask to Hask, equipped with Day convolution mapping the cartesian product of the--- source to the Cartesian product of the target.------ @--- 'choose' Left m ('lose' f) = m--- 'choose' Right ('lose' f) m = m--- 'choose' f ('choose' g m n) o = 'divide' f' m ('divide' 'id' n o) where--- f' bcd = 'either' ('either' 'id' ('Right' . 'Left') . g) ('Right' . 'Right') . f--- @------ In addition, we expect the same kind of distributive law as is satisfied by the usual--- covariant 'Alternative', w.r.t 'Applicative', which should be fully formulated and--- added here at some point!--class Divisible f => Decidable f where- -- | The only way to win is not to play.- lose :: (a -> Void) -> f a- choose :: (a -> Either b c) -> f b -> f c -> f a---- |--- @--- 'lost' = 'lose' 'id'--- @-lost :: Decidable f => f Void-lost = lose id---- |--- @--- 'chosen' = 'choose' 'id'--- @-chosen :: Decidable f => f b -> f c -> f (Either b c)-chosen = choose id--instance Decidable Comparison where- lose f = Comparison $ \a _ -> absurd (f a)- choose f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of- Left c -> case f b of- Left d -> g c d- Right{} -> LT- Right c -> case f b of- Left{} -> GT- Right d -> h c d--instance Decidable Equivalence where- lose f = Equivalence $ \a -> absurd (f a)- choose f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of- Left c -> case f b of- Left d -> g c d- Right{} -> False- Right c -> case f b of- Left{} -> False- Right d -> h c d--instance Decidable Predicate where- lose f = Predicate $ \a -> absurd (f a)- choose f (Predicate g) (Predicate h) = Predicate $ either g h . f--instance Monoid r => Decidable (Op r) where- lose f = Op $ absurd . f- choose f (Op g) (Op h) = Op $ either g h . f
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2007-2014 Edward Kmett+Copyright 2007-2015 Edward Kmett All rights reserved.
contravariant.cabal view
@@ -1,6 +1,6 @@ name: contravariant category: Control, Data-version: 1.2.0.1+version: 1.2.1 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE@@ -9,7 +9,7 @@ stability: provisional homepage: http://github.com/ekmett/contravariant/ bug-reports: http://github.com/ekmett/contravariant/issues-copyright: Copyright (C) 2007-2014 Edward A. Kmett+copyright: Copyright (C) 2007-2015 Edward A. Kmett synopsis: Contravariant functors description: Contravariant functors build-type: Simple@@ -29,16 +29,27 @@ default: True manual: True +flag semigroups+ description:+ You can disable the use of the `semigroups` package on older versons of GHC using `-f-semigroups`.+ .+ Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users.+ default: True+ manual: True+ library+ hs-source-dirs: src build-depends: base < 5,- semigroups >= 0.15.2 && < 1, transformers >= 0.2 && < 0.5, transformers-compat >= 0.3 && < 1, void >= 0.6 && < 1 if flag(tagged) && !impl(ghc >= 7.7) build-depends: tagged >= 0.4.4 && < 1++ if flag(semigroups)+ build-depends: semigroups >= 0.15.2 && < 1 if impl(ghc >= 7.4 && < 7.6) build-depends: ghc-prim
+ src/Data/Functor/Contravariant.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}++#ifdef __GLASGOW_HASKELL__+#define LANGUAGE_DeriveDataTypeable+{-# LANGUAGE DeriveDataTypeable #-}+#endif++#ifndef MIN_VERSION_tagged+#define MIN_VERSION_tagged(x,y,z) 1+#endif++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++#if __GLASGOW_HASKELL__ >= 702+#if MIN_VERSION_transformers(0,3,0) && MIN_VERSION_tagged(0,6,1)+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-}+#endif+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Contravariant+-- Copyright : (C) 2007-2015 Edward Kmett+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,+-- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'+-- the definition of 'Contravariant' for a given ADT is unambiguous.+----------------------------------------------------------------------------++module Data.Functor.Contravariant (+ -- * Contravariant Functors+ Contravariant(..)+ , phantom++ -- * Operators+ , (>$<), (>$$<)++ -- * Predicates+ , Predicate(..)++ -- * Comparisons+ , Comparison(..)+ , defaultComparison++ -- * Equivalence Relations+ , Equivalence(..)+ , defaultEquivalence+ , comparisonEquivalence++ -- * Dual arrows+ , Op(..)+ ) where++import Control.Applicative+import Control.Applicative.Backwards++import Control.Category++import Data.Functor.Product+import Data.Functor.Sum+import Data.Functor.Constant+import Data.Functor.Compose+import Data.Functor.Reverse++import Data.Monoid (Monoid(..))++#ifdef MIN_VERSION_semigroups+import Data.Semigroup (Semigroup(..))+#endif++#ifdef LANGUAGE_DeriveDataTypeable+import Data.Typeable+#endif++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 707 && defined(VERSION_tagged)+import Data.Proxy+#endif++import Data.Void++#if __GLASGOW_HASKELL__ >= 702+#define GHC_GENERICS+import GHC.Generics+#endif++import Prelude hiding ((.),id)++-- | Any instance should be subject to the following laws:+--+-- > contramap id = id+-- > contramap f . contramap g = contramap (g . f)+--+-- Note, that the second law follows from the free theorem of the type of+-- 'contramap' and the first law, so you need only check that the former+-- condition holds.++class Contravariant f where+ contramap :: (a -> b) -> f b -> f a++ -- | Replace all locations in the output with the same value.+ -- The default definition is @'contramap' . 'const'@, but this may be+ -- overridden with a more efficient version.+ (>$) :: b -> f b -> f a+ (>$) = contramap . const++-- | If 'f' is both 'Functor' and 'Contravariant' then by the time you factor in the laws+-- of each of those classes, it can't actually use it's argument in any meaningful capacity.+--+-- This method is surprisingly useful. Where both instances exist and are lawful we have+-- the following laws:+--+-- @+-- 'fmap' f ≡ 'phantom'+-- 'contramap' f ≡ 'phantom'+-- @+phantom :: (Functor f, Contravariant f) => f a -> f b+phantom x = absurd <$> contramap absurd x++infixl 4 >$, >$<, >$$<++-- | This is an infix alias for 'contramap'+(>$<) :: Contravariant f => (a -> b) -> f b -> f a+(>$<) = contramap+{-# INLINE (>$<) #-}++-- | This is an infix version of 'contramap' with the arguments flipped.+(>$$<) :: Contravariant f => f b -> (a -> b) -> f a+(>$$<) = flip contramap+{-# INLINE (>$$<) #-}++#ifdef GHC_GENERICS+instance Contravariant V1 where+ contramap _ x = x `seq` undefined++instance Contravariant U1 where+ contramap _ U1 = U1++instance Contravariant f => Contravariant (Rec1 f) where+ contramap f (Rec1 fp)= Rec1 (contramap f fp)++instance Contravariant f => Contravariant (M1 i c f) where+ contramap f (M1 fp) = M1 (contramap f fp)++instance Contravariant (K1 i c) where+ contramap _ (K1 c) = K1 c++instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where+ contramap f (xs :*: ys) = contramap f xs :*: contramap f ys++instance (Functor f, Contravariant g) => Contravariant (f :.: g) where+ contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)+ {-# INLINE contramap #-}++instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where+ contramap f (L1 xs) = L1 (contramap f xs)+ contramap f (R1 ys) = R1 (contramap f ys)+#endif++instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where+ contramap f (InL xs) = InL (contramap f xs)+ contramap f (InR ys) = InR (contramap f ys)++instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where+ contramap f (Pair a b) = Pair (contramap f a) (contramap f b)++instance Contravariant (Constant a) where+ contramap _ (Constant a) = Constant a++instance Contravariant (Const a) where+ contramap _ (Const a) = Const a++instance (Functor f, Contravariant g) => Contravariant (Compose f g) where+ contramap f (Compose fga) = Compose (fmap (contramap f) fga)+ {-# INLINE contramap #-}++instance Contravariant f => Contravariant (Backwards f) where+ contramap f = Backwards . contramap f . forwards+ {-# INLINE contramap #-}++instance Contravariant f => Contravariant (Reverse f) where+ contramap f = Reverse . contramap f . getReverse+ {-# INLINE contramap #-}++#if (__GLASGOW_HASKELL__ >= 707) || defined(VERSION_tagged)+instance Contravariant Proxy where+ contramap _ Proxy = Proxy+#endif++newtype Predicate a = Predicate { getPredicate :: a -> Bool }+#ifdef LANGUAGE_DeriveDataTypeable+ deriving Typeable+#endif++-- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can+-- apply its function argument to the input of the predicate.+instance Contravariant Predicate where+ contramap f g = Predicate $ getPredicate g . f++-- | Defines a total ordering on a type as per 'compare'+--+-- This condition is not checked by the types. You must ensure that the supplied+-- values are valid total orderings yourself.+newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }+#ifdef LANGUAGE_DeriveDataTypeable+ deriving Typeable+#endif++-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can+-- apply its function argument to each input to each input to the+-- comparison function.+instance Contravariant Comparison where+ contramap f g = Comparison $ \a b -> getComparison g (f a) (f b)++#ifdef MIN_VERSION_semigroups+instance Semigroup (Comparison a) where+ Comparison p <> Comparison q = Comparison $ mappend p q+#endif++instance Monoid (Comparison a) where+ mempty = Comparison (\_ _ -> EQ)+ mappend (Comparison p) (Comparison q) = Comparison $ mappend p q++-- | Compare using 'compare'+defaultComparison :: Ord a => Comparison a+defaultComparison = Comparison compare++-- | This data type represents an equivalence relation.+--+-- Equivalence relations are expected to satisfy three laws:+--+-- __Reflexivity__:+--+-- @+-- 'getEquivalence' f a a = True+-- @+--+-- __Symmetry__:+-- +-- @+-- 'getEquivalence' f a b = 'getEquivalence' f b a+-- @+--+-- __Transitivity__:+--+-- If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True' then so is @'getEquivalence' f a c@+--+-- The types alone do not enforce these laws, so you'll have to check them yourself.+newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }+#ifdef LANGUAGE_DeriveDataTypeable+ deriving Typeable+#endif++-- | Equivalence relations are 'Contravariant', because you can+-- apply the contramapped function to each input to the equivalence+-- relation.+instance Contravariant Equivalence where+ contramap f g = Equivalence $ \a b -> getEquivalence g (f a) (f b)++#ifdef MIN_VERSION_semigroups+instance Semigroup (Equivalence a) where+ Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b+#endif++instance Monoid (Equivalence a) where+ mempty = Equivalence (\_ _ -> True)+ mappend (Equivalence p) (Equivalence q) = Equivalence $ \a b -> p a b && q a b++-- | Check for equivalence with '=='+--+-- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@.+defaultEquivalence :: Eq a => Equivalence a+defaultEquivalence = Equivalence (==)++comparisonEquivalence :: Comparison a -> Equivalence a+comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ++-- | Dual function arrows.+newtype Op a b = Op { getOp :: b -> a }+#ifdef LANGUAGE_DeriveDataTypeable+ deriving Typeable+#endif++instance Category Op where+ id = Op id+ Op f . Op g = Op (g . f)++instance Contravariant (Op a) where+ contramap f g = Op (getOp g . f)++#ifdef MIN_VERSION_semigroups+instance Semigroup a => Semigroup (Op a b) where+ Op p <> Op q = Op $ \a -> p a <> q a+#endif++instance Monoid a => Monoid (Op a b) where+ mempty = Op (const mempty)+ mappend (Op p) (Op q) = Op $ \a -> mappend (p a) (q a)++#if MIN_VERSION_base(4,5,0)+instance Num a => Num (Op a b) where+ Op f + Op g = Op $ \a -> f a + g a+ Op f * Op g = Op $ \a -> f a * g a+ Op f - Op g = Op $ \a -> f a - g a+ abs (Op f) = Op $ abs . f+ signum (Op f) = Op $ signum . f+ fromInteger = Op . const . fromInteger++instance Fractional a => Fractional (Op a b) where+ Op f / Op g = Op $ \a -> f a / g a+ recip (Op f) = Op $ recip . f+ fromRational = Op . const . fromRational++instance Floating a => Floating (Op a b) where+ pi = Op $ const pi+ exp (Op f) = Op $ exp . f+ sqrt (Op f) = Op $ sqrt . f+ log (Op f) = Op $ log . f+ sin (Op f) = Op $ sin . f+ tan (Op f) = Op $ tan . f+ cos (Op f) = Op $ cos . f+ asin (Op f) = Op $ asin . f+ atan (Op f) = Op $ atan . f+ acos (Op f) = Op $ acos . f+ sinh (Op f) = Op $ sinh . f+ tanh (Op f) = Op $ tanh . f+ cosh (Op f) = Op $ cosh . f+ asinh (Op f) = Op $ asinh . f+ atanh (Op f) = Op $ atanh . f+ acosh (Op f) = Op $ acosh . f+ Op f ** Op g = Op $ \a -> f a ** g a+ logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a)+#endif
+ src/Data/Functor/Contravariant/Compose.hs view
@@ -0,0 +1,60 @@+-- |+-- Module : Data.Functor.Contravariant.Compose+-- Copyright : (c) Edward Kmett 2010+-- License : BSD3+--+-- Maintainer : ekmett@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- Composition of contravariant functors.++module Data.Functor.Contravariant.Compose+ ( Compose(..)+ , ComposeFC(..)+ , ComposeCF(..)+ ) where++import Control.Arrow+import Control.Applicative+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible++-- | Composition of two contravariant functors+newtype Compose f g a = Compose { getCompose :: f (g a) }++instance (Contravariant f, Contravariant g) => Functor (Compose f g) where+ fmap f (Compose x) = Compose (contramap (contramap f) x)++-- | Composition of covariant and contravariant functors+newtype ComposeFC f g a = ComposeFC { getComposeFC :: f (g a) }++instance (Functor f, Contravariant g) => Contravariant (ComposeFC f g) where+ contramap f (ComposeFC x) = ComposeFC (fmap (contramap f) x)++instance (Functor f, Functor g) => Functor (ComposeFC f g) where+ fmap f (ComposeFC x) = ComposeFC (fmap (fmap f) x)++instance (Applicative f, Divisible g) => Divisible (ComposeFC f g) where+ conquer = ComposeFC $ pure conquer+ divide abc (ComposeFC fb) (ComposeFC fc) = ComposeFC $ divide abc <$> fb <*> fc++instance (Applicative f, Decidable g) => Decidable (ComposeFC f g) where+ lose f = ComposeFC $ pure (lose f)+ choose abc (ComposeFC fb) (ComposeFC fc) = ComposeFC $ choose abc <$> fb <*> fc++-- | Composition of contravariant and covariant functors+newtype ComposeCF f g a = ComposeCF { getComposeCF :: f (g a) }++instance (Contravariant f, Functor g) => Contravariant (ComposeCF f g) where+ contramap f (ComposeCF x) = ComposeCF (contramap (fmap f) x)++instance (Functor f, Functor g) => Functor (ComposeCF f g) where+ fmap f (ComposeCF x) = ComposeCF (fmap (fmap f) x)++instance (Divisible f, Applicative g) => Divisible (ComposeCF f g) where+ conquer = ComposeCF conquer+ divide abc (ComposeCF fb) (ComposeCF fc) = ComposeCF $ divide (funzip . fmap abc) fb fc++funzip :: Functor f => f (a, b) -> (f a, f b)+funzip = fmap fst &&& fmap snd
+ src/Data/Functor/Contravariant/Divisible.hs view
@@ -0,0 +1,179 @@+module Data.Functor.Contravariant.Divisible+ (+ -- * Contravariant Applicative+ Divisible(..), divided, conquered, liftD+ -- * Contravariant Alternative+ , Decidable(..), chosen, lost+ ) where++import Data.Functor.Contravariant+import Data.Monoid+import Data.Void++--------------------------------------------------------------------------------+-- * Contravariant Applicative+--------------------------------------------------------------------------------++-- |+--+-- A 'Divisible' contravariant functor is the contravariant analogue of 'Applicative'.+--+-- In denser jargon, a 'Divisible' contravariant functor is a monoid object in the category+-- of presheaves from Hask to Hask, equipped with Day convolution mapping the Cartesian+-- product of the source to the Cartesian product of the target.+--+-- By way of contrast, an 'Applicative' functor can be viewed as a monoid object in the+-- category of copresheaves from Hask to Hask, equipped with Day convolution mapping the+-- Cartesian product of the source to the Cartesian product of the target.+--+-- Given the canonical diagonal morphism:+--+-- @+-- delta a = (a,a)+-- @+-- +-- @'divide' 'delta'@ should be associative with 'conquer' as a unit+--+-- @+-- 'divide' 'delta' m 'conquer' = m+-- 'divide' 'delta' 'conquer' m = m+-- 'divide' 'delta' ('divide' 'delta' m n) o = 'divide' 'delta' m ('divide' 'delta' n o)+-- @+--+-- With more general arguments you'll need to reassociate and project using the monoidal+-- structure of the source category. (Here fst and snd are used in lieu of the more restricted+-- lambda and rho, but this construction works with just a monoidal category.)+--+-- @+-- 'divide' f m 'conquer' = 'contramap' ('fst' . f) m+-- 'divide' f 'conquer' m = 'contramap' ('snd' . f) m+-- 'divide' f ('divide' g m n) o = 'divide' f' m ('divide' 'id' n o) where+-- f' a = case f a of (bc,d) -> case g bc of (b,c) -> (a,(b,c))+-- @+class Contravariant f => Divisible f where+ divide :: (a -> (b, c)) -> f b -> f c -> f a+ -- | The underlying theory would suggest that this should be:+ --+ -- @+ -- conquer :: (a -> ()) -> f a+ -- @+ --+ -- However, as we are working over a Cartesian category (Hask) and the Cartesian product, such an input+ -- morphism is uniquely determined to be @'const' 'mempty'@, so we elide it.+ conquer :: f a++-- |+-- @+-- 'divided' = 'divide' 'id'+-- @+divided :: Divisible f => f a -> f b -> f (a, b)+divided = divide id++-- | Redundant, but provided for symmetry.+--+-- @+-- 'conquered' = 'conquer+-- @+conquered :: Divisible f => f ()+conquered = conquer+++-- |+-- This is the divisible analogue of 'liftA'. It gives a viable default definition for 'contramap' in terms+-- of the members of 'Divisible'.+--+-- @+-- 'liftD' f = 'divide' ((,) () . f) 'conquer'+-- @+liftD :: Divisible f => (a -> b) -> f b -> f a+liftD f = divide ((,) () . f) conquer+ +instance Monoid r => Divisible (Op r) where+ divide f (Op g) (Op h) = Op $ \a -> case f a of+ (b, c) -> g b `mappend` h c+ conquer = Op $ const mempty++instance Divisible Comparison where+ divide f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of+ (a',a'') -> case f b of+ (b',b'') -> g a' b' `mappend` h a'' b''+ conquer = Comparison $ \_ _ -> EQ++instance Divisible Equivalence where+ divide f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of+ (a',a'') -> case f b of+ (b',b'') -> g a' b' && h a'' b''+ conquer = Equivalence $ \_ _ -> True++instance Divisible Predicate where+ divide f (Predicate g) (Predicate h) = Predicate $ \a -> case f a of+ (b, c) -> g b && h c+ conquer = Predicate $ const True++--------------------------------------------------------------------------------+-- * Contravariant Alternative+--------------------------------------------------------------------------------++-- |+--+-- A 'Divisible' contravariant functor is a monoid object in the category of presheaves +-- from Hask to Hask, equipped with Day convolution mapping the cartesian product of the+-- source to the Cartesian product of the target.+--+-- @+-- 'choose' Left m ('lose' f) = m+-- 'choose' Right ('lose' f) m = m+-- 'choose' f ('choose' g m n) o = 'divide' f' m ('divide' 'id' n o) where+-- f' bcd = 'either' ('either' 'id' ('Right' . 'Left') . g) ('Right' . 'Right') . f+-- @+--+-- In addition, we expect the same kind of distributive law as is satisfied by the usual+-- covariant 'Alternative', w.r.t 'Applicative', which should be fully formulated and+-- added here at some point!++class Divisible f => Decidable f where+ -- | The only way to win is not to play.+ lose :: (a -> Void) -> f a+ choose :: (a -> Either b c) -> f b -> f c -> f a++-- |+-- @+-- 'lost' = 'lose' 'id'+-- @+lost :: Decidable f => f Void+lost = lose id++-- |+-- @+-- 'chosen' = 'choose' 'id'+-- @+chosen :: Decidable f => f b -> f c -> f (Either b c)+chosen = choose id++instance Decidable Comparison where+ lose f = Comparison $ \a _ -> absurd (f a)+ choose f (Comparison g) (Comparison h) = Comparison $ \a b -> case f a of+ Left c -> case f b of+ Left d -> g c d+ Right{} -> LT+ Right c -> case f b of+ Left{} -> GT+ Right d -> h c d++instance Decidable Equivalence where+ lose f = Equivalence $ \a -> absurd (f a)+ choose f (Equivalence g) (Equivalence h) = Equivalence $ \a b -> case f a of+ Left c -> case f b of+ Left d -> g c d+ Right{} -> False+ Right c -> case f b of+ Left{} -> False+ Right d -> h c d++instance Decidable Predicate where+ lose f = Predicate $ \a -> absurd (f a)+ choose f (Predicate g) (Predicate h) = Predicate $ either g h . f++instance Monoid r => Decidable (Op r) where+ lose f = Op $ absurd . f+ choose f (Op g) (Op h) = Op $ either g h . f