diff options
Diffstat (limited to 'EventLoop.hs')
| -rw-r--r-- | EventLoop.hs | 268 |
1 files changed, 0 insertions, 268 deletions
diff --git a/EventLoop.hs b/EventLoop.hs deleted file mode 100644 index ce29264..0000000 --- a/EventLoop.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- | --- Module : EventLoop.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 = layoutHook xmc - lreads = readsLayout layout - 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 - mClean <- cleanMask m - userCode $ whenJust (M.lookup (mClean, 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 - m <- cleanMask $ ev_state e - if isr then userCode $ whenJust (M.lookup (m, 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 - ems <- extraModifiers - mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ mouseBindings xmc) |