diff options
| -rw-r--r-- | StackSet.hs | 8 | ||||
| -rw-r--r-- | XMonad.hs | 1 | ||||
| -rw-r--r-- | tests/Properties.hs | 127 |
3 files changed, 132 insertions, 4 deletions
diff --git a/StackSet.hs b/StackSet.hs index 5dc95b1..07a8424 100644 --- a/StackSet.hs +++ b/StackSet.hs @@ -25,7 +25,7 @@ module StackSet ( screen, peekStack, index, empty, peek, push, delete, member, raiseFocus, rotate, promote, shift, view, workspace, fromList, - toList, size, visibleWorkspaces + toList, size, visibleWorkspaces, swap {- helper -} ) where import Data.Maybe @@ -219,12 +219,16 @@ promote :: (Integral i, Ord a) => StackSet i j a -> StackSet i j a promote w = maybe w id $ do a <- peek w -- fail if null let w' = w { stacks = M.adjust (\s -> swap a (head s) s) (current w) (stacks w) } - return $ insert a (current w) w' -- and maintain focus + return $ insert a (current w) w' -- and maintain focus (?) -- -- | Swap first occurences of 'a' and 'b' in list. -- If both elements are not in the list, the list is unchanged. -- +-- Given a set as a list (no duplicates) +-- +-- > swap a b . swap a b == id +-- swap :: Eq a => a -> a -> [a] -> [a] swap a b xs | a == b = xs -- do nothing @@ -1,3 +1,4 @@ +{-# OPTIONS -fglasgow-exts #-} ----------------------------------------------------------------------------- -- | -- Module : XMonad.hs diff --git a/tests/Properties.hs b/tests/Properties.hs index 7eefe67..c3d58b6 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -1,7 +1,12 @@ {-# OPTIONS -fglasgow-exts #-} import StackSet +import Operations (tile,vtile) +import Debug.Trace +import Data.Word +import Graphics.X11.Xlib.Types (Rectangle(..),Position,Dimension) +import Data.Ratio import Data.Maybe import System.Environment import Control.Exception (assert) @@ -58,15 +63,31 @@ prop_peekmember x = case peek x of Nothing -> True {- then we don't know anything -} where _ = x :: T +prop_peek_peekStack n x = + if current x == n then peekStack n x == peek x + else True -- so we don't exhaust + where _ = x :: T + +prop_notpeek_peekStack n x = current x /= n && isJust (peek x) ==> peekStack n x /= peek x + where _ = x :: T + +------------------------------------------------------------------------ + type T = StackSet Int Int Int prop_delete_uniq i x = not (member i x) ==> delete i x == x where _ = x :: T +prop_delete_push i x = not (member i x) ==> delete i (push i x) == x + where _ = x :: T + prop_delete2 i x = delete i x == delete i (delete i x) where _ = x :: T +prop_focus1 i x = member i x ==> peek (raiseFocus i x) == Just i + where _ = x :: T + prop_rotaterotate x = rotate LT (rotate GT x) == x where _ = x :: T @@ -103,6 +124,10 @@ prop_screenworkspace x = all test [0..((fromIntegral $ size x)-1)] Nothing -> True Just sc -> workspace sc x == Just ws _ = x :: T + +prop_swap a b xs = swap a b (swap a b ys) == ys + where ys = nub xs :: [Int] + ------------------------------------------------------------------------ -- promote is idempotent @@ -110,11 +135,15 @@ prop_promote2 x = promote (promote x) == (promote x) where _ = x :: T -- focus doesn't change -prop_promotefocus x = focus (promote x) == focus x +prop_promotefocus x = focus (promote x) == focus x where _ = x :: T -- screen certainly should't change -prop_promotecurrent x = current (promote x) == current x +prop_promotecurrent x = current (promote x) == current x + where _ = x :: T + +-- the physical screen doesn't change +prop_promotescreen n x = screen n (promote x) == screen n x where _ = x :: T -- promote doesn't mess with other windows @@ -123,6 +152,79 @@ prop_promoterotate x b = focus (rotate dir (promote x)) == focus (rotate dir x) dir = if b then LT else GT ------------------------------------------------------------------------ +-- some properties for layouts: + +-- 1 window should always be tiled fullscreen +prop_tile_fullscreen rect = tile pct rect [1] == [(1, rect)] + +prop_vtile_fullscreen rect = vtile pct rect [1] == [(1, rect)] + +-- multiple windows +prop_tile_non_overlap rect windows = noOverlaps (tile pct rect windows) + where _ = rect :: Rectangle + +prop_vtile_non_overlap rect windows = noOverlaps (vtile pct rect windows) + where _ = rect :: Rectangle + +pct = 3 % 100 + +noOverlaps [] = True +noOverlaps [_] = True +noOverlaps xs = and [ verts a `notOverlap` verts b + | (_,a) <- xs + , (_,b) <- filter (\(_,b) -> a /= b) 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) + + +------------------------------------------------------------------------ + +instance Random Word8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Arbitrary Word8 where + arbitrary = choose (minBound,maxBound) + coarbitrary n = variant (fromIntegral ((fromIntegral n) `rem` 4)) + +integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) +integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, + fromIntegral b :: Integer) g of + (x,g) -> (fromIntegral x, g) + +instance Arbitrary Position where + arbitrary = do n <- arbitrary :: Gen Word8 + return (fromIntegral n) + coarbitrary = undefined + +instance Arbitrary Dimension where + arbitrary = do n <- arbitrary :: Gen Word8 + return (fromIntegral n) + coarbitrary = undefined + +instance Arbitrary Rectangle where + arbitrary = do + sx <- arbitrary + sy <- arbitrary + sw <- arbitrary + sh <- arbitrary + return $ Rectangle sx sy sw sh + +instance Arbitrary Rational where + arbitrary = do + n <- arbitrary + d' <- arbitrary + let d = if d' == 0 then 1 else d' + return (n % d) + coarbitrary = undefined + +------------------------------------------------------------------------ main :: IO () main = do @@ -134,16 +236,27 @@ main = do tests = [("read.show ", mytest prop_id) + ,("member/push ", mytest prop_member1) ,("member/peek ", mytest prop_peekmember) ,("member/delete ", mytest prop_member2) ,("member/empty ", mytest prop_member3) + ,("size/push ", mytest prop_sizepush) ,("height/push ", mytest prop_currentpush) ,("push/peek ", mytest prop_pushpeek) + + ,("peek/peekStack" , mytest prop_peek_peekStack) + ,("not . peek/peekStack", mytest prop_notpeek_peekStack) + ,("delete/not.member", mytest prop_delete_uniq) ,("delete idempotent", mytest prop_delete2) + ,("delete.push identity" , mytest prop_delete_push) + + ,("focus", mytest prop_focus1) + ,("rotate/rotate ", mytest prop_rotaterotate) + ,("view/view ", mytest prop_viewview) ,("fullcache ", mytest prop_fullcache) ,("currentwsvisible ", mytest prop_currentwsvisible) @@ -154,6 +267,16 @@ main = do ,("promote focus", mytest prop_promotefocus) ,("promote current", mytest prop_promotecurrent) ,("promote only swaps", mytest prop_promoterotate) + ,("promote/screen" , mytest prop_promotescreen) + + ,("swap", mytest prop_swap) + +------------------------------------------------------------------------ + + ,("tile 1 window fullsize", mytest prop_tile_fullscreen) + ,("vtile 1 window fullsize", mytest prop_vtile_fullscreen) + ,("vtiles never overlap", mytest prop_vtile_non_overlap ) + ] debug = False |