Commit 8ae263ce authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Make Semigroup a superclass of Monoid (re #14191)

Unfortunately, this requires introducing a couple of .hs-boot files to
break up import cycles (mostly to provide class & typenames in order to
be able to write type signatures).

This does not yet re-export `(<>)` from Prelude (while the class-name
`Semigroup` is reexported); that will happen in a future commit.

Test Plan: local ./validate passed

Reviewers: ekmett, austin, bgamari, erikd, RyanGlScott

Reviewed By: ekmett, RyanGlScott

GHC Trac Issues: #14191

Differential Revision: https://phabricator.haskell.org/D3927
parent 055d73c6
......@@ -471,7 +471,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_NATURAL, gHC_LIST,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, dATA_SEMIGROUP,
dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,
......@@ -502,8 +502,6 @@ dATA_EITHER = mkBaseModule (fsLit "Data.Either")
dATA_STRING = mkBaseModule (fsLit "Data.String")
dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable")
dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")
dATA_SEMIGROUP = mkBaseModule (fsLit "Data.Semigroup")
dATA_MONOID = mkBaseModule (fsLit "Data.Monoid")
gHC_CONC = mkBaseModule (fsLit "GHC.Conc")
gHC_IO = mkBaseModule (fsLit "GHC.IO")
gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")
......@@ -1020,8 +1018,8 @@ traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") trave
-- Classes (Semigroup, Monoid)
semigroupClassName, sappendName :: Name
semigroupClassName = clsQual dATA_SEMIGROUP (fsLit "Semigroup") semigroupClassKey
sappendName = varQual dATA_SEMIGROUP (fsLit "<>") sappendClassOpKey
semigroupClassName = clsQual gHC_BASE (fsLit "Semigroup") semigroupClassKey
sappendName = varQual gHC_BASE (fsLit "<>") sappendClassOpKey
monoidClassName, memptyName, mappendName, mconcatName :: Name
monoidClassName = clsQual gHC_BASE (fsLit "Monoid") monoidClassKey
memptyName = varQual gHC_BASE (fsLit "mempty") memptyClassOpKey
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
......@@ -131,6 +132,17 @@ instance Functor (Either a) where
fmap _ (Left x) = Left x
fmap f (Right y) = Right (f y)
-- | @since 4.9.0.0
instance Semigroup (Either a b) where
Left _ <> b = b
a <> _ = a
#if !defined(__HADDOCK_VERSION__)
-- workaround https://github.com/haskell/haddock/issues/680
stimes n x
| n <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected"
| otherwise = x
#endif
-- | @since 3.0
instance Applicative (Either e) where
pure = Right
......
......@@ -38,8 +38,8 @@ import GHC.Show (Show(showsPrec), showParen, showString)
-- | The 'Const' functor.
newtype Const a b = Const { getConst :: a }
deriving ( Bits, Bounded, Enum, Eq, FiniteBits, Floating, Fractional
, Generic, Generic1, Integral, Ix, Monoid, Num, Ord, Real
, RealFrac, RealFloat , Storable)
, Generic, Generic1, Integral, Ix, Semigroup, Monoid, Num, Ord
, Real, RealFrac, RealFloat, Storable)
-- | This instance would be equivalent to the derived instances of the
-- 'Const' newtype if the 'runConst' field were removed
......
......@@ -43,7 +43,7 @@ import Data.Functor.Utils ((#.))
import Foreign.Storable (Storable)
import GHC.Arr (Ix)
import GHC.Base ( Applicative(..), Eq(..), Functor(..), Monad(..)
, Monoid, Ord(..), ($), (.) )
, Semigroup, Monoid, Ord(..), ($), (.) )
import GHC.Enum (Bounded, Enum)
import GHC.Float (Floating, RealFloat)
import GHC.Generics (Generic, Generic1)
......@@ -58,7 +58,7 @@ import GHC.Types (Bool(..))
-- @since 4.8.0.0
newtype Identity a = Identity { runIdentity :: a }
deriving ( Bits, Bounded, Enum, Eq, FiniteBits, Floating, Fractional
, Generic, Generic1, Integral, Ix, Monoid, Num, Ord
, Generic, Generic1, Integral, Ix, Semigroup, Monoid, Num, Ord
, Real, RealFrac, RealFloat, Storable)
-- | This instance would be equivalent to the derived instances of the
......
......@@ -11,7 +11,7 @@ module Data.Functor.Utils where
import Data.Coerce (Coercible, coerce)
import GHC.Base ( Applicative(..), Functor(..), Maybe(..), Monoid(..), Ord(..)
, ($), otherwise )
, Semigroup(..), ($), otherwise )
-- We don't expose Max and Min because, as Edward Kmett pointed out to me,
-- there are two reasonable ways to define them. One way is to use Maybe, as we
......@@ -22,27 +22,31 @@ import GHC.Base ( Applicative(..), Functor(..), Maybe(..), Monoid(..), Ord(..)
newtype Max a = Max {getMax :: Maybe a}
newtype Min a = Min {getMin :: Maybe a}
-- | @since 4.11.0.0
instance Ord a => Semigroup (Max a) where
{-# INLINE (<>) #-}
m <> Max Nothing = m
Max Nothing <> n = n
(Max m@(Just x)) <> (Max n@(Just y))
| x >= y = Max m
| otherwise = Max n
-- | @since 4.8.0.0
instance Ord a => Monoid (Max a) where
mempty = Max Nothing
mempty = Max Nothing
{-# INLINE mappend #-}
m `mappend` Max Nothing = m
Max Nothing `mappend` n = n
(Max m@(Just x)) `mappend` (Max n@(Just y))
| x >= y = Max m
| otherwise = Max n
-- | @since 4.11.0.0
instance Ord a => Semigroup (Min a) where
{-# INLINE (<>) #-}
m <> Min Nothing = m
Min Nothing <> n = n
(Min m@(Just x)) <> (Min n@(Just y))
| x <= y = Min m
| otherwise = Min n
-- | @since 4.8.0.0
instance Ord a => Monoid (Min a) where
mempty = Min Nothing
{-# INLINE mappend #-}
m `mappend` Min Nothing = m
Min Nothing `mappend` n = n
(Min m@(Just x)) `mappend` (Min n@(Just y))
| x <= y = Min m
| otherwise = Min n
mempty = Min Nothing
-- left-to-right state transformer
newtype StateL s a = StateL { runStateL :: s -> (s, a) }
......
......@@ -43,148 +43,11 @@ module Data.Monoid (
-- 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'.
--
-- >>> getDual (mappend (Dual "Hello") (Dual "World"))
-- "WorldHello"
newtype Dual a = Dual { getDual :: a }
deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1)
-- | @since 2.01
instance Monoid a => Monoid (Dual a) where
mempty = Dual mempty
Dual x `mappend` Dual y = Dual (y `mappend` x)
-- | @since 4.8.0.0
instance Functor Dual where
fmap = coerce
-- | @since 4.8.0.0
instance Applicative Dual where
pure = Dual
(<*>) = coerce
-- | @since 4.8.0.0
instance Monad Dual where
m >>= k = k (getDual m)
-- | The monoid of endomorphisms under composition.
--
-- >>> let computation = Endo ("Hello, " ++) <> Endo (++ "!")
-- >>> appEndo computation "Haskell"
-- "Hello, Haskell!"
newtype Endo a = Endo { appEndo :: a -> a }
deriving (Generic)
-- | @since 2.01
instance Monoid (Endo a) where
mempty = Endo id
Endo f `mappend` Endo g = Endo (f . g)
-- | Boolean monoid under conjunction ('&&').
--
-- >>> getAll (All True <> mempty <> All False)
-- False
--
-- >>> getAll (mconcat (map (\x -> All (even x)) [2,4,6,7,8]))
-- False
newtype All = All { getAll :: Bool }
deriving (Eq, Ord, Read, Show, Bounded, Generic)
-- | @since 2.01
instance Monoid All where
mempty = All True
All x `mappend` All y = All (x && y)
-- | Boolean monoid under disjunction ('||').
--
-- >>> getAny (Any True <> mempty <> Any False)
-- True
--
-- >>> getAny (mconcat (map (\x -> Any (even x)) [2,4,6,7,8]))
-- True
newtype Any = Any { getAny :: Bool }
deriving (Eq, Ord, Read, Show, Bounded, Generic)
-- | @since 2.01
instance Monoid Any where
mempty = Any False
Any x `mappend` Any y = Any (x || y)
-- | Monoid under addition.
--
-- >>> getSum (Sum 1 <> Sum 2 <> mempty)
-- 3
newtype Sum a = Sum { getSum :: a }
deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)
-- | @since 2.01
instance Num a => Monoid (Sum a) where
mempty = Sum 0
mappend = coerce ((+) :: a -> a -> a)
-- Sum x `mappend` Sum y = Sum (x + y)
-- | @since 4.8.0.0
instance Functor Sum where
fmap = coerce
-- | @since 4.8.0.0
instance Applicative Sum where
pure = Sum
(<*>) = coerce
-- | @since 4.8.0.0
instance Monad Sum where
m >>= k = k (getSum m)
-- | Monoid under multiplication.
--
-- >>> getProduct (Product 3 <> Product 4 <> mempty)
-- 12
newtype Product a = Product { getProduct :: a }
deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)
-- | @since 2.01
instance Num a => Monoid (Product a) where
mempty = Product 1
mappend = coerce ((*) :: a -> a -> a)
-- Product x `mappend` Product y = Product (x * y)
-- | @since 4.8.0.0
instance Functor Product where
fmap = coerce
-- | @since 4.8.0.0
instance Applicative Product where
pure = Product
(<*>) = coerce
-- | @since 4.8.0.0
instance Monad Product where
m >>= k = k (getProduct m)
import Data.Semigroup.Internal
-- $MaybeExamples
-- To implement @find@ or @findLast@ on any 'Foldable':
......@@ -229,11 +92,15 @@ newtype First a = First { getFirst :: Maybe a }
deriving (Eq, Ord, Read, Show, Generic, Generic1,
Functor, Applicative, Monad)
-- | @since 4.9.0.0
instance Semigroup (First a) where
First Nothing <> b = b
a <> _ = a
stimes = stimesIdempotentMonoid
-- | @since 2.01
instance Monoid (First a) where
mempty = First Nothing
First Nothing `mappend` r = r
l `mappend` _ = l
-- | Maybe monoid returning the rightmost non-Nothing value.
--
......@@ -246,23 +113,17 @@ newtype Last a = Last { getLast :: Maybe a }
deriving (Eq, Ord, Read, Show, Generic, Generic1,
Functor, Applicative, Monad)
-- | @since 4.9.0.0
instance Semigroup (Last a) where
a <> Last Nothing = a
_ <> b = b
stimes = stimesIdempotentMonoid
-- | @since 2.01
instance Monoid (Last a) where
mempty = Last Nothing
l `mappend` Last Nothing = l
_ `mappend` r = r
-- | Monoid under '<|>'.
--
-- @since 4.8.0.0
newtype Alt f a = Alt {getAlt :: f a}
deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum,
Monad, MonadPlus, Applicative, Alternative, Functor)
-- | @since 4.8.0.0
instance Alternative f => Monoid (Alt f a) where
mempty = Alt empty
mappend = coerce ((<|>) :: f a -> f a -> f a)
{-
{--------------------------------------------------------------------
......
......@@ -52,6 +52,7 @@ newtype Down a = Down a
, Show -- ^ @since 4.7.0.0
, Read -- ^ @since 4.7.0.0
, Num -- ^ @since 4.11.0.0
, Semigroup -- ^ @since 4.11.0.0
, Monoid -- ^ @since 4.11.0.0
)
......
......@@ -98,10 +98,15 @@ instance Ix (Proxy s) where
unsafeIndex _ _ = 0
unsafeRangeSize _ = 1
-- | @since 4.9.0.0
instance Semigroup (Proxy s) where
_ <> _ = Proxy
sconcat _ = Proxy
stimes _ _ = Proxy
-- | @since 4.7.0.0
instance Monoid (Proxy s) where
mempty = Proxy
mappend _ _ = Proxy
mconcat _ = Proxy
-- | @since 4.7.0.0
......
......@@ -48,7 +48,6 @@ module Data.Semigroup (
, Last(..)
, WrappedMonoid(..)
-- * Re-exported monoids from Data.Monoid
, Monoid(..)
, Dual(..)
, Endo(..)
, All(..)
......@@ -69,267 +68,31 @@ module Data.Semigroup (
import Prelude hiding (foldr1)
import GHC.Base (Semigroup(..))
import Data.Semigroup.Internal
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Control.Monad.ST(ST)
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.Coerce
import Data.Data
import Data.Functor.Identity
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.Ord (Down(..))
import Data.Void
#if !defined(mingw32_HOST_OS)
import GHC.Event (Event, Lifetime)
#endif
-- import qualified Data.Monoid as Monoid
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'
-- | @since 4.9.0.0
instance Semigroup () where
_ <> _ = ()
sconcat _ = ()
stimes _ _ = ()
-- | @since 4.9.0.0
instance Semigroup b => Semigroup (a -> b) where
f <> g = \a -> f a <> g a
stimes n f e = stimes n (f e)
-- | @since 4.9.0.0
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)
-- | @since 4.9.0.0
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)
-- | @since 4.9.0.0
instance Semigroup (Either a b) where
Left _ <> b = b
a <> _ = a
stimes = stimesIdempotent
-- | @since 4.9.0.0
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)
-- | @since 4.9.0.0
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)
-- | @since 4.9.0.0
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)
-- | @since 4.9.0.0
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)
-- | @since 4.9.0.0
instance Semigroup Ordering where
LT <> _ = LT
EQ <> y = y
GT <> _ = GT
stimes = stimesIdempotentMonoid
-- | @since 4.9.0.0
instance Semigroup a => Semigroup (Dual a) where
Dual a <> Dual b = Dual (b <> a)
stimes n (Dual a) = Dual (stimes n a)
-- | @since 4.9.0.0
instance Semigroup (Endo a) where
(<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a))
stimes = stimesMonoid
-- | @since 4.9.0.0
instance Semigroup All where
(<>) = coerce (&&)
stimes = stimesIdempotentMonoid
-- | @since 4.9.0.0
instance Semigroup Any where
(<>) = coerce (||)
stimes = stimesIdempotentMonoid
-- | @since 4.11.0.0
instance Semigroup a => Semigroup (Down a) where
Down a <> Down b = Down (a <> b)
stimes n (Down a) = Down (stimes n a)
-- | @since 4.9.0.0
instance Num a => Semigroup (Sum a) where
(<>) = coerce ((+) :: a -> a -> a)
stimes n (Sum a) = Sum (fromIntegral n * a)
-- | @since 4.9.0.0
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
-- | @since 4.9.0.0
instance Semigroup a => Semigroup (Identity a) where
(<>) = coerce ((<>) :: a -> a -> a)
stimes n (Identity a) = Identity (stimes n a)
-- | @since 4.9.0.0
instance Semigroup a => Semigroup (Const a b) where