ref: 01e3ea89201c49757154ce04c475a95b0040d3df
dir: /lib/Data/Monoid/Internal.hs/
module Data.Monoid.Internal(module Data.Monoid.Internal) where
import Prelude() -- do not import Prelude
import Primitives
import Control.Applicative
import Control.Error
import Data.Bool
import Data.Bounded
import Data.Eq
import Data.Function
import Data.Functor
import Data.Int
import Data.Integral
import Data.List_Type
import Data.List.NonEmpty_Type
import Data.Ord
import Data.Maybe_Type
import Data.Num
import Data.Records
import Text.Show
class Semigroup a => Monoid a where
mempty :: a
mappend :: a -> a -> a
mappend = (<>)
mconcat :: [a] -> a
mconcat [] = mempty
mconcat (a:as) = a <> mconcat as
---------------------
instance (Monoid b) => Monoid (a -> b) where
mempty _ = mempty
instance (Semigroup b) => Semigroup (a -> b) where
f <> g = \ x -> f x <> g x
---------------------
newtype Endo a = Endo { appEndo :: a -> a }
instance forall a . Semigroup (Endo a) where
Endo f <> Endo g = Endo (f . g)
instance forall a . Monoid (Endo a) where
mempty = Endo id
---------------------
newtype Dual a = Dual { getDual :: a }
deriving (Bounded, Eq, Ord, Show)
instance forall a . Semigroup a => Semigroup (Dual a) where
Dual a <> Dual b = Dual (b <> a)
instance forall a . Monoid a => Monoid (Dual a) where
mempty = Dual mempty
instance Functor Dual where
fmap f (Dual a) = Dual (f a)
instance Applicative Dual where
pure = Dual
Dual f <*> Dual b = Dual (f b)
---------------------
newtype Max a = Max { getMax :: a }
deriving (Bounded, Eq, Ord, Show)
instance forall a . Ord a => Semigroup (Max a) where
Max a <> Max b = Max (a `max` b)
stimes = stimesIdempotent
instance forall a . (Ord a, Bounded a) => Monoid (Max a) where
mempty = Max minBound
---------------------
newtype Min a = Min { getMin :: a }
deriving (Bounded, Eq, Ord, Show)
instance forall a . Ord a => Semigroup (Min a) where
Min a <> Min b = Min (a `min` b)
stimes = stimesIdempotent
instance forall a . (Ord a, Bounded a) => Monoid (Min a) where
mempty = Min maxBound
---------------------
newtype Sum a = Sum { getSum :: a }
deriving (Bounded, Eq, Ord, Show)
instance forall a . Num a => Semigroup (Sum a) where
Sum a <> Sum b = Sum (a + b)
instance forall a . (Num a) => Monoid (Sum a) where
mempty = Sum 0
---------------------
newtype Product a = Product { getProduct :: a }
deriving (Bounded, Eq, Ord, Show)
instance forall a . Num a => Semigroup (Product a) where
Product a <> Product b = Product (a * b)
instance forall a . (Num a) => Monoid (Product a) where
mempty = Product 1
---------------------
newtype All = All { getAll :: Bool }
deriving (Bounded, Eq, Ord, Show)
instance Semigroup All where
All a <> All b = All (a && b)
instance Monoid All where
mempty = All True
---------------------
newtype Any = Any { getAny :: Bool }
deriving (Bounded, Eq, Ord, Show)
instance Semigroup Any where
Any a <> Any b = Any (a || b)
instance Monoid Any where
mempty = Any False
---------------------
instance Semigroup Ordering where
LT <> _ = LT
EQ <> o = o
GT <> _ = GT
instance Monoid Ordering where
mempty = EQ
----------------------
data Arg a b = Arg a b
deriving(Show)
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 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
----------------------
newtype Alt f a = Alt (f a)
-- deriving (Show)
getAlt :: Alt f a -> f a
getAlt (Alt x) = x
{-
deriving ( Generic -- ^ @since base-4.8.0.0
, Generic1 -- ^ @since base-4.8.0.0
, Read -- ^ @since base-4.8.0.0
, Show -- ^ @since base-4.8.0.0
, Eq -- ^ @since base-4.8.0.0
, Ord -- ^ @since base-4.8.0.0
, Num -- ^ @since base-4.8.0.0
, Enum -- ^ @since base-4.8.0.0
, Monad -- ^ @since base-4.8.0.0
, MonadPlus -- ^ @since base-4.8.0.0
, Applicative -- ^ @since base-4.8.0.0
, Alternative -- ^ @since base-4.8.0.0
, Functor -- ^ @since base-4.8.0.0
)
-}
instance Alternative f => Semigroup (Alt f a) where
Alt x <> Alt y = Alt (x <|> y)
stimes = stimesMonoid
instance Alternative f => Monoid (Alt f a) where
mempty = Alt empty
----------------------
-- This really belongs in Data.Semigroup,
-- but some functions have Monoid as in the context.
infixr 6 <>
class Semigroup a where
(<>) :: a -> a -> a
sconcat :: NonEmpty a -> a
stimes :: (Integral b, Ord b) => b -> a -> a
sconcat (a :| as) = go a as
where go b (c:cs) = b <> go c cs
go b [] = b
stimes y0 x0
| y0 <= 0 = error "stimes: positive multiplier expected"
| otherwise = f x0 y0
where
f x y
| y `rem` 2 == 0 = f (x <> x) (y `quot` 2)
| y == 1 = x
| otherwise = g (x <> x) (y `quot` 2) x
g x y z
| y `rem` 2 == 0 = g (x <> x) (y `quot` 2) z
| y == 1 = x <> z
| otherwise = g (x <> x) (y `quot` 2) (x <> z)
stimesIdempotent :: (Integral b, Ord b) => b -> a -> a
stimesIdempotent n x =
if n <= 0 then error "stimesIdempotent: positive multiplier expected"
else x
stimesIdempotentMonoid :: (Ord b, Integral b, Monoid a) => b -> a -> a
stimesIdempotentMonoid n x = case compare n 0 of
LT -> error "stimesIdempotentMonoid: negative multiplier"
EQ -> mempty
GT -> x
stimesMonoid :: (Ord b, Integral b, Monoid a) => b -> a -> a
stimesMonoid n x0 = case compare n 0 of
LT -> error "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)
---------------------