(original) (raw)

{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-}

module Data.Semigroup ( Semigroup(..) , stimesMonoid , stimesIdempotent , stimesIdempotentMonoid , mtimesDefault

, Min(..) , Max(..) , First(..) , Last(..) , WrappedMonoid(..)

, Dual(..) , Endo(..) , All(..) , Any(..) , Sum(..) , Product(..)

, Option(..) , option

, diff , cycle1

, Arg(..) , ArgMin , ArgMax ) where

import Prelude hiding (foldr1)

import GHC.Base (Semigroup(..))

import Data.Semigroup.Internal

import Control.Applicative import Control.Monad import Control.Monad.Fix import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.Coerce import Data.Data import Data.Monoid (All (..), Any (..), Dual (..), Endo (..), Product (..), Sum (..))

import GHC.Generics

cycle1 :: Semigroup m => m -> m cycle1 xs = xs' where xs' = xs <> xs'

diff :: Semigroup m => m -> Endo m diff = Endo . (<>)

newtype Min a = Min { getMin :: a } deriving ( Bounded
, Eq
, Ord
, Show
, Read
, Data
, Generic
, Generic1 )

instance Enum a => Enum (Min a) where succ (Min a) = Min (succ a) pred (Min a) = Min (pred a) toEnum = Min . toEnum fromEnum = fromEnum . getMin enumFrom (Min a) = Min <$> enumFrom a enumFromThen (Min a) (Min b) = Min <$> enumFromThen a b enumFromTo (Min a) (Min b) = Min <$> enumFromTo a b enumFromThenTo (Min a) (Min b) (Min c) = Min <$> enumFromThenTo a b c

instance Ord a => Semigroup (Min a) where (<>) = coerce (min :: a -> a -> a) stimes = stimesIdempotent

instance (Ord a, Bounded a) => Monoid (Min a) where mempty = maxBound

instance Functor Min where fmap f (Min x) = Min (f x)

instance Foldable Min where foldMap f (Min a) = f a

instance Traversable Min where traverse f (Min a) = Min <$> f a

instance Applicative Min where pure = Min a <* _ = a _ *> a = a (<*>) = coerce liftA2 = coerce

instance Monad Min where (>>) = (*>) Min a >>= f = f a

instance MonadFix Min where mfix f = fix (f . getMin)

instance Num a => Num (Min a) where (Min a) + (Min b) = Min (a + b) (Min a) * (Min b) = Min (a * b) (Min a) - (Min b) = Min (a - b) negate (Min a) = Min (negate a) abs (Min a) = Min (abs a) signum (Min a) = Min (signum a) fromInteger = Min . fromInteger

newtype Max a = Max { getMax :: a } deriving ( Bounded
, Eq
, Ord
, Show
, Read
, Data
, Generic
, Generic1 )

instance Enum a => Enum (Max a) where succ (Max a) = Max (succ a) pred (Max a) = Max (pred a) toEnum = Max . toEnum fromEnum = fromEnum . getMax enumFrom (Max a) = Max <$> enumFrom a enumFromThen (Max a) (Max b) = Max <$> enumFromThen a b enumFromTo (Max a) (Max b) = Max <$> enumFromTo a b enumFromThenTo (Max a) (Max b) (Max c) = Max <$> enumFromThenTo a b c

instance Ord a => Semigroup (Max a) where (<>) = coerce (max :: a -> a -> a) stimes = stimesIdempotent

instance (Ord a, Bounded a) => Monoid (Max a) where mempty = minBound

instance Functor Max where fmap f (Max x) = Max (f x)

instance Foldable Max where foldMap f (Max a) = f a

instance Traversable Max where traverse f (Max a) = Max <$> f a

instance Applicative Max where pure = Max a <* _ = a _ *> a = a (<*>) = coerce liftA2 = coerce

instance Monad Max where (>>) = (*>) Max a >>= f = f a

instance MonadFix Max where mfix f = fix (f . getMax)

instance Num a => Num (Max a) where (Max a) + (Max b) = Max (a + b) (Max a) * (Max b) = Max (a * b) (Max a) - (Max b) = Max (a - b) negate (Max a) = Max (negate a) abs (Max a) = Max (abs a) signum (Max a) = Max (signum a) fromInteger = Max . fromInteger

data Arg a b = Arg a b deriving ( Show
, Read
, Data
, Generic
, Generic1 )

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 Foldable (Arg a) where foldMap f (Arg _ a) = f a

instance Traversable (Arg a) where traverse 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

instance Bifunctor Arg where bimap f g (Arg a b) = Arg (f a) (g b)

instance Bifoldable Arg where bifoldMap f g (Arg a b) = f a <> g b

instance Bitraversable Arg where bitraverse f g (Arg a b) = Arg <$> f a <*> g b

newtype First a = First { getFirst :: a } deriving ( Bounded
, Eq
, Ord
, Show
, Read
, Data
, Generic
, Generic1 )

instance Enum a => Enum (First a) where succ (First a) = First (succ a) pred (First a) = First (pred a) toEnum = First . toEnum fromEnum = fromEnum . getFirst enumFrom (First a) = First <$> enumFrom a enumFromThen (First a) (First b) = First <$> enumFromThen a b enumFromTo (First a) (First b) = First <$> enumFromTo a b enumFromThenTo (First a) (First b) (First c) = First <$> enumFromThenTo a b c

instance Semigroup (First a) where a <> _ = a stimes = stimesIdempotent

instance Functor First where fmap f (First x) = First (f x)

instance Foldable First where foldMap f (First a) = f a

instance Traversable First where traverse f (First a) = First <$> f a

instance Applicative First where pure x = First x a <* _ = a _ *> a = a (<*>) = coerce liftA2 = coerce

instance Monad First where (>>) = (*>) First a >>= f = f a

instance MonadFix First where mfix f = fix (f . getFirst)

newtype Last a = Last { getLast :: a } deriving ( Bounded
, Eq
, Ord
, Show
, Read
, Data
, Generic
, Generic1 )

instance Enum a => Enum (Last a) where succ (Last a) = Last (succ a) pred (Last a) = Last (pred a) toEnum = Last . toEnum fromEnum = fromEnum . getLast enumFrom (Last a) = Last <$> enumFrom a enumFromThen (Last a) (Last b) = Last <$> enumFromThen a b enumFromTo (Last a) (Last b) = Last <$> enumFromTo a b enumFromThenTo (Last a) (Last b) (Last c) = Last <$> enumFromThenTo a b c

instance Semigroup (Last a) where _ <> b = b stimes = stimesIdempotent

instance Functor Last where fmap f (Last x) = Last (f x) a <$ _ = Last a

instance Foldable Last where foldMap f (Last a) = f a

instance Traversable Last where traverse f (Last a) = Last <$> f a

instance Applicative Last where pure = Last a <* _ = a _ *> a = a (<*>) = coerce liftA2 = coerce

instance Monad Last where (>>) = (*>) Last a >>= f = f a

instance MonadFix Last where mfix f = fix (f . getLast)

newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m } deriving ( Bounded
, Eq
, Ord
, Show
, Read
, Data
, Generic
, Generic1 )

instance Monoid m => Semigroup (WrappedMonoid m) where (<>) = coerce (mappend :: m -> m -> m)

instance Monoid m => Monoid (WrappedMonoid m) where mempty = WrapMonoid mempty

instance Enum a => Enum (WrappedMonoid a) where succ (WrapMonoid a) = WrapMonoid (succ a) pred (WrapMonoid a) = WrapMonoid (pred a) toEnum = WrapMonoid . toEnum fromEnum = fromEnum . unwrapMonoid enumFrom (WrapMonoid a) = WrapMonoid <$> enumFrom a enumFromThen (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromThen a b enumFromTo (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromTo a b enumFromThenTo (WrapMonoid a) (WrapMonoid b) (WrapMonoid c) = WrapMonoid <$> enumFromThenTo a b c

mtimesDefault :: (Integral b, Monoid a) => b -> a -> a mtimesDefault n x | n == 0 = mempty | otherwise = unwrapMonoid (stimes n (WrapMonoid x))

newtype Option a = Option { getOption :: Maybe a } deriving ( Eq
, Ord
, Show
, Read
, Data
, Generic
, Generic1 )

instance Functor Option where fmap f (Option a) = Option (fmap f a)

instance Applicative Option where pure a = Option (Just a) Option a <*> Option b = Option (a <*> b) liftA2 f (Option x) (Option y) = Option (liftA2 f x y)

Option Nothing *> _ = Option Nothing _ *> b = b

instance Monad Option where Option (Just a) >>= k = k a _ >>= _ = Option Nothing (>>) = (*>)

instance Alternative Option where empty = Option Nothing Option Nothing <|> b = b a <|> _ = a

instance MonadPlus Option

instance MonadFix Option where mfix f = Option (mfix (getOption . f))

instance Foldable Option where foldMap f (Option (Just m)) = f m foldMap _ (Option Nothing) = mempty

instance Traversable Option where traverse f (Option (Just a)) = Option . Just <$> f a traverse _ (Option Nothing) = pure (Option Nothing)

option :: b -> (a -> b) -> Option a -> b option n j (Option m) = maybe n j m

instance Semigroup a => Semigroup (Option a) where (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a) #if !defined(HADDOCK_VERSION)

stimes _ (Option Nothing) = Option Nothing stimes n (Option (Just a)) = case compare n 0 of LT -> errorWithoutStackTrace "stimes: Option, negative multiplier" EQ -> Option Nothing GT -> Option (Just (stimes n a)) #endif

instance Semigroup a => Monoid (Option a) where mempty = Option Nothing