From 2c91ea1621563b504dc4cc43f210dc96a2c62cdf Mon Sep 17 00:00:00 2001 From: Keith Date: Wed, 27 Jan 2021 19:55:01 -0500 Subject: [PATCH 1/6] Add Foldable, Functor, and Traversable instances for Stack `Functor` is provided by DeriveFunctor. `Foldable` uses `integrate` (`Stack`'s `toList`). `Traversable` uses the `Reverse` Applicative to traverse the `up` list in reverse order. --- src/XMonad/StackSet.hs | 16 +++++++++++++++- xmonad.cabal | 1 + 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/src/XMonad/StackSet.hs b/src/XMonad/StackSet.hs index c99509c..7fe0d1a 100644 --- a/src/XMonad/StackSet.hs +++ b/src/XMonad/StackSet.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | @@ -52,6 +53,8 @@ module XMonad.StackSet ( ) where import Prelude hiding (filter) +import Control.Applicative.Backwards (Backwards (Backwards, forwards)) +import Data.Foldable (foldr, toList) import Data.Maybe (listToMaybe,isJust,fromMaybe) import qualified Data.List as L (deleteBy,find,splitAt,filter,nub) import Data.List ( (\\) ) @@ -175,8 +178,19 @@ data RationalRect = RationalRect !Rational !Rational !Rational !Rational data Stack a = Stack { focus :: !a -- focused thing in this set , up :: [a] -- clowns to the left , down :: [a] } -- jokers to the right - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Functor) +instance Foldable Stack where + toList = integrate + foldr f z = foldr f z . toList + +instance Traversable Stack where + traverse f s = + flip Stack + -- 'Backwards' applies the Applicative in reverse order. + <$> forwards (traverse (Backwards . f) (up s)) + <*> f (focus s) + <*> traverse f (down s) -- | this function indicates to catch that an error is expected abort :: String -> a diff --git a/xmonad.cabal b/xmonad.cabal index dba5e5e..478589d 100644 --- a/xmonad.cabal +++ b/xmonad.cabal @@ -81,6 +81,7 @@ library , mtl , process , setlocale + , transformers >= 0.3 , unix , utf8-string >= 0.3 && < 1.1 ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind From 05e8c204e9583071feec545ac836a25075c6baef Mon Sep 17 00:00:00 2001 From: Keith Date: Wed, 3 Feb 2021 11:44:42 -0500 Subject: [PATCH 2/6] Add quickcheck-classes tests for Stack The tests are implemented by using a newtype wrapper `TestStack`. This is to avoid creating `Eq1` and `Show1` instances for `Stack` itself, which are needed by quickcheck-classes to run with GHC less than 8.5. Tests are automatically generated by `traversalLaws` and `foldableLaws` using the `Arbitrary` instance for `TestStack`. --- tests/Properties.hs | 5 ++-- tests/Properties/Stack.hs | 53 +++++++++++++++++++++++++++++++++++++++ xmonad.cabal | 7 +++++- 3 files changed, 61 insertions(+), 4 deletions(-) diff --git a/tests/Properties.hs b/tests/Properties.hs index 62ebeb6..6c7013c 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -196,6 +196,5 @@ tests = ,("pointWithin", property prop_point_within) ,("pointWithin mirror", property prop_point_within_mirror) - ] - - + ] <> + prop_laws_Stack diff --git a/tests/Properties/Stack.hs b/tests/Properties/Stack.hs index 586df1d..27486fd 100644 --- a/tests/Properties/Stack.hs +++ b/tests/Properties/Stack.hs @@ -1,13 +1,19 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Properties.Stack where import Test.QuickCheck +import Test.QuickCheck.Classes ( + Laws (lawsTypeclass, lawsProperties), Proxy1 (Proxy1), + foldableLaws, traversableLaws, + ) import Instances import XMonad.StackSet hiding (filter) import qualified XMonad.StackSet as S (filter) import Data.Maybe +import Data.Functor.Classes (Eq1 (liftEq), Show1 (liftShowsPrec)) -- The list returned by index should be the same length as the actual @@ -49,3 +55,50 @@ prop_differentiate xs = if null xs then differentiate xs == Nothing else (differentiate xs) == Just (Stack (head xs) [] (tail xs)) where _ = xs :: [Int] + + +-- Check type class laws of 'Data.Foldable.Foldable' and 'Data.Traversable.Traversable'. +newtype TestStack a = TestStack (Stack a) + deriving (Eq, Read, Show, Foldable, Functor) + +instance Arbitrary1 TestStack where + liftArbitrary gen = + (\ x xu xd -> TestStack (Stack x xu xd)) + <$> gen + <*> liftArbitrary gen + <*> liftArbitrary gen + +instance (Arbitrary a)=> Arbitrary (TestStack a) where + arbitrary = arbitrary1 + shrink = shrink1 + +instance Traversable TestStack where + traverse f (TestStack sx) = fmap TestStack (traverse f sx) + +instance Eq1 TestStack where + 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 + format laws = + fmap + (\(name, prop) -> + ("Stack: " <> lawsTypeclass laws <> ": " <> name, prop)) + (lawsProperties laws) diff --git a/xmonad.cabal b/xmonad.cabal index 478589d..d7cb1e8 100644 --- a/xmonad.cabal +++ b/xmonad.cabal @@ -135,7 +135,12 @@ test-suite properties Properties.Workspace Utils hs-source-dirs: tests - build-depends: base, QuickCheck >= 2, X11, containers, xmonad + build-depends: base + , QuickCheck >= 2 + , quickcheck-classes >= 0.4.3 + , X11 + , containers + , xmonad if flag(pedantic) ghc-options: -Werror From 031bbd62306e592ddd0768d4e5b1105bf5e81032 Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sat, 3 Apr 2021 14:35:39 +0100 Subject: [PATCH 3/6] Make quickcheck-classes dependency optional --- tests/Properties/Stack.hs | 18 +++++++++++++----- xmonad.cabal | 7 ++++++- 2 files changed, 19 insertions(+), 6 deletions(-) diff --git a/tests/Properties/Stack.hs b/tests/Properties/Stack.hs index 27486fd..42ec784 100644 --- a/tests/Properties/Stack.hs +++ b/tests/Properties/Stack.hs @@ -1,19 +1,23 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} module Properties.Stack where import Test.QuickCheck -import Test.QuickCheck.Classes ( - Laws (lawsTypeclass, lawsProperties), Proxy1 (Proxy1), - foldableLaws, traversableLaws, - ) import Instances import XMonad.StackSet hiding (filter) import qualified XMonad.StackSet as S (filter) import Data.Maybe + +#ifdef VERSION_quickcheck_classes +import Test.QuickCheck.Classes ( + Laws (lawsTypeclass, lawsProperties), Proxy1 (Proxy1), + foldableLaws, traversableLaws, + ) import Data.Functor.Classes (Eq1 (liftEq), Show1 (liftShowsPrec)) +#endif -- The list returned by index should be the same length as the actual @@ -57,6 +61,7 @@ prop_differentiate xs = where _ = xs :: [Int] +#ifdef VERSION_quickcheck_classes -- Check type class laws of 'Data.Foldable.Foldable' and 'Data.Traversable.Traversable'. newtype TestStack a = TestStack (Stack a) deriving (Eq, Read, Show, Foldable, Functor) @@ -102,3 +107,6 @@ prop_laws_Stack = (\(name, prop) -> ("Stack: " <> lawsTypeclass laws <> ": " <> name, prop)) (lawsProperties laws) +#else +prop_laws_Stack = [] +#endif diff --git a/xmonad.cabal b/xmonad.cabal index d7cb1e8..a7297d4 100644 --- a/xmonad.cabal +++ b/xmonad.cabal @@ -61,6 +61,8 @@ flag generatemanpage manual: True description: Build the tool for generating the man page +flag quickcheck-classes + library exposed-modules: XMonad XMonad.Config @@ -137,10 +139,13 @@ test-suite properties hs-source-dirs: tests build-depends: base , QuickCheck >= 2 - , quickcheck-classes >= 0.4.3 , X11 , containers , xmonad + if flag(quickcheck-classes) + -- no quickcheck-classes in LTS-12 + build-depends: quickcheck-classes >= 0.4.3 + if flag(pedantic) ghc-options: -Werror From 910d99cb742d1b3393e7915465d32561d2849280 Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sat, 3 Apr 2021 14:39:10 +0100 Subject: [PATCH 4/6] Update CHANGES --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 1145e54..fa66eac 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -35,6 +35,8 @@ * Fixed dunst notifications being obscured when moving floats. https://github.com/xmonad/xmonad/issues/208 + * Added `Foldable`, `Functor`, and `Traversable` instances for `Stack`. + ## 0.15 (September 30, 2018) * Reimplement `sendMessage` to deal properly with windowset changes made From 6c5204b91ce43edc177304bb5f1c72662060da54 Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sat, 3 Apr 2021 15:17:25 +0100 Subject: [PATCH 5/6] Simplify quickcheck-classes tests for Stack We don't need the compat hacks for GHC 8.4. --- tests/Properties/Stack.hs | 45 +++++++-------------------------------- xmonad.cabal | 3 ++- 2 files changed, 10 insertions(+), 38 deletions(-) diff --git a/tests/Properties/Stack.hs b/tests/Properties/Stack.hs index 42ec784..344c4c3 100644 --- a/tests/Properties/Stack.hs +++ b/tests/Properties/Stack.hs @@ -12,11 +12,11 @@ import qualified XMonad.StackSet as S (filter) import Data.Maybe #ifdef VERSION_quickcheck_classes +import Data.Proxy import Test.QuickCheck.Classes ( Laws (lawsTypeclass, lawsProperties), Proxy1 (Proxy1), foldableLaws, traversableLaws, ) -import Data.Functor.Classes (Eq1 (liftEq), Show1 (liftShowsPrec)) #endif @@ -66,47 +66,18 @@ prop_differentiate xs = newtype TestStack a = TestStack (Stack a) deriving (Eq, Read, Show, Foldable, Functor) -instance Arbitrary1 TestStack where - liftArbitrary gen = - (\ x xu xd -> TestStack (Stack x xu xd)) - <$> gen - <*> liftArbitrary gen - <*> liftArbitrary gen - -instance (Arbitrary a)=> Arbitrary (TestStack a) where - arbitrary = arbitrary1 - shrink = shrink1 +instance (Arbitrary a) => Arbitrary (TestStack a) where + arbitrary = TestStack <$> (Stack <$> arbitrary <*> arbitrary <*> arbitrary) + shrink = traverse shrink instance Traversable TestStack where traverse f (TestStack sx) = fmap TestStack (traverse f sx) -instance Eq1 TestStack where - 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 +prop_laws_Stack = format (foldableLaws p) <> format (traversableLaws p) where - format laws = - fmap - (\(name, prop) -> - ("Stack: " <> lawsTypeclass laws <> ": " <> name, prop)) - (lawsProperties laws) + p = Proxy :: Proxy TestStack + format laws = [ ("Stack: " <> lawsTypeclass laws <> ": " <> name, prop) + | (name, prop) <- lawsProperties laws ] #else prop_laws_Stack = [] #endif diff --git a/xmonad.cabal b/xmonad.cabal index a7297d4..640bb5f 100644 --- a/xmonad.cabal +++ b/xmonad.cabal @@ -143,8 +143,9 @@ test-suite properties , containers , xmonad - if flag(quickcheck-classes) + if flag(quickcheck-classes) && impl(ghc > 8.5) -- no quickcheck-classes in LTS-12 + -- GHC 8.4 and lower needs too much boilerplate (Eq1, Show1, …) build-depends: quickcheck-classes >= 0.4.3 if flag(pedantic) From 400730fe3b8aab8e7f9403215c88b37e44fe7a66 Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sat, 3 Apr 2021 15:46:39 +0100 Subject: [PATCH 6/6] Disable quickcheck-classes when building with stack Stack doesn't support automatic flags: it doesn't backtrack when dependency resolution fails using the default value of an automatic flag, it just fails the build plan construction. We can't use automatic flags to check if quickcheck-classes is available, and since the code is tested by the haskell-ci.yml cabal workflow anyway, let's just disable it here. It's not worth the hassle trying to enable it for select LTS versions only. It's too much noise already, actually. :-( Further reading: https://cabal.readthedocs.io/en/latest/cabal-package.html#resolution-of-conditions-and-flags https://github.com/commercialhaskell/stack/issues/1313#issuecomment-157259270 --- stack.yaml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/stack.yaml b/stack.yaml index 0c2108c..a592eba 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,6 +6,13 @@ packages: extra-deps: - X11-1.9.2 +flags: + xmonad: + # stack doesn't support automatic flags + # https://cabal.readthedocs.io/en/latest/cabal-package.html#resolution-of-conditions-and-flags + # https://github.com/commercialhaskell/stack/issues/1313#issuecomment-157259270 + quickcheck-classes: false + nix: packages: - zlib