{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_HADDOCK hide #-} -- | This module is exported, but it is not part of the stable -- public API and is not subject to PVP. It is used by other -- modules in @quickcheck-classes-base@ and by modules in the -- @quickcheck-classes@ library as well. Functions and types -- in this module are either auxiliary functions that are reused -- by many different laws tests, or they are compatibility shims -- that make it possible to build with older versions GHC and -- transformers. module Test.QuickCheck.Classes.Internal ( -- * Common Types and Functions Laws(..) , foldMapA , myForAllShrink -- Modifiers , SmallList(..) , VerySmallList(..) , ShowReadPrecedence(..) -- only used for higher-kinded types , Apply(..) #if HAVE_BINARY_LAWS , Apply2(..) #endif , Triple(..) , ChooseFirst(..) , ChooseSecond(..) , LastNothing(..) , Bottom(..) , LinearEquation(..) #if HAVE_UNARY_LAWS , LinearEquationM(..) #endif , QuadraticEquation(..) , LinearEquationTwo(..) #if HAVE_UNARY_LAWS , nestedEq1 , propNestedEq1 , toSpecialApplicative #endif , flipPair #if HAVE_UNARY_LAWS , apTrans #endif , func1 , func2 , func3 #if HAVE_UNARY_LAWS , func4 #endif , func5 , func6 , reverseTriple , runLinearEquation #if HAVE_UNARY_LAWS , runLinearEquationM #endif , runQuadraticEquation , runLinearEquationTwo -- * Compatibility Shims , isTrue# #if HAVE_UNARY_LAWS , eq1 #endif #if HAVE_BINARY_LAWS , eq2 , eq1_2 #endif , readMaybe ) where import Control.Applicative import Control.Monad import Data.Foldable import Data.Traversable import Data.Monoid #if defined(HAVE_UNARY_LAWS) import Data.Functor.Classes (Eq1(..),Show1(..),showsPrec1) import Data.Functor.Compose #endif #if defined(HAVE_BINARY_LAWS) import Data.Functor.Classes (Eq2(..),Show2(..),showsPrec2) #endif import Data.Semigroup (Semigroup) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property(..)) import qualified Control.Monad.Trans.Writer.Lazy as WL import qualified Data.List as L import qualified Data.Monoid as MND import qualified Data.Semigroup as SG import qualified Data.Set as S #if MIN_VERSION_base(4,6,0) import Text.Read (readMaybe) #else import Text.ParserCombinators.ReadP (skipSpaces) import Text.ParserCombinators.ReadPrec (lift, minPrec, readPrec_to_S) import Text.Read (readPrec) #endif #if MIN_VERSION_base(4,7,0) import GHC.Exts (isTrue#) #endif #if defined(HAVE_UNARY_LAWS) || defined(HAVE_BINARY_LAWS) import qualified Data.Functor.Classes as C #endif -- | A set of laws associated with a typeclass. -- -- /Note/: Most of the top-level functions provided -- by this library have the shape -- `forall a. (Ctx a) => Proxy a -> Laws`. You can just -- as easily provide your own `Laws` in libraries/test suites -- using regular QuickCheck machinery. data Laws = Laws { lawsTypeclass :: String -- ^ Name of the typeclass whose laws are tested , lawsProperties :: [(String,Property)] -- ^ Pairs of law name and property } myForAllShrink :: (Arbitrary a, Show b, Eq b) => Bool -- Should we show the RHS. It's better not to show it -- if the RHS is equal to the input. -> (a -> Bool) -- is the value a valid input -> (a -> [String]) -- show the 'a' values -> String -- show the LHS -> (a -> b) -- the function that makes the LHS -> String -- show the RHS -> (a -> b) -- the function that makes the RHS -> Property myForAllShrink displayRhs isValid showInputs name1 calc1 name2 calc2 = #if MIN_VERSION_QuickCheck(2,9,0) again $ #endif MkProperty $ arbitrary >>= \x -> unProperty $ shrinking shrink x $ \x' -> let b1 = calc1 x' b2 = calc2 x' sb1 = show b1 sb2 = show b2 description = " Description: " ++ name1 ++ " = " ++ name2 err = description ++ "\n" ++ unlines (map (" " ++) (showInputs x')) ++ " " ++ name1 ++ " = " ++ sb1 ++ (if displayRhs then "\n " ++ name2 ++ " = " ++ sb2 else "") in isValid x' ==> counterexample err (b1 == b2) #if HAVE_UNARY_LAWS -- the Functor constraint is needed for transformers-0.4 #if HAVE_QUANTIFIED_CONSTRAINTS nestedEq1 :: (forall x. Eq x => Eq (f x), forall x. Eq x => Eq (g x), Eq a) => f (g a) -> f (g a) -> Bool nestedEq1 = (==) #else nestedEq1 :: (Eq1 f, Eq1 g, Eq a, Functor f) => f (g a) -> f (g a) -> Bool nestedEq1 x y = C.eq1 (Compose x) (Compose y) #endif #if HAVE_QUANTIFIED_CONSTRAINTS propNestedEq1 :: (forall x. Eq x => Eq (f x), forall x. Eq x => Eq (g x), Eq a, forall x. Show x => Show (f x), forall x. Show x => Show (g x), Show a) => f (g a) -> f (g a) -> Property propNestedEq1 = (===) #else propNestedEq1 :: (Eq1 f, Eq1 g, Eq a, Show1 f, Show1 g, Show a, Functor f) => f (g a) -> f (g a) -> Property propNestedEq1 x y = Compose x === Compose y #endif toSpecialApplicative :: Compose Triple ((,) (S.Set Integer)) Integer -> Compose Triple (WL.Writer (S.Set Integer)) Integer toSpecialApplicative (Compose (Triple a b c)) = Compose (Triple (WL.writer (flipPair a)) (WL.writer (flipPair b)) (WL.writer (flipPair c))) #endif flipPair :: (a,b) -> (b,a) flipPair (x,y) = (y,x) #if HAVE_UNARY_LAWS -- Reverse the list and accumulate the writers. We cannot -- use Sum or Product or else it wont actually be a valid -- applicative transformation. apTrans :: Compose Triple (WL.Writer (S.Set Integer)) a -> Compose (WL.Writer (S.Set Integer)) Triple a apTrans (Compose xs) = Compose (sequenceA (reverseTriple xs)) #endif func1 :: Integer -> (Integer,Integer) func1 i = (div (i + 5) 3, i * i - 2 * i + 1) func2 :: (Integer,Integer) -> (Bool,Either Ordering Integer) func2 (a,b) = (odd a, if even a then Left (compare a b) else Right (b + 2)) func3 :: Integer -> SG.Sum Integer func3 i = SG.Sum (3 * i * i - 7 * i + 4) #if HAVE_UNARY_LAWS func4 :: Integer -> Compose Triple (WL.Writer (S.Set Integer)) Integer func4 i = Compose $ Triple (WL.writer (i * i, S.singleton (i * 7 + 5))) (WL.writer (i + 2, S.singleton (i * i + 3))) (WL.writer (i * 7, S.singleton 4)) #endif func5 :: Integer -> Triple Integer func5 i = Triple (i + 2) (i * 3) (i * i) func6 :: Integer -> Triple Integer func6 i = Triple (i * i * i) (4 * i - 7) (i * i * i) data Triple a = Triple a a a deriving (Show,Eq) tripleLiftEq :: (a -> b -> Bool) -> Triple a -> Triple b -> Bool tripleLiftEq p (Triple a1 b1 c1) (Triple a2 b2 c2) = p a1 a2 && p b1 b2 && p c1 c2 #if HAVE_UNARY_LAWS instance Eq1 Triple where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftEq = tripleLiftEq #else eq1 = tripleLiftEq (==) #endif #endif tripleLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Triple a -> ShowS tripleLiftShowsPrec elemShowsPrec _ p (Triple a b c) = showParen (p > 10) $ showString "Triple " . elemShowsPrec 11 a . showString " " . elemShowsPrec 11 b . showString " " . elemShowsPrec 11 c #if HAVE_UNARY_LAWS instance Show1 Triple where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftShowsPrec = tripleLiftShowsPrec #else showsPrec1 = tripleLiftShowsPrec showsPrec showList #endif #endif #if HAVE_UNARY_LAWS instance Arbitrary1 Triple where liftArbitrary x = Triple <$> x <*> x <*> x instance Arbitrary a => Arbitrary (Triple a) where arbitrary = liftArbitrary arbitrary #else instance Arbitrary a => Arbitrary (Triple a) where arbitrary = Triple <$> arbitrary <*> arbitrary <*> arbitrary #endif instance Functor Triple where fmap f (Triple a b c) = Triple (f a) (f b) (f c) instance Applicative Triple where pure a = Triple a a a Triple f g h <*> Triple a b c = Triple (f a) (g b) (h c) instance Foldable Triple where foldMap f (Triple a b c) = f a MND.<> f b MND.<> f c instance Traversable Triple where traverse f (Triple a b c) = Triple <$> f a <*> f b <*> f c reverseTriple :: Triple a -> Triple a reverseTriple (Triple a b c) = Triple c b a data ChooseSecond = ChooseSecond deriving (Eq) data ChooseFirst = ChooseFirst deriving (Eq) data LastNothing = LastNothing deriving (Eq) data Bottom a = BottomUndefined | BottomValue a deriving (Eq) instance Show ChooseFirst where show ChooseFirst = "\\a b -> if even a then a else b" instance Show ChooseSecond where show ChooseSecond = "\\a b -> if even b then a else b" instance Show LastNothing where show LastNothing = "0" instance Show a => Show (Bottom a) where show x = case x of BottomUndefined -> "undefined" BottomValue a -> show a instance Arbitrary ChooseSecond where arbitrary = pure ChooseSecond instance Arbitrary ChooseFirst where arbitrary = pure ChooseFirst instance Arbitrary LastNothing where arbitrary = pure LastNothing instance Arbitrary a => Arbitrary (Bottom a) where arbitrary = fmap maybeToBottom arbitrary shrink x = map maybeToBottom (shrink (bottomToMaybe x)) bottomToMaybe :: Bottom a -> Maybe a bottomToMaybe BottomUndefined = Nothing bottomToMaybe (BottomValue a) = Just a maybeToBottom :: Maybe a -> Bottom a maybeToBottom Nothing = BottomUndefined maybeToBottom (Just a) = BottomValue a newtype Apply f a = Apply { getApply :: f a } instance (Applicative f, Monoid a) => Semigroup (Apply f a) where Apply x <> Apply y = Apply $ liftA2 mappend x y instance (Applicative f, Monoid a) => Monoid (Apply f a) where mempty = Apply $ pure mempty mappend = (SG.<>) #if HAVE_UNARY_LAWS #if HAVE_QUANTIFIED_CONSTRAINTS deriving instance (forall x. Eq x => Eq (f x), Eq a) => Eq (Apply f a) deriving instance (forall x. Arbitrary x => Arbitrary (f x), Arbitrary a) => Arbitrary (Apply f a) deriving instance (forall x. Show x => Show (f x), Show a) => Show (Apply f a) #else instance (Eq1 f, Eq a) => Eq (Apply f a) where Apply a == Apply b = eq1 a b -- This show instance is intentionally a little bit wrong. -- We don't wrap the result in Apply since the end user -- should not be made aware of the Apply wrapper anyway. instance (Show1 f, Show a) => Show (Apply f a) where showsPrec p = showsPrec1 p . getApply instance (Arbitrary1 f, Arbitrary a) => Arbitrary (Apply f a) where arbitrary = fmap Apply arbitrary1 shrink = map Apply . shrink1 . getApply #endif #endif foldMapA :: (Foldable t, Monoid m, Semigroup m, Applicative f) => (a -> f m) -> t a -> f m foldMapA f = getApply . foldMap (Apply . f) #if HAVE_BINARY_LAWS newtype Apply2 f a b = Apply2 { getApply2 :: f a b } #if HAVE_QUANTIFIED_CONSTRAINTS deriving instance (forall x y. (Eq x, Eq y) => Eq (f x y), Eq a, Eq b) => Eq (Apply2 f a b) deriving instance (forall x y. (Arbitrary x, Arbitrary y) => Arbitrary (f x y), Arbitrary a, Arbitrary b) => Arbitrary (Apply2 f a b) deriving instance (forall x y. (Show x, Show y) => Show (f x y), Show a, Show b) => Show (Apply2 f a b) #else instance (Eq2 f, Eq a, Eq b) => Eq (Apply2 f a b) where Apply2 a == Apply2 b = C.eq2 a b instance (Show2 f, Show a, Show b) => Show (Apply2 f a b) where showsPrec p = showsPrec2 p . getApply2 instance (Arbitrary2 f, Arbitrary a, Arbitrary b) => Arbitrary (Apply2 f a b) where arbitrary = fmap Apply2 arbitrary2 shrink = fmap Apply2 . shrink2 . getApply2 #endif #endif data LinearEquation = LinearEquation { _linearEquationLinear :: Integer , _linearEquationConstant :: Integer } deriving (Eq) instance Show LinearEquation where showsPrec = showLinear showList = showLinearList runLinearEquation :: LinearEquation -> Integer -> Integer runLinearEquation (LinearEquation a b) x = a * x + b showLinear :: Int -> LinearEquation -> ShowS showLinear _ (LinearEquation a b) = shows a . showString " * x + " . shows b showLinearList :: [LinearEquation] -> ShowS showLinearList xs = SG.appEndo $ mconcat $ [SG.Endo (showChar '[')] ++ L.intersperse (SG.Endo (showChar ',')) (map (SG.Endo . showLinear 0) xs) ++ [SG.Endo (showChar ']')] #if HAVE_UNARY_LAWS data LinearEquationM m = LinearEquationM (m LinearEquation) (m LinearEquation) runLinearEquationM :: Monad m => LinearEquationM m -> Integer -> m Integer runLinearEquationM (LinearEquationM e1 e2) i = if odd i then liftM (flip runLinearEquation i) e1 else liftM (flip runLinearEquation i) e2 #if HAVE_QUANTIFIED_CONSTRAINTS deriving instance (forall x. Eq x => Eq (m x)) => Eq (LinearEquationM m) instance (forall a. Show a => Show (m a)) => Show (LinearEquationM m) where show (LinearEquationM a b) = (\f -> f "") $ showString "\\x -> if odd x then " . showsPrec 0 a . showString " else " . showsPrec 0 b instance (forall a. Arbitrary a => Arbitrary (m a)) => Arbitrary (LinearEquationM m) where arbitrary = liftA2 LinearEquationM arbitrary arbitrary shrink (LinearEquationM a b) = L.concat [ map (\x -> LinearEquationM x b) (shrink a) , map (\x -> LinearEquationM a x) (shrink b) ] #else instance Eq1 m => Eq (LinearEquationM m) where LinearEquationM a1 b1 == LinearEquationM a2 b2 = eq1 a1 a2 && eq1 b1 b2 instance Show1 m => Show (LinearEquationM m) where show (LinearEquationM a b) = (\f -> f "") $ showString "\\x -> if odd x then " . showsPrec1 0 a . showString " else " . showsPrec1 0 b instance Arbitrary1 m => Arbitrary (LinearEquationM m) where arbitrary = liftA2 LinearEquationM arbitrary1 arbitrary1 shrink (LinearEquationM a b) = L.concat [ map (\x -> LinearEquationM x b) (shrink1 a) , map (\x -> LinearEquationM a x) (shrink1 b) ] #endif #endif instance Arbitrary LinearEquation where arbitrary = do (a,b) <- arbitrary return (LinearEquation (abs a) (abs b)) shrink (LinearEquation a b) = let xs = shrink (a,b) in map (\(x,y) -> LinearEquation (abs x) (abs y)) xs -- this is a quadratic equation data QuadraticEquation = QuadraticEquation { _quadraticEquationQuadratic :: Integer , _quadraticEquationLinear :: Integer , _quadraticEquationConstant :: Integer } deriving (Eq) -- This show instance is does not actually provide a -- way to create an equation. Instead, it makes it look -- like a lambda. instance Show QuadraticEquation where show (QuadraticEquation a b c) = "\\x -> " ++ show a ++ " * x ^ 2 + " ++ show b ++ " * x + " ++ show c instance Arbitrary QuadraticEquation where arbitrary = do (a,b,c) <- arbitrary return (QuadraticEquation (abs a) (abs b) (abs c)) shrink (QuadraticEquation a b c) = let xs = shrink (a,b,c) in map (\(x,y,z) -> QuadraticEquation (abs x) (abs y) (abs z)) xs runQuadraticEquation :: QuadraticEquation -> Integer -> Integer runQuadraticEquation (QuadraticEquation a b c) x = a * x ^ (2 :: Integer) + b * x + c data LinearEquationTwo = LinearEquationTwo { _linearEquationTwoX :: Integer , _linearEquationTwoY :: Integer } deriving (Eq) -- This show instance does not actually provide a -- way to create a LinearEquationTwo. Instead, it makes it look -- like a lambda that takes two variables. instance Show LinearEquationTwo where show (LinearEquationTwo a b) = "\\x y -> " ++ show a ++ " * x + " ++ show b ++ " * y" instance Arbitrary LinearEquationTwo where arbitrary = do (a,b) <- arbitrary return (LinearEquationTwo (abs a) (abs b)) shrink (LinearEquationTwo a b) = let xs = shrink (a,b) in map (\(x,y) -> LinearEquationTwo (abs x) (abs y)) xs runLinearEquationTwo :: LinearEquationTwo -> Integer -> Integer -> Integer runLinearEquationTwo (LinearEquationTwo a b) x y = a * x + b * y newtype SmallList a = SmallList { getSmallList :: [a] } deriving (Eq,Show) instance Arbitrary a => Arbitrary (SmallList a) where arbitrary = do n <- choose (0,6) xs <- vector n return (SmallList xs) shrink = map SmallList . shrink . getSmallList newtype VerySmallList a = VerySmallList { getVerySmallList :: [a] } deriving (Eq, Show, Semigroup, Monoid) instance Arbitrary a => Arbitrary (VerySmallList a) where arbitrary = do n <- choose (0,2) xs <- vector n return (VerySmallList xs) shrink = map VerySmallList . shrink . getVerySmallList -- Haskell uses the operator precedences 0..9, the special function application -- precedence 10 and the precedence 11 for function arguments. Both show and -- read instances have to accept this range. According to the Haskell Language -- Report, the output of derived show instances in precedence context 11 has to -- be an atomic expression. showReadPrecedences :: [Int] showReadPrecedences = [0..11] newtype ShowReadPrecedence = ShowReadPrecedence Int deriving (Eq,Ord,Show) instance Arbitrary ShowReadPrecedence where arbitrary = ShowReadPrecedence <$> elements showReadPrecedences shrink (ShowReadPrecedence p) = [ ShowReadPrecedence p' | p' <- showReadPrecedences, p' < p ] #if !MIN_VERSION_base(4,6,0) readMaybe :: Read a => String -> Maybe a readMaybe s = case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of [x] -> Just x _ -> Nothing where read' = do x <- readPrec lift skipSpaces return x #endif #if !MIN_VERSION_base(4,7,0) isTrue# :: Bool -> Bool isTrue# b = b #endif #if HAVE_UNARY_LAWS #if HAVE_QUANTIFIED_CONSTRAINTS eq1 :: (forall x. Eq x => Eq (f x), Eq a) => f a -> f a -> Bool eq1 = (==) #else eq1 :: (C.Eq1 f, Eq a) => f a -> f a -> Bool eq1 = C.eq1 #endif #endif #if HAVE_UNARY_LAWS #if HAVE_QUANTIFIED_CONSTRAINTS eq1_2 :: (forall a. Eq a => Eq (f a), forall a b. (Eq a, Eq b) => Eq (g a b), Eq x, Eq y) => f (g x y) -> f (g x y) -> Bool eq1_2 = (==) #else eq1_2 :: (C.Eq1 f, C.Eq2 g, Eq a, Eq b) => f (g a b) -> f (g a b) -> Bool eq1_2 = C.liftEq C.eq2 #endif #endif #if HAVE_BINARY_LAWS #if HAVE_QUANTIFIED_CONSTRAINTS eq2 :: (forall a. (Eq a, Eq b) => Eq (f a b), Eq a, Eq b) => f a b -> f a b -> Bool eq2 = (==) #else eq2 :: (C.Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool eq2 = C.eq2 #endif #endif