X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FMonoid.hs;h=3c2337c0cfd635e55b15deb4267bc10529aa1560;hb=4b26136ab82fb1ff12e49477c4833a9586d368c5;hp=052472721ebb931dbec7bd476abae0f2775a9e41;hpb=dbf490ac992de84156826d846b25ecfbc4346744;p=haskell-directory.git diff --git a/Data/Monoid.hs b/Data/Monoid.hs index 0524727..3c2337c 100644 --- a/Data/Monoid.hs +++ b/Data/Monoid.hs @@ -19,22 +19,29 @@ ----------------------------------------------------------------------------- module Data.Monoid ( + -- * Monoid typeclass Monoid(..), - Endo(..), Dual(..), + Endo(..), + -- * Bool wrappers + All(..), + Any(..), + -- * Num wrappers Sum(..), - Product(..) + Product(..), + -- * Maybe wrappers + -- $MaybeExamples + First(..), + Last(..) ) where import Prelude -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) -import Data.IntMap ( IntMap ) -import qualified Data.IntMap as IntMap hiding ( IntMap ) -import Data.Set ( Set ) -import qualified Data.Set as Set hiding ( Set ) -import Data.IntSet ( IntSet ) -import qualified Data.IntSet as IntSet hiding ( IntSet ) + +{- +-- just for testing +import Data.Maybe +import Test.QuickCheck +-- -} -- --------------------------------------------------------------------------- -- | The monoid class. @@ -101,6 +108,14 @@ instance Monoid Ordering where EQ `mappend` y = y GT `mappend` _ = GT +-- | The dual of a monoid, obtained by swapping the arguments of 'mappend'. +newtype Dual a = Dual { getDual :: a } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Monoid a => Monoid (Dual a) where + mempty = Dual mempty + Dual x `mappend` Dual y = Dual (y `mappend` x) + -- | The monoid of endomorphisms under composition. newtype Endo a = Endo { appEndo :: a -> a } @@ -108,15 +123,25 @@ instance Monoid (Endo a) where mempty = Endo id Endo f `mappend` Endo g = Endo (f . g) --- | The dual of a monoid, obtained by swapping the arguments of 'mappend'. -newtype Dual a = Dual { getDual :: a } +-- | Boolean monoid under conjunction. +newtype All = All { getAll :: Bool } + deriving (Eq, Ord, Read, Show, Bounded) -instance Monoid a => Monoid (Dual a) where - mempty = Dual mempty - Dual x `mappend` Dual y = Dual (y `mappend` x) +instance Monoid All where + mempty = All True + All x `mappend` All y = All (x && y) + +-- | Boolean monoid under disjunction. +newtype Any = Any { getAny :: Bool } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Monoid Any where + mempty = Any False + Any x `mappend` Any y = Any (x || y) -- | Monoid under addition. newtype Sum a = Sum { getSum :: a } + deriving (Eq, Ord, Read, Show, Bounded) instance Num a => Monoid (Sum a) where mempty = Sum 0 @@ -124,27 +149,105 @@ instance Num a => Monoid (Sum a) where -- | Monoid under multiplication. newtype Product a = Product { getProduct :: a } + deriving (Eq, Ord, Read, Show, Bounded) instance Num a => Monoid (Product a) where mempty = Product 1 Product x `mappend` Product y = Product (x * y) -instance (Ord k) => Monoid (Map k v) where - mempty = Map.empty - mappend = Map.union - mconcat = Map.unions - -instance Ord a => Monoid (IntMap a) where - mempty = IntMap.empty - mappend = IntMap.union - mconcat = IntMap.unions - -instance Ord a => Monoid (Set a) where - mempty = Set.empty - mappend = Set.union - mconcat = Set.unions - -instance Monoid IntSet where - mempty = IntSet.empty - mappend = IntSet.union - mconcat = IntSet.unions +-- $MaybeExamples +-- To implement @find@ or @findLast@ on any 'Foldable': +-- +-- @ +-- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a +-- findLast pred = getLast . foldMap (\x -> if pred x +-- then Last (Just x) +-- else Last Nothing) +-- @ +-- +-- Much of "Data.Map"'s interface can be implemented with +-- 'Data.Map.alter'. Some of the rest can be implemented with a new +-- @alterA@ function and either 'First' or 'Last': +-- +-- > alterA :: (Applicative f, Ord k) => +-- > (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a) +-- > +-- > instance Monoid a => Applicative ((,) a) -- from Control.Applicative +-- +-- @ +-- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v +-- -> Map k v -> (Maybe v, Map k v) +-- insertLookupWithKey combine key value = +-- Arrow.first getFirst . alterA doChange key +-- where +-- doChange Nothing = (First Nothing, Just value) +-- doChange (Just oldValue) = +-- (First (Just oldValue), +-- Just (combine key value oldValue)) +-- @ + +-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to +-- : \"Any semigroup @S@ may be +-- turned into a monoid simply by adjoining an element @e@ not in @S@ +-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since +-- there is no \"Semigroup\" typeclass providing just 'mappend', we +-- use 'Monoid' instead. +instance Monoid a => Monoid (Maybe a) where + mempty = Nothing + Nothing `mappend` m = m + m `mappend` Nothing = m + Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) + + +-- | Maybe monoid returning the leftmost non-Nothing value. +newtype First a = First { getFirst :: Maybe a } +#ifndef __HADDOCK__ + deriving (Eq, Ord, Read, Show) +#else /* __HADDOCK__ */ +instance Eq a => Eq (First a) +instance Ord a => Ord (First a) +instance Read a => Read (First a) +instance Show a => Show (First a) +#endif + +instance Monoid (First a) where + mempty = First Nothing + r@(First (Just _)) `mappend` _ = r + First Nothing `mappend` r = r + +-- | Maybe monoid returning the rightmost non-Nothing value. +newtype Last a = Last { getLast :: Maybe a } +#ifndef __HADDOCK__ + deriving (Eq, Ord, Read, Show) +#else /* __HADDOCK__ */ +instance Eq a => Eq (Last a) +instance Ord a => Ord (Last a) +instance Read a => Read (Last a) +instance Show a => Show (Last a) +#endif + +instance Monoid (Last a) where + mempty = Last Nothing + _ `mappend` r@(Last (Just _)) = r + r `mappend` Last Nothing = r + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = oneof [return Nothing, Just `fmap` arbitrary] + +prop_mconcatMaybe :: [Maybe [Int]] -> Bool +prop_mconcatMaybe x = + fromMaybe [] (mconcat x) == mconcat (catMaybes x) + +prop_mconcatFirst :: [Maybe Int] -> Bool +prop_mconcatFirst x = + getFirst (mconcat (map First x)) == listToMaybe (catMaybes x) +prop_mconcatLast :: [Maybe Int] -> Bool +prop_mconcatLast x = + getLast (mconcat (map Last x)) == listLastToMaybe (catMaybes x) + where listLastToMaybe [] = Nothing + listLastToMaybe lst = Just (last lst) +-- -}