ec6868379911431ce49b43f168a0fa820c6e1626
[ghc.git] / libraries / base / Data / Semigroup.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE DefaultSignatures #-}
3 {-# LANGUAGE DeriveDataTypeable #-}
4 {-# LANGUAGE DeriveGeneric #-}
5 {-# LANGUAGE FlexibleContexts #-}
6 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
7 {-# LANGUAGE PolyKinds #-}
8 {-# LANGUAGE ScopedTypeVariables #-}
9 {-# LANGUAGE Trustworthy #-}
10 {-# LANGUAGE TypeOperators #-}
11
12 -----------------------------------------------------------------------------
13 -- |
14 -- Module : Data.Semigroup
15 -- Copyright : (C) 2011-2015 Edward Kmett
16 -- License : BSD-style (see the file LICENSE)
17 --
18 -- Maintainer : libraries@haskell.org
19 -- Stability : provisional
20 -- Portability : portable
21 --
22 -- In mathematics, a semigroup is an algebraic structure consisting of a
23 -- set together with an associative binary operation. A semigroup
24 -- generalizes a monoid in that there might not exist an identity
25 -- element. It also (originally) generalized a group (a monoid with all
26 -- inverses) to a type where every element did not have to have an inverse,
27 -- thus the name semigroup.
28 --
29 -- The use of @(\<\>)@ in this module conflicts with an operator with the same
30 -- name that is being exported by Data.Monoid. However, this package
31 -- re-exports (most of) the contents of Data.Monoid, so to use semigroups
32 -- and monoids in the same package just
33 --
34 -- > import Data.Semigroup
35 --
36 -- @since 4.9.0.0
37 ----------------------------------------------------------------------------
38 module Data.Semigroup (
39 Semigroup(..)
40 , stimesMonoid
41 , stimesIdempotent
42 , stimesIdempotentMonoid
43 , mtimesDefault
44 -- * Semigroups
45 , Min(..)
46 , Max(..)
47 , First(..)
48 , Last(..)
49 , WrappedMonoid(..)
50 -- * Re-exported monoids from Data.Monoid
51 , Monoid(..)
52 , Dual(..)
53 , Endo(..)
54 , All(..)
55 , Any(..)
56 , Sum(..)
57 , Product(..)
58 -- * A better monoid for Maybe
59 , Option(..)
60 , option
61 -- * Difference lists of a semigroup
62 , diff
63 , cycle1
64 -- * ArgMin, ArgMax
65 , Arg(..)
66 , ArgMin
67 , ArgMax
68 ) where
69
70 import Prelude hiding (foldr1)
71
72 import Control.Applicative
73 import Control.Monad
74 import Control.Monad.Fix
75 import Data.Bifoldable
76 import Data.Bifunctor
77 import Data.Bitraversable
78 import Data.Coerce
79 import Data.Data
80 import Data.Functor.Identity
81 import Data.List.NonEmpty
82 import Data.Monoid (All (..), Any (..), Dual (..), Endo (..),
83 Product (..), Sum (..))
84 import Data.Monoid (Alt (..))
85 import qualified Data.Monoid as Monoid
86 import Data.Ord (Down(..))
87 import Data.Void
88 #ifndef mingw32_HOST_OS
89 import GHC.Event (Event, Lifetime)
90 #endif
91 import GHC.Generics
92
93 infixr 6 <>
94
95 -- | The class of semigroups (types with an associative binary operation).
96 --
97 -- @since 4.9.0.0
98 class Semigroup a where
99 -- | An associative operation.
100 --
101 -- @
102 -- (a '<>' b) '<>' c = a '<>' (b '<>' c)
103 -- @
104 --
105 -- If @a@ is also a 'Monoid' we further require
106 --
107 -- @
108 -- ('<>') = 'mappend'
109 -- @
110 (<>) :: a -> a -> a
111
112 default (<>) :: Monoid a => a -> a -> a
113 (<>) = mappend
114
115 -- | Reduce a non-empty list with @\<\>@
116 --
117 -- The default definition should be sufficient, but this can be
118 -- overridden for efficiency.
119 --
120 sconcat :: NonEmpty a -> a
121 sconcat (a :| as) = go a as where
122 go b (c:cs) = b <> go c cs
123 go b [] = b
124
125 -- | Repeat a value @n@ times.
126 --
127 -- Given that this works on a 'Semigroup' it is allowed to fail if
128 -- you request 0 or fewer repetitions, and the default definition
129 -- will do so.
130 --
131 -- By making this a member of the class, idempotent semigroups and monoids can
132 -- upgrade this to execute in /O(1)/ by picking
133 -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@
134 -- respectively.
135 stimes :: Integral b => b -> a -> a
136 stimes y0 x0
137 | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected"
138 | otherwise = f x0 y0
139 where
140 f x y
141 | even y = f (x <> x) (y `quot` 2)
142 | y == 1 = x
143 | otherwise = g (x <> x) (pred y `quot` 2) x
144 g x y z
145 | even y = g (x <> x) (y `quot` 2) z
146 | y == 1 = x <> z
147 | otherwise = g (x <> x) (pred y `quot` 2) (x <> z)
148
149 -- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'.
150 -- May fail to terminate for some values in some semigroups.
151 cycle1 :: Semigroup m => m -> m
152 cycle1 xs = xs' where xs' = xs <> xs'
153
154 -- | @since 4.9.0.0
155 instance Semigroup () where
156 _ <> _ = ()
157 sconcat _ = ()
158 stimes _ _ = ()
159
160 -- | @since 4.9.0.0
161 instance Semigroup b => Semigroup (a -> b) where
162 f <> g = \a -> f a <> g a
163 stimes n f e = stimes n (f e)
164
165 -- | @since 4.9.0.0
166 instance Semigroup [a] where
167 (<>) = (++)
168 stimes n x
169 | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier"
170 | otherwise = rep n
171 where
172 rep 0 = []
173 rep i = x ++ rep (i - 1)
174
175 -- | @since 4.9.0.0
176 instance Semigroup a => Semigroup (Maybe a) where
177 Nothing <> b = b
178 a <> Nothing = a
179 Just a <> Just b = Just (a <> b)
180 stimes _ Nothing = Nothing
181 stimes n (Just a) = case compare n 0 of
182 LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier"
183 EQ -> Nothing
184 GT -> Just (stimes n a)
185
186 -- | @since 4.9.0.0
187 instance Semigroup (Either a b) where
188 Left _ <> b = b
189 a <> _ = a
190 stimes = stimesIdempotent
191
192 -- | @since 4.9.0.0
193 instance (Semigroup a, Semigroup b) => Semigroup (a, b) where
194 (a,b) <> (a',b') = (a<>a',b<>b')
195 stimes n (a,b) = (stimes n a, stimes n b)
196
197 -- | @since 4.9.0.0
198 instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where
199 (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')
200 stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c)
201
202 -- | @since 4.9.0.0
203 instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)
204 => Semigroup (a, b, c, d) where
205 (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')
206 stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d)
207
208 -- | @since 4.9.0.0
209 instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)
210 => Semigroup (a, b, c, d, e) where
211 (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')
212 stimes n (a,b,c,d,e) =
213 (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e)
214
215 -- | @since 4.9.0.0
216 instance Semigroup Ordering where
217 LT <> _ = LT
218 EQ <> y = y
219 GT <> _ = GT
220 stimes = stimesIdempotentMonoid
221
222 -- | @since 4.9.0.0
223 instance Semigroup a => Semigroup (Dual a) where
224 Dual a <> Dual b = Dual (b <> a)
225 stimes n (Dual a) = Dual (stimes n a)
226
227 -- | @since 4.9.0.0
228 instance Semigroup (Endo a) where
229 (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a))
230 stimes = stimesMonoid
231
232 -- | @since 4.9.0.0
233 instance Semigroup All where
234 (<>) = coerce (&&)
235 stimes = stimesIdempotentMonoid
236
237 -- | @since 4.9.0.0
238 instance Semigroup Any where
239 (<>) = coerce (||)
240 stimes = stimesIdempotentMonoid
241
242 -- | @since 4.11.0.0
243 instance Semigroup a => Semigroup (Down a) where
244 Down a <> Down b = Down (a <> b)
245 stimes n (Down a) = Down (stimes n a)
246
247
248 -- | @since 4.9.0.0
249 instance Num a => Semigroup (Sum a) where
250 (<>) = coerce ((+) :: a -> a -> a)
251 stimes n (Sum a) = Sum (fromIntegral n * a)
252
253 -- | @since 4.9.0.0
254 instance Num a => Semigroup (Product a) where
255 (<>) = coerce ((*) :: a -> a -> a)
256 stimes n (Product a) = Product (a ^ n)
257
258 -- | This is a valid definition of 'stimes' for a 'Monoid'.
259 --
260 -- Unlike the default definition of 'stimes', it is defined for 0
261 -- and so it should be preferred where possible.
262 stimesMonoid :: (Integral b, Monoid a) => b -> a -> a
263 stimesMonoid n x0 = case compare n 0 of
264 LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier"
265 EQ -> mempty
266 GT -> f x0 n
267 where
268 f x y
269 | even y = f (x `mappend` x) (y `quot` 2)
270 | y == 1 = x
271 | otherwise = g (x `mappend` x) (pred y `quot` 2) x
272 g x y z
273 | even y = g (x `mappend` x) (y `quot` 2) z
274 | y == 1 = x `mappend` z
275 | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z)
276
277 -- | This is a valid definition of 'stimes' for an idempotent 'Monoid'.
278 --
279 -- When @mappend x x = x@, this definition should be preferred, because it
280 -- works in /O(1)/ rather than /O(log n)/
281 stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a
282 stimesIdempotentMonoid n x = case compare n 0 of
283 LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier"
284 EQ -> mempty
285 GT -> x
286
287 -- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'.
288 --
289 -- When @x <> x = x@, this definition should be preferred, because it
290 -- works in /O(1)/ rather than /O(log n)/.
291 stimesIdempotent :: Integral b => b -> a -> a
292 stimesIdempotent n x
293 | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected"
294 | otherwise = x
295
296 -- | @since 4.9.0.0
297 instance Semigroup a => Semigroup (Identity a) where
298 (<>) = coerce ((<>) :: a -> a -> a)
299 stimes n (Identity a) = Identity (stimes n a)
300
301 -- | @since 4.9.0.0
302 instance Semigroup a => Semigroup (Const a b) where
303 (<>) = coerce ((<>) :: a -> a -> a)
304 stimes n (Const a) = Const (stimes n a)
305
306 -- | @since 4.9.0.0
307 instance Semigroup (Monoid.First a) where
308 Monoid.First Nothing <> b = b
309 a <> _ = a
310 stimes = stimesIdempotentMonoid
311
312 -- | @since 4.9.0.0
313 instance Semigroup (Monoid.Last a) where
314 a <> Monoid.Last Nothing = a
315 _ <> b = b
316 stimes = stimesIdempotentMonoid
317
318 -- | @since 4.9.0.0
319 instance Alternative f => Semigroup (Alt f a) where
320 (<>) = coerce ((<|>) :: f a -> f a -> f a)
321 stimes = stimesMonoid
322
323 -- | @since 4.9.0.0
324 instance Semigroup Void where
325 a <> _ = a
326 stimes = stimesIdempotent
327
328 -- | @since 4.9.0.0
329 instance Semigroup (NonEmpty a) where
330 (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs)
331
332
333 newtype Min a = Min { getMin :: a }
334 deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
335
336 -- | @since 4.9.0.0
337 instance Enum a => Enum (Min a) where
338 succ (Min a) = Min (succ a)
339 pred (Min a) = Min (pred a)
340 toEnum = Min . toEnum
341 fromEnum = fromEnum . getMin
342 enumFrom (Min a) = Min <$> enumFrom a
343 enumFromThen (Min a) (Min b) = Min <$> enumFromThen a b
344 enumFromTo (Min a) (Min b) = Min <$> enumFromTo a b
345 enumFromThenTo (Min a) (Min b) (Min c) = Min <$> enumFromThenTo a b c
346
347
348 -- | @since 4.9.0.0
349 instance Ord a => Semigroup (Min a) where
350 (<>) = coerce (min :: a -> a -> a)
351 stimes = stimesIdempotent
352
353 -- | @since 4.9.0.0
354 instance (Ord a, Bounded a) => Monoid (Min a) where
355 mempty = maxBound
356 mappend = (<>)
357
358 -- | @since 4.9.0.0
359 instance Functor Min where
360 fmap f (Min x) = Min (f x)
361
362 -- | @since 4.9.0.0
363 instance Foldable Min where
364 foldMap f (Min a) = f a
365
366 -- | @since 4.9.0.0
367 instance Traversable Min where
368 traverse f (Min a) = Min <$> f a
369
370 -- | @since 4.9.0.0
371 instance Applicative Min where
372 pure = Min
373 a <* _ = a
374 _ *> a = a
375 (<*>) = coerce
376 liftA2 = coerce
377
378 -- | @since 4.9.0.0
379 instance Monad Min where
380 (>>) = (*>)
381 Min a >>= f = f a
382
383 -- | @since 4.9.0.0
384 instance MonadFix Min where
385 mfix f = fix (f . getMin)
386
387 -- | @since 4.9.0.0
388 instance Num a => Num (Min a) where
389 (Min a) + (Min b) = Min (a + b)
390 (Min a) * (Min b) = Min (a * b)
391 (Min a) - (Min b) = Min (a - b)
392 negate (Min a) = Min (negate a)
393 abs (Min a) = Min (abs a)
394 signum (Min a) = Min (signum a)
395 fromInteger = Min . fromInteger
396
397 newtype Max a = Max { getMax :: a }
398 deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
399
400 -- | @since 4.9.0.0
401 instance Enum a => Enum (Max a) where
402 succ (Max a) = Max (succ a)
403 pred (Max a) = Max (pred a)
404 toEnum = Max . toEnum
405 fromEnum = fromEnum . getMax
406 enumFrom (Max a) = Max <$> enumFrom a
407 enumFromThen (Max a) (Max b) = Max <$> enumFromThen a b
408 enumFromTo (Max a) (Max b) = Max <$> enumFromTo a b
409 enumFromThenTo (Max a) (Max b) (Max c) = Max <$> enumFromThenTo a b c
410
411 -- | @since 4.9.0.0
412 instance Ord a => Semigroup (Max a) where
413 (<>) = coerce (max :: a -> a -> a)
414 stimes = stimesIdempotent
415
416 -- | @since 4.9.0.0
417 instance (Ord a, Bounded a) => Monoid (Max a) where
418 mempty = minBound
419 mappend = (<>)
420
421 -- | @since 4.9.0.0
422 instance Functor Max where
423 fmap f (Max x) = Max (f x)
424
425 -- | @since 4.9.0.0
426 instance Foldable Max where
427 foldMap f (Max a) = f a
428
429 -- | @since 4.9.0.0
430 instance Traversable Max where
431 traverse f (Max a) = Max <$> f a
432
433 -- | @since 4.9.0.0
434 instance Applicative Max where
435 pure = Max
436 a <* _ = a
437 _ *> a = a
438 (<*>) = coerce
439 liftA2 = coerce
440
441 -- | @since 4.9.0.0
442 instance Monad Max where
443 (>>) = (*>)
444 Max a >>= f = f a
445
446 -- | @since 4.9.0.0
447 instance MonadFix Max where
448 mfix f = fix (f . getMax)
449
450 -- | @since 4.9.0.0
451 instance Num a => Num (Max a) where
452 (Max a) + (Max b) = Max (a + b)
453 (Max a) * (Max b) = Max (a * b)
454 (Max a) - (Max b) = Max (a - b)
455 negate (Max a) = Max (negate a)
456 abs (Max a) = Max (abs a)
457 signum (Max a) = Max (signum a)
458 fromInteger = Max . fromInteger
459
460 -- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be
461 -- placed inside 'Min' and 'Max' to compute an arg min or arg max.
462 data Arg a b = Arg a b deriving
463 (Show, Read, Data, Generic, Generic1)
464
465 type ArgMin a b = Min (Arg a b)
466 type ArgMax a b = Max (Arg a b)
467
468 -- | @since 4.9.0.0
469 instance Functor (Arg a) where
470 fmap f (Arg x a) = Arg x (f a)
471
472 -- | @since 4.9.0.0
473 instance Foldable (Arg a) where
474 foldMap f (Arg _ a) = f a
475
476 -- | @since 4.9.0.0
477 instance Traversable (Arg a) where
478 traverse f (Arg x a) = Arg x <$> f a
479
480 -- | @since 4.9.0.0
481 instance Eq a => Eq (Arg a b) where
482 Arg a _ == Arg b _ = a == b
483
484 -- | @since 4.9.0.0
485 instance Ord a => Ord (Arg a b) where
486 Arg a _ `compare` Arg b _ = compare a b
487 min x@(Arg a _) y@(Arg b _)
488 | a <= b = x
489 | otherwise = y
490 max x@(Arg a _) y@(Arg b _)
491 | a >= b = x
492 | otherwise = y
493
494 -- | @since 4.9.0.0
495 instance Bifunctor Arg where
496 bimap f g (Arg a b) = Arg (f a) (g b)
497
498 -- | @since 4.10.0.0
499 instance Bifoldable Arg where
500 bifoldMap f g (Arg a b) = f a `mappend` g b
501
502 -- | @since 4.10.0.0
503 instance Bitraversable Arg where
504 bitraverse f g (Arg a b) = Arg <$> f a <*> g b
505
506 -- | Use @'Option' ('First' a)@ to get the behavior of
507 -- 'Data.Monoid.First' from "Data.Monoid".
508 newtype First a = First { getFirst :: a } deriving
509 (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
510
511 -- | @since 4.9.0.0
512 instance Enum a => Enum (First a) where
513 succ (First a) = First (succ a)
514 pred (First a) = First (pred a)
515 toEnum = First . toEnum
516 fromEnum = fromEnum . getFirst
517 enumFrom (First a) = First <$> enumFrom a
518 enumFromThen (First a) (First b) = First <$> enumFromThen a b
519 enumFromTo (First a) (First b) = First <$> enumFromTo a b
520 enumFromThenTo (First a) (First b) (First c) = First <$> enumFromThenTo a b c
521
522 -- | @since 4.9.0.0
523 instance Semigroup (First a) where
524 a <> _ = a
525 stimes = stimesIdempotent
526
527 -- | @since 4.9.0.0
528 instance Functor First where
529 fmap f (First x) = First (f x)
530
531 -- | @since 4.9.0.0
532 instance Foldable First where
533 foldMap f (First a) = f a
534
535 -- | @since 4.9.0.0
536 instance Traversable First where
537 traverse f (First a) = First <$> f a
538
539 -- | @since 4.9.0.0
540 instance Applicative First where
541 pure x = First x
542 a <* _ = a
543 _ *> a = a
544 (<*>) = coerce
545 liftA2 = coerce
546
547 -- | @since 4.9.0.0
548 instance Monad First where
549 (>>) = (*>)
550 First a >>= f = f a
551
552 -- | @since 4.9.0.0
553 instance MonadFix First where
554 mfix f = fix (f . getFirst)
555
556 -- | Use @'Option' ('Last' a)@ to get the behavior of
557 -- 'Data.Monoid.Last' from "Data.Monoid"
558 newtype Last a = Last { getLast :: a } deriving
559 (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
560
561 -- | @since 4.9.0.0
562 instance Enum a => Enum (Last a) where
563 succ (Last a) = Last (succ a)
564 pred (Last a) = Last (pred a)
565 toEnum = Last . toEnum
566 fromEnum = fromEnum . getLast
567 enumFrom (Last a) = Last <$> enumFrom a
568 enumFromThen (Last a) (Last b) = Last <$> enumFromThen a b
569 enumFromTo (Last a) (Last b) = Last <$> enumFromTo a b
570 enumFromThenTo (Last a) (Last b) (Last c) = Last <$> enumFromThenTo a b c
571
572 -- | @since 4.9.0.0
573 instance Semigroup (Last a) where
574 _ <> b = b
575 stimes = stimesIdempotent
576
577 -- | @since 4.9.0.0
578 instance Functor Last where
579 fmap f (Last x) = Last (f x)
580 a <$ _ = Last a
581
582 -- | @since 4.9.0.0
583 instance Foldable Last where
584 foldMap f (Last a) = f a
585
586 -- | @since 4.9.0.0
587 instance Traversable Last where
588 traverse f (Last a) = Last <$> f a
589
590 -- | @since 4.9.0.0
591 instance Applicative Last where
592 pure = Last
593 a <* _ = a
594 _ *> a = a
595 (<*>) = coerce
596 liftA2 = coerce
597
598 -- | @since 4.9.0.0
599 instance Monad Last where
600 (>>) = (*>)
601 Last a >>= f = f a
602
603 -- | @since 4.9.0.0
604 instance MonadFix Last where
605 mfix f = fix (f . getLast)
606
607 -- | Provide a Semigroup for an arbitrary Monoid.
608 newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m }
609 deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
610
611 -- | @since 4.9.0.0
612 instance Monoid m => Semigroup (WrappedMonoid m) where
613 (<>) = coerce (mappend :: m -> m -> m)
614
615 -- | @since 4.9.0.0
616 instance Monoid m => Monoid (WrappedMonoid m) where
617 mempty = WrapMonoid mempty
618 mappend = (<>)
619
620 -- | @since 4.9.0.0
621 instance Enum a => Enum (WrappedMonoid a) where
622 succ (WrapMonoid a) = WrapMonoid (succ a)
623 pred (WrapMonoid a) = WrapMonoid (pred a)
624 toEnum = WrapMonoid . toEnum
625 fromEnum = fromEnum . unwrapMonoid
626 enumFrom (WrapMonoid a) = WrapMonoid <$> enumFrom a
627 enumFromThen (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromThen a b
628 enumFromTo (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromTo a b
629 enumFromThenTo (WrapMonoid a) (WrapMonoid b) (WrapMonoid c) =
630 WrapMonoid <$> enumFromThenTo a b c
631
632 -- | Repeat a value @n@ times.
633 --
634 -- > mtimesDefault n a = a <> a <> ... <> a -- using <> (n-1) times
635 --
636 -- Implemented using 'stimes' and 'mempty'.
637 --
638 -- This is a suitable definition for an 'mtimes' member of 'Monoid'.
639 mtimesDefault :: (Integral b, Monoid a) => b -> a -> a
640 mtimesDefault n x
641 | n == 0 = mempty
642 | otherwise = unwrapMonoid (stimes n (WrapMonoid x))
643
644 -- | 'Option' is effectively 'Maybe' with a better instance of
645 -- 'Monoid', built off of an underlying 'Semigroup' instead of an
646 -- underlying 'Monoid'.
647 --
648 -- Ideally, this type would not exist at all and we would just fix the
649 -- 'Monoid' instance of 'Maybe'
650 newtype Option a = Option { getOption :: Maybe a }
651 deriving (Eq, Ord, Show, Read, Data, Generic, Generic1)
652
653 -- | @since 4.9.0.0
654 instance Functor Option where
655 fmap f (Option a) = Option (fmap f a)
656
657 -- | @since 4.9.0.0
658 instance Applicative Option where
659 pure a = Option (Just a)
660 Option a <*> Option b = Option (a <*> b)
661 liftA2 f (Option x) (Option y) = Option (liftA2 f x y)
662
663 Option Nothing *> _ = Option Nothing
664 _ *> b = b
665
666 -- | @since 4.9.0.0
667 instance Monad Option where
668 Option (Just a) >>= k = k a
669 _ >>= _ = Option Nothing
670 (>>) = (*>)
671
672 -- | @since 4.9.0.0
673 instance Alternative Option where
674 empty = Option Nothing
675 Option Nothing <|> b = b
676 a <|> _ = a
677
678 -- | @since 4.9.0.0
679 instance MonadPlus Option
680
681 -- | @since 4.9.0.0
682 instance MonadFix Option where
683 mfix f = Option (mfix (getOption . f))
684
685 -- | @since 4.9.0.0
686 instance Foldable Option where
687 foldMap f (Option (Just m)) = f m
688 foldMap _ (Option Nothing) = mempty
689
690 -- | @since 4.9.0.0
691 instance Traversable Option where
692 traverse f (Option (Just a)) = Option . Just <$> f a
693 traverse _ (Option Nothing) = pure (Option Nothing)
694
695 -- | Fold an 'Option' case-wise, just like 'maybe'.
696 option :: b -> (a -> b) -> Option a -> b
697 option n j (Option m) = maybe n j m
698
699 -- | @since 4.9.0.0
700 instance Semigroup a => Semigroup (Option a) where
701 (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a)
702
703 stimes _ (Option Nothing) = Option Nothing
704 stimes n (Option (Just a)) = case compare n 0 of
705 LT -> errorWithoutStackTrace "stimes: Option, negative multiplier"
706 EQ -> Option Nothing
707 GT -> Option (Just (stimes n a))
708
709 -- | @since 4.9.0.0
710 instance Semigroup a => Monoid (Option a) where
711 mempty = Option Nothing
712 mappend = (<>)
713
714 -- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'.
715 diff :: Semigroup m => m -> Endo m
716 diff = Endo . (<>)
717
718 -- | @since 4.9.0.0
719 instance Semigroup (Proxy s) where
720 _ <> _ = Proxy
721 sconcat _ = Proxy
722 stimes _ _ = Proxy
723
724 -- | @since 4.10.0.0
725 instance Semigroup a => Semigroup (IO a) where
726 (<>) = liftA2 (<>)
727
728 #ifndef mingw32_HOST_OS
729 -- | @since 4.10.0.0
730 instance Semigroup Event where
731 (<>) = mappend
732 stimes = stimesMonoid
733
734 -- | @since 4.10.0.0
735 instance Semigroup Lifetime where
736 (<>) = mappend
737 stimes = stimesMonoid
738 #endif