Data/Monoid.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Data.Monoid
   4 -- Copyright   :  (c) Andy Gill 2001,
   5 --                (c) Oregon Graduate Institute of Science and Technology, 2001
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  experimental
  10 -- Portability :  portable
  11 --
  12 -- The Monoid class with various general-purpose instances.
  13 --
  14 --        Inspired by the paper
  15 --        /Functional Programming with Overloading and
  16 --            Higher-Order Polymorphism/,
  17 --          Mark P Jones (<http://www.cse.ogi.edu/~mpj/>)
  18 --                Advanced School of Functional Programming, 1995.
  19 -----------------------------------------------------------------------------
  20
  21 module Data.Monoid (
  22         -- * Monoid typeclass
  23         Monoid(..),
  24         Dual(..),
  25         Endo(..),
  26         -- * Bool wrappers
  27         All(..),
  28         Any(..),
  29         -- * Num wrappers
  30         Sum(..),
  31         Product(..),
  32         -- * Maybe wrappers
  33         -- $MaybeExamples
  34         First(..),
  35         Last(..)
  36   ) where
  37
  38 import Prelude
  39
  40 {-
  41 -- just for testing
  42 import Data.Maybe
  43 import Test.QuickCheck
  44 -- -}
  45
  46 -- ---------------------------------------------------------------------------
  47 -- | The monoid class.
  48 -- A minimal complete definition must supply 'mempty' and 'mappend',
  49 -- and these should satisfy the monoid laws.
  50
  51 class Monoid a where
  52         mempty  :: a
  53         -- ^ Identity of 'mappend'
  54         mappend :: a -> a -> a
  55         -- ^ An associative operation
  56         mconcat :: [a] -> a
  57
  58         -- ^ Fold a list using the monoid.
  59         -- For most types, the default definition for 'mconcat' will be
  60         -- used, but the function is included in the class definition so
  61         -- that an optimized version can be provided for specific types.
  62
  63         mconcat = foldr mappend mempty
  64
  65 -- Monoid instances.
  66
  67 instance Monoid [a] where
  68         mempty  = []
  69         mappend = (++)
  70
  71 instance Monoid b => Monoid (a -> b) where
  72         mempty _ = mempty
  73         mappend f g x = f x `mappend` g x
  74
  75 instance Monoid () where
  76         -- Should it be strict?
  77         mempty        = ()
  78         _ `mappend` _ = ()
  79         mconcat _     = ()
  80
  81 instance (Monoid a, Monoid b) => Monoid (a,b) where
  82         mempty = (mempty, mempty)
  83         (a1,b1) `mappend` (a2,b2) =
  84                 (a1 `mappend` a2, b1 `mappend` b2)
  85
  86 instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
  87         mempty = (mempty, mempty, mempty)
  88         (a1,b1,c1) `mappend` (a2,b2,c2) =
  89                 (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)
  90
  91 instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
  92         mempty = (mempty, mempty, mempty, mempty)
  93         (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =
  94                 (a1 `mappend` a2, b1 `mappend` b2,
  95                  c1 `mappend` c2, d1 `mappend` d2)
  96
  97 instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
  98                 Monoid (a,b,c,d,e) where
  99         mempty = (mempty, mempty, mempty, mempty, mempty)
 100         (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =
 101                 (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,
 102                  d1 `mappend` d2, e1 `mappend` e2)
 103
 104 -- lexicographical ordering
 105 instance Monoid Ordering where
 106         mempty         = EQ
 107         LT `mappend` _ = LT
 108         EQ `mappend` y = y
 109         GT `mappend` _ = GT
 110
 111 -- | The dual of a monoid, obtained by swapping the arguments of 'mappend'.
 112 newtype Dual a = Dual { getDual :: a }
 113         deriving (Eq, Ord, Read, Show, Bounded)
 114
 115 instance Monoid a => Monoid (Dual a) where
 116         mempty = Dual mempty
 117         Dual x `mappend` Dual y = Dual (y `mappend` x)
 118
 119 -- | The monoid of endomorphisms under composition.
 120 newtype Endo a = Endo { appEndo :: a -> a }
 121
 122 instance Monoid (Endo a) where
 123         mempty = Endo id
 124         Endo f `mappend` Endo g = Endo (f . g)
 125
 126 -- | Boolean monoid under conjunction.
 127 newtype All = All { getAll :: Bool }
 128         deriving (Eq, Ord, Read, Show, Bounded)
 129
 130 instance Monoid All where
 131         mempty = All True
 132         All x `mappend` All y = All (x && y)
 133
 134 -- | Boolean monoid under disjunction.
 135 newtype Any = Any { getAny :: Bool }
 136         deriving (Eq, Ord, Read, Show, Bounded)
 137
 138 instance Monoid Any where
 139         mempty = Any False
 140         Any x `mappend` Any y = Any (x || y)
 141
 142 -- | Monoid under addition.
 143 newtype Sum a = Sum { getSum :: a }
 144         deriving (Eq, Ord, Read, Show, Bounded)
 145
 146 instance Num a => Monoid (Sum a) where
 147         mempty = Sum 0
 148         Sum x `mappend` Sum y = Sum (x + y)
 149
 150 -- | Monoid under multiplication.
 151 newtype Product a = Product { getProduct :: a }
 152         deriving (Eq, Ord, Read, Show, Bounded)
 153
 154 instance Num a => Monoid (Product a) where
 155         mempty = Product 1
 156         Product x `mappend` Product y = Product (x * y)
 157
 158 -- $MaybeExamples
 159 -- To implement @find@ or @findLast@ on any 'Foldable':
 160 --
 161 -- @
 162 -- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a
 163 -- findLast pred = getLast . foldMap (\x -> if pred x
 164 --                                            then Last (Just x)
 165 --                                            else Last Nothing)
 166 -- @
 167 --
 168 -- Much of Data.Map's interface can be implemented with
 169 -- Data.Map.alter. Some of the rest can be implemented with a new
 170 -- @alterA@ function and either 'First' or 'Last':
 171 --
 172 -- > alterA :: (Applicative f, Ord k) =>
 173 -- >           (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
 174 -- >
 175 -- > instance Monoid a => Applicative ((,) a)  -- from Control.Applicative
 176 --
 177 -- @
 178 -- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v
 179 --                     -> Map k v -> (Maybe v, Map k v)
 180 -- insertLookupWithKey combine key value =
 181 --   Arrow.first getFirst . alterA doChange key
 182 --   where
 183 --   doChange Nothing = (First Nothing, Just value)
 184 --   doChange (Just oldValue) =
 185 --     (First (Just oldValue),
 186 --      Just (combine key value oldValue))
 187 -- @
 188
 189 -- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
 190 -- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
 191 -- turned into a monoid simply by adjoining an element @e@ not in @S@
 192 -- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since
 193 -- there is no \"Semigroup\" typeclass providing just 'mappend', we
 194 -- use 'Monoid' instead.
 195 instance Monoid a => Monoid (Maybe a) where
 196   mempty = Nothing
 197   Nothing `mappend` m = m
 198   m `mappend` Nothing = m
 199   Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)
 200
 201
 202 -- | Maybe monoid returning the leftmost non-Nothing value.
 203 newtype First a = First { getFirst :: Maybe a }
 204 #ifndef __HADDOCK__
 205         deriving (Eq, Ord, Read, Show)
 206 #else  /* __HADDOCK__ */
 207 instance Eq a => Eq (First a)
 208 instance Ord a => Ord (First a)
 209 instance Read a => Read (First a)
 210 instance Show a => Show (First a)
 211 #endif
 212
 213 instance Monoid (First a) where
 214         mempty = First Nothing
 215         r@(First (Just _)) `mappend` _ = r
 216         First Nothing `mappend` r = r
 217
 218 -- | Maybe monoid returning the rightmost non-Nothing value.
 219 newtype Last a = Last { getLast :: Maybe a }
 220 #ifndef __HADDOCK__
 221         deriving (Eq, Ord, Read, Show)
 222 #else  /* __HADDOCK__ */
 223 instance Eq a => Eq (Last a)
 224 instance Ord a => Ord (Last a)
 225 instance Read a => Read (Last a)
 226 instance Show a => Show (Last a)
 227 #endif
 228
 229 instance Monoid (Last a) where
 230         mempty = Last Nothing
 231         _ `mappend` r@(Last (Just _)) = r
 232         r `mappend` Last Nothing = r
 233
 234 {-
 235 {--------------------------------------------------------------------
 236   Testing
 237 --------------------------------------------------------------------}
 238 instance Arbitrary a => Arbitrary (Maybe a) where
 239   arbitrary = oneof [return Nothing, Just `fmap` arbitrary]
 240
 241 prop_mconcatMaybe :: [Maybe [Int]] -> Bool
 242 prop_mconcatMaybe x =
 243   fromMaybe [] (mconcat x) == mconcat (catMaybes x)
 244
 245 prop_mconcatFirst :: [Maybe Int] -> Bool
 246 prop_mconcatFirst x =
 247   getFirst (mconcat (map First x)) == listToMaybe (catMaybes x)
 248 prop_mconcatLast :: [Maybe Int] -> Bool
 249 prop_mconcatLast x =
 250   getLast (mconcat (map Last x)) == listLastToMaybe (catMaybes x)
 251         where listLastToMaybe [] = Nothing
 252               listLastToMaybe lst = Just (last lst)
 253 -- -}