module Data.Semigroup (
Semigroup(..)
, stimesMonoid
, stimesIdempotent
, stimesIdempotentMonoid
, mtimesDefault
, Min(..)
, Max(..)
, First(..)
, Last(..)
, WrappedMonoid(..)
, Monoid(..)
, Dual(..)
, Endo(..)
, All(..)
, Any(..)
, Sum(..)
, Product(..)
, Option(..)
, option
, diff
, cycle1
, Arg(..)
, ArgMin
, ArgMax
) where
import Prelude hiding (foldr1)
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
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.Void
#ifndef mingw32_HOST_OS
import GHC.Event (Event, Lifetime)
#endif
import GHC.Generics
infixr 6 <>
class Semigroup a where
(<>) :: a -> a -> a
default (<>) :: Monoid a => a -> a -> a
(<>) = mappend
sconcat :: NonEmpty a -> a
sconcat (a :| as) = go a as where
go b (c:cs) = b <> go c cs
go b [] = b
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)
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)
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)
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
stimesIdempotent :: Integral b => b -> a -> a
stimesIdempotent n x
| n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected"
| otherwise = x
instance Semigroup a => Semigroup (Identity a) where
(<>) = coerce ((<>) :: a -> a -> a)
stimes n (Identity a) = Identity (stimes n a)
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 (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
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
(<*>) = coerce
liftA2 = coerce
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 (Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
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
(<*>) = coerce
liftA2 = coerce
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
data Arg a b = Arg a b deriving
(Show, Read, Data, 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)
instance Bifoldable Arg where
bifoldMap f g (Arg a b) = f a `mappend` g b
instance Bitraversable Arg where
bitraverse f g (Arg a b) = Arg <$> f a <*> g b
newtype First a = First { getFirst :: a } deriving
(Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
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
(<*>) = coerce
liftA2 = coerce
instance Monad First where
(>>) = (*>)
First a >>= f = f a
instance MonadFix First where
mfix f = fix (f . getFirst)
newtype Last a = Last { getLast :: a } deriving
(Bounded, Eq, Ord, Show, Read, Data, Generic, Generic1)
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
(<*>) = coerce
liftA2 = coerce
instance Monad Last where
(>>) = (*>)
Last a >>= f = f a
instance MonadFix Last where
mfix f = fix (f . getLast)
newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m }
deriving (Bounded, Eq, Ord, Show, Read, Data, 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 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
mtimesDefault :: (Integral b, Monoid a) => b -> a -> a
mtimesDefault n x
| n == 0 = mempty
| otherwise = unwrapMonoid (stimes n (WrapMonoid x))
newtype Option a = Option { getOption :: Maybe a }
deriving (Eq, Ord, Show, Read, Data, 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)
liftA2 f (Option x) (Option y) = Option (liftA2 f x y)
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
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)
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 = (<>)
diff :: Semigroup m => m -> Endo m
diff = Endo . (<>)
instance Semigroup (Proxy s) where
_ <> _ = Proxy
sconcat _ = Proxy
stimes _ _ = Proxy
instance Semigroup a => Semigroup (IO a) where
(<>) = liftA2 (<>)
#ifndef mingw32_HOST_OS
instance Semigroup Event where
(<>) = mappend
stimes = stimesMonoid
instance Semigroup Lifetime where
(<>) = mappend
stimes = stimesMonoid
#endif