(original) (raw)

{-# 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](GHC.Base.html#mappend) x) (y [quot](GHC.Real.html#quot) 2) | y == 1 = x | otherwise = g (x [mappend](GHC.Base.html#mappend) x) (y [quot](GHC.Real.html#quot) 2) x
g x y z | even y = g (x [mappend](GHC.Base.html#mappend) x) (y [quot](GHC.Real.html#quot) 2) z | y == 1 = x [mappend](GHC.Base.html#mappend) z | otherwise = g (x [mappend](GHC.Base.html#mappend) x) (y [quot](GHC.Real.html#quot) 2) (x [mappend](GHC.Base.html#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](GHC.Real.html#quot) 2) | y == 1 = x | otherwise = g (x <> x) (y [quot](GHC.Real.html#quot) 2) x
g x y z | even y = g (x <> x) (y [quot](GHC.Real.html#quot) 2) z | y == 1 = x <> z | otherwise = g (x <> x) (y [quot](GHC.Real.html#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