diff options
| -rw-r--r-- | Main.hs | 2 | ||||
| -rw-r--r-- | StackSet.hs | 70 | ||||
| -rw-r--r-- | XMonad.hs | 2 | ||||
| -rw-r--r-- | tests/Properties.hs | 30 |
4 files changed, 53 insertions, 51 deletions
@@ -52,7 +52,7 @@ main = do let winset | ("--resume" : s : _) <- args , [(x, "")] <- reads s = x - | otherwise = new workspaces $ zipWith SD xinesc gaps + | otherwise = new (fst safeLayouts) workspaces $ zipWith SD xinesc gaps gaps = take (length xinesc) $ defaultGaps ++ repeat (0,0,0,0) safeLayouts = case defaultLayouts of [] -> (SomeLayout Full, []); (x:xs) -> (x,xs) diff --git a/StackSet.hs b/StackSet.hs index e6c2433..611c7f2 100644 --- a/StackSet.hs +++ b/StackSet.hs @@ -147,23 +147,23 @@ import qualified Data.Map as M (Map,insert,delete,empty) -- that are produced are used to track those workspaces visible as -- Xinerama screens, and those workspaces not visible anywhere. -data StackSet i a sid sd = - StackSet { current :: !(Screen i a sid sd) -- ^ currently focused workspace - , visible :: [Screen i a sid sd] -- ^ non-focused workspaces, visible in xinerama - , hidden :: [Workspace i a] -- ^ workspaces not visible anywhere +data StackSet i l a sid sd = + StackSet { current :: !(Screen i l a sid sd) -- ^ currently focused workspace + , visible :: [Screen i l a sid sd] -- ^ non-focused workspaces, visible in xinerama + , hidden :: [Workspace i l a] -- ^ workspaces not visible anywhere , floating :: M.Map a RationalRect -- ^ floating windows } deriving (Show, Read, Eq) -- | Visible workspaces, and their Xinerama screens. -data Screen i a sid sd = Screen { workspace :: !(Workspace i a) - , screen :: !sid - , screenDetail :: !sd } +data Screen i l a sid sd = Screen { workspace :: !(Workspace i l a) + , screen :: !sid + , screenDetail :: !sd } deriving (Show, Read, Eq) -- | -- A workspace is just a tag - its index - and a stack -- -data Workspace i a = Workspace { tag :: !i, stack :: StackOrNot a } +data Workspace i l a = Workspace { tag :: !i, layout :: l, stack :: StackOrNot a } deriving (Show, Read, Eq) data RationalRect = RationalRect Rational Rational Rational Rational @@ -208,12 +208,12 @@ abort x = error $ "xmonad: StackSet: " ++ x -- -- Xinerama: Virtual workspaces are assigned to physical screens, starting at 0. -- -new :: (Integral s) => [i] -> [sd] -> StackSet i a s sd -new wids m | not (null wids) && length m <= length wids = StackSet cur visi unseen M.empty - where (seen,unseen) = L.splitAt (length m) $ map (flip Workspace Nothing) wids +new :: (Integral s) => l -> [i] -> [sd] -> StackSet i l a s sd +new l wids m | not (null wids) && length m <= length wids = StackSet cur visi unseen M.empty + where (seen,unseen) = L.splitAt (length m) $ map (\i -> Workspace i l Nothing) wids (cur:visi) = [ Screen i s sd | (i, s, sd) <- zip3 seen [0..] m ] -- now zip up visibles with their screen id -new _ _ = abort "non-positive argument to StackSet.new" +new _ _ _ = abort "non-positive argument to StackSet.new" @@ -225,7 +225,7 @@ new _ _ = abort "non-positive argument to StackSet.new" -- becomes the current screen. If it is in the visible list, it becomes -- current. -view :: (Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd +view :: (Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd view i s | not (i `tagMember` s) || i == tag (workspace (current s)) = s -- out of bounds or current @@ -254,7 +254,7 @@ view i s -- screen, the workspaces of the current screen and the other screen are -- swapped. -greedyView :: (Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd +greedyView :: (Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd greedyView w ws | any wTag (hidden ws) = view w ws | (Just s) <- L.find (wTag . workspace) (visible ws) @@ -270,7 +270,7 @@ greedyView w ws -- | Find the tag of the workspace visible on Xinerama screen 'sc'. -- Nothing if screen is out of bounds. -lookupWorkspace :: Eq s => s -> StackSet i a s sd -> Maybe i +lookupWorkspace :: Eq s => s -> StackSet i l a s sd -> Maybe i lookupWorkspace sc w = listToMaybe [ tag i | Screen i s _ <- current w : visible w, s == sc ] -- --------------------------------------------------------------------- @@ -282,13 +282,13 @@ lookupWorkspace sc w = listToMaybe [ tag i | Screen i s _ <- current w : visible -- default value. Otherwise, it applies the function to the stack, -- returning the result. It is like 'maybe' for the focused workspace. -- -with :: b -> (Stack a -> b) -> StackSet i a s sd -> b +with :: b -> (Stack a -> b) -> StackSet i l a s sd -> b with dflt f = maybe dflt f . stack . workspace . current -- | -- Apply a function, and a default value for Nothing, to modify the current stack. -- -modify :: StackOrNot a -> (Stack a -> StackOrNot a) -> StackSet i a s sd -> StackSet i a s sd +modify :: StackOrNot a -> (Stack a -> StackOrNot a) -> StackSet i l a s sd -> StackSet i l a s sd modify d f s = s { current = (current s) { workspace = (workspace (current s)) { stack = with d f s }}} @@ -296,14 +296,14 @@ modify d f s = s { current = (current s) -- Apply a function to modify the current stack if it isn't empty, and we don't -- want to empty it. -- -modify' :: (Stack a -> Stack a) -> StackSet i a s sd -> StackSet i a s sd +modify' :: (Stack a -> Stack a) -> StackSet i l a s sd -> StackSet i l a s sd modify' f = modify Nothing (Just . f) -- | -- /O(1)/. Extract the focused element of the current stack. -- Return Just that element, or Nothing for an empty stack. -- -peek :: StackSet i a s sd -> Maybe a +peek :: StackSet i l a s sd -> Maybe a peek = with Nothing (return . focus) -- | @@ -341,7 +341,7 @@ filter p (Stack f ls rs) = case L.filter p (f:rs) of -- the head of the list. The implementation is given by the natural -- integration of a one-hole list cursor, back to a list. -- -index :: StackSet i a s sd -> [a] +index :: StackSet i l a s sd -> [a] index = with [] integrate -- let is = t : r ++ reverse l in take (length is) (dropWhile (/= m) (cycle is)) @@ -358,7 +358,7 @@ index = with [] integrate -- if we reach the end. Again the wrapping model should 'cycle' on -- the current stack. -- -focusUp, focusDown, swapUp, swapDown :: StackSet i a s sd -> StackSet i a s sd +focusUp, focusDown, swapUp, swapDown :: StackSet i l a s sd -> StackSet i l a s sd focusUp = modify' focusUp' focusDown = modify' (reverseStack . focusUp' . reverseStack) @@ -380,7 +380,7 @@ reverseStack (Stack t ls rs) = Stack t rs ls -- | /O(1) on current window, O(n) in general/. Focus the window 'w', -- and set its workspace as current. -- -focusWindow :: (Eq s, Eq a, Eq i) => a -> StackSet i a s sd -> StackSet i a s sd +focusWindow :: (Eq s, Eq a, Eq i) => a -> StackSet i l a s sd -> StackSet i l a s sd focusWindow w s | Just w == peek s = s | otherwise = maybe s id $ do n <- findIndex w s @@ -393,11 +393,11 @@ screens :: StackSet i a s sd -> [Screen i a s sd] screens s = current s : visible s -- | Get a list of all workspaces in the StackSet. -workspaces :: StackSet i a s sd -> [Workspace i a] +workspaces :: StackSet i l a s sd -> [Workspace i l a] workspaces s = workspace (current s) : map workspace (visible s) ++ hidden s -- | Is the given tag present in the StackSet? -tagMember :: Eq i => i -> StackSet i a s sd -> Bool +tagMember :: Eq i => i -> StackSet i l a s sd -> Bool tagMember t = elem t . map tag . workspaces -- | @@ -406,13 +406,13 @@ tagMember t = elem t . map tag . workspaces -- -- | /O(n)/. Is a window in the StackSet. -member :: Eq a => a -> StackSet i a s sd -> Bool +member :: Eq a => a -> StackSet i l a s sd -> Bool member a s = maybe False (const True) (findIndex a s) -- | /O(1) on current window, O(n) in general/. -- Return Just the workspace index of the given window, or Nothing -- if the window is not in the StackSet. -findIndex :: Eq a => a -> StackSet i a s sd -> Maybe i +findIndex :: Eq a => a -> StackSet i l a s sd -> Maybe i findIndex a s = listToMaybe [ tag w | w <- workspaces s, has a (stack w) ] where has _ Nothing = False @@ -435,11 +435,11 @@ findIndex a s = listToMaybe -- Semantics in Huet's paper is that insert doesn't move the cursor. -- However, we choose to insert above, and move the focus. -- -insertUp :: Eq a => a -> StackSet i a s sd -> StackSet i a s sd +insertUp :: Eq a => a -> StackSet i l a s sd -> StackSet i l a s sd insertUp a s = if member a s then s else insert where insert = modify (Just $ Stack a [] []) (\(Stack t l r) -> Just $ Stack a l (t:r)) s --- insertDown :: a -> StackSet i a s sd -> StackSet i a s sd +-- insertDown :: a -> StackSet i l a s sd -> StackSet i l a s sd -- insertDown a = modify (Stack a [] []) $ \(Stack t l r) -> Stack a (t:l) r -- Old semantics, from Huet. -- > w { down = a : down w } @@ -458,12 +458,12 @@ insertUp a s = if member a s then s else insert -- * deleting the master window resets it to the newly focused window -- * otherwise, delete doesn't affect the master. -- -delete :: (Ord a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd +delete :: (Ord a, Eq s) => a -> StackSet i l a s sd -> StackSet i l a s sd delete w = sink w . delete' w -- | Only temporarily remove the window from the stack, thereby not destroying special -- information saved in the Stackset -delete' :: (Eq a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd +delete' :: (Eq a, Eq s) => a -> StackSet i l a s sd -> StackSet i l a s sd delete' w s = s { current = removeFromScreen (current s) , visible = map removeFromScreen (visible s) , hidden = map removeFromWorkspace (hidden s) } @@ -474,11 +474,11 @@ delete' w s = s { current = removeFromScreen (current s) -- | Given a window, and its preferred rectangle, set it as floating -- A floating window should already be managed by the StackSet. -float :: Ord a => a -> RationalRect -> StackSet i a s sd -> StackSet i a s sd +float :: Ord a => a -> RationalRect -> StackSet i l a s sd -> StackSet i l a s sd float w r s = s { floating = M.insert w r (floating s) } -- | Clear the floating status of a window -sink :: Ord a => a -> StackSet i a s sd -> StackSet i a s sd +sink :: Ord a => a -> StackSet i l a s sd -> StackSet i l a s sd sink w s = s { floating = M.delete w (floating s) } ------------------------------------------------------------------------ @@ -487,7 +487,7 @@ sink w s = s { floating = M.delete w (floating s) } -- | /O(s)/. Set the master window to the focused window. -- The old master window is swapped in the tiling order with the focused window. -- Focus stays with the item moved. -swapMaster :: StackSet i a s sd -> StackSet i a s sd +swapMaster :: StackSet i l a s sd -> StackSet i l a s sd swapMaster = modify' $ \c -> case c of Stack _ [] _ -> c -- already master. Stack t ls rs -> Stack t [] (xs ++ x : rs) where (x:xs) = reverse ls @@ -510,7 +510,7 @@ focusMaster = modify' $ \c -> case c of -- The actual focused workspace doesn't change. If there is -- no -- element on the current stack, the original stackSet is returned. -- -shift :: (Ord a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd +shift :: (Ord a, Eq s, Eq i) => i -> StackSet i l a s sd -> StackSet i l a s sd shift n s | n `tagMember` s && n /= curtag = maybe s go (peek s) | otherwise = s where go w = view curtag . insertUp w . view n . delete' w $ s @@ -523,7 +523,7 @@ shift n s | n `tagMember` s && n /= curtag = maybe s go (peek s) -- The actual focused workspace doesn't change. If the window is not -- found in the stackSet, the original stackSet is returned. -- TODO how does this duplicate 'shift's behaviour? -shiftWin :: (Ord a, Eq a, Eq s, Eq i) => i -> a -> StackSet i a s sd -> StackSet i a s sd +shiftWin :: (Ord a, Eq a, Eq s, Eq i) => i -> a -> StackSet i l a s sd -> StackSet i l a s sd shiftWin n w s | from == Nothing = s | n `tagMember` s && (Just n) /= from = go | otherwise = s @@ -52,7 +52,7 @@ data XConf = XConf , normalBorder :: !Pixel -- ^ border color of unfocused windows , focusedBorder :: !Pixel } -- ^ border color of the focused window -type WindowSet = StackSet WorkspaceId Window ScreenId ScreenDetail +type WindowSet = StackSet WorkspaceId (SomeLayout Window) Window ScreenId ScreenDetail -- | Virtual workspace indicies type WorkspaceId = String diff --git a/tests/Properties.hs b/tests/Properties.hs index 0f4b733..8256c45 100644 --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -34,12 +34,13 @@ import qualified Data.Map as M -- -- The all important Arbitrary instance for StackSet. -- -instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary sd) - => Arbitrary (StackSet i a s sd) where +instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary l, Arbitrary sd) + => Arbitrary (StackSet i l a s sd) where arbitrary = do sz <- choose (1,10) -- number of workspaces n <- choose (0,sz-1) -- pick one to be in focus sc <- choose (1,sz) -- a number of physical screens + lay <- arbitrary -- pick any layout sds <- replicateM sc arbitrary ls <- vector sz -- a vector of sz workspaces @@ -48,7 +49,7 @@ instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary sd) else liftM Just (choose ((-1),length s-1)) | s <- ls ] - return $ fromList (fromIntegral n, sds,fs,ls) + return $ fromList (fromIntegral n, sds,fs,ls,lay) coarbitrary = error "no coarbitrary for StackSet" @@ -62,14 +63,14 @@ instance (Integral i, Integral s, Eq a, Arbitrary a, Arbitrary sd) -- 'fs' random focused window on each workspace -- 'xs' list of list of windows -- -fromList :: (Integral i, Integral s, Eq a) => (i, [sd], [Maybe Int], [[a]]) -> StackSet i a s sd -fromList (_,_,_,[]) = error "Cannot build a StackSet from an empty list" +fromList :: (Integral i, Integral s, Eq a) => (i, [sd], [Maybe Int], [[a]], l) -> StackSet i l a s sd +fromList (_,_,_,[],_) = error "Cannot build a StackSet from an empty list" -fromList (o,m,fs,xs) = +fromList (o,m,fs,xs,l) = let s = view o $ foldr (\(i,ys) s -> foldr insertUp (view i s) ys) - (new [0..genericLength xs-1] m) (zip [0..] xs) + (new l [0..genericLength xs-1] m) (zip [0..] xs) in foldr (\f t -> case f of Nothing -> t Just i -> foldr (const focusUp) t [0..i] ) s fs @@ -79,7 +80,7 @@ fromList (o,m,fs,xs) = -- -- Just generate StackSets with Char elements. -- -type T = StackSet (NonNegative Int) Char Int Int +type T = StackSet (NonNegative Int) Int Char Int Int -- Useful operation, the non-local workspaces hidden_spaces x = map workspace (visible x) ++ hidden x @@ -129,9 +130,9 @@ monotonic (x:y:zs) | x == y-1 = monotonic (y:zs) prop_invariant = invariant -- and check other ops preserve invariants -prop_empty_I (n :: Positive Int) = forAll (choose (1,fromIntegral n)) $ \m -> - forAll (vector m) $ \ms -> - invariant $ new [0..fromIntegral n-1] ms +prop_empty_I (n :: Positive Int) l = forAll (choose (1,fromIntegral n)) $ \m -> + forAll (vector m) $ \ms -> + invariant $ new l [0..fromIntegral n-1] ms prop_view_I (n :: NonNegative Int) (x :: T) = n `tagMember` x ==> invariant $ view (fromIntegral n) x @@ -182,11 +183,11 @@ prop_empty (EmptyStackSet x) = : map workspace (visible x) ++ hidden x ] -- empty StackSets always have focus on first workspace -prop_empty_current (NonEmptyNubList ns) (NonEmptyNubList sds) = +prop_empty_current (NonEmptyNubList ns) (NonEmptyNubList sds) l = -- TODO, this is ugly length sds <= length ns ==> tag (workspace $ current x) == head ns - where x = new ns sds :: T + where x = new l ns sds :: T -- no windows will be a member of an empty workspace prop_member_empty i (EmptyStackSet x) @@ -844,8 +845,9 @@ instance Arbitrary EmptyStackSet where arbitrary = do (NonEmptyNubList ns) <- arbitrary (NonEmptyNubList sds) <- arbitrary + l <- arbitrary -- there cannot be more screens than workspaces: - return . EmptyStackSet . new ns $ take (min (length ns) (length sds)) sds + return . EmptyStackSet . new l ns $ take (min (length ns) (length sds)) sds -- | Generates a value that satisfies a predicate. suchThat :: Gen a -> (a -> Bool) -> Gen a |