{-# 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.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 $$\mathcal{O}(1)$$ rather than $$\mathcal{O}(\log n)$$.
stimesIdempotent :: Integral b => b -> a -> a
stimesIdempotent :: b -> a -> a
stimesIdempotent b
n a
x
| b
n b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
0 = [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"stimesIdempotent: positive multiplier expected"
| Bool
otherwise = a
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 $$\mathcal{O}(1)$$ rather than $$\mathcal{O}(\log n)$$
stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a
stimesIdempotentMonoid :: b -> a -> a
stimesIdempotentMonoid b
n a
x = case b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare b
n b
0 of
Ordering
LT -> [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"stimesIdempotentMonoid: negative multiplier"
Ordering
EQ -> a
forall a. Monoid a => a
mempty
Ordering
GT -> a
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 :: b -> a -> a
stimesMonoid b
n a
x0 = case b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare b
n b
0 of
Ordering
LT -> [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"stimesMonoid: negative multiplier"
Ordering
EQ -> a
forall a. Monoid a => a
mempty
Ordering
GT -> a -> b -> a
forall a a. (Integral a, Monoid a) => a -> a -> a
f a
x0 b
n
where
f :: a -> a -> a
f a
x a
y
| a -> Bool
forall a. Integral a => a -> Bool
even a
y = a -> a -> a
f (a
x a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
quot a
2)
| a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 = a
x
| Bool
otherwise = a -> a -> a -> a
forall a a. (Integral a, Monoid a) => a -> a -> a -> a
g (a
x a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
quot a
2) a
x               -- See Note [Half of y - 1]
g :: a -> a -> a -> a
g a
x a
y a
z
| a -> Bool
forall a. Integral a => a -> Bool
even a
y = a -> a -> a -> a
g (a
x a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
quot a
2) a
z
| a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 = a
x a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
z
| Bool
otherwise = a -> a -> a -> a
g (a
x a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
quot a
2) (a
x a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
z) -- See Note [Half of y - 1]

-- this is used by the class definitionin GHC.Base;
-- it lives here to avoid cycles
stimesDefault :: (Integral b, Semigroup a) => b -> a -> a
stimesDefault :: b -> a -> a
stimesDefault b
y0 a
x0
| b
y0 b -> b -> Bool
forall a. Ord a => a -> a -> Bool
<= b
0   = [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"stimes: positive multiplier expected"
| Bool
otherwise = a -> b -> a
forall a a. (Integral a, Semigroup a) => a -> a -> a
f a
x0 b
y0
where
f :: a -> a -> a
f a
x a
y
| a -> Bool
forall a. Integral a => a -> Bool
even a
y = a -> a -> a
f (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
quot a
2)
| a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 = a
x
| Bool
otherwise = a -> a -> a -> a
forall a a. (Integral a, Semigroup a) => a -> a -> a -> a
g (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
quot a
2) a
x        -- See Note [Half of y - 1]
g :: a -> a -> a -> a
g a
x a
y a
z
| a -> Bool
forall a. Integral a => a -> Bool
even a
y = a -> a -> a -> a
g (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
quot a
2) a
z
| a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 = a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
z
| Bool
otherwise = a -> a -> a -> a
g (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
quot a
2) (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
z) -- See Note [Half of y - 1]

{- Note [Half of y - 1]
~~~~~~~~~~~~~~~~~~~~~
Since y is guaranteed to be odd and positive here,
half of y - 1 can be computed as y quot 2, optimising subtraction away.
-}

stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a
stimesMaybe :: b -> Maybe a -> Maybe a
stimesMaybe b
_ Maybe a
Nothing = Maybe a
forall a. Maybe a
Nothing
stimesMaybe b
n (Just a
a) = case b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare b
n b
0 of
Ordering
LT -> [Char] -> Maybe a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"stimes: Maybe, negative multiplier"
Ordering
EQ -> Maybe a
forall a. Maybe a
Nothing
Ordering
GT -> a -> Maybe a
forall a. a -> Maybe a
Just (b -> a -> a
forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes b
n a
a)

stimesList  :: Integral b => b -> [a] -> [a]
stimesList :: b -> [a] -> [a]
stimesList b
n [a]
x
| b
n b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
0 = [Char] -> [a]
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"stimes: [], negative multiplier"
| Bool
otherwise = b -> [a]
forall t. (Eq t, Num t) => t -> [a]
rep b
n
where
rep :: t -> [a]
rep t
0 = []
rep t
i = [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ t -> [a]
rep (t
i t -> t -> t
forall a. Num a => a -> a -> a
- t
1)

-- | The dual of a 'Monoid', obtained by swapping the arguments of 'mappend'.
--
-- >>> getDual (mappend (Dual "Hello") (Dual "World"))
-- "WorldHello"
newtype Dual a = Dual { Dual a -> a
getDual :: a }
deriving ( Eq       -- ^ @since 2.01
, Ord      -- ^ @since 2.01
, Read     -- ^ @since 2.01
, Show     -- ^ @since 2.01
, Bounded  -- ^ @since 2.01
, Generic  -- ^ @since 4.7.0.0
, Generic1 -- ^ @since 4.7.0.0
)

-- | @since 4.9.0.0
instance Semigroup a => Semigroup (Dual a) where
Dual a
a <> :: Dual a -> Dual a -> Dual a
<> Dual a
b = a -> Dual a
forall a. a -> Dual a
Dual (a
b a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a)
stimes :: b -> Dual a -> Dual a
stimes b
n (Dual a
a) = a -> Dual a
forall a. a -> Dual a
Dual (b -> a -> a
forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes b
n a
a)

-- | @since 2.01
instance Monoid a => Monoid (Dual a) where
mempty :: Dual a
mempty = a -> Dual a
forall a. a -> Dual a
Dual a
forall a. Monoid a => a
mempty

-- | @since 4.8.0.0
instance Functor Dual where
fmap :: (a -> b) -> Dual a -> Dual b
fmap     = (a -> b) -> Dual a -> Dual b
coerce

-- | @since 4.8.0.0
instance Applicative Dual where
pure :: a -> Dual a
pure     = a -> Dual a
forall a. a -> Dual a
Dual
<*> :: Dual (a -> b) -> Dual a -> Dual b
(<*>)    = Dual (a -> b) -> Dual a -> Dual b
coerce

-- | @since 4.8.0.0
Dual a
m >>= :: Dual a -> (a -> Dual b) -> Dual b
>>= a -> Dual b
k  = a -> Dual b
k (Dual a -> a
forall a. Dual a -> a
getDual Dual a
m)

-- | The monoid of endomorphisms under composition.
--
-- >>> let computation = Endo ("Hello, " ++) <> Endo (++ "!")
newtype Endo a = Endo { Endo a -> a -> a
appEndo :: a -> a }
deriving ( Generic -- ^ @since 4.7.0.0
)

-- | @since 4.9.0.0
instance Semigroup (Endo a) where
<> :: Endo a -> Endo a -> Endo a
(<>) = ((a -> a) -> (a -> a) -> a -> a) -> Endo a -> Endo a -> Endo a
coerce ((a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) :: (a -> a) -> (a -> a) -> (a -> a))
stimes :: b -> Endo a -> Endo a
stimes = b -> Endo a -> Endo a
forall b a. (Integral b, Monoid a) => b -> a -> a
stimesMonoid

-- | @since 2.01
instance Monoid (Endo a) where
mempty :: Endo a
mempty = (a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo a -> a
forall a. a -> a
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 { All -> Bool
getAll :: Bool }
deriving ( Eq      -- ^ @since 2.01
, Ord     -- ^ @since 2.01
, Read    -- ^ @since 2.01
, Show    -- ^ @since 2.01
, Bounded -- ^ @since 2.01
, Generic -- ^ @since 4.7.0.0
)

-- | @since 4.9.0.0
instance Semigroup All where
<> :: All -> All -> All
(<>) = (Bool -> Bool -> Bool) -> All -> All -> All
coerce Bool -> Bool -> Bool
(&&)
stimes :: b -> All -> All
stimes = b -> All -> All
forall b a. (Integral b, Monoid a) => b -> a -> a
stimesIdempotentMonoid

-- | @since 2.01
instance Monoid All where
mempty :: All
mempty = Bool -> All
All Bool
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 { Any -> Bool
getAny :: Bool }
deriving ( Eq      -- ^ @since 2.01
, Ord     -- ^ @since 2.01
, Read    -- ^ @since 2.01
, Show    -- ^ @since 2.01
, Bounded -- ^ @since 2.01
, Generic -- ^ @since 4.7.0.0
)

-- | @since 4.9.0.0
instance Semigroup Any where
<> :: Any -> Any -> Any
(<>) = (Bool -> Bool -> Bool) -> Any -> Any -> Any
coerce Bool -> Bool -> Bool
(||)
stimes :: b -> Any -> Any
stimes = b -> Any -> Any
forall b a. (Integral b, Monoid a) => b -> a -> a
stimesIdempotentMonoid

-- | @since 2.01
instance Monoid Any where
mempty :: Any
mempty = Bool -> Any
Any Bool
False

--
-- >>> getSum (Sum 1 <> Sum 2 <> mempty)
-- 3
newtype Sum a = Sum { Sum a -> a
getSum :: a }
deriving ( Eq       -- ^ @since 2.01
, Ord      -- ^ @since 2.01
, Read     -- ^ @since 2.01
, Show     -- ^ @since 2.01
, Bounded  -- ^ @since 2.01
, Generic  -- ^ @since 4.7.0.0
, Generic1 -- ^ @since 4.7.0.0
, Num      -- ^ @since 4.7.0.0
)

-- | @since 4.9.0.0
instance Num a => Semigroup (Sum a) where
<> :: Sum a -> Sum a -> Sum a
(<>) = (a -> a -> a) -> Sum a -> Sum a -> Sum a
coerce (a -> a -> a
forall a. Num a => a -> a -> a
(+) :: a -> a -> a)
stimes :: b -> Sum a -> Sum a
stimes b
n (Sum a
a) = a -> Sum a
forall a. a -> Sum a
Sum (b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
n a -> a -> a
forall a. Num a => a -> a -> a
* a
a)

-- | @since 2.01
instance Num a => Monoid (Sum a) where
mempty :: Sum a
mempty = a -> Sum a
forall a. a -> Sum a
Sum a
0

-- | @since 4.8.0.0
instance Functor Sum where
fmap :: (a -> b) -> Sum a -> Sum b
fmap     = (a -> b) -> Sum a -> Sum b
coerce

-- | @since 4.8.0.0
instance Applicative Sum where
pure :: a -> Sum a
pure     = a -> Sum a
forall a. a -> Sum a
Sum
<*> :: Sum (a -> b) -> Sum a -> Sum b
(<*>)    = Sum (a -> b) -> Sum a -> Sum b
coerce

-- | @since 4.8.0.0
Sum a
m >>= :: Sum a -> (a -> Sum b) -> Sum b
>>= a -> Sum b
k  = a -> Sum b
k (Sum a -> a
forall a. Sum a -> a
getSum Sum a
m)

-- | Monoid under multiplication.
--
-- >>> getProduct (Product 3 <> Product 4 <> mempty)
-- 12
newtype Product a = Product { Product a -> a
getProduct :: a }
deriving ( Eq       -- ^ @since 2.01
, Ord      -- ^ @since 2.01
, Read     -- ^ @since 2.01
, Show     -- ^ @since 2.01
, Bounded  -- ^ @since 2.01
, Generic  -- ^ @since 4.7.0.0
, Generic1 -- ^ @since 4.7.0.0
, Num      -- ^ @since 4.7.0.0
)

-- | @since 4.9.0.0
instance Num a => Semigroup (Product a) where
<> :: Product a -> Product a -> Product a
(<>) = (a -> a -> a) -> Product a -> Product a -> Product a
coerce (a -> a -> a
forall a. Num a => a -> a -> a
(*) :: a -> a -> a)
stimes :: b -> Product a -> Product a
stimes b
n (Product a
a) = a -> Product a
forall a. a -> Product a
Product (a
a a -> b -> a
forall a b. (Num a, Integral b) => a -> b -> a
^ b
n)

-- | @since 2.01
instance Num a => Monoid (Product a) where
mempty :: Product a
mempty = a -> Product a
forall a. a -> Product a
Product a
1

-- | @since 4.8.0.0
instance Functor Product where
fmap :: (a -> b) -> Product a -> Product b
fmap     = (a -> b) -> Product a -> Product b
coerce

-- | @since 4.8.0.0
instance Applicative Product where
pure :: a -> Product a
pure     = a -> Product a
forall a. a -> Product a
Product
<*> :: Product (a -> b) -> Product a -> Product b
(<*>)    = Product (a -> b) -> Product a -> Product b
coerce

-- | @since 4.8.0.0
Product a
m >>= :: Product a -> (a -> Product b) -> Product b
>>= a -> Product b
k  = a -> Product b
k (Product a -> a
forall a. Product a -> a
getProduct Product a
m)

-- | Monoid under '<|>'.
--
-- >>> getAlt (Alt (Just 12) <> Alt (Just 24))
-- Just 12
--
-- >>> getAlt \$ Alt Nothing <> Alt (Just 24)
-- Just 24
--
-- @since 4.8.0.0
newtype Alt f a = Alt {Alt f a -> f a
getAlt :: f a}
deriving ( Generic     -- ^ @since 4.8.0.0
, Generic1    -- ^ @since 4.8.0.0
, Read        -- ^ @since 4.8.0.0
, Show        -- ^ @since 4.8.0.0
, Eq          -- ^ @since 4.8.0.0
, Ord         -- ^ @since 4.8.0.0
, Num         -- ^ @since 4.8.0.0
, Enum        -- ^ @since 4.8.0.0
, Monad       -- ^ @since 4.8.0.0
, MonadPlus   -- ^ @since 4.8.0.0
, Applicative -- ^ @since 4.8.0.0
, Alternative -- ^ @since 4.8.0.0
, Functor     -- ^ @since 4.8.0.0
)

-- | @since 4.9.0.0
instance Alternative f => Semigroup (Alt f a) where
<> :: Alt f a -> Alt f a -> Alt f a
(<>) = (f a -> f a -> f a) -> Alt f a -> Alt f a -> Alt f a
coerce (f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) :: f a -> f a -> f a)
stimes :: b -> Alt f a -> Alt f a
stimes = b -> Alt f a -> Alt f a
forall b a. (Integral b, Monoid a) => b -> a -> a
stimesMonoid

-- | @since 4.8.0.0
instance Alternative f => Monoid (Alt f a) where
mempty :: Alt f a
mempty = f a -> Alt f a
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Alt f a
forall (f :: * -> *) a. Alternative f => f a
empty