diff --git a/Data/Monoid/Cancellative.hs b/Data/Monoid/Cancellative.hs --- a/Data/Monoid/Cancellative.hs +++ b/Data/Monoid/Cancellative.hs @@ -35,8 +35,8 @@ {-# LANGUAGE Haskell2010 #-} module Data.Monoid.Cancellative ( - -- * Symmetric monoid classes - ReductiveMonoid(..), CancellativeMonoid(..), GCDMonoid(..), + -- * Symmetric, commutative monoid classes + CommutativeMonoid, ReductiveMonoid(..), CancellativeMonoid(..), GCDMonoid(..), -- * Asymmetric monoid classes LeftReductiveMonoid(..), RightReductiveMonoid(..), LeftCancellativeMonoid(..), RightCancellativeMonoid(..), @@ -63,12 +63,17 @@ import Data.Sequence (ViewL((:<)), ViewR((:>)), (<|), (|>)) import qualified Data.Vector as Vector +-- | Class of all Abelian ({i.e.}, commutative) monoids that satisfy the commutativity property: +-- +-- > a <> b == b <> a +class Monoid m => CommutativeMonoid m + -- | Class of Abelian monoids with a partial inverse for the Monoid '<>' operation. The inverse operation '' must -- satisfy the following laws: -- -- > maybe a (b <>) (a b) == a -- > maybe a (<> b) (a b) == a -class (LeftReductiveMonoid m, RightReductiveMonoid m) => ReductiveMonoid m where +class (CommutativeMonoid m, LeftReductiveMonoid m, RightReductiveMonoid m) => ReductiveMonoid m where () :: m -> m -> Maybe m infix 5 @@ -176,8 +181,38 @@ Just x' = stripSuffix s x Just y' = stripSuffix s y +-- Unit instances + +instance CommutativeMonoid () + +instance ReductiveMonoid () where + () () = Just () + +instance CancellativeMonoid () + +instance GCDMonoid () where + gcd () () = () + +instance LeftReductiveMonoid () where + stripPrefix () () = Just () + +instance RightReductiveMonoid () where + stripSuffix () () = Just () + +instance LeftCancellativeMonoid () + +instance RightCancellativeMonoid () + +instance LeftGCDMonoid () where + commonPrefix () () = () + +instance RightGCDMonoid () where + commonSuffix () () = () + -- Dual instances +instance CommutativeMonoid a => CommutativeMonoid (Dual a) + instance ReductiveMonoid a => ReductiveMonoid (Dual a) where Dual a Dual b = fmap Dual (a b) @@ -206,6 +241,8 @@ -- Sum instances +instance Num a => CommutativeMonoid (Sum a) + instance Integral a => ReductiveMonoid (Sum a) where Sum a Sum b = Just $ Sum (a - b) @@ -232,6 +269,8 @@ -- Product instances +instance Num a => CommutativeMonoid (Product a) + instance Integral a => ReductiveMonoid (Product a) where Product 0 Product 0 = Just (Product 0) Product a Product 0 = Nothing @@ -255,6 +294,8 @@ -- Pair instances +instance (CommutativeMonoid a, CommutativeMonoid b) => CommutativeMonoid (a, b) + instance (ReductiveMonoid a, ReductiveMonoid b) => ReductiveMonoid (a, b) where (a, b) (c, d) = case (a c, b d) of (Just a', Just b') -> Just (a', b') @@ -289,6 +330,8 @@ -- Set instances +instance Ord a => CommutativeMonoid (Set.Set a) + instance Ord a => LeftReductiveMonoid (Set.Set a) where isPrefixOf = Set.isSubsetOf stripPrefix a b = b a @@ -311,6 +354,8 @@ gcd = Set.intersection -- IntSet instances + +instance CommutativeMonoid IntSet.IntSet instance LeftReductiveMonoid IntSet.IntSet where isPrefixOf = IntSet.isSubsetOf diff --git a/Data/Monoid/Factorial.hs b/Data/Monoid/Factorial.hs --- a/Data/Monoid/Factorial.hs +++ b/Data/Monoid/Factorial.hs @@ -149,6 +149,15 @@ take n p = fst (splitAt n p) reverse = mconcat . List.reverse . factors +instance FactorialMonoid () where + factors () = [] + primePrefix () = () + primeSuffix () = () + splitPrimePrefix () = Nothing + splitPrimeSuffix () = Nothing + length () = 0 + reverse = id + instance FactorialMonoid a => FactorialMonoid (Dual a) where factors (Dual a) = fmap Dual (reverse $ factors a) length (Dual a) = length a diff --git a/Test/TestMonoidSubclasses.hs b/Test/TestMonoidSubclasses.hs --- a/Test/TestMonoidSubclasses.hs +++ b/Test/TestMonoidSubclasses.hs @@ -43,7 +43,7 @@ import Data.Monoid.Null (MonoidNull, null) import Data.Monoid.Factorial (FactorialMonoid, factors, splitPrimePrefix, splitPrimeSuffix, primePrefix, primeSuffix, foldl, foldl', foldr, length, reverse, span, split, splitAt) -import Data.Monoid.Cancellative (ReductiveMonoid, LeftReductiveMonoid, RightReductiveMonoid, +import Data.Monoid.Cancellative (CommutativeMonoid, ReductiveMonoid, LeftReductiveMonoid, RightReductiveMonoid, CancellativeMonoid, LeftCancellativeMonoid, RightCancellativeMonoid, GCDMonoid, LeftGCDMonoid, RightGCDMonoid, (), gcd, @@ -52,7 +52,8 @@ import Data.Monoid.Textual (TextualMonoid) import qualified Data.Monoid.Textual as Textual -data Test = NullTest (forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) => a -> Property) +data Test = CommutativeTest (forall a. (Arbitrary a, Show a, Eq a, CommutativeMonoid a) => a -> Property) + | NullTest (forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) => a -> Property) | FactorialTest (forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property) | TextualTest (forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property) | LeftReductiveTest (forall a. (Arbitrary a, Show a, Eq a, LeftReductiveMonoid a) => a -> Property) @@ -70,6 +71,13 @@ main = mapM_ (quickCheck . uncurry checkInstances) tests checkInstances :: String -> Test -> Property +checkInstances name (CommutativeTest checkType) = label name (checkType () + .&&. checkType (mempty :: Sum Integer) + .&&. checkType (mempty :: Product Integer) + .&&. checkType (mempty :: Dual (Sum Integer)) + .&&. checkType (mempty :: (Sum Integer, Sum Int)) + .&&. checkType (mempty :: IntSet) + .&&. checkType (mempty :: Set Integer)) checkInstances name (NullTest checkType) = label name (checkType () .&&. checkType (mempty :: Ordering) .&&. checkType (mempty :: All) @@ -92,7 +100,8 @@ .&&. checkType (mempty :: Seq Int) .&&. checkType (mempty :: Set String) .&&. checkType (mempty :: Vector Int)) -checkInstances name (FactorialTest checkType) = label name (checkType (mempty :: TestString) +checkInstances name (FactorialTest checkType) = label name (checkType () + .&&. checkType (mempty :: TestString) .&&. checkType (mempty :: String) .&&. checkType (mempty :: ByteString) .&&. checkType (mempty :: Lazy.ByteString) @@ -117,7 +126,8 @@ .&&. checkType (mempty :: Lazy.Text) .&&. checkType (mempty :: Seq Char) .&&. checkType (mempty :: Vector Char)) -checkInstances name (LeftReductiveTest checkType) = label name (checkType (mempty :: String) +checkInstances name (LeftReductiveTest checkType) = label name (checkType () + .&&. checkType (mempty :: String) .&&. checkType (mempty :: ByteString) .&&. checkType (mempty :: Lazy.ByteString) .&&. checkType (mempty :: Text) @@ -130,7 +140,8 @@ .&&. checkType (mempty :: Seq String) .&&. checkType (mempty :: Set Integer) .&&. checkType (mempty :: Vector Int)) -checkInstances name (RightReductiveTest checkType) = label name (checkType (mempty :: ByteString) +checkInstances name (RightReductiveTest checkType) = label name (checkType () + .&&. checkType (mempty :: ByteString) .&&. checkType (mempty :: Lazy.ByteString) .&&. checkType (mempty :: Text) .&&. checkType (mempty :: Lazy.Text) @@ -142,13 +153,15 @@ .&&. checkType (mempty :: Seq Int) .&&. checkType (mempty :: Set String) .&&. checkType (mempty :: Vector Int)) -checkInstances name (ReductiveTest checkType) = label name (checkType (mempty :: Sum Integer) +checkInstances name (ReductiveTest checkType) = label name (checkType () + .&&. checkType (mempty :: Sum Integer) .&&. checkType (mempty :: Product Integer) .&&. checkType (mempty :: Dual (Sum Integer)) .&&. checkType (mempty :: (Sum Integer, Sum Int)) .&&. checkType (mempty :: IntSet) .&&. checkType (mempty :: Set Integer)) -checkInstances name (LeftCancellativeTest checkType) = label name (checkType (mempty :: String) +checkInstances name (LeftCancellativeTest checkType) = label name (checkType () + .&&. checkType (mempty :: String) .&&. checkType (mempty :: ByteString) .&&. checkType (mempty :: Lazy.ByteString) .&&. checkType (mempty :: Text) @@ -158,7 +171,8 @@ .&&. checkType (mempty :: (Text, String)) .&&. checkType (mempty :: Seq Int) .&&. checkType (mempty :: Vector Int)) -checkInstances name (RightCancellativeTest checkType) = label name (checkType (mempty :: ByteString) +checkInstances name (RightCancellativeTest checkType) = label name (checkType () + .&&. checkType (mempty :: ByteString) .&&. checkType (mempty :: Lazy.ByteString) .&&. checkType (mempty :: Text) .&&. checkType (mempty :: Lazy.Text) @@ -167,10 +181,12 @@ .&&. checkType (mempty :: (Text, ByteString)) .&&. checkType (mempty :: Seq Int) .&&. checkType (mempty :: Vector Int)) -checkInstances name (CancellativeTest checkType) = label name (checkType (mempty :: Sum Integer) +checkInstances name (CancellativeTest checkType) = label name (checkType () + .&&. checkType (mempty :: Sum Integer) .&&. checkType (mempty :: Dual (Sum Integer)) .&&. checkType (mempty :: (Sum Integer, Sum Int))) -checkInstances name (LeftGCDTest checkType) = label name (checkType (mempty :: String) +checkInstances name (LeftGCDTest checkType) = label name (checkType () + .&&. checkType (mempty :: String) .&&. checkType (mempty :: ByteString) .&&. checkType (mempty :: Lazy.ByteString) .&&. checkType (mempty :: Text) @@ -185,7 +201,8 @@ .&&. checkType (mempty :: Seq Int) .&&. checkType (mempty :: Set String) .&&. checkType (mempty :: Vector Int)) -checkInstances name (RightGCDTest checkType) = label name (checkType (mempty :: ByteString) +checkInstances name (RightGCDTest checkType) = label name (checkType () + .&&. checkType (mempty :: ByteString) .&&. checkType (mempty :: Lazy.ByteString) .&&. checkType (mempty :: Dual String) .&&. checkType (mempty :: Sum Integer) @@ -195,18 +212,21 @@ .&&. checkType (mempty :: Seq Int) .&&. checkType (mempty :: Set String) .&&. checkType (mempty :: Vector Int)) -checkInstances name (GCDTest checkType) = label name (checkType (mempty :: Sum Integer) +checkInstances name (GCDTest checkType) = label name (checkType () + .&&. checkType (mempty :: Sum Integer) .&&. checkType (mempty :: Product Integer) .&&. checkType (mempty :: Dual (Product Integer)) .&&. checkType (mempty :: (Sum Integer, Sum Int)) .&&. checkType (mempty :: IntSet) .&&. checkType (mempty :: Set String)) -checkInstances name (CancellativeGCDTest checkType) = label name (checkType (mempty :: Sum Integer) +checkInstances name (CancellativeGCDTest checkType) = label name (checkType () + .&&. checkType (mempty :: Sum Integer) .&&. checkType (mempty :: Dual (Sum Integer)) .&&. checkType (mempty :: (Sum Integer, Sum Int))) tests :: [(String, Test)] -tests = [("MonoidNull", NullTest checkNull), +tests = [("CommutativeMonoid", CommutativeTest checkCommutative), + ("MonoidNull", NullTest checkNull), ("mconcat . factors == id", FactorialTest checkConcatFactors), ("all factors . factors", FactorialTest checkFactorsOfFactors), ("splitPrimePrefix", FactorialTest checkSplitPrimePrefix), @@ -263,6 +283,9 @@ ("gcd", GCDTest checkGCD), ("cancellative gcd", CancellativeGCDTest checkCancellativeGCD) ] + +checkCommutative :: forall a. (Arbitrary a, Show a, Eq a, CommutativeMonoid a) => a -> Property +checkCommutative e = forAll (arbitrary :: Gen (a, a)) (\(a, b)-> a <> b == b <> a) checkNull :: forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) => a -> Property checkNull e = null e .&&. forAll (arbitrary :: Gen a) (\a-> null a == (a == mempty)) diff --git a/monoid-subclasses.cabal b/monoid-subclasses.cabal --- a/monoid-subclasses.cabal +++ b/monoid-subclasses.cabal @@ -1,5 +1,5 @@ Name: monoid-subclasses -Version: 0.2 +Version: 0.3 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid