{-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Copyright: © 2022–2023 Jonathan Knowles -- License: Apache-2.0 -- module ClassSpec where import Data.ByteString.Lazy ( ByteString ) import Data.IntMap.Strict ( IntMap ) import Data.Map.Strict ( Map ) import Data.Monoid ( Product (..), Sum (..) ) import Data.Monoid.GCD ( GCDMonoid, LeftGCDMonoid, OverlappingGCDMonoid, RightGCDMonoid ) import Data.Monoid.Monus ( Monus ) import Data.Monoid.Null ( MonoidNull, PositiveMonoid ) import Data.Semigroup.Cancellative ( Cancellative , Commutative , LeftCancellative , LeftReductive , Reductive , RightCancellative , RightReductive , SumCancellative ) import Data.Sequence ( Seq ) import Data.Set ( Set ) import Data.Text ( Text ) import Data.Vector ( Vector ) import Numeric.Natural ( Natural ) import Numeric.Product.Commutative ( CommutativeProduct ) import Test.Hspec ( Spec ) import Test.Hspec.Laws ( testLawsMany ) import Test.QuickCheck ( Arbitrary (..) , Confidence , Property , arbitrarySizedIntegral , scale , shrinkMap ) import Test.QuickCheck.Classes ( Laws (..) ) import Test.QuickCheck.Classes.Monoid.GCD ( cancellativeGCDMonoidLaws , gcdMonoidLaws , leftGCDMonoidLaws , overlappingGCDMonoidLaws , rightGCDMonoidLaws ) import Test.QuickCheck.Classes.Monoid.LCM ( lcmMonoidLaws ) import Test.QuickCheck.Classes.Monoid.Monus ( monusLaws ) import Test.QuickCheck.Classes.Monoid.Null ( monoidNullLaws, positiveMonoidLaws ) import Test.QuickCheck.Classes.Semigroup.Cancellative ( cancellativeLaws , commutativeLaws , leftCancellativeLaws , leftReductiveLaws , reductiveLaws , rightCancellativeLaws , rightReductiveLaws ) import Test.QuickCheck.Instances.ByteString () import Test.QuickCheck.Instances.Natural () import Test.QuickCheck.Instances.Text () import Test.QuickCheck.Instances.Vector () import Test.QuickCheck.Property ( Result (..), mapTotalResult ) spec :: Spec spec = do testLawsMany @() $ fmap disableCoverageCheck <$> [ cancellativeGCDMonoidLaws , cancellativeLaws , commutativeLaws , gcdMonoidLaws , lcmMonoidLaws , leftCancellativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , monusLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , reductiveLaws , rightCancellativeLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @ByteString [ leftCancellativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , rightCancellativeLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @Text [ leftCancellativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , rightCancellativeLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @[SmallInt] [ leftCancellativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , rightCancellativeLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @(Seq SmallInt) [ leftCancellativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , rightCancellativeLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @(Set SmallInt) [ commutativeLaws , gcdMonoidLaws , leftGCDMonoidLaws , leftReductiveLaws , lcmMonoidLaws , monoidNullLaws , monusLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , reductiveLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @(Set Natural) [ commutativeLaws , gcdMonoidLaws , leftGCDMonoidLaws , leftReductiveLaws , lcmMonoidLaws , monoidNullLaws , monusLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , reductiveLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @(Product SmallInt) [ commutativeLaws , leftReductiveLaws , monoidNullLaws , reductiveLaws , rightReductiveLaws ] testLawsMany @(Product Natural) [ commutativeLaws , gcdMonoidLaws , lcmMonoidLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , monusLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , reductiveLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @(Sum SmallInt) [ cancellativeLaws , commutativeLaws , leftCancellativeLaws , leftReductiveLaws , monoidNullLaws , reductiveLaws , rightCancellativeLaws , rightReductiveLaws ] testLawsMany @(Sum Natural) [ cancellativeGCDMonoidLaws , cancellativeLaws , commutativeLaws , gcdMonoidLaws , lcmMonoidLaws , leftCancellativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , monusLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , reductiveLaws , rightCancellativeLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @(IntMap SmallInt) [ leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , rightReductiveLaws ] testLawsMany @(IntMap Natural) [ leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , rightReductiveLaws ] testLawsMany @(Map Int SmallInt) [ leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , rightReductiveLaws ] testLawsMany @(Map Int Natural) [ leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , rightReductiveLaws ] testLawsMany @(Maybe ()) $ fmap disableCoverageCheck <$> [ commutativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , monusLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , reductiveLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @(Maybe (Product SmallInt)) [ commutativeLaws , leftReductiveLaws , monoidNullLaws , positiveMonoidLaws , reductiveLaws , rightReductiveLaws ] testLawsMany @(Maybe (Product Natural)) [ commutativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , monusLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , reductiveLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @(Maybe (Sum SmallInt)) [ commutativeLaws , leftReductiveLaws , monoidNullLaws , positiveMonoidLaws , reductiveLaws , rightReductiveLaws ] testLawsMany @(Maybe (Sum Natural)) [ commutativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , monusLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , reductiveLaws , rightGCDMonoidLaws , rightReductiveLaws ] testLawsMany @(Vector SmallInt) [ leftCancellativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , rightCancellativeLaws , rightGCDMonoidLaws , rightReductiveLaws ] -------------------------------------------------------------------------------- -- Notes -------------------------------------------------------------------------------- {- All laws tested in this module: [ cancellativeGCDMonoidLaws , cancellativeLaws , commutativeLaws , gcdMonoidLaws , lcmMonoidLaws , leftCancellativeLaws , leftGCDMonoidLaws , leftReductiveLaws , monoidNullLaws , monusLaws , overlappingGCDMonoidLaws , positiveMonoidLaws , reductiveLaws , rightCancellativeLaws , rightGCDMonoidLaws , rightReductiveLaws ] -} -------------------------------------------------------------------------------- -- Utility types -------------------------------------------------------------------------------- type SmallInt = Small Int newtype Small a = Small {getSmall :: a} deriving newtype ( Cancellative , Commutative , CommutativeProduct , Enum , Eq , GCDMonoid , Integral , LeftCancellative , LeftGCDMonoid , LeftReductive , Monoid , MonoidNull , Monus , Num , Ord , OverlappingGCDMonoid , PositiveMonoid , Real , Reductive , RightCancellative , RightGCDMonoid , RightReductive , Semigroup , Show , SumCancellative ) instance Arbitrary a => Arbitrary (Small a) where arbitrary = Small <$> scale (`div` 2) arbitrary shrink = shrinkMap Small getSmall -------------------------------------------------------------------------------- -- Coverage checks -------------------------------------------------------------------------------- class HasCoverageCheck p where disableCoverageCheck :: p -> p instance HasCoverageCheck Laws where disableCoverageCheck = mapLawsProperties disableCoverageCheck instance HasCoverageCheck Property where disableCoverageCheck = mapPropertyCheckCoverage (const Nothing) mapLawsProperties :: (Property -> Property) -> Laws -> Laws mapLawsProperties f (Laws t ps) = Laws t $ fmap f <$> ps mapPropertyCheckCoverage :: (Maybe Confidence -> Maybe Confidence) -> Property -> Property mapPropertyCheckCoverage f = mapTotalResult $ \r -> r {maybeCheckCoverage = f (maybeCheckCoverage r)}