From 320fe8c537f2155bfb451e06e5f1569ade7a506b Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sat, 23 Jan 2021 12:05:18 +0000 Subject: [PATCH 1/5] tests: Clean up test-suite in cabal * silence warnings about unlisted modules * remove xmonad-contrib dependency to make it unambiguous that modules are recompiled with -DTESTING, not taken from the library * sort build-depends --- xmonad-contrib.cabal | 30 +++++++++++++++++++++++++----- 1 file changed, 25 insertions(+), 5 deletions(-) diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 5d37a46f..f9cfff61 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -372,17 +372,37 @@ 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 , mtl , process , unix , utf8-string , xmonad >= 0.15 && < 0.16 - ghc-options: -i. cpp-options: -DTESTING From cd5b1a10157acda78c5f32974ac52f4742c72cfe Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Mon, 25 Jan 2021 21:05:57 +0000 Subject: [PATCH 2/5] tests: Use hspec as test driver My main motivation here is that I'd like to add some unit tests (as opposed to testing everything using QuickCheck properties), but there are other benefits: it's now easier to run a subset of tests -- the command-line interface is more powerful. Also, rename the test-suite to "tests" as it's no longer limited to properties. --- tests/Main.hs | 106 ++++++++++++++----------------------------- xmonad-contrib.cabal | 3 +- 2 files changed, 37 insertions(+), 72 deletions(-) diff --git a/tests/Main.hs b/tests/Main.hs index 4c761289..3b920f5c 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,79 +1,43 @@ module Main where -import Test.QuickCheck -import System.Environment -import Text.Printf -import Control.Monad + +import Test.Hspec +import Test.Hspec.QuickCheck + import qualified ManageDocks import qualified RotateSome import qualified Selective import qualified SwapWorkspaces - import qualified XPrompt main :: IO () -main = do - arg <- fmap (drop 1) getArgs - let n = if null arg then 100 else read $ head arg - args = stdArgs { maxSuccess = n, maxSize = 100, maxDiscardRatio = 100 } - qc t = do - c <- quickCheckWithResult args t - case c of - Success{} -> return True - _ -> return False - perform (s, t) = printf "%-35s: " s >> qc t - nFailed <- length . filter not <$> mapM perform tests - unless (nFailed == 0) (error (show nFailed ++ " test(s) failed")) - - -tests :: [(String, Property)] -tests = - [ ("ManageDocks.prop_r2c_c2r" , property ManageDocks.prop_r2c_c2r) - , ("ManageDocks.prop_c2r_r2c" , property ManageDocks.prop_c2r_r2c) - , ("Selective.prop_select_length", property Selective.prop_select_length) - , ("Selective.prop_update_idem" , property Selective.prop_update_idem) - , ("Selective.prop_select_master", property Selective.prop_select_master) - , ("Selective.prop_select_focus" , property Selective.prop_select_focus) - , ( "Selective.prop_select_increasing" - , property Selective.prop_select_increasing - ) - , ( "Selective.prop_select_two_consec" - , property Selective.prop_select_two_consec - ) - , ("Selective.prop_update_nm" , property Selective.prop_update_nm) - , ("Selective.prop_update_start" , property Selective.prop_update_start) - , ("Selective.prop_update_nr" , property Selective.prop_update_nr) - , ("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) - ] +main = hspec $ do + context "ManageDocks" $ do + prop "prop_r2c_c2r" $ ManageDocks.prop_r2c_c2r + prop "prop_c2r_r2c" $ ManageDocks.prop_c2r_r2c + context "Selective" $ do + prop "prop_select_length" $ Selective.prop_select_length + prop "prop_update_idem" $ Selective.prop_update_idem + prop "prop_select_master" $ Selective.prop_select_master + prop "prop_select_focus" $ Selective.prop_select_focus + prop "prop_select_increasing" $ Selective.prop_select_increasing + prop "prop_select_two_consec" $ Selective.prop_select_two_consec + prop "prop_update_nm" $ Selective.prop_update_nm + prop "prop_update_start" $ Selective.prop_update_start + prop "prop_update_nr" $ Selective.prop_update_nr + prop "prop_update_focus_up" $ Selective.prop_update_focus_up + prop "prop_update_focus_down" $ Selective.prop_update_focus_down + context "RotateSome" $ do + prop "prop_rotate_some_length" $ RotateSome.prop_rotate_some_length + prop "prop_rotate_some_cycle" $ RotateSome.prop_rotate_some_cycle + prop "prop_rotate_some_anchors" $ RotateSome.prop_rotate_some_anchors + prop "prop_rotate_some_rotate" $ RotateSome.prop_rotate_some_rotate + prop "prop_rotate_some_focus" $ RotateSome.prop_rotate_some_focus + context "SwapWorkspaces" $ modifyMaxDiscardRatio (const 100) $ do + prop "prop_double_swap" $ SwapWorkspaces.prop_double_swap + prop "prop_invalid_swap" $ SwapWorkspaces.prop_invalid_swap + prop "prop_swap_only_two" $ SwapWorkspaces.prop_swap_only_two + prop "prop_swap_with_current" $ SwapWorkspaces.prop_swap_with_current + context "XPrompt" $ do + prop "prop_split" $ XPrompt.prop_split + prop "prop_spliInSubListsAt" $ XPrompt.prop_spliInSubListsAt + prop "prop_skipGetLastWord" $ XPrompt.prop_skipGetLastWord diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index f9cfff61..1968c522 100644 --- a/xmonad-contrib.cabal +++ b/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 @@ -400,6 +400,7 @@ test-suite properties , X11>=1.6.1 && < 1.10 , containers , directory + , hspec >= 2.4.0 && < 3 , mtl , process , unix From 245dac496b66ab78d118c60de2da4c967667840d Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Mon, 25 Jan 2021 21:31:27 +0000 Subject: [PATCH 3/5] tests: Speed up by producing less discarded tests in SwapWorkspaces --- tests/Main.hs | 2 +- tests/SwapWorkspaces.hs | 35 +++++++++++++++++++---------------- 2 files changed, 20 insertions(+), 17 deletions(-) diff --git a/tests/Main.hs b/tests/Main.hs index 3b920f5c..ff9122bc 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -32,7 +32,7 @@ main = hspec $ do prop "prop_rotate_some_anchors" $ RotateSome.prop_rotate_some_anchors prop "prop_rotate_some_rotate" $ RotateSome.prop_rotate_some_rotate prop "prop_rotate_some_focus" $ RotateSome.prop_rotate_some_focus - context "SwapWorkspaces" $ modifyMaxDiscardRatio (const 100) $ do + context "SwapWorkspaces" $ do prop "prop_double_swap" $ SwapWorkspaces.prop_double_swap prop "prop_invalid_swap" $ SwapWorkspaces.prop_invalid_swap prop "prop_swap_only_two" $ SwapWorkspaces.prop_swap_only_two diff --git a/tests/SwapWorkspaces.hs b/tests/SwapWorkspaces.hs index 1a70c030..f30cedad 100644 --- a/tests/SwapWorkspaces.hs +++ b/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) = - t1 `tagMember` ss && t2 `tagMember` ss ==> - ss == swap (swap ss) - where swap = swapWorkspaces t1 t2 +prop_double_swap (ss :: T) = do + t1 <- arbitraryTag ss + t2 <- arbitraryTag ss + 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) = - not (t1 `tagMember` ss || t2 `tagMember` ss) ==> - ss == swapWorkspaces t1 t2 ss +prop_invalid_swap (ss :: T) = do + t1 <- arbitrary `suchThat` (not . (`tagMember` 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) = - t1 `tagMember` ss && t2 `tagMember` ss ==> - and $ zipWorkspacesWith mostlyEqual ss (swapWorkspaces t1 t2 ss) - where mostlyEqual w1 w2 = map tag [w1, w2] `elem` [[t1, t2], [t2, t1]] || w1 == w2 +prop_swap_only_two (ss :: T) = do + t1 <- arbitraryTag ss + t2 <- arbitraryTag ss + 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) = - t `tagMember` ss ==> - layout before == layout after && stack before == stack after - where before = workspace $ current ss - after = workspace $ current $ swapWithCurrent t ss +prop_swap_with_current (ss :: T) = do + t <- arbitraryTag ss + let before = workspace $ current ss + let after = workspace $ current $ swapWithCurrent t ss + return $ layout before == layout after && stack before == stack after From 2691e3a4902511d995a4994fbfda9337e0fdd749 Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Tue, 26 Jan 2021 12:17:36 +0000 Subject: [PATCH 4/5] X.A.GridSelect: Use OVERLAPPABLE, seems to help with unnecessary recompiles Without this, any change to tests triggers a recompile of GridSelect when invoking "stack test", adding a couple seconds. This seems to help. --- XMonad/Actions/GridSelect.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/XMonad/Actions/GridSelect.hs b/XMonad/Actions/GridSelect.hs index 4195a9bd..69bb4f1b 100644 --- a/XMonad/Actions/GridSelect.hs +++ b/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 From 6179ed9dbe5e9bb6c2880f53979e107dda2297c8 Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Tue, 26 Jan 2021 22:13:28 +0000 Subject: [PATCH 5/5] X.L.LimitWindows: Silence duplicate export warnings in tests --- XMonad/Layout/LimitWindows.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/XMonad/Layout/LimitWindows.hs b/XMonad/Layout/LimitWindows.hs index a1c4d291..3a337abc 100644 --- a/XMonad/Layout/LimitWindows.hs +++ b/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