diff options
Diffstat (limited to 'XMonad/Operations.hs')
| -rw-r--r-- | XMonad/Operations.hs | 588 |
1 files changed, 0 insertions, 588 deletions
diff --git a/XMonad/Operations.hs b/XMonad/Operations.hs deleted file mode 100644 index 294d4a8..0000000 --- a/XMonad/Operations.hs +++ /dev/null @@ -1,588 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} - --- -------------------------------------------------------------------------- --- | --- Module : XMonad.Operations --- 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.Core -import XMonad.Layout (Full(..)) -import qualified XMonad.StackSet as W - -import Data.Maybe -import Data.Monoid (Endo(..)) -import Data.List (nub, (\\), find) -import Data.Bits ((.|.), (.&.), complement, testBit) -import Data.Ratio -import qualified Data.Map as M - -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Monad.Reader -import Control.Monad.State -import qualified Control.Exception.Extensible as C - -import System.Posix.Process (executeFile) -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 (not <$> isClient w) $ do - mh <- asks (manageHook . config) - g <- appEndo <$> userCodeDef (Endo id) (runQuery mh w) - windows (g . W.insertUp w) - --- | unmanage. A window no longer exists, remove it from the window --- list, on whatever workspace it is. --- -unmanage :: Window -> X () -unmanage = windows . W.delete - --- | Kill the specified window. 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) --- -killWindow :: Window -> X () -killWindow w = withDisplay $ \d -> 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 () - --- | Kill the currently focused client. -kill :: X () -kill = withFocused killWindow - --- --------------------------------------------------------------------- --- 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.screenWorkspace) $ W.screens old - newwindows = W.allWindows ws \\ W.allWindows old - ws = f old - XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask - - mapM_ setInitialProperties newwindows - - whenJust (W.peek old) $ \otherw -> setFrameBackground d otherw nbc - modify (\s -> s { windowset = ws }) - - -- notify non visibility - let tags_oldvisible = map (W.tag . W.screenWorkspace) $ W.screens old - gottenhidden = filter (flip elem tags_oldvisible . W.tag) $ W.hidden ws - mapM_ (sendMessageWithNoRefresh Hide) gottenhidden - - -- for each workspace, layout the currently visible workspaces - let allscreens = W.screens ws - summed_visible = scanl (++) [] $ map (W.integrate' . W.stack . W.screenWorkspace) allscreens - rects <- fmap concat $ forM (zip allscreens summed_visible) $ \ (w, vis) -> do - let wsp = W.screenWorkspace w - this = W.view n ws - n = W.tag wsp - tiled = (W.stack . W.screenWorkspace . W.current $ this) - >>= W.filter (`notElem` vis) - viewrect = screenRect $ W.screenDetail w - - -- just the tiled windows: - -- now tile the windows on this workspace, modified by the gap - (rs, ml') <- runLayout wsp { W.stack = tiled } viewrect `catchX` - runLayout wsp { W.stack = tiled, W.layout = Layout Full } viewrect - updateLayout n ml' - - io $ restackWindows d (map fst rs) - -- return the visible windows for this workspace: - return rs - - let visible = map fst rects - - mapM_ (uncurry tileWindow) rects - - whenJust (W.peek ws) $ \w -> setFrameBackground d w fbc - - mapM_ reveal visible - setTopFocus - - -- hide every window that was potentially visible before, but is not - -- given a position by a layout now. - mapM_ hide (nub (oldvisible ++ newwindows) \\ visible) - - -- all windows that are no longer in the windowset are marked as - -- withdrawn, it is important to do this after the above, otherwise 'hide' - -- will overwrite withdrawnState with iconicState - mapM_ (flip setWMState withdrawnState) (W.allWindows old \\ W.allWindows ws) - - isMouseFocused <- asks mouseFocused - unless isMouseFocused $ clearEvents enterWindowMask - asks (logHook . config) >>= userCodeDef () - where - setFrameBackground :: Display -> Window -> Pixel -> X () - setFrameBackground d w p = do - frame <- getsWindowState wsFrame w - io $ do - setWindowBackground d frame p - clearWindow d frame - --- | Produce the actual rectangle from a screen and a ratio on that screen. -scaleRationalRect :: Rectangle -> W.RationalRect -> Rectangle -scaleRationalRect (Rectangle sx sy sw sh) (W.RationalRect rx ry rw rh) - = Rectangle (sx + scale sw rx) (sy + scale sh ry) (scale sw rw) (scale sh rh) - where scale s r = floor (toRational s * r) - --- | 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 (getsWindowState wsMapped w) $ withDisplay $ \d -> do - (cMask,fMask) <- asks $ (clientMask &&& frameMask) . config - frame <- getsWindowState wsFrame w - io $ do selectInput d w (cMask .&. complement structureNotifyMask) - selectInput d frame (fMask .&. complement structureNotifyMask) - unmapWindow d frame - selectInput d frame fMask - selectInput d w cMask - setWMState w iconicState - -- this part is key: we increment the waitingUnmap counter to distinguish - -- between client and xmonad initiated unmaps. - modifyWindowState (\ws -> ws { wsMapped = False - , wsWaitingUnmap = (wsWaitingUnmap ws) + 1 }) w - -configureClientWindow :: Window -> X () -configureClientWindow w = withDisplay $ \d -> do - (frame, bw) <- getsWindowState (wsFrame &&& wsBorderWidth) w - (_, x, y, width, height, _, _) <- io $ getGeometry d frame - let least1 n = max 1 n - x' = x + (fi $ bwLeft bw) - y' = y + (fi $ bwTop bw) - width' = least1 (width - bwLeft bw - bwRight bw) - height' = least1 (height - bwTop bw - bwBottom bw) - io $ do - moveResizeWindow d w (fi $ bwLeft bw) (fi $ bwTop bw) width' height' - -- send absolute ConfigureNotify - allocaXEvent $ \event -> do - setEventType event configureNotify - setConfigureEvent event w w (fi x') (fi y') (fi width') (fi height') 0 none False - sendEvent d w False 0 event - where - fi :: (Integral a, Num b) => a -> b - fi = fromIntegral - --- | 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 - whenX (isClient w) $ do - configureClientWindow w - getsWindowState wsFrame w >>= io . mapWindow d - modifyWindowState (\ws -> ws { wsMapped = True }) w - --- | Set some properties when we initially gain control of a window -setInitialProperties :: Window -> X () -setInitialProperties w = withDisplay $ \d -> do - setWMState w iconicState - asks (clientMask . config) >>= io . selectInput d w - io $ setWindowBorderWidth d w 0 - --- | 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 - -- give all windows at least 1x1 pixels - let least x | x <= 0 = 1 - | otherwise = x - frame <- getsWindowState wsFrame w - io $ moveResizeWindow d frame (rect_x r) (rect_y r) (least $ rect_width r) (least $ rect_height r) - --- --------------------------------------------------------------------- - --- | Returns 'True' if the first rectangle is contained within, but not equal --- to the second. -containedIn :: Rectangle -> Rectangle -> Bool -containedIn r1@(Rectangle x1 y1 w1 h1) r2@(Rectangle x2 y2 w2 h2) - = and [ r1 /= r2 - , x1 >= x2 - , y1 >= y2 - , fromIntegral x1 + w1 <= fromIntegral x2 + w2 - , fromIntegral y1 + h1 <= fromIntegral y2 + h2 ] - --- | Given a list of screens, remove all duplicated screens and screens that --- are entirely contained within another. -nubScreens :: [Rectangle] -> [Rectangle] -nubScreens xs = nub . filter (\x -> not $ any (x `containedIn`) xs) $ xs - --- | Cleans the list of screens according to the rules documented for --- nubScreens. -getCleanedScreenInfo :: MonadIO m => Display -> m [Rectangle] -getCleanedScreenInfo = io . fmap nubScreens . getScreenInfo - --- | 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 getCleanedScreenInfo - - windows $ \ws -> - let (xs, ys) = splitAt (length xinesc) $ W.workspaces ws - (a:as) = zipWith3 (flip W.Screen []) xs [0..] $ map SD xinesc - in ws { W.current = a { W.screenHidden = ys } - , W.visible = as } - --- --------------------------------------------------------------------- - --- | setButtonGrab. Tell whether or not to intercept clicks on a given window -setButtonGrab :: Bool -> Window -> X () -setButtonGrab grab w = do - pointerMode <- asks $ \c -> if clickJustFocuses (config c) - then grabModeAsync - else grabModeSync - withDisplay $ \d -> io $ if grab - then forM_ [button1, button2, button3] $ \b -> - grabButton d b anyModifier w False buttonPressMask - pointerMode 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 = local (\c -> c { mouseFocused = True }) $ withWindowSet $ \s -> do - let stag = W.tag . W.screenWorkspace - curr = stag $ W.current s - mnew <- maybe (return Nothing) (fmap (fmap stag) . uncurry pointScreen) - =<< asks mousePosition - root <- asks theRoot - case () of - _ | W.member w s && W.peek s /= Just w -> windows (W.focusWindow w) - | Just new <- mnew, w == root && curr /= new - -> windows (W.view new) - | otherwise -> return () - --- | 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.screens ws) $ \wk -> - forM_ (W.index (W.view (W.tag (W.screenWorkspace wk)) ws)) $ \otherw -> - setButtonGrab True otherw - - -- If we ungrab buttons on the root window, we lose our mouse bindings. - whenX (not <$> isRoot w) $ setButtonGrab False w - - hints <- io $ getWMHints dpy w - protocols <- io $ getWMProtocols dpy w - wmprot <- atom_WM_PROTOCOLS - wmtf <- atom_WM_TAKE_FOCUS - currevt <- asks currentEvent - let inputHintSet = wmh_flags hints `testBit` inputHintBit - - when ((inputHintSet && wmh_input hints) || (not inputHintSet)) $ - io $ do setInputFocus dpy w revertToPointerRoot 0 - when (wmtf `elem` protocols) $ - io $ allocaXEvent $ \ev -> do - setEventType ev clientMessage - setClientMessageEvent ev w wmprot 32 wmtf $ maybe currentTime event_time currevt - sendEvent dpy w False noEventMask ev - where event_time ev = - if (ev_event_type ev) `elem` timedEvents then - ev_time ev - else - currentTime - timedEvents = [ keyPress, keyRelease, buttonPress, buttonRelease, enterNotify, leaveNotify, selectionRequest ] - ------------------------------------------------------------------------- --- 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.screenWorkspace . W.current <$> gets windowset - ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - whenJust ml' $ \l' -> - windows $ \ws -> ws { W.current = (W.current ws) - { W.screenWorkspace = (W.screenWorkspace $ W.current ws) - { W.layout = l' }}} - --- | Send a message to all layouts, without refreshing. -broadcastMessage :: Message a => a -> X () -broadcastMessage a = withWindowSet $ \ws -> - mapM_ (sendMessageWithNoRefresh a) (W.workspaces ws) - --- | Send a message to a layout, without refreshing. -sendMessageWithNoRefresh :: Message a => a -> W.Workspace WorkspaceId (Layout Window) Window -> X () -sendMessageWithNoRefresh a w = - handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing >>= - updateLayout (W.tag w) - --- | Update the layout field of a workspace -updateLayout :: WorkspaceId -> Maybe (Layout Window) -> X () -updateLayout i ml = whenJust ml $ \l -> - runOnWorkspaces $ \ww -> return $ if W.tag ww == i then ww { W.layout = l} else ww - --- | Set the layout of the currently viewed workspace -setLayout :: Layout Window -> X () -setLayout l = do - ss@(W.StackSet { W.current = c@(W.Screen { W.screenWorkspace = ws })}) <- gets windowset - handleMessage (W.layout ws) (SomeMessage ReleaseResources) - windows $ const $ ss {W.current = c { W.screenWorkspace = 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 <- gets numberlockMask - return [0, nlm, lockMask, nlm .|. lockMask ] - --- | Strip numlock\/capslock from a mask -cleanMask :: KeyMask -> X KeyMask -cleanMask km = do - nlm <- gets numberlockMask - return (complement (nlm .|. lockMask) .&. km) - --- | Get the 'Pixel' value for a named color -initColor :: Display -> String -> IO (Maybe Pixel) -initColor dpy c = C.handle (\(C.SomeException _) -> return Nothing) $ - (Just . color_pixel . fst) <$> allocNamedColor dpy colormap c - where colormap = defaultColormap dpy (defaultScreen dpy) - ------------------------------------------------------------------------- - --- | @restart name resume@. Attempt to restart xmonad by executing the program --- @name@. If @resume@ is 'True', restart with the current window state. --- When executing another window manager, @resume@ should be 'False'. -restart :: String -> Bool -> X () -restart prog resume = do - broadcastMessage ReleaseResources - io . flush =<< asks display - let wsData = show . W.mapLayout show . windowset - maybeShow (t, Right (PersistentExtension ext)) = Just (t, show ext) - maybeShow (t, Left str) = Just (t, str) - maybeShow _ = Nothing - extState = return . show . catMaybes . map maybeShow . M.toList . extensibleState - args <- if resume then gets (\s -> "--resume":wsData s:extState s) else return [] - catchIO (executeFile prog True args Nothing) - ------------------------------------------------------------------------- --- | 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 - let bw = (fromIntegral . wa_border_width) wa - sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa) - - let 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 - --- | Given a point, determine the screen (if any) that contains it. -pointScreen :: Position -> Position - -> X (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)) -pointScreen x y = withWindowSet $ return . find p . W.screens - where p = pointWithin x y . screenRect . W.screenDetail - --- | @pointWithin x y r@ returns 'True' if the @(x, y)@ co-ordinate is within --- @r@. -pointWithin :: Position -> Position -> Rectangle -> Bool -pointWithin x y r = x >= rect_x r && - x < rect_x r + fromIntegral (rect_width r) && - y >= rect_y r && - y < rect_y r + fromIntegral (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` concatMap (map W.tag . W.screenWorkspaces) (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 -> - io $ resizeWindow d w `uncurry` - applySizeHintsContents sh (ex - fromIntegral (wa_x wa), - ey - fromIntegral (wa_y wa))) - (float w)-} - --- --------------------------------------------------------------------- --- | Support for window size hints - -type D = (Dimension, Dimension) - --- | Given a window, build an adjuster function that will reduce the given --- dimensions according to the window's border width and size hints. -mkAdjust :: Window -> X (D -> D) -mkAdjust w = withDisplay $ \d -> liftIO $ do - sh <- getWMNormalHints d w - bw <- fmap (fromIntegral . wa_border_width) $ getWindowAttributes d w - return $ applySizeHints bw sh - --- | Reduce the dimensions if needed to comply to the given SizeHints, taking --- window borders into account. -applySizeHints :: Integral a => Dimension -> SizeHints -> (a, a) -> D -applySizeHints bw sh = - tmap (+ 2 * bw) . applySizeHintsContents sh . tmap (subtract $ 2 * fromIntegral bw) - where - tmap f (x, y) = (f x, f y) - --- | Reduce the dimensions if needed to comply to the given SizeHints. -applySizeHintsContents :: Integral a => SizeHints -> (a, a) -> D -applySizeHintsContents 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 |