Permalink
Fetching contributors…
Cannot retrieve contributors at this time
284 lines (240 sloc) 8.76 KB
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Monoid
-- Copyright : (c) Andy Gill 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 : portable
--
-- A class for monoids (types with an associative binary operation that
-- has an identity) with various general-purpose instances.
--
-----------------------------------------------------------------------------
module Data.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.
import GHC.Base hiding (Any)
import GHC.Enum
import GHC.Num
import GHC.Read
import GHC.Show
import GHC.Generics
import Data.Maybe
import Data.Proxy
{-
-- just for testing
import Data.Maybe
import Test.QuickCheck
-- -}
-- ---------------------------------------------------------------------------
-- | 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
-- ^ 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
infixr 6 <>
-- | An infix synonym for 'mappend'.
--
-- /Since: 4.5.0.0/
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
{-# INLINE (<>) #-}
-- Monoid instances.
instance Monoid [a] where
mempty = []
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 _ = ()
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
instance Monoid (Proxy s) where
mempty = Proxy
mappend _ _ = Proxy
mconcat _ = Proxy
-- | The dual of a monoid, obtained by swapping the arguments of 'mappend'.
newtype Dual a = Dual { getDual :: a }
deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1)
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 }
deriving (Generic)
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, Generic)
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, Generic)
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, Generic, Generic1, Num)
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, Generic, Generic1, Num)
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
-- <http://en.wikipedia.org/wiki/Monoid>: \"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 }
deriving (Eq, Ord, Read, Show, Generic, Generic1)
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 }
deriving (Eq, Ord, Read, Show, Generic, Generic1)
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)
-- -}