Make Applicative a superclass of Monad
[ghc.git] / libraries / base / Data / Monoid.hs
1 {-# LANGUAGE Trustworthy #-}
2 {-# LANGUAGE NoImplicitPrelude #-}
3 {-# LANGUAGE AutoDeriveTypeable #-}
4 {-# LANGUAGE DeriveGeneric #-}
5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 {-# LANGUAGE PolyKinds #-}
7
8 -----------------------------------------------------------------------------
9 -- |
10 -- Module : Data.Monoid
11 -- Copyright : (c) Andy Gill 2001,
12 -- (c) Oregon Graduate Institute of Science and Technology, 2001
13 -- License : BSD-style (see the file libraries/base/LICENSE)
14 --
15 -- Maintainer : libraries@haskell.org
16 -- Stability : experimental
17 -- Portability : portable
18 --
19 -- A class for monoids (types with an associative binary operation that
20 -- has an identity) with various general-purpose instances.
21 --
22 -----------------------------------------------------------------------------
23
24 module Data.Monoid (
25 -- * Monoid typeclass
26 Monoid(..),
27 (<>),
28 Dual(..),
29 Endo(..),
30 -- * Bool wrappers
31 All(..),
32 Any(..),
33 -- * Num wrappers
34 Sum(..),
35 Product(..),
36 -- * Maybe wrappers
37 -- $MaybeExamples
38 First(..),
39 Last(..)
40 ) where
41
42 -- Push down the module in the dependency hierarchy.
43 import GHC.Base hiding (Any)
44 import GHC.Enum
45 import GHC.Num
46 import GHC.Read
47 import GHC.Show
48 import GHC.Generics
49 import Data.Maybe
50
51 {-
52 -- just for testing
53 import Data.Maybe
54 import Test.QuickCheck
55 -- -}
56
57 infixr 6 <>
58
59 -- | An infix synonym for 'mappend'.
60 --
61 -- /Since: 4.5.0.0/
62 (<>) :: Monoid m => m -> m -> m
63 (<>) = mappend
64 {-# INLINE (<>) #-}
65
66 -- Monoid instances.
67
68 -- | The dual of a monoid, obtained by swapping the arguments of 'mappend'.
69 newtype Dual a = Dual { getDual :: a }
70 deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1)
71
72 instance Monoid a => Monoid (Dual a) where
73 mempty = Dual mempty
74 Dual x `mappend` Dual y = Dual (y `mappend` x)
75
76 -- | The monoid of endomorphisms under composition.
77 newtype Endo a = Endo { appEndo :: a -> a }
78 deriving (Generic)
79
80 instance Monoid (Endo a) where
81 mempty = Endo id
82 Endo f `mappend` Endo g = Endo (f . g)
83
84 -- | Boolean monoid under conjunction.
85 newtype All = All { getAll :: Bool }
86 deriving (Eq, Ord, Read, Show, Bounded, Generic)
87
88 instance Monoid All where
89 mempty = All True
90 All x `mappend` All y = All (x && y)
91
92 -- | Boolean monoid under disjunction.
93 newtype Any = Any { getAny :: Bool }
94 deriving (Eq, Ord, Read, Show, Bounded, Generic)
95
96 instance Monoid Any where
97 mempty = Any False
98 Any x `mappend` Any y = Any (x || y)
99
100 -- | Monoid under addition.
101 newtype Sum a = Sum { getSum :: a }
102 deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)
103
104 instance Num a => Monoid (Sum a) where
105 mempty = Sum 0
106 Sum x `mappend` Sum y = Sum (x + y)
107
108 -- | Monoid under multiplication.
109 newtype Product a = Product { getProduct :: a }
110 deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)
111
112 instance Num a => Monoid (Product a) where
113 mempty = Product 1
114 Product x `mappend` Product y = Product (x * y)
115
116 -- $MaybeExamples
117 -- To implement @find@ or @findLast@ on any 'Foldable':
118 --
119 -- @
120 -- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a
121 -- findLast pred = getLast . foldMap (\x -> if pred x
122 -- then Last (Just x)
123 -- else Last Nothing)
124 -- @
125 --
126 -- Much of Data.Map's interface can be implemented with
127 -- Data.Map.alter. Some of the rest can be implemented with a new
128 -- @alterA@ function and either 'First' or 'Last':
129 --
130 -- > alterA :: (Applicative f, Ord k) =>
131 -- > (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
132 -- >
133 -- > instance Monoid a => Applicative ((,) a) -- from Control.Applicative
134 --
135 -- @
136 -- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v
137 -- -> Map k v -> (Maybe v, Map k v)
138 -- insertLookupWithKey combine key value =
139 -- Arrow.first getFirst . alterA doChange key
140 -- where
141 -- doChange Nothing = (First Nothing, Just value)
142 -- doChange (Just oldValue) =
143 -- (First (Just oldValue),
144 -- Just (combine key value oldValue))
145 -- @
146
147
148 -- | Maybe monoid returning the leftmost non-Nothing value.
149 newtype First a = First { getFirst :: Maybe a }
150 deriving (Eq, Ord, Read, Show, Generic, Generic1)
151
152 instance Monoid (First a) where
153 mempty = First Nothing
154 r@(First (Just _)) `mappend` _ = r
155 First Nothing `mappend` r = r
156
157 instance Functor First where
158 fmap f (First x) = First (fmap f x)
159
160 instance Applicative First where
161 pure x = First (Just x)
162 First x <*> First y = First (x <*> y)
163
164 instance Monad First where
165 return x = First (Just x)
166 First x >>= m = First (x >>= getFirst . m)
167
168 -- | Maybe monoid returning the rightmost non-Nothing value.
169 newtype Last a = Last { getLast :: Maybe a }
170 deriving (Eq, Ord, Read, Show, Generic, Generic1)
171
172 instance Monoid (Last a) where
173 mempty = Last Nothing
174 _ `mappend` r@(Last (Just _)) = r
175 r `mappend` Last Nothing = r
176
177 instance Functor Last where
178 fmap f (Last x) = Last (fmap f x)
179
180 instance Applicative Last where
181 pure x = Last (Just x)
182 Last x <*> Last y = Last (x <*> y)
183
184 instance Monad Last where
185 return x = Last (Just x)
186 Last x >>= m = Last (x >>= getLast . m)
187
188 {-
189 {--------------------------------------------------------------------
190 Testing
191 --------------------------------------------------------------------}
192 instance Arbitrary a => Arbitrary (Maybe a) where
193 arbitrary = oneof [return Nothing, Just `fmap` arbitrary]
194
195 prop_mconcatMaybe :: [Maybe [Int]] -> Bool
196 prop_mconcatMaybe x =
197 fromMaybe [] (mconcat x) == mconcat (catMaybes x)
198
199 prop_mconcatFirst :: [Maybe Int] -> Bool
200 prop_mconcatFirst x =
201 getFirst (mconcat (map First x)) == listToMaybe (catMaybes x)
202 prop_mconcatLast :: [Maybe Int] -> Bool
203 prop_mconcatLast x =
204 getLast (mconcat (map Last x)) == listLastToMaybe (catMaybes x)
205 where listLastToMaybe [] = Nothing
206 listLastToMaybe lst = Just (last lst)
207 -- -}
208