Semigroup.hs 13 KB
Newer Older
1
{-# LANGUAGE CPP                        #-}
2 3 4 5 6 7 8 9 10
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE Trustworthy                #-}
{-# LANGUAGE TypeOperators              #-}
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

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Semigroup
-- Copyright   :  (C) 2011-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- In mathematics, a semigroup is an algebraic structure consisting of a
-- set together with an associative binary operation. A semigroup
-- generalizes a monoid in that there might not exist an identity
-- element. It also (originally) generalized a group (a monoid with all
-- inverses) to a type where every element did not have to have an inverse,
-- thus the name semigroup.
--
-- The use of @(\<\>)@ in this module conflicts with an operator with the same
-- name that is being exported by Data.Monoid. However, this package
-- re-exports (most of) the contents of Data.Monoid, so to use semigroups
-- and monoids in the same package just
--
-- > import Data.Semigroup
--
36
-- @since 4.9.0.0
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
----------------------------------------------------------------------------
module Data.Semigroup (
    Semigroup(..)
  , stimesMonoid
  , stimesIdempotent
  , stimesIdempotentMonoid
  , mtimesDefault
  -- * Semigroups
  , Min(..)
  , Max(..)
  , First(..)
  , Last(..)
  , WrappedMonoid(..)
  -- * Re-exported monoids from Data.Monoid
  , Dual(..)
  , Endo(..)
  , All(..)
  , Any(..)
  , Sum(..)
  , Product(..)
  -- * A better monoid for Maybe
  , Option(..)
  , option
  -- * Difference lists of a semigroup
  , diff
  , cycle1
  -- * ArgMin, ArgMax
  , Arg(..)
  , ArgMin
  , ArgMax
  ) where

import           Prelude             hiding (foldr1)

71 72 73 74
import GHC.Base (Semigroup(..))

import           Data.Semigroup.Internal

75 76 77
import           Control.Applicative
import           Control.Monad
import           Control.Monad.Fix
78
import           Data.Bifoldable
79
import           Data.Bifunctor
80
import           Data.Bitraversable
81 82 83 84
import           Data.Coerce
import           Data.Data
import           Data.Monoid         (All (..), Any (..), Dual (..), Endo (..),
                                      Product (..), Sum (..))
85
-- import qualified Data.Monoid         as Monoid
86 87 88 89 90 91 92
import           GHC.Generics

-- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'.
-- May fail to terminate for some values in some semigroups.
cycle1 :: Semigroup m => m -> m
cycle1 xs = xs' where xs' = xs <> xs'

93 94 95
-- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'.
diff :: Semigroup m => m -> Endo m
diff = Endo . (<>)
96 97

newtype Min a = Min { getMin :: a }
98
  deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
99

100
-- | @since 4.9.0.0
101 102 103 104 105 106 107 108 109 110 111
instance Enum a => Enum (Min a) where
  succ (Min a) = Min (succ a)
  pred (Min a) = Min (pred a)
  toEnum = Min . toEnum
  fromEnum = fromEnum . getMin
  enumFrom (Min a) = Min <$> enumFrom a
  enumFromThen (Min a) (Min b) = Min <$> enumFromThen a b
  enumFromTo (Min a) (Min b) = Min <$> enumFromTo a b
  enumFromThenTo (Min a) (Min b) (Min c) = Min <$> enumFromThenTo a b c


112
-- | @since 4.9.0.0
113 114 115 116
instance Ord a => Semigroup (Min a) where
  (<>) = coerce (min :: a -> a -> a)
  stimes = stimesIdempotent

117
-- | @since 4.9.0.0
118 119 120
instance (Ord a, Bounded a) => Monoid (Min a) where
  mempty = maxBound

121
-- | @since 4.9.0.0
122 123 124
instance Functor Min where
  fmap f (Min x) = Min (f x)

125
-- | @since 4.9.0.0
126 127 128
instance Foldable Min where
  foldMap f (Min a) = f a

129
-- | @since 4.9.0.0
130 131 132
instance Traversable Min where
  traverse f (Min a) = Min <$> f a

133
-- | @since 4.9.0.0
134 135 136 137
instance Applicative Min where
  pure = Min
  a <* _ = a
  _ *> a = a
138 139
  (<*>) = coerce
  liftA2 = coerce
140

141
-- | @since 4.9.0.0
142
instance Monad Min where
143
  (>>) = (*>)
144 145
  Min a >>= f = f a

146
-- | @since 4.9.0.0
147 148 149
instance MonadFix Min where
  mfix f = fix (f . getMin)

150
-- | @since 4.9.0.0
151 152 153 154 155 156 157 158 159 160
instance Num a => Num (Min a) where
  (Min a) + (Min b) = Min (a + b)
  (Min a) * (Min b) = Min (a * b)
  (Min a) - (Min b) = Min (a - b)
  negate (Min a) = Min (negate a)
  abs    (Min a) = Min (abs a)
  signum (Min a) = Min (signum a)
  fromInteger    = Min . fromInteger

newtype Max a = Max { getMax :: a }
161
  deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
162

163
-- | @since 4.9.0.0
164 165 166 167 168 169 170 171 172 173
instance Enum a => Enum (Max a) where
  succ (Max a) = Max (succ a)
  pred (Max a) = Max (pred a)
  toEnum = Max . toEnum
  fromEnum = fromEnum . getMax
  enumFrom (Max a) = Max <$> enumFrom a
  enumFromThen (Max a) (Max b) = Max <$> enumFromThen a b
  enumFromTo (Max a) (Max b) = Max <$> enumFromTo a b
  enumFromThenTo (Max a) (Max b) (Max c) = Max <$> enumFromThenTo a b c

174
-- | @since 4.9.0.0
175 176 177 178
instance Ord a => Semigroup (Max a) where
  (<>) = coerce (max :: a -> a -> a)
  stimes = stimesIdempotent

179
-- | @since 4.9.0.0
180 181 182
instance (Ord a, Bounded a) => Monoid (Max a) where
  mempty = minBound

183
-- | @since 4.9.0.0
184 185 186
instance Functor Max where
  fmap f (Max x) = Max (f x)

187
-- | @since 4.9.0.0
188 189 190
instance Foldable Max where
  foldMap f (Max a) = f a

191
-- | @since 4.9.0.0
192 193 194
instance Traversable Max where
  traverse f (Max a) = Max <$> f a

195
-- | @since 4.9.0.0
196 197 198 199
instance Applicative Max where
  pure = Max
  a <* _ = a
  _ *> a = a
200 201
  (<*>) = coerce
  liftA2 = coerce
202

203
-- | @since 4.9.0.0
204
instance Monad Max where
205
  (>>) = (*>)
206 207
  Max a >>= f = f a

208
-- | @since 4.9.0.0
209 210 211
instance MonadFix Max where
  mfix f = fix (f . getMax)

212
-- | @since 4.9.0.0
213 214 215 216 217 218 219 220 221 222 223 224
instance Num a => Num (Max a) where
  (Max a) + (Max b) = Max (a + b)
  (Max a) * (Max b) = Max (a * b)
  (Max a) - (Max b) = Max (a - b)
  negate (Max a) = Max (negate a)
  abs    (Max a) = Max (abs a)
  signum (Max a) = Max (signum a)
  fromInteger    = Max . fromInteger

-- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be
-- placed inside 'Min' and 'Max' to compute an arg min or arg max.
data Arg a b = Arg a b deriving
225
  (Show, Read, Data, Generic, Generic1)
226 227 228 229

type ArgMin a b = Min (Arg a b)
type ArgMax a b = Max (Arg a b)

230
-- | @since 4.9.0.0
231 232 233
instance Functor (Arg a) where
  fmap f (Arg x a) = Arg x (f a)

234
-- | @since 4.9.0.0
235 236 237
instance Foldable (Arg a) where
  foldMap f (Arg _ a) = f a

238
-- | @since 4.9.0.0
239 240 241
instance Traversable (Arg a) where
  traverse f (Arg x a) = Arg x <$> f a

242
-- | @since 4.9.0.0
243 244 245
instance Eq a => Eq (Arg a b) where
  Arg a _ == Arg b _ = a == b

246
-- | @since 4.9.0.0
247 248 249 250 251 252 253 254 255
instance Ord a => Ord (Arg a b) where
  Arg a _ `compare` Arg b _ = compare a b
  min x@(Arg a _) y@(Arg b _)
    | a <= b    = x
    | otherwise = y
  max x@(Arg a _) y@(Arg b _)
    | a >= b    = x
    | otherwise = y

256
-- | @since 4.9.0.0
257 258 259
instance Bifunctor Arg where
  bimap f g (Arg a b) = Arg (f a) (g b)

Ryan Scott's avatar
Ryan Scott committed
260
-- | @since 4.10.0.0
261
instance Bifoldable Arg where
262
  bifoldMap f g (Arg a b) = f a <> g b
263

Ryan Scott's avatar
Ryan Scott committed
264
-- | @since 4.10.0.0
265 266 267
instance Bitraversable Arg where
  bitraverse f g (Arg a b) = Arg <$> f a <*> g b

268 269 270
-- | Use @'Option' ('First' a)@ to get the behavior of
-- 'Data.Monoid.First' from "Data.Monoid".
newtype First a = First { getFirst :: a } deriving
271
  (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
272

273
-- | @since 4.9.0.0
274 275 276 277 278 279 280 281 282 283
instance Enum a => Enum (First a) where
  succ (First a) = First (succ a)
  pred (First a) = First (pred a)
  toEnum = First . toEnum
  fromEnum = fromEnum . getFirst
  enumFrom (First a) = First <$> enumFrom a
  enumFromThen (First a) (First b) = First <$> enumFromThen a b
  enumFromTo (First a) (First b) = First <$> enumFromTo a b
  enumFromThenTo (First a) (First b) (First c) = First <$> enumFromThenTo a b c

284
-- | @since 4.9.0.0
285 286 287 288
instance Semigroup (First a) where
  a <> _ = a
  stimes = stimesIdempotent

289
-- | @since 4.9.0.0
290 291 292
instance Functor First where
  fmap f (First x) = First (f x)

293
-- | @since 4.9.0.0
294 295 296
instance Foldable First where
  foldMap f (First a) = f a

297
-- | @since 4.9.0.0
298 299 300
instance Traversable First where
  traverse f (First a) = First <$> f a

301
-- | @since 4.9.0.0
302 303 304 305
instance Applicative First where
  pure x = First x
  a <* _ = a
  _ *> a = a
306 307
  (<*>) = coerce
  liftA2 = coerce
308

309
-- | @since 4.9.0.0
310
instance Monad First where
311
  (>>) = (*>)
312 313
  First a >>= f = f a

314
-- | @since 4.9.0.0
315 316 317 318 319 320
instance MonadFix First where
  mfix f = fix (f . getFirst)

-- | Use @'Option' ('Last' a)@ to get the behavior of
-- 'Data.Monoid.Last' from "Data.Monoid"
newtype Last a = Last { getLast :: a } deriving
321
  (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
322

323
-- | @since 4.9.0.0
324 325 326 327 328 329 330 331 332 333
instance Enum a => Enum (Last a) where
  succ (Last a) = Last (succ a)
  pred (Last a) = Last (pred a)
  toEnum = Last . toEnum
  fromEnum = fromEnum . getLast
  enumFrom (Last a) = Last <$> enumFrom a
  enumFromThen (Last a) (Last b) = Last <$> enumFromThen a b
  enumFromTo (Last a) (Last b) = Last <$> enumFromTo a b
  enumFromThenTo (Last a) (Last b) (Last c) = Last <$> enumFromThenTo a b c

334
-- | @since 4.9.0.0
335 336 337 338
instance Semigroup (Last a) where
  _ <> b = b
  stimes = stimesIdempotent

339
-- | @since 4.9.0.0
340 341 342 343
instance Functor Last where
  fmap f (Last x) = Last (f x)
  a <$ _ = Last a

344
-- | @since 4.9.0.0
345 346 347
instance Foldable Last where
  foldMap f (Last a) = f a

348
-- | @since 4.9.0.0
349 350 351
instance Traversable Last where
  traverse f (Last a) = Last <$> f a

352
-- | @since 4.9.0.0
353 354 355 356
instance Applicative Last where
  pure = Last
  a <* _ = a
  _ *> a = a
357 358
  (<*>) = coerce
  liftA2 = coerce
359

360
-- | @since 4.9.0.0
361
instance Monad Last where
362
  (>>) = (*>)
363 364
  Last a >>= f = f a

365
-- | @since 4.9.0.0
366 367 368 369
instance MonadFix Last where
  mfix f = fix (f . getLast)

-- | Provide a Semigroup for an arbitrary Monoid.
370 371 372
--
-- __NOTE__: This is not needed anymore since 'Semigroup' became a superclass of
-- 'Monoid' in /base-4.11/ and this newtype be deprecated at some point in the future.
373
newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m }
374
  deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
375

376
-- | @since 4.9.0.0
377 378 379
instance Monoid m => Semigroup (WrappedMonoid m) where
  (<>) = coerce (mappend :: m -> m -> m)

380
-- | @since 4.9.0.0
381 382 383
instance Monoid m => Monoid (WrappedMonoid m) where
  mempty = WrapMonoid mempty

384
-- | @since 4.9.0.0
385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414
instance Enum a => Enum (WrappedMonoid a) where
  succ (WrapMonoid a) = WrapMonoid (succ a)
  pred (WrapMonoid a) = WrapMonoid (pred a)
  toEnum = WrapMonoid . toEnum
  fromEnum = fromEnum . unwrapMonoid
  enumFrom (WrapMonoid a) = WrapMonoid <$> enumFrom a
  enumFromThen (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromThen a b
  enumFromTo (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromTo a b
  enumFromThenTo (WrapMonoid a) (WrapMonoid b) (WrapMonoid c) =
      WrapMonoid <$> enumFromThenTo a b c

-- | Repeat a value @n@ times.
--
-- > mtimesDefault n a = a <> a <> ... <> a  -- using <> (n-1) times
--
-- Implemented using 'stimes' and 'mempty'.
--
-- This is a suitable definition for an 'mtimes' member of 'Monoid'.
mtimesDefault :: (Integral b, Monoid a) => b -> a -> a
mtimesDefault n x
  | n == 0    = mempty
  | otherwise = unwrapMonoid (stimes n (WrapMonoid x))

-- | 'Option' is effectively 'Maybe' with a better instance of
-- 'Monoid', built off of an underlying 'Semigroup' instead of an
-- underlying 'Monoid'.
--
-- Ideally, this type would not exist at all and we would just fix the
-- 'Monoid' instance of 'Maybe'
newtype Option a = Option { getOption :: Maybe a }
415
  deriving (Eq, Ord, Show, Read, Data, Generic, Generic1)
416

417
-- | @since 4.9.0.0
418 419 420
instance Functor Option where
  fmap f (Option a) = Option (fmap f a)

421
-- | @since 4.9.0.0
422 423 424
instance Applicative Option where
  pure a = Option (Just a)
  Option a <*> Option b = Option (a <*> b)
425
  liftA2 f (Option x) (Option y) = Option (liftA2 f x y)
426

427 428
  Option Nothing  *>  _ = Option Nothing
  _               *>  b = b
429

430
-- | @since 4.9.0.0
431
instance Monad Option where
432 433
  Option (Just a) >>= k = k a
  _               >>= _ = Option Nothing
434
  (>>) = (*>)
435

436
-- | @since 4.9.0.0
437 438 439 440 441
instance Alternative Option where
  empty = Option Nothing
  Option Nothing <|> b = b
  a <|> _ = a

442
-- | @since 4.9.0.0
443
instance MonadPlus Option
444

445
-- | @since 4.9.0.0
446 447 448
instance MonadFix Option where
  mfix f = Option (mfix (getOption . f))

449
-- | @since 4.9.0.0
450 451 452 453
instance Foldable Option where
  foldMap f (Option (Just m)) = f m
  foldMap _ (Option Nothing)  = mempty

454
-- | @since 4.9.0.0
455 456 457 458 459 460 461 462
instance Traversable Option where
  traverse f (Option (Just a)) = Option . Just <$> f a
  traverse _ (Option Nothing)  = pure (Option Nothing)

-- | Fold an 'Option' case-wise, just like 'maybe'.
option :: b -> (a -> b) -> Option a -> b
option n j (Option m) = maybe n j m

463
-- | @since 4.9.0.0
464 465
instance Semigroup a => Semigroup (Option a) where
  (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a)
466 467
#if !defined(__HADDOCK_VERSION__)
    -- workaround https://github.com/haskell/haddock/issues/680
468 469
  stimes _ (Option Nothing) = Option Nothing
  stimes n (Option (Just a)) = case compare n 0 of
Eric Seidel's avatar
Eric Seidel committed
470
    LT -> errorWithoutStackTrace "stimes: Option, negative multiplier"
471 472
    EQ -> Option Nothing
    GT -> Option (Just (stimes n a))
473
#endif
474

475
-- | @since 4.9.0.0
476 477
instance Semigroup a => Monoid (Option a) where
  mempty = Option Nothing