diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 1f9f8f33dfc91bf3159de75adb019236bc1a0222..b7cfb4f2262773e02768be97e3f8198bd2bec0a2 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -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 diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs index 2469e785111a888ced2d16802054c36e7f0a6a25..58a8020034c6da962f600f9038881b2a334e6948 100644 --- a/libraries/base/Data/Either.hs +++ b/libraries/base/Data/Either.hs @@ -1,3 +1,4 @@ +{-# 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 diff --git a/libraries/base/Data/Functor/Const.hs b/libraries/base/Data/Functor/Const.hs index 9199b7cf945f44b9f743f06129f8457e64d0091a..8a33e580ad62b1ed0cc40fc3176b0047bac9d619 100644 --- a/libraries/base/Data/Functor/Const.hs +++ b/libraries/base/Data/Functor/Const.hs @@ -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 diff --git a/libraries/base/Data/Functor/Identity.hs b/libraries/base/Data/Functor/Identity.hs index 1fe127f310cfc094b1c12cc2ede397a4893bca2d..41c32d0d1528573675577c16bf5d250d0494eed5 100644 --- a/libraries/base/Data/Functor/Identity.hs +++ b/libraries/base/Data/Functor/Identity.hs @@ -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 diff --git a/libraries/base/Data/Functor/Utils.hs b/libraries/base/Data/Functor/Utils.hs index 1bd729bcca2c8ab5d78551fbbd61ae7663e474b1..c6c2758c9d71ddfeca05d9d10e35f7484cac779a 100644 --- a/libraries/base/Data/Functor/Utils.hs +++ b/libraries/base/Data/Functor/Utils.hs @@ -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) } diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs index 2e8178460fbbf5dc586489bd287c5e8508198ebc..1284a078ce2b3199127b01d88593620788e7a24d 100644 --- a/libraries/base/Data/Monoid.hs +++ b/libraries/base/Data/Monoid.hs @@ -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) {- {-------------------------------------------------------------------- diff --git a/libraries/base/Data/Ord.hs b/libraries/base/Data/Ord.hs index 11d6967134f41a82328cebd108e052c9c7643ce7..2f5798cca280d6d39ab015179c7c4dd65c0effa9 100644 --- a/libraries/base/Data/Ord.hs +++ b/libraries/base/Data/Ord.hs @@ -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 ) diff --git a/libraries/base/Data/Proxy.hs b/libraries/base/Data/Proxy.hs index 2ebb4ab7b5de460e8a844a4c70a214b51db70ec4..4f824d0e3c8349ff7762da2e4f7121e78f8432d2 100644 --- a/libraries/base/Data/Proxy.hs +++ b/libraries/base/Data/Proxy.hs @@ -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 diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs index 8631b117be214def43d3a2a87d5d7d885e8059b8..4d06a40a6d7a85ed4c3cf46d5e5498b52c41c13c 100644 --- a/libraries/base/Data/Semigroup.hs +++ b/libraries/base/Data/Semigroup.hs @@ -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 - (<>) = coerce ((<>) :: a -> a -> a) - stimes n (Const a) = Const (stimes n a) - --- | @since 4.9.0.0 -instance Semigroup (Monoid.First a) where - Monoid.First Nothing <> b = b - a <> _ = a - stimes = stimesIdempotentMonoid - --- | @since 4.9.0.0 -instance Semigroup (Monoid.Last a) where - a <> Monoid.Last Nothing = a - _ <> b = b - stimes = stimesIdempotentMonoid - --- | @since 4.9.0.0 -instance Alternative f => Semigroup (Alt f a) where - (<>) = coerce ((<|>) :: f a -> f a -> f a) - stimes = stimesMonoid - --- | @since 4.9.0.0 -instance Semigroup Void where - a <> _ = a - stimes = stimesIdempotent - --- | @since 4.9.0.0 -instance Semigroup (NonEmpty a) where - (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs) - +-- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. +diff :: Semigroup m => m -> Endo m +diff = Endo . (<>) newtype Min a = Min { getMin :: a } deriving (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1) @@ -354,7 +117,6 @@ instance Ord a => Semigroup (Min a) where -- | @since 4.9.0.0 instance (Ord a, Bounded a) => Monoid (Min a) where mempty = maxBound - mappend = (<>) -- | @since 4.9.0.0 instance Functor Min where @@ -417,7 +179,6 @@ instance Ord a => Semigroup (Max a) where -- | @since 4.9.0.0 instance (Ord a, Bounded a) => Monoid (Max a) where mempty = minBound - mappend = (<>) -- | @since 4.9.0.0 instance Functor Max where @@ -498,7 +259,7 @@ instance Bifunctor Arg where -- | @since 4.10.0.0 instance Bifoldable Arg where - bifoldMap f g (Arg a b) = f a `mappend` g b + bifoldMap f g (Arg a b) = f a <> g b -- | @since 4.10.0.0 instance Bitraversable Arg where @@ -606,6 +367,9 @@ 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, Eq, Ord, Show, Read, Data, Generic, Generic1) @@ -616,7 +380,6 @@ instance Monoid m => Semigroup (WrappedMonoid m) where -- | @since 4.9.0.0 instance Monoid m => Monoid (WrappedMonoid m) where mempty = WrapMonoid mempty - mappend = (<>) -- | @since 4.9.0.0 instance Enum a => Enum (WrappedMonoid a) where @@ -700,44 +463,15 @@ option n j (Option m) = maybe n j m -- | @since 4.9.0.0 instance Semigroup a => Semigroup (Option a) where (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a) - +#if !defined(__HADDOCK_VERSION__) + -- workaround https://github.com/haskell/haddock/issues/680 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)) +#endif -- | @since 4.9.0.0 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 . (<>) - --- | @since 4.9.0.0 -instance Semigroup (Proxy s) where - _ <> _ = Proxy - sconcat _ = Proxy - stimes _ _ = Proxy - --- | @since 4.10.0.0 -instance Semigroup a => Semigroup (IO a) where - (<>) = liftA2 (<>) - --- | @since 4.11.0.0 -instance Semigroup a => Semigroup (ST s a) where - (<>) = liftA2 (<>) - -#if !defined(mingw32_HOST_OS) --- | @since 4.10.0.0 -instance Semigroup Event where - (<>) = mappend - stimes = stimesMonoid - --- | @since 4.10.0.0 -instance Semigroup Lifetime where - (<>) = mappend - stimes = stimesMonoid -#endif diff --git a/libraries/base/Data/Semigroup/Internal.hs b/libraries/base/Data/Semigroup/Internal.hs new file mode 100644 index 0000000000000000000000000000000000000000..3cdf54bb336aa1257b1a6fa0913e71b7b23a5e39 --- /dev/null +++ b/libraries/base/Data/Semigroup/Internal.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Auxilary definitions for 'Semigroup' +-- +-- This module provides some @newtype@ wrappers and helpers which are +-- reexported from the "Data.Semigroup" module or imported directly +-- by some other modules. +-- +-- This module also provides internal definitions related to the +-- 'Semigroup' class some. +-- +-- This module exists mostly to simplify or workaround import-graph +-- issues; there is also a .hs-boot file to allow "GHC.Base" and other +-- modules to import method default implementations for 'stimes' +-- +-- @since 4.11.0.0 +module Data.Semigroup.Internal where + +import GHC.Base hiding (Any) +import GHC.Enum +import GHC.Num +import GHC.Read +import GHC.Show +import GHC.Generics +import GHC.Real + +-- | 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 + +-- | 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 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 used by the class definitionin GHC.Base; +-- it lives here to avoid cycles +stimesDefault :: (Integral b, Semigroup a) => b -> a -> a +stimesDefault 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) + +stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a +stimesMaybe _ Nothing = Nothing +stimesMaybe n (Just a) = case compare n 0 of + LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier" + EQ -> Nothing + GT -> Just (stimes n a) + +stimesList :: Integral b => b -> [a] -> [a] +stimesList n x + | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier" + | otherwise = rep n + where + rep 0 = [] + rep i = x ++ rep (i - 1) + +-- | 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 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 2.01 +instance Monoid a => Monoid (Dual a) where + mempty = Dual mempty + +-- | @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 4.9.0.0 +instance Semigroup (Endo a) where + (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a)) + stimes = stimesMonoid + +-- | @since 2.01 +instance Monoid (Endo a) where + mempty = Endo id + +-- | 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 4.9.0.0 +instance Semigroup All where + (<>) = coerce (&&) + stimes = stimesIdempotentMonoid + +-- | @since 2.01 +instance Monoid All where + mempty = All True + +-- | 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 4.9.0.0 +instance Semigroup Any where + (<>) = coerce (||) + stimes = stimesIdempotentMonoid + +-- | @since 2.01 +instance Monoid Any where + mempty = Any False + +-- | 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 4.9.0.0 +instance Num a => Semigroup (Sum a) where + (<>) = coerce ((+) :: a -> a -> a) + stimes n (Sum a) = Sum (fromIntegral n * a) + +-- | @since 2.01 +instance Num a => Monoid (Sum a) where + mempty = Sum 0 + +-- | @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 4.9.0.0 +instance Num a => Semigroup (Product a) where + (<>) = coerce ((*) :: a -> a -> a) + stimes n (Product a) = Product (a ^ n) + + +-- | @since 2.01 +instance Num a => Monoid (Product a) where + mempty = Product 1 + +-- | @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) + + +-- | 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.9.0.0 +instance Alternative f => Semigroup (Alt f a) where + (<>) = coerce ((<|>) :: f a -> f a -> f a) + stimes = stimesMonoid + +-- | @since 4.8.0.0 +instance Alternative f => Monoid (Alt f a) where + mempty = Alt empty diff --git a/libraries/base/Data/Semigroup/Internal.hs-boot b/libraries/base/Data/Semigroup/Internal.hs-boot new file mode 100644 index 0000000000000000000000000000000000000000..645a088eb92e8547de1a208d3657c8da4173e8f9 --- /dev/null +++ b/libraries/base/Data/Semigroup/Internal.hs-boot @@ -0,0 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Semigroup.Internal where + +import {-# SOURCE #-} GHC.Real (Integral) +import {-# SOURCE #-} GHC.Base (Semigroup,Monoid,Maybe) + +stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a + +stimesDefault :: (Integral b, Semigroup a) => b -> a -> a +stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a +stimesList :: Integral b => b -> [a] -> [a] diff --git a/libraries/base/Data/Void.hs b/libraries/base/Data/Void.hs index d7fa1799b3ba7957a3fa7e944a0549ffbe6038da..ed3cfbc3306466cd4a04f2d57df2eab1d180a7e8 100644 --- a/libraries/base/Data/Void.hs +++ b/libraries/base/Data/Void.hs @@ -28,6 +28,7 @@ import Control.Exception import Data.Data import Data.Ix import GHC.Generics +import Data.Semigroup (Semigroup(..), stimesIdempotent) -- | Uninhabited data type -- @@ -64,6 +65,11 @@ instance Ix Void where -- | @since 4.8.0.0 instance Exception Void +-- | @since 4.9.0.0 +instance Semigroup Void where + a <> _ = a + stimes = stimesIdempotent + -- | Since 'Void' values logically don't exist, this witnesses the -- logical reasoning tool of \"ex falso quodlibet\". -- diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index 96f2d641bdd15bb27862a33ba783eb4e1048ef82..82b99a88c2742c963b5276a51ed488306de84164 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -129,6 +129,14 @@ import {-# SOURCE #-} GHC.IO (failIO,mplusIO) import GHC.Tuple () -- Note [Depend on GHC.Tuple] import GHC.Integer () -- Note [Depend on GHC.Integer] +-- for 'class Semigroup' +import {-# SOURCE #-} GHC.Real (Integral) +import {-# SOURCE #-} Data.Semigroup.Internal ( stimesDefault + , stimesMaybe + , stimesList + , stimesIdempotentMonoid + ) + infixr 9 . infixr 5 ++ infixl 4 <$ @@ -204,16 +212,53 @@ foldr = errorWithoutStackTrace "urk" data Maybe a = Nothing | Just a deriving (Eq, Ord) +infixr 6 <> + +-- | The class of semigroups (types with an associative binary operation). +-- +-- Instances should satisfy the associativity law: +-- +-- * @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ +-- +-- @since 4.9.0.0 +class Semigroup a where + -- | An associative operation. + (<>) :: a -> a -> a + + -- | 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 = stimesDefault + + -- | The class of monoids (types with an associative binary operation that -- has an identity). Instances should satisfy the following laws: -- --- * @'mappend' 'mempty' x = x@ +-- * @x '<>' 'mempty' = x@ -- --- * @'mappend' x 'mempty' = x@ +-- * @'mempty' '<>' x = x@ -- --- * @'mappend' x ('mappend' y z) = 'mappend' ('mappend' x y) z@ +-- * @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ ('Semigroup' law) -- --- * @'mconcat' = 'foldr' 'mappend' 'mempty'@ +-- * @'mconcat' = 'foldr' '(<>)' 'mempty'@ -- -- The method names refer to the monoid of lists under concatenation, -- but there are many other instances. @@ -222,27 +267,39 @@ data Maybe a = Nothing | Just a -- e.g. both addition and multiplication on numbers. -- In such cases we often define @newtype@s and make those instances -- of 'Monoid', e.g. 'Sum' and 'Product'. - -class Monoid a where +-- +-- __NOTE__: 'Semigroup' is a superclass of 'Monoid' since /base-4.11.0.0/. +class Semigroup a => Monoid a where + -- | Identity of 'mappend' mempty :: a - -- ^ Identity of 'mappend' + + -- | An associative operation + -- + -- __NOTE__: This method is redundant and has the default + -- implementation @'mappend' = '(<>)'@ since /base-4.11.0.0/. mappend :: a -> a -> a - -- ^ An associative operation - mconcat :: [a] -> a + mappend = (<>) + {-# INLINE mappend #-} - -- ^ Fold a list using the monoid. + -- | Fold a list using the monoid. + -- -- For most types, the default definition for 'mconcat' will be -- used, but the function is included in the class definition so -- that an optimized version can be provided for specific types. - + mconcat :: [a] -> a mconcat = foldr mappend mempty +-- | @since 4.9.0.0 +instance Semigroup [a] where + (<>) = (++) + {-# INLINE (<>) #-} + + stimes = stimesList + -- | @since 2.01 instance Monoid [a] where {-# INLINE mempty #-} mempty = [] - {-# INLINE mappend #-} - mappend = (++) {-# INLINE mconcat #-} mconcat xss = [x | xs <- xss, x <- xs] -- See Note: [List comprehensions and inlining] @@ -266,52 +323,92 @@ needed to make foldr/build forms efficient are turned off, we'll get reasonably efficient translations anyway. -} +-- | @since 4.9.0.0 +instance Semigroup (NonEmpty a) where + (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs) + +-- | @since 4.9.0.0 +instance Semigroup b => Semigroup (a -> b) where + f <> g = \x -> f x <> g x + stimes n f e = stimes n (f e) + -- | @since 2.01 instance Monoid b => Monoid (a -> b) where mempty _ = mempty - mappend f g x = f x `mappend` g x + +-- | @since 4.9.0.0 +instance Semigroup () where + _ <> _ = () + sconcat _ = () + stimes _ _ = () -- | @since 2.01 instance Monoid () where -- Should it be strict? mempty = () - _ `mappend` _ = () mconcat _ = () +-- | @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 2.01 instance (Monoid a, Monoid b) => Monoid (a,b) where mempty = (mempty, mempty) - (a1,b1) `mappend` (a2,b2) = - (a1 `mappend` a2, b1 `mappend` b2) + +-- | @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 2.01 instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where mempty = (mempty, mempty, mempty) - (a1,b1,c1) `mappend` (a2,b2,c2) = - (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2) + +-- | @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 2.01 instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where mempty = (mempty, mempty, mempty, mempty) - (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) = - (a1 `mappend` a2, b1 `mappend` b2, - c1 `mappend` c2, d1 `mappend` d2) + +-- | @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 2.01 instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) => Monoid (a,b,c,d,e) where mempty = (mempty, mempty, mempty, mempty, mempty) - (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) = - (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2, - d1 `mappend` d2, e1 `mappend` e2) + + +-- | @since 4.9.0.0 +instance Semigroup Ordering where + LT <> _ = LT + EQ <> y = y + GT <> _ = GT + + stimes = stimesIdempotentMonoid -- lexicographical ordering -- | @since 2.01 instance Monoid Ordering where - mempty = EQ - LT `mappend` _ = LT - EQ `mappend` y = y - GT `mappend` _ = GT + mempty = EQ + +-- | @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 = stimesMaybe -- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to -- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be @@ -322,10 +419,7 @@ instance Monoid Ordering where -- -- @since 2.01 instance Monoid a => Monoid (Maybe a) where - mempty = Nothing - Nothing `mappend` m = m - m `mappend` Nothing = m - Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) + mempty = Nothing -- | For tuples, the 'Monoid' constraint on @a@ determines -- how the first values merge. @@ -337,17 +431,20 @@ instance Monoid a => Monoid (Maybe a) where -- @since 2.01 instance Monoid a => Applicative ((,) a) where pure x = (mempty, x) - (u, f) <*> (v, x) = (u `mappend` v, f x) - liftA2 f (u, x) (v, y) = (u `mappend` v, f x y) + (u, f) <*> (v, x) = (u <> v, f x) + liftA2 f (u, x) (v, y) = (u <> v, f x y) -- | @since 4.9.0.0 instance Monoid a => Monad ((,) a) where - (u, a) >>= k = case k a of (v, b) -> (u `mappend` v, b) + (u, a) >>= k = case k a of (v, b) -> (u <> v, b) + +-- | @since 4.10.0.0 +instance Semigroup a => Semigroup (IO a) where + (<>) = liftA2 (<>) -- | @since 4.9.0.0 instance Monoid a => Monoid (IO a) where mempty = pure mempty - mappend = liftA2 mappend {- | The 'Functor' class is used for types that can be mapped over. Instances of 'Functor' should satisfy the following laws: diff --git a/libraries/base/GHC/Base.hs-boot b/libraries/base/GHC/Base.hs-boot new file mode 100644 index 0000000000000000000000000000000000000000..ca85b49147eebf3d39239b67f7a0d88f651c7be2 --- /dev/null +++ b/libraries/base/GHC/Base.hs-boot @@ -0,0 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Base where + +import GHC.Types () + +class Semigroup a +class Monoid a + +data Maybe a = Nothing | Just a diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs index 9b8230c032511a2b3e16f447e560625e2f322b0e..b7befdda254bd7ab87d8973477010121df773950 100644 --- a/libraries/base/GHC/Event/Internal.hs +++ b/libraries/base/GHC/Event/Internal.hs @@ -36,6 +36,7 @@ import GHC.Base import GHC.Word (Word64) import GHC.Num (Num(..)) import GHC.Show (Show(..)) +import Data.Semigroup.Internal (stimesMonoid) -- | An I\/O event. newtype Event = Event Int @@ -72,10 +73,14 @@ instance Show Event where where ev `so` disp | e `eventIs` ev = disp | otherwise = "" +-- | @since 4.10.0.0 +instance Semigroup Event where + (<>) = evtCombine + stimes = stimesMonoid + -- | @since 4.3.1.0 instance Monoid Event where mempty = evtNothing - mappend = evtCombine mconcat = evtConcat evtCombine :: Event -> Event -> Event @@ -100,12 +105,16 @@ elSupremum OneShot OneShot = OneShot elSupremum _ _ = MultiShot {-# INLINE elSupremum #-} +-- | @since 4.10.0.0 +instance Semigroup Lifetime where + (<>) = elSupremum + stimes = stimesMonoid + -- | @mappend@ takes the longer of two lifetimes. -- -- @since 4.8.0.0 instance Monoid Lifetime where mempty = OneShot - mappend = elSupremum -- | A pair of an event and lifetime -- @@ -114,10 +123,13 @@ instance Monoid Lifetime where newtype EventLifetime = EL Int deriving (Show, Eq) +-- | @since 4.11.0.0 +instance Semigroup EventLifetime where + EL a <> EL b = EL (a .|. b) + -- | @since 4.8.0.0 instance Monoid EventLifetime where mempty = EL 0 - EL a `mappend` EL b = EL (a .|. b) eventLifetime :: Event -> Lifetime -> EventLifetime eventLifetime (Event e) l = EL (e .|. lifetimeBit l) diff --git a/libraries/base/GHC/Real.hs-boot b/libraries/base/GHC/Real.hs-boot new file mode 100644 index 0000000000000000000000000000000000000000..b462c1c2995c535c2d637cfa463d8a9d51c80e37 --- /dev/null +++ b/libraries/base/GHC/Real.hs-boot @@ -0,0 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Real where + +import GHC.Types () + +class Integral a diff --git a/libraries/base/GHC/ST.hs b/libraries/base/GHC/ST.hs index a245b9fc502ff6355778c4fb3a4b849a46b800c5..9f8bb6489f3997ace5ef168f2a3f2cbdde56469b 100644 --- a/libraries/base/GHC/ST.hs +++ b/libraries/base/GHC/ST.hs @@ -77,10 +77,13 @@ instance Monad (ST s) where case (k r) of { ST k2 -> (k2 new_s) }}) +-- | @since 4.11.0.0 +instance Semigroup a => Semigroup (ST s a) where + (<>) = liftA2 (<>) + -- | @since 4.11.0.0 instance Monoid a => Monoid (ST s a) where mempty = pure mempty - mappend = liftA2 mappend data STret s a = STret (State# s) a diff --git a/libraries/base/Prelude.hs b/libraries/base/Prelude.hs index 158cc0a8ff292c905847b822b40393916db7f7e3..75a0d5341d40aa725d37d9b4ad03b27310c0c32f 100644 --- a/libraries/base/Prelude.hs +++ b/libraries/base/Prelude.hs @@ -66,7 +66,8 @@ module Prelude ( subtract, even, odd, gcd, lcm, (^), (^^), fromIntegral, realToFrac, - -- ** Monoids + -- ** Semigroups and Monoids + Semigroup, -- TODO: export (<>) Monoid(mempty, mappend, mconcat), -- ** Monads and functors diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 4bbe2f2d5119f73870148754859710473c36d730..df5efa8d7c0551c5a9b35244f13fead17d8c0ef5 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -317,6 +317,7 @@ Library Control.Monad.ST.Lazy.Imp Data.Functor.Utils Data.OldList + Data.Semigroup.Internal Data.Typeable.Internal Foreign.ForeignPtr.Imp GHC.StaticPtr.Internal diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index a8915cbbeb34b1e7d2cd21134caf7121a220222a..b9b1756c36e5ca8d3b167a529ecb29aabc14a813 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -8,6 +8,12 @@ * Add instances `Num`, `Functor`, `Applicative`, `Monad`, `Semigroup` and `Monoid` for `Data.Ord.Down` (#13097). + * Add `Semigroup` instance for `EventLifetime`. + + * Make `Semigroup` a superclass of `Monoid`; + export `Semigroup` from `Prelude`; remove `Monoid` reexport + from `Data.Semigroup` (#14191). + * Add `infixl 9 !!` declaration for `Data.List.NonEmpty.!!` * Add `<&>` operator to `Data.Functor` (#14029) diff --git a/testsuite/tests/ghci/scripts/T10963.script b/testsuite/tests/ghci/scripts/T10963.script index 357d1256ba315c2304aff5439653d1eef08c609d..2bba5b36ef56bd1d268a0357213a93b4ebc277e9 100644 --- a/testsuite/tests/ghci/scripts/T10963.script +++ b/testsuite/tests/ghci/scripts/T10963.script @@ -3,5 +3,7 @@ :t +d length let foo :: (Num a, Monoid a) => a -> a; foo = undefined :t +d foo -instance Monoid Double where mempty = 0; mappend = (+) +import Data.Semigroup +instance Semigroup Double where (<>) = (+) +instance Monoid Double where mempty = 0 :t +d foo diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index 6f56a5f86884c1e0564272e143aa2e555f51ee2d..7b630f1ed9b97e427f49382f41d2b2232353015e 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -21,6 +21,7 @@ instance C () -- Defined at T4175.hs:21:10 instance Eq () -- Defined in ‘GHC.Classes’ instance Monoid () -- Defined in ‘GHC.Base’ instance Ord () -- Defined in ‘GHC.Classes’ +instance Semigroup () -- Defined in ‘GHC.Base’ instance Show () -- Defined in ‘GHC.Show’ instance Read () -- Defined in ‘GHC.Read’ instance Enum () -- Defined in ‘GHC.Enum’ @@ -35,6 +36,8 @@ instance Functor Maybe -- Defined in ‘GHC.Base’ instance Monad Maybe -- Defined in ‘GHC.Base’ instance Monoid a => Monoid (Maybe a) -- Defined in ‘GHC.Base’ instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’ +instance Semigroup a => Semigroup (Maybe a) + -- Defined in ‘GHC.Base’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’ instance Foldable Maybe -- Defined in ‘Data.Foldable’ diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout index c13a3f3ba059397f4c1343c5a44e01254b80f883..ff4e67005ee2be443195fd76351e5a009633b4df 100644 --- a/testsuite/tests/ghci/scripts/T7627.stdout +++ b/testsuite/tests/ghci/scripts/T7627.stdout @@ -2,6 +2,7 @@ data () = () -- Defined in ‘GHC.Tuple’ instance Eq () -- Defined in ‘GHC.Classes’ instance Monoid () -- Defined in ‘GHC.Base’ instance Ord () -- Defined in ‘GHC.Classes’ +instance Semigroup () -- Defined in ‘GHC.Base’ instance Show () -- Defined in ‘GHC.Show’ instance Read () -- Defined in ‘GHC.Read’ instance Enum () -- Defined in ‘GHC.Enum’ @@ -19,6 +20,8 @@ instance Monoid a => Monad ((,) a) -- Defined in ‘GHC.Base’ instance (Monoid a, Monoid b) => Monoid (a, b) -- Defined in ‘GHC.Base’ instance (Ord a, Ord b) => Ord (a, b) -- Defined in ‘GHC.Classes’ +instance (Semigroup a, Semigroup b) => Semigroup (a, b) + -- Defined in ‘GHC.Base’ instance (Show a, Show b) => Show (a, b) -- Defined in ‘GHC.Show’ instance (Read a, Read b) => Read (a, b) -- Defined in ‘GHC.Read’ instance Foldable ((,) a) -- Defined in ‘Data.Foldable’ diff --git a/testsuite/tests/ghci/scripts/T8535.stdout b/testsuite/tests/ghci/scripts/T8535.stdout index 3995bc0b20d89fff67e23bc7d059dcd80ae6cab5..873b992a38427cc20bb54d71be9b5434d71e5d8a 100644 --- a/testsuite/tests/ghci/scripts/T8535.stdout +++ b/testsuite/tests/ghci/scripts/T8535.stdout @@ -4,3 +4,4 @@ instance Applicative ((->) a) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ instance Monad ((->) r) -- Defined in ‘GHC.Base’ instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/scripts/T9881.stdout b/testsuite/tests/ghci/scripts/T9881.stdout index 18fa4d521f071ae70a0b4ace8cea355d75b4fe80..68acea7c61275026fb65698a68eee43875378123 100644 --- a/testsuite/tests/ghci/scripts/T9881.stdout +++ b/testsuite/tests/ghci/scripts/T9881.stdout @@ -9,6 +9,8 @@ instance Monoid Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ instance Ord Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ +instance Semigroup Data.ByteString.Lazy.ByteString + -- Defined in ‘Data.ByteString.Lazy.Internal’ instance Show Data.ByteString.Lazy.ByteString -- Defined in ‘Data.ByteString.Lazy.Internal’ instance Read Data.ByteString.Lazy.ByteString @@ -26,6 +28,8 @@ instance Monoid Data.ByteString.ByteString -- Defined in ‘Data.ByteString.Internal’ instance Ord Data.ByteString.ByteString -- Defined in ‘Data.ByteString.Internal’ +instance Semigroup Data.ByteString.ByteString + -- Defined in ‘Data.ByteString.Internal’ instance Show Data.ByteString.ByteString -- Defined in ‘Data.ByteString.Internal’ instance Read Data.ByteString.ByteString diff --git a/testsuite/tests/ghci/scripts/ghci011.stdout b/testsuite/tests/ghci/scripts/ghci011.stdout index 372930d66d2cf731b01d7edd93d0e48dabb3dca6..7bd58dcc246e4fd84e91c02a486cf233b8ce4b97 100644 --- a/testsuite/tests/ghci/scripts/ghci011.stdout +++ b/testsuite/tests/ghci/scripts/ghci011.stdout @@ -5,6 +5,7 @@ instance Functor [] -- Defined in ‘GHC.Base’ instance Monad [] -- Defined in ‘GHC.Base’ instance Monoid [a] -- Defined in ‘GHC.Base’ instance Ord a => Ord [a] -- Defined in ‘GHC.Classes’ +instance Semigroup [a] -- Defined in ‘GHC.Base’ instance Show a => Show [a] -- Defined in ‘GHC.Show’ instance Read a => Read [a] -- Defined in ‘GHC.Read’ instance Foldable [] -- Defined in ‘Data.Foldable’ @@ -13,6 +14,7 @@ data () = () -- Defined in ‘GHC.Tuple’ instance Eq () -- Defined in ‘GHC.Classes’ instance Monoid () -- Defined in ‘GHC.Base’ instance Ord () -- Defined in ‘GHC.Classes’ +instance Semigroup () -- Defined in ‘GHC.Base’ instance Show () -- Defined in ‘GHC.Show’ instance Read () -- Defined in ‘GHC.Read’ instance Enum () -- Defined in ‘GHC.Enum’ @@ -25,6 +27,8 @@ instance Monoid a => Monad ((,) a) -- Defined in ‘GHC.Base’ instance (Monoid a, Monoid b) => Monoid (a, b) -- Defined in ‘GHC.Base’ instance (Ord a, Ord b) => Ord (a, b) -- Defined in ‘GHC.Classes’ +instance (Semigroup a, Semigroup b) => Semigroup (a, b) + -- Defined in ‘GHC.Base’ instance (Show a, Show b) => Show (a, b) -- Defined in ‘GHC.Show’ instance (Read a, Read b) => Read (a, b) -- Defined in ‘GHC.Read’ instance Foldable ((,) a) -- Defined in ‘Data.Foldable’ diff --git a/testsuite/tests/ghci/scripts/ghci020.stdout b/testsuite/tests/ghci/scripts/ghci020.stdout index 3995bc0b20d89fff67e23bc7d059dcd80ae6cab5..873b992a38427cc20bb54d71be9b5434d71e5d8a 100644 --- a/testsuite/tests/ghci/scripts/ghci020.stdout +++ b/testsuite/tests/ghci/scripts/ghci020.stdout @@ -4,3 +4,4 @@ instance Applicative ((->) a) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ instance Monad ((->) r) -- Defined in ‘GHC.Base’ instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/should_run/T10145.stdout b/testsuite/tests/ghci/should_run/T10145.stdout index 3995bc0b20d89fff67e23bc7d059dcd80ae6cab5..873b992a38427cc20bb54d71be9b5434d71e5d8a 100644 --- a/testsuite/tests/ghci/should_run/T10145.stdout +++ b/testsuite/tests/ghci/should_run/T10145.stdout @@ -4,3 +4,4 @@ instance Applicative ((->) a) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ instance Monad ((->) r) -- Defined in ‘GHC.Base’ instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’ +instance Semigroup b => Semigroup (a -> b) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index d309f6c48a8030efc831cd8488b196766dcde674..7227ebfe52935bd386c078fc9497377578cab043 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -1040,13 +1040,14 @@ test('T12234', # initial: 83032768 # 2017-02-19 89180624 (x64/Windows) - Unknown # 2017-02-25 79889200 (x64/Windows) - Early inline patch - (wordsize(64), 80245640, 5), + (wordsize(64), 81696664, 5), # initial: 72958288 # 2016-01-17: 76848856 (x86-64, Linux. drift?) # 2017-02-01: 80882208 (Use superclass instances when solving) # 2017-02-05: 74374440 (Probably OccAnal fixes) # 2017-02-17: 86525344 (Type-indexed Typeable) # 2017-02-25: 83032768 (Early inline patch) + # 2017-09-07: 81696664 (Semigroup=>Monoid patch, D3927) ]), ], compile, diff --git a/testsuite/tests/perf/should_run/T4978.hs b/testsuite/tests/perf/should_run/T4978.hs index b661edc483ad91aa6897dbedbc79dee45a7b60bc..9324b72be0f55a8c731ab43e938a7b4d6826b691 100644 --- a/testsuite/tests/perf/should_run/T4978.hs +++ b/testsuite/tests/perf/should_run/T4978.hs @@ -4,6 +4,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal (inlinePerformIO) import qualified Data.ByteString.Internal as S +import Data.Semigroup import Data.Monoid import Foreign import System.IO.Unsafe @@ -12,11 +13,13 @@ newtype Builder = Builder { runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] } +instance Semigroup Builder where + (<>) = append + {-# INLINE (<>) #-} + instance Monoid Builder where mempty = empty {-# INLINE mempty #-} - mappend = append - {-# INLINE mappend #-} mconcat = foldr mappend mempty {-# INLINE mconcat #-} diff --git a/testsuite/tests/polykinds/MonoidsFD.hs b/testsuite/tests/polykinds/MonoidsFD.hs index f093d77663aec704d2a78176034ffc1d392eaf90..67be60d60ac5977ea5906a704abdb9dcc2d7a3f7 100644 --- a/testsuite/tests/polykinds/MonoidsFD.hs +++ b/testsuite/tests/polykinds/MonoidsFD.hs @@ -15,6 +15,7 @@ module Main where import Control.Monad (Monad(..), join, ap) import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) -- First we define the type class Monoidy: @@ -81,9 +82,11 @@ test2 = print (Sum 1 <+> Sum 2 <+> Sum 4) -- Sum 7 -- rather cumbersome in actual use. So, we can give traditional Monad and -- Monoid instances for instances of Monoidy: +instance Monoidy (→) (,) () m ⇒ Semigroup m where + (<>) = curry mjoin + instance Monoidy (→) (,) () m ⇒ Monoid m where mempty = munit () - mappend = curry mjoin instance Applicative Wrapper where pure = return diff --git a/testsuite/tests/polykinds/MonoidsTF.hs b/testsuite/tests/polykinds/MonoidsTF.hs index 9097e53af224b80751c7fa2be1cabc019fbb3835..365c3766bc9ffc6b8c39127618ec734a44430057 100644 --- a/testsuite/tests/polykinds/MonoidsTF.hs +++ b/testsuite/tests/polykinds/MonoidsTF.hs @@ -14,6 +14,7 @@ module Main where import Control.Monad (Monad(..), join, ap, liftM) import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) -- First we define the type class Monoidy: @@ -91,10 +92,13 @@ test2 = print (Sum 1 <+> Sum 2 <+> Sum 4) -- Sum 7 -- rather cumbersome in actual use. So, we can give traditional Monad and -- Monoid instances for instances of Monoidy: -instance (MId (→) m ~ (), MComp (→) m ~ (,), Monoidy (→) m) +instance (MId (→) m ~ (), MComp (→) m ~ (,), Monoidy (→) m) + ⇒ Semigroup m where + (<>) = curry mjoin + +instance (MId (→) m ~ (), MComp (→) m ~ (,), Monoidy (→) m) ⇒ Monoid m where mempty = munit () - mappend = curry mjoin instance Applicative Wrapper where pure = return diff --git a/testsuite/tests/polykinds/T7332.hs b/testsuite/tests/polykinds/T7332.hs index 0d3e7e5a132e02ec9df9c52444c6f83207367e03..75a6cbc991f0393bc267c6aa9fbc907945f55b66 100644 --- a/testsuite/tests/polykinds/T7332.hs +++ b/testsuite/tests/polykinds/T7332.hs @@ -9,9 +9,10 @@ module T7332 where import GHC.Exts( IsString(..) ) import Data.Monoid +import Data.Semigroup newtype DC d = DC d - deriving (Show, Monoid) + deriving (Show, Semigroup, Monoid) instance IsString (DC String) where fromString = DC diff --git a/testsuite/tests/semigroup/Makefile b/testsuite/tests/semigroup/Makefile deleted file mode 100644 index 9a36a1c5fee5849898f7c20c59672b9268409e4a..0000000000000000000000000000000000000000 --- a/testsuite/tests/semigroup/Makefile +++ /dev/null @@ -1,3 +0,0 @@ -TOP=../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk diff --git a/testsuite/tests/semigroup/SemigroupWarnings.hs b/testsuite/tests/semigroup/SemigroupWarnings.hs deleted file mode 100644 index 83ae2cf1807105556a7d56f4c84657f26e11ffa4..0000000000000000000000000000000000000000 --- a/testsuite/tests/semigroup/SemigroupWarnings.hs +++ /dev/null @@ -1,34 +0,0 @@ --- Test purpose: --- Ensure that missing semigroup warnings are issued --- correctly if the warning flag is enabled - -{-# OPTIONS_GHC -fwarn-semigroup #-} - -module SemigroupWarnings where - - - -import Data.Semigroup - - - --- Bad instance, should complain about missing Semigroup parent -data LacksSemigroup -instance Monoid LacksSemigroup where - mempty = undefined - mappend = undefined - - - --- Correct instance, should not warn -data HasSemigroup -instance Semigroup HasSemigroup where - (<>) = undefined -instance Monoid HasSemigroup where - mempty = undefined - mappend = undefined - - - --- Should issue a Prelude clash warning -(<>) = undefined diff --git a/testsuite/tests/semigroup/SemigroupWarnings.stderr b/testsuite/tests/semigroup/SemigroupWarnings.stderr deleted file mode 100644 index 277fea66ffb0f0ae0a5b8e3577d057e738de29a3..0000000000000000000000000000000000000000 --- a/testsuite/tests/semigroup/SemigroupWarnings.stderr +++ /dev/null @@ -1,8 +0,0 @@ - -SemigroupWarnings.hs:17:10: warning: [-Wsemigroup (in -Wcompat)] - ‘LacksSemigroup’ is an instance of Monoid but not Semigroup. - This will become an error in a future release. - -SemigroupWarnings.hs:34:1: warning: [-Wsemigroup (in -Wcompat)] - Local definition of ‘<>’ clashes with a future Prelude name. - This will become an error in a future release. diff --git a/testsuite/tests/semigroup/all.T b/testsuite/tests/semigroup/all.T deleted file mode 100644 index 0b1c3b987866a426f644ba133b4404f6efe27b97..0000000000000000000000000000000000000000 --- a/testsuite/tests/semigroup/all.T +++ /dev/null @@ -1 +0,0 @@ -test('SemigroupWarnings', normal, compile, ['']) diff --git a/testsuite/tests/simplCore/should_run/T13429a.hs b/testsuite/tests/simplCore/should_run/T13429a.hs index 6a838cb79c576efe40b656af5f2e03c43d944cd5..718f26520a6f980b9b198cd03aec7a877c0b6df2 100644 --- a/testsuite/tests/simplCore/should_run/T13429a.hs +++ b/testsuite/tests/simplCore/should_run/T13429a.hs @@ -5,6 +5,8 @@ {-# LANGUAGE UndecidableInstances #-} module T13429a where -- Orignally FingerTree.hs from the ticket +import Data.Semigroup (Semigroup(..)) + class (Monoid v) => Measured v a | a -> v where measure :: a -> v @@ -32,9 +34,11 @@ instance Foldable (FingerTree v) where foldMap f (Deep _ pr m sf) = foldMap f pr `mappend` foldMap (foldMap f) m `mappend` foldMap f sf +instance Measured v a => Semigroup (FingerTree v a) where + (<>) = (><) + instance Measured v a => Monoid (FingerTree v a) where mempty = empty - mappend = (><) empty :: Measured v a => FingerTree v a empty = Empty diff --git a/testsuite/tests/typecheck/should_run/T6117.hs b/testsuite/tests/typecheck/should_run/T6117.hs index 2fe9f292910427ceb701a8e43d01a1f0d9df23d4..33e81c7b5987b92b721fb59465c07d11370dda6b 100644 --- a/testsuite/tests/typecheck/should_run/T6117.hs +++ b/testsuite/tests/typecheck/should_run/T6117.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} +import Prelude hiding (Semigroup(..)) + {- [Summary of the program] Ring is defined as a subclass of Semigroup, inheriting multiplication. Additive is a wrapper that extracts the additive diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs index 64a19e5cf938fc6585f61145bb6ad418c4085130..707e153a8d4ea34cbe7547ef066782361cd6b361 100644 --- a/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs +++ b/testsuite/tests/wcompat-warnings/WCompatWarningsNotOn.hs @@ -21,6 +21,6 @@ newtype S = S Int instance Semi.Semigroup S where (<>) = mappend -instance Semi.Monoid S where +instance Monoid S where S a `mappend` S b = S (a+b) mempty = S 0 diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs index 6ed25f1ef75876248663fc8fdadfad5703758606..777c11cd70de14e39f19d8b44ebe735811877168 100644 --- a/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs +++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOff.hs @@ -21,6 +21,6 @@ newtype S = S Int instance Semi.Semigroup S where (<>) = mappend -instance Semi.Monoid S where +instance Monoid S where S a `mappend` S b = S (a+b) mempty = S 0 diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs index c155f37f425e46669869393f4b94558266ba534f..6d67ed039faef8eac7b9e545aedbfc6b1ec9b310 100644 --- a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs +++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.hs @@ -21,6 +21,6 @@ newtype S = S Int instance Semi.Semigroup S where (<>) = mappend -instance Semi.Monoid S where +instance Monoid S where S a `mappend` S b = S (a+b) mempty = S 0 diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr index 571a24119ab041efd01526e26336c1ed712b9666..c62780f0b7407646b4ae73e415d804837c97e3d4 100644 --- a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr +++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr @@ -26,7 +26,7 @@ WCompatWarningsOn.hs:16:1: warning: [-Wsemigroup (in -Wcompat)] WCompatWarningsOn.hs:22:3: warning: [-Wnoncanonical-monoid-instances (in -Wcompat)] Noncanonical ‘(<>) = mappend’ definition detected - in the instance declaration for ‘Semi.Semigroup S’. + in the instance declaration for ‘Semigroup S’. Move definition from ‘mappend’ to ‘(<>)’ WCompatWarningsOn.hs:25:3: warning: [-Wnoncanonical-monoid-instances (in -Wcompat)] diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs b/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs index 44f554ee47f82ff661a323a74d24735681243a2e..e6a4aa3efb771b9fd23fe96f165ec317637a3d7c 100644 --- a/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs +++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOnOff.hs @@ -21,6 +21,6 @@ newtype S = S Int instance Semi.Semigroup S where (<>) = mappend -instance Semi.Monoid S where +instance Monoid S where S a `mappend` S b = S (a+b) mempty = S 0