Conditionally expose Data.Functor.* modules
[darcs-mirrors/transformers.git] / legacy / pre711 / Data / Functor / Compose.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.Compose
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 -- Composition of functors.
31 -----------------------------------------------------------------------------
32
33 module Data.Functor.Compose (
34 Compose(..),
35 ) where
36
37 import Data.Functor.Classes
38
39 import Control.Applicative
40 #if __GLASGOW_HASKELL__ >= 708
41 import Data.Data
42 #endif
43 import Data.Foldable (Foldable(foldMap))
44 import Data.Traversable (Traversable(traverse))
45 #if __GLASGOW_HASKELL__ >= 702
46 import GHC.Generics
47 #endif
48
49 infixr 9 `Compose`
50
51 -- | Right-to-left composition of functors.
52 -- The composition of applicative functors is always applicative,
53 -- but the composition of monads is not always a monad.
54 newtype Compose f g a = Compose { getCompose :: f (g a) }
55
56 #if __GLASGOW_HASKELL__ >= 702
57 deriving instance Generic (Compose f g a)
58
59 instance Functor f => Generic1 (Compose f g) where
60 type Rep1 (Compose f g) =
61 D1 MDCompose
62 (C1 MCCompose
63 (S1 MSCompose (f :.: Rec1 g)))
64 from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x))))
65 to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x))
66
67 data MDCompose
68 data MCCompose
69 data MSCompose
70
71 instance Datatype MDCompose where
72 datatypeName _ = "Compose"
73 moduleName _ = "Data.Functor.Compose"
74 # if __GLASGOW_HASKELL__ >= 708
75 isNewtype _ = True
76 # endif
77
78 instance Constructor MCCompose where
79 conName _ = "Compose"
80 conIsRecord _ = True
81
82 instance Selector MSCompose where
83 selName _ = "getCompose"
84 #endif
85
86 #if __GLASGOW_HASKELL__ >= 708
87 deriving instance Typeable Compose
88 deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a)
89 => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *))
90 #endif
91
92 -- Instances of lifted Prelude classes
93
94 instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
95 liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y
96
97 instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
98 liftCompare comp (Compose x) (Compose y) =
99 liftCompare (liftCompare comp) x y
100
101 instance (Read1 f, Read1 g) => Read1 (Compose f g) where
102 liftReadsPrec rp rl = readsData $
103 readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose
104 where
105 rp' = liftReadsPrec rp rl
106 rl' = liftReadList rp rl
107
108 instance (Show1 f, Show1 g) => Show1 (Compose f g) where
109 liftShowsPrec sp sl d (Compose x) =
110 showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x
111 where
112 sp' = liftShowsPrec sp sl
113 sl' = liftShowList sp sl
114
115 -- Instances of Prelude classes
116
117 instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
118 (==) = eq1
119
120 instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
121 compare = compare1
122
123 instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where
124 readsPrec = readsPrec1
125
126 instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where
127 showsPrec = showsPrec1
128
129 -- Functor instances
130
131 instance (Functor f, Functor g) => Functor (Compose f g) where
132 fmap f (Compose x) = Compose (fmap (fmap f) x)
133
134 instance (Foldable f, Foldable g) => Foldable (Compose f g) where
135 foldMap f (Compose t) = foldMap (foldMap f) t
136
137 instance (Traversable f, Traversable g) => Traversable (Compose f g) where
138 traverse f (Compose t) = Compose <$> traverse (traverse f) t
139
140 instance (Applicative f, Applicative g) => Applicative (Compose f g) where
141 pure x = Compose (pure (pure x))
142 Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)
143
144 instance (Alternative f, Applicative g) => Alternative (Compose f g) where
145 empty = Compose empty
146 Compose x <|> Compose y = Compose (x <|> y)