X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FMonoid.hs;h=aaefd42169c7bdc85ba028ddd1d1df4aeda4089b;hb=HEAD;hp=a328639b50ed5daf48f5c5ab3df7dc573480d718;hpb=bc9366635bdecd7a3476f33fb4118b4976a5ebd8;p=ghc-base.git
diff --git a/Data/Monoid.hs b/Data/Monoid.hs
index a328639..aaefd42 100644
--- a/Data/Monoid.hs
+++ b/Data/Monoid.hs
@@ -1,60 +1,277 @@
+{-# LANGUAGE CPP, NoImplicitPrelude #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Data.Monoid
-- Copyright : (c) Andy Gill 2001,
--- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
-- License : BSD-style (see the file libraries/base/LICENSE)
---
+--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
--- Portability : non-portable (requires extended type classes)
---
--- Declaration of the Monoid class, and instances for list and functions.
+-- Portability : portable
--
--- Inspired by the paper
--- /Functional Programming with Overloading and
--- Higher-Order Polymorphism/,
--- Mark P Jones ()
--- Advanced School of Functional Programming, 1995.
+-- A class for monoids (types with an associative binary operation that
+-- has an identity) with various general-purpose instances.
-----------------------------------------------------------------------------
module Data.Monoid (
- Monoid(..)
+ -- * Monoid typeclass
+ Monoid(..),
+ Dual(..),
+ Endo(..),
+ -- * Bool wrappers
+ All(..),
+ Any(..),
+ -- * Num wrappers
+ Sum(..),
+ Product(..),
+ -- * Maybe wrappers
+ -- $MaybeExamples
+ First(..),
+ Last(..)
) where
+-- Push down the module in the dependency hierarchy.
+#if defined(__GLASGOW_HASKELL__)
+import GHC.Base hiding (Any)
+import GHC.Enum
+import GHC.Num
+import GHC.Read
+import GHC.Show
+import Data.Maybe
+#else
import Prelude
+#endif
+
+{-
+-- just for testing
+import Data.Maybe
+import Test.QuickCheck
+-- -}
-- ---------------------------------------------------------------------------
--- | The monoid class.
--- A minimal complete definition must supply 'mempty' and 'mappend',
--- and these should satisfy the monoid laws.
+-- | The class of monoids (types with an associative binary operation that
+-- has an identity). Instances should satisfy the following laws:
+--
+-- * @mappend mempty x = x@
+--
+-- * @mappend x mempty = x@
+--
+-- * @mappend x (mappend y z) = mappend (mappend x y) z@
+--
+-- * @mconcat = 'foldr' mappend mempty@
+--
+-- The method names refer to the monoid of lists under concatenation,
+-- but there are many other instances.
+--
+-- Minimal complete definition: 'mempty' and 'mappend'.
+--
+-- Some types can be viewed as a monoid in more than one way,
+-- e.g. both addition and multiplication on numbers.
+-- In such cases we often define @newtype@s and make those instances
+-- of 'Monoid', e.g. 'Sum' and 'Product'.
class Monoid a where
- mempty :: a
- -- ^ Identity of 'mappend'
- mappend :: a -> a -> a
- -- ^ An associative operation
- mconcat :: [a] -> a
+ mempty :: a
+ -- ^ Identity of 'mappend'
+ mappend :: a -> a -> a
+ -- ^ An associative operation
+ mconcat :: [a] -> a
- -- ^ Fold a list using the monoid.
- -- For most types, the default definition for 'mconcat' will be
- -- used, but the function is included in the class definition so
- -- that an optimized version can be provided for specific types.
+ -- ^ Fold a list using the monoid.
+ -- For most types, the default definition for 'mconcat' will be
+ -- used, but the function is included in the class definition so
+ -- that an optimized version can be provided for specific types.
- mconcat = foldr mappend mempty
+ mconcat = foldr mappend mempty
-- Monoid instances.
instance Monoid [a] where
- mempty = []
- mappend = (++)
+ mempty = []
+ mappend = (++)
-instance Monoid (a -> a) where
- mempty = id
- mappend = (.)
+instance Monoid b => Monoid (a -> b) where
+ mempty _ = mempty
+ mappend f g x = f x `mappend` g x
instance Monoid () where
- -- Should it be strict?
- mempty = ()
- _ `mappend` _ = ()
- mconcat _ = ()
+ -- Should it be strict?
+ mempty = ()
+ _ `mappend` _ = ()
+ mconcat _ = ()
+
+instance (Monoid a, Monoid b) => Monoid (a,b) where
+ mempty = (mempty, mempty)
+ (a1,b1) `mappend` (a2,b2) =
+ (a1 `mappend` a2, b1 `mappend` b2)
+
+instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
+ mempty = (mempty, mempty, mempty)
+ (a1,b1,c1) `mappend` (a2,b2,c2) =
+ (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)
+
+instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
+ mempty = (mempty, mempty, mempty, mempty)
+ (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =
+ (a1 `mappend` a2, b1 `mappend` b2,
+ c1 `mappend` c2, d1 `mappend` d2)
+
+instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
+ Monoid (a,b,c,d,e) where
+ mempty = (mempty, mempty, mempty, mempty, mempty)
+ (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =
+ (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,
+ d1 `mappend` d2, e1 `mappend` e2)
+
+-- lexicographical ordering
+instance Monoid Ordering where
+ mempty = EQ
+ LT `mappend` _ = LT
+ EQ `mappend` y = y
+ GT `mappend` _ = GT
+
+-- | The dual of a monoid, obtained by swapping the arguments of 'mappend'.
+newtype Dual a = Dual { getDual :: a }
+ deriving (Eq, Ord, Read, Show, Bounded)
+
+instance Monoid a => Monoid (Dual a) where
+ mempty = Dual mempty
+ Dual x `mappend` Dual y = Dual (y `mappend` x)
+
+-- | The monoid of endomorphisms under composition.
+newtype Endo a = Endo { appEndo :: a -> a }
+
+instance Monoid (Endo a) where
+ mempty = Endo id
+ Endo f `mappend` Endo g = Endo (f . g)
+
+-- | Boolean monoid under conjunction.
+newtype All = All { getAll :: Bool }
+ deriving (Eq, Ord, Read, Show, Bounded)
+
+instance Monoid All where
+ mempty = All True
+ All x `mappend` All y = All (x && y)
+
+-- | Boolean monoid under disjunction.
+newtype Any = Any { getAny :: Bool }
+ deriving (Eq, Ord, Read, Show, Bounded)
+
+instance Monoid Any where
+ mempty = Any False
+ Any x `mappend` Any y = Any (x || y)
+
+-- | Monoid under addition.
+newtype Sum a = Sum { getSum :: a }
+ deriving (Eq, Ord, Read, Show, Bounded)
+
+instance Num a => Monoid (Sum a) where
+ mempty = Sum 0
+ Sum x `mappend` Sum y = Sum (x + y)
+
+-- | Monoid under multiplication.
+newtype Product a = Product { getProduct :: a }
+ deriving (Eq, Ord, Read, Show, Bounded)
+
+instance Num a => Monoid (Product a) where
+ mempty = Product 1
+ Product x `mappend` Product y = Product (x * y)
+
+-- $MaybeExamples
+-- To implement @find@ or @findLast@ on any 'Foldable':
+--
+-- @
+-- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a
+-- findLast pred = getLast . foldMap (\x -> if pred x
+-- then Last (Just x)
+-- else Last Nothing)
+-- @
+--
+-- Much of Data.Map's interface can be implemented with
+-- Data.Map.alter. Some of the rest can be implemented with a new
+-- @alterA@ function and either 'First' or 'Last':
+--
+-- > alterA :: (Applicative f, Ord k) =>
+-- > (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
+-- >
+-- > instance Monoid a => Applicative ((,) a) -- from Control.Applicative
+--
+-- @
+-- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v
+-- -> Map k v -> (Maybe v, Map k v)
+-- insertLookupWithKey combine key value =
+-- Arrow.first getFirst . alterA doChange key
+-- where
+-- doChange Nothing = (First Nothing, Just value)
+-- doChange (Just oldValue) =
+-- (First (Just oldValue),
+-- Just (combine key value oldValue))
+-- @
+
+-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
+-- : \"Any semigroup @S@ may be
+-- turned into a monoid simply by adjoining an element @e@ not in @S@
+-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s â S@.\" Since
+-- there is no \"Semigroup\" typeclass providing just 'mappend', we
+-- use 'Monoid' instead.
+instance Monoid a => Monoid (Maybe a) where
+ mempty = Nothing
+ Nothing `mappend` m = m
+ m `mappend` Nothing = m
+ Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)
+
+
+-- | Maybe monoid returning the leftmost non-Nothing value.
+newtype First a = First { getFirst :: Maybe a }
+#ifndef __HADDOCK__
+ deriving (Eq, Ord, Read, Show)
+#else /* __HADDOCK__ */
+instance Eq a => Eq (First a)
+instance Ord a => Ord (First a)
+instance Read a => Read (First a)
+instance Show a => Show (First a)
+#endif
+
+instance Monoid (First a) where
+ mempty = First Nothing
+ r@(First (Just _)) `mappend` _ = r
+ First Nothing `mappend` r = r
+
+-- | Maybe monoid returning the rightmost non-Nothing value.
+newtype Last a = Last { getLast :: Maybe a }
+#ifndef __HADDOCK__
+ deriving (Eq, Ord, Read, Show)
+#else /* __HADDOCK__ */
+instance Eq a => Eq (Last a)
+instance Ord a => Ord (Last a)
+instance Read a => Read (Last a)
+instance Show a => Show (Last a)
+#endif
+
+instance Monoid (Last a) where
+ mempty = Last Nothing
+ _ `mappend` r@(Last (Just _)) = r
+ r `mappend` Last Nothing = r
+
+{-
+{--------------------------------------------------------------------
+ Testing
+--------------------------------------------------------------------}
+instance Arbitrary a => Arbitrary (Maybe a) where
+ arbitrary = oneof [return Nothing, Just `fmap` arbitrary]
+
+prop_mconcatMaybe :: [Maybe [Int]] -> Bool
+prop_mconcatMaybe x =
+ fromMaybe [] (mconcat x) == mconcat (catMaybes x)
+
+prop_mconcatFirst :: [Maybe Int] -> Bool
+prop_mconcatFirst x =
+ getFirst (mconcat (map First x)) == listToMaybe (catMaybes x)
+prop_mconcatLast :: [Maybe Int] -> Bool
+prop_mconcatLast x =
+ getLast (mconcat (map Last x)) == listLastToMaybe (catMaybes x)
+ where listLastToMaybe [] = Nothing
+ listLastToMaybe lst = Just (last lst)
+-- -}