diff options
Diffstat (limited to 'XMonad/Operations.hs')
| -rw-r--r-- | XMonad/Operations.hs | 505 |
1 files changed, 505 insertions, 0 deletions
diff --git a/XMonad/Operations.hs b/XMonad/Operations.hs new file mode 100644 index 0000000..dc2d090 --- /dev/null +++ b/XMonad/Operations.hs @@ -0,0 +1,505 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fglasgow-exts #-} -- For deriving Data/Typeable +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} + +-- -------------------------------------------------------------------------- +-- | +-- Module : Operations.hs +-- Copyright : (c) Spencer Janssen 2007 +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : unstable +-- Portability : not portable, Typeable deriving, mtl, posix +-- +-- Operations. +-- +----------------------------------------------------------------------------- + +module XMonad.Operations where + +import XMonad +import XMonad.Layouts (Full(..)) +import qualified XMonad.StackSet as W + +import Data.Maybe +import Data.List (nub, (\\), find) +import Data.Bits ((.|.), (.&.), complement) +import Data.Ratio +import qualified Data.Map as M +import qualified Data.Set as S + +import Control.Monad.State +import Control.Monad.Reader + +import System.IO +import Graphics.X11.Xlib +import Graphics.X11.Xinerama (getScreenInfo) +import Graphics.X11.Xlib.Extras + +-- --------------------------------------------------------------------- +-- | +-- Window manager operations +-- manage. Add a new window to be managed in the current workspace. +-- Bring it into focus. +-- +-- Whether the window is already managed, or not, it is mapped, has its +-- border set, and its event mask set. +-- +manage :: Window -> X () +manage w = whenX (fmap not $ isClient w) $ withDisplay $ \d -> do + sh <- io $ getWMNormalHints d w + + let isFixedSize = sh_min_size sh /= Nothing && sh_min_size sh == sh_max_size sh + isTransient <- isJust `liftM` io (getTransientForHint d w) + + (sc, rr) <- floatLocation w + -- ensure that float windows don't go over the edge of the screen + let adjust (W.RationalRect x y wid h) | x + wid > 1 || y + h > 1 || x < 0 || y < 0 + = W.RationalRect (0.5 - wid/2) (0.5 - h/2) wid h + adjust r = r + + f ws | isFixedSize || isTransient = W.float w (adjust rr) . W.insertUp w . W.view i $ ws + | otherwise = W.insertUp w ws + where i = fromMaybe (W.tag . W.workspace . W.current $ ws) $ W.lookupWorkspace sc ws + + n <- fmap (fromMaybe "") $ io $ fetchName d w + (ClassHint rn rc) <- io $ getClassHint d w + mh <- asks (manageHook . config) + g <- mh w n rn rc `catchX` return id + windows (g . f) + +-- | unmanage. A window no longer exists, remove it from the window +-- list, on whatever workspace it is. +-- +-- should also unmap? +-- +unmanage :: Window -> X () +unmanage w = do + windows (W.delete w) + setWMState w withdrawnState + modify (\s -> s {mapped = S.delete w (mapped s), waitingUnmap = M.delete w (waitingUnmap s)}) + +-- | Modify the size of the status gap at the top of the current screen +-- Taking a function giving the current screen, and current geometry. +modifyGap :: (Int -> (Int,Int,Int,Int) -> (Int,Int,Int,Int)) -> X () +modifyGap f = do + windows $ \ws@(W.StackSet { W.current = c@(W.Screen { W.screenDetail = sd }) }) -> + let n = fromIntegral . W.screen $ c + g = f n . statusGap $ sd + in ws { W.current = c { W.screenDetail = sd { statusGap = g } } } + +-- | Kill the currently focused client. If we do kill it, we'll get a +-- delete notify back from X. +-- +-- There are two ways to delete a window. Either just kill it, or if it +-- supports the delete protocol, send a delete event (e.g. firefox) +-- +kill :: X () +kill = withDisplay $ \d -> withFocused $ \w -> do + wmdelt <- atom_WM_DELETE_WINDOW ; wmprot <- atom_WM_PROTOCOLS + + protocols <- io $ getWMProtocols d w + io $ if wmdelt `elem` protocols + then allocaXEvent $ \ev -> do + setEventType ev clientMessage + setClientMessageEvent ev w wmprot 32 wmdelt 0 + sendEvent d w False noEventMask ev + else killClient d w >> return () + +-- --------------------------------------------------------------------- +-- Managing windows + +-- | windows. Modify the current window list with a pure function, and refresh +windows :: (WindowSet -> WindowSet) -> X () +windows f = do + XState { windowset = old } <- get + let oldvisible = concatMap (W.integrate' . W.stack . W.workspace) $ W.current old : W.visible old + ws = f old + XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask + mapM_ setInitialProperties (W.allWindows ws \\ W.allWindows old) + whenJust (W.peek old) $ \otherw -> io $ setWindowBorder d otherw nbc + modify (\s -> s { windowset = ws }) + + -- notify non visibility + let tags_oldvisible = map (W.tag . W.workspace) $ W.current old : W.visible old + gottenhidden = filter (`elem` tags_oldvisible) $ map W.tag $ W.hidden ws + sendMessageToWorkspaces Hide gottenhidden + + -- for each workspace, layout the currently visible workspaces + let allscreens = W.screens ws + summed_visible = scanl (++) [] $ map (W.integrate' . W.stack . W.workspace) allscreens + visible <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do + let n = W.tag (W.workspace w) + this = W.view n ws + l = W.layout (W.workspace w) + flt = filter (flip M.member (W.floating ws)) (W.index this) + tiled = (W.stack . W.workspace . W.current $ this) + >>= W.filter (`M.notMember` W.floating ws) + >>= W.filter (`notElem` vis) + (SD (Rectangle sx sy sw sh) + (gt,gb,gl,gr)) = W.screenDetail w + viewrect = Rectangle (sx + fromIntegral gl) (sy + fromIntegral gt) + (sw - fromIntegral (gl + gr)) (sh - fromIntegral (gt + gb)) + + -- just the tiled windows: + -- now tile the windows on this workspace, modified by the gap + (rs, ml') <- runLayout l viewrect tiled `catchX` runLayout (Layout Full) viewrect tiled + mapM_ (uncurry tileWindow) rs + whenJust ml' $ \l' -> runOnWorkspaces (\ww -> if W.tag ww == n + then return $ ww { W.layout = l'} + else return ww) + + -- now the floating windows: + -- move/resize the floating windows, if there are any + forM_ flt $ \fw -> whenJust (M.lookup fw (W.floating ws)) $ + \(W.RationalRect rx ry rw rh) -> do + tileWindow fw $ Rectangle + (sx + floor (toRational sw*rx)) (sy + floor (toRational sh*ry)) + (floor (toRational sw*rw)) (floor (toRational sh*rh)) + + let vs = flt ++ map fst rs + io $ restackWindows d vs + -- return the visible windows for this workspace: + return vs + + whenJust (W.peek ws) $ \w -> io $ setWindowBorder d w fbc + setTopFocus + asks (logHook . config) >>= userCode + -- io performGC -- really helps, but seems to trigger GC bugs? + + -- hide every window that was potentially visible before, but is not + -- given a position by a layout now. + mapM_ hide (nub oldvisible \\ visible) + + clearEvents enterWindowMask + +-- | setWMState. set the WM_STATE property +setWMState :: Window -> Int -> X () +setWMState w v = withDisplay $ \dpy -> do + a <- atom_WM_STATE + io $ changeProperty32 dpy w a a propModeReplace [fromIntegral v, fromIntegral none] + +-- | hide. Hide a window by unmapping it, and setting Iconified. +hide :: Window -> X () +hide w = whenX (gets (S.member w . mapped)) $ withDisplay $ \d -> do + io $ do selectInput d w (clientMask .&. complement structureNotifyMask) + unmapWindow d w + selectInput d w clientMask + setWMState w iconicState + -- this part is key: we increment the waitingUnmap counter to distinguish + -- between client and xmonad initiated unmaps. + modify (\s -> s { waitingUnmap = M.insertWith (+) w 1 (waitingUnmap s) + , mapped = S.delete w (mapped s) }) + +-- | reveal. Show a window by mapping it and setting Normal +-- this is harmless if the window was already visible +reveal :: Window -> X () +reveal w = withDisplay $ \d -> do + setWMState w normalState + io $ mapWindow d w + modify (\s -> s { mapped = S.insert w (mapped s) }) + +-- | The client events that xmonad is interested in +clientMask :: EventMask +clientMask = structureNotifyMask .|. enterWindowMask .|. propertyChangeMask + +-- | Set some properties when we initially gain control of a window +setInitialProperties :: Window -> X () +setInitialProperties w = asks normalBorder >>= \nb -> withDisplay $ \d -> do + setWMState w iconicState + io $ selectInput d w $ clientMask + bw <- asks (borderWidth . config) + io $ setWindowBorderWidth d w bw + -- we must initially set the color of new windows, to maintain invariants + -- required by the border setting in 'windows' + io $ setWindowBorder d w nb + +-- | refresh. Render the currently visible workspaces, as determined by +-- the StackSet. Also, set focus to the focused window. +-- +-- This is our 'view' operation (MVC), in that it pretty prints our model +-- with X calls. +-- +refresh :: X () +refresh = windows id + +-- | clearEvents. Remove all events of a given type from the event queue. +clearEvents :: EventMask -> X () +clearEvents mask = withDisplay $ \d -> io $ do + sync d False + allocaXEvent $ \p -> fix $ \again -> do + more <- checkMaskEvent d mask p + when more again -- beautiful + +-- | tileWindow. Moves and resizes w such that it fits inside the given +-- rectangle, including its border. +tileWindow :: Window -> Rectangle -> X () +tileWindow w r = withDisplay $ \d -> do + bw <- (fromIntegral . wa_border_width) `fmap` io (getWindowAttributes d w) + -- give all windows at least 1x1 pixels + let least x | x <= bw*2 = 1 + | otherwise = x - bw*2 + io $ moveResizeWindow d w (rect_x r) (rect_y r) + (least $ rect_width r) (least $ rect_height r) + reveal w + +-- --------------------------------------------------------------------- + +-- | rescreen. The screen configuration may have changed (due to +-- xrandr), update the state and refresh the screen, and reset the gap. +rescreen :: X () +rescreen = do + xinesc <- withDisplay (io . getScreenInfo) + + windows $ \ws@(W.StackSet { W.current = v, W.visible = vs, W.hidden = hs }) -> + let (xs, ys) = splitAt (length xinesc) $ map W.workspace (v:vs) ++ hs + (a:as) = zipWith3 W.Screen xs [0..] $ zipWith SD xinesc gs + sgs = map (statusGap . W.screenDetail) (v:vs) + gs = take (length xinesc) (sgs ++ repeat (0,0,0,0)) + in ws { W.current = a + , W.visible = as + , W.hidden = ys } + +-- --------------------------------------------------------------------- + +-- | setButtonGrab. Tell whether or not to intercept clicks on a given window +setButtonGrab :: Bool -> Window -> X () +setButtonGrab grab w = withDisplay $ \d -> io $ + if grab + then forM_ [button1, button2, button3] $ \b -> + grabButton d b anyModifier w False buttonPressMask + grabModeAsync grabModeSync none none + else ungrabButton d anyButton anyModifier w + +-- --------------------------------------------------------------------- +-- Setting keyboard focus + +-- | Set the focus to the window on top of the stack, or root +setTopFocus :: X () +setTopFocus = withWindowSet $ maybe (setFocusX =<< asks theRoot) setFocusX . W.peek + +-- | Set focus explicitly to window 'w' if it is managed by us, or root. +-- This happens if X notices we've moved the mouse (and perhaps moved +-- the mouse to a new screen). +focus :: Window -> X () +focus w = withWindowSet $ \s -> do + if W.member w s then when (W.peek s /= Just w) $ windows (W.focusWindow w) + else whenX (isRoot w) $ setFocusX w + +-- | Call X to set the keyboard focus details. +setFocusX :: Window -> X () +setFocusX w = withWindowSet $ \ws -> do + dpy <- asks display + + -- clear mouse button grab and border on other windows + forM_ (W.current ws : W.visible ws) $ \wk -> do + forM_ (W.index (W.view (W.tag (W.workspace wk)) ws)) $ \otherw -> do + setButtonGrab True otherw + + -- If we ungrab buttons on the root window, we lose our mouse bindings. + whenX (not `liftM` isRoot w) $ setButtonGrab False w + io $ do setInputFocus dpy w revertToPointerRoot 0 + -- raiseWindow dpy w + +------------------------------------------------------------------------ +-- Message handling + +-- | Throw a message to the current LayoutClass possibly modifying how we +-- layout the windows, then refresh. +sendMessage :: Message a => a -> X () +sendMessage a = do + w <- (W.workspace . W.current) `fmap` gets windowset + ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing + whenJust ml' $ \l' -> do + windows $ \ws -> ws { W.current = (W.current ws) + { W.workspace = (W.workspace $ W.current ws) + { W.layout = l' }}} + +-- | Send a message to a list of workspaces' layouts, without necessarily refreshing. +sendMessageToWorkspaces :: Message a => a -> [WorkspaceId] -> X () +sendMessageToWorkspaces a l = runOnWorkspaces $ \w -> + if W.tag w `elem` l + then do ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing + return $ w { W.layout = maybe (W.layout w) id ml' } + else return w + +-- | Send a message to all visible layouts, without necessarily refreshing. +-- This is how we implement the hooks, such as UnDoLayout. +broadcastMessage :: Message a => a -> X () +broadcastMessage a = runOnWorkspaces $ \w -> do + ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing + return $ w { W.layout = maybe (W.layout w) id ml' } + +-- | This is basically a map function, running a function in the X monad on +-- each workspace with the output of that function being the modified workspace. +runOnWorkspaces :: (WindowSpace -> X WindowSpace) -> X () +runOnWorkspaces job =do + ws <- gets windowset + h <- mapM job $ W.hidden ws + c:v <- mapM (\s -> fmap (\w -> s { W.workspace = w}) $ job (W.workspace s)) + $ W.current ws : W.visible ws + modify $ \s -> s { windowset = ws { W.current = c, W.visible = v, W.hidden = h } } + +-- | Set the layout of the currently viewed workspace +setLayout :: Layout Window -> X () +setLayout l = do + ss@(W.StackSet { W.current = c@(W.Screen { W.workspace = ws })}) <- gets windowset + handleMessage (W.layout ws) (SomeMessage ReleaseResources) + windows $ const $ ss {W.current = c { W.workspace = ws { W.layout = l } } } + +------------------------------------------------------------------------ +-- Utilities + +-- | Return workspace visible on screen 'sc', or Nothing. +screenWorkspace :: ScreenId -> X (Maybe WorkspaceId) +screenWorkspace sc = withWindowSet $ return . W.lookupWorkspace sc + +-- | Apply an X operation to the currently focused window, if there is one. +withFocused :: (Window -> X ()) -> X () +withFocused f = withWindowSet $ \w -> whenJust (W.peek w) f + +-- | True if window is under management by us +isClient :: Window -> X Bool +isClient w = withWindowSet $ return . W.member w + +-- | Combinations of extra modifier masks we need to grab keys\/buttons for. +-- (numlock and capslock) +extraModifiers :: X [KeyMask] +extraModifiers = do + nlm <- asks (numlockMask . config) + return [0, nlm, lockMask, nlm .|. lockMask ] + +-- | Strip numlock\/capslock from a mask +cleanMask :: KeyMask -> X KeyMask +cleanMask km = do + nlm <- asks (numlockMask . config) + return (complement (nlm .|. lockMask) .&. km) + +-- | Get the Pixel value for a named color +initColor :: Display -> String -> IO Pixel +initColor dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c + where colormap = defaultColormap dpy (defaultScreen dpy) + +------------------------------------------------------------------------ +-- | Floating layer support + +-- | Given a window, find the screen it is located on, and compute +-- the geometry of that window wrt. that screen. +floatLocation :: Window -> X (ScreenId, W.RationalRect) +floatLocation w = withDisplay $ \d -> do + ws <- gets windowset + wa <- io $ getWindowAttributes d w + bw <- fi `fmap` asks (borderWidth . config) + + -- XXX horrible + let sc = fromMaybe (W.current ws) $ find (pointWithin (fi $ wa_x wa) (fi $ wa_y wa) . screenRect . W.screenDetail) $ W.screens ws + sr = screenRect . W.screenDetail $ sc + rr = W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr)) + ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr)) + (fi (wa_width wa + bw*2) % fi (rect_width sr)) + (fi (wa_height wa + bw*2) % fi (rect_height sr)) + + return (W.screen $ sc, rr) + where fi x = fromIntegral x + pointWithin :: Integer -> Integer -> Rectangle -> Bool + pointWithin x y r = x >= fi (rect_x r) && + x < fi (rect_x r) + fi (rect_width r) && + y >= fi (rect_y r) && + y < fi (rect_y r) + fi (rect_height r) + +-- | Make a tiled window floating, using its suggested rectangle +float :: Window -> X () +float w = do + (sc, rr) <- floatLocation w + windows $ \ws -> W.float w rr . fromMaybe ws $ do + i <- W.findTag w ws + guard $ i `elem` map (W.tag . W.workspace) (W.screens ws) + f <- W.peek ws + sw <- W.lookupWorkspace sc ws + return (W.focusWindow f . W.shiftWin sw w $ ws) + +-- --------------------------------------------------------------------- +-- Mouse handling + +-- | Accumulate mouse motion events +mouseDrag :: (Position -> Position -> X ()) -> X () -> X () +mouseDrag f done = do + drag <- gets dragging + case drag of + Just _ -> return () -- error case? we're already dragging + Nothing -> do + XConf { theRoot = root, display = d } <- ask + io $ grabPointer d root False (buttonReleaseMask .|. pointerMotionMask) + grabModeAsync grabModeAsync none none currentTime + modify $ \s -> s { dragging = Just (motion, cleanup) } + where + cleanup = do + withDisplay $ io . flip ungrabPointer currentTime + modify $ \s -> s { dragging = Nothing } + done + motion x y = do z <- f x y + clearEvents pointerMotionMask + return z + +-- | XXX comment me +mouseMoveWindow :: Window -> X () +mouseMoveWindow w = whenX (isClient w) $ withDisplay $ \d -> do + io $ raiseWindow d w + wa <- io $ getWindowAttributes d w + (_, _, _, ox', oy', _, _, _) <- io $ queryPointer d w + let ox = fromIntegral ox' + oy = fromIntegral oy' + mouseDrag (\ex ey -> io $ moveWindow d w (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) + (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))) + (float w) + +-- | XXX comment me +mouseResizeWindow :: Window -> X () +mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do + io $ raiseWindow d w + wa <- io $ getWindowAttributes d w + sh <- io $ getWMNormalHints d w + io $ warpPointer d none w 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa)) + mouseDrag (\ex ey -> do + io $ resizeWindow d w `uncurry` + applySizeHints sh (ex - fromIntegral (wa_x wa), + ey - fromIntegral (wa_y wa))) + (float w) + +-- --------------------------------------------------------------------- +-- | Support for window size hints + +type D = (Dimension, Dimension) + +-- | Reduce the dimensions if needed to comply to the given SizeHints. +applySizeHints :: Integral a => SizeHints -> (a,a) -> D +applySizeHints sh (w,h) = applySizeHints' sh (fromIntegral $ max 1 w, + fromIntegral $ max 1 h) + +-- | XXX comment me +applySizeHints' :: SizeHints -> D -> D +applySizeHints' sh = + maybe id applyMaxSizeHint (sh_max_size sh) + . maybe id (\(bw, bh) (w, h) -> (w+bw, h+bh)) (sh_base_size sh) + . maybe id applyResizeIncHint (sh_resize_inc sh) + . maybe id applyAspectHint (sh_aspect sh) + . maybe id (\(bw,bh) (w,h) -> (w-bw, h-bh)) (sh_base_size sh) + +-- | Reduce the dimensions so their aspect ratio falls between the two given aspect ratios. +applyAspectHint :: (D, D) -> D -> D +applyAspectHint ((minx, miny), (maxx, maxy)) x@(w,h) + | or [minx < 1, miny < 1, maxx < 1, maxy < 1] = x + | w * maxy > h * maxx = (h * maxx `div` maxy, h) + | w * miny < h * minx = (w, w * miny `div` minx) + | otherwise = x + +-- | Reduce the dimensions so they are a multiple of the size increments. +applyResizeIncHint :: D -> D -> D +applyResizeIncHint (iw,ih) x@(w,h) = + if iw > 0 && ih > 0 then (w - w `mod` iw, h - h `mod` ih) else x + +-- | Reduce the dimensions if they exceed the given maximum dimensions. +applyMaxSizeHint :: D -> D -> D +applyMaxSizeHint (mw,mh) x@(w,h) = + if mw > 0 && mh > 0 then (min w mw,min h mh) else x |