mirror of
https://github.com/xmonad/xmonad.git
synced 2025-05-19 08:30:21 -07:00
Simplify quickcheck-classes tests for Stack
We don't need the compat hacks for GHC 8.4.
This commit is contained in:
parent
910d99cb74
commit
6c5204b91c
@ -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
|
||||||
|
@ -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)
|
||||||
|
Loading…
x
Reference in New Issue
Block a user