diff --git a/Data/Monoid/Factorial.hs b/Data/Monoid/Factorial.hs --- a/Data/Monoid/Factorial.hs +++ b/Data/Monoid/Factorial.hs @@ -37,7 +37,7 @@ import qualified Data.Vector as Vector import Data.Numbers.Primes (primeFactors) -import Data.Monoid.Null (MonoidNull(null)) +import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) -- | 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: @@ -148,7 +148,7 @@ -- | A subclass of 'FactorialMonoid' whose instances satisfy this additional law: -- -- > factors (a <> b) == factors a <> factors b -class FactorialMonoid m => StableFactorialMonoid m +class (FactorialMonoid m, PositiveMonoid m) => StableFactorialMonoid m instance FactorialMonoid () where factors () = [] diff --git a/Data/Monoid/Instances/Concat.hs b/Data/Monoid/Instances/Concat.hs --- a/Data/Monoid/Instances/Concat.hs +++ b/Data/Monoid/Instances/Concat.hs @@ -16,7 +16,6 @@ import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) -import Control.Applicative (Applicative(..)) import Data.Foldable (Foldable) import Data.Traversable (Traversable, traverse) import qualified Data.Foldable as Foldable @@ -205,15 +204,6 @@ break pt pc = Textual.span (not . pt) (not . pc) find p (Concat x) = getFirst $ Foldable.foldMap (First . find p) x - -newtype Pair a = Pair (a, a) - -instance Functor Pair where - fmap f (Pair (x, y)) = Pair (f x, f y) - -instance Applicative Pair where - pure x = Pair (x, x) - Pair (f, g) <*> Pair (x, y) = Pair (f x, g y) inject :: (MonoidNull a, PositiveMonoid a) => Seq a -> Concat a inject = Concat . filter (not . null) diff --git a/Data/Monoid/Instances/Measured.hs b/Data/Monoid/Instances/Measured.hs new file mode 100644 --- /dev/null +++ b/Data/Monoid/Instances/Measured.hs @@ -0,0 +1,117 @@ +{- + Copyright 2013 Mario Blazevic + + License: BSD3 (see BSD3-LICENSE.txt file) +-} + +-- | This module defines the monoid transformer data type 'Measured'. +-- + +{-# LANGUAGE Haskell2010 #-} + +module Data.Monoid.Instances.Measured ( + Measured, inject, extract + ) +where + +import Prelude hiding (all, any, break, filter, foldl, foldl1, foldr, foldr1, map, concatMap, + length, null, reverse, scanl, scanr, scanl1, scanr1, span, splitAt) +import Data.Functor ((<$>)) +import qualified Data.List as List +import Data.String (IsString(..)) +import Data.Monoid (Monoid(..), (<>), First(..), Sum(..)) +import Data.Monoid.Cancellative (LeftReductiveMonoid(..), RightReductiveMonoid(..), + LeftGCDMonoid(..), RightGCDMonoid(..)) +import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) +import Data.Monoid.Factorial (FactorialMonoid(..), StableFactorialMonoid) +import Data.Monoid.Textual (TextualMonoid(..)) +import qualified Data.Monoid.Factorial as Factorial +import qualified Data.Monoid.Textual as Textual + +-- | @'Measured' a@ is a wrapper around the 'FactorialMonoid' @a@ that memoizes the monoid's 'length' so it becomes a +-- constant-time operation. The parameter is restricted to the 'StableFactorialMonoid' class, which guarantees that +-- @'length' (a <> b) == 'length' a + 'length' b@. + +data Measured a = Measured{measuredLength :: Int, extract :: a} deriving (Eq, Show) + +inject :: FactorialMonoid a => a -> Measured a +inject x = Measured (length x) x + +instance Ord a => Ord (Measured a) where + compare (Measured _ x) (Measured _ y) = compare x y + +instance StableFactorialMonoid a => Monoid (Measured a) where + mempty = Measured 0 mempty + mappend (Measured m a) (Measured n b) = Measured (m + n) (mappend a b) + +instance StableFactorialMonoid a => MonoidNull (Measured a) where + null (Measured n x) = n == 0 + +instance StableFactorialMonoid a => PositiveMonoid (Measured a) + +instance (LeftReductiveMonoid a, StableFactorialMonoid a) => LeftReductiveMonoid (Measured a) where + stripPrefix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripPrefix x y) + +instance (RightReductiveMonoid a, StableFactorialMonoid a) => RightReductiveMonoid (Measured a) where + stripSuffix (Measured m x) (Measured n y) = fmap (Measured (n - m)) (stripSuffix x y) + +instance (LeftGCDMonoid a, StableFactorialMonoid a) => LeftGCDMonoid (Measured a) where + commonPrefix (Measured _ x) (Measured _ y) = inject (commonPrefix x y) + +instance (RightGCDMonoid a, StableFactorialMonoid a) => RightGCDMonoid (Measured a) where + commonSuffix (Measured _ x) (Measured _ y) = inject (commonSuffix x y) + +instance StableFactorialMonoid a => FactorialMonoid (Measured a) where + factors (Measured _ x) = List.map (Measured 1) (factors x) + primePrefix m@(Measured _ x) = if null x then m else Measured 1 (primePrefix x) + primeSuffix m@(Measured _ x) = if null x then m else Measured 1 (primeSuffix x) + splitPrimePrefix (Measured n x) = case splitPrimePrefix x + of Nothing -> Nothing + Just (p, s) -> Just (Measured 1 p, Measured (n - 1) s) + splitPrimeSuffix (Measured n x) = case splitPrimeSuffix x + of Nothing -> Nothing + Just (p, s) -> Just (Measured (n - 1) p, Measured 1 s) + foldl f a (Measured _ x) = Factorial.foldl g a x + where g a = f a . Measured 1 + foldl' f a (Measured _ x) = Factorial.foldl' g a x + where g a = f a . Measured 1 + foldr f a (Measured _ x) = Factorial.foldr g a x + where g = f . Measured 1 + length (Measured n _) = n + foldMap f (Measured _ x) = Factorial.foldMap (f . Measured 1) x + span p (Measured n x) = (xp', xs') + where (xp, xs) = Factorial.span (p . Measured 1) x + xp' = inject xp + xs' = Measured (n - length xp') xs + split p (Measured _ x) = inject <$> Factorial.split (p . Measured 1) x + splitAt m (Measured n x) | m <= 0 = (mempty, Measured n x) + | m >= n = (Measured n x, mempty) + | otherwise = (Measured m xp, Measured (n - m) xs) + where (xp, xs) = splitAt m x + reverse (Measured n x) = Measured n (reverse x) + +instance StableFactorialMonoid a => StableFactorialMonoid (Measured a) + +instance (FactorialMonoid a, IsString a) => IsString (Measured a) where + fromString = inject . fromString + +instance (Eq a, TextualMonoid a, StableFactorialMonoid a) => TextualMonoid (Measured a) where + fromText = inject . fromText + singleton = Measured 1 . singleton + splitCharacterPrefix (Measured n x) = (Measured (n - 1) <$>) <$> splitCharacterPrefix x + characterPrefix (Measured _ x) = characterPrefix x + map f (Measured n x) = Measured n (map f x) + any p (Measured _ x) = any p x + all p (Measured _ x) = all p x + + foldl ft fc a (Measured _ x) = Textual.foldl (\a-> ft a . Measured 1) fc a x + foldl' ft fc a (Measured _ x) = Textual.foldl' (\a-> ft a . Measured 1) fc a x + foldr ft fc a (Measured _ x) = Textual.foldr (ft . Measured 1) fc a x + + span pt pc (Measured n x) = (xp', xs') + where (xp, xs) = Textual.span (pt . Measured 1) pc x + xp' = inject xp + xs' = Measured (n - length xp') xs + break pt pc = Textual.span (not . pt) (not . pc) + + find p (Measured _ x) = find p x diff --git a/Test/TestMonoidSubclasses.hs b/Test/TestMonoidSubclasses.hs --- a/Test/TestMonoidSubclasses.hs +++ b/Test/TestMonoidSubclasses.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ExistentialQuantification #-} module Main where @@ -43,7 +44,10 @@ import Data.Vector (Vector, fromList) import Data.Monoid.Instances.ByteString.UTF8 (ByteStringUTF8(ByteStringUTF8)) -import Data.Monoid.Instances.Concat (Concat, extract, inject) +import Data.Monoid.Instances.Concat (Concat) +import qualified Data.Monoid.Instances.Concat as Concat +import Data.Monoid.Instances.Measured (Measured) +import qualified Data.Monoid.Instances.Measured as Measured import Data.Monoid (Monoid, mempty, (<>), mconcat, All(All), Any(Any), Dual(Dual), First(First), Last(Last), Sum(Sum), Product(Product)) @@ -60,222 +64,267 @@ import Data.Monoid.Textual (TextualMonoid) import qualified Data.Monoid.Textual as Textual -data Test = CommutativeTest (forall a. (Arbitrary a, Show a, Eq a, CommutativeMonoid a) => a -> Property) - | NullTest (forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) => a -> Property) - | FactorialTest (forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => a -> Property) - | TextualTest (forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property) - | LeftReductiveTest (forall a. (Arbitrary a, Show a, Eq a, LeftReductiveMonoid a) => a -> Property) - | 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) +data Test = CommutativeTest (CommutativeMonoidInstance -> Property) + | NullTest (NullMonoidInstance -> Property) + | PositiveTest (PositiveMonoidInstance -> Property) + | FactorialTest (FactorialMonoidInstance -> Property) + | StableFactorialTest (StableFactorialMonoidInstance -> Property) + | TextualTest (TextualMonoidInstance -> Property) + | LeftReductiveTest (LeftReductiveMonoidInstance -> Property) + | RightReductiveTest (RightReductiveMonoidInstance -> Property) + | ReductiveTest (ReductiveMonoidInstance -> Property) + | LeftCancellativeTest (LeftCancellativeMonoidInstance -> Property) + | RightCancellativeTest (RightCancellativeMonoidInstance -> Property) + | CancellativeTest (CancellativeMonoidInstance -> Property) + | LeftGCDTest (LeftGCDMonoidInstance -> Property) + | RightGCDTest (RightGCDMonoidInstance -> Property) + | GCDTest (GCDMonoidInstance -> Property) + | CancellativeGCDTest (CancellativeGCDMonoidInstance -> Property) +data CommutativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CommutativeMonoid a) => + CommutativeMonoidInstance a +data NullMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) => + NullMonoidInstance a +data PositiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, PositiveMonoid a) => + PositiveMonoidInstance a +data FactorialMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, FactorialMonoid a) => + FactorialMonoidInstance a +data StableFactorialMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, StableFactorialMonoid a) => + StableFactorialMonoidInstance a +data TextualMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => + TextualMonoidInstance a +data StableTextualMonoidInstance = forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, StableFactorialMonoid a, + TextualMonoid a) => + StableTextualMonoidInstance a +data LeftReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftReductiveMonoid a) => + LeftReductiveMonoidInstance a +data RightReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightReductiveMonoid a) => + RightReductiveMonoidInstance a +data ReductiveMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, ReductiveMonoid a) => + ReductiveMonoidInstance a +data LeftCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftCancellativeMonoid a) => + LeftCancellativeMonoidInstance a +data RightCancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightCancellativeMonoid a) => + RightCancellativeMonoidInstance a +data CancellativeMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a) => + CancellativeMonoidInstance a +data LeftGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, LeftGCDMonoid a) => + LeftGCDMonoidInstance a +data RightGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, RightGCDMonoid a) => + RightGCDMonoidInstance a +data GCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, GCDMonoid a) => + GCDMonoidInstance a +data CancellativeGCDMonoidInstance = forall a. (Arbitrary a, Show a, Eq a, CancellativeMonoid a, GCDMonoid a) => + CancellativeGCDMonoidInstance a + +commutativeInstances :: [CommutativeMonoidInstance] +commutativeInstances = map upcast reductiveInstances + ++ [CommutativeMonoidInstance (mempty :: Product Double)] + where upcast (ReductiveMonoidInstance i) = CommutativeMonoidInstance i + +nullInstances :: [NullMonoidInstance] +nullInstances = map upcast factorialInstances + ++ [NullMonoidInstance (mempty :: Ordering), + NullMonoidInstance (mempty :: All), + NullMonoidInstance (mempty :: Any), + NullMonoidInstance (mempty :: Sum Float), + NullMonoidInstance (mempty :: Product Int), + NullMonoidInstance (mempty :: First Int), + NullMonoidInstance (mempty :: Last Int), + NullMonoidInstance (mempty :: Concat Any), + NullMonoidInstance (mempty :: Concat (Dual String)), + NullMonoidInstance (mempty :: Concat (Map String Int))] + where upcast (FactorialMonoidInstance i) = NullMonoidInstance i + +positiveInstances = map upcast stableFactorialInstances + ++ [PositiveMonoidInstance (mempty :: ()), + PositiveMonoidInstance (mempty :: Ordering), + PositiveMonoidInstance (mempty :: All), + PositiveMonoidInstance (mempty :: Any), + PositiveMonoidInstance (mempty :: (Maybe (Sum Int))), + PositiveMonoidInstance (mempty :: (First Char)), + PositiveMonoidInstance (mempty :: (Last Int)), + PositiveMonoidInstance (mempty :: String), + PositiveMonoidInstance (mempty :: (Map Int16 Int)), + PositiveMonoidInstance (mempty :: (IntMap Char)), + PositiveMonoidInstance (mempty :: IntSet), + PositiveMonoidInstance (mempty :: (Set Float)), + PositiveMonoidInstance (mempty :: (Dual ()))] + where upcast (StableFactorialMonoidInstance i) = PositiveMonoidInstance i + +factorialInstances :: [FactorialMonoidInstance] +factorialInstances = map upcast stableFactorialInstances + ++ [FactorialMonoidInstance (mempty :: Sum Int8), + FactorialMonoidInstance (mempty :: Product Int32), + FactorialMonoidInstance (mempty :: Maybe String), + FactorialMonoidInstance (mempty :: (Text, String)), + FactorialMonoidInstance (mempty :: IntMap Int), + FactorialMonoidInstance (mempty :: IntSet), + FactorialMonoidInstance (mempty :: Map String Int), + FactorialMonoidInstance (mempty :: Set String), + FactorialMonoidInstance (mempty :: Concat ByteString), + FactorialMonoidInstance (mempty :: Concat (Dual ByteString)), + FactorialMonoidInstance (mempty :: Concat (Maybe String)), + FactorialMonoidInstance (mempty :: Concat (Text, String)), + FactorialMonoidInstance (mempty :: Concat (IntMap Int))] + where upcast (StableFactorialMonoidInstance i) = FactorialMonoidInstance i + +stableFactorialInstances :: [StableFactorialMonoidInstance] +stableFactorialInstances = stable1 ++ map measure stable1 + where stable1 = map upcast stableTextualInstances + ++ [StableFactorialMonoidInstance (mempty :: ByteString), + StableFactorialMonoidInstance (mempty :: Lazy.ByteString), + StableFactorialMonoidInstance (mempty :: Dual String), + StableFactorialMonoidInstance (mempty :: Seq Int), + StableFactorialMonoidInstance (mempty :: Vector Int)] + upcast (StableTextualMonoidInstance i) = StableFactorialMonoidInstance i + measure (StableFactorialMonoidInstance i) = StableFactorialMonoidInstance (Measured.inject i) + +textualInstances :: [TextualMonoidInstance] +textualInstances = map upcast stableTextualInstances + ++ [TextualMonoidInstance (mempty :: ByteStringUTF8), + TextualMonoidInstance (mempty :: Text), + TextualMonoidInstance (mempty :: Lazy.Text), + TextualMonoidInstance (mempty :: Seq Char), + TextualMonoidInstance (mempty :: Vector Char)] + where upcast (StableTextualMonoidInstance i) = TextualMonoidInstance i + +stableTextualInstances :: [StableTextualMonoidInstance] +stableTextualInstances = [StableTextualMonoidInstance (mempty :: TestString), + StableTextualMonoidInstance (mempty :: String), + StableTextualMonoidInstance (mempty :: Text), + StableTextualMonoidInstance (mempty :: Lazy.Text), + StableTextualMonoidInstance (mempty :: Seq Char), + StableTextualMonoidInstance (mempty :: Vector Char)] + +leftReductiveInstances = map upcast leftCancellativeInstances + ++ [LeftReductiveMonoidInstance (mempty :: Sum Integer), + LeftReductiveMonoidInstance (mempty :: IntSet), + LeftReductiveMonoidInstance (mempty :: Set Integer), + LeftReductiveMonoidInstance (mempty :: Concat String), + LeftReductiveMonoidInstance (mempty :: Concat ByteString), + LeftReductiveMonoidInstance (mempty :: Concat Lazy.ByteString), + LeftReductiveMonoidInstance (mempty :: Concat Text), + LeftReductiveMonoidInstance (mempty :: Concat Lazy.Text), + LeftReductiveMonoidInstance (mempty :: Concat (Dual Text))] + where upcast (LeftCancellativeMonoidInstance i) = LeftReductiveMonoidInstance i + +rightReductiveInstances = map upcast rightCancellativeInstances + ++ [RightReductiveMonoidInstance (mempty :: Product Integer), + RightReductiveMonoidInstance (mempty :: IntSet), + RightReductiveMonoidInstance (mempty :: Set String), + RightReductiveMonoidInstance (mempty :: Concat ByteString), + RightReductiveMonoidInstance (mempty :: Concat Lazy.ByteString), + RightReductiveMonoidInstance (mempty :: Concat Text), + RightReductiveMonoidInstance (mempty :: Concat Lazy.Text), + RightReductiveMonoidInstance (mempty :: Concat (Dual Text))] + where upcast (RightCancellativeMonoidInstance i) = RightReductiveMonoidInstance i + +reductiveInstances = map upcast cancellativeInstances + ++ [ReductiveMonoidInstance (mempty :: Product Integer), + ReductiveMonoidInstance (mempty :: IntSet), + ReductiveMonoidInstance (mempty :: Set Integer)] + where upcast (CancellativeMonoidInstance i) = ReductiveMonoidInstance i + +leftCancellativeInstances = map upcast cancellativeInstances + ++ [LeftCancellativeMonoidInstance (mempty :: String), + LeftCancellativeMonoidInstance (mempty :: ByteString), + LeftCancellativeMonoidInstance (mempty :: Lazy.ByteString), + LeftCancellativeMonoidInstance (mempty :: Text), + LeftCancellativeMonoidInstance (mempty :: Lazy.Text), + LeftCancellativeMonoidInstance (mempty :: Dual Text), + LeftCancellativeMonoidInstance (mempty :: (Text, String)), + LeftCancellativeMonoidInstance (mempty :: Seq Int), + LeftCancellativeMonoidInstance (mempty :: Vector Int)] + where upcast (CancellativeMonoidInstance i) = LeftCancellativeMonoidInstance i + +rightCancellativeInstances = map upcast cancellativeInstances + ++ [RightCancellativeMonoidInstance (mempty :: ByteString), + RightCancellativeMonoidInstance (mempty :: Lazy.ByteString), + RightCancellativeMonoidInstance (mempty :: Text), + RightCancellativeMonoidInstance (mempty :: Lazy.Text), + RightCancellativeMonoidInstance (mempty :: Dual String), + RightCancellativeMonoidInstance (mempty :: (Text, ByteString)), + RightCancellativeMonoidInstance (mempty :: Seq Int), + RightCancellativeMonoidInstance (mempty :: Vector Int)] + where upcast (CancellativeMonoidInstance i) = RightCancellativeMonoidInstance i + +cancellativeInstances = map upcast cancellativeGCDInstances + ++ [] + where upcast (CancellativeGCDMonoidInstance i) = CancellativeMonoidInstance i + +leftGCDInstances = map upcast gcdInstances + ++ [LeftGCDMonoidInstance (mempty :: String), + LeftGCDMonoidInstance (mempty :: ByteString), + LeftGCDMonoidInstance (mempty :: Lazy.ByteString), + LeftGCDMonoidInstance (mempty :: Text), + LeftGCDMonoidInstance (mempty :: Lazy.Text), + LeftGCDMonoidInstance (mempty :: Dual ByteString), + LeftGCDMonoidInstance (mempty :: (Text, String)), + LeftGCDMonoidInstance (mempty :: IntMap Int), + LeftGCDMonoidInstance (mempty :: Map String Int), + LeftGCDMonoidInstance (mempty :: Seq Int), + LeftGCDMonoidInstance (mempty :: Vector Int), + LeftGCDMonoidInstance (mempty :: Concat String), + LeftGCDMonoidInstance (mempty :: Concat ByteString), + LeftGCDMonoidInstance (mempty :: Concat Lazy.ByteString), + LeftGCDMonoidInstance (mempty :: Concat Text), + LeftGCDMonoidInstance (mempty :: Concat Lazy.Text), + LeftGCDMonoidInstance (mempty :: Concat (Dual ByteString))] + where upcast (GCDMonoidInstance i) = LeftGCDMonoidInstance i + +rightGCDInstances = map upcast gcdInstances + ++ [RightGCDMonoidInstance (mempty :: ByteString), + RightGCDMonoidInstance (mempty :: Lazy.ByteString), + RightGCDMonoidInstance (mempty :: Dual String), + RightGCDMonoidInstance (mempty :: (Seq Int, ByteString)), + RightGCDMonoidInstance (mempty :: Seq Int), + RightGCDMonoidInstance (mempty :: Vector Int), + RightGCDMonoidInstance (mempty :: Concat ByteString), + RightGCDMonoidInstance (mempty :: Concat Lazy.ByteString), + RightGCDMonoidInstance (mempty :: Concat (Dual Text))] + where upcast (GCDMonoidInstance i) = RightGCDMonoidInstance i + +gcdInstances = map upcast cancellativeGCDInstances + ++ [GCDMonoidInstance (mempty :: Product Integer), + GCDMonoidInstance (mempty :: Dual (Product Integer)), + GCDMonoidInstance (mempty :: IntSet), + GCDMonoidInstance (mempty :: Set String)] + where upcast (CancellativeGCDMonoidInstance i) = GCDMonoidInstance i + +cancellativeGCDInstances = [CancellativeGCDMonoidInstance (), + CancellativeGCDMonoidInstance (mempty :: Sum Integer), + CancellativeGCDMonoidInstance (mempty :: Dual (Sum Integer)), + CancellativeGCDMonoidInstance (mempty :: (Sum Integer, Sum Int))] + main = mapM_ (quickCheck . uncurry checkInstances) tests checkInstances :: String -> Test -> Property -checkInstances name (CommutativeTest checkType) = label name (checkType () - .&&. checkType (mempty :: Sum Integer) - .&&. checkType (mempty :: Product Integer) - .&&. checkType (mempty :: Dual (Sum Integer)) - .&&. checkType (mempty :: (Sum Integer, Sum Int)) - .&&. checkType (mempty :: IntSet) - .&&. checkType (mempty :: Set Integer)) -checkInstances name (NullTest checkType) = label name (checkType () - .&&. checkType (mempty :: Ordering) - .&&. checkType (mempty :: All) - .&&. 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) - .&&. checkType (mempty :: Concat Any) - .&&. checkType (mempty :: Concat String) - .&&. checkType (mempty :: Concat ByteString) - .&&. checkType (mempty :: Concat Text) - .&&. checkType (mempty :: Concat Lazy.Text) - .&&. checkType (mempty :: Concat (Dual String)) - .&&. checkType (mempty :: Concat (Maybe String)) - .&&. checkType (mempty :: Concat (Text, String)) - .&&. checkType (mempty :: Concat (IntMap Int)) - .&&. checkType (mempty :: Concat (Map String Int))) -checkInstances name (FactorialTest checkType) = label name (checkType () - .&&. 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) - .&&. checkType (mempty :: Concat String) - .&&. checkType (mempty :: Concat ByteString) - .&&. checkType (mempty :: Concat Text) - .&&. checkType (mempty :: Concat Lazy.Text) - .&&. checkType (mempty :: Concat (Dual ByteString)) - .&&. checkType (mempty :: Concat (Maybe String)) - .&&. checkType (mempty :: Concat (Text, String)) - .&&. checkType (mempty :: Concat (IntMap Int))) -checkInstances name (TextualTest checkType) = label name (checkType (mempty :: TestString) - .&&. checkType (mempty :: String) - .&&. checkType (mempty :: ByteStringUTF8) - .&&. checkType (mempty :: Text) - .&&. checkType (mempty :: Lazy.Text) - .&&. checkType (mempty :: Seq Char) - .&&. checkType (mempty :: Vector Char) - .&&. checkType (mempty :: Concat String) - .&&. checkType (mempty :: Concat Text) - .&&. checkType (mempty :: Concat Lazy.Text)) -checkInstances name (LeftReductiveTest checkType) = label name (checkType () - .&&. 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) - .&&. checkType (mempty :: Concat String) - .&&. checkType (mempty :: Concat ByteString) - .&&. checkType (mempty :: Concat Lazy.ByteString) - .&&. checkType (mempty :: Concat Text) - .&&. checkType (mempty :: Concat Lazy.Text) - .&&. checkType (mempty :: Concat (Dual Text))) -checkInstances name (RightReductiveTest checkType) = label name (checkType () - .&&. 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) - .&&. checkType (mempty :: Concat ByteString) - .&&. checkType (mempty :: Concat Lazy.ByteString) - .&&. checkType (mempty :: Concat Text) - .&&. checkType (mempty :: Concat Lazy.Text) - .&&. checkType (mempty :: Concat (Dual Text))) -checkInstances name (ReductiveTest checkType) = label name (checkType () - .&&. checkType (mempty :: Sum Integer) - .&&. checkType (mempty :: Product Integer) - .&&. checkType (mempty :: Dual (Sum Integer)) - .&&. checkType (mempty :: (Sum Integer, Sum Int)) - .&&. checkType (mempty :: IntSet) - .&&. checkType (mempty :: Set Integer)) -checkInstances name (LeftCancellativeTest checkType) = label name (checkType () - .&&. 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 () - .&&. 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 () - .&&. checkType (mempty :: Sum Integer) - .&&. checkType (mempty :: Dual (Sum Integer)) - .&&. checkType (mempty :: (Sum Integer, Sum Int))) -checkInstances name (LeftGCDTest checkType) = label name (checkType () - .&&. 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) - .&&. checkType (mempty :: Concat String) - .&&. checkType (mempty :: Concat ByteString) - .&&. checkType (mempty :: Concat Lazy.ByteString) - .&&. checkType (mempty :: Concat Text) - .&&. checkType (mempty :: Concat Lazy.Text) - .&&. checkType (mempty :: Concat (Dual ByteString))) -checkInstances name (RightGCDTest checkType) = label name (checkType () - .&&. 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) - .&&. checkType (mempty :: Concat ByteString) - .&&. checkType (mempty :: Concat Lazy.ByteString) - .&&. checkType (mempty :: Concat (Dual Text))) -checkInstances name (GCDTest checkType) = label name (checkType () - .&&. checkType (mempty :: Sum Integer) - .&&. checkType (mempty :: Product Integer) - .&&. checkType (mempty :: Dual (Product Integer)) - .&&. checkType (mempty :: (Sum Integer, Sum Int)) - .&&. checkType (mempty :: IntSet) - .&&. checkType (mempty :: Set String)) -checkInstances name (CancellativeGCDTest checkType) = label name (checkType () - .&&. checkType (mempty :: Sum Integer) - .&&. checkType (mempty :: Dual (Sum Integer)) - .&&. checkType (mempty :: (Sum Integer, Sum Int))) +checkInstances name (CommutativeTest checkType) = label name $ foldr1 (.&&.) (map checkType commutativeInstances) +checkInstances name (NullTest checkType) = label name $ foldr1 (.&&.) (map checkType nullInstances) +checkInstances name (PositiveTest checkType) = label name $ foldr1 (.&&.) (map checkType positiveInstances) +checkInstances name (FactorialTest checkType) = label name $ foldr1 (.&&.) (map checkType factorialInstances) +checkInstances name (StableFactorialTest checkType) = + label name $ foldr1 (.&&.) (map checkType stableFactorialInstances) +checkInstances name (TextualTest checkType) = label name $ foldr1 (.&&.) (map checkType textualInstances) +checkInstances name (LeftReductiveTest checkType) = label name $ foldr1 (.&&.) (map checkType leftReductiveInstances) +checkInstances name (RightReductiveTest checkType) = label name $ foldr1 (.&&.) (map checkType rightReductiveInstances) +checkInstances name (ReductiveTest checkType) = label name $ foldr1 (.&&.) (map checkType reductiveInstances) +checkInstances name (LeftCancellativeTest checkType) = + label name $ foldr1 (.&&.) (map checkType leftCancellativeInstances) +checkInstances name (RightCancellativeTest checkType) = + label name $ foldr1 (.&&.) (map checkType rightCancellativeInstances) +checkInstances name (CancellativeTest checkType) = label name $ foldr1 (.&&.) (map checkType cancellativeInstances) +checkInstances name (LeftGCDTest checkType) = label name $ foldr1 (.&&.) (map checkType leftGCDInstances) +checkInstances name (RightGCDTest checkType) = label name $ foldr1 (.&&.) (map checkType rightGCDInstances) +checkInstances name (GCDTest checkType) = label name $ foldr1 (.&&.) (map checkType gcdInstances) +checkInstances name (CancellativeGCDTest checkType) = + label name $ foldr1 (.&&.) (map checkType cancellativeGCDInstances) tests :: [(String, Test)] tests = [("CommutativeMonoid", CommutativeTest checkCommutative), ("MonoidNull", NullTest checkNull), + ("PositiveMonoid", PositiveTest checkPositive), ("mconcat . factors == id", FactorialTest checkConcatFactors), ("all factors . factors", FactorialTest checkFactorsOfFactors), ("splitPrimePrefix", FactorialTest checkSplitPrimePrefix), @@ -290,6 +339,7 @@ ("split", FactorialTest checkSplit), ("splitAt", FactorialTest checkSplitAt), ("reverse", FactorialTest checkReverse), + ("stable", StableFactorialTest checkStability), ("fromText", TextualTest checkFromText), ("singleton", TextualTest checkSingleton), ("Textual.splitCharacterPrefix", TextualTest checkSplitCharacterPrefix), @@ -332,280 +382,254 @@ ("cancellative gcd", CancellativeGCDTest checkCancellativeGCD) ] -checkCommutative :: forall a. (Arbitrary a, Show a, Eq a, CommutativeMonoid a) => a -> Property -checkCommutative e = forAll (arbitrary :: Gen (a, a)) (\(a, b)-> a <> b == b <> a) +checkCommutative (CommutativeMonoidInstance (e :: a)) = forAll (arbitrary :: Gen (a, a)) (\(a, b)-> a <> b == b <> a) -checkNull :: forall a. (Arbitrary a, Show a, Eq a, MonoidNull a) => a -> Property -checkNull e = null e .&&. forAll (arbitrary :: Gen a) (\a-> null a == (a == mempty)) +checkNull (NullMonoidInstance (e :: a)) = 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 +checkPositive (PositiveMonoidInstance (_ :: a)) = + forAll (arbitrary :: Gen (a, a)) (\(a, b)-> null a && null b || not (null (a <> b))) + +checkConcatFactors (FactorialMonoidInstance (e :: a)) = 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) +checkFactorsOfFactors (FactorialMonoidInstance (_ :: a)) = 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) +checkSplitPrimePrefix (FactorialMonoidInstance (_ :: a)) = + 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 +checkSplitPrimeSuffix (FactorialMonoidInstance (_ :: a)) = 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)) +checkPrimePrefix (FactorialMonoidInstance (_ :: a)) = + 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)) +checkPrimeSuffix (FactorialMonoidInstance (_ :: a)) = + 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 (FactorialMonoidInstance (_ :: a)) = + 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)) +checkLeftFold' (FactorialMonoidInstance (_ :: a)) = + 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)) +checkRightFold (FactorialMonoidInstance (_ :: a)) = + 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)) +checkLength (FactorialMonoidInstance (_ :: a)) = + 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) +checkSpan (FactorialMonoidInstance (_ :: a)) = 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 +checkSplit (FactorialMonoidInstance (_ :: a)) = 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) +checkSplitAt (FactorialMonoidInstance (_ :: a)) = 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)) +checkReverse (FactorialMonoidInstance (_ :: a)) = + 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)) +checkStability (StableFactorialMonoidInstance (_ :: a)) = + property $ forAll (arbitrary :: Gen (a, a)) (\(a, b)-> factors (a <> b) == factors a <> factors b) -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)) +checkFromText (TextualMonoidInstance (_ :: a)) = + forAll (arbitrary :: Gen Text) (\t-> Textual.fromText t == (fromString (Text.unpack t) :: a)) -checkSplitCharacterPrefix :: forall a. (Arbitrary a, CoArbitrary a, Show a, Eq a, TextualMonoid a) => a -> Property -checkSplitCharacterPrefix _ = forAll (arbitrary :: Gen String) check1 .&&. forAll (arbitrary :: Gen a) check2 +checkSingleton (TextualMonoidInstance (_ :: a)) = + forAll (arbitrary :: Gen Char) (\c-> Textual.singleton c == (fromString [c] :: 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) == 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 +checkCharacterPrefix (TextualMonoidInstance (_ :: a)) = 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 +checkTextualFactors (TextualMonoidInstance (_ :: a)) = 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 +checkUnfoldrToFactors (TextualMonoidInstance (_ :: a)) = 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 +checkFactorsFromString (TextualMonoidInstance (_ :: a)) = 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 +checkTextualMap (TextualMonoidInstance (_ :: a)) = + 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 +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 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 +checkAll (TextualMonoidInstance (_ :: a)) = 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 +checkAny (TextualMonoidInstance (_ :: a)) = 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 +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 :: 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 +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 (:) [] 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 +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 -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 +checkTextualScanl (TextualMonoidInstance (_ :: a)) = + 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 = min 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 +checkTextualScanr (TextualMonoidInstance (_ :: a)) = + 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 = min 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 +checkTextualScanl1 (TextualMonoidInstance (_ :: a)) = + 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 = min 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 +checkTextualScanr1 (TextualMonoidInstance (_ :: a)) = 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 = min 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 +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 :: 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 +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 :: 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 +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 :: 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 +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) && 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 +checkTextualSpan (TextualMonoidInstance (_ :: a)) = 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 +checkTextualBreak (TextualMonoidInstance (_ :: a)) = 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 +checkTextualSplit (TextualMonoidInstance (_ :: a)) = 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 +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 -checkStripPrefix :: forall a. (Arbitrary a, Show a, Eq a, LeftReductiveMonoid a) => a -> Property -checkStripPrefix _ = forAll (arbitrary :: Gen (a, a)) check +checkStripPrefix (LeftReductiveMonoidInstance (_ :: a)) = 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 +checkIsPrefixOf (LeftReductiveMonoidInstance (_ :: a)) = 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 +checkStripSuffix (RightReductiveMonoidInstance (_ :: a)) = 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 +checkIsSuffixOf (RightReductiveMonoidInstance (_ :: a)) = 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 +checkUnAppend (ReductiveMonoidInstance (_ :: a)) = 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 +checkStripPrefix' (LeftCancellativeMonoidInstance (_ :: a)) = 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 +checkStripSuffix' (RightCancellativeMonoidInstance (_ :: a)) = 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 +checkUnAppend' (CancellativeMonoidInstance (_ :: a)) = 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 +checkStripCommonPrefix1 (LeftGCDMonoidInstance (_ :: a)) = 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 +checkStripCommonPrefix2 (LeftGCDMonoidInstance (_ :: a)) = 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 +checkStripCommonSuffix1 (RightGCDMonoidInstance (_ :: a)) = 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 +checkStripCommonSuffix2 (RightGCDMonoidInstance (_ :: a)) = 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 +checkGCD (GCDMonoidInstance (_ :: a)) = 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 +checkCancellativeGCD (CancellativeGCDMonoidInstance (_ :: a)) = 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 @@ -617,7 +641,7 @@ newtype TestString = TestString String deriving (Eq, Show, Arbitrary, CoArbitrary, Monoid, LeftReductiveMonoid, LeftCancellativeMonoid, LeftGCDMonoid, - MonoidNull, IsString) + MonoidNull, PositiveMonoid, StableFactorialMonoid, IsString) instance FactorialMonoid TestString where splitPrimePrefix (TestString []) = Nothing @@ -655,8 +679,11 @@ arbitrary = fmap ByteStringUTF8 arbitrary instance (Arbitrary a, MonoidNull a, PositiveMonoid a) => Arbitrary (Concat a) where - arbitrary = fmap inject arbitrary + arbitrary = fmap Concat.inject arbitrary +instance (Arbitrary a, MonoidNull a, FactorialMonoid a) => Arbitrary (Measured a) where + arbitrary = fmap Measured.inject arbitrary + instance CoArbitrary All where coarbitrary (All p) = coarbitrary p @@ -685,7 +712,10 @@ coarbitrary (ByteStringUTF8 bs) = coarbitrary bs instance CoArbitrary a => CoArbitrary (Concat a) where - coarbitrary = coarbitrary . extract + coarbitrary = coarbitrary . Concat.extract + +instance CoArbitrary a => CoArbitrary (Measured a) where + coarbitrary = coarbitrary . Measured.extract instance Show a => Show (a -> Bool) where show _ = "predicate" diff --git a/monoid-subclasses.cabal b/monoid-subclasses.cabal --- a/monoid-subclasses.cabal +++ b/monoid-subclasses.cabal @@ -1,5 +1,5 @@ Name: monoid-subclasses -Version: 0.3.3 +Version: 0.3.4 Cabal-Version: >= 1.10 Build-Type: Simple Synopsis: Subclasses of Monoid @@ -22,7 +22,7 @@ Library Exposed-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null, Data.Monoid.Textual, - Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.Concat + Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.Concat, Data.Monoid.Instances.Measured Build-Depends: base < 5, bytestring >= 0.9 && < 1.0, containers == 0.5.*, text == 0.11.*, primes == 0.2.*, vector >= 0.9 && < 0.11 GHC-prof-options: -auto-all @@ -37,5 +37,5 @@ test-framework >= 0.4.1, test-framework-quickcheck2 Main-is: Test/TestMonoidSubclasses.hs Other-Modules: Data.Monoid.Cancellative, Data.Monoid.Factorial, Data.Monoid.Null, Data.Monoid.Textual, - Data.Monoid.Instances.ByteString.UTF8 + Data.Monoid.Instances.ByteString.UTF8, Data.Monoid.Instances.Concat, Data.Monoid.Instances.Measured default-language: Haskell2010