Merge pull request #202 from wygulmage/stack_instances

Add Functor, Foldable, and Traversable instances for StackSet.Stack

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

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

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

tests/Properties.hs

@@ -196,6 +196,5 @@ tests =
   ,("pointWithin",        property prop_point_within)
   ,("pointWithin mirror", property prop_point_within_mirror)
 
-  ]
-
-
+  ] <>
+  prop_laws_Stack

tests/Properties/Stack.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Properties.Stack where
 
@@ -9,6 +11,14 @@ 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,
+    )
+#endif
+
 
 -- The list returned by index should be the same length as the actual
 -- windows kept in the zipper
@@ -49,3 +59,25 @@ prop_differentiate xs =
         if null xs then differentiate xs == Nothing
                    else (differentiate xs) == Just (Stack (head xs) [] (tail 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)
+
+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)
+
+prop_laws_Stack = format (foldableLaws p) <> format (traversableLaws p)
+  where
+    p = Proxy :: Proxy TestStack
+    format laws = [ ("Stack: " <> lawsTypeclass laws <> ": " <> name, prop)
+                  | (name, prop) <- lawsProperties laws ]
+#else
+prop_laws_Stack = []
+#endif

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
@@ -81,6 +83,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
@@ -134,7 +137,16 @@ test-suite properties
                   Properties.Workspace
                   Utils
   hs-source-dirs: tests
-  build-depends:  base, QuickCheck >= 2, X11, containers, xmonad
+  build-depends:  base
+                , QuickCheck >= 2
+                , X11
+                , containers
+                , xmonad
+
+  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)
     ghc-options:   -Werror