1b7785cecc55df793787d5d88a4dc090b2775b8e
[darcs-mirrors/transformers.git] / Data / Functor / Compose.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.Compose
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 -- Composition of functors.
22 -----------------------------------------------------------------------------
23
24 module Data.Functor.Compose (
25 Compose(..),
26 ) where
27
28 import Data.Functor.Classes
29
30 import Control.Applicative
31 import Data.Foldable (Foldable(foldMap))
32 import Data.Traversable (Traversable(traverse))
33
34 infixr 9 `Compose`
35
36 -- | Right-to-left composition of functors.
37 -- The composition of applicative functors is always applicative,
38 -- but the composition of monads is not always a monad.
39 newtype Compose f g a = Compose { getCompose :: f (g a) }
40
41 -- Instances of lifted Prelude classes
42
43 instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
44 liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y
45
46 instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
47 liftCompare comp (Compose x) (Compose y) =
48 liftCompare (liftCompare comp) x y
49
50 instance (Read1 f, Read1 g) => Read1 (Compose f g) where
51 liftReadsPrec rp rl = readsData $
52 readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose
53 where
54 rp' = liftReadsPrec rp rl
55 rl' = liftReadList rp rl
56
57 instance (Show1 f, Show1 g) => Show1 (Compose f g) where
58 liftShowsPrec sp sl d (Compose x) =
59 showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x
60 where
61 sp' = liftShowsPrec sp sl
62 sl' = liftShowList sp sl
63
64 -- Instances of Prelude classes
65
66 instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
67 (==) = eq1
68
69 instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
70 compare = compare1
71
72 instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where
73 readsPrec = readsPrec1
74
75 instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where
76 showsPrec = showsPrec1
77
78 -- Functor instances
79
80 instance (Functor f, Functor g) => Functor (Compose f g) where
81 fmap f (Compose x) = Compose (fmap (fmap f) x)
82
83 instance (Foldable f, Foldable g) => Foldable (Compose f g) where
84 foldMap f (Compose t) = foldMap (foldMap f) t
85
86 instance (Traversable f, Traversable g) => Traversable (Compose f g) where
87 traverse f (Compose t) = Compose <$> traverse (traverse f) t
88
89 instance (Applicative f, Applicative g) => Applicative (Compose f g) where
90 pure x = Compose (pure (pure x))
91 Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)
92
93 instance (Alternative f, Applicative g) => Alternative (Compose f g) where
94 empty = Compose empty
95 Compose x <|> Compose y = Compose (x <|> y)