diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +Version 1.2.6 +--------------- + +* Improved the performance of `instance FactorialMonoid PrefixMemory` +* Bumped the `containers` dependency upper bound +* Thanks to Jonathan Knowles: + * Documented and added tests for `Monus` laws + * Added the missing class instances and tests for `Identity` and `Const` + * Using `GeneralizedNewtypeDeriving` to simplify existing instances + * Fixed compilation on older versions of GHC + * Updated and improved the CI + * Removed trailing whitespace + Version 1.2.5.1 --------------- diff --git a/Test/TestMonoidSubclasses.hs b/Test/TestMonoidSubclasses.hs --- a/Test/TestMonoidSubclasses.hs +++ b/Test/TestMonoidSubclasses.hs @@ -1,4 +1,4 @@ -{- +{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) @@ -70,7 +70,7 @@ import Data.Semigroup (Semigroup, (<>), Max, Min) import Data.Monoid (Monoid, mempty, mconcat, All(All), Any(Any), Dual(Dual), First(First), Last(Last), Sum(Sum), Product(Product)) -import Data.Semigroup.Factorial (Factorial, StableFactorial, +import Data.Semigroup.Factorial (Factorial, StableFactorial, factors, primePrefix, primeSuffix, foldl, foldl', foldr, length, reverse) import Data.Semigroup.Cancellative (Commutative, Reductive, LeftReductive, RightReductive, @@ -231,6 +231,8 @@ factorialInstances = map upcast stableFactorialInstances ++ [FactorialMonoidInstance (mempty :: Sum Integer), FactorialMonoidInstance (mempty :: Product Int32), + FactorialMonoidInstance (mempty :: Identity String), + FactorialMonoidInstance (mempty :: Const String Int), FactorialMonoidInstance (mempty :: Maybe String), FactorialMonoidInstance (mempty :: (Text, String)), FactorialMonoidInstance (mempty :: (Product Int32, ByteString, Sum Integer)), @@ -247,7 +249,7 @@ where upcast (StableFactorialMonoidInstance i) = FactorialMonoidInstance i stableFactorialInstances :: [StableFactorialMonoidInstance] -stableFactorialInstances = stable1 ++ map measure stable1 ++ map prefixed stable1 ++ map position stable1 +stableFactorialInstances = stable1 ++ map measure stable1 ++ map prefixed stable1 ++ map position stable1 where stable1 = map upcast stableTextualInstances ++ [StableFactorialMonoidInstance (mempty :: ByteString), StableFactorialMonoidInstance (mempty :: Lazy.ByteString), @@ -257,7 +259,7 @@ upcast (StableTextualMonoidInstance i) = StableFactorialMonoidInstance i measure (StableFactorialMonoidInstance i) = StableFactorialMonoidInstance (Measured.measure i) prefixed (StableFactorialMonoidInstance i) = StableFactorialMonoidInstance (PrefixMemory.shadowed i) - position (StableFactorialMonoidInstance (i :: a)) = + position (StableFactorialMonoidInstance (i :: a)) = StableFactorialMonoidInstance (pure i :: OffsetPositioned a) textualInstances :: [TextualMonoidInstance] @@ -282,7 +284,7 @@ StableTextualMonoidInstance (mempty :: Vector Char)] measure (StableTextualMonoidInstance i) = StableTextualMonoidInstance (Measured.measure i) prefixed (StableTextualMonoidInstance i) = StableTextualMonoidInstance (PrefixMemory.shadowed i) - position (StableTextualMonoidInstance (i :: a)) = + position (StableTextualMonoidInstance (i :: a)) = [StableTextualMonoidInstance (pure i :: OffsetPositioned a), StableTextualMonoidInstance (pure i :: LinePositioned a)] @@ -338,6 +340,8 @@ overlappingGCDMonoidInstances = map upcast monusInstances ++ [OverlappingGCDMonoidInstance (mempty :: String), + OverlappingGCDMonoidInstance (mempty :: Identity String), + OverlappingGCDMonoidInstance (mempty :: Const String Int), OverlappingGCDMonoidInstance (mempty :: Seq Int), OverlappingGCDMonoidInstance (mempty :: ByteString), OverlappingGCDMonoidInstance (mempty :: Lazy.ByteString), @@ -350,12 +354,19 @@ monusInstances = [MonusInstance (mempty :: Product Natural), MonusInstance (mempty :: Sum Natural), + MonusInstance (mempty :: Identity (Sum Natural)), + MonusInstance (mempty :: Const (Sum Natural) Int), MonusInstance (mempty :: Dual (Product Natural)), MonusInstance (mempty :: Maybe ()), MonusInstance (mempty :: Maybe (Product Natural)), MonusInstance (mempty :: Maybe (Sum Natural)), MonusInstance (mempty :: IntSet), - MonusInstance (mempty :: Set String)] + MonusInstance (mempty :: Set String), + MonusInstance (mempty :: ()), + MonusInstance (mempty :: (Sum Natural)), + MonusInstance (mempty :: (Sum Natural, Sum Natural)), + MonusInstance (mempty :: (Sum Natural, Sum Natural, Sum Natural)), + MonusInstance (mempty :: (Sum Natural, Sum Natural, Sum Natural, Sum Natural))] leftCancellativeInstances = map upcast cancellativeInstances ++ [LeftCancellativeMonoidInstance (mempty :: String), @@ -388,6 +399,8 @@ LeftGCDMonoidInstance (mempty :: Lazy.ByteString), LeftGCDMonoidInstance (mempty :: Text), LeftGCDMonoidInstance (mempty :: Lazy.Text), + LeftGCDMonoidInstance (mempty :: Identity ByteString), + LeftGCDMonoidInstance (mempty :: Const ByteString Int), LeftGCDMonoidInstance (mempty :: Dual ByteString), LeftGCDMonoidInstance (mempty :: (Text, String)), LeftGCDMonoidInstance (mempty :: (ByteString, Text, String)), @@ -410,6 +423,8 @@ RightGCDMonoidInstance (mempty :: Text), RightGCDMonoidInstance (mempty :: Lazy.Text), RightGCDMonoidInstance (mempty :: String), + RightGCDMonoidInstance (mempty :: Identity ByteString), + RightGCDMonoidInstance (mempty :: Const ByteString Int), RightGCDMonoidInstance (mempty :: Dual String), RightGCDMonoidInstance (mempty :: (Seq Int, ByteString)), RightGCDMonoidInstance (mempty :: Seq Int), @@ -422,6 +437,8 @@ gcdInstances = [ GCDMonoidInstance (mempty :: ()) , GCDMonoidInstance (mempty :: Product Natural) + , GCDMonoidInstance (mempty :: Identity (Sum Natural)) + , GCDMonoidInstance (mempty :: Const (Sum Natural) Int) , GCDMonoidInstance (mempty :: Dual (Product Natural)) , GCDMonoidInstance (mempty :: IntSet) , GCDMonoidInstance (mempty :: Set String) @@ -436,6 +453,8 @@ , DistributiveGCDMonoidInstance (mempty :: Set ()) , DistributiveGCDMonoidInstance (mempty :: Set Bool) , DistributiveGCDMonoidInstance (mempty :: Set Word) + , DistributiveGCDMonoidInstance (mempty :: Identity (Sum Natural)) + , DistributiveGCDMonoidInstance (mempty :: Const (Sum Natural) Int) , DistributiveGCDMonoidInstance (mempty :: Dual (Set ())) , DistributiveGCDMonoidInstance (mempty :: Dual (Set Bool)) , DistributiveGCDMonoidInstance (mempty :: Dual (Set Word)) @@ -466,6 +485,12 @@ , LeftDistributiveGCDMonoidInstance (mempty :: Set Bool) , LeftDistributiveGCDMonoidInstance (mempty :: Set Word) -- Instances for monoid transformers: + , LeftDistributiveGCDMonoidInstance (mempty :: Identity [()]) + , LeftDistributiveGCDMonoidInstance (mempty :: Identity [Bool]) + , LeftDistributiveGCDMonoidInstance (mempty :: Identity [Word]) + , LeftDistributiveGCDMonoidInstance (mempty :: Const [()] Int) + , LeftDistributiveGCDMonoidInstance (mempty :: Const [Bool] Int) + , LeftDistributiveGCDMonoidInstance (mempty :: Const [Word] Int) , LeftDistributiveGCDMonoidInstance (mempty :: Dual [()]) , LeftDistributiveGCDMonoidInstance (mempty :: Dual [Bool]) , LeftDistributiveGCDMonoidInstance (mempty :: Dual [Word]) @@ -496,6 +521,12 @@ , RightDistributiveGCDMonoidInstance (mempty :: Set Bool) , RightDistributiveGCDMonoidInstance (mempty :: Set Word) -- Instances for monoid transformers: + , RightDistributiveGCDMonoidInstance (mempty :: Identity [()]) + , RightDistributiveGCDMonoidInstance (mempty :: Identity [Bool]) + , RightDistributiveGCDMonoidInstance (mempty :: Identity [Word]) + , RightDistributiveGCDMonoidInstance (mempty :: Const [()] Int) + , RightDistributiveGCDMonoidInstance (mempty :: Const [Bool] Int) + , RightDistributiveGCDMonoidInstance (mempty :: Const [Word] Int) , RightDistributiveGCDMonoidInstance (mempty :: Dual [()]) , RightDistributiveGCDMonoidInstance (mempty :: Dual [Bool]) , RightDistributiveGCDMonoidInstance (mempty :: Dual [Word]) @@ -504,6 +535,8 @@ lcmInstances = [LCMMonoidInstance (mempty :: Product Natural), LCMMonoidInstance (mempty :: Sum Natural), + LCMMonoidInstance (mempty :: Identity (Sum Natural)), + LCMMonoidInstance (mempty :: Const (Sum Natural) Int), LCMMonoidInstance (mempty :: Dual (Product Natural)), LCMMonoidInstance (mempty :: Dual (Sum Natural)), LCMMonoidInstance (mempty :: IntSet), @@ -525,6 +558,8 @@ , DistributiveLCMMonoidInstance (mempty :: Set ()) , DistributiveLCMMonoidInstance (mempty :: Set Bool) , DistributiveLCMMonoidInstance (mempty :: Set Word) + , DistributiveLCMMonoidInstance (mempty :: Identity (Sum Natural)) + , DistributiveLCMMonoidInstance (mempty :: Const (Sum Natural) Int) , DistributiveLCMMonoidInstance (mempty :: Dual (Product Natural)) , DistributiveLCMMonoidInstance (mempty :: Dual (Sum Natural)) ] @@ -542,14 +577,14 @@ checkInstances (LeftReductiveTest checkType) = (map checkType leftReductiveInstances) checkInstances (RightReductiveTest checkType) = (map checkType rightReductiveInstances) checkInstances (ReductiveTest checkType) = (map checkType reductiveInstances) -checkInstances (LeftCancellativeTest checkType) = (map checkType leftCancellativeInstances) -checkInstances (RightCancellativeTest checkType) = (map checkType rightCancellativeInstances) -checkInstances (CancellativeTest checkType) = (map checkType cancellativeInstances) +checkInstances (LeftCancellativeTest checkType) = (map checkType leftCancellativeInstances) +checkInstances (RightCancellativeTest checkType) = (map checkType rightCancellativeInstances) +checkInstances (CancellativeTest checkType) = (map checkType cancellativeInstances) checkInstances (OverlappingGCDTest checkType) = (map checkType overlappingGCDMonoidInstances) checkInstances (MonusTest checkType) = (map checkType monusInstances) -checkInstances (LeftGCDTest checkType) = (map checkType leftGCDInstances) -checkInstances (RightGCDTest checkType) = (map checkType rightGCDInstances) -checkInstances (GCDTest checkType) = (map checkType gcdInstances) +checkInstances (LeftGCDTest checkType) = (map checkType leftGCDInstances) +checkInstances (RightGCDTest checkType) = (map checkType rightGCDInstances) +checkInstances (GCDTest checkType) = (map checkType gcdInstances) checkInstances (DistributiveGCDTest checkType) = (map checkType distributiveGCDMonoidInstances) checkInstances (LeftDistributiveGCDTest checkType) = (map checkType leftDistributiveGCDMonoidInstances) checkInstances (RightDistributiveGCDTest checkType) = (map checkType rightDistributiveGCDMonoidInstances) @@ -629,6 +664,12 @@ ("overlap idempotence", OverlappingGCDTest checkOverlap_idempotence), ("overlap identity (left)", OverlappingGCDTest checkOverlap_identity_left), ("overlap identity (right)", OverlappingGCDTest checkOverlap_identity_right), + ("Monus identity (1)", MonusTest checkMonus_identity_1), + ("Monus identity (2)", MonusTest checkMonus_identity_2), + ("Monus mappend (1)", MonusTest checkMonus_mappend_1), + ("Monus mappend (2)", MonusTest checkMonus_mappend_2), + ("Monus stripPrefixOverlap", MonusTest checkMonus_stripPrefixOverlap), + ("Monus stripSuffixOverlap", MonusTest checkMonus_stripSuffixOverlap), ("isPrefixOf", LeftReductiveTest checkIsPrefixOf), ("stripSuffix", RightReductiveTest checkStripSuffix), ("isSuffixOf", RightReductiveTest checkIsSuffixOf), @@ -694,16 +735,16 @@ checkFactorsOfFactors (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (all singleton . factors) where singleton prime = factors prime == [prime] -checkSplitPrimePrefix (FactorialMonoidInstance (_ :: a)) = +checkSplitPrimePrefix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> factors a == unfoldr splitPrimePrefix a) checkSplitPrimeSuffix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = factors a == reverse (unfoldr (fmap swap . splitPrimeSuffix) a) -checkPrimePrefix (FactorialMonoidInstance (_ :: a)) = +checkPrimePrefix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> primePrefix a == maybe mempty fst (splitPrimePrefix a)) -checkPrimeSuffix (FactorialMonoidInstance (_ :: a)) = +checkPrimeSuffix (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> primeSuffix a == maybe mempty snd (splitPrimeSuffix a)) checkInits (FactorialMonoidInstance (_ :: a)) = @@ -712,16 +753,16 @@ checkTails (FactorialMonoidInstance (_ :: a)) = mapSize (`div` 5) $ forAll (arbitrary :: Gen a) (\a-> tails a == List.map mconcat (List.tails $ factors a)) -checkLeftFold (FactorialMonoidInstance (_ :: a)) = +checkLeftFold (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldl (flip (:)) [] a == List.foldl (flip (:)) [] (factors a)) -checkLeftFold' (FactorialMonoidInstance (_ :: a)) = +checkLeftFold' (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldl' (flip (:)) [] a == List.foldl' (flip (:)) [] (factors a)) -checkRightFold (FactorialMonoidInstance (_ :: a)) = +checkRightFold (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> foldr (:) [] a == List.foldr (:) [] (factors a)) -checkLength (FactorialMonoidInstance (_ :: a)) = +checkLength (FactorialMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) (\a-> length a == List.length (factors a)) checkSpan (FactorialMonoidInstance (_ :: a)) = property $ \p-> forAll (arbitrary :: Gen a) (check p) @@ -744,19 +785,19 @@ where check i a = splitAt i a == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors a) -checkReverse (FactorialMonoidInstance (_ :: a)) = +checkReverse (FactorialMonoidInstance (_ :: a)) = property $ forAll (arbitrary :: Gen a) (\a-> reverse a == mconcat (List.reverse $ factors a)) checkStability (StableFactorialMonoidInstance (_ :: a)) = property $ forAll (arbitrary :: Gen (a, a)) (\(a, b)-> factors (a <> b) == factors a <> factors b) -checkFromText (TextualMonoidInstance (_ :: a)) = +checkFromText (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen Text) (\t-> Textual.fromText t == (fromString (Text.unpack t) :: a)) -checkSingleton (TextualMonoidInstance (_ :: a)) = +checkSingleton (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen Char) (\c-> Textual.singleton c == (fromString [c] :: a)) -checkSplitCharacterPrefix (TextualMonoidInstance (_ :: a)) = +checkSplitCharacterPrefix (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen String) check1 .&&. forAll (arbitrary :: Gen a) check2 where check1 s = unfoldr Textual.splitCharacterPrefix (fromString s :: a) == s check2 t = Textual.splitCharacterPrefix (primePrefix t) @@ -774,7 +815,7 @@ checkFactorsFromString (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen String) check where check s = unfoldr Textual.splitCharacterPrefix (fromString s :: a) == s -checkTextualMap (TextualMonoidInstance (_ :: a)) = +checkTextualMap (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.map wrapSucc a == Textual.concatMap (Textual.singleton . wrapSucc) a && Textual.map id a == a @@ -783,7 +824,7 @@ | c == maxBound = minBound | otherwise = succ c -checkConcatMap (TextualMonoidInstance (_ :: a)) = +checkConcatMap (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.concatMap (fromString . f) a == mconcat (map apply $ factors a) && Textual.concatMap Textual.singleton a == a @@ -797,19 +838,19 @@ checkAny (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check where check a = Textual.any isLetter a == Textual.foldr (const id) ((||) . isLetter) False a -checkTextualFoldl (TextualMonoidInstance (_ :: a)) = +checkTextualFoldl (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl (\l a-> Left a : l) (\l c-> Right c : l) [] a == List.reverse (textualFactors a) && Textual.foldl (<>) (\a-> (a <>) . Textual.singleton) mempty a == a check2 s = Textual.foldl undefined (flip (:)) [] s == List.foldl (flip (:)) [] s -checkTextualFoldr (TextualMonoidInstance (_ :: a)) = +checkTextualFoldr (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldr (\a l-> Left a : l) (\c l-> Right c : l) [] a == textualFactors a && Textual.foldr (<>) ((<>) . Textual.singleton) mempty a == a check2 s = Textual.foldr undefined (:) [] (fromString s :: a) == s -checkTextualFoldl' (TextualMonoidInstance (_ :: a)) = +checkTextualFoldl' (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.foldl' (\l a-> Left a : l) (\l c-> Right c : l) [] a == List.reverse (textualFactors a) && Textual.foldl' (<>) (\a-> (a <>) . Textual.singleton) mempty a == a @@ -868,28 +909,28 @@ where check1 a = forAll arbitrary $ \f-> Textual.toText f a == Textual.foldr (\t s-> f t <> s) Text.cons Text.empty a check2 s = Textual.toText undefined (Textual.fromText s :: a) == s -checkTextualMapAccumL (TextualMonoidInstance (_ :: a)) = +checkTextualMapAccumL (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumL (,)) ((), a) == ((), a) check2 s = Textual.mapAccumL f c (fromString s :: a) == fmap fromString (List.mapAccumL f c s) c = 0 :: Int f n c = if isLetter c then (succ n, succ c) else (2*n, c) -checkTextualMapAccumR (TextualMonoidInstance (_ :: a)) = +checkTextualMapAccumR (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = uncurry (Textual.mapAccumR (,)) ((), a) == ((), a) check2 s = Textual.mapAccumR f c (fromString s :: a) == fmap fromString (List.mapAccumR f c s) c = 0 :: Int f n c = if isLetter c then (succ n, succ c) else (2*n, c) -checkTextualTakeWhile (TextualMonoidInstance (_ :: a)) = +checkTextualTakeWhile (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.takeWhile (const True) isLetter a) == List.takeWhile (either (const True) isLetter) (textualFactors a) && Textual.takeWhile (const True) (const True) a == a check2 s = Textual.takeWhile undefined isLetter (fromString s :: a) == fromString (List.takeWhile isLetter s) -checkTextualDropWhile (TextualMonoidInstance (_ :: a)) = +checkTextualDropWhile (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.dropWhile (const True) isLetter a) == List.dropWhile (either (const True) isLetter) (textualFactors a) @@ -942,14 +983,14 @@ foldMaybe = Textual.foldl_' gc (Just s0) gc s c = s >>= flip fc c -checkTextualTakeWhile_ (TextualMonoidInstance (_ :: a)) = +checkTextualTakeWhile_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.takeWhile_ True isLetter a) == List.takeWhile (either (const True) isLetter) (textualFactors a) && Textual.takeWhile_ True (const True) a == a check2 s = Textual.takeWhile_ undefined isLetter (fromString s :: a) == fromString (List.takeWhile isLetter s) -checkTextualDropWhile_ (TextualMonoidInstance (_ :: a)) = +checkTextualDropWhile_ (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = textualFactors (Textual.dropWhile_ True isLetter a) == List.dropWhile (either (const True) isLetter) (textualFactors a) @@ -961,7 +1002,7 @@ where check a = List.all (List.all isLetter . rights . textualFactors) (Textual.split (not . isLetter) a) && (mconcat . intersperse (fromString " ") . Textual.split (== ' ')) a == a -checkTextualFind (TextualMonoidInstance (_ :: a)) = +checkTextualFind (TextualMonoidInstance (_ :: a)) = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 where check1 a = Textual.find isLetter a == (List.find isLetter . rights . textualFactors) a check2 s = Textual.find isLetter (fromString s :: a) == List.find isLetter s @@ -1263,11 +1304,41 @@ where check a b c = gcd a (lcm b c) === lcm (gcd a b) (gcd a c) +checkMonus_identity_1 (MonusInstance (_ :: a)) = + forAll (arbitrary :: Gen a) check + where + check a = a <\> a === mempty + +checkMonus_identity_2 (MonusInstance (_ :: a)) = + forAll (arbitrary :: Gen a) check + where + check a = mempty <\> a === mempty + +checkMonus_mappend_1 (MonusInstance (_ :: a)) = + forAll (arbitrary :: Gen (a, a)) check + where + check a b = a <> (b <\> a) === b <> (a <\> b) + +checkMonus_mappend_2 (MonusInstance (_ :: a)) = + forAll (arbitrary :: Gen (a, a, a)) check + where + check (a, b, c) = (a <\> b) <\> c === a <\> (b <> c) + +checkMonus_stripPrefixOverlap (MonusInstance (_ :: a)) = + forAll (arbitrary :: Gen (a, a)) check + where + check (a, b) = (a <\> b) === stripPrefixOverlap b a + +checkMonus_stripSuffixOverlap (MonusInstance (_ :: a)) = + forAll (arbitrary :: Gen (a, a)) check + where + check (a, b) = (a <\> b) === stripSuffixOverlap b a + textualFactors :: TextualMonoid t => t -> [Either t Char] textualFactors = map characterize . factors where characterize prime = maybe (Left prime) Right (Textual.characterPrefix prime) -newtype TestString = TestString String deriving (Eq, Show, Arbitrary, CoArbitrary, +newtype TestString = TestString String deriving (Eq, Show, Arbitrary, CoArbitrary, Semigroup, LeftReductive, LeftCancellative, StableFactorial, Monoid, LeftGCDMonoid, MonoidNull, PositiveMonoid, IsString) diff --git a/monoid-subclasses.cabal b/monoid-subclasses.cabal --- a/monoid-subclasses.cabal +++ b/monoid-subclasses.cabal @@ -1,14 +1,27 @@ Name: monoid-subclasses -Version: 1.2.5.1 +Version: 1.2.6 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid Category: Data, Algebra, Text -Tested-with: GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 +Tested-with: GHC==8.0.2 + , GHC==8.2.2 + , GHC==8.4.4 + , GHC==8.6.5 + , GHC==8.8.4 + , GHC==8.10.7 + , GHC==9.0.2 + , GHC==9.2.8 + , GHC==9.4.8 + , GHC==9.6.6 + , GHC==9.8.4 + , GHC==9.10.1 + , GHC==9.12.1 + Description: A hierarchy of subclasses of 'Monoid' together with their instances for all data structures from base, containers, and text packages. - + License: BSD3 License-file: BSD3-LICENSE.txt Copyright: (c) 2013-2024 Mario Blažević @@ -42,7 +55,7 @@ , Data.Semigroup.Factorial Build-Depends: base >= 4.9 && < 5, bytestring >= 0.9 && < 1.0, - containers >= 0.5.7.0 && < 0.8, + containers >= 0.5.7.0 && < 0.9, text >= 0.11 && < 1.3 || >= 2.0 && < 2.2, primes == 0.2.*, vector >= 0.12 && < 0.14, diff --git a/src/Data/Monoid/Factorial.hs b/src/Data/Monoid/Factorial.hs --- a/src/Data/Monoid/Factorial.hs +++ b/src/Data/Monoid/Factorial.hs @@ -1,13 +1,15 @@ -{- +{- Copyright 2013-2017 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'FactorialMonoid' class and some of its instances. --- +-- {-# LANGUAGE Haskell2010, ConstraintKinds, FlexibleInstances, Trustworthy #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} module Data.Monoid.Factorial ( module Data.Semigroup.Factorial, @@ -16,6 +18,8 @@ where import Control.Arrow (first) +import Data.Functor.Const (Const (Const)) +import Data.Functor.Identity (Identity (Identity)) import Data.Monoid -- (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) import qualified Data.Foldable as Foldable import qualified Data.List as List @@ -46,9 +50,9 @@ -- Factors of a list are /not/ its elements but all its single-item sublists: -- -- prop> factors "abc" == ["a", "b", "c"] --- +-- -- The methods of this class satisfy the following laws in addition to those of 'Factorial': --- +-- -- > null == List.null . factors -- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix) -- > reverse == mconcat . List.reverse . factors @@ -162,6 +166,10 @@ instance FactorialMonoid () where splitPrimePrefix () = Nothing splitPrimeSuffix () = Nothing + +deriving instance FactorialMonoid a => FactorialMonoid (Identity a) + +deriving instance FactorialMonoid a => FactorialMonoid (Const a b) instance FactorialMonoid a => FactorialMonoid (Dual a) where splitPrimePrefix (Dual a) = case splitPrimeSuffix a diff --git a/src/Data/Monoid/GCD.hs b/src/Data/Monoid/GCD.hs --- a/src/Data/Monoid/GCD.hs +++ b/src/Data/Monoid/GCD.hs @@ -1,4 +1,4 @@ -{- +{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) @@ -49,6 +49,8 @@ -- Subclass of 'RightGCDMonoid' with /right/-distributivity. -- {-# LANGUAGE CPP, Haskell2010, FlexibleInstances, Trustworthy #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} module Data.Monoid.GCD ( GCDMonoid (..) @@ -63,6 +65,8 @@ import qualified Prelude +import Data.Functor.Const (Const (Const)) +import Data.Functor.Identity (Identity (Identity)) import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..)) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Unsafe as ByteString @@ -210,7 +214,7 @@ -- | Class of monoids capable of finding the equivalent of greatest common divisor on the right side of two monoidal -- values. The following laws must be respected: --- +-- -- > stripCommonSuffix a b == (a', b', s) -- > where s = commonSuffix a b -- > Just a' = stripSuffix p a @@ -285,6 +289,18 @@ instance RightGCDMonoid () where commonSuffix () () = () +-- Identity instances + +deriving instance GCDMonoid a => GCDMonoid (Identity a) +deriving instance LeftGCDMonoid a => LeftGCDMonoid (Identity a) +deriving instance RightGCDMonoid a => RightGCDMonoid (Identity a) + +-- Const instances + +deriving instance GCDMonoid a => GCDMonoid (Const a b) +deriving instance LeftGCDMonoid a => LeftGCDMonoid (Const a b) +deriving instance RightGCDMonoid a => RightGCDMonoid (Const a b) + -- Dual instances instance GCDMonoid a => GCDMonoid (Dual a) where @@ -617,6 +633,8 @@ => DistributiveGCDMonoid m instance DistributiveGCDMonoid () +instance DistributiveGCDMonoid a => DistributiveGCDMonoid (Identity a) +instance DistributiveGCDMonoid a => DistributiveGCDMonoid (Const a b) instance DistributiveGCDMonoid (Product Natural) instance DistributiveGCDMonoid (Sum Natural) instance DistributiveGCDMonoid IntSet.IntSet @@ -655,6 +673,8 @@ instance Ord a => LeftDistributiveGCDMonoid (Set.Set a) -- Instances for monoid transformers: +instance LeftDistributiveGCDMonoid a => LeftDistributiveGCDMonoid (Identity a) +instance LeftDistributiveGCDMonoid a => LeftDistributiveGCDMonoid (Const a b) instance RightDistributiveGCDMonoid a => LeftDistributiveGCDMonoid (Dual a) -------------------------------------------------------------------------------- @@ -689,4 +709,6 @@ instance Ord a => RightDistributiveGCDMonoid (Set.Set a) -- Instances for monoid transformers: +instance RightDistributiveGCDMonoid a => RightDistributiveGCDMonoid (Identity a) +instance RightDistributiveGCDMonoid a => RightDistributiveGCDMonoid (Const a b) instance LeftDistributiveGCDMonoid a => RightDistributiveGCDMonoid (Dual a) diff --git a/src/Data/Monoid/Instances/PrefixMemory.hs b/src/Data/Monoid/Instances/PrefixMemory.hs --- a/src/Data/Monoid/Instances/PrefixMemory.hs +++ b/src/Data/Monoid/Instances/PrefixMemory.hs @@ -130,6 +130,10 @@ where rewrap (cp, cs) = (Shadowed p cp, Shadowed (p <> cp) cs) splitPrimeSuffix (Shadowed p c) = fmap rewrap (splitPrimeSuffix c) where rewrap (cp, cs) = (Shadowed p cp, Shadowed (p <> cp) cs) + inits (Shadowed p c) = Shadowed p <$> inits c + tails (Shadowed p c) + | null p = zipWith Shadowed (inits c) (tails c) + | otherwise = zipWith (Shadowed . (p <>)) (inits c) (tails c) spanMaybe s0 f (Shadowed p0 c) = rewrap $ Factorial.spanMaybe (s0, p0) f' c where f' (s, p) prime = do s' <- f s (Shadowed p prime) let p' = p <> prime diff --git a/src/Data/Monoid/Instances/Stateful.hs b/src/Data/Monoid/Instances/Stateful.hs --- a/src/Data/Monoid/Instances/Stateful.hs +++ b/src/Data/Monoid/Instances/Stateful.hs @@ -70,11 +70,11 @@ {-# INLINE mempty #-} {-# INLINE mappend #-} -instance (MonoidNull a, MonoidNull b) => MonoidNull (Stateful a b) where +instance (Semigroup a, Semigroup b, MonoidNull a, MonoidNull b) => MonoidNull (Stateful a b) where null (Stateful x) = null x {-# INLINE null #-} -instance (PositiveMonoid a, PositiveMonoid b) => PositiveMonoid (Stateful a b) +instance (Semigroup a, Semigroup b, PositiveMonoid a, PositiveMonoid b) => PositiveMonoid (Stateful a b) instance (LeftReductive a, LeftReductive b) => LeftReductive (Stateful a b) where isPrefixOf (Stateful x) (Stateful x') = isPrefixOf x x' diff --git a/src/Data/Monoid/LCM.hs b/src/Data/Monoid/LCM.hs --- a/src/Data/Monoid/LCM.hs +++ b/src/Data/Monoid/LCM.hs @@ -1,4 +1,6 @@ {-# LANGUAGE Haskell2010, FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} -- | This module defines the 'LCMMonoid' subclass of the 'Monoid' class. -- @@ -21,6 +23,8 @@ import Prelude hiding (gcd, lcm, max) import qualified Prelude +import Data.Functor.Const (Const (Const)) +import Data.Functor.Identity (Identity (Identity)) import Data.IntSet (IntSet) import Data.Monoid (Dual (..), Product (..), Sum (..)) import Data.Monoid.GCD (GCDMonoid (..), DistributiveGCDMonoid) @@ -106,6 +110,10 @@ instance LCMMonoid () where lcm () () = () +deriving instance LCMMonoid a => LCMMonoid (Identity a) + +deriving instance LCMMonoid a => LCMMonoid (Const a b) + instance LCMMonoid a => LCMMonoid (Dual a) where lcm (Dual a) (Dual b) = Dual (lcm a b) @@ -166,6 +174,8 @@ class (DistributiveGCDMonoid m, LCMMonoid m) => DistributiveLCMMonoid m instance DistributiveLCMMonoid () +instance DistributiveLCMMonoid a => DistributiveLCMMonoid (Identity a) +instance DistributiveLCMMonoid a => DistributiveLCMMonoid (Const a b) instance DistributiveLCMMonoid (Product Natural) instance DistributiveLCMMonoid (Sum Natural) instance DistributiveLCMMonoid IntSet diff --git a/src/Data/Monoid/Monus.hs b/src/Data/Monoid/Monus.hs --- a/src/Data/Monoid/Monus.hs +++ b/src/Data/Monoid/Monus.hs @@ -1,4 +1,4 @@ -{- +{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) @@ -9,12 +9,16 @@ -- @since 1.0 {-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} module Data.Monoid.Monus ( Monus(..), OverlappingGCDMonoid(..) ) where - + +import Data.Functor.Const (Const (Const)) +import Data.Functor.Identity (Identity (Identity)) import Data.Monoid -- (Monoid, Dual(..), Sum(..), Product(..)) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LazyByteString @@ -34,12 +38,33 @@ import Prelude hiding (null) --- | Class of Abelian monoids with monus. The monus operation '<\>' is a synonym for both 'stripPrefixOverlap' and --- 'stripSuffixOverlap', which must be equivalent as '<>' is both associative and commutative: +-- | Class of Abelian monoids with monus. -- +-- The monus operation '<\>' is a synonym for both 'stripPrefixOverlap' and +-- 'stripSuffixOverlap', which must be equivalent as '<>' is both associative +-- and commutative: +-- -- > (<\>) = flip stripPrefixOverlap -- > (<\>) = flip stripSuffixOverlap -- +-- In addition, the monus operation '<\>' must satisfy the following laws: +-- +-- @ +-- a '<\>' a '==' 'mempty' +-- @ +-- +-- @ +-- 'mempty' '<\>' a '==' 'mempty' +-- @ +-- +-- @ +-- a '<>' (b '<\>' a) '==' b '<>' (a '<\>' b) +-- @ +-- +-- @ +-- (a '<\>' b) '<\>' c '==' a '<\>' (b '<>' c) +-- @ +-- -- @since 1.0 class (Commutative m, Monoid m, OverlappingGCDMonoid m) => Monus m where (<\>) :: m -> m -> m @@ -111,6 +136,16 @@ stripOverlap () () = ((), (), ()) stripPrefixOverlap () () = () stripSuffixOverlap () () = () + +-- Identity instances + +deriving instance Monus a => Monus (Identity a) +deriving instance OverlappingGCDMonoid a => OverlappingGCDMonoid (Identity a) + +-- Const instances + +deriving instance Monus a => Monus (Const a b) +deriving instance OverlappingGCDMonoid a => OverlappingGCDMonoid (Const a b) -- Dual instances diff --git a/src/Data/Monoid/Null.hs b/src/Data/Monoid/Null.hs --- a/src/Data/Monoid/Null.hs +++ b/src/Data/Monoid/Null.hs @@ -8,6 +8,8 @@ -- {-# LANGUAGE Haskell2010, CPP, FlexibleInstances, DefaultSignatures, Trustworthy #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} module Data.Monoid.Null ( MonoidNull(..), PositiveMonoid @@ -140,12 +142,10 @@ #endif -- | @since 1.2.5.0 -instance MonoidNull r => MonoidNull (Const r a) where - null (Const r) = null r +deriving instance MonoidNull a => MonoidNull (Const a b) -- | @since 1.2.5.0 -instance MonoidNull a => MonoidNull (Identity a) where - null (Identity a) = null a +deriving instance MonoidNull a => MonoidNull (Identity a) -- | @since 1.2.5.0 instance MonoidNull a => MonoidNull (WrappedMonoid a) where diff --git a/src/Data/Semigroup/Cancellative.hs b/src/Data/Semigroup/Cancellative.hs --- a/src/Data/Semigroup/Cancellative.hs +++ b/src/Data/Semigroup/Cancellative.hs @@ -1,4 +1,4 @@ -{- +{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) @@ -17,16 +17,18 @@ -- -- All semigroup subclasses listed above are for Abelian, /i.e./, commutative or symmetric semigroups. Since most -- practical semigroups in Haskell are not Abelian, each of the these classes has two symmetric superclasses: --- +-- -- * 'LeftReductive' --- +-- -- * 'LeftCancellative' --- +-- -- * 'RightReductive' --- +-- -- * 'RightCancellative' {-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} module Data.Semigroup.Cancellative ( -- * Symmetric, commutative semigroup classes @@ -59,7 +61,7 @@ -- | Class of Abelian semigroups with a partial inverse for the Semigroup '<>' operation. The inverse operation '' must -- satisfy the following laws: --- +-- -- > maybe a (b <>) (a b) == a -- > maybe a (<> b) (a b) == a -- @@ -81,11 +83,11 @@ class (LeftCancellative m, RightCancellative m, Reductive m) => Cancellative m -- | Class of semigroups with a left inverse of 'Data.Semigroup.<>', satisfying the following law: --- +-- -- > isPrefixOf a b == isJust (stripPrefix a b) -- > maybe b (a <>) (stripPrefix a b) == b -- > a `isPrefixOf` (a <> b) --- +-- -- Every instance definition has to implement at least the 'stripPrefix' method. class Semigroup m => LeftReductive m where isPrefixOf :: m -> m -> Bool @@ -95,11 +97,11 @@ {-# MINIMAL stripPrefix #-} -- | Class of semigroups with a right inverse of 'Data.Semigroup.<>', satisfying the following law: --- +-- -- > isSuffixOf a b == isJust (stripSuffix a b) -- > maybe b (<> a) (stripSuffix a b) == b -- > b `isSuffixOf` (a <> b) --- +-- -- Every instance definition has to implement at least the 'stripSuffix' method. class Semigroup m => RightReductive m where isSuffixOf :: m -> m -> Bool @@ -248,27 +250,17 @@ -- Identity & Const instances -instance Reductive a => Reductive (Identity a) where - Identity a Identity b = Identity <$> (a b) -instance Reductive a => Reductive (Const a x) where - Const a Const b = Const <$> (a b) +deriving instance Reductive a => Reductive (Identity a) +deriving instance Reductive a => Reductive (Const a b) instance Cancellative a => Cancellative (Identity a) instance Cancellative a => Cancellative (Const a x) -instance LeftReductive a => LeftReductive (Identity a) where - stripPrefix (Identity a) (Identity b) = Identity <$> stripPrefix a b - isPrefixOf (Identity a) (Identity b) = isPrefixOf a b -instance LeftReductive a => LeftReductive (Const a x) where - stripPrefix (Const a) (Const b) = Const <$> stripPrefix a b - isPrefixOf (Const a) (Const b) = isPrefixOf a b +deriving instance LeftReductive a => LeftReductive (Identity a) +deriving instance LeftReductive a => LeftReductive (Const a b) -instance RightReductive a => RightReductive (Identity a) where - stripSuffix (Identity a) (Identity b) = Identity <$> stripSuffix a b - isSuffixOf (Identity a) (Identity b) = isSuffixOf a b -instance RightReductive a => RightReductive (Const a x) where - stripSuffix (Const a) (Const b) = Const <$> stripSuffix a b - isSuffixOf (Const a) (Const b) = isSuffixOf a b +deriving instance RightReductive a => RightReductive (Identity a) +deriving instance RightReductive a => RightReductive (Const a b) instance LeftCancellative a => LeftCancellative (Identity a) instance LeftCancellative a => LeftCancellative (Const a x) diff --git a/src/Data/Semigroup/Factorial.hs b/src/Data/Semigroup/Factorial.hs --- a/src/Data/Semigroup/Factorial.hs +++ b/src/Data/Semigroup/Factorial.hs @@ -1,13 +1,15 @@ -{- +{- Copyright 2013-2019 Mario Blazevic License: BSD3 (see BSD3-LICENSE.txt file) -} -- | This module defines the 'Semigroup' => 'Factorial' => 'StableFactorial' classes and some of their instances. --- +-- {-# LANGUAGE Haskell2010, FlexibleInstances, Trustworthy #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} module Data.Semigroup.Factorial ( -- * Classes @@ -18,6 +20,8 @@ where import qualified Control.Monad as Monad +import Data.Functor.Const (Const (Const)) +import Data.Functor.Identity (Identity (Identity)) import Data.Semigroup -- (Semigroup (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) import qualified Data.Foldable as Foldable import qualified Data.List as List @@ -50,9 +54,9 @@ -- Factors of a list are /not/ its elements but all its single-item sublists: -- -- prop> factors "abc" == ["a", "b", "c"] --- +-- -- The methods of this class satisfy the following laws: --- +-- -- > maybe id sconcat . nonEmpty . factors == id -- > List.all (\prime-> factors prime == [prime]) . factors -- > primePrefix s == foldr const s s @@ -117,6 +121,10 @@ length () = 0 reverse = id +deriving instance Factorial a => Factorial (Identity a) + +deriving instance Factorial a => Factorial (Const a b) + instance Factorial a => Factorial (Dual a) where factors (Dual a) = fmap Dual (reverse $ factors a) length (Dual a) = length a @@ -420,6 +428,8 @@ reverse = Vector.reverse instance StableFactorial () +instance StableFactorial a => StableFactorial (Identity a) +instance StableFactorial a => StableFactorial (Const a b) instance StableFactorial a => StableFactorial (Dual a) instance StableFactorial [x] instance StableFactorial ByteString.ByteString