1{-# LANGUAGE EmptyCase #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE StandaloneDeriving #-}
4{-# LANGUAGE Trustworthy #-}
5{-# LANGUAGE TypeOperators #-}
6
7-----------------------------------------------------------------------------
8-- |
9-- Module      :  Data.Functor.Contravariant
10-- Copyright   :  (C) 2007-2015 Edward Kmett
11-- License     :  BSD-style (see the file LICENSE)
12--
13-- Maintainer  :  libraries@haskell.org
14-- Stability   :  provisional
15-- Portability :  portable
16--
17-- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,
18-- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'
19-- the definition of 'Contravariant' for a given ADT is unambiguous.
20--
21-- @since 4.12.0.0
22----------------------------------------------------------------------------
23
24module Data.Functor.Contravariant (
25  -- * Contravariant Functors
26    Contravariant(..)
27  , phantom
28
29  -- * Operators
30  , (>$<), (>$$<), ($<)
31
32  -- * Predicates
33  , Predicate(..)
34
35  -- * Comparisons
36  , Comparison(..)
37  , defaultComparison
38
39  -- * Equivalence Relations
40  , Equivalence(..)
41  , defaultEquivalence
42  , comparisonEquivalence
43
44  -- * Dual arrows
45  , Op(..)
46  ) where
47
48import Control.Applicative
49import Control.Category
50import Data.Function (on)
51
52import Data.Functor.Product
53import Data.Functor.Sum
54import Data.Functor.Compose
55
56import Data.Monoid (Alt(..))
57import Data.Proxy
58import GHC.Generics
59
60import Prelude hiding ((.),id)
61
62-- | The class of contravariant functors.
63--
64-- Whereas in Haskell, one can think of a 'Functor' as containing or producing
65-- values, a contravariant functor is a functor that can be thought of as
66-- /consuming/ values.
67--
68-- As an example, consider the type of predicate functions  @a -> Bool@. One
69-- such predicate might be @negative x = x < 0@, which
70-- classifies integers as to whether they are negative. However, given this
71-- predicate, we can re-use it in other situations, providing we have a way to
72-- map values /to/ integers. For instance, we can use the @negative@ predicate
73-- on a person's bank balance to work out if they are currently overdrawn:
74--
75-- @
76-- newtype Predicate a = Predicate { getPredicate :: a -> Bool }
77--
78-- instance Contravariant Predicate where
79--   contramap f (Predicate p) = Predicate (p . f)
80--                                          |   `- First, map the input...
81--                                          `----- then apply the predicate.
82--
83-- overdrawn :: Predicate Person
84-- overdrawn = contramap personBankBalance negative
85-- @
86--
87-- Any instance should be subject to the following laws:
88--
89-- [Identity]    @'contramap' 'id' = 'id'@
90-- [Composition] @'contramap' (g . f) = 'contramap' f . 'contramap' g@
91--
92-- Note, that the second law follows from the free theorem of the type of
93-- 'contramap' and the first law, so you need only check that the former
94-- condition holds.
95
96class Contravariant f where
97  contramap :: (a -> b) -> f b -> f a
98
99  -- | Replace all locations in the output with the same value.
100  -- The default definition is @'contramap' . 'const'@, but this may be
101  -- overridden with a more efficient version.
102  (>$) :: b -> f b -> f a
103  (>$) = contramap . const
104
105-- | If @f@ is both 'Functor' and 'Contravariant' then by the time you factor
106-- in the laws of each of those classes, it can't actually use its argument in
107-- any meaningful capacity.
108--
109-- This method is surprisingly useful. Where both instances exist and are
110-- lawful we have the following laws:
111--
112-- @
113-- 'fmap' f ≡ 'phantom'
114-- 'contramap' f ≡ 'phantom'
115-- @
116phantom :: (Functor f, Contravariant f) => f a -> f b
117phantom x = () <$ x $< ()
118
119infixl 4 >$, $<, >$<, >$$<
120
121-- | This is '>$' with its arguments flipped.
122($<) :: Contravariant f => f b -> b -> f a
123($<) = flip (>$)
124
125-- | This is an infix alias for 'contramap'.
126(>$<) :: Contravariant f => (a -> b) -> f b -> f a
127(>$<) = contramap
128
129-- | This is an infix version of 'contramap' with the arguments flipped.
130(>$$<) :: Contravariant f => f b -> (a -> b) -> f a
131(>$$<) = flip contramap
132
133deriving instance Contravariant f => Contravariant (Alt f)
134deriving instance Contravariant f => Contravariant (Rec1 f)
135deriving instance Contravariant f => Contravariant (M1 i c f)
136
137instance Contravariant V1 where
138  contramap _ x = case x of
139
140instance Contravariant U1 where
141  contramap _ _ = U1
142
143instance Contravariant (K1 i c) where
144  contramap _ (K1 c) = K1 c
145
146instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where
147  contramap f (xs :*: ys) = contramap f xs :*: contramap f ys
148
149instance (Functor f, Contravariant g) => Contravariant (f :.: g) where
150  contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)
151
152instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where
153  contramap f (L1 xs) = L1 (contramap f xs)
154  contramap f (R1 ys) = R1 (contramap f ys)
155
156instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where
157  contramap f (InL xs) = InL (contramap f xs)
158  contramap f (InR ys) = InR (contramap f ys)
159
160instance (Contravariant f, Contravariant g)
161  => Contravariant (Product f g) where
162    contramap f (Pair a b) = Pair (contramap f a) (contramap f b)
163
164instance Contravariant (Const a) where
165  contramap _ (Const a) = Const a
166
167instance (Functor f, Contravariant g) => Contravariant (Compose f g) where
168  contramap f (Compose fga) = Compose (fmap (contramap f) fga)
169
170instance Contravariant Proxy where
171  contramap _ _ = Proxy
172
173newtype Predicate a = Predicate { getPredicate :: a -> Bool }
174
175-- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can
176-- apply its function argument to the input of the predicate.
177instance Contravariant Predicate where
178  contramap f g = Predicate $ getPredicate g . f
179
180instance Semigroup (Predicate a) where
181  Predicate p <> Predicate q = Predicate $ \a -> p a && q a
182
183instance Monoid (Predicate a) where
184  mempty = Predicate $ const True
185
186-- | Defines a total ordering on a type as per 'compare'.
187--
188-- This condition is not checked by the types. You must ensure that the
189-- supplied values are valid total orderings yourself.
190newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }
191
192deriving instance Semigroup (Comparison a)
193deriving instance Monoid (Comparison a)
194
195-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can
196-- apply its function argument to each input of the comparison function.
197instance Contravariant Comparison where
198  contramap f g = Comparison $ on (getComparison g) f
199
200-- | Compare using 'compare'.
201defaultComparison :: Ord a => Comparison a
202defaultComparison = Comparison compare
203
204-- | This data type represents an equivalence relation.
205--
206-- Equivalence relations are expected to satisfy three laws:
207--
208-- [Reflexivity]:  @'getEquivalence' f a a = True@
209-- [Symmetry]:     @'getEquivalence' f a b = 'getEquivalence' f b a@
210-- [Transitivity]:
211--    If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True'
212--    then so is @'getEquivalence' f a c@.
213--
214-- The types alone do not enforce these laws, so you'll have to check them
215-- yourself.
216newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }
217
218-- | Equivalence relations are 'Contravariant', because you can
219-- apply the contramapped function to each input to the equivalence
220-- relation.
221instance Contravariant Equivalence where
222  contramap f g = Equivalence $ on (getEquivalence g) f
223
224instance Semigroup (Equivalence a) where
225  Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b
226
227instance Monoid (Equivalence a) where
228  mempty = Equivalence (\_ _ -> True)
229
230-- | Check for equivalence with '=='.
231--
232-- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@.
233defaultEquivalence :: Eq a => Equivalence a
234defaultEquivalence = Equivalence (==)
235
236comparisonEquivalence :: Comparison a -> Equivalence a
237comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ
238
239-- | Dual function arrows.
240newtype Op a b = Op { getOp :: b -> a }
241
242deriving instance Semigroup a => Semigroup (Op a b)
243deriving instance Monoid a => Monoid (Op a b)
244
245instance Category Op where
246  id = Op id
247  Op f . Op g = Op (g . f)
248
249instance Contravariant (Op a) where
250  contramap f g = Op (getOp g . f)
251
252instance Num a => Num (Op a b) where
253  Op f + Op g = Op $ \a -> f a + g a
254  Op f * Op g = Op $ \a -> f a * g a
255  Op f - Op g = Op $ \a -> f a - g a
256  abs (Op f) = Op $ abs . f
257  signum (Op f) = Op $ signum . f
258  fromInteger = Op . const . fromInteger
259
260instance Fractional a => Fractional (Op a b) where
261  Op f / Op g = Op $ \a -> f a / g a
262  recip (Op f) = Op $ recip . f
263  fromRational = Op . const . fromRational
264
265instance Floating a => Floating (Op a b) where
266  pi = Op $ const pi
267  exp (Op f) = Op $ exp . f
268  sqrt (Op f) = Op $ sqrt . f
269  log (Op f) = Op $ log . f
270  sin (Op f) = Op $ sin . f
271  tan (Op f) = Op $ tan . f
272  cos (Op f) = Op $ cos . f
273  asin (Op f) = Op $ asin . f
274  atan (Op f) = Op $ atan . f
275  acos (Op f) = Op $ acos . f
276  sinh (Op f) = Op $ sinh . f
277  tanh (Op f) = Op $ tanh . f
278  cosh (Op f) = Op $ cosh . f
279  asinh (Op f) = Op $ asinh . f
280  atanh (Op f) = Op $ atanh . f
281  acosh (Op f) = Op $ acosh . f
282  Op f ** Op g = Op $ \a -> f a ** g a
283  logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a)
284