diff --git a/tests/Instances.hs b/tests/Instances.hs new file mode 100644 index 00000000..a8d24cbb --- /dev/null +++ b/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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 index 00000000..4c761289 --- /dev/null +++ b/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) + ] diff --git a/tests/ManageDocks.hs b/tests/ManageDocks.hs index cefcb07a..8a538539 100644 --- a/tests/ManageDocks.hs +++ b/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 diff --git a/tests/RotateSome.hs b/tests/RotateSome.hs index 6ca3b9bb..d647ccb9 100644 --- a/tests/RotateSome.hs +++ b/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 diff --git a/tests/Selective.hs b/tests/Selective.hs index cdef57a0..940def10 100644 --- a/tests/Selective.hs +++ b/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 } diff --git a/tests/SwapWorkspaces.hs b/tests/SwapWorkspaces.hs index 1cd33a07..1a70c030 100644 --- a/tests/SwapWorkspaces.hs +++ b/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 diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 index 00000000..fb4f8f50 --- /dev/null +++ b/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 diff --git a/tests/XPrompt.hs b/tests/XPrompt.hs index 9c8ca8ce..dff8099a 100644 --- a/tests/XPrompt.hs +++ 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 - diff --git a/tests/genMain.hs b/tests/genMain.hs deleted file mode 100644 index a64687c5..00000000 --- a/tests/genMain.hs +++ /dev/null @@ -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 diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 92d912a1..c5e9eb10 100644 --- a/xmonad-contrib.cabal +++ b/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