{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
stimesIdempotent :: Integral b => b -> a -> a
stimesIdempotent n x
| n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected"
| otherwise = x
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
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) (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) (y `quot` 2) (x `mappend` z)
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) (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) (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)
newtype Dual a = Dual { getDual :: a }
deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1)
instance Semigroup a => Semigroup (Dual a) where
Dual a <> Dual b = Dual (b <> a)
stimes n (Dual a) = Dual (stimes n a)
instance Monoid a => Monoid (Dual a) where
mempty = Dual mempty
instance Functor Dual where
fmap = coerce
instance Applicative Dual where
pure = Dual
(<*>) = coerce
instance Monad Dual where
m >>= k = k (getDual m)
newtype Endo a = Endo { appEndo :: a -> a }
deriving (Generic)
instance Semigroup (Endo a) where
(<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a))
stimes = stimesMonoid
instance Monoid (Endo a) where
mempty = Endo id
newtype All = All { getAll :: Bool }
deriving (Eq, Ord, Read, Show, Bounded, Generic)
instance Semigroup All where
(<>) = coerce (&&)
stimes = stimesIdempotentMonoid
instance Monoid All where
mempty = All True
newtype Any = Any { getAny :: Bool }
deriving (Eq, Ord, Read, Show, Bounded, Generic)
instance Semigroup Any where
(<>) = coerce (||)
stimes = stimesIdempotentMonoid
instance Monoid Any where
mempty = Any False
newtype Sum a = Sum { getSum :: a }
deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)
instance Num a => Semigroup (Sum a) where
(<>) = coerce ((+) :: a -> a -> a)
stimes n (Sum a) = Sum (fromIntegral n * a)
instance Num a => Monoid (Sum a) where
mempty = Sum 0
instance Functor Sum where
fmap = coerce
instance Applicative Sum where
pure = Sum
(<*>) = coerce
instance Monad Sum where
m >>= k = k (getSum m)
newtype Product a = Product { getProduct :: a }
deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)
instance Num a => Semigroup (Product a) where
(<>) = coerce ((*) :: a -> a -> a)
stimes n (Product a) = Product (a ^ n)
instance Num a => Monoid (Product a) where
mempty = Product 1
instance Functor Product where
fmap = coerce
instance Applicative Product where
pure = Product
(<*>) = coerce
instance Monad Product where
m >>= k = k (getProduct m)
newtype Alt f a = Alt {getAlt :: f a}
deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum,
Monad, MonadPlus, Applicative, Alternative, Functor)
instance Alternative f => Semigroup (Alt f a) where
(<>) = coerce ((<|>) :: f a -> f a -> f a)
stimes = stimesMonoid
instance Alternative f => Monoid (Alt f a) where
mempty = Alt empty