From 1f2f6239a5d942d2cd0f06aeec2d96ab05980600 Mon Sep 17 00:00:00 2001 From: Adam Vogt Date: Mon, 19 Apr 2010 03:49:46 +0200 Subject: Rearrange tests. See test/genMain.hs for instructions. Ignore-this: 1745e6f1052e84e40153b5b1c0a6e15a darcs-hash:20100419014946-1499c-4705ec3d27ad26df038a7d72e978e5a137d712b5.gz --- tests/Selective.hs | 87 ++++++++++++++++++++++++++++++++++++++++++++ tests/SwapWorkspaces.hs | 57 +++++++++++++++++++++++++++++ tests/XPrompt.hs | 81 +++++++++++++++++++++++++++++++++++++++++ tests/genMain.hs | 52 ++++++++++++++++++++++++++ tests/test_Selective.hs | 85 ------------------------------------------- tests/test_SwapWorkspaces.hs | 56 ---------------------------- tests/test_XPrompt.hs | 76 -------------------------------------- 7 files changed, 277 insertions(+), 217 deletions(-) create mode 100644 tests/Selective.hs create mode 100644 tests/SwapWorkspaces.hs create mode 100644 tests/XPrompt.hs create mode 100644 tests/genMain.hs delete mode 100644 tests/test_Selective.hs delete mode 100644 tests/test_SwapWorkspaces.hs delete mode 100644 tests/test_XPrompt.hs diff --git a/tests/Selective.hs b/tests/Selective.hs new file mode 100644 index 0000000..db00563 --- /dev/null +++ b/tests/Selective.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} +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 Control.Applicative ((<$>)) +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 +-- (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)) + where sel' = update sel stk + +-- update normalizes selections (is idempotent) +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) = + take (nMaster sel) (integrate stk) == take (nMaster sel) (integrate $ select sel stk) + +-- the focus should always be selected in normalized selections +prop_select_focus sel (stk :: Stack Int) = focus stk == (focus $ select sel' stk) + where sel' = update sel stk + +-- select doesn't change order (or duplicate elements) +-- relies on the Arbitrary instance for Stack Int generating increasing stacks +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 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 sel (stk :: Stack Int) = nMaster (update sel stk) >= 0 +prop_update_start sel (stk :: Stack Int) = nMaster sel' <= start sel' + where sel' = update sel stk +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 sel (stk :: Stack Int) x' = + (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 sel (stk :: Stack Int) x' = + (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 stk = stk { up=tail (up stk), focus=head (up stk), down=focus stk:down stk } +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 new file mode 100644 index 0000000..1cd33a0 --- /dev/null +++ b/tests/SwapWorkspaces.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module SwapWorkspaces where + +import Data.List(find,union) +import Data.Maybe(fromJust) +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) = + 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) = + 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) = +-- t1 `tagMember` ss && not (t2 `tagMember` ss) ==> +-- ss == swapWorkspaces t1 t2 ss + +zipWorkspacesWith :: (Workspace i l a -> Workspace i l a -> n) -> StackSet i l a s sd -> + StackSet i l a s sd -> [n] +zipWorkspacesWith f s t = f (workspace $ current s) (workspace $ current t) : + zipWith f (map workspace $ visible s) (map workspace $ visible 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) = + 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) = + 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/XPrompt.hs b/tests/XPrompt.hs new file mode 100644 index 0000000..9c8ca8c --- /dev/null +++ b/tests/XPrompt.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE ScopedTypeVariables #-} +------------------------------------- +-- +-- Tests for XPrompt and ShellPrompt +-- +------------------------------------- +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]) = + 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]) = + x < length str ==> result == take x str + where result = case splitInSubListsAt x str of + [] -> [] + x -> head x + +-- 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]) = + 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]] + let l = case filter (/= []) a of + [] -> ["a"] + x -> x + e <- elements l + return (l,e) + +{- newIndex and newCommand have since been renamed or are no longer used + +-- newIndex calculates the index of the next completion in the +-- completion list, so the index must be within the range of the +-- copletions list +prop_newIndex_range = + forAll elemGen $ \(l,c) -> newIndex c l >= 0 && newIndex c l < length l +-} + +-- this is actually the definition of newCommand... +-- just to check something. +{- +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 new file mode 100644 index 0000000..90d8224 --- /dev/null +++ b/tests/genMain.hs @@ -0,0 +1,52 @@ +{-# 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 + +-} +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) `fmap` 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 `fmap` 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" + $$ vcat [ text "import qualified" <+> text im | im <- imports ] + props' = vcat [ text "quickCheck" <+> text p | p <- props ] + main = hang (text "main = do") 4 props' + +io x = liftIO x diff --git a/tests/test_Selective.hs b/tests/test_Selective.hs deleted file mode 100644 index 186f904..0000000 --- a/tests/test_Selective.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} - --- 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 Control.Applicative ((<$>)) -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 --- (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)) - where sel' = update sel stk - --- update normalizes selections (is idempotent) -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) = - take (nMaster sel) (integrate stk) == take (nMaster sel) (integrate $ select sel stk) - --- the focus should always be selected in normalized selections -prop_select_focus sel (stk :: Stack Int) = focus stk == (focus $ select sel' stk) - where sel' = update sel stk - --- select doesn't change order (or duplicate elements) --- relies on the Arbitrary instance for Stack Int generating increasing stacks -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 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 sel (stk :: Stack Int) = nMaster (update sel stk) >= 0 -prop_update_start sel (stk :: Stack Int) = nMaster sel' <= start sel' - where sel' = update sel stk -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 sel (stk :: Stack Int) x' = - (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 sel (stk :: Stack Int) x' = - (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 stk = stk { up=tail (up stk), focus=head (up stk), down=focus stk:down stk } -focusDown stk = stk { down=tail (down stk), focus=head (down stk), up=focus stk:up stk } diff --git a/tests/test_SwapWorkspaces.hs b/tests/test_SwapWorkspaces.hs deleted file mode 100644 index 148ab97..0000000 --- a/tests/test_SwapWorkspaces.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -import Data.List(find,union) -import Data.Maybe(fromJust) -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) = - 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) = - 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) = --- t1 `tagMember` ss && not (t2 `tagMember` ss) ==> --- ss == swapWorkspaces t1 t2 ss - -zipWorkspacesWith :: (Workspace i l a -> Workspace i l a -> n) -> StackSet i l a s sd -> - StackSet i l a s sd -> [n] -zipWorkspacesWith f s t = f (workspace $ current s) (workspace $ current t) : - zipWith f (map workspace $ visible s) (map workspace $ visible 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) = - 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) = - 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/test_XPrompt.hs b/tests/test_XPrompt.hs deleted file mode 100644 index a4c6236..0000000 --- a/tests/test_XPrompt.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -------------------------------------- --- --- Tests for XPrompt and ShellPrompt --- -------------------------------------- - -import Data.Char -import Test.QuickCheck - -import Data.List - -import XMonad.Prompt -import qualified XMonad.Prompt.Shell as S - -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]) = - 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]) = - x < length str ==> result == take x str - where result = case splitInSubListsAt x str of - [] -> [] - x -> head x - --- 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]) = - 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]] - let l = case filter (/= []) a of - [] -> ["a"] - x -> x - e <- elements l - return (l,e) - -{- newIndex and newCommand have since been renamed or are no longer used - --- newIndex calculates the index of the next completion in the --- completion list, so the index must be within the range of the --- copletions list -prop_newIndex_range = - forAll elemGen $ \(l,c) -> newIndex c l >= 0 && newIndex c l < length l --} - --- this is actually the definition of newCommand... --- just to check something. -{- -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 - -- cgit v1.2.3