ea0898c642a190316d9f1c1260560a9fb623f7ed
[darcs-mirrors/transformers.git] / Data / Functor / Product.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__ >= 702
3 {-# LANGUAGE Safe #-}
4 #endif
5 #if __GLASGOW_HASKELL__ >= 704
6 {-# LANGUAGE PolyKinds #-}
7 #endif
8 #if __GLASGOW_HASKELL__ >= 710
9 {-# LANGUAGE AutoDeriveTypeable #-}
10 #endif
11 -----------------------------------------------------------------------------
12 -- |
13 -- Module : Data.Functor.Product
14 -- Copyright : (c) Ross Paterson 2010
15 -- License : BSD-style (see the file LICENSE)
16 --
17 -- Maintainer : R.Paterson@city.ac.uk
18 -- Stability : experimental
19 -- Portability : portable
20 --
21 -- Products, lifted to functors.
22 -----------------------------------------------------------------------------
23
24 module Data.Functor.Product (
25 Product(..),
26 ) where
27
28 import Control.Applicative
29 import Control.Monad (MonadPlus(..))
30 import Control.Monad.Fix (MonadFix(..))
31 #if MIN_VERSION_base(4,4,0)
32 import Control.Monad.Zip (MonadZip(mzipWith))
33 #endif
34 import Data.Foldable (Foldable(foldMap))
35 import Data.Functor.Classes
36 import Data.Monoid (mappend)
37 import Data.Traversable (Traversable(traverse))
38
39 -- | Lifted product of functors.
40 data Product f g a = Pair (f a) (g a)
41
42 instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where
43 liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2
44
45 instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where
46 liftCompare comp (Pair x1 y1) (Pair x2 y2) =
47 liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2
48
49 instance (Read1 f, Read1 g) => Read1 (Product f g) where
50 liftReadsPrec rp rl = readsData $
51 readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair
52
53 instance (Show1 f, Show1 g) => Show1 (Product f g) where
54 liftShowsPrec sp sl d (Pair x y) =
55 showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y
56
57 instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)
58 where (==) = eq1
59 instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where
60 compare = compare1
61 instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where
62 readsPrec = readsPrec1
63 instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where
64 showsPrec = showsPrec1
65
66 instance (Functor f, Functor g) => Functor (Product f g) where
67 fmap f (Pair x y) = Pair (fmap f x) (fmap f y)
68
69 instance (Foldable f, Foldable g) => Foldable (Product f g) where
70 foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y
71
72 instance (Traversable f, Traversable g) => Traversable (Product f g) where
73 traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y
74
75 instance (Applicative f, Applicative g) => Applicative (Product f g) where
76 pure x = Pair (pure x) (pure x)
77 Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y)
78
79 instance (Alternative f, Alternative g) => Alternative (Product f g) where
80 empty = Pair empty empty
81 Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2)
82
83 instance (Monad f, Monad g) => Monad (Product f g) where
84 #if !(MIN_VERSION_base(4,8,0))
85 return x = Pair (return x) (return x)
86 #endif
87 Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f)
88 where
89 fstP (Pair a _) = a
90 sndP (Pair _ b) = b
91
92 instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where
93 mzero = Pair mzero mzero
94 Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2)
95
96 instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where
97 mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f))
98 where
99 fstP (Pair a _) = a
100 sndP (Pair _ b) = b
101
102 #if MIN_VERSION_base(4,4,0)
103 instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where
104 mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2)
105 #endif