{-# 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 \(\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
instance Monad Dual where
    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 (++ "!")
-- >>> appEndo computation "Haskell"
-- "Hello, Haskell!"
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

-- | Monoid under addition.
--
-- >>> 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
instance Monad Sum where
    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
instance Monad Product where
    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