Data/Semigroup.hs

    {-# LANGUAGE DefaultSignatures   #-}
    {-# LANGUAGE DeriveDataTypeable  #-}
    {-# LANGUAGE DeriveGeneric       #-}
    {-# LANGUAGE FlexibleContexts    #-}
    {-# LANGUAGE PolyKinds           #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE Trustworthy         #-}
    {-# LANGUAGE TypeOperators       #-}

    -----------------------------------------------------------------------------
    -- |
    -- 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
    --
    -- @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
      , 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)

    import           Control.Applicative
    import           Control.Monad
    import           Control.Monad.Fix
    import           Data.Bifunctor
    import           Data.Coerce
    import           Data.Data
    import           Data.List.NonEmpty
    import           Data.Monoid         (All (..), Any (..), Dual (..), Endo (..),
                                          Product (..), Sum (..))
    import           Data.Monoid         (Alt (..))
    import qualified Data.Monoid         as Monoid
    import           Data.Void
    import           GHC.Generics

    infixr 6 <>

    -- | The class of semigroups (types with an associative binary operation).
    --
    -- @since 4.9.0.0
    class Semigroup a where
      -- | An associative operation.
      --
      -- @
      -- (a '<>' b) '<>' c = a '<>' (b '<>' c)
      -- @
      --
      -- If @a@ is also a 'Monoid' we further require
      --
      -- @
      -- ('<>') = 'mappend'
      -- @
      (<>) :: a -> a -> a

      default (<>) :: Monoid a => a -> a -> a
      (<>) = mappend

      -- | Reduce a non-empty list with @\<\>@
      --
      -- The default definition should be sufficient, but this can be
      -- overridden for efficiency.
      --
      sconcat :: NonEmpty a -> a
      sconcat (a :| as) = go a as where
        go b (c:cs) = b <> go c cs
        go b []     = b

      -- | Repeat a value @n@ times.
      --
      -- Given that this works on a 'Semigroup' it is allowed to fail if
      -- you request 0 or fewer repetitions, and the default definition
      -- will do so.
      --
      -- By making this a member of the class, idempotent semigroups and monoids can
      -- upgrade this to execute in /O(1)/ by picking
      -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@
      -- respectively.
      stimes :: Integral b => b -> a -> a
      stimes y0 x0
        | y0 <= 0   = errorWithoutStackTrace "stimes: positive multiplier expected"
        | otherwise = f x0 y0
        where
          f x y
            | even y = f (x <> x) (y `quot` 2)
            | y == 1 = x
            | otherwise = g (x <> x) (pred y  `quot` 2) x
          g x y z
            | even y = g (x <> x) (y `quot` 2) z
            | y == 1 = x <> z
            | otherwise = g (x <> x) (pred y `quot` 2) (x <> z)

    -- | 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'

    instance Semigroup () where
      _ <> _ = ()
      sconcat _ = ()
      stimes _ _ = ()

    instance Semigroup b => Semigroup (a -> b) where
      f <> g = \a -> f a <> g a
      stimes n f e = stimes n (f e)

    instance Semigroup [a] where
      (<>) = (++)
      stimes n x
        | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier"
        | otherwise = rep n
        where
          rep 0 = []
          rep i = x ++ rep (i - 1)

    instance Semigroup a => Semigroup (Maybe a) where
      Nothing <> b       = b
      a       <> Nothing = a
      Just a  <> Just b  = Just (a <> b)
      stimes _ Nothing  = Nothing
      stimes n (Just a) = case compare n 0 of
        LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier"
        EQ -> Nothing
        GT -> Just (stimes n a)

    instance Semigroup (Either a b) where
      Left _ <> b = b
      a      <> _ = a
      stimes = stimesIdempotent

    instance (Semigroup a, Semigroup b) => Semigroup (a, b) where
      (a,b) <> (a',b') = (a<>a',b<>b')
      stimes n (a,b) = (stimes n a, stimes n b)

    instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where
      (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')
      stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c)

    instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)
             => Semigroup (a, b, c, d) where
      (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')
      stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d)

    instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)
             => Semigroup (a, b, c, d, e) where
      (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')
      stimes n (a,b,c,d,e) =
          (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e)

    instance Semigroup Ordering where
      LT <> _ = LT
      EQ <> y = y
      GT <> _ = GT
      stimes = stimesIdempotentMonoid

    instance Semigroup a => Semigroup (Dual a) where
      Dual a <> Dual b = Dual (b <> a)
      stimes n (Dual a) = Dual (stimes n a)

    instance Semigroup (Endo a) where
      (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a))
      stimes = stimesMonoid

    instance Semigroup All where
      (<>) = coerce (&&)
      stimes = stimesIdempotentMonoid

    instance Semigroup Any where
      (<>) = coerce (||)
      stimes = stimesIdempotentMonoid

    instance Num a => Semigroup (Sum a) where
      (<>) = coerce ((+) :: a -> a -> a)
      stimes n (Sum a) = Sum (fromIntegral n * a)

    instance Num a => Semigroup (Product a) where
      (<>) = coerce ((*) :: a -> a -> a)
      stimes n (Product a) = Product (a ^ n)

    -- | This is a valid definition of 'stimes' for a 'Monoid'.
    --
    -- Unlike the default definition of 'stimes', it is defined for 0
    -- and so it should be preferred where possible.
    stimesMonoid :: (Integral b, Monoid a) => b -> a -> a
    stimesMonoid n x0 = case compare n 0 of
      LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier"
      EQ -> mempty
      GT -> f x0 n
        where
          f x y
            | even y = f (x `mappend` x) (y `quot` 2)
            | y == 1 = x
            | otherwise = g (x `mappend` x) (pred y  `quot` 2) x
          g x y z
            | even y = g (x `mappend` x) (y `quot` 2) z
            | y == 1 = x `mappend` z
            | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z)

    -- | This is a valid definition of 'stimes' for an idempotent 'Monoid'.
    --
    -- When @mappend x x = x@, this definition should be preferred, because it
    -- works in /O(1)/ rather than /O(log n)/
    stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a
    stimesIdempotentMonoid n x = case compare n 0 of
      LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier"
      EQ -> mempty
      GT -> x

    -- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'.
    --
    -- When @x <> x = x@, this definition should be preferred, because it
    -- works in /O(1)/ rather than /O(log n)/.
    stimesIdempotent :: Integral b => b -> a -> a
    stimesIdempotent n x
      | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected"
      | otherwise = x

    instance Semigroup a => Semigroup (Const a b) where
      (<>) = coerce ((<>) :: a -> a -> a)
      stimes n (Const a) = Const (stimes n a)

    instance Semigroup (Monoid.First a) where
      Monoid.First Nothing <> b = b
      a                    <> _ = a
      stimes = stimesIdempotentMonoid

    instance Semigroup (Monoid.Last a) where
      a <> Monoid.Last Nothing = a
      _ <> b                   = b
      stimes = stimesIdempotentMonoid

    instance Alternative f => Semigroup (Alt f a) where
      (<>) = coerce ((<|>) :: f a -> f a -> f a)
      stimes = stimesMonoid

    instance Semigroup Void where
      a <> _ = a
      stimes = stimesIdempotent

    instance Semigroup (NonEmpty a) where
      (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs)

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

    instance Bounded a => Bounded (Min a) where
      minBound = Min minBound
      maxBound = Min maxBound

    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

    instance Ord a => Semigroup (Min a) where
      (<>) = coerce (min :: a -> a -> a)
      stimes = stimesIdempotent

    instance (Ord a, Bounded a) => Monoid (Min a) where
      mempty = maxBound
      mappend = (<>)

    instance Functor Min where
      fmap f (Min x) = Min (f x)

    instance Foldable Min where
      foldMap f (Min a) = f a

    instance Traversable Min where
      traverse f (Min a) = Min <$> f a

    instance Applicative Min where
      pure = Min
      a <* _ = a
      _ *> a = a
      Min f <*> Min x = Min (f x)

    instance Monad Min where
      (>>) = (*>)
      Min a >>= f = f a

    instance MonadFix Min where
      mfix f = fix (f . getMin)

    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 }
      deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1)

    instance Bounded a => Bounded (Max a) where
      minBound = Max minBound
      maxBound = Max maxBound

    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

    instance Ord a => Semigroup (Max a) where
      (<>) = coerce (max :: a -> a -> a)
      stimes = stimesIdempotent

    instance (Ord a, Bounded a) => Monoid (Max a) where
      mempty = minBound
      mappend = (<>)

    instance Functor Max where
      fmap f (Max x) = Max (f x)

    instance Foldable Max where
      foldMap f (Max a) = f a

    instance Traversable Max where
      traverse f (Max a) = Max <$> f a

    instance Applicative Max where
      pure = Max
      a <* _ = a
      _ *> a = a
      Max f <*> Max x = Max (f x)

    instance Monad Max where
      (>>) = (*>)
      Max a >>= f = f a

    instance MonadFix Max where
      mfix f = fix (f . getMax)

    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
      (Show, Read, Data, Typeable, Generic, Generic1)

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

    instance Functor (Arg a) where
      fmap f (Arg x a) = Arg x (f a)

    instance Foldable (Arg a) where
      foldMap f (Arg _ a) = f a

    instance Traversable (Arg a) where
      traverse f (Arg x a) = Arg x <$> f a

    instance Eq a => Eq (Arg a b) where
      Arg a _ == Arg b _ = a == b

    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

    instance Bifunctor Arg where
      bimap f g (Arg a b) = Arg (f a) (g b)

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

    instance Bounded a => Bounded (First a) where
      minBound = First minBound
      maxBound = First maxBound

    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

    instance Semigroup (First a) where
      a <> _ = a
      stimes = stimesIdempotent

    instance Functor First where
      fmap f (First x) = First (f x)

    instance Foldable First where
      foldMap f (First a) = f a

    instance Traversable First where
      traverse f (First a) = First <$> f a

    instance Applicative First where
      pure x = First x
      a <* _ = a
      _ *> a = a
      First f <*> First x = First (f x)

    instance Monad First where
      (>>) = (*>)
      First a >>= f = f a

    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
      (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1)

    instance Bounded a => Bounded (Last a) where
      minBound = Last minBound
      maxBound = Last maxBound

    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

    instance Semigroup (Last a) where
      _ <> b = b
      stimes = stimesIdempotent

    instance Functor Last where
      fmap f (Last x) = Last (f x)
      a <$ _ = Last a

    instance Foldable Last where
      foldMap f (Last a) = f a

    instance Traversable Last where
      traverse f (Last a) = Last <$> f a

    instance Applicative Last where
      pure = Last
      a <* _ = a
      _ *> a = a
      Last f <*> Last x = Last (f x)

    instance Monad Last where
      (>>) = (*>)
      Last a >>= f = f a

    instance MonadFix Last where
      mfix f = fix (f . getLast)

    -- | Provide a Semigroup for an arbitrary Monoid.
    newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m }
      deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1)

    instance Monoid m => Semigroup (WrappedMonoid m) where
      (<>) = coerce (mappend :: m -> m -> m)

    instance Monoid m => Monoid (WrappedMonoid m) where
      mempty = WrapMonoid mempty
      mappend = (<>)

    instance Bounded a => Bounded (WrappedMonoid a) where
      minBound = WrapMonoid minBound
      maxBound = WrapMonoid maxBound

    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 }
      deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1)

    instance Functor Option where
      fmap f (Option a) = Option (fmap f a)

    instance Applicative Option where
      pure a = Option (Just a)
      Option a <*> Option b = Option (a <*> b)

      Option Nothing  *>  _ = Option Nothing
      _               *>  b = b

    instance Monad Option where
      Option (Just a) >>= k = k a
      _               >>= _ = Option Nothing
      (>>) = (*>)

    instance Alternative Option where
      empty = Option Nothing
      Option Nothing <|> b = b
      a <|> _ = a

    instance MonadPlus Option where
      mzero = Option Nothing
      mplus = (<|>)

    instance MonadFix Option where
      mfix f = Option (mfix (getOption . f))

    instance Foldable Option where
      foldMap f (Option (Just m)) = f m
      foldMap _ (Option Nothing)  = mempty

    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

    instance Semigroup a => Semigroup (Option a) where
      (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a)

      stimes _ (Option Nothing) = Option Nothing
      stimes n (Option (Just a)) = case compare n 0 of
        LT -> errorWithoutStackTrace "stimes: Option, negative multiplier"
        EQ -> Option Nothing
        GT -> Option (Just (stimes n a))

    instance Semigroup a => Monoid (Option a) where
      mempty = Option Nothing
      mappend = (<>)

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

    instance Semigroup (Proxy s) where
      _ <> _ = Proxy
      sconcat _ = Proxy
      stimes _ _ = Proxy