twin/xmonad
1
0
Fork 0
mirror of https://github.com/xmonad/xmonad.git synced 2025-05-19 00:20:22 -07:00
Code Issues Packages Projects Releases Wiki Activity

sketch of config/main inversion.

Browse Source
This commit is contained in:
David Roundy 2007-10-18 16:42:30 +00:00
parent c1e039ba88
commit 97fe14dfd2
4 changed files with 274 additions and 265 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

264
EventLoop.hs Normal file
View File

@ -0,0 +1,264 @@
----------------------------------------------------------------------------
-- |
-- 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 :: String -> String -> Layout Window -> [String] -> [(Int,Int,Int,Int)]
-> M.Map (ButtonMask,KeySym) (X ()) -> M.Map (ButtonMask, Button) (Window -> X ())
-> Int -> X () -> IO ()
makeMain normalBorderColor focusedBorderColor layoutHook workspaces
defaultGaps keys mouseBindings borderWidth logHook = do
dpy <- openDisplay ""
let dflt = defaultScreen dpy
rootw <- rootWindow dpy dflt
xinesc <- getScreenInfo dpy
nbc <- initColor dpy normalBorderColor
fbc <- initColor dpy focusedBorderColor
hSetBuffering stdout NoBuffering
args <- getArgs
let initialWinset = new layoutHook workspaces $ zipWith SD xinesc gaps
maybeRead s = case reads s of
[(x, "")] -> Just x
_ -> Nothing
winset = fromMaybe initialWinset $ do
("--resume" : s : _) <- return args
ws <- maybeRead s
return . W.ensureTags layoutHook workspaces
$ W.mapLayout (fromMaybe layoutHook . maybeRead) ws
gaps = take (length xinesc) $ defaultGaps ++ repeat (0,0,0,0)
cf = XConf
{ display = dpy
, 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 keys
grabButtons mouseBindings
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) 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 keys)
-- 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) ($ 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
, 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
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 :: M.Map (ButtonMask,KeySym) (X ()) -> X ()
grabKeys keys = 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) $ \(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 :: M.Map (ButtonMask, Button) (Window -> X ()) -> X ()
grabButtons mouseBindings = 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)

262
Main.hs
View File

@ -1,262 +0,0 @@
----------------------------------------------------------------------------
-- |
-- 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 Main 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 Config
import StackSet (new, floating, member)
import qualified StackSet as W
import Operations
import System.IO
-- |
-- The main entry point
--
main :: IO ()
main = do
dpy <- openDisplay ""
let dflt = defaultScreen dpy
rootw <- rootWindow dpy dflt
xinesc <- getScreenInfo dpy
nbc <- initColor dpy normalBorderColor
fbc <- initColor dpy focusedBorderColor
hSetBuffering stdout NoBuffering
args <- getArgs
let initialWinset = new layoutHook workspaces $ zipWith SD xinesc gaps
maybeRead s = case reads s of
[(x, "")] -> Just x
_ -> Nothing
winset = fromMaybe initialWinset $ do
("--resume" : s : _) <- return args
ws <- maybeRead s
return . W.ensureTags layoutHook workspaces
$ W.mapLayout (fromMaybe layoutHook . maybeRead) ws
gaps = take (length xinesc) $ defaultGaps ++ repeat (0,0,0,0)
cf = XConf
{ display = dpy
, 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
grabButtons
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
-- ---------------------------------------------------------------------
-- 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 :: X ()
grabKeys = 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) $ \(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 :: X ()
grabButtons = 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)
-- ---------------------------------------------------------------------
-- | 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) 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
-- 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) ($ 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
, 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
handle e = broadcastMessage e -- trace (eventName e) -- ignoring

9
Config.hs → config.hs
View File

@ -14,7 +14,7 @@
--
------------------------------------------------------------------------
module Config where
module Main ( main ) where
--
-- Useful imports
@ -27,6 +27,7 @@ import Data.Bits ((.|.))
import qualified Data.Map as M
import System.Exit
import Graphics.X11.Xlib
import EventLoop
-- % Extension-provided imports
@ -272,3 +273,9 @@ mouseBindings = M.fromList $
]
-- % Extension-provided definitions
-- % The main function
main = makeMain normalBorderColor focusedBorderColor layoutHook workspaces
defaultGaps keys mouseBindings borderWidth logHook

4
xmonad.cabal
View File

@ -22,8 +22,8 @@ extra-source-files: README TODO tests/loc.hs tests/Properties.hs man/xmonad.1.in
Config.hs-boot util/GenerateManpage.hs man/xmonad.1 man/xmonad.html
executable: xmonad
main-is: Main.hs
other-modules: Config Operations StackSet XMonad
main-is: config.hs
other-modules: EventLoop Operations StackSet XMonad
ghc-options: -funbox-strict-fields -O2 -fasm -Wall -optl-Wl,-s
ghc-prof-options: -prof -auto-all
extensions: GeneralizedNewtypeDeriving