diff --git a/BSD3-LICENSE.txt b/BSD3-LICENSE.txt new file mode 100644 --- /dev/null +++ b/BSD3-LICENSE.txt @@ -0,0 +1,22 @@ +Copyright (c) 2012-2013, Mario Blazevic +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the +following conditions are met: + +Redistributions of source code must retain the above copyright notice, this list of conditions and the following +disclaimer. + +Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following +disclaimer in the documentation and/or other materials provided with the distribution. + +Neither the name of {{the ORGANIZATION nor the names of its contributors}} may be used to endorse or promote products +derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY {{THE COPYRIGHT HOLDERS AND CONTRIBUTORS}} "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL {{THE COPYRIGHT HOLDER OR CONTRIBUTORS}} BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Data/Monoid/Cancellative.hs b/Data/Monoid/Cancellative.hs new file mode 100644 --- /dev/null +++ b/Data/Monoid/Cancellative.hs @@ -0,0 +1,547 @@ +{- + Copyright 2011-2013 Mario Blazevic + + License: BSD3 (see BSD3-LICENSE.txt file) +-} + +-- | This module defines the 'Monoid' => 'ReductiveMonoid' => ('CancellativeMonoid', 'GCDMonoid') class hierarchy. +-- +-- The 'ReductiveMonoid' class introduces operation '' which is the inverse of '<>'. For the 'Sum' monoid, this +-- operation is subtraction; for 'Product' it is division and for 'Set' it's the set difference. A 'ReductiveMonoid' is +-- not a full group because '' may return 'Nothing'. +-- +-- The 'CancellativeMonoid' subclass does not add any operation but it provides the additional guarantee that '<>' can +-- always be undone with ''. Thus 'Sum' is a 'CancellativeMonoid' but 'Product' is not because @(0*n)/0@ is not +-- defined. +-- +-- The 'GCDMonoid' subclass adds the 'gcd' operation which takes two monoidal arguments and finds their greatest common +-- divisor, or (more generally) the greatest monoid that can be extracted with the '' operation from both. +-- +-- All monoid subclasses listed above are for Abelian, /i.e./, commutative or symmetric monoids. Since most practical +-- monoids in Haskell are not Abelian, each of the these classes has two symmetric superclasses: +-- +-- * 'LeftReductiveMonoid' +-- +-- * 'LeftCancellativeMonoid' +-- +-- * 'LeftGCDMonoid' +-- +-- * 'RightReductiveMonoid' +-- +-- * 'RightCancellativeMonoid' +-- +-- * 'RightGCDMonoid' + +{-# LANGUAGE Haskell2010 #-} + +module Data.Monoid.Cancellative ( + -- * Symmetric monoid classes + ReductiveMonoid(..), CancellativeMonoid(..), GCDMonoid(..), + -- * Asymmetric monoid classes + LeftReductiveMonoid(..), RightReductiveMonoid(..), + LeftCancellativeMonoid(..), RightCancellativeMonoid(..), + LeftGCDMonoid(..), RightGCDMonoid(..) + ) +where + +import Prelude hiding (gcd) +import qualified Prelude + +import Data.Monoid (Monoid (mappend), Dual(..), Sum(..), Product(..)) +import qualified Data.List as List +import Data.Maybe (isJust) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Sequence as Sequence +import qualified Data.Set as Set +import Data.Sequence (ViewL((:<)), ViewR((:>)), (<|), (|>)) +import qualified Data.Vector as Vector + +-- | 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 + () :: m -> m -> Maybe m + +infix 5 + +-- | Subclass of 'ReductiveMonoid' where '' is a complete inverse of the Monoid '<>' operation. The class instances +-- must satisfy the following additional laws: +-- +-- > (a <> b) a == Just b +-- > (a <> b) b == Just a +class (LeftCancellativeMonoid m, RightCancellativeMonoid m, ReductiveMonoid m) => CancellativeMonoid m + +-- | Class of Abelian monoids that allow the greatest common denominator to be found for any two given values. The +-- operations must satisfy the following laws: +-- +-- > gcd a b == commonPrefix a b == commonSuffix a b +-- > Just a' = a p && Just b' = b p +-- > where p = gcd a b +-- +-- If a 'GCDMonoid' happens to also be a 'CancellativeMonoid', it should additionally satisfy the following laws: +-- +-- > gcd (a <> b) (a <> c) == a <> gcd b c +-- > gcd (a <> c) (b <> c) == gcd a b <> c +class (ReductiveMonoid m, LeftGCDMonoid m, RightGCDMonoid m) => GCDMonoid m where + gcd :: m -> m -> m + +-- | Class of monoids with a left inverse of 'mappend', 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. Its complexity should be no worse +-- than linear in the length of the prefix argument. +class Monoid m => LeftReductiveMonoid m where + isPrefixOf :: m -> m -> Bool + stripPrefix :: m -> m -> Maybe m + + isPrefixOf a b = isJust (stripPrefix a b) + +-- | Class of monoids with a right inverse of 'mappend', 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. Its complexity should be no worse +-- than linear in the length of the suffix argument. +class Monoid m => RightReductiveMonoid m where + isSuffixOf :: m -> m -> Bool + stripSuffix :: m -> m -> Maybe m + + isSuffixOf a b = isJust (stripSuffix a b) + +-- | Subclass of 'LeftReductiveMonoid' where 'stripPrefix' is a complete inverse of '<>', satisfying the following +-- additional law: +-- +-- > stripPrefix a (a <> b) == Just b +class LeftReductiveMonoid m => LeftCancellativeMonoid m + +-- | Subclass of 'LeftReductiveMonoid' where 'stripPrefix' is a complete inverse of '<>', satisfying the following +-- additional law: +-- +-- > stripSuffix b (a <> b) == Just a +class RightReductiveMonoid m => RightCancellativeMonoid m + +-- | Class of monoids capable of finding the equivalent of greatest common divisor on the left side of two monoidal +-- values. The methods' complexity should be no worse than linear in the length of the common prefix. The following laws +-- must be respected: +-- +-- > stripCommonPrefix a b == (p, a', b') +-- > where p = commonPrefix a b +-- > Just a' = stripPrefix p a +-- > Just b' = stripPrefix p b +-- > p == commonPrefix a b && p <> a' == a && p <> b' == b +-- > where (p, a', b') = stripCommonPrefix a b +class LeftReductiveMonoid m => LeftGCDMonoid m where + commonPrefix :: m -> m -> m + stripCommonPrefix :: m -> m -> (m, m, m) + + commonPrefix x y = p + where (p, _, _) = stripCommonPrefix x y + stripCommonPrefix x y = (p, x', y') + where p = commonPrefix x y + Just x' = stripPrefix p x + Just y' = stripPrefix p y + +-- | Class of monoids capable of finding the equivalent of greatest common divisor on the right side of two monoidal +-- values. The methods' complexity must be no worse than linear in the length of the common suffix. The following laws +-- must be respected: +-- +-- > stripCommonSuffix a b == (a', b', s) +-- > where s = commonSuffix a b +-- > Just a' = stripSuffix p a +-- > Just b' = stripSuffix p b +-- > s == commonSuffix a b && a' <> s == a && b' <> s == b +-- > where (a', b', s) = stripCommonSuffix a b +class RightReductiveMonoid m => RightGCDMonoid m where + commonSuffix :: m -> m -> m + stripCommonSuffix :: m -> m -> (m, m, m) + + commonSuffix x y = s + where (_, _, s) = stripCommonSuffix x y + stripCommonSuffix x y = (x', y', s) + where s = commonSuffix x y + Just x' = stripSuffix s x + Just y' = stripSuffix s y + +-- Dual instances + +instance ReductiveMonoid a => ReductiveMonoid (Dual a) where + Dual a Dual b = fmap Dual (a b) + +instance CancellativeMonoid a => CancellativeMonoid (Dual a) + +instance GCDMonoid a => GCDMonoid (Dual a) where + gcd (Dual a) (Dual b) = Dual (gcd a b) + +instance LeftReductiveMonoid a => RightReductiveMonoid (Dual a) where + stripSuffix (Dual a) (Dual b) = fmap Dual (stripPrefix a b) + Dual a `isSuffixOf` Dual b = a `isPrefixOf` b + +instance RightReductiveMonoid a => LeftReductiveMonoid (Dual a) where + stripPrefix (Dual a) (Dual b) = fmap Dual (stripSuffix a b) + Dual a `isPrefixOf` Dual b = a `isSuffixOf` b + +instance LeftCancellativeMonoid a => RightCancellativeMonoid (Dual a) + +instance RightCancellativeMonoid a => LeftCancellativeMonoid (Dual a) + +instance LeftGCDMonoid a => RightGCDMonoid (Dual a) where + commonSuffix (Dual a) (Dual b) = Dual (commonPrefix a b) + +instance RightGCDMonoid a => LeftGCDMonoid (Dual a) where + commonPrefix (Dual a) (Dual b) = Dual (commonSuffix a b) + +-- Sum instances + +instance Integral a => ReductiveMonoid (Sum a) where + Sum a Sum b = Just $ Sum (a - b) + +instance Integral a => CancellativeMonoid (Sum a) + +instance (Integral a, Ord a) => GCDMonoid (Sum a) where + gcd (Sum a) (Sum b) = Sum (min a b) + +instance Integral a => LeftReductiveMonoid (Sum a) where + stripPrefix a b = b a + +instance Integral a => RightReductiveMonoid (Sum a) where + stripSuffix a b = b a + +instance Integral a => LeftCancellativeMonoid (Sum a) + +instance Integral a => RightCancellativeMonoid (Sum a) + +instance (Integral a, Ord a) => LeftGCDMonoid (Sum a) where + commonPrefix a b = gcd a b + +instance (Integral a, Ord a) => RightGCDMonoid (Sum a) where + commonSuffix a b = gcd a b + +-- Product instances + +instance Integral a => ReductiveMonoid (Product a) where + Product 0 Product 0 = Just (Product 0) + Product a Product 0 = Nothing + Product a Product b = if remainder == 0 then Just (Product quotient) else Nothing + where (quotient, remainder) = quotRem a b + +instance Integral a => GCDMonoid (Product a) where + gcd (Product a) (Product b) = Product (Prelude.gcd a b) + +instance Integral a => LeftReductiveMonoid (Product a) where + stripPrefix a b = b a + +instance Integral a => RightReductiveMonoid (Product a) where + stripSuffix a b = b a + +instance Integral a => LeftGCDMonoid (Product a) where + commonPrefix a b = gcd a b + +instance Integral a => RightGCDMonoid (Product a) where + commonSuffix a b = gcd a b + +-- Pair instances + +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') + _ -> Nothing + +instance (CancellativeMonoid a, CancellativeMonoid b) => CancellativeMonoid (a, b) + +instance (GCDMonoid a, GCDMonoid b) => GCDMonoid (a, b) where + gcd (a, b) (c, d) = (gcd a c, gcd b d) + +instance (LeftReductiveMonoid a, LeftReductiveMonoid b) => LeftReductiveMonoid (a, b) where + stripPrefix (a, b) (c, d) = case (stripPrefix a c, stripPrefix b d) + of (Just a', Just b') -> Just (a', b') + _ -> Nothing + isPrefixOf (a, b) (c, d) = isPrefixOf a c && isPrefixOf b d + +instance (RightReductiveMonoid a, RightReductiveMonoid b) => RightReductiveMonoid (a, b) where + stripSuffix (a, b) (c, d) = case (stripSuffix a c, stripSuffix b d) + of (Just a', Just b') -> Just (a', b') + _ -> Nothing + isSuffixOf (a, b) (c, d) = isSuffixOf a c && isSuffixOf b d + +instance (LeftCancellativeMonoid a, LeftCancellativeMonoid b) => LeftCancellativeMonoid (a, b) + +instance (RightCancellativeMonoid a, RightCancellativeMonoid b) => RightCancellativeMonoid (a, b) + +instance (LeftGCDMonoid a, LeftGCDMonoid b) => LeftGCDMonoid (a, b) where + commonPrefix (a, b) (c, d) = (commonPrefix a c, commonPrefix b d) + +instance (RightGCDMonoid a, RightGCDMonoid b) => RightGCDMonoid (a, b) where + commonSuffix (a, b) (c, d) = (commonSuffix a c, commonSuffix b d) + +-- Set instances + +instance Ord a => LeftReductiveMonoid (Set.Set a) where + isPrefixOf = Set.isSubsetOf + stripPrefix a b = b a + +instance Ord a => RightReductiveMonoid (Set.Set a) where + isSuffixOf = Set.isSubsetOf + stripSuffix a b = b a + +instance Ord a => ReductiveMonoid (Set.Set a) where + a b | Set.isSubsetOf b a = Just (a Set.\\ b) + | otherwise = Nothing + +instance Ord a => LeftGCDMonoid (Set.Set a) where + commonPrefix = Set.intersection + +instance Ord a => RightGCDMonoid (Set.Set a) where + commonSuffix = Set.intersection + +instance Ord a => GCDMonoid (Set.Set a) where + gcd = Set.intersection + +-- IntSet instances + +instance LeftReductiveMonoid IntSet.IntSet where + isPrefixOf = IntSet.isSubsetOf + stripPrefix a b = b a + +instance RightReductiveMonoid IntSet.IntSet where + isSuffixOf = IntSet.isSubsetOf + stripSuffix a b = b a + +instance ReductiveMonoid IntSet.IntSet where + a b | IntSet.isSubsetOf b a = Just (a IntSet.\\ b) + | otherwise = Nothing + +instance LeftGCDMonoid IntSet.IntSet where + commonPrefix = IntSet.intersection + +instance RightGCDMonoid IntSet.IntSet where + commonSuffix = IntSet.intersection + +instance GCDMonoid IntSet.IntSet where + gcd = IntSet.intersection + +-- Map instances + +instance Ord k => LeftReductiveMonoid (Map.Map k a) where + isPrefixOf = Map.isSubmapOfBy (\_ _-> True) + stripPrefix a b | Map.isSubmapOfBy (\_ _-> True) a b = Just (b Map.\\ a) + | otherwise = Nothing + +instance (Ord k, Eq a) => LeftGCDMonoid (Map.Map k a) where + commonPrefix = Map.mergeWithKey (\k a b -> if a == b then Just a else Nothing) (const Map.empty) (const Map.empty) + +-- IntMap instances + +instance LeftReductiveMonoid (IntMap.IntMap a) where + isPrefixOf = IntMap.isSubmapOfBy (\_ _-> True) + stripPrefix a b | IntMap.isSubmapOfBy (\_ _-> True) a b = Just (b IntMap.\\ a) + | otherwise = Nothing + +instance Eq a => LeftGCDMonoid (IntMap.IntMap a) where + commonPrefix = IntMap.mergeWithKey (\k a b -> if a == b then Just a else Nothing) + (const IntMap.empty) (const IntMap.empty) + +-- List instances + +instance Eq x => LeftReductiveMonoid [x] where + stripPrefix = List.stripPrefix + isPrefixOf = List.isPrefixOf + +instance Eq x => LeftCancellativeMonoid [x] + +instance Eq x => LeftGCDMonoid [x] where + commonPrefix (x:xs) (y:ys) | x == y = x : commonPrefix xs ys + commonPrefix _ _ = [] + + stripCommonPrefix x y = strip' id x y + where strip' f (x:xs) (y:ys) | x == y = strip' (f . (x :)) xs ys + strip' f x y = (f [], x, y) + +-- Seq instances + +instance Eq a => LeftReductiveMonoid (Sequence.Seq a) where + stripPrefix p s | p == s1 = Just s2 + | otherwise = Nothing + where (s1, s2) = Sequence.splitAt (Sequence.length p) s + +instance Eq a => RightReductiveMonoid (Sequence.Seq a) where + stripSuffix p s | p == s2 = Just s1 + | otherwise = Nothing + where (s1, s2) = Sequence.splitAt (Sequence.length s - Sequence.length p) s + +instance Eq a => LeftCancellativeMonoid (Sequence.Seq a) + +instance Eq a => RightCancellativeMonoid (Sequence.Seq a) + +instance Eq a => LeftGCDMonoid (Sequence.Seq a) where + stripCommonPrefix = findCommonPrefix Sequence.empty + where findCommonPrefix prefix a b = case (Sequence.viewl a, Sequence.viewl b) + of (a1: findCommonPrefix (prefix |> a1) a' b' + _ -> (prefix, a, b) + +instance Eq a => RightGCDMonoid (Sequence.Seq a) where + stripCommonSuffix = findCommonSuffix Sequence.empty + where findCommonSuffix suffix a b = case (Sequence.viewr a, Sequence.viewr b) + of (a':>a1, b':>b1) | a1 == b1 -> findCommonSuffix (a1 <| suffix) a' b' + _ -> (a, b, suffix) + +-- Vector instances + +instance Eq a => LeftReductiveMonoid (Vector.Vector a) where + stripPrefix p l | prefixLength > Vector.length l = Nothing + | otherwise = strip 0 + where strip i | i == prefixLength = Just (Vector.drop prefixLength l) + | l Vector.! i == p Vector.! i = strip (succ i) + | otherwise = Nothing + prefixLength = Vector.length p + isPrefixOf p l | prefixLength > Vector.length l = False + | otherwise = test 0 + where test i | i == prefixLength = True + | l Vector.! i == p Vector.! i = test (succ i) + | otherwise = False + prefixLength = Vector.length p + +instance Eq a => RightReductiveMonoid (Vector.Vector a) where + stripSuffix s l | suffixLength > Vector.length l = Nothing + | otherwise = strip (pred suffixLength) + where strip i | i == -1 = Just (Vector.take lengthDifference l) + | l Vector.! (lengthDifference + i) == s Vector.! i = strip (pred i) + | otherwise = Nothing + suffixLength = Vector.length s + lengthDifference = Vector.length l - suffixLength + isSuffixOf s l | suffixLength > Vector.length l = False + | otherwise = test (pred suffixLength) + where test i | i == -1 = True + | l Vector.! (lengthDifference + i) == s Vector.! i = test (pred i) + | otherwise = False + suffixLength = Vector.length s + lengthDifference = Vector.length l - suffixLength + +instance Eq a => LeftCancellativeMonoid (Vector.Vector a) + +instance Eq a => RightCancellativeMonoid (Vector.Vector a) + +instance Eq a => LeftGCDMonoid (Vector.Vector a) where + stripCommonPrefix x y = (xp, xs, Vector.drop maxPrefixLength y) + where maxPrefixLength = prefixLength 0 (Vector.length x `min` Vector.length y) + prefixLength n len | n < len && x Vector.! n == y Vector.! n = prefixLength (succ n) len + prefixLength n _ = n + (xp, xs) = Vector.splitAt maxPrefixLength x + +instance Eq a => RightGCDMonoid (Vector.Vector a) where + stripCommonSuffix x y = findSuffix (Vector.length x - 1) (Vector.length y - 1) + where findSuffix m n | m >= 0 && n >= 0 && x Vector.! m == y Vector.! n = + findSuffix (pred m) (pred n) + findSuffix m n = (Vector.take (succ m) x, yp, ys) + where (yp, ys) = Vector.splitAt (succ n) y + +-- ByteString instances + +instance LeftReductiveMonoid ByteString.ByteString where + stripPrefix p l = if ByteString.isPrefixOf p l + then Just (ByteString.drop (ByteString.length p) l) + else Nothing + isPrefixOf = ByteString.isPrefixOf + +instance RightReductiveMonoid ByteString.ByteString where + stripSuffix s l = if ByteString.isSuffixOf s l + then Just (ByteString.take (ByteString.length l - ByteString.length s) l) + else Nothing + isSuffixOf = ByteString.isSuffixOf + +instance LeftCancellativeMonoid ByteString.ByteString + +instance RightCancellativeMonoid ByteString.ByteString + +instance LeftGCDMonoid ByteString.ByteString where + stripCommonPrefix x y = (xp, xs, ByteString.drop maxPrefixLength y) + where maxPrefixLength = prefixLength 0 (ByteString.length x `min` ByteString.length y) + prefixLength n len | n < len && ByteString.index x n == ByteString.index y n = prefixLength (succ n) len + prefixLength n _ = n + (xp, xs) = ByteString.splitAt maxPrefixLength x + +instance RightGCDMonoid ByteString.ByteString where + stripCommonSuffix x y = findSuffix (ByteString.length x - 1) (ByteString.length y - 1) + where findSuffix m n | m >= 0 && n >= 0 && ByteString.index x m == ByteString.index y n = + findSuffix (pred m) (pred n) + findSuffix m n = (ByteString.take (succ m) x, yp, ys) + where (yp, ys) = ByteString.splitAt (succ n) y + +-- Lazy ByteString instances + +instance LeftReductiveMonoid LazyByteString.ByteString where + stripPrefix p l = if LazyByteString.isPrefixOf p l + then Just (LazyByteString.drop (LazyByteString.length p) l) + else Nothing + isPrefixOf = LazyByteString.isPrefixOf + +instance RightReductiveMonoid LazyByteString.ByteString where + stripSuffix s l = if LazyByteString.isSuffixOf s l + then Just (LazyByteString.take (LazyByteString.length l - LazyByteString.length s) l) + else Nothing + isSuffixOf = LazyByteString.isSuffixOf + +instance LeftCancellativeMonoid LazyByteString.ByteString + +instance RightCancellativeMonoid LazyByteString.ByteString + +instance LeftGCDMonoid LazyByteString.ByteString where + stripCommonPrefix x y = (xp, xs, LazyByteString.drop maxPrefixLength y) + where maxPrefixLength = prefixLength 0 (LazyByteString.length x `min` LazyByteString.length y) + prefixLength n len | n < len && LazyByteString.index x n == LazyByteString.index y n = + prefixLength (succ n) len + prefixLength n _ = n + (xp, xs) = LazyByteString.splitAt maxPrefixLength x + +instance RightGCDMonoid LazyByteString.ByteString where + stripCommonSuffix x y = findSuffix (LazyByteString.length x - 1) (LazyByteString.length y - 1) + where findSuffix m n | m >= 0 && n >= 0 && LazyByteString.index x m == LazyByteString.index y n = + findSuffix (pred m) (pred n) + findSuffix m n = (LazyByteString.take (succ m) x, yp, ys) + where (yp, ys) = LazyByteString.splitAt (succ n) y + +-- Text instances + +instance LeftReductiveMonoid Text.Text where + stripPrefix = Text.stripPrefix + isPrefixOf = Text.isPrefixOf + +instance RightReductiveMonoid Text.Text where + stripSuffix = Text.stripSuffix + isSuffixOf = Text.isSuffixOf + +instance LeftCancellativeMonoid Text.Text + +instance RightCancellativeMonoid Text.Text + +instance LeftGCDMonoid Text.Text where + stripCommonPrefix x y = maybe (Text.empty, x, y) id (Text.commonPrefixes x y) + +-- Lazy Text instances + +instance LeftReductiveMonoid LazyText.Text where + stripPrefix = LazyText.stripPrefix + isPrefixOf = LazyText.isPrefixOf + +instance RightReductiveMonoid LazyText.Text where + stripSuffix = LazyText.stripSuffix + isSuffixOf = LazyText.isSuffixOf + +instance LeftCancellativeMonoid LazyText.Text + +instance RightCancellativeMonoid LazyText.Text + +instance LeftGCDMonoid LazyText.Text where + stripCommonPrefix x y = maybe (LazyText.empty, x, y) id (LazyText.commonPrefixes x y) diff --git a/Data/Monoid/Factorial.hs b/Data/Monoid/Factorial.hs new file mode 100644 --- /dev/null +++ b/Data/Monoid/Factorial.hs @@ -0,0 +1,455 @@ +{- + Copyright 2011-2013 Mario Blazevic + + License: BSD3 (see BSD3-LICENSE.txt file) +-} + +-- | This module defines the 'FactorialMonoid' class and some of its instances. +-- + +{-# LANGUAGE Haskell2010 #-} + +module Data.Monoid.Factorial ( + -- * Class + FactorialMonoid(..), + -- * Monad function equivalents + mapM, mapM_ + ) +where + +import Prelude hiding (break, drop, dropWhile, foldl, foldr, length, map, mapM, mapM_, null, + reverse, span, splitAt, take, takeWhile) + +import qualified Control.Monad as Monad +import Data.Monoid (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) +import qualified Data.Foldable as Foldable +import qualified Data.List as List +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Sequence as Sequence +import qualified Data.Set as Set +import qualified Data.Vector as Vector +import Data.Numbers.Primes (primeFactors) + +import Data.Monoid.Null (MonoidNull(null)) + +-- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of +-- a 'Product' are literally its prime factors: +-- +-- prop> factors (Product 12) == [Product 2, Product 2, Product 3] +-- +-- 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: +-- +-- > mconcat . factors == id +-- > null == List.null . factors +-- > List.all (\prime-> factors prime == [prime]) . factors +-- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix) +-- > reverse == mconcat . List.reverse . factors +-- > primePrefix == maybe mempty fst . splitPrimePrefix +-- > primeSuffix == maybe mempty snd . splitPrimeSuffix +-- > foldl f a == List.foldl f a . factors +-- > foldl' f a == List.foldl' f a . factors +-- > foldr f a == List.foldr f a . factors +-- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m) +-- > List.all (List.all (not . pred) . factors) . split pred +-- > mconcat . intersperse prime . split (== prime) == id +-- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m) +-- +-- It's worth noting that a class instance does /not/ need to satisfy this law: +-- +-- > factors (a <> b) == factors a <> factors b +-- +-- A minimal instance definition must implement 'factors' or 'splitPrimePrefix'. Other methods are provided and should +-- be implemented only for performance reasons. +class MonoidNull m => FactorialMonoid m where + -- | Returns a list of all prime factors; inverse of mconcat. + factors :: m -> [m] + -- | The prime prefix, 'mempty' if none. + primePrefix :: m -> m + -- | The prime suffix, 'mempty' if none. + primeSuffix :: m -> m + -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'. + splitPrimePrefix :: m -> Maybe (m, m) + -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'. + splitPrimeSuffix :: m -> Maybe (m, m) + -- | Like 'List.foldl' from "Data.List" on the list of 'primes'. + foldl :: (a -> m -> a) -> a -> m -> a + -- | Like 'List.foldl'' from "Data.List" on the list of 'primes'. + foldl' :: (a -> m -> a) -> a -> m -> a + -- | Like 'List.foldr' from "Data.List" on the list of 'primes'. + foldr :: (m -> a -> a) -> a -> m -> a + -- | The 'length' of the list of 'primes'. + length :: m -> Int + -- | Equivalent to 'List.map' from "Data.List", except the argument function works on prime factors rather than list + -- elements. + map :: (FactorialMonoid m, Monoid n) => (m -> n) -> m -> n + -- | Like 'List.span' from "Data.List" on the list of 'primes'. + span :: (m -> Bool) -> m -> (m, m) + -- | Equivalent to 'List.break' from "Data.List". + break :: FactorialMonoid m => (m -> Bool) -> m -> (m, m) + -- | Splits the monoid into components delimited by prime separators satisfying the given predicate. The primes + -- satisfying the predicate are not a part of the result. + split :: (m -> Bool) -> m -> [m] + -- | Equivalent to 'List.takeWhile' from "Data.List". + takeWhile :: FactorialMonoid m => (m -> Bool) -> m -> m + -- | Equivalent to 'List.dropWhile' from "Data.List". + dropWhile :: FactorialMonoid m => (m -> Bool) -> m -> m + -- | Like 'List.splitAt' from "Data.List" on the list of 'primes'. + splitAt :: Int -> m -> (m, m) + -- | Equivalent to 'List.drop' from "Data.List". + drop :: FactorialMonoid m => Int -> m -> m + -- | Equivalent to 'List.take' from "Data.List". + take :: FactorialMonoid m => Int -> m -> m + -- | Equivalent to 'List.reverse' from "Data.List". + reverse :: FactorialMonoid m => m -> m + + factors = List.unfoldr splitPrimePrefix + primePrefix = maybe mempty fst . splitPrimePrefix + primeSuffix = maybe mempty snd . splitPrimeSuffix + splitPrimePrefix x = case factors x + of [] -> Nothing + prefix : rest -> Just (prefix, mconcat rest) + splitPrimeSuffix x = case factors x + of [] -> Nothing + fs -> Just (mconcat (List.init fs), List.last fs) + foldl f f0 = List.foldl f f0 . factors + foldl' f f0 = List.foldl' f f0 . factors + foldr f f0 = List.foldr f f0 . factors + length = List.length . factors + map f = foldr (mappend . f) mempty + span p = foldr f (mempty, mempty) + where f s (prefix, suffix) = if p s + then (mappend s prefix, suffix) + else (mempty, mappend s (mappend prefix suffix)) + break = span . (not .) + split p m = foldr f [mempty] m + where f prime s@(x:xs) | p prime = mempty : s + | otherwise = mappend prime x : xs + takeWhile p = fst . span p + dropWhile p = snd . span p + splitAt n m | n <= 0 = (mempty, m) + | otherwise = split n id m + where split 0 f m = (f mempty, m) + split n f m = case splitPrimePrefix m + of Nothing -> (f mempty, m) + Just (prime, rest) -> split (pred n) (f . mappend prime) rest + drop n p = snd (splitAt n p) + take n p = fst (splitAt n p) + reverse = mconcat . List.reverse . factors + +instance FactorialMonoid a => FactorialMonoid (Dual a) where + factors (Dual a) = fmap Dual (reverse $ factors a) + length (Dual a) = length a + primePrefix (Dual a) = Dual (primeSuffix a) + primeSuffix (Dual a) = Dual (primePrefix a) + splitPrimePrefix (Dual a) = case splitPrimeSuffix a + of Nothing -> Nothing + Just (p, s) -> Just (Dual s, Dual p) + splitPrimeSuffix (Dual a) = case splitPrimePrefix a + of Nothing -> Nothing + Just (p, s) -> Just (Dual s, Dual p) + reverse (Dual a) = Dual (reverse a) + +instance (Integral a, Eq a) => FactorialMonoid (Sum a) where + primePrefix (Sum a) = Sum (signum a ) + primeSuffix = primePrefix + splitPrimePrefix (Sum 0) = Nothing + splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a)) + splitPrimeSuffix (Sum 0) = Nothing + splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a)) + length (Sum a) = abs (fromIntegral a) + reverse = id + +instance Integral a => FactorialMonoid (Product a) where + factors (Product a) = List.map Product (primeFactors a) + reverse = id + +instance FactorialMonoid a => FactorialMonoid (Maybe a) where + factors Nothing = [] + factors (Just a) | null a = [Just a] + | otherwise = List.map Just (factors a) + length Nothing = 0 + length (Just a) | null a = 1 + | otherwise = length a + reverse = fmap reverse + +instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where + factors (a, b) = List.map (\a-> (a, mempty)) (factors a) ++ List.map ((,) mempty) (factors b) + length (a, b) = length a + length b + reverse (a, b) = (reverse a, reverse b) + +instance FactorialMonoid [x] where + factors xs = List.map (:[]) xs + primePrefix [] = [] + primePrefix (x:xs) = [x] + primeSuffix [] = [] + primeSuffix xs = [List.last xs] + splitPrimePrefix [] = Nothing + splitPrimePrefix (x:xs) = Just ([x], xs) + splitPrimeSuffix [] = Nothing + splitPrimeSuffix xs = Just (split id xs) + where split f last@[x] = (f [], last) + split f (x:xs) = split (f . (x:)) xs + foldl _ a [] = a + foldl f a (x:xs) = foldl f (f a [x]) xs + foldl' _ a [] = a + foldl' f a (x:xs) = let a' = f a [x] in a' `seq` foldl' f a' xs + foldr _ f0 [] = f0 + foldr f f0 (x:xs) = f [x] (foldr f f0 xs) + length = List.length + map f = mconcat . List.map (f . (:[])) + break f = List.break (f . (:[])) + span f = List.span (f . (:[])) + dropWhile f = List.dropWhile (f . (:[])) + takeWhile f = List.takeWhile (f . (:[])) + splitAt = List.splitAt + drop = List.drop + take = List.take + reverse = List.reverse + +instance FactorialMonoid ByteString.ByteString where + factors x = factorize (ByteString.length x) x + where factorize 0 xs = [] + factorize n xs = x : factorize (pred n) xs' + where (x, xs') = ByteString.splitAt 1 xs + primePrefix = ByteString.take 1 + primeSuffix x = ByteString.drop (ByteString.length x - 1) x + splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x) + splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x) + foldl f = ByteString.foldl f' + where f' a byte = f a (ByteString.singleton byte) + foldl' f = ByteString.foldl' f' + where f' a byte = f a (ByteString.singleton byte) + foldr f = ByteString.foldr (f . ByteString.singleton) + break f = ByteString.break (f . ByteString.singleton) + span f = ByteString.span (f . ByteString.singleton) + dropWhile f = ByteString.dropWhile (f . ByteString.singleton) + takeWhile f = ByteString.takeWhile (f . ByteString.singleton) + length = ByteString.length + split f = ByteString.splitWith f' + where f' = f . ByteString.singleton + splitAt = ByteString.splitAt + drop = ByteString.drop + take = ByteString.take + reverse = ByteString.reverse + +instance FactorialMonoid LazyByteString.ByteString where + factors x = factorize (LazyByteString.length x) x + where factorize 0 xs = [] + factorize n xs = x : factorize (pred n) xs' + where (x, xs') = LazyByteString.splitAt 1 xs + primePrefix = LazyByteString.take 1 + primeSuffix x = LazyByteString.drop (LazyByteString.length x - 1) x + splitPrimePrefix x = if LazyByteString.null x then Nothing + else Just (LazyByteString.splitAt 1 x) + splitPrimeSuffix x = if LazyByteString.null x then Nothing + else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x) + foldl f = LazyByteString.foldl f' + where f' a byte = f a (LazyByteString.singleton byte) + foldl' f = LazyByteString.foldl' f' + where f' a byte = f a (LazyByteString.singleton byte) + foldr f = LazyByteString.foldr f' + where f' byte a = f (LazyByteString.singleton byte) a + length = fromIntegral . LazyByteString.length + break f = LazyByteString.break (f . LazyByteString.singleton) + span f = LazyByteString.span (f . LazyByteString.singleton) + dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton) + takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton) + split f = LazyByteString.splitWith f' + where f' = f . LazyByteString.singleton + splitAt = LazyByteString.splitAt . fromIntegral + drop n = LazyByteString.drop (fromIntegral n) + take n = LazyByteString.take (fromIntegral n) + reverse = LazyByteString.reverse + +instance FactorialMonoid Text.Text where + factors = Text.chunksOf 1 + primePrefix = Text.take 1 + primeSuffix x = if Text.null x then Text.empty else Text.singleton (Text.last x) + splitPrimePrefix = fmap (\(c, t)-> (Text.singleton c, t)) . Text.uncons + splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.splitAt (Text.length x - 1) x) + foldl f = Text.foldl f' + where f' a char = f a (Text.singleton char) + foldl' f = Text.foldl' f' + where f' a char = f a (Text.singleton char) + foldr f = Text.foldr f' + where f' char a = f (Text.singleton char) a + length = Text.length + span f = Text.span (f . Text.singleton) + break f = Text.break (f . Text.singleton) + dropWhile f = Text.dropWhile (f . Text.singleton) + takeWhile f = Text.takeWhile (f . Text.singleton) + split f = Text.split f' + where f' = f . Text.singleton + splitAt = Text.splitAt + drop = Text.drop + take = Text.take + reverse = Text.reverse + +instance FactorialMonoid LazyText.Text where + factors = LazyText.chunksOf 1 + primePrefix = LazyText.take 1 + primeSuffix x = if LazyText.null x then LazyText.empty else LazyText.singleton (LazyText.last x) + splitPrimePrefix = fmap (\(c, t)-> (LazyText.singleton c, t)) . LazyText.uncons + splitPrimeSuffix x = if LazyText.null x then Nothing else Just (LazyText.splitAt (LazyText.length x - 1) x) + foldl f = LazyText.foldl f' + where f' a char = f a (LazyText.singleton char) + foldl' f = LazyText.foldl' f' + where f' a char = f a (LazyText.singleton char) + foldr f = LazyText.foldr f' + where f' char a = f (LazyText.singleton char) a + length = fromIntegral . LazyText.length + span f = LazyText.span (f . LazyText.singleton) + break f = LazyText.break (f . LazyText.singleton) + dropWhile f = LazyText.dropWhile (f . LazyText.singleton) + takeWhile f = LazyText.takeWhile (f . LazyText.singleton) + split f = LazyText.split f' + where f' = f . LazyText.singleton + splitAt = LazyText.splitAt . fromIntegral + drop n = LazyText.drop (fromIntegral n) + take n = LazyText.take (fromIntegral n) + reverse = LazyText.reverse + +instance Ord k => FactorialMonoid (Map.Map k v) where + factors = List.map (uncurry Map.singleton) . Map.toAscList + primePrefix map | Map.null map = map + | otherwise = uncurry Map.singleton $ Map.findMin map + primeSuffix map | Map.null map = map + | otherwise = uncurry Map.singleton $ Map.findMax map + splitPrimePrefix = fmap singularize . Map.minViewWithKey + where singularize ((k, v), rest) = (Map.singleton k v, rest) + splitPrimeSuffix = fmap singularize . Map.maxViewWithKey + where singularize ((k, v), rest) = (rest, Map.singleton k v) + foldl f = Map.foldlWithKey f' + where f' a k v = f a (Map.singleton k v) + foldl' f = Map.foldlWithKey' f' + where f' a k v = f a (Map.singleton k v) + foldr f = Map.foldrWithKey f' + where f' k v a = f (Map.singleton k v) a + length = Map.size + reverse = id + +instance FactorialMonoid (IntMap.IntMap a) where + factors = List.map (uncurry IntMap.singleton) . IntMap.toAscList + primePrefix map | IntMap.null map = map + | otherwise = uncurry IntMap.singleton $ IntMap.findMin map + primeSuffix map | IntMap.null map = map + | otherwise = uncurry IntMap.singleton $ IntMap.findMax map + splitPrimePrefix = fmap singularize . IntMap.minViewWithKey + where singularize ((k, v), rest) = (IntMap.singleton k v, rest) + splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey + where singularize ((k, v), rest) = (rest, IntMap.singleton k v) + foldl f = IntMap.foldlWithKey f' + where f' a k v = f a (IntMap.singleton k v) + foldl' f = IntMap.foldlWithKey' f' + where f' a k v = f a (IntMap.singleton k v) + foldr f = IntMap.foldrWithKey f' + where f' k v a = f (IntMap.singleton k v) a + length = IntMap.size + reverse = id + +instance FactorialMonoid IntSet.IntSet where + factors = List.map IntSet.singleton . IntSet.toAscList + primePrefix set | IntSet.null set = set + | otherwise = IntSet.singleton $ IntSet.findMin set + primeSuffix set | IntSet.null set = set + | otherwise = IntSet.singleton $ IntSet.findMax set + splitPrimePrefix = fmap singularize . IntSet.minView + where singularize (min, rest) = (IntSet.singleton min, rest) + splitPrimeSuffix = fmap singularize . IntSet.maxView + where singularize (max, rest) = (rest, IntSet.singleton max) + foldl f = IntSet.foldl f' + where f' a b = f a (IntSet.singleton b) + foldl' f = IntSet.foldl' f' + where f' a b = f a (IntSet.singleton b) + foldr f = IntSet.foldr f' + where f' a b = f (IntSet.singleton a) b + length = IntSet.size + reverse = id + +instance FactorialMonoid (Sequence.Seq a) where + factors = List.map Sequence.singleton . Foldable.toList + primePrefix = Sequence.take 1 + primeSuffix seq = Sequence.drop (Sequence.length seq - 1) seq + splitPrimePrefix seq = case Sequence.viewl seq + of Sequence.EmptyL -> Nothing + first Sequence.:< rest -> Just (Sequence.singleton first, rest) + splitPrimeSuffix seq = case Sequence.viewr seq + of Sequence.EmptyR -> Nothing + rest Sequence.:> last -> Just (rest, Sequence.singleton last) + foldl f = Foldable.foldl f' + where f' a b = f a (Sequence.singleton b) + foldl' f = Foldable.foldl' f' + where f' a b = f a (Sequence.singleton b) + foldr f = Foldable.foldr f' + where f' a b = f (Sequence.singleton a) b + span f = Sequence.spanl (f . Sequence.singleton) + break f = Sequence.breakl (f . Sequence.singleton) + dropWhile f = Sequence.dropWhileL (f . Sequence.singleton) + takeWhile f = Sequence.takeWhileL (f . Sequence.singleton) + splitAt = Sequence.splitAt + drop = Sequence.drop + take = Sequence.take + length = Sequence.length + reverse = Sequence.reverse + +instance Ord a => FactorialMonoid (Set.Set a) where + factors = List.map Set.singleton . Set.toAscList + primePrefix set | Set.null set = set + | otherwise = Set.singleton $ Set.findMin set + primeSuffix set | Set.null set = set + | otherwise = Set.singleton $ Set.findMax set + splitPrimePrefix = fmap singularize . Set.minView + where singularize (min, rest) = (Set.singleton min, rest) + splitPrimeSuffix = fmap singularize . Set.maxView + where singularize (max, rest) = (rest, Set.singleton max) + foldl f = Foldable.foldl f' + where f' a b = f a (Set.singleton b) + foldl' f = Foldable.foldl' f' + where f' a b = f a (Set.singleton b) + foldr f = Foldable.foldr f' + where f' a b = f (Set.singleton a) b + length = Set.size + reverse = id + +instance FactorialMonoid (Vector.Vector a) where + factors x = factorize (Vector.length x) x + where factorize 0 xs = [] + factorize n xs = x : factorize (pred n) xs' + where (x, xs') = Vector.splitAt 1 xs + primePrefix = Vector.take 1 + primeSuffix x = Vector.drop (Vector.length x - 1) x + splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x) + splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x) + foldl f = Vector.foldl f' + where f' a byte = f a (Vector.singleton byte) + foldl' f = Vector.foldl' f' + where f' a byte = f a (Vector.singleton byte) + foldr f = Vector.foldr f' + where f' byte a = f (Vector.singleton byte) a + break f = Vector.break (f . Vector.singleton) + span f = Vector.span (f . Vector.singleton) + dropWhile f = Vector.dropWhile (f . Vector.singleton) + takeWhile f = Vector.takeWhile (f . Vector.singleton) + splitAt = Vector.splitAt + drop = Vector.drop + take = Vector.take + length = Vector.length + reverse = Vector.reverse + +-- | A 'Monad.mapM' equivalent. +mapM :: (FactorialMonoid a, Monoid b, Monad m) => (a -> m b) -> a -> m b +mapM f = ($ return mempty) . appEndo . map (Endo . Monad.liftM2 mappend . f) + +-- | A 'Monad.mapM_' equivalent. +mapM_ :: (FactorialMonoid a, Monad m) => (a -> m b) -> a -> m () +mapM_ f = foldr ((>>) . f) (return ()) diff --git a/Data/Monoid/Instances/ByteString/UTF8.hs b/Data/Monoid/Instances/ByteString/UTF8.hs new file mode 100644 --- /dev/null +++ b/Data/Monoid/Instances/ByteString/UTF8.hs @@ -0,0 +1,54 @@ +{- + Copyright 2013 Mario Blazevic + + License: BSD3 (see BSD3-LICENSE.txt file) +-} + +-- | This module defines the 'ByteStringUTF8' newtype wrapper around 'ByteString', together with its 'TextualMonoid' +-- instance. +-- + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Monoid.Instances.ByteString.UTF8 ( + ByteStringUTF8(..) + ) +where + +import Prelude hiding (foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1, map, concatMap, break, span) + +import Data.String (IsString(fromString)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.UTF8 as UTF8 + +import Data.Monoid (Monoid) +import Data.Monoid.Cancellative (LeftReductiveMonoid, LeftCancellativeMonoid, LeftGCDMonoid) +import Data.Monoid.Null (MonoidNull) +import Data.Monoid.Factorial (FactorialMonoid(..)) +import Data.Monoid.Textual (TextualMonoid(..)) + +newtype ByteStringUTF8 = ByteStringUTF8 ByteString deriving (Eq, Show, Monoid, MonoidNull, + LeftReductiveMonoid, LeftCancellativeMonoid, LeftGCDMonoid) + +instance IsString ByteStringUTF8 where + fromString = ByteStringUTF8 . UTF8.fromString + +instance FactorialMonoid ByteStringUTF8 where + splitPrimePrefix (ByteStringUTF8 bs) = + do (_, n) <- UTF8.decode bs + let (bytes, rest) = ByteString.splitAt n bs + return (ByteStringUTF8 bytes, ByteStringUTF8 rest) + splitAt n (ByteStringUTF8 bs) = wrapPair (UTF8.splitAt n bs) + take n (ByteStringUTF8 bs) = ByteStringUTF8 (UTF8.take n bs) + drop n (ByteStringUTF8 bs) = ByteStringUTF8 (UTF8.drop n bs) + length (ByteStringUTF8 bs) = UTF8.length bs + +instance TextualMonoid ByteStringUTF8 where + splitCharacterPrefix (ByteStringUTF8 bs) = do (c, rest) <- UTF8.uncons bs + if c == UTF8.replacement_char + then Nothing + else return (c, ByteStringUTF8 rest) + + +wrapPair (bs1, bs2) = (ByteStringUTF8 bs1, ByteStringUTF8 bs2) diff --git a/Data/Monoid/Null.hs b/Data/Monoid/Null.hs new file mode 100644 --- /dev/null +++ b/Data/Monoid/Null.hs @@ -0,0 +1,106 @@ +{- + Copyright 2011-2013 Mario Blazevic + + License: BSD3 (see BSD3-LICENSE.txt file) +-} + +-- | This module defines the MonoidNull class and some of its instances. +-- + +{-# LANGUAGE Haskell2010 #-} + +module Data.Monoid.Null ( + MonoidNull(..) + ) +where + +import Prelude hiding (null) + +import Data.Monoid (Monoid(mempty), First(..), Last(..), Dual(..), Sum(..), Product(..), All(getAll), Any(getAny)) +import qualified Data.List as List +import Data.Ord (Ordering(EQ)) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Sequence as Sequence +import qualified Data.Set as Set +import qualified Data.Vector as Vector + +-- | Extension of 'Monoid' that allows testing a value for equality with 'mempty'. The following law must hold: +-- +-- prop> null x == (x == mempty) +class Monoid m => MonoidNull m where + null :: m -> Bool + +instance MonoidNull () where + null () = True + +instance MonoidNull Ordering where + null = (== EQ) + +instance MonoidNull All where + null = getAll + +instance MonoidNull Any where + null = not . getAny + +instance MonoidNull (First a) where + null (First Nothing) = True + null _ = False + +instance MonoidNull (Last a) where + null (Last Nothing) = True + null _ = False + +instance MonoidNull a => MonoidNull (Dual a) where + null (Dual a) = null a + +instance (Num a, Eq a) => MonoidNull (Sum a) where + null (Sum a) = a == 0 + +instance (Num a, Eq a) => MonoidNull (Product a) where + null (Product a) = a == 1 + +instance Monoid a => MonoidNull (Maybe a) where + null Nothing = True + null _ = False + +instance (MonoidNull a, MonoidNull b) => MonoidNull (a, b) where + null (a, b) = null a && null b + +instance MonoidNull [x] where + null = List.null + +instance MonoidNull ByteString.ByteString where + null = ByteString.null + +instance MonoidNull LazyByteString.ByteString where + null = LazyByteString.null + +instance MonoidNull Text.Text where + null = Text.null + +instance MonoidNull LazyText.Text where + null = LazyText.null + +instance Ord k => MonoidNull (Map.Map k v) where + null = Map.null + +instance MonoidNull (IntMap.IntMap v) where + null = IntMap.null + +instance MonoidNull IntSet.IntSet where + null = IntSet.null + +instance MonoidNull (Sequence.Seq a) where + null = Sequence.null + +instance Ord a => MonoidNull (Set.Set a) where + null = Set.null + +instance MonoidNull (Vector.Vector a) where + null = Vector.null diff --git a/Data/Monoid/Textual.hs b/Data/Monoid/Textual.hs new file mode 100644 --- /dev/null +++ b/Data/Monoid/Textual.hs @@ -0,0 +1,281 @@ +{- + Copyright 2013 Mario Blazevic + + License: BSD3 (see BSD3-LICENSE.txt file) +-} + +-- | This module defines the 'TextualMonoid' class and its most important instances for 'String' and 'Text'. +-- + +{-# LANGUAGE FlexibleInstances #-} + +module Data.Monoid.Textual ( + TextualMonoid(..) + ) +where + +import Prelude hiding (foldl, foldl1, foldr, foldr1, scanl, scanr, scanl1, scanr1, map, concatMap, break, span) + +import Data.Maybe (fromJust) +import Data.Either (rights) +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import Data.Text (Text) +import Data.Monoid (Monoid(mappend, mconcat, mempty)) +import Data.String (IsString(fromString)) + +import Data.Monoid.Null (MonoidNull (null)) +import Data.Monoid.Cancellative (LeftReductiveMonoid, LeftGCDMonoid) +import Data.Monoid.Factorial (FactorialMonoid) +import qualified Data.Monoid.Factorial as Factorial + +-- | The 'TextualMonoid' class is an extension of 'FactorialMonoid' specialized for monoids that can contain +-- characters. Its methods are generally equivalent to their namesake functions from "Data.List" and "Data.Text", and +-- they satisfy the following laws: +-- +-- > splitCharacterPrefix (singleton c <> t) == Just (c, t) +-- > splitCharacterPrefix . primePrefix == fmap (\(c, t)-> (c, mempty)) . splitCharacterPrefix +-- > +-- > map f . fromString == fromString . List.map f +-- > concatMap (fromString . f) . fromString == fromString . List.concatMap f +-- > +-- > foldl ft fc a . fromString == List.foldl fc a +-- > foldr ft fc a . fromString == List.foldr fc a +-- > foldl' ft fc a . fromString == List.foldl' fc a +-- > +-- > scanl f c . fromString == fromString . List.scanl f c +-- > scanr f c . fromString == fromString . List.scanr f c +-- > mapAccumL f a . fromString == fmap fromString . List.mapAccumL f a +-- > mapAccumL f a . fromString == fmap fromString . List.mapAccumL f a +-- > +-- > takeWhile pt pc . fromString == fromString . takeWhile pc +-- > dropWhile pt pc . fromString == fromString . dropWhile pc +-- > +-- > mconcat . intersperse (singleton c) . split (== c) == id +-- > find p . fromString == List.find p +-- +-- A 'TextualMonoid' may contain non-character data insterspersed between its characters. Every class method that +-- returns a modified 'TextualMonoid' instance generally preserves this non-character data. All of the following +-- expressions are identities: +-- +-- > map id +-- > concatMap singleton +-- > foldl (<>) (\a c-> a <> singleton c) mempty +-- > foldr (<>) ((<>) . singleton) mempty +-- > foldl' (<>) (\a c-> a <> singleton c) mempty +-- > scanl1 (const id) +-- > scanr1 const +-- > uncurry (mapAccumL (,)) +-- > uncurry (mapAccumR (,)) +-- > takeWhile (const True) (const True) +-- > dropWhile (const False) (const False) +-- +-- A minimal instance definition must implement 'splitCharacterPrefix'. + +class (IsString t, LeftReductiveMonoid t, LeftGCDMonoid t, FactorialMonoid t) => TextualMonoid t where + -- | Contructs a new data type instance Like 'fromString', but from a 'Text' input instead of 'String'. + -- + -- > fromText == fromString . Text.unpack + fromText :: Text -> t + -- | Creates a prime monoid containing a single character. + -- + -- > singleton c == fromString [c] + singleton :: Char -> t + -- | Specialized version of 'Factorial.splitPrimePrefix'. Every prime factor of a 'Textual' monoid must consist of a + -- single character or no character at all. + splitCharacterPrefix :: t -> Maybe (Char, t) + -- | Extracts a single character that prefixes the monoid, if the monoid begins with a character. Otherwise returns + -- 'Nothing'. + -- + -- > characterPrefix == fmap fst . splitCharacterPrefix + characterPrefix :: t -> Maybe Char + -- | Equivalent to 'List.map' from "Data.List" with a @Char -> Char@ function. Preserves all non-character data. + -- + -- > map f == concatMap (singleton . f) + map :: (Char -> Char) -> t -> t + -- | Equivalent to 'List.concatMap' from "Data.List" with a @Char -> String@ function. Preserves all non-character + -- data. + concatMap :: (Char -> t) -> t -> t + -- | Equivalent to 'List.any' from "Data.List". Ignores all non-character data. + any :: (Char -> Bool) -> t -> Bool + -- | Equivalent to 'List.all' from "Data.List". Ignores all non-character data. + all :: (Char -> Bool) -> t -> Bool + + -- | The first argument folds over the non-character prime factors, the second over characters. Otherwise equivalent + -- to 'List.foldl' from "Data.List". + foldl :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a + -- | Strict version of 'foldl'. + foldl' :: (a -> t -> a) -> (a -> Char -> a) -> a -> t -> a + -- | The first argument folds over the non-character prime factors, the second over characters. Otherwise equivalent + -- to 'List.foldr' from "Data.List". + foldr :: (t -> a -> a) -> (Char -> a -> a) -> a -> t -> a + + -- | Equivalent to 'List.scanl' from "Data.List" when applied to a 'String', but preserves all non-character data. + scanl :: (Char -> Char -> Char) -> Char -> t -> t + -- | Equivalent to 'List.scanl1' from "Data.List" when applied to a 'String', but preserves all non-character data. + -- + -- > scanl f c == scanl1 f . (singleton c <>) + scanl1 :: (Char -> Char -> Char) -> t -> t + -- | Equivalent to 'List.scanr' from "Data.List" when applied to a 'String', but preserves all non-character data. + scanr :: (Char -> Char -> Char) -> Char -> t -> t + -- | Equivalent to 'List.scanr1' from "Data.List" when applied to a 'String', but preserves all non-character data. + -- + -- > scanr f c == scanr1 f . (<> singleton c) + scanr1 :: (Char -> Char -> Char) -> t -> t + -- | Equivalent to 'List.mapAccumL' from "Data.List" when applied to a 'String', but preserves all non-character + -- data. + mapAccumL :: (a -> Char -> (a, Char)) -> a -> t -> (a, t) + -- | Equivalent to 'List.mapAccumR' from "Data.List" when applied to a 'String', but preserves all non-character + -- data. + mapAccumR :: (a -> Char -> (a, Char)) -> a -> t -> (a, t) + + -- | The first predicate tests the non-character data, the second one the characters. Otherwise equivalent to + -- 'List.takeWhile' from "Data.List" when applied to a 'String'. + takeWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t + -- | The first predicate tests the non-character data, the second one the characters. Otherwise equivalent to + -- 'List.dropWhile' from "Data.List" when applied to a 'String'. + dropWhile :: (t -> Bool) -> (Char -> Bool) -> t -> t + -- | 'break pt pc' is equivalent to |span (not . pt) (not . pc)|. + break :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t) + -- | 'span pt pc t' is equivalent to |(takeWhile pt pc t, dropWhile pt pc t)|. + span :: (t -> Bool) -> (Char -> Bool) -> t -> (t, t) + -- | Splits the monoid into components delimited by character separators satisfying the given predicate. The + -- characters satisfying the predicate are not a part of the result. + -- + -- > split p == Factorial.split (maybe False p . characterPrefix) + split :: (Char -> Bool) -> t -> [t] + -- | Like 'List.find' from "Data.List" when applied to a 'String'. Ignores non-character data. + find :: (Char -> Bool) -> t -> Maybe Char + + fromText = fromString . Text.unpack + singleton = fromString . (:[]) + + characterPrefix = fmap fst . splitCharacterPrefix + + map f = concatMap (singleton . f) + concatMap f = foldr mappend (mappend . f) mempty + all p = foldr (const id) ((&&) . p) True + any p = foldr (const id) ((||) . p) False + + foldl ft fc = Factorial.foldl (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime)) + foldr ft fc = Factorial.foldr (\prime-> maybe (ft prime) fc (characterPrefix prime)) + foldl' ft fc = Factorial.foldl' (\a prime-> maybe (ft a prime) (fc a) (characterPrefix prime)) + + scanl f c = mappend (singleton c) . fst . foldl foldlOther (foldlChars f) (mempty, c) + scanl1 f t = case (Factorial.splitPrimePrefix t, splitCharacterPrefix t) + of (Nothing, _) -> t + (Just (prefix, suffix), Nothing) -> mappend prefix (scanl1 f suffix) + (Just _, Just (c, suffix)) -> scanl f c suffix + scanr f c = fst . foldr foldrOther (foldrChars f) (singleton c, c) + scanr1 f = fst . foldr foldrOther fc (mempty, Nothing) + where fc c (t, Nothing) = (mappend (singleton c) t, Just c) + fc c1 (t, Just c2) = (mappend (singleton c') t, Just c') + where c' = f c1 c2 + mapAccumL f a0 = foldl ft fc (a0, mempty) + where ft (a, t1) t2 = (a, mappend t1 t2) + fc (a, t) c = (a', mappend t (singleton c')) + where (a', c') = f a c + mapAccumR f a0 = foldr ft fc (a0, mempty) + where ft t1 (a, t2) = (a, mappend t1 t2) + fc c (a, t) = (a', mappend (singleton c') t) + where (a', c') = f a c + + takeWhile pt pc = fst . span pt pc + dropWhile pt pc = snd . span pt pc + span pt pc = Factorial.span (\prime-> maybe (pt prime) pc (characterPrefix prime)) + break pt pc = Factorial.break (\prime-> maybe (pt prime) pc (characterPrefix prime)) + split f = Factorial.split (maybe False f . characterPrefix) + find f = foldr (const id) (\c r-> if f c then Just c else r) Nothing + +foldlChars f (t, c1) c2 = (mappend t (singleton c'), c') + where c' = f c1 c2 +foldlOther (t1, c) t2 = (mappend t1 t2, c) +foldrChars f c1 (t, c2) = (mappend (singleton c') t, c') + where c' = f c1 c2 +foldrOther t1 (t2, c) = (mappend t1 t2, c) + +instance TextualMonoid String where + fromText = Text.unpack + singleton c = [c] + splitCharacterPrefix (c:rest) = Just (c, rest) + splitCharacterPrefix [] = Nothing + characterPrefix (c:_) = Just c + characterPrefix [] = Nothing + map = List.map + concatMap = List.concatMap + any = List.any + all = List.all + + foldl = const List.foldl + foldl' = const List.foldl' + foldr = const List.foldr + + scanl = List.scanl + scanl1 = List.scanl1 + scanr = List.scanr + scanr1 = List.scanr1 + mapAccumL = List.mapAccumL + mapAccumR = List.mapAccumR + + takeWhile _ = List.takeWhile + dropWhile _ = List.dropWhile + break _ = List.break + span _ = List.span + find = List.find + +instance TextualMonoid Text where + fromText = id + singleton = Text.singleton + splitCharacterPrefix = Text.uncons + characterPrefix t = if Text.null t then Nothing else Just (Text.head t) + map = Text.map + concatMap = Text.concatMap + any = Text.any + all = Text.all + + foldl = const Text.foldl + foldl' = const Text.foldl' + foldr = const Text.foldr + + scanl = Text.scanl + scanl1 = Text.scanl1 + scanr = Text.scanr + scanr1 = Text.scanr1 + mapAccumL = Text.mapAccumL + mapAccumR = Text.mapAccumR + + takeWhile _ = Text.takeWhile + dropWhile _ = Text.dropWhile + break _ = Text.break + span _ = Text.span + split = Text.split + find = Text.find + +instance TextualMonoid LazyText.Text where + fromText = LazyText.fromStrict + singleton = LazyText.singleton + splitCharacterPrefix = LazyText.uncons + characterPrefix t = if LazyText.null t then Nothing else Just (LazyText.head t) + map = LazyText.map + concatMap = LazyText.concatMap + any = LazyText.any + all = LazyText.all + + foldl = const LazyText.foldl + foldl' = const LazyText.foldl' + foldr = const LazyText.foldr + + scanl = LazyText.scanl + scanl1 = LazyText.scanl1 + scanr = LazyText.scanr + scanr1 = LazyText.scanr1 + mapAccumL = LazyText.mapAccumL + mapAccumR = LazyText.mapAccumR + + takeWhile _ = LazyText.takeWhile + dropWhile _ = LazyText.dropWhile + break _ = LazyText.break + span _ = LazyText.span + split = LazyText.split + find = LazyText.find diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/Test/TestMonoidSubclasses.hs b/Test/TestMonoidSubclasses.hs new file mode 100644 --- /dev/null +++ b/Test/TestMonoidSubclasses.hs @@ -0,0 +1,612 @@ +{- + Copyright 2013 Mario Blazevic + + License: BSD3 (see BSD3-LICENSE.txt file) +-} + +{-# LANGUAGE Rank2Types, ScopedTypeVariables, FlexibleInstances, GeneralizedNewtypeDeriving #-} + +module Main where + +import Prelude hiding (foldl, foldr, gcd, length, null, reverse, span, splitAt, takeWhile) + +import Test.QuickCheck (Arbitrary, CoArbitrary, Property, Gen, + quickCheck, arbitrary, coarbitrary, property, label, forAll, variant, whenFail, (.&&.)) +import Test.QuickCheck.Instances () + +import Data.Int (Int8, Int32) +import Data.Foldable (toList) +import Data.List (intersperse, unfoldr) +import qualified Data.List as List +import Data.Maybe (isJust) +import Data.Either (lefts, rights) +import Data.Tuple (swap) +import Data.String (IsString, fromString) +import Data.Char (isLetter) + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import Data.Text (Text) +import qualified Data.Text.Lazy as Lazy (Text) +import qualified Data.Text as Text +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.Map (Map) +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.Vector (Vector, fromList) + +import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(ByteStringUTF8)) + +import Data.Monoid (Monoid, mempty, (<>), mconcat, All(All), Any(Any), Dual(Dual), + First(First), Last(Last), Sum(Sum), Product(Product)) +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, + CancellativeMonoid, LeftCancellativeMonoid, RightCancellativeMonoid, + GCDMonoid, LeftGCDMonoid, RightGCDMonoid, + (), gcd, + isPrefixOf, stripPrefix, commonPrefix, stripCommonPrefix, + isSuffixOf, stripSuffix, commonSuffix, stripCommonSuffix) +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) + | 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) + | RightReductiveTest (forall a. (Arbitrary a, Show a, Eq a, RightReductiveMonoid a) => a -> Property) + | ReductiveTest (forall a. (Arbitrary a, Show a, Eq a, ReductiveMonoid a) => a -> Property) + | LeftCancellativeTest (forall a. (Arbitrary a, Show a, Eq a, LeftCancellativeMonoid a) => a -> Property) + | RightCancellativeTest (forall a. (Arbitrary a, Show a, Eq a, RightCancellativeMonoid a) => a -> Property) + | CancellativeTest (forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a) => a -> Property) + | LeftGCDTest (forall a. (Arbitrary a, Show a, Eq a, LeftGCDMonoid a) => a -> Property) + | RightGCDTest (forall a. (Arbitrary a, Show a, Eq a, RightGCDMonoid a) => a -> Property) + | GCDTest (forall a. (Arbitrary a, Show a, Eq a, GCDMonoid a) => a -> Property) + | CancellativeGCDTest (forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a, GCDMonoid a) + => a -> Property) + +main = mapM_ (quickCheck . uncurry checkInstances) tests + +checkInstances :: String -> Test -> Property +checkInstances name (NullTest checkType) = label name (checkType () + .&&. checkType (mempty :: Ordering) + .&&. checkType (mempty :: All) + .&&. checkType (mempty :: Any) + .&&. checkType (mempty :: String) + .&&. checkType (mempty :: ByteString) + .&&. checkType (mempty :: Lazy.ByteString) + .&&. checkType (mempty :: Text) + .&&. checkType (mempty :: Lazy.Text) + .&&. checkType (mempty :: Dual String) + .&&. checkType (mempty :: Sum Float) + .&&. checkType (mempty :: Product Int) + .&&. checkType (mempty :: First Int) + .&&. checkType (mempty :: Last Int) + .&&. checkType (mempty :: Maybe String) + .&&. checkType (mempty :: (Text, String)) + .&&. checkType (mempty :: IntMap Int) + .&&. checkType (mempty :: IntSet) + .&&. checkType (mempty :: Map String Int) + .&&. checkType (mempty :: Seq Int) + .&&. checkType (mempty :: Set String) + .&&. checkType (mempty :: Vector Int)) +checkInstances name (FactorialTest checkType) = label name (checkType (mempty :: TestString) + .&&. checkType (mempty :: String) + .&&. checkType (mempty :: ByteString) + .&&. checkType (mempty :: Lazy.ByteString) + .&&. checkType (mempty :: ByteStringUTF8) + .&&. checkType (mempty :: Text) + .&&. checkType (mempty :: Lazy.Text) + .&&. checkType (mempty :: Dual String) + .&&. checkType (mempty :: Sum Int8) + .&&. checkType (mempty :: Product Int32) + .&&. checkType (mempty :: Maybe String) + .&&. checkType (mempty :: (Text, String)) + .&&. checkType (mempty :: IntMap Int) + .&&. checkType (mempty :: IntSet) + .&&. checkType (mempty :: Map String Int) + .&&. checkType (mempty :: Seq Int) + .&&. checkType (mempty :: Set String) + .&&. checkType (mempty :: Vector Int)) +checkInstances name (TextualTest checkType) = label name (checkType (mempty :: TestString) + .&&. checkType (mempty :: String) + .&&. checkType (mempty :: ByteStringUTF8) + .&&. checkType (mempty :: Text) + .&&. checkType (mempty :: Lazy.Text)) +checkInstances name (LeftReductiveTest checkType) = label name (checkType (mempty :: String) + .&&. checkType (mempty :: ByteString) + .&&. checkType (mempty :: Lazy.ByteString) + .&&. checkType (mempty :: Text) + .&&. checkType (mempty :: Lazy.Text) + .&&. checkType (mempty :: Dual Text) + .&&. checkType (mempty :: Sum Integer) + .&&. checkType (mempty :: Product Integer) + .&&. checkType (mempty :: (Text, String)) + .&&. checkType (mempty :: IntSet) + .&&. checkType (mempty :: Seq String) + .&&. checkType (mempty :: Set Integer) + .&&. checkType (mempty :: Vector Int)) +checkInstances name (RightReductiveTest checkType) = label name (checkType (mempty :: ByteString) + .&&. checkType (mempty :: Lazy.ByteString) + .&&. checkType (mempty :: Text) + .&&. checkType (mempty :: Lazy.Text) + .&&. checkType (mempty :: Dual String) + .&&. checkType (mempty :: Sum Integer) + .&&. checkType (mempty :: Product Integer) + .&&. checkType (mempty :: (Text, ByteString)) + .&&. checkType (mempty :: IntSet) + .&&. checkType (mempty :: Seq Int) + .&&. checkType (mempty :: Set String) + .&&. checkType (mempty :: Vector Int)) +checkInstances name (ReductiveTest checkType) = label name (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) + .&&. checkType (mempty :: ByteString) + .&&. checkType (mempty :: Lazy.ByteString) + .&&. checkType (mempty :: Text) + .&&. checkType (mempty :: Lazy.Text) + .&&. checkType (mempty :: Dual Text) + .&&. checkType (mempty :: Sum Integer) + .&&. checkType (mempty :: (Text, String)) + .&&. checkType (mempty :: Seq Int) + .&&. checkType (mempty :: Vector Int)) +checkInstances name (RightCancellativeTest checkType) = label name (checkType (mempty :: ByteString) + .&&. checkType (mempty :: Lazy.ByteString) + .&&. checkType (mempty :: Text) + .&&. checkType (mempty :: Lazy.Text) + .&&. checkType (mempty :: Dual String) + .&&. checkType (mempty :: Sum Integer) + .&&. checkType (mempty :: (Text, ByteString)) + .&&. checkType (mempty :: Seq Int) + .&&. checkType (mempty :: Vector Int)) +checkInstances name (CancellativeTest checkType) = label name (checkType (mempty :: Sum Integer) + .&&. checkType (mempty :: Dual (Sum Integer)) + .&&. checkType (mempty :: (Sum Integer, Sum Int))) +checkInstances name (LeftGCDTest checkType) = label name (checkType (mempty :: String) + .&&. checkType (mempty :: ByteString) + .&&. checkType (mempty :: Lazy.ByteString) + .&&. checkType (mempty :: Text) + .&&. checkType (mempty :: Lazy.Text) + .&&. checkType (mempty :: Dual ByteString) + .&&. checkType (mempty :: Sum Integer) + .&&. checkType (mempty :: Product Integer) + .&&. checkType (mempty :: (Text, String)) + .&&. checkType (mempty :: IntMap Int) + .&&. checkType (mempty :: IntSet) + .&&. checkType (mempty :: Map String Int) + .&&. checkType (mempty :: Seq Int) + .&&. checkType (mempty :: Set String) + .&&. checkType (mempty :: Vector Int)) +checkInstances name (RightGCDTest checkType) = label name (checkType (mempty :: ByteString) + .&&. checkType (mempty :: Lazy.ByteString) + .&&. checkType (mempty :: Dual String) + .&&. checkType (mempty :: Sum Integer) + .&&. checkType (mempty :: Product Integer) + .&&. checkType (mempty :: (Seq Int, ByteString)) + .&&. checkType (mempty :: IntSet) + .&&. checkType (mempty :: Seq Int) + .&&. checkType (mempty :: Set String) + .&&. checkType (mempty :: Vector Int)) +checkInstances name (GCDTest checkType) = label name (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) + .&&. checkType (mempty :: Dual (Sum Integer)) + .&&. checkType (mempty :: (Sum Integer, Sum Int))) + +tests :: [(String, Test)] +tests = [("MonoidNull", NullTest checkNull), + ("mconcat . factors == id", FactorialTest checkConcatFactors), + ("all factors . factors", FactorialTest checkFactorsOfFactors), + ("splitPrimePrefix", FactorialTest checkSplitPrimePrefix), + ("splitPrimeSuffix", FactorialTest checkSplitPrimeSuffix), + ("primePrefix", FactorialTest checkPrimePrefix), + ("primeSuffix", FactorialTest checkPrimeSuffix), + ("foldl", FactorialTest checkLeftFold), + ("foldl'", FactorialTest checkLeftFold'), + ("foldr", FactorialTest checkRightFold), + ("length", FactorialTest checkLength), + ("span", FactorialTest checkSpan), + ("split", FactorialTest checkSplit), + ("splitAt", FactorialTest checkSplitAt), + ("reverse", FactorialTest checkReverse), + ("fromText", TextualTest checkFromText), + ("singleton", TextualTest checkSingleton), + ("Textual.splitCharacterPrefix", TextualTest checkSplitCharacterPrefix), + ("Textual.characterPrefix", TextualTest checkCharacterPrefix), + ("Textual factors", TextualTest checkTextualFactors), + ("Textual.unfoldr", TextualTest checkUnfoldrToFactors), + ("factors . fromString", TextualTest checkFactorsFromString), + ("Textual.map", TextualTest checkTextualMap), + ("Textual.concatMap", TextualTest checkConcatMap), + ("Textual.any", TextualTest checkAny), + ("Textual.all", TextualTest checkAll), + ("Textual.foldl", TextualTest checkTextualFoldl), + ("Textual.foldr", TextualTest checkTextualFoldr), + ("Textual.foldl'", TextualTest checkTextualFoldl'), + ("Textual.scanl", TextualTest checkTextualScanl), + ("Textual.scanr", TextualTest checkTextualScanr), + ("Textual.scanl1", TextualTest checkTextualScanl1), + ("Textual.scanr1", TextualTest checkTextualScanr1), + ("Textual.mapAccumL", TextualTest checkTextualMapAccumL), + ("Textual.mapAccumR", TextualTest checkTextualMapAccumR), + ("Textual.mapAccumR", TextualTest checkTextualMapAccumR), + ("Textual.takeWhile", TextualTest checkTextualTakeWhile), + ("Textual.dropWhile", TextualTest checkTextualDropWhile), + ("Textual.span", TextualTest checkTextualSpan), + ("Textual.break", TextualTest checkTextualBreak), + ("Textual.split", TextualTest checkTextualSplit), + ("Textual.find", TextualTest checkTextualFind), + ("stripPrefix", LeftReductiveTest checkStripPrefix), + ("isPrefixOf", LeftReductiveTest checkIsPrefixOf), + ("stripSuffix", RightReductiveTest checkStripSuffix), + ("isSuffixOf", RightReductiveTest checkIsSuffixOf), + ("", ReductiveTest checkUnAppend), + ("cancellative stripPrefix", LeftCancellativeTest checkStripPrefix'), + ("cancellative stripSuffix", RightCancellativeTest checkStripSuffix'), + ("cancellative ", CancellativeTest checkUnAppend'), + ("stripCommonPrefix 1", LeftGCDTest checkStripCommonPrefix1), + ("stripCommonPrefix 2", LeftGCDTest checkStripCommonPrefix2), + ("stripCommonSuffix 1", RightGCDTest checkStripCommonSuffix1), + ("stripCommonSuffix 2", RightGCDTest checkStripCommonSuffix2), + ("gcd", GCDTest checkGCD), + ("cancellative gcd", CancellativeGCDTest checkCancellativeGCD) + ] + +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)) + +checkConcatFactors :: forall a. (Arbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkConcatFactors e = null (factors e) .&&. forAll (arbitrary :: Gen a) check + where check a = mconcat (factors a) == a + +checkFactorsOfFactors :: forall a. (Arbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkFactorsOfFactors _ = forAll (arbitrary :: Gen a) (all singleton . factors) + where singleton prime = factors prime == [prime] + +checkSplitPrimePrefix :: forall a. (Arbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkSplitPrimePrefix _ = forAll (arbitrary :: Gen a) (\a-> factors a == unfoldr splitPrimePrefix a) + +checkSplitPrimeSuffix :: forall a. (Arbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkSplitPrimeSuffix _ = forAll (arbitrary :: Gen a) check + where check a = factors a == reverse (unfoldr (fmap swap . splitPrimeSuffix) a) + +checkPrimePrefix :: forall a. (Arbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkPrimePrefix _ = forAll (arbitrary :: Gen a) (\a-> primePrefix a == maybe mempty fst (splitPrimePrefix a)) + +checkPrimeSuffix :: forall a. (Arbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkPrimeSuffix _ = forAll (arbitrary :: Gen a) (\a-> primeSuffix a == maybe mempty snd (splitPrimeSuffix a)) + +checkLeftFold :: forall a. (Arbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkLeftFold _ = forAll (arbitrary :: Gen a) (\a-> foldl (flip (:)) [] a == List.foldl (flip (:)) [] (factors a)) + +checkLeftFold' :: forall a. (Arbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkLeftFold' _ = forAll (arbitrary :: Gen a) (\a-> foldl' (flip (:)) [] a == List.foldl' (flip (:)) [] (factors a)) + +checkRightFold :: forall a. (Arbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkRightFold _ = forAll (arbitrary :: Gen a) (\a-> foldr (:) [] a == List.foldr (:) [] (factors a)) + +checkLength :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkLength _ = forAll (arbitrary :: Gen a) (\a-> length a == List.length (factors a)) + +checkSpan :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkSpan _ = property $ \p-> forAll (arbitrary :: Gen a) (check p) + where check p a = span p a == (mconcat l, mconcat r) + where (l, r) = List.span p (factors a) + +checkSplit :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkSplit _ = forAll (arbitrary :: Gen a) check + where check a = property (\pred-> all (all (not . pred) . factors) (split pred a)) + .&&. property (\prime-> mconcat (intersperse prime $ split (== prime) a) == a) + +checkSplitAt :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkSplitAt _ = property $ \i-> forAll (arbitrary :: Gen a) (check i) + where check i a = splitAt i a == (mconcat l, mconcat r) + where (l, r) = List.splitAt i (factors a) + +checkReverse :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property +checkReverse _ = property $ forAll (arbitrary :: Gen a) (\a-> reverse a == mconcat (List.reverse $ factors a)) + +checkFromText :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkFromText _ = forAll (arbitrary :: Gen Text) (\t-> Textual.fromText t == (fromString (Text.unpack t) :: a)) + +checkSingleton :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkSingleton _ = forAll (arbitrary :: Gen Char) (\c-> Textual.singleton c == (fromString [c] :: a)) + +checkSplitCharacterPrefix :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkSplitCharacterPrefix _ = forAll (arbitrary :: Gen (Char, a)) check + where check p@(c, t) = Textual.splitCharacterPrefix (Textual.singleton c <> t) == Just p + && Textual.splitCharacterPrefix (primePrefix t) + == fmap (\(c, t)-> (c, mempty)) (Textual.splitCharacterPrefix t) + +checkCharacterPrefix :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkCharacterPrefix _ = forAll (arbitrary :: Gen a) check + where check t = Textual.characterPrefix t == fmap fst (Textual.splitCharacterPrefix t) + +checkTextualFactors :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualFactors _ = forAll (arbitrary :: Gen a) check + where check a = all (maybe True (null . snd) . Textual.splitCharacterPrefix) (factors a) + +checkUnfoldrToFactors :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkUnfoldrToFactors _ = forAll (arbitrary :: Gen a) check + where check a = factors a == unfoldr splitPrimePrefix a + +checkFactorsFromString :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkFactorsFromString _ = forAll (arbitrary :: Gen String) check + where check s = unfoldr Textual.splitCharacterPrefix (fromString s :: a) == s + +checkTextualMap :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualMap _ = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 + where check1 a = Textual.map succ a == Textual.concatMap (Textual.singleton . succ) a + && Textual.map id a == a + check2 s = Textual.map succ (fromString s :: a) == fromString (List.map succ s) + +checkConcatMap :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkConcatMap _ = 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 + check2 s = Textual.concatMap (fromString . f) (fromString s :: a) == fromString (List.concatMap f s) + f = replicate 3 + apply prime = maybe prime (fromString . f) (Textual.characterPrefix prime) + +checkAll :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkAll _ = forAll (arbitrary :: Gen a) check + where check a = Textual.all isLetter a == Textual.foldr (const id) ((&&) . isLetter) True a + +checkAny :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkAny _ = forAll (arbitrary :: Gen a) check + where check a = Textual.any isLetter a == Textual.foldr (const id) ((||) . isLetter) False a + +checkTextualFoldl :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualFoldl _ = 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 :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualFoldr _ = 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 (:) [] s == s + +checkTextualFoldl' :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualFoldl' _ = 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 + +checkTextualScanl :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualScanl _ = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 + where check1 a = (rights . textualFactors . Textual.scanl f 'Z') a == (List.scanl f 'Z' . rights . textualFactors) a + && (lefts . textualFactors . Textual.scanl f 'Y') a == (lefts . textualFactors) a + && Textual.scanl f 'W' a == Textual.scanl1 f (Textual.singleton 'W' <> a) + check2 s = Textual.scanl f 'X' (fromString s :: a) == fromString (List.scanl f 'X' s) + f c1 c2 = succ (max c1 c2) + +checkTextualScanr :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualScanr _ = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 + where check1 a = (rights . textualFactors . Textual.scanr f 'Z') a == (List.scanr f 'Z' . rights . textualFactors) a + && (lefts . textualFactors . Textual.scanr f 'Y') a == (lefts . textualFactors) a + && Textual.scanr f 'W' a == Textual.scanr1 f (a <> Textual.singleton 'W') + check2 s = Textual.scanr f 'X' (fromString s :: a) == fromString (List.scanr f 'X' s) + f c1 c2 = succ (max c1 c2) + +checkTextualScanl1 :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualScanl1 _ = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 + where check1 a = Textual.scanl1 (const id) a == a + check2 s = Textual.scanl1 f (fromString s :: a) == fromString (List.scanl1 f s) + f c1 c2 = succ (max c1 c2) + +checkTextualScanr1 :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualScanr1 _ = forAll (arbitrary :: Gen a) check1 .&&. forAll (arbitrary :: Gen String) check2 + where check1 a = Textual.scanr1 const a == a + check2 s = Textual.scanr1 f (fromString s :: a) == fromString (List.scanr1 f s) + f c1 c2 = succ (max c1 c2) + +checkTextualMapAccumL :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualMapAccumL _ = 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 :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualMapAccumR _ = 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 :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualTakeWhile _ = 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 :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualDropWhile _ = 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) + && Textual.dropWhile (const False) (const False) a == a + check2 s = Textual.dropWhile undefined isLetter (fromString s :: a) + == fromString (List.dropWhile isLetter s) + +checkTextualSpan :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualSpan _ = forAll (arbitrary :: Gen a) check + where check a = Textual.span pt pc a == (Textual.takeWhile pt pc a, Textual.dropWhile pt pc a) + where pt = (== primePrefix a) + pc = isLetter + +checkTextualBreak :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualBreak _ = forAll (arbitrary :: Gen a) check + where check a = Textual.break pt pc a == Textual.span (not . pt) (not . pc) a + where pt = (/= primePrefix a) + pc = isLetter + +checkTextualSplit :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualSplit _ = forAll (arbitrary :: Gen a) check + where check a = List.all (List.all isLetter . rights . textualFactors) (Textual.split (not . isLetter) a) + && (mconcat . intersperse (fromString " ") . Textual.split (== ' ')) a == a + +checkTextualFind :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property +checkTextualFind _ = 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 + +checkStripPrefix :: forall a. (Arbitrary a, Show a, Eq a, LeftReductiveMonoid a) => a -> Property +checkStripPrefix _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = maybe b (a <>) (stripPrefix a b) == b + +checkIsPrefixOf :: forall a. (Arbitrary a, Show a, Eq a, LeftReductiveMonoid a) => a -> Property +checkIsPrefixOf _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = isPrefixOf a b == isJust (stripPrefix a b) + && a `isPrefixOf` (a <> b) + +checkStripSuffix :: forall a. (Arbitrary a, Show a, Eq a, RightReductiveMonoid a) => a -> Property +checkStripSuffix _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = maybe b (<> a) (stripSuffix a b) == b + +checkIsSuffixOf :: forall a. (Arbitrary a, Show a, Eq a, RightReductiveMonoid a) => a -> Property +checkIsSuffixOf _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = isSuffixOf a b == isJust (stripSuffix a b) + && b `isSuffixOf` (a <> b) + +checkUnAppend :: forall a. (Arbitrary a, Show a, Eq a, ReductiveMonoid a) => a -> Property +checkUnAppend _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = maybe a (b <>) (a b) == a + && maybe a (<> b) (a b) == a + +checkStripPrefix' :: forall a. (Arbitrary a, Show a, Eq a, LeftCancellativeMonoid a) => a -> Property +checkStripPrefix' _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = stripPrefix a (a <> b) == Just b + +checkStripSuffix' :: forall a. (Arbitrary a, Show a, Eq a, RightCancellativeMonoid a) => a -> Property +checkStripSuffix' _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = stripSuffix b (a <> b) == Just a + +checkUnAppend' :: forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a) => a -> Property +checkUnAppend' _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = a <> b a == Just b + && a <> b b == Just a + +checkStripCommonPrefix1 :: forall a. (Arbitrary a, Show a, Eq a, LeftGCDMonoid a) => a -> Property +checkStripCommonPrefix1 _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = stripCommonPrefix a b == (p, a', b') + where p = commonPrefix a b + Just a' = stripPrefix p a + Just b' = stripPrefix p b + +checkStripCommonPrefix2 :: forall a. (Arbitrary a, Show a, Eq a, LeftGCDMonoid a) => a -> Property +checkStripCommonPrefix2 _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = p == commonPrefix a b && p <> a' == a && p <> b' == b + where (p, a', b') = stripCommonPrefix a b + +checkStripCommonSuffix1 :: forall a. (Arbitrary a, Show a, Eq a, RightGCDMonoid a) => a -> Property +checkStripCommonSuffix1 _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = stripCommonSuffix a b == (a', b', s) + where s = commonSuffix a b + Just a' = stripSuffix s a + Just b' = stripSuffix s b + +checkStripCommonSuffix2 :: forall a. (Arbitrary a, Show a, Eq a, RightGCDMonoid a) => a -> Property +checkStripCommonSuffix2 _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = s == commonSuffix a b && a' <> s == a && b' <> s == b + where (a', b', s) = stripCommonSuffix a b + +checkGCD :: forall a. (Arbitrary a, Show a, Eq a, GCDMonoid a) => a -> Property +checkGCD _ = forAll (arbitrary :: Gen (a, a)) check + where check (a, b) = d == commonPrefix a b + && d == commonSuffix a b + && isJust (a d) + && isJust (b d) + where d = gcd a b + +checkCancellativeGCD :: forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a, GCDMonoid a) => a -> Property +checkCancellativeGCD _ = forAll (arbitrary :: Gen (a, a, a)) check + where check (a, b, c) = commonPrefix (a <> b) (a <> c) == a <> (commonPrefix b c) + && commonSuffix (a <> c) (b <> c) == (commonSuffix a b) <> c + && gcd (a <> b) (a <> c) == a <> gcd b c + && gcd (a <> c) (b <> c) == gcd a b <> c + +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, + Monoid, LeftReductiveMonoid, LeftCancellativeMonoid, LeftGCDMonoid, + MonoidNull, IsString) + +instance FactorialMonoid TestString where + splitPrimePrefix (TestString []) = Nothing + splitPrimePrefix (TestString (x:xs)) = Just (TestString [x], TestString xs) + +instance TextualMonoid TestString where + splitCharacterPrefix (TestString []) = Nothing + splitCharacterPrefix (TestString (x:xs)) = Just (x, TestString xs) + +instance Show a => Show (a -> Bool) where + show _ = "predicate" + +instance Arbitrary All where + arbitrary = fmap All arbitrary + +instance Arbitrary Any where + arbitrary = fmap Any arbitrary + +instance Arbitrary a => Arbitrary (Dual a) where + arbitrary = fmap Dual arbitrary + +instance Arbitrary a => Arbitrary (First a) where + arbitrary = fmap First arbitrary + +instance Arbitrary a => Arbitrary (Last a) where + arbitrary = fmap Last arbitrary + +instance Arbitrary a => Arbitrary (Product a) where + arbitrary = fmap Product arbitrary + +instance Arbitrary a => Arbitrary (Sum a) where + arbitrary = fmap Sum arbitrary + +instance Arbitrary a => Arbitrary (Vector a) where + arbitrary = fmap fromList arbitrary + +instance Arbitrary ByteStringUTF8 where + arbitrary = fmap ByteStringUTF8 arbitrary + +instance CoArbitrary All where + coarbitrary (All p) = coarbitrary p + +instance CoArbitrary Any where + coarbitrary (Any p) = coarbitrary p + +instance CoArbitrary a => CoArbitrary (Dual a) where + coarbitrary (Dual a) = coarbitrary a + +instance CoArbitrary a => CoArbitrary (First a) where + coarbitrary (First a) = coarbitrary a + +instance CoArbitrary a => CoArbitrary (Last a) where + coarbitrary (Last a) = coarbitrary a + +instance CoArbitrary a => CoArbitrary (Product a) where + coarbitrary (Product a) = coarbitrary a + +instance CoArbitrary a => CoArbitrary (Sum a) where + coarbitrary (Sum a) = coarbitrary a + +instance CoArbitrary a => CoArbitrary (Vector a) where + coarbitrary = coarbitrary . toList + +instance CoArbitrary ByteStringUTF8 where + coarbitrary (ByteStringUTF8 bs) = coarbitrary bs diff --git a/monoid-subclasses.cabal b/monoid-subclasses.cabal new file mode 100644 --- /dev/null +++ b/monoid-subclasses.cabal @@ -0,0 +1,39 @@ +Name: monoid-subclasses +Version: 0.1 +Cabal-Version: >= 1.10 +Build-Type: Simple +Synopsis: Subclasses of Monoid +Category: Data +Tested-with: GHC +Description: + This package defines 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 Mario Blazevic +Author: Mario Blazevic +Maintainer: blamario@yahoo.com +Homepage: https://github.com/blamario/monoid-subclasses/ +Source-repository head + type: darcs + location: http://code.haskell.org/SCC/ + +Library + Exposed-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null, Data.Monoid.Textual, + Data.Monoid.Instances.ByteString.UTF8 + Build-Depends: base < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text == 0.11.*, primes == 0.2.*, + utf8-string == 0.3.*, vector == 0.10.* + GHC-prof-options: -auto-all + if impl(ghc >= 7.0.0) + default-language: Haskell2010 + +test-suite Main + Type: exitcode-stdio-1.0 + x-uses-tf: true + Build-Depends: base < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text == 0.11.*, primes == 0.2.*, + utf8-string == 0.3.*, vector == 0.10.*, QuickCheck == 2.*, quickcheck-instances == 0.3.*, + test-framework >= 0.4.1, test-framework-quickcheck2 + Main-is: Test/TestMonoidSubclasses.hs + Other-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null + default-language: Haskell2010