module XMonad.Main (xmonad) 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 XMonad.Core
import XMonad.StackSet (new, floating, member)
import qualified XMonad.StackSet as W
import XMonad.Operations
import System.IO
xmonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
xmonad initxmc = do
let xmc = initxmc { layoutHook = Layout $ layoutHook initxmc }
dpy <- openDisplay ""
let dflt = defaultScreen dpy
rootw <- rootWindow dpy dflt
xinesc <- getCleanedScreenInfo 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
, keyActions = keys xmc xmc
, buttonActions = mouseBindings xmc xmc }
st = XState
{ windowset = initialWinset
, mapped = S.empty
, waitingUnmap = M.empty
, dragging = Nothing }
xSetErrorHandler
sync dpy False
selectInput dpy rootw $ substructureRedirectMask .|. substructureNotifyMask
.|. enterWindowMask .|. leaveWindowMask .|. structureNotifyMask
allocaXEvent $ \e ->
runX cf st $ do
grabKeys
grabButtons
io $ sync dpy False
windows (const winset)
ws <- io $ scan dpy rootw
mapM_ manage ws
forever_ $ handle =<< io (nextEvent dpy e >> getEvent e)
return ()
where forever_ a = a >> forever_ a
handle :: Event -> X ()
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
ks <- asks keyActions
userCode $ whenJust (M.lookup (mClean, s) ks) id
handle (MapRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do
wa <- io $ getWindowAttributes dpy w
managed <- isClient w
when (not (wa_override_redirect wa) && not managed) $ do manage w
handle (DestroyWindowEvent {ev_window = w}) = whenX (isClient w) $ do
unmanage w
modify (\s -> s { mapped = S.delete w (mapped s)
, waitingUnmap = M.delete w (waitingUnmap s)})
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.update mpred w (waitingUnmap s) })
where mpred 1 = Nothing
mpred n = Just $ pred n
handle e@(MappingNotifyEvent {}) = do
io $ refreshKeyboardMapping e
when (ev_request e == mappingKeyboard) grabKeys
handle e@(ButtonEvent {ev_event_type = t})
| t == buttonRelease = do
drag <- gets dragging
case drag of
Just (_,f) -> modify (\s -> s { dragging = Nothing }) >> f
Nothing -> broadcastMessage e
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)
Nothing -> broadcastMessage e
handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b })
| t == buttonPress = do
isr <- isRoot w
m <- cleanMask $ ev_state e
ba <- asks buttonActions
if isr then userCode $ whenJust (M.lookup (m, b) ba) ($ ev_subwindow e)
else focus w
sendMessage e
handle e@(CrossingEvent {ev_window = w, ev_event_type = t})
| t == enterNotify && ev_mode e == notifyNormal
&& ev_detail e /= notifyInferior
= whenX (asks $ focusFollowsMouse . config) (focus w)
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
handle e@(ConfigureRequestEvent {ev_window = w}) = withDisplay $ \dpy -> do
ws <- gets windowset
wa <- io $ getWindowAttributes dpy w
bw <- asks (borderWidth . config)
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 bw
, 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
handle (ConfigureEvent {ev_window = w}) = whenX (isRoot w) rescreen
handle PropertyEvent { ev_event_type = t, ev_atom = a }
| t == propertyNotify && a == wM_NAME = userCode =<< asks (logHook . config)
handle e = broadcastMessage e
scan :: Display -> Window -> IO [Window]
scan dpy rootw = do
(_, _, ws) <- queryTree dpy rootw
filterM ok ws
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
_ -> False
return $ not (wa_override_redirect wa)
&& (wa_map_state wa == waIsViewable || ic)
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
ks <- asks keyActions
forM_ (M.keys ks) $ \(mask,sym) -> do
kc <- io $ keysymToKeycode dpy sym
when (kc /= '\0') $ mapM_ (grab kc . (mask .|.)) =<< extraModifiers
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
ems <- extraModifiers
ba <- asks buttonActions
mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ ba)