Conditionally expose Data.Functor.* modules
[darcs-mirrors/transformers.git] / legacy / pre711 / Data / Functor / Product.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__ >= 702
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE EmptyDataDecls #-}
5 {-# LANGUAGE StandaloneDeriving #-}
6 {-# LANGUAGE Trustworthy #-}
7 {-# LANGUAGE TypeFamilies #-}
8 {-# LANGUAGE TypeOperators #-}
9 #endif
10 #if __GLASGOW_HASKELL__ >= 704
11 {-# LANGUAGE PolyKinds #-}
12 #endif
13 #if __GLASGOW_HASKELL__ >= 708
14 {-# LANGUAGE AutoDeriveTypeable #-}
15 {-# LANGUAGE DataKinds #-}
16 {-# LANGUAGE DeriveDataTypeable #-}
17 {-# LANGUAGE FlexibleContexts #-}
18 {-# LANGUAGE KindSignatures #-}
19 #endif
20 -----------------------------------------------------------------------------
21 -- |
22 -- Module : Data.Functor.Product
23 -- Copyright : (c) Ross Paterson 2010
24 -- License : BSD-style (see the file LICENSE)
25 --
26 -- Maintainer : R.Paterson@city.ac.uk
27 -- Stability : experimental
28 -- Portability : portable
29 --
30 -- Products, lifted to functors.
31 -----------------------------------------------------------------------------
32
33 module Data.Functor.Product (
34 Product(..),
35 ) where
36
37 import Control.Applicative
38 import Control.Monad (MonadPlus(..))
39 import Control.Monad.Fix (MonadFix(..))
40 #if MIN_VERSION_base(4,4,0)
41 import Control.Monad.Zip (MonadZip(mzipWith))
42 #endif
43 #if __GLASGOW_HASKELL__ >= 708
44 import Data.Data
45 #endif
46 import Data.Foldable (Foldable(foldMap))
47 import Data.Functor.Classes
48 import Data.Monoid (mappend)
49 import Data.Traversable (Traversable(traverse))
50 #if __GLASGOW_HASKELL__ >= 702
51 import GHC.Generics
52 #endif
53
54 -- | Lifted product of functors.
55 data Product f g a = Pair (f a) (g a)
56
57 #if __GLASGOW_HASKELL__ >= 702
58 deriving instance Generic (Product f g a)
59
60 instance Generic1 (Product f g) where
61 type Rep1 (Product f g) =
62 D1 MDProduct
63 (C1 MCPair
64 (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g)))
65 from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))
66 to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g)
67
68 data MDProduct
69 data MCPair
70
71 instance Datatype MDProduct where
72 datatypeName _ = "Product"
73 moduleName _ = "Data.Functor.Product"
74
75 instance Constructor MCPair where
76 conName _ = "Pair"
77 #endif
78
79 #if __GLASGOW_HASKELL__ >= 708
80 deriving instance Typeable Product
81 deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)
82 => Data (Product (f :: * -> *) (g :: * -> *) (a :: *))
83 #endif
84
85 instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where
86 liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2
87
88 instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where
89 liftCompare comp (Pair x1 y1) (Pair x2 y2) =
90 liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2
91
92 instance (Read1 f, Read1 g) => Read1 (Product f g) where
93 liftReadsPrec rp rl = readsData $
94 readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair
95
96 instance (Show1 f, Show1 g) => Show1 (Product f g) where
97 liftShowsPrec sp sl d (Pair x y) =
98 showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y
99
100 instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)
101 where (==) = eq1
102 instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where
103 compare = compare1
104 instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where
105 readsPrec = readsPrec1
106 instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where
107 showsPrec = showsPrec1
108
109 instance (Functor f, Functor g) => Functor (Product f g) where
110 fmap f (Pair x y) = Pair (fmap f x) (fmap f y)
111
112 instance (Foldable f, Foldable g) => Foldable (Product f g) where
113 foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y
114
115 instance (Traversable f, Traversable g) => Traversable (Product f g) where
116 traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y
117
118 instance (Applicative f, Applicative g) => Applicative (Product f g) where
119 pure x = Pair (pure x) (pure x)
120 Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y)
121
122 instance (Alternative f, Alternative g) => Alternative (Product f g) where
123 empty = Pair empty empty
124 Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2)
125
126 instance (Monad f, Monad g) => Monad (Product f g) where
127 #if !(MIN_VERSION_base(4,8,0))
128 return x = Pair (return x) (return x)
129 #endif
130 Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f)
131 where
132 fstP (Pair a _) = a
133 sndP (Pair _ b) = b
134
135 instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where
136 mzero = Pair mzero mzero
137 Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2)
138
139 instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where
140 mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f))
141 where
142 fstP (Pair a _) = a
143 sndP (Pair _ b) = b
144
145 #if MIN_VERSION_base(4,4,0)
146 instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where
147 mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2)
148 #endif