added new test-suite

tests/Instances.hs

@@ -0,0 +1,180 @@
+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Instances where -- copied (and adapted) from the core library
+
+
+import           XMonad.Hooks.ManageDocks
+import           XMonad.Layout.LimitWindows
+import           Test.QuickCheck
+import           Utils
+
+import           XMonad.StackSet
+import           Control.Monad
+import           Data.List                      ( nub )
+
+import           Graphics.X11                   ( Rectangle(Rectangle) )
+
+arbNat :: Gen Int
+arbNat = abs <$> arbitrary
+
+arbPos :: Gen Int
+arbPos = (+ 1) . abs <$> arbitrary
+
+instance Arbitrary (Stack Int) where
+  arbitrary = do
+    xs <- arbNat
+    ys <- arbNat
+    return $ Stack { up    = [xs - 1, xs - 2 .. 0]
+                   , focus = xs
+                   , down  = [xs + 1 .. xs + ys]
+                   }
+
+instance Arbitrary (Selection a) where
+  arbitrary = do
+    nm <- arbNat
+    st <- arbNat
+    nr <- arbPos
+    return $ Sel nm (st + nm) nr
+
+--
+-- The all important Arbitrary instance for StackSet.
+--
+instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary l, Arbitrary sd)
+         => Arbitrary (StackSet i l a s sd) where
+  arbitrary = do
+      -- TODO: Fix this to be a reasonable higher number, Possibly use PositiveSized
+    numWs        <- choose (1, 20)    -- number of workspaces, there must be at least 1.
+    numScreens   <- choose (1, numWs) -- number of physical screens, there must be at least 1
+    lay          <- arbitrary                  -- pick any layout
+
+    wsIdxInFocus <- choose (1, numWs) -- pick index of WS to be in focus
+
+    -- The same screen id's will be present in the list, with high possibility.
+    screens      <- replicateM numScreens arbitrary
+
+    -- Generate a list of "windows" for each workspace.
+    wsWindows    <- vector numWs :: Gen [[a]]
+
+    -- Pick a random window "number" in each workspace, to give focus.
+    focus        <- sequence
+      [ if null windows
+          then return Nothing
+          else Just <$> choose (0, length windows - 1)
+      | windows <- wsWindows
+      ]
+
+    let tags           = [1 .. fromIntegral numWs]
+        focusWsWindows = zip focus wsWindows
+        wss            = zip tags focusWsWindows -- tmp representation of a workspace (tag, windows)
+        initSs         = new lay tags screens
+    return $ view (fromIntegral wsIdxInFocus) $ foldr
+      (\(tag, (focus, windows)) ss -> -- Fold through all generated (tags,windows).
+              -- set workspace active by tag and fold through all
+              -- windows while inserting them.  Apply the given number
+              -- of `focusUp` on the resulting StackSet.
+        applyN focus focusUp $ foldr insertUp (view tag ss) windows
+      )
+      initSs
+      wss
+
+
+--
+-- Just generate StackSets with Char elements.
+--
+type Tag = Int
+type Window = Char
+type T = StackSet Tag Int Window Int Int
+
+
+
+newtype EmptyStackSet = EmptyStackSet T
+    deriving Show
+
+instance Arbitrary EmptyStackSet where
+  arbitrary = do
+    (NonEmptyNubList ns ) <- arbitrary
+    (NonEmptyNubList sds) <- arbitrary
+    l                     <- arbitrary
+    -- there cannot be more screens than workspaces:
+    return . EmptyStackSet . new l ns $ take (min (length ns) (length sds)) sds
+
+
+
+newtype NonEmptyWindowsStackSet = NonEmptyWindowsStackSet T
+    deriving Show
+
+instance Arbitrary NonEmptyWindowsStackSet where
+  arbitrary =
+    NonEmptyWindowsStackSet
+      `fmap` (arbitrary `suchThat` (not . null . allWindows))
+
+instance Arbitrary RectC where
+  arbitrary = do
+    (x :: Int, y :: Int) <- arbitrary
+    NonNegative w        <- arbitrary
+    NonNegative h        <- arbitrary
+    return $ RectC
+      ( fromIntegral x
+      , fromIntegral y
+      , fromIntegral $ x + w
+      , fromIntegral $ y + h
+      )
+
+instance Arbitrary Rectangle where
+  arbitrary = Rectangle <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+
+newtype SizedPositive = SizedPositive Int
+    deriving (Eq, Ord, Show, Read)
+
+instance Arbitrary SizedPositive where
+  arbitrary = sized $ \s -> do
+    x <- choose (1, max 1 s)
+    return $ SizedPositive x
+
+
+
+newtype NonEmptyNubList a = NonEmptyNubList [a]
+    deriving ( Eq, Ord, Show, Read )
+
+instance (Eq a, Arbitrary a) => Arbitrary (NonEmptyNubList a) where
+  arbitrary =
+    NonEmptyNubList `fmap` (fmap nub arbitrary `suchThat` (not . null))
+
+
+
+-- | Pull out an arbitrary tag from the StackSet. This removes the need for the
+-- precondition "n `tagMember x` in many properties and thus reduces the number
+-- of discarded tests.
+--
+--  n <- arbitraryTag x
+--
+-- We can do the reverse with a simple `suchThat`:
+--
+-- n <- arbitrary `suchThat` \n' -> not $ n' `tagMember` x
+arbitraryTag :: T -> Gen Tag
+arbitraryTag x = do
+  let ts = tags x
+  -- There must be at least 1 workspace, thus at least 1 tag.
+  idx <- choose (0, length ts - 1)
+  return $ ts !! idx
+
+-- | Pull out an arbitrary window from a StackSet that is guaranteed to have a
+-- non empty set of windows. This eliminates the precondition "i `member` x" in
+-- a few properties.
+--
+--
+-- foo (nex :: NonEmptyWindowsStackSet) = do
+--   let NonEmptyWindowsStackSet x = nex
+--   w <- arbitraryWindow nex
+--   return $ .......
+--
+-- We can do the reverse with a simple `suchThat`:
+--
+--   n <- arbitrary `suchThat` \n' -> not $ n `member` x
+arbitraryWindow :: NonEmptyWindowsStackSet -> Gen Window
+arbitraryWindow (NonEmptyWindowsStackSet x) = do
+  let ws = allWindows x
+  -- We know that there are at least 1 window in a NonEmptyWindowsStackSet.
+  idx <- choose (0, (length ws) - 1)
+  return $ ws !! idx

tests/Main.hs

@@ -0,0 +1,79 @@
+module Main where
+import           Test.QuickCheck
+import           System.Environment
+import           Text.Printf
+import           Control.Monad
+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)
+  ]

tests/ManageDocks.hs

@@ -1,18 +1,6 @@
 module ManageDocks where
-import XMonad
-import XMonad.Hooks.ManageDocks
-import Test.QuickCheck
-import Foreign.C.Types
-import Properties
-
-instance Arbitrary CLong where
-    arbitrary = fromIntegral <$> (arbitrary :: Gen Int)
-instance Arbitrary RectC where
-    arbitrary = do
-        (x,y) <- arbitrary
-        NonNegative w <- arbitrary
-        NonNegative h <- arbitrary
-        return $ RectC (x,y,x+w,y+h)
+import           XMonad                         ( Rectangle )
+import           XMonad.Hooks.ManageDocks
 
 prop_r2c_c2r :: RectC -> Bool
 prop_r2c_c2r r = r2c (c2r r) == r

tests/RotateSome.hs

@@ -1,23 +1,13 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 
 module RotateSome where
 
-import Test.QuickCheck (Arbitrary, Gen, arbitrary, choose, listOf, quickCheck)
-import Utils (applyN)
-import XMonad.StackSet (Stack (Stack), down, focus, integrate, up)
+import Utils
+import Test.QuickCheck (Arbitrary, arbitrary, choose)
+import XMonad.StackSet (Stack, integrate, up)
 import XMonad.Actions.RotateSome (rotateSome)
 
-instance Arbitrary (Stack Int) where
-  arbitrary = do
-    foc   <- arbNat
-    ups   <- listOf arbNat
-    downs <- listOf arbNat
-    pure (Stack foc ups downs)
-
-arbNat :: Gen Int
-arbNat = fmap abs arbitrary
-
 newtype Divisor = Divisor Int deriving Show
 instance Arbitrary Divisor where
   arbitrary = Divisor <$> choose (1, 5)
@@ -56,20 +46,3 @@ prop_rotate_some_rotate (Divisor d) (stk :: Stack Int) =
 -- Focus position is preserved.
 prop_rotate_some_focus (Divisor d) (stk :: Stack Int) =
   length (up stk) == length (up $ rotateSome (`isMultOf` d) stk)
-
-main :: IO ()
-main = do
-  putStrLn "Testing rotateSome length"
-  quickCheck prop_rotate_some_length
-
-  putStrLn "Testing rotateSome cycle"
-  quickCheck prop_rotate_some_cycle
-
-  putStrLn "Testing rotateSome anchors"
-  quickCheck prop_rotate_some_anchors
-
-  putStrLn "Testing rotateSome rotate"
-  quickCheck prop_rotate_some_rotate
-
-  putStrLn "Testing rotateSome focus"
-  quickCheck prop_rotate_some_focus

tests/Selective.hs

@@ -1,35 +1,17 @@
-{-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 module Selective where
 
 -- Tests for limitSelect-related code in L.LimitWindows.
 -- To run these tests, export (select,update,Selection(..),updateAndSelect) from
 -- L.LimitWindows.
 
+
 import XMonad.Layout.LimitWindows
 import XMonad.StackSet hiding (focusUp, focusDown, filter)
 import Test.QuickCheck
-import Control.Arrow (second)
 
-instance Arbitrary (Stack Int) where
-    arbitrary = do
-                    xs <- arbNat
-                    ys <- arbNat
-                    return $ Stack { up=[xs-1,xs-2..0], focus=xs, down=[xs+1..xs+ys] }
-    coarbitrary = undefined
-
-instance Arbitrary (Selection a) where
-    arbitrary = do
-                    nm <- arbNat
-                    st <- arbNat
-                    nr <- arbPos
-                    return $ Sel nm (st+nm) nr
-    coarbitrary = undefined
-
-arbNat = abs <$> arbitrary
-arbPos = (+1) . abs <$> arbitrary
-
--- as many windows as possible should be selected 
+-- as many windows as possible should be selected
 -- (when the selection is normalized)
 prop_select_length sel (stk :: Stack Int) =
     (length . integrate $ select sel' stk) == ((nMaster sel' + nRest sel') `min` length (integrate stk))
@@ -40,7 +22,7 @@ prop_update_idem sel (stk :: Stack Int) = sel' == update sel' stk
     where sel' = update sel stk
 
 -- select selects the master pane
-prop_select_master sel (stk :: Stack Int) = 
+prop_select_master sel (stk :: Stack Int) =
     take (nMaster sel) (integrate stk) == take (nMaster sel) (integrate $ select sel stk)
 
 -- the focus should always be selected in normalized selections
@@ -49,38 +31,49 @@ prop_select_focus sel (stk :: Stack Int) = focus stk == (focus $ select sel' stk
 
 -- select doesn't change order (or duplicate elements)
 -- relies on the Arbitrary instance for Stack Int generating increasing stacks
+prop_select_increasing :: Selection l -> Stack Int -> Bool
 prop_select_increasing sel (stk :: Stack Int) =
     let res = integrate $ select sel stk
      in and . zipWith (<) res $ tail res
 
 -- selection has the form [0..l] ++ [m..n]
 -- relies on the Arbitrary instance for Stack Int generating stacks like [0..k]
+prop_select_two_consec :: Selection l -> Stack Int -> Bool
 prop_select_two_consec sel (stk :: Stack Int) =
     let wins = integrate $ select sel stk
      in (length . filter not . zipWith ((==) . (+1)) wins $ tail wins) <= 1
 
 -- update preserves invariants on selections
+prop_update_nm :: Selection l -> Stack Int -> Bool
 prop_update_nm sel (stk :: Stack Int) = nMaster (update sel stk) >= 0
+
+prop_update_start :: Selection l -> Stack Int -> Bool
 prop_update_start sel (stk :: Stack Int) = nMaster sel' <= start sel'
     where sel' = update sel stk
+
+prop_update_nr :: Selection l -> Stack Int -> Bool
 prop_update_nr sel (stk :: Stack Int) = nRest (update sel stk) >= 0
 
 -- moving the focus to a window that's already selected doesn't change the selection
+prop_update_focus_up :: Selection l -> Stack Int -> Int -> Property
 prop_update_focus_up sel (stk :: Stack Int) x' =
-    (length (up stk) >= x) && ((up stk !! (x-1)) `elem` integrate stk') ==> 
+    (length (up stk) >= x) && ((up stk !! (x-1)) `elem` integrate stk') ==>
         sel' == update sel' (iterate focusUp stk !! x)
     where
         x = 1 + abs x'
         sel' = update sel stk
         stk' = select sel' stk
 
+prop_update_focus_down :: Selection l -> Stack Int -> Int -> Property
 prop_update_focus_down sel (stk :: Stack Int) x' =
-    (length (down stk) >= x) && ((down stk !! (x-1)) `elem` integrate stk') ==> 
+    (length (down stk) >= x) && ((down stk !! (x-1)) `elem` integrate stk') ==>
         sel' == update sel' (iterate focusDown stk !! x)
     where
         x = 1 + abs x'
         sel' = update sel stk
         stk' = select sel' stk
 
+focusUp :: Stack a -> Stack a
 focusUp stk = stk { up=tail (up stk), focus=head (up stk), down=focus stk:down stk }
+focusDown :: Stack a -> Stack a
 focusDown stk = stk { down=tail (down stk), focus=head (down stk), up=focus stk:up stk }

tests/SwapWorkspaces.hs

@@ -1,27 +1,27 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-module SwapWorkspaces where
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 
-import Data.List(find,union)
-import Data.Maybe(fromJust)
+module SwapWorkspaces where
+import Instances
 import Test.QuickCheck
 
 import XMonad.StackSet
-import Properties(T, NonNegative) -- requires tests/Properties.hs from xmonad-core
 import XMonad.Actions.SwapWorkspaces
 
+
 -- Ensures that no "loss of information" can happen from a swap.
-prop_double_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =
+prop_double_swap (ss :: T) (NonNegative t1) (NonNegative t2) =
   t1 `tagMember` ss && t2 `tagMember` ss ==>
   ss == swap (swap ss)
   where swap = swapWorkspaces t1 t2
 
 -- Degrade nicely when given invalid data.
-prop_invalid_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =
+prop_invalid_swap (ss :: T) (NonNegative t1) (NonNegative t2) =
   not (t1 `tagMember` ss || t2 `tagMember` ss) ==>
   ss == swapWorkspaces t1 t2 ss
 
 -- This doesn't pass yet. Probably should.
--- prop_half_invalid_swap (ss :: T) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =
+-- prop_half_invalid_swap (ss :: T) (NonNegative t1) (NonNegative t2) =
 --   t1 `tagMember` ss && not (t2 `tagMember` ss) ==>
 --   ss == swapWorkspaces t1 t2 ss
 
@@ -32,26 +32,14 @@ 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) (t1 :: NonNegative Int) (t2 :: NonNegative Int) =
+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
 
 -- swapWithCurrent stays on current
-prop_swap_with_current (ss :: T) (t :: NonNegative Int) =
+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
-
-main = do
-  putStrLn "Testing double swap"
-  quickCheck prop_double_swap
-  putStrLn "Testing invalid swap"
-  quickCheck prop_invalid_swap
-  -- putStrLn "Testing half-invalid swap"
-  -- quickCheck prop_half_invalid_swap
-  putStrLn "Testing swap only two"
-  quickCheck prop_swap_only_two
-  putStrLn "Testing swap with current"
-  quickCheck prop_swap_with_current

tests/Utils.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE RankNTypes #-}
+module Utils where -- copied from the core library
+
+import XMonad.StackSet hiding (filter)
+import Graphics.X11.Xlib.Types (Rectangle(..))
+import Data.List (sortBy)
+
+-- Useful operation, the non-local workspaces
+hidden_spaces :: StackSet i l a sid sd -> [Workspace i l a]
+hidden_spaces x = map workspace (visible x) ++ hidden x
+
+
+-- normalise workspace list
+normal :: Ord i => StackSet i l a s sd -> StackSet i l a s sd
+normal s = s { hidden = sortBy g (hidden s), visible = sortBy f (visible s) }
+    where
+        f a b = tag (workspace a) `compare` tag (workspace b)
+        g a b = tag a `compare` tag b
+
+
+noOverlaps :: [Rectangle] -> Bool
+noOverlaps []  = True
+noOverlaps [_] = True
+noOverlaps xs  = and [ verts a `notOverlap` verts b
+                     | a <- xs
+                     , b <- filter (a /=) xs
+                     ]
+    where
+      verts (Rectangle a b w h) = (a,b,a + fromIntegral w - 1, b + fromIntegral h - 1)
+
+      notOverlap (left1,bottom1,right1,top1)
+                 (left2,bottom2,right2,top2)
+        =  (top1 < bottom2 || top2 < bottom1)
+        || (right1 < left2 || right2 < left1)
+
+
+applyN :: (Integral n) => Maybe n -> (a -> a) -> a -> a
+applyN Nothing  _ v = v
+applyN (Just 0) _ v = v
+applyN (Just n) f v = applyN (Just $ n - 1) f (f v)
+
+tags :: StackSet i l a sid sd -> [i]
+tags x = map tag $ workspaces x
+
+
+-- | noOverflows op a b is True if @a `op` fromIntegral b@ overflows (or
+-- otherwise gives the same answer when done using Integer
+noOverflows :: (Integral b, Integral c) =>
+  (forall a. Integral a => a -> a -> a) -> b -> c -> Bool
+noOverflows op a b = toInteger (a `op` fromIntegral b) == toInteger a `op` toInteger b

tests/XPrompt.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 -------------------------------------
 --
 -- Tests for XPrompt and ShellPrompt
@@ -6,33 +7,18 @@
 -------------------------------------
 module XPrompt where
 
-import Data.Char
 import Test.QuickCheck
 
-import Data.List
-
 import XMonad.Prompt
 import qualified XMonad.Prompt.Shell as S
-import Properties
- 
-{-
-instance Arbitrary Char where
-    arbitrary     = choose ('\32', '\255')
-    coarbitrary c = variant (ord c `rem` 4)
-
--}
-
-doubleCheck p = check (defaultConfig { configMaxTest = 1000}) p
-deepCheck p = check (defaultConfig { configMaxTest = 10000}) p
-deepestCheck p = check (defaultConfig { configMaxTest = 100000}) p
 
 -- brute force check for exceptions
-prop_split (str :: [Char]) =
+prop_split (str :: String) =
     forAll (elements str) $ \e -> S.split e str == S.split e str
 
 -- check if the first element of the new list is indeed the first part
 -- of the string.
-prop_spliInSubListsAt (x :: Int) (str :: [Char]) =
+prop_spliInSubListsAt (x :: Int) (str :: String) =
     x < length str ==> result == take x str
     where result = case splitInSubListsAt x str of
                      [] -> []
@@ -41,14 +27,14 @@ prop_spliInSubListsAt (x :: Int) (str :: [Char]) =
 -- skipLastWord is complementary to getLastWord, unless the only space
 -- in the string is the final character, in which case skipLastWord
 -- and getLastWord will produce the same result.
-prop_skipGetLastWord (str :: [Char]) =
+prop_skipGetLastWord (str :: String) =
     skipLastWord str ++ getLastWord str == str || skipLastWord str == getLastWord str
 
 
 -- newIndex and newCommand get only non empy lists
 elemGen :: Gen ([String],String)
 elemGen = do
-  a <- arbitrary :: Gen [[Char]]
+  a <- arbitrary :: Gen [String]
   let l = case filter (/= []) a of
             [] -> ["a"]
             x -> x
@@ -67,15 +53,6 @@ prop_newIndex_range =
 -- this is actually the definition of newCommand...
 -- just to check something.
 {-
-prop_newCommandIndex = 
+prop_newCommandIndex =
     forAll elemGen $ \(l,c) -> (skipLastWord c ++ (l !! (newIndex c l)))  == newCommand c l
 -}
-
-main = do
-  putStrLn "Testing ShellPrompt.split"
-  deepCheck prop_split
-  putStrLn "Testing spliInSubListsAt"
-  deepCheck prop_spliInSubListsAt
-  putStrLn "Testing skip + get lastWord"
-  deepCheck prop_skipGetLastWord
-

tests/genMain.hs

@@ -1,66 +0,0 @@
-{-# LANGUAGE ViewPatterns #-}
-{- | generate another Main from all modules in the current directory,
-extracting all functions with @prop_@.
-
-Usage (your QuickCheck-1 version may vary):
-
-> ln -s ../../xmonad/tests/Properties.hs .
-> runghc genMain.hs > Main.hs
-> ghc -DTESTING -i.. -i. -package QuickCheck-1.2.0.0 Main.hs -e ':main 200'
-
--}
-module Main where
-
-import Control.Monad.List
-import Data.Char
-import Data.IORef
-import Data.List
-import qualified Data.Set as S
-import System.Directory
-import System.FilePath
-import Text.PrettyPrint.HughesPJ
-
-main = do
-    imports <- newIORef S.empty
-    props <- runListT $ do
-        f @ ((isUpper -> True) : (takeExtension -> ".hs"))
-            <- ListT (getDirectoryContents ".")
-        guard $ f `notElem` ["Main.hs", "Common.hs", "Properties.hs"]
-        let b = takeBaseName f
-        nesting <- io $ newIORef 0
-        decl : _ <- ListT $ (map words . lines) <$> readFile f
-        case decl of
-            "{-" -> io $ modifyIORef nesting succ
-            "-}" -> io $ modifyIORef nesting pred
-            _ -> return ()
-        0 <- io $ readIORef nesting
-        guard $ "prop_" `isPrefixOf` decl
-        io $ modifyIORef imports (S.insert b)
-        return (b ++ "." ++ decl)
-    imports <- S.toList <$> readIORef imports
-    print $ genModule imports props
-
-genModule :: [String] -> [String] -> Doc
-genModule imports props = vcat [header,imports', main ]
-    where
-        header = text "module Main where"
-        imports' = text "import Test.QuickCheck; import Data.Maybe; \
-                            \import System.Environment; import Text.Printf; \
-                            \import Properties hiding (main); import Control.Monad"
-                $$ vcat [ text "import qualified" <+> text im | im <- imports ]
-        props' = [ parens $ doubleQuotes (text p) <> comma <> text "mytest" <+> text p
-                            | p <- props ]
-        main = hang (text "main = do") 4 $
-                    text "n <- maybe (return 100) readIO . listToMaybe =<< getArgs"
-                    $$
-                    hang (text "let props = ") 8
-                        (brackets $ foldr1 (\x xs -> x <> comma $$ xs) props')
-                    $$
-                    text "(results, passed) <- fmap unzip $ \
-                            \mapM (\\(s,a) -> printf \"%-40s: \" s >> a n) props"
-                    $$
-                    text "printf \"Passed %d tests!\\n\" (sum passed)"
-                    $$
-                    text "when (any not results) $ fail \"Not all tests passed!\""
-
-io x = liftIO x

xmonad-contrib.cabal

@@ -25,7 +25,9 @@ extra-source-files: README.md CHANGES.md scripts/generate-configs scripts/run-xm
                     scripts/window-properties.sh
                     scripts/xinitrc scripts/xmonad-acpi.c
                     scripts/xmonad-clock.c
-                    tests/genMain.hs
+                    tests/Main.hs
+                    tests/Utils.hs
+                    tests/Instances.hs
                     tests/ManageDocks.hs
                     tests/RotateSome.hs
                     tests/Selective.hs
@@ -33,7 +35,7 @@ extra-source-files: README.md CHANGES.md scripts/generate-configs scripts/run-xm
                     tests/XPrompt.hs
                     XMonad/Config/dmwit.xmobarrc
                     XMonad/Config/Example.hs
-cabal-version:      >= 1.6
+cabal-version:      >= 1.8
 build-type:         Simple
 bug-reports:        https://github.com/xmonad/xmonad-contrib/issues
 
@@ -369,3 +371,29 @@ library
                         XMonad.Util.WorkspaceCompare
                         XMonad.Util.XSelection
                         XMonad.Util.XUtils
+
+test-suite properties
+  type:           exitcode-stdio-1.0
+  main-is:        Main.hs
+  other-modules:  ManageDocks
+                  RotateSome
+                  Selective
+                  SwapWorkspaces
+                  XPrompt
+                  Instances
+                  Utils
+  hs-source-dirs: tests
+  build-depends: base
+               , QuickCheck >= 2
+               , containers
+               , extensible-exceptions
+               , xmonad-contrib
+               , directory
+               , X11>=1.6.1 && < 1.10
+               , mtl
+               , process
+               , unix
+               , utf8-string
+               , xmonad >= 0.15 && < 0.16
+  ghc-options: -i.
+  cpp-options: -DTESTING