Merge pull request #452 from liskin/pr/hspec

tests: Use hspec as test driver (prep for #407 #430 #440 unit tests); speed up

XMonad/Actions/GridSelect.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-}
+{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Actions.GridSelect
@@ -220,7 +220,7 @@ instance HasColorizer Window where
 instance HasColorizer String where
     defaultColorizer = stringColorizer
 
-instance HasColorizer a where
+instance {-# OVERLAPPABLE #-} HasColorizer a where
     defaultColorizer _ isFg =
         let getColor = if isFg then focusedBorderColor else normalBorderColor
         in asks $ flip (,) "black" . getColor . config

XMonad/Layout/LimitWindows.hs

@@ -1,4 +1,7 @@
 {-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, PatternGuards #-}
+#ifdef TESTING
+{-# OPTIONS_GHC -Wno-duplicate-exports #-}
+#endif
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Layout.LimitWindows

tests/Main.hs

@@ -1,79 +1,43 @@
 module Main where
-import           Test.QuickCheck
+
-import           System.Environment
+import Test.Hspec
-import           Text.Printf
+import Test.Hspec.QuickCheck
-import           Control.Monad
+
 import qualified ManageDocks
 import qualified RotateSome
 import qualified Selective
 import qualified SwapWorkspaces
-
 import qualified XPrompt
 
 main :: IO ()
-main = do
+main = hspec $ do
-  arg <- fmap (drop 1) getArgs
+    context "ManageDocks" $ do
-  let n    = if null arg then 100 else read $ head arg
+        prop "prop_r2c_c2r" $ ManageDocks.prop_r2c_c2r
-      args = stdArgs { maxSuccess = n, maxSize = 100, maxDiscardRatio = 100 }
+        prop "prop_c2r_r2c" $ ManageDocks.prop_c2r_r2c
-      qc t = do
+    context "Selective" $ do
-        c <- quickCheckWithResult args t
+        prop "prop_select_length"     $ Selective.prop_select_length
-        case c of
+        prop "prop_update_idem"       $ Selective.prop_update_idem
-          Success{} -> return True
+        prop "prop_select_master"     $ Selective.prop_select_master
-          _         -> return False
+        prop "prop_select_focus"      $ Selective.prop_select_focus
-      perform (s, t) = printf "%-35s: " s >> qc t
+        prop "prop_select_increasing" $ Selective.prop_select_increasing
-  nFailed <- length . filter not <$> mapM perform tests
+        prop "prop_select_two_consec" $ Selective.prop_select_two_consec
-  unless (nFailed == 0) (error (show nFailed ++ " test(s) failed"))
+        prop "prop_update_nm"         $ Selective.prop_update_nm
-
+        prop "prop_update_start"      $ Selective.prop_update_start
-
+        prop "prop_update_nr"         $ Selective.prop_update_nr
-tests :: [(String, Property)]
+        prop "prop_update_focus_up"   $ Selective.prop_update_focus_up
-tests =
+        prop "prop_update_focus_down" $ Selective.prop_update_focus_down
-  [ ("ManageDocks.prop_r2c_c2r"    , property ManageDocks.prop_r2c_c2r)
+    context "RotateSome" $ do
-  , ("ManageDocks.prop_c2r_r2c"    , property ManageDocks.prop_c2r_r2c)
+        prop "prop_rotate_some_length"  $ RotateSome.prop_rotate_some_length
-  , ("Selective.prop_select_length", property Selective.prop_select_length)
+        prop "prop_rotate_some_cycle"   $ RotateSome.prop_rotate_some_cycle
-  , ("Selective.prop_update_idem"  , property Selective.prop_update_idem)
+        prop "prop_rotate_some_anchors" $ RotateSome.prop_rotate_some_anchors
-  , ("Selective.prop_select_master", property Selective.prop_select_master)
+        prop "prop_rotate_some_rotate"  $ RotateSome.prop_rotate_some_rotate
-  , ("Selective.prop_select_focus" , property Selective.prop_select_focus)
+        prop "prop_rotate_some_focus"   $ RotateSome.prop_rotate_some_focus
-  , ( "Selective.prop_select_increasing"
+    context "SwapWorkspaces" $ do
-    , property Selective.prop_select_increasing
+        prop "prop_double_swap"       $ SwapWorkspaces.prop_double_swap
-    )
+        prop "prop_invalid_swap"      $ SwapWorkspaces.prop_invalid_swap
-  , ( "Selective.prop_select_two_consec"
+        prop "prop_swap_only_two"     $ SwapWorkspaces.prop_swap_only_two
-    , property Selective.prop_select_two_consec
+        prop "prop_swap_with_current" $ SwapWorkspaces.prop_swap_with_current
-    )
+    context "XPrompt" $ do
-  , ("Selective.prop_update_nm"      , property Selective.prop_update_nm)
+        prop "prop_split"            $ XPrompt.prop_split
-  , ("Selective.prop_update_start"   , property Selective.prop_update_start)
+        prop "prop_spliInSubListsAt" $ XPrompt.prop_spliInSubListsAt
-  , ("Selective.prop_update_nr"      , property Selective.prop_update_nr)
+        prop "prop_skipGetLastWord"  $ XPrompt.prop_skipGetLastWord
-  , ("Selective.prop_update_focus_up", property Selective.prop_update_focus_up)
-  , ( "Selective.prop_update_focus_down"
-    , property Selective.prop_update_focus_down
-    )
-  , ( "RotateSome.prop_rotate_some_length"
-    , property RotateSome.prop_rotate_some_length
-    )
-  , ( "RotateSome.prop_rotate_some_cycle"
-    , property RotateSome.prop_rotate_some_cycle
-    )
-  , ( "RotateSome.prop_rotate_some_anchors"
-    , property RotateSome.prop_rotate_some_anchors
-    )
-  , ( "RotateSome.prop_rotate_some_rotate"
-    , property RotateSome.prop_rotate_some_rotate
-    )
-  , ( "RotateSome.prop_rotate_some_focus"
-    , property RotateSome.prop_rotate_some_focus
-    )
-  , ( "SwapWorkspaces.prop_double_swap"
-    , property SwapWorkspaces.prop_double_swap
-    )
-  , ( "SwapWorkspaces.prop_invalid_swap"
-    , property SwapWorkspaces.prop_invalid_swap
-    )
-  , ( "SwapWorkspaces.prop_swap_only_two"
-    , property SwapWorkspaces.prop_swap_only_two
-    )
-  , ( "SwapWorkspaces.prop_swap_with_current"
-    , property SwapWorkspaces.prop_swap_with_current
-    )
-  , ("XPrompt.prop_split"           , property XPrompt.prop_split)
-  , ("XPrompt.prop_spliInSubListsAt", property XPrompt.prop_spliInSubListsAt)
-  , ("XPrompt.prop_skipGetLastWord" , property XPrompt.prop_skipGetLastWord)
-  ]

tests/SwapWorkspaces.hs

@@ -10,15 +10,17 @@ import XMonad.Actions.SwapWorkspaces
 
 
 -- Ensures that no "loss of information" can happen from a swap.
-prop_double_swap (ss :: T) (NonNegative t1) (NonNegative t2) =
+prop_double_swap (ss :: T) = do
-  t1 `tagMember` ss && t2 `tagMember` ss ==>
+  t1 <- arbitraryTag ss
-  ss == swap (swap ss)
+  t2 <- arbitraryTag ss
-  where swap = swapWorkspaces t1 t2
+  let swap = swapWorkspaces t1 t2
+  return $ ss == swap (swap ss)
 
 -- Degrade nicely when given invalid data.
-prop_invalid_swap (ss :: T) (NonNegative t1) (NonNegative t2) =
+prop_invalid_swap (ss :: T) = do
-  not (t1 `tagMember` ss || t2 `tagMember` ss) ==>
+  t1 <- arbitrary `suchThat` (not . (`tagMember` ss))
-  ss == swapWorkspaces t1 t2 ss
+  t2 <- arbitrary `suchThat` (not . (`tagMember` ss))
+  return $ ss == swapWorkspaces t1 t2 ss
 
 -- This doesn't pass yet. Probably should.
 -- prop_half_invalid_swap (ss :: T) (NonNegative t1) (NonNegative t2) =
@@ -32,14 +34,15 @@ zipWorkspacesWith f s t = f (workspace $ current s) (workspace $ current t) :
                           zipWith f (hidden s)  (hidden t)
 
 -- Swap only modifies the workspaces tagged t1 and t2 -- leaves all others alone.
-prop_swap_only_two (ss :: T) (NonNegative t1) (NonNegative t2) =
+prop_swap_only_two (ss :: T) = do
-  t1 `tagMember` ss && t2 `tagMember` ss ==>
+  t1 <- arbitraryTag ss
-  and $ zipWorkspacesWith mostlyEqual ss (swapWorkspaces t1 t2 ss)
+  t2 <- arbitraryTag ss
-  where mostlyEqual w1 w2 = map tag [w1, w2] `elem` [[t1, t2], [t2, t1]] || w1 == w2
+  let mostlyEqual w1 w2 = map tag [w1, w2] `elem` [[t1, t2], [t2, t1]] || w1 == w2
+  return $ and $ zipWorkspacesWith mostlyEqual ss (swapWorkspaces t1 t2 ss)
 
 -- swapWithCurrent stays on current
-prop_swap_with_current (ss :: T) (NonNegative t) =
+prop_swap_with_current (ss :: T) = do
-  t `tagMember` ss ==>
+  t <- arbitraryTag ss
-  layout before == layout after && stack before == stack after
+  let before = workspace $ current ss
-  where before = workspace $ current ss
+  let after  = workspace $ current $ swapWithCurrent t ss
-        after  = workspace $ current $ swapWithCurrent t ss
+  return $ layout before == layout after && stack before == stack after

xmonad-contrib.cabal

@@ -362,7 +362,7 @@ library
                         XMonad.Util.XSelection
                         XMonad.Util.XUtils
 
-test-suite properties
+test-suite tests
   type:           exitcode-stdio-1.0
   main-is:        Main.hs
   other-modules:  ManageDocks
@@ -372,17 +372,38 @@ test-suite properties
                   XPrompt
                   Instances
                   Utils
-  hs-source-dirs: tests
+                  XMonad.Actions.CycleWS
+                  XMonad.Actions.FocusNth
+                  XMonad.Actions.PhysicalScreens
+                  XMonad.Actions.RotateSome
+                  XMonad.Actions.SwapWorkspaces
+                  XMonad.Actions.TagWindows
+                  XMonad.Hooks.ManageDocks
+                  XMonad.Hooks.WorkspaceHistory
+                  XMonad.Layout.LayoutModifier
+                  XMonad.Layout.LimitWindows
+                  XMonad.Prompt
+                  XMonad.Prompt.Shell
+                  XMonad.Util.ExtensibleState
+                  XMonad.Util.Font
+                  XMonad.Util.Image
+                  XMonad.Util.PureX
+                  XMonad.Util.Run
+                  XMonad.Util.Types
+                  XMonad.Util.WindowProperties
+                  XMonad.Util.WorkspaceCompare
+                  XMonad.Util.XSelection
+                  XMonad.Util.XUtils
+  hs-source-dirs: tests, .
   build-depends: base
                , QuickCheck >= 2
-               , containers
-               , xmonad-contrib
-               , directory
                , X11>=1.6.1 && < 1.10
+               , containers
+               , directory
+               , hspec >= 2.4.0 && < 3
                , mtl
                , process
                , unix
                , utf8-string
                , xmonad >= 0.15 && < 0.16
-  ghc-options: -i.
   cpp-options: -DTESTING