1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
-----------------------------------------------------------------------------
-- |
-- 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
{-
-- just for testing
import Data.Maybe
import Test.QuickCheck
-- -}
infixr 6 <>
-- | An infix synonym for 'mappend'.
--
-- /Since: 4.5.0.0/
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
{-# INLINE (<>) #-}
-- Monoid instances.
-- | 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))
-- @
-- | 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
instance Functor First where
fmap f (First x) = First (fmap f x)
instance Applicative First where
pure x = First (Just x)
First x <*> First y = First (x <*> y)
instance Monad First where
return x = First (Just x)
First x >>= m = First (x >>= getFirst . m)
-- | 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
instance Functor Last where
fmap f (Last x) = Last (fmap f x)
instance Applicative Last where
pure x = Last (Just x)
Last x <*> Last y = Last (x <*> y)
instance Monad Last where
return x = Last (Just x)
Last x >>= m = Last (x >>= getLast . m)
{-
{--------------------------------------------------------------------
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)
-- -}
|
