{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Semigroup -- Copyright : (C) 2011-2015 Edward Kmett -- License : BSD-style (see the file LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- -- A type @a@ is a 'Semigroup' if it provides an associative function ('<>') -- that lets you combine any two values of type @a@ into one. Where being -- associative means that the following must always hold: -- -- prop> (a <> b) <> c == a <> (b <> c) -- -- ==== __Examples__ -- -- The 'Min' 'Semigroup' instance for 'Int' is defined to always pick the smaller -- number: -- -- >>> Min 1 <> Min 2 <> Min 3 <> Min 4 :: Min Int -- Min {getMin = 1} -- -- If we need to combine multiple values we can use the 'sconcat' function -- to do so. We need to ensure however that we have at least one value to -- operate on, since otherwise our result would be undefined. It is for this -- reason that 'sconcat' uses "Data.List.NonEmpty.NonEmpty" - a list that -- can never be empty: -- -- >>> (1 :| []) -- 1 :| [] -- equivalent to [1] but guaranteed to be non-empty. -- -- >>> (1 :| [2, 3, 4]) -- 1 :| [2,3,4] -- equivalent to [1,2,3,4] but guaranteed to be non-empty. -- -- Equipped with this guaranteed to be non-empty data structure, we can combine -- values using 'sconcat' and a 'Semigroup' of our choosing. We can try the 'Min' -- and 'Max' instances of 'Int' which pick the smallest, or largest number -- respectively: -- -- >>> sconcat (1 :| [2, 3, 4]) :: Min Int -- Min {getMin = 1} -- -- >>> sconcat (1 :| [2, 3, 4]) :: Max Int -- Max {getMax = 4} -- -- String concatenation is another example of a 'Semigroup' instance: -- -- >>> "foo" <> "bar" -- "foobar" -- -- A 'Semigroup' is a generalization of a 'Monoid'. Yet unlike the 'Semigroup', the 'Monoid' -- requires the presence of a neutral element ('mempty') in addition to the associative -- operator. The requirement for a neutral element prevents many types from being a full Monoid, -- like "Data.List.NonEmpty.NonEmpty". -- -- Note that 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 -- -- @since 4.9.0.0 ---------------------------------------------------------------------------- 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(..) -- * Difference lists of a semigroup , diff , cycle1 -- * ArgMin, ArgMax , Arg(..) , ArgMin , ArgMax ) where import Prelude hiding (foldr1, Applicative(..)) import GHC.Base (Semigroup(..)) import Data.Semigroup.Internal import Control.Applicative import Control.Monad.Fix import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.Coerce import Data.Data import GHC.Generics import qualified GHC.List as List -- $setup -- >>> import Prelude -- >>> import Data.List.NonEmpty (NonEmpty (..)) -- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'. -- May fail to terminate for some values in some semigroups. -- -- ==== __Examples__ -- -- >>> take 10 $ cycle1 [1, 2, 3] -- [1,2,3,1,2,3,1,2,3,1] -- -- >>> cycle1 (Right 1) -- Right 1 -- -- >>> cycle1 (Left 1) -- * hangs forever * cycle1 :: Semigroup m => m -> m cycle1 xs = xs' where xs' = xs <> xs' -- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. -- -- ==== __Examples__ -- -- > let hello = diff "Hello, " -- -- >>> appEndo hello "World!" -- "Hello, World!" -- -- >>> appEndo (hello <> mempty) "World!" -- "Hello, World!" -- -- >>> appEndo (mempty <> hello) "World!" -- "Hello, World!" -- -- > let world = diff "World" -- > let excl = diff "!" -- -- >>> appEndo (hello <> (world <> excl)) mempty -- "Hello, World!" -- -- >>> appEndo ((hello <> world) <> excl) mempty -- "Hello, World!" diff :: Semigroup m => m -> Endo m diff = Endo . (<>) -- | The 'Min' 'Monoid' and 'Semigroup' always choose the smaller element as -- by the 'Ord' instance and 'min' of the contained type. -- -- ==== __Examples__ -- -- >>> Min 42 <> Min 3 -- Min 3 -- -- >>> sconcat $ Min 1 :| [ Min n | n <- [2 .. 100]] -- Min {getMin = 1} newtype Min a = Min { getMin :: a } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 , Ord -- ^ @since 4.9.0.0 , Show -- ^ @since 4.9.0.0 , Read -- ^ @since 4.9.0.0 , Data -- ^ @since 4.9.0.0 , Generic -- ^ @since 4.9.0.0 , Generic1 -- ^ @since 4.9.0.0 ) -- | @since 4.9.0.0 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 -- | @since 4.9.0.0 instance Ord a => Semigroup (Min a) where (<>) = coerce (min :: a -> a -> a) stimes = stimesIdempotent -- | @since 4.9.0.0 instance (Ord a, Bounded a) => Monoid (Min a) where mempty = maxBound -- By default, we would get a lazy right fold. This forces the use of a strict -- left fold instead. mconcat = List.foldl' (<>) mempty {-# INLINE mconcat #-} -- | @since 4.9.0.0 instance Functor Min where fmap f (Min x) = Min (f x) -- | @since 4.9.0.0 instance Foldable Min where foldMap f (Min a) = f a -- | @since 4.9.0.0 instance Traversable Min where traverse f (Min a) = Min <$> f a -- | @since 4.9.0.0 instance Applicative Min where pure = Min a <* _ = a _ *> a = a (<*>) = coerce liftA2 = coerce -- | @since 4.9.0.0 instance Monad Min where (>>) = (*>) Min a >>= f = f a -- | @since 4.9.0.0 instance MonadFix Min where mfix f = fix (f . getMin) -- | @since 4.9.0.0 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 -- | The 'Max' 'Monoid' and 'Semigroup' always choose the bigger element as -- by the 'Ord' instance and 'max' of the contained type. -- -- ==== __Examples__ -- -- >>> Max 42 <> Max 3 -- Max 42 -- -- >>> sconcat $ Max 1 :| [ Max n | n <- [2 .. 100]] -- Max {getMax = 100} newtype Max a = Max { getMax :: a } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 , Ord -- ^ @since 4.9.0.0 , Show -- ^ @since 4.9.0.0 , Read -- ^ @since 4.9.0.0 , Data -- ^ @since 4.9.0.0 , Generic -- ^ @since 4.9.0.0 , Generic1 -- ^ @since 4.9.0.0 ) -- | @since 4.9.0.0 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 -- | @since 4.9.0.0 instance Ord a => Semigroup (Max a) where (<>) = coerce (max :: a -> a -> a) stimes = stimesIdempotent -- | @since 4.9.0.0 instance (Ord a, Bounded a) => Monoid (Max a) where mempty = minBound -- By default, we would get a lazy right fold. This forces the use of a strict -- left fold instead. mconcat = List.foldl' (<>) mempty {-# INLINE mconcat #-} -- | @since 4.9.0.0 instance Functor Max where fmap f (Max x) = Max (f x) -- | @since 4.9.0.0 instance Foldable Max where foldMap f (Max a) = f a -- | @since 4.9.0.0 instance Traversable Max where traverse f (Max a) = Max <$> f a -- | @since 4.9.0.0 instance Applicative Max where pure = Max a <* _ = a _ *> a = a (<*>) = coerce liftA2 = coerce -- | @since 4.9.0.0 instance Monad Max where (>>) = (*>) Max a >>= f = f a -- | @since 4.9.0.0 instance MonadFix Max where mfix f = fix (f . getMax) -- | @since 4.9.0.0 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. -- -- ==== __Examples__ -- -- >>> minimum [ Arg (x * x) x | x <- [-10 .. 10] ] -- Arg 0 0 -- -- >>> maximum [ Arg (-0.2*x^2 + 1.5*x + 1) x | x <- [-10 .. 10] ] -- Arg 3.8 4.0 -- -- >>> minimum [ Arg (-0.2*x^2 + 1.5*x + 1) x | x <- [-10 .. 10] ] -- Arg (-34.0) (-10.0) data Arg a b = Arg a -- ^ The argument used for comparisons in 'Eq' and 'Ord'. b -- ^ The "value" exposed via the 'Functor', 'Foldable' etc. instances. deriving ( Show -- ^ @since 4.9.0.0 , Read -- ^ @since 4.9.0.0 , Data -- ^ @since 4.9.0.0 , Generic -- ^ @since 4.9.0.0 , Generic1 -- ^ @since 4.9.0.0 ) -- | -- ==== __Examples__ -- -- >>> Min (Arg 0 ()) <> Min (Arg 1 ()) -- Min {getMin = Arg 0 ()} -- -- >>> minimum [ Arg (length name) name | name <- ["violencia", "lea", "pixie"]] -- Arg 3 "lea" type ArgMin a b = Min (Arg a b) -- | -- ==== __Examples__ -- -- >>> Max (Arg 0 ()) <> Max (Arg 1 ()) -- Max {getMax = Arg 1 ()} -- -- >>> maximum [ Arg (length name) name | name <- ["violencia", "lea", "pixie"]] -- Arg 9 "violencia" type ArgMax a b = Max (Arg a b) -- | @since 4.9.0.0 instance Functor (Arg a) where fmap f (Arg x a) = Arg x (f a) -- | @since 4.9.0.0 instance Foldable (Arg a) where foldMap f (Arg _ a) = f a -- | @since 4.9.0.0 instance Traversable (Arg a) where traverse f (Arg x a) = Arg x <$> f a -- | @since 4.9.0.0 instance Eq a => Eq (Arg a b) where Arg a _ == Arg b _ = a == b -- | @since 4.9.0.0 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 -- | @since 4.9.0.0 instance Bifunctor Arg where bimap f g (Arg a b) = Arg (f a) (g b) -- | @since 4.10.0.0 instance Bifoldable Arg where bifoldMap f g (Arg a b) = f a <> g b -- | @since 4.10.0.0 instance Bitraversable Arg where bitraverse f g (Arg a b) = Arg <$> f a <*> g b -- | -- Beware that @Data.Semigroup.@'First' is different from -- @Data.Monoid.@'Data.Monoid.First'. The former simply returns the first value, -- so @Data.Semigroup.First Nothing <> x = Data.Semigroup.First Nothing@. -- The latter returns the first non-'Nothing', -- thus @Data.Monoid.First Nothing <> x = x@. -- -- ==== __Examples__ -- -- >>> First 0 <> First 10 -- First 0 -- -- >>> sconcat $ First 1 :| [ First n | n <- [2 ..] ] -- First 1 newtype First a = First { getFirst :: a } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 , Ord -- ^ @since 4.9.0.0 , Show -- ^ @since 4.9.0.0 , Read -- ^ @since 4.9.0.0 , Data -- ^ @since 4.9.0.0 , Generic -- ^ @since 4.9.0.0 , Generic1 -- ^ @since 4.9.0.0 ) -- | @since 4.9.0.0 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 -- | @since 4.9.0.0 instance Semigroup (First a) where a <> _ = a stimes = stimesIdempotent -- | @since 4.9.0.0 instance Functor First where fmap f (First x) = First (f x) -- | @since 4.9.0.0 instance Foldable First where foldMap f (First a) = f a -- | @since 4.9.0.0 instance Traversable First where traverse f (First a) = First <$> f a -- | @since 4.9.0.0 instance Applicative First where pure x = First x a <* _ = a _ *> a = a (<*>) = coerce liftA2 = coerce -- | @since 4.9.0.0 instance Monad First where (>>) = (*>) First a >>= f = f a -- | @since 4.9.0.0 instance MonadFix First where mfix f = fix (f . getFirst) -- | -- Beware that @Data.Semigroup.@'Last' is different from -- @Data.Monoid.@'Data.Monoid.Last'. The former simply returns the last value, -- so @x <> Data.Semigroup.Last Nothing = Data.Semigroup.Last Nothing@. -- The latter returns the last non-'Nothing', -- thus @x <> Data.Monoid.Last Nothing = x@. -- -- ==== __Examples__ -- -- >>> Last 0 <> Last 10 -- Last {getLast = 10} -- -- >>> sconcat $ Last 1 :| [ Last n | n <- [2..]] -- Last {getLast = * hangs forever * newtype Last a = Last { getLast :: a } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 , Ord -- ^ @since 4.9.0.0 , Show -- ^ @since 4.9.0.0 , Read -- ^ @since 4.9.0.0 , Data -- ^ @since 4.9.0.0 , Generic -- ^ @since 4.9.0.0 , Generic1 -- ^ @since 4.9.0.0 ) -- | @since 4.9.0.0 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 -- | @since 4.9.0.0 instance Semigroup (Last a) where _ <> b = b stimes = stimesIdempotent -- | @since 4.9.0.0 instance Functor Last where fmap f (Last x) = Last (f x) a <$ _ = Last a -- | @since 4.9.0.0 instance Foldable Last where foldMap f (Last a) = f a -- | @since 4.9.0.0 instance Traversable Last where traverse f (Last a) = Last <$> f a -- | @since 4.9.0.0 instance Applicative Last where pure = Last a <* _ = a _ *> a = a (<*>) = coerce liftA2 = coerce -- | @since 4.9.0.0 instance Monad Last where (>>) = (*>) Last a >>= f = f a -- | @since 4.9.0.0 instance MonadFix Last where mfix f = fix (f . getLast) -- | Provide a Semigroup for an arbitrary Monoid. -- -- __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. newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m } deriving ( Bounded -- ^ @since 4.9.0.0 , Eq -- ^ @since 4.9.0.0 , Ord -- ^ @since 4.9.0.0 , Show -- ^ @since 4.9.0.0 , Read -- ^ @since 4.9.0.0 , Data -- ^ @since 4.9.0.0 , Generic -- ^ @since 4.9.0.0 , Generic1 -- ^ @since 4.9.0.0 ) -- | @since 4.9.0.0 instance Monoid m => Semigroup (WrappedMonoid m) where (<>) = coerce (mappend :: m -> m -> m) -- | @since 4.9.0.0 instance Monoid m => Monoid (WrappedMonoid m) where mempty = WrapMonoid mempty -- This ensures that we use whatever mconcat is defined for the wrapped -- Monoid. mconcat = coerce (mconcat :: [m] -> m) -- | @since 4.9.0.0 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 -- -- In many cases, @'stimes' 0 a@ for a `Monoid` will produce `mempty`. -- However, there are situations when it cannot do so. In particular, -- the following situation is fairly common: -- -- @ -- data T a = ... -- -- class Constraint1 a -- class Constraint1 a => Constraint2 a -- @ -- -- @ -- instance Constraint1 a => 'Semigroup' (T a) -- instance Constraint2 a => 'Monoid' (T a) -- @ -- -- Since @Constraint1@ is insufficient to implement 'mempty', -- 'stimes' for @T a@ cannot do so. -- -- When working with such a type, or when working polymorphically with -- 'Semigroup' instances, @mtimesDefault@ should be used when the -- multiplier might be zero. It is implemented using 'stimes' when -- the multiplier is nonzero and 'mempty' when it is zero. -- -- ==== __Examples__ -- -- >>> mtimesDefault 0 "bark" -- [] -- -- >>> mtimesDefault 3 "meow" -- "meowmeowmeow" mtimesDefault :: (Integral b, Monoid a) => b -> a -> a mtimesDefault n x | n == 0 = mempty | otherwise = stimes n x