{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Semiring ( #if HAVE_SEMIRINGS semiringLaws #endif ) where #if HAVE_SEMIRINGS import Data.Semiring hiding (fromInteger) import Prelude hiding (Num(..)) import Prelude (fromInteger) #endif import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Internal (Laws(..), myForAllShrink) #if HAVE_SEMIRINGS -- | Tests the following properties: -- -- [/Additive Commutativity/] -- @a + b ≡ b + a@ -- [/Additive Left Identity/] -- @0 + a ≡ a@ -- [/Additive Right Identity/] -- @a + 0 ≡ a@ -- [/Multiplicative Associativity/] -- @a * (b * c) ≡ (a * b) * c@ -- [/Multiplicative Left Identity/] -- @1 * a ≡ a@ -- [/Multiplicative Right Identity/] -- @a * 1 ≡ a@ -- [/Multiplication Left Distributes Over Addition/] -- @a * (b + c) ≡ (a * b) + (a * c)@ -- [/Multiplication Right Distributes Over Addition/] -- @(a + b) * c ≡ (a * c) + (b * c)@ -- [/Multiplicative Left Annihilation/] -- @0 * a ≡ 0@ -- [/Multiplicative Right Annihilation/] -- @a * 0 ≡ 0@ -- -- Also tests that 'fromNatural' is a homomorphism of semirings: -- -- [/FromNatural Maps Zero/] -- 'fromNatural' 0 = 'zero' -- [/FromNatural Maps One/] -- 'fromNatural' 1 = 'one' -- [/FromNatural Maps Plus/] -- 'fromNatural' (@a@ + @b@) = 'fromNatural' @a@ + 'fromNatural' @b@ -- [/FromNatural Maps Times/] -- 'fromNatural' (@a@ * @b@) = 'fromNatural' @a@ * 'fromNatural' @b@ semiringLaws :: (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws semiringLaws p = Laws "Semiring" [ ("Additive Commutativity", semiringCommutativePlus p) , ("Additive Left Identity", semiringLeftIdentityPlus p) , ("Additive Right Identity", semiringRightIdentityPlus p) , ("Multiplicative Associativity", semiringAssociativeTimes p) , ("Multiplicative Left Identity", semiringLeftIdentityTimes p) , ("Multiplicative Right Identity", semiringRightIdentityTimes p) , ("Multiplication Left Distributes Over Addition", semiringLeftMultiplicationDistributes p) , ("Multiplication Right Distributes Over Addition", semiringRightMultiplicationDistributes p) , ("Multiplicative Left Annihilation", semiringLeftAnnihilation p) , ("Multiplicative Right Annihilation", semiringRightAnnihilation p) , ("FromNatural Maps Zero", semiringFromNaturalMapsZero p) , ("FromNatural Maps One", semiringFromNaturalMapsOne p) , ("FromNatural Maps Plus", semiringFromNaturalMapsPlus p) , ("FromNatural Maps Times", semiringFromNaturalMapsTimes p) ] semiringLeftMultiplicationDistributes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringLeftMultiplicationDistributes _ = myForAllShrink True (const True) (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) "a * (b + c)" (\(a,b,c) -> a * (b + c)) "(a * b) + (a * c)" (\(a,b,c) -> (a * b) + (a * c)) semiringRightMultiplicationDistributes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringRightMultiplicationDistributes _ = myForAllShrink True (const True) (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) "(a + b) * c" (\(a,b,c) -> (a + b) * c) "(a * c) + (b * c)" (\(a,b,c) -> (a * c) + (b * c)) semiringLeftIdentityPlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringLeftIdentityPlus _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "0 + a" (\a -> zero + a) "a" (\a -> a) semiringRightIdentityPlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringRightIdentityPlus _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "a + 0" (\a -> a + zero) "a" (\a -> a) semiringRightIdentityTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringRightIdentityTimes _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "a * 1" (\a -> a * one) "a" (\a -> a) semiringLeftIdentityTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringLeftIdentityTimes _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "1 * a" (\a -> one * a) "a" (\a -> a) semiringLeftAnnihilation :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringLeftAnnihilation _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "0 * a" (\a -> zero * a) "0" (\_ -> zero) semiringRightAnnihilation :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringRightAnnihilation _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "a * 0" (\a -> a * zero) "0" (\_ -> zero) semiringCommutativePlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringCommutativePlus _ = myForAllShrink True (const True) (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) "a + b" (\(a,b) -> a + b) "b + a" (\(a,b) -> b + a) semiringAssociativeTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringAssociativeTimes _ = myForAllShrink True (const True) (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) "a * (b * c)" (\(a,b,c) -> a * (b * c)) "(a * b) * c" (\(a,b,c) -> (a * b) * c) semiringFromNaturalMapsZero :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringFromNaturalMapsZero _ = myForAllShrink False (const True) (\_ -> [""]) "fromNatural 0" (\() -> fromNatural 0 :: a) "zero" (\() -> zero) semiringFromNaturalMapsOne :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringFromNaturalMapsOne _ = myForAllShrink False (const True) (\_ -> [""]) "fromNatural 1" (\() -> fromNatural 1 :: a) "one" (\() -> one) -- | There is no Arbitrary instance for Natural in QuickCheck, -- so we use NonNegative Integer instead. semiringFromNaturalMapsPlus :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringFromNaturalMapsPlus _ = myForAllShrink True (const True) (\(NonNegative a, NonNegative b) -> ["a = " ++ show a, "b = " ++ show b]) "fromNatural (a + b)" (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger (a + b)) :: a) "fromNatural a + fromNatural b" (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger a) + fromNatural (fromInteger b)) semiringFromNaturalMapsTimes :: forall a. (Semiring a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semiringFromNaturalMapsTimes _ = myForAllShrink True (const True) (\(NonNegative a, NonNegative b) -> ["a = " ++ show a, "b = " ++ show b]) "fromNatural (a * b)" (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger (a * b)) :: a) "fromNatural a * fromNatural b" (\(NonNegative a, NonNegative b) -> fromNatural (fromInteger a) * fromNatural (fromInteger b)) #endif