Simplify quickcheck-classes tests for Stack

We don't need the compat hacks for GHC 8.4.
This commit is contained in:
Tomas Janousek 2021-04-03 15:17:25 +01:00
parent 910d99cb74
commit 6c5204b91c
2 changed files with 10 additions and 38 deletions

View File

@ -12,11 +12,11 @@ import qualified XMonad.StackSet as S (filter)
import Data.Maybe import Data.Maybe
#ifdef VERSION_quickcheck_classes #ifdef VERSION_quickcheck_classes
import Data.Proxy
import Test.QuickCheck.Classes ( import Test.QuickCheck.Classes (
Laws (lawsTypeclass, lawsProperties), Proxy1 (Proxy1), Laws (lawsTypeclass, lawsProperties), Proxy1 (Proxy1),
foldableLaws, traversableLaws, foldableLaws, traversableLaws,
) )
import Data.Functor.Classes (Eq1 (liftEq), Show1 (liftShowsPrec))
#endif #endif
@ -66,47 +66,18 @@ prop_differentiate xs =
newtype TestStack a = TestStack (Stack a) newtype TestStack a = TestStack (Stack a)
deriving (Eq, Read, Show, Foldable, Functor) deriving (Eq, Read, Show, Foldable, Functor)
instance Arbitrary1 TestStack where instance (Arbitrary a) => Arbitrary (TestStack a) where
liftArbitrary gen = arbitrary = TestStack <$> (Stack <$> arbitrary <*> arbitrary <*> arbitrary)
(\ x xu xd -> TestStack (Stack x xu xd)) shrink = traverse shrink
<$> gen
<*> liftArbitrary gen
<*> liftArbitrary gen
instance (Arbitrary a)=> Arbitrary (TestStack a) where
arbitrary = arbitrary1
shrink = shrink1
instance Traversable TestStack where instance Traversable TestStack where
traverse f (TestStack sx) = fmap TestStack (traverse f sx) traverse f (TestStack sx) = fmap TestStack (traverse f sx)
instance Eq1 TestStack where prop_laws_Stack = format (foldableLaws p) <> format (traversableLaws p)
liftEq f (TestStack (Stack x xu xd)) (TestStack (Stack y yu yd)) =
f x y && liftEq f xu yu && liftEq f xd yd
instance Show1 TestStack where
liftShowsPrec shwP shwL p (TestStack (Stack x xu xd)) =
showString "TestStack (Stack {focus = "
<> shwP p x
<> showString ", up = "
<> shwL xu
<> showString ", down ="
<> shwL xd
<> showString "})"
proxy_TestStack :: Proxy1 TestStack
proxy_TestStack = Proxy1
laws_Stack_Traversable, laws_Stack_Foldable :: Laws
laws_Stack_Traversable = traversableLaws proxy_TestStack
laws_Stack_Foldable = foldableLaws proxy_TestStack
prop_laws_Stack =
format laws_Stack_Foldable <> format laws_Stack_Traversable
where where
format laws = p = Proxy :: Proxy TestStack
fmap format laws = [ ("Stack: " <> lawsTypeclass laws <> ": " <> name, prop)
(\(name, prop) -> | (name, prop) <- lawsProperties laws ]
("Stack: " <> lawsTypeclass laws <> ": " <> name, prop))
(lawsProperties laws)
#else #else
prop_laws_Stack = [] prop_laws_Stack = []
#endif #endif

View File

@ -143,8 +143,9 @@ test-suite properties
, containers , containers
, xmonad , xmonad
if flag(quickcheck-classes) if flag(quickcheck-classes) && impl(ghc > 8.5)
-- no quickcheck-classes in LTS-12 -- no quickcheck-classes in LTS-12
-- GHC 8.4 and lower needs too much boilerplate (Eq1, Show1, …)
build-depends: quickcheck-classes >= 0.4.3 build-depends: quickcheck-classes >= 0.4.3
if flag(pedantic) if flag(pedantic)