summaryrefslogtreecommitdiffstats
path: root/XMonad/Main.hsc
diff options
context:
space:
mode:
Diffstat (limited to 'XMonad/Main.hsc')
-rw-r--r--XMonad/Main.hsc433
1 files changed, 0 insertions, 433 deletions
diff --git a/XMonad/Main.hsc b/XMonad/Main.hsc
deleted file mode 100644
index 224631c..0000000
--- a/XMonad/Main.hsc
+++ /dev/null
@@ -1,433 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, ForeignFunctionInterface #-}
-----------------------------------------------------------------------------
--- |
--- Module : XMonad.Main
--- Copyright : (c) Spencer Janssen 2007
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : spencerjanssen@gmail.com
--- Stability : unstable
--- Portability : not portable, uses mtl, X11, posix
---
--- xmonad, a minimalist, tiling window manager for X11
---
------------------------------------------------------------------------------
-
-module XMonad.Main (xmonad) where
-
-import Control.Arrow (second)
-import Data.Bits
-import Data.List ((\\))
-import Data.Function
-import qualified Data.Map as M
-import Control.Monad.Reader
-import Control.Monad.State
-import Data.Maybe (fromMaybe)
-import Data.Monoid (getAll)
-
-import Foreign.C
-import Foreign.Ptr
-
-import System.Environment (getArgs)
-
-import Graphics.X11.Xlib hiding (refreshKeyboardMapping)
-import Graphics.X11.Xlib.Extras
-import Graphics.X11.Xlib.Types (Visual(..))
-
-import XMonad.Core
-import qualified XMonad.Config as Default
-import XMonad.StackSet (new, member)
-import qualified XMonad.StackSet as W
-import XMonad.Operations
-
-import System.IO
-
-------------------------------------------------------------------------
--- Locale support
-
-#include <locale.h>
-
-foreign import ccall unsafe "locale.h setlocale"
- c_setlocale :: CInt -> Ptr CChar -> IO (Ptr CChar)
-
-------------------------------------------------------------------------
-
--- |
--- The main entry point
---
-xmonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
-xmonad initxmc = do
- -- setup locale information from environment
- withCString "" $ c_setlocale (#const LC_ALL)
- -- ignore SIGPIPE and SIGCHLD
- installSignalHandlers
- -- First, wrap the layout in an existential, to keep things pretty:
- let xmc = initxmc { layoutHook = Layout $ layoutHook initxmc }
- dpy <- openDisplay ""
- let dflt = defaultScreen dpy
-
- rootw <- rootWindow dpy dflt
-
- args <- getArgs
-
- when ("--replace" `elem` args) $ replace dpy dflt rootw
-
- -- If another WM is running, a BadAccess error will be returned. The
- -- default error handler will write the exception to stderr and exit with
- -- an error.
- selectInput dpy rootw $ rootMask initxmc
-
- sync dpy False -- sync to ensure all outstanding errors are delivered
-
- -- turn off the default handler in favor of one that ignores all errors
- -- (ugly, I know)
- xSetErrorHandler -- in C, I'm too lazy to write the binding: dons
-
- xinesc <- getCleanedScreenInfo dpy
- nbc <- do v <- initColor dpy $ normalBorderColor xmc
- ~(Just nbc_) <- initColor dpy $ normalBorderColor Default.def
- return (fromMaybe nbc_ v)
-
- fbc <- do v <- initColor dpy $ focusedBorderColor xmc
- ~(Just fbc_) <- initColor dpy $ focusedBorderColor Default.def
- return (fromMaybe fbc_ v)
-
- hSetBuffering stdout NoBuffering
-
- let layout = layoutHook xmc
- lreads = readsLayout layout
- initialWinset = new layout (workspaces xmc) $ map SD xinesc
- 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.mapLayout (fromMaybe layout . maybeRead lreads) ws
- extState = fromMaybe M.empty $ do
- ("--resume" : _ : dyns : _) <- return args
- vals <- maybeRead reads dyns
- return . M.fromList . map (second Left) $ vals
-
- cf = XConf
- { display = dpy
- , config = xmc
- , theRoot = rootw
- , normalBorder = nbc
- , focusedBorder = fbc
- , keyActions = keys xmc xmc
- , buttonActions = mouseBindings xmc xmc
- , mouseFocused = False
- , mousePosition = Nothing
- , currentEvent = Nothing }
-
- st = XState
- { windowset = initialWinset
- , numberlockMask = 0
- , windowState = M.empty
- , dragging = Nothing
- , extensibleState = extState
- }
- allocaXEvent $ \e ->
- runX cf st $ do
-
- setNumlockMask
- grabKeys
- grabButtons
-
- io $ sync dpy False
-
- ws <- io $ scan dpy rootw
-
- -- bootstrap the windowset, Operations.windows will identify all
- -- the windows in winset as new and set initial properties for
- -- those windows. Remove all windows that are no longer top-level
- -- children of the root, they may have disappeared since
- -- restarting.
- windows . const . foldr W.delete winset $ W.allWindows winset \\ ws
-
- -- manage the as-yet-unmanaged windows
- mapM_ (\w -> reparent w >> manage w) (ws \\ W.allWindows winset)
-
- userCode $ startupHook initxmc
-
- -- main loop, for all you HOF/recursion fans out there.
- forever $ prehandle =<< io (nextEvent dpy e >> getEvent e)
-
- return ()
- where
- -- if the event gives us the position of the pointer, set mousePosition
- prehandle e = let mouse = do guard (ev_event_type e `elem` evs)
- return (fromIntegral (ev_x_root e)
- ,fromIntegral (ev_y_root e))
- in local (\c -> c { mousePosition = mouse, currentEvent = Just e }) (handleWithHook e)
- evs = [ keyPress, keyRelease, enterNotify, leaveNotify
- , buttonPress, buttonRelease]
-
-
--- | Runs handleEventHook from the configuration and runs the default handler
--- function if it returned True.
-handleWithHook :: Event -> X ()
-handleWithHook e = do
- evHook <- asks (handleEventHook . config)
- whenX (userCodeDef True $ getAll `fmap` evHook e) (handle e)
-
--- ---------------------------------------------------------------------
--- | 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
- ks <- asks keyActions
- userCodeDef () $ whenJust (M.lookup (mClean, s) ks) 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
- reparent w
- manage w
-
--- window destroyed, unmanage it
--- window gone, unmanage it
-handle (DestroyWindowEvent {ev_window = w}) = do
- whenX (isClient w) $
- unmanage w
- unparent w
- modify (\s -> s { windowState = M.delete w (windowState s)})
-
--- 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, ev_event = we} = whenX (isClient w) $ do
- rootw <- asks theRoot
- e <- getsWindowState wsWaitingUnmap w
- if (synthetic || (e == 0 && we /= rootw))
- then unmanage w >> hideParent w
- else when (e > 0) $ modifyWindowState (\ws -> ws { wsWaitingUnmap = e - 1 }) w
-
--- set keyboard mapping
-handle e@(MappingNotifyEvent {}) = do
- io $ refreshKeyboardMapping e
- when (ev_request e `elem` [mappingKeyboard, mappingModifier]) $ do
- setNumlockMask
- 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.
- dpy <- asks display
- isr <- isRoot w
- m <- cleanMask $ ev_state e
- mact <- asks (M.lookup (m, b) . buttonActions)
- case mact of
- Just act | isr -> act $ ev_subwindow e
- _ -> do
- focus w
- ctf <- asks (clickJustFocuses . config)
- unless ctf $ io (allowEvents dpy replayPointer currentTime)
- broadcastMessage e -- Always send button events.
-
--- entered a normal window: focus it if focusFollowsMouse is set to
--- True in the user's config.
-handle e@(CrossingEvent {ev_window = w, ev_event_type = t})
- | t == enterNotify && ev_mode e == notifyNormal
- = whenX (asks $ focusFollowsMouse . config) (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
-
- if 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 = 0
- , wc_sibling = ev_above e
- , wc_stack_mode = ev_detail e }
- else configureClientWindow w
- 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 event@(PropertyEvent { ev_event_type = t, ev_atom = a })
- | t == propertyNotify && a == wM_NAME = asks (logHook . config) >>= userCodeDef () >>
- broadcastMessage event
-
-handle e@ClientMessageEvent { ev_message_type = mt } = do
- a <- getAtom "XMONAD_RESTART"
- if (mt == a)
- then restart "xmonad" True
- else broadcastMessage e
-
-handle e = broadcastMessage e -- trace (eventName e) -- ignoring
-
-
-reparent :: Window -> X ()
-reparent w = withDisplay $ \dpy -> do
- rootw <- asks theRoot
- p <- asks normalBorder
- fMask <- asks (frameMask . config)
- noFrame <- getsWindowState ((==none) . wsFrame) w
- when noFrame $ do
- trace $ "reparent: " ++ show w
- frame <- io $ allocaSetWindowAttributes $ \swa -> do
- set_background_pixel swa p
- set_border_pixel swa p
- set_event_mask swa fMask
- set_override_redirect swa True
- createWindow dpy rootw (-1) (-1) 1 1 0 copyFromParent inputOutput (Visual nullPtr) (cWBackPixel.|.cWBorderPixel.|.cWEventMask.|.cWOverrideRedirect) swa
- io $ do
- unmapWindow dpy w
- addToSaveSet dpy w
- reparentWindow dpy w frame 0 0
- modifyWindowState (\ws -> ws { wsFrame = frame }) w
-
-hideParent :: Window -> X ()
-hideParent w = withDisplay $ \dpy -> do
- frame <- getsWindowState wsFrame w
- when (frame /= none) $ io $ unmapWindow dpy frame
-
-unparent :: Window -> X ()
-unparent w = withDisplay $ \dpy -> do
- frame <- getsWindowState wsFrame w
- when (frame /= none) $ do
- trace $ "unparent: " ++ show w
- io $ destroyWindow dpy frame
- modifyWindowState (\ws -> ws { wsFrame = none }) w
-
--- ---------------------------------------------------------------------
--- 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)
-
-setNumlockMask :: X ()
-setNumlockMask = do
- dpy <- asks display
- ms <- io $ getModifierMapping dpy
- xs <- sequence [ do
- ks <- io $ keycodeToKeysym dpy kc 0
- if ks == xK_Num_Lock
- then return (setBit 0 (fromIntegral m))
- else return (0 :: KeyMask)
- | (m, kcs) <- ms, kc <- kcs, kc /= 0]
- modify (\s -> s { numberlockMask = foldr (.|.) 0 xs })
-
--- | 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
- (minCode, maxCode) = displayKeycodes dpy
- allCodes = [fromIntegral minCode .. fromIntegral maxCode]
- io $ ungrabKey dpy anyKey anyModifier rootw
- ks <- asks keyActions
- -- build a map from keysyms to lists of keysyms (doing what
- -- XGetKeyboardMapping would do if the X11 package bound it)
- syms <- forM allCodes $ \code -> io (keycodeToKeysym dpy code 0)
- let keysymMap = M.fromListWith (++) (zip syms [[code] | code <- allCodes])
- keysymToKeycodes sym = M.findWithDefault [] sym keysymMap
- forM_ (M.keys ks) $ \(mask,sym) ->
- forM_ (keysymToKeycodes sym) $ \kc ->
- 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
- ems <- extraModifiers
- ba <- asks buttonActions
- mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ ba)
-
--- | @replace@ to signals compliant window managers to exit.
-replace :: Display -> ScreenNumber -> Window -> IO ()
-replace dpy dflt rootw = do
- -- check for other WM
- wmSnAtom <- internAtom dpy ("WM_S" ++ show dflt) False
- currentWmSnOwner <- xGetSelectionOwner dpy wmSnAtom
- when (currentWmSnOwner /= 0) $ do
- -- prepare to receive destroyNotify for old WM
- selectInput dpy currentWmSnOwner structureNotifyMask
-
- -- create off-screen window
- netWmSnOwner <- allocaSetWindowAttributes $ \attributes -> do
- set_override_redirect attributes True
- set_event_mask attributes propertyChangeMask
- let screen = defaultScreenOfDisplay dpy
- visual = defaultVisualOfScreen screen
- attrmask = cWOverrideRedirect .|. cWEventMask
- createWindow dpy rootw (-100) (-100) 1 1 0 copyFromParent copyFromParent visual attrmask attributes
-
- -- try to acquire wmSnAtom, this should signal the old WM to terminate
- xSetSelectionOwner dpy wmSnAtom netWmSnOwner currentTime
-
- -- SKIPPED: check if we acquired the selection
- -- SKIPPED: send client message indicating that we are now the WM
-
- -- wait for old WM to go away
- fix $ \again -> do
- evt <- allocaXEvent $ \event -> do
- windowEvent dpy currentWmSnOwner structureNotifyMask event
- get_EventType event
-
- when (evt /= destroyNotify) again