Data/Semigroup.hs

-----------------------------------------------------------------------------
-- |
-- Module : Data.Semigroup
-- Copyright : (C) 2011 Edward Kmett,
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Edward Kmett <ekmett@gmail.com>
-- Stability : provisional
-- Portability : portable
--
----------------------------------------------------------------------------
module Data.Semigroup ( 
 Semigroup(..)
 -- * Semigroups
 , Min(..)
 , Max(..)
 , First(..)
 , Last(..)
 , WrappedMonoid(..)
 -- * Monoids from Data.Monoid 
 , Dual(..)
 , Endo(..)
 , All(..)
 , Any(..)
 , Sum(..)
 , Product(..)
 -- * A better monoid for Maybe
 , Option(..)
 , option
 -- * Difference lists of a semigroup
 , diff
 ) where

import Prelude hiding (foldr1)
import Data.Monoid hiding (First(..), Last(..))
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import qualified Data.Monoid as Monoid
import Data.Foldable
import Data.Traversable

import Data.Void
import Data.Tagged
import Data.Proxy
import Data.Sequence (Seq, (><))
import Data.Set (Set)
import Data.IntSet (IntSet)
import Data.Map (Map)
import Data.IntMap (IntMap)

#ifdef LANGUAGE_DeriveDataTypeable
import Data.Data
#endif

infixl 4 <> 

class Semigroup a where
 (<>) :: a -> a -> a

instance Semigroup b => Semigroup (a -> b) where
 f <> g = \a -> f a <> g a

instance Semigroup [a] where
 (<>) = (++)

instance Semigroup a => Semigroup (Maybe a) where
 Nothing <> b = b
 a <> Nothing = a
 Just a <> Just b = Just (a <> b)

instance Semigroup (Either a b) where
 Left _ <> b = b
 a <> _ = a

instance (Semigroup a, Semigroup b) => Semigroup (a, b) where
 (a,b) <> (a',b') = (a<>a',b<>b')
 
instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where
 (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')

instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) => Semigroup (a, b, c, d) where
 (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')

instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) => Semigroup (a, b, c, d, e) where
 (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')

instance Semigroup a => Semigroup (Dual a) where
 Dual a <> Dual b = Dual (b <> a)

instance Semigroup (Endo a) where
 Endo f <> Endo g = Endo (f . g) 

instance Semigroup All where
 All a <> All b = All (a && b)

instance Semigroup Any where
 Any a <> Any b = Any (a || b)

instance Num a => Semigroup (Sum a) where
 Sum a <> Sum b = Sum (a + b)

instance Num a => Semigroup (Product a) where
 Product a <> Product b = Product (a * b)

instance Semigroup (Monoid.First a) where
 Monoid.First Nothing <> b = b
 a <> _ = a

instance Semigroup (Monoid.Last a) where
 a <> Monoid.Last Nothing = a
 _ <> b = b

newtype Min a = Min { getMin :: a } deriving 
 ( Eq, Ord, Bounded, Show, Read
#ifdef LANGUAGE_DeriveDataTypeable
 , Data, Typeable
#endif
 )

instance Ord a => Semigroup (Min a) where
 Min a <> Min b = Min (a `min` b)

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

newtype Max a = Max { getMax :: a } deriving 
 ( Eq, Ord, Bounded, Show, Read
#ifdef LANGUAGE_DeriveDataTypeable
 , Data, Typeable
#endif
 )

instance Ord a => Semigroup (Max a) where
 Max a <> Max b = Max (a `max` b)

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

-- | Use @'Option' ('First' a)@ -- to get the behavior of 'Data.Monoid.First'
newtype First a = First { getFirst :: a } deriving 
 ( Eq, Ord, Bounded, Show, Read
#ifdef LANGUAGE_DeriveDataTypeable
 , Data
 , Typeable
#endif
 )

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

-- | Use @'Option' ('Last' a)@ -- to get the behavior of 'Data.Monoid.Last'
newtype Last a = Last { getLast :: a } deriving 
 ( Eq, Ord, Bounded, Show, Read
#ifdef LANGUAGE_DeriveDataTypeable
 , Data, Typeable
#endif
 )

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

-- (==)/XNOR on Bool forms a 'Semigroup', but has no good name

newtype WrappedMonoid m = WrapMonoid 
 { unwrapMonoid :: m } deriving 
 ( Eq, Ord, Show, Read
#ifdef LANGUAGE_DeriveDataTypeable
 , Data, Typeable
#endif
 )

instance Monoid m => Semigroup (WrappedMonoid m) where
 WrapMonoid a <> WrapMonoid b = WrapMonoid (a `mappend` b)

instance Monoid m => Monoid (WrappedMonoid m) where
 mempty = WrapMonoid mempty
 WrapMonoid a `mappend` WrapMonoid b = WrapMonoid (a `mappend` b)


-- | Option is effectively 'Maybe' with a better instance of 'Monoid', built off of an underlying 'Semigroup'
-- instead of an underlying 'Monoid'.
newtype Option a = Option 
 { getOption :: Maybe a } deriving 
 ( Eq, Ord, Show, Read
#ifdef LANGUAGE_DeriveDataTypeable
 , Data, Typeable
#endif
 )

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)

instance Monad Option where
 return = pure

 Option (Just a) >>= k = k a
 _ >>= _ = Option Nothing

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

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

instance MonadPlus Option where
 mzero = empty
 mplus = (<|>)

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
 Option a <> Option b = Option (a <> b) 

instance Semigroup a => Monoid (Option a) where
 mempty = empty
 Option a `mappend` Option b = Option (a <> b)

-- | This lets you use a 'difference list' of a semigroup as a Monoid.
diff :: Semigroup m => m -> Endo m
diff = Endo . (<>)

instance Semigroup Void where
 a <> _ = a

instance Semigroup a => Semigroup (Tagged s a) where
 Tagged a <> Tagged b = Tagged (a <> b)

instance Semigroup (Proxy a) where
 Proxy <> Proxy = Proxy

instance Semigroup (Seq a) where
 (<>) = (><)

instance Semigroup IntSet where
 (<>) = mappend

instance Ord a => Semigroup (Set a) where
 (<>) = mappend

instance Semigroup (IntMap v) where
 (<>) = mappend

instance Ord k => Semigroup (Map k v) where
 (<>) = mappend