mirror of
https://github.com/xmonad/xmonad.git
synced 2025-05-19 00:20:22 -07:00
265 lines
11 KiB
Haskell
265 lines
11 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
----------------------------------------------------------------------------
|
|
-- |
|
|
-- Module : Main.hs
|
|
-- Copyright : (c) Spencer Janssen 2007
|
|
-- License : BSD3-style (see LICENSE)
|
|
--
|
|
-- Maintainer : sjanssen@cse.unl.edu
|
|
-- Stability : unstable
|
|
-- Portability : not portable, uses mtl, X11, posix
|
|
--
|
|
-- xmonad, a minimalist, tiling window manager for X11
|
|
--
|
|
-----------------------------------------------------------------------------
|
|
|
|
module EventLoop (makeMain) where
|
|
|
|
import Data.Bits
|
|
import qualified Data.Map as M
|
|
import qualified Data.Set as S
|
|
import Control.Monad.Reader
|
|
import Control.Monad.State
|
|
import Data.Maybe (fromMaybe)
|
|
|
|
import System.Environment (getArgs)
|
|
|
|
import Graphics.X11.Xlib hiding (refreshKeyboardMapping)
|
|
import Graphics.X11.Xlib.Extras
|
|
import Graphics.X11.Xinerama (getScreenInfo)
|
|
|
|
import XMonad
|
|
import StackSet (new, floating, member)
|
|
import qualified StackSet as W
|
|
import Operations
|
|
|
|
import System.IO
|
|
|
|
-- |
|
|
-- The main entry point
|
|
--
|
|
makeMain :: XConfig -> IO ()
|
|
makeMain xmc = do
|
|
dpy <- openDisplay ""
|
|
let dflt = defaultScreen dpy
|
|
|
|
rootw <- rootWindow dpy dflt
|
|
xinesc <- getScreenInfo dpy
|
|
nbc <- initColor dpy $ normalBorderColor xmc
|
|
fbc <- initColor dpy $ focusedBorderColor xmc
|
|
hSetBuffering stdout NoBuffering
|
|
args <- getArgs
|
|
|
|
let (layout, lreads) = case xmc of XConfig {layoutHook = lh } -> (Layout lh, \s -> [(Layout (x `asTypeOf` lh), s') | (x, s') <- reads s])
|
|
initialWinset = new layout (workspaces xmc) $ zipWith SD xinesc gaps
|
|
|
|
maybeRead reads' s = case reads' s of
|
|
[(x, "")] -> Just x
|
|
_ -> Nothing
|
|
|
|
winset = fromMaybe initialWinset $ do
|
|
("--resume" : s : _) <- return args
|
|
ws <- maybeRead reads s
|
|
return . W.ensureTags layout (workspaces xmc)
|
|
$ W.mapLayout (fromMaybe layout . maybeRead lreads) ws
|
|
|
|
gaps = take (length xinesc) $ defaultGaps xmc ++ repeat (0,0,0,0)
|
|
|
|
cf = XConf
|
|
{ display = dpy
|
|
, config = xmc
|
|
, theRoot = rootw
|
|
, normalBorder = nbc
|
|
, focusedBorder = fbc }
|
|
st = XState
|
|
{ windowset = initialWinset
|
|
, mapped = S.empty
|
|
, waitingUnmap = M.empty
|
|
, dragging = Nothing }
|
|
|
|
xSetErrorHandler -- in C, I'm too lazy to write the binding: dons
|
|
|
|
-- setup initial X environment
|
|
sync dpy False
|
|
selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask
|
|
.|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask
|
|
|
|
allocaXEvent $ \e ->
|
|
runX cf st $ do
|
|
|
|
grabKeys xmc
|
|
grabButtons xmc
|
|
|
|
io $ sync dpy False
|
|
|
|
-- bootstrap the windowset, Operations.windows will identify all
|
|
-- the windows in winset as new and set initial properties for
|
|
-- those windows
|
|
windows (const winset)
|
|
|
|
-- scan for all top-level windows, add the unmanaged ones to the
|
|
-- windowset
|
|
ws <- io $ scan dpy rootw
|
|
mapM_ manage ws
|
|
|
|
-- main loop, for all you HOF/recursion fans out there.
|
|
forever_ $ handle =<< io (nextEvent dpy e >> getEvent e)
|
|
|
|
return ()
|
|
where forever_ a = a >> forever_ a
|
|
|
|
-- ---------------------------------------------------------------------
|
|
-- | Event handler. Map X events onto calls into Operations.hs, which
|
|
-- modify our internal model of the window manager state.
|
|
--
|
|
-- Events dwm handles that we don't:
|
|
--
|
|
-- [ButtonPress] = buttonpress,
|
|
-- [Expose] = expose,
|
|
-- [PropertyNotify] = propertynotify,
|
|
--
|
|
handle :: Event -> X ()
|
|
|
|
-- run window manager command
|
|
handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code})
|
|
| t == keyPress = withDisplay $ \dpy -> do
|
|
s <- io $ keycodeToKeysym dpy code 0
|
|
userCode $ whenJust (M.lookup (cleanMask m,s) (keys xmc)) id
|
|
|
|
-- manage a new window
|
|
handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do
|
|
wa <- io $ getWindowAttributes dpy w -- ignore override windows
|
|
-- need to ignore mapping requests by managed windows not on the current workspace
|
|
managed <- isClient w
|
|
when (not (wa_override_redirect wa) && not managed) $ do manage w
|
|
|
|
-- window destroyed, unmanage it
|
|
-- window gone, unmanage it
|
|
handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ unmanage w
|
|
|
|
-- We track expected unmap events in waitingUnmap. We ignore this event unless
|
|
-- it is synthetic or we are not expecting an unmap notification from a window.
|
|
handle (UnmapEvent {ev_window = w, ev_send_event = synthetic}) = whenX (isClient w) $ do
|
|
e <- gets (fromMaybe 0 . M.lookup w . waitingUnmap)
|
|
if (synthetic || e == 0)
|
|
then unmanage w
|
|
else modify (\s -> s { waitingUnmap = M.adjust pred w (waitingUnmap s) })
|
|
|
|
-- set keyboard mapping
|
|
handle e@(MappingNotifyEvent {}) = do
|
|
io $ refreshKeyboardMapping e
|
|
when (ev_request e == mappingKeyboard) (grabKeys xmc)
|
|
|
|
-- handle button release, which may finish dragging.
|
|
handle e@(ButtonEvent {ev_event_type = t})
|
|
| t == buttonRelease = do
|
|
drag <- gets dragging
|
|
case drag of
|
|
-- we're done dragging and have released the mouse:
|
|
Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f
|
|
Nothing -> broadcastMessage e
|
|
|
|
-- handle motionNotify event, which may mean we are dragging.
|
|
handle e@(MotionEvent {ev_event_type = _t, ev_x = x, ev_y = y}) = do
|
|
drag <- gets dragging
|
|
case drag of
|
|
Just (d,_) -> d (fromIntegral x) (fromIntegral y) -- we're dragging
|
|
Nothing -> broadcastMessage e
|
|
|
|
-- click on an unfocused window, makes it focused on this workspace
|
|
handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b })
|
|
| t == buttonPress = do
|
|
-- If it's the root window, then it's something we
|
|
-- grabbed in grabButtons. Otherwise, it's click-to-focus.
|
|
isr <- isRoot w
|
|
if isr then userCode $ whenJust (M.lookup (cleanMask (ev_state e), b) $ mouseBindings xmc) ($ ev_subwindow e)
|
|
else focus w
|
|
sendMessage e -- Always send button events.
|
|
|
|
-- entered a normal window, makes this focused.
|
|
handle e@(CrossingEvent {ev_window = w, ev_event_type = t})
|
|
| t == enterNotify && ev_mode e == notifyNormal
|
|
&& ev_detail e /= notifyInferior = focus w
|
|
|
|
-- left a window, check if we need to focus root
|
|
handle e@(CrossingEvent {ev_event_type = t})
|
|
| t == leaveNotify
|
|
= do rootw <- asks theRoot
|
|
when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw
|
|
|
|
-- configure a window
|
|
handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do
|
|
ws <- gets windowset
|
|
wa <- io $ getWindowAttributes dpy w
|
|
|
|
if M.member w (floating ws)
|
|
|| not (member w ws)
|
|
then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges
|
|
{ wc_x = ev_x e
|
|
, wc_y = ev_y e
|
|
, wc_width = ev_width e
|
|
, wc_height = ev_height e
|
|
, wc_border_width = fromIntegral (borderWidth xmc)
|
|
, wc_sibling = ev_above e
|
|
, wc_stack_mode = ev_detail e }
|
|
when (member w ws) (float w)
|
|
else io $ allocaXEvent $ \ev -> do
|
|
setEventType ev configureNotify
|
|
setConfigureEvent ev w w
|
|
(wa_x wa) (wa_y wa) (wa_width wa)
|
|
(wa_height wa) (ev_border_width e) none (wa_override_redirect wa)
|
|
sendEvent dpy w False 0 ev
|
|
io $ sync dpy False
|
|
|
|
-- configuration changes in the root may mean display settings have changed
|
|
handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen
|
|
|
|
-- property notify
|
|
handle PropertyEvent { ev_event_type = t, ev_atom = a }
|
|
| t == propertyNotify && a == wM_NAME = userCode $ logHook xmc
|
|
|
|
handle e = broadcastMessage e -- trace (eventName e) -- ignoring
|
|
|
|
|
|
-- ---------------------------------------------------------------------
|
|
-- IO stuff. Doesn't require any X state
|
|
-- Most of these things run only on startup (bar grabkeys)
|
|
|
|
-- | scan for any new windows to manage. If they're already managed,
|
|
-- this should be idempotent.
|
|
scan :: Display -> Window -> IO [Window]
|
|
scan dpy rootw = do
|
|
(_, _, ws) <- queryTree dpy rootw
|
|
filterM ok ws
|
|
-- TODO: scan for windows that are either 'IsViewable' or where WM_STATE ==
|
|
-- Iconic
|
|
where ok w = do wa <- getWindowAttributes dpy w
|
|
a <- internAtom dpy "WM_STATE" False
|
|
p <- getWindowProperty32 dpy a w
|
|
let ic = case p of
|
|
Just (3:_) -> True -- 3 for iconified
|
|
_ -> False
|
|
return $ not (wa_override_redirect wa)
|
|
&& (wa_map_state wa == waIsViewable || ic)
|
|
|
|
-- | Grab the keys back
|
|
grabKeys :: XConfig -> X ()
|
|
grabKeys xmc = do
|
|
XConf { display = dpy, theRoot = rootw } <- ask
|
|
let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync
|
|
io $ ungrabKey dpy anyKey anyModifier rootw
|
|
forM_ (M.keys $ keys xmc) $ \(mask,sym) -> do
|
|
kc <- io $ keysymToKeycode dpy sym
|
|
-- "If the specified KeySym is not defined for any KeyCode,
|
|
-- XKeysymToKeycode() returns zero."
|
|
when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) extraModifiers
|
|
|
|
-- | XXX comment me
|
|
grabButtons :: XConfig -> X ()
|
|
grabButtons xmc = do
|
|
XConf { display = dpy, theRoot = rootw } <- ask
|
|
let grab button mask = io $ grabButton dpy button mask rootw False buttonPressMask
|
|
grabModeAsync grabModeSync none none
|
|
io $ ungrabButton dpy anyButton anyModifier rootw
|
|
mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) extraModifiers) (M.keys $ mouseBindings xmc)
|