XMonad.Main: call setlocale on startup

darcs-hash:20080406011234-462cf-09fde81185653a210d292b90b02595de7c365bb1.gz

1 files changed, 308 insertions, 0 deletions

diff --git a/XMonad/Main.hsc b/XMonad/Main.hsc
new file mode 100644
index 0000000..5df6ed8
--- /dev/null
+++ b/XMonad/Main.hsc
@@ -0,0 +1,308 @@
+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, ForeignFunctionInterface #-}
+----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Main
+-- 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 XMonad.Main (xmonad) where
+
+import Data.Bits
+import Data.List ((\\))
+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 Foreign.C
+import Foreign.Ptr
+
+import System.Environment (getArgs)
+import System.Posix.Signals
+
+import Graphics.X11.Xlib hiding (refreshKeyboardMapping)
+import Graphics.X11.Xlib.Extras
+
+import XMonad.Core
+import qualified XMonad.Config as Default
+import XMonad.StackSet (new, floating, member)
+import qualified XMonad.StackSet as W
+import XMonad.Operations
+
+import System.IO
+
+#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 "" $ \p -> do
+        c_setlocale (#const LC_ALL) p
+    -- ignore SIGPIPE
+    installHandler openEndedPipe Ignore Nothing
+    -- 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
+    xinesc <- getCleanedScreenInfo dpy
+    nbc    <- do v            <- initColor dpy $ normalBorderColor  xmc
+                 ~(Just nbc_) <- initColor dpy $ normalBorderColor Default.defaultConfig
+                 return (fromMaybe nbc_ v)
+
+    fbc    <- do v <- initColor dpy $ focusedBorderColor xmc
+                 ~(Just fbc_)  <- initColor dpy $ focusedBorderColor Default.defaultConfig
+                 return (fromMaybe fbc_ v)
+
+    hSetBuffering stdout NoBuffering
+    args <- getArgs
+
+    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.ensureTags layout (workspaces xmc)
+                           $ W.mapLayout (fromMaybe layout . maybeRead lreads) ws
+
+        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 -- 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
+
+            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_ manage (ws \\ W.allWindows winset)
+
+            userCode $ startupHook initxmc
+
+            -- 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
+        ks <- asks keyActions
+        userCode $ 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 manage w
+
+-- window destroyed, unmanage it
+-- window gone,      unmanage it
+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)})
+
+-- 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.update mpred w (waitingUnmap s) })
+ where mpred 1 = Nothing
+       mpred n = Just $ pred n
+
+-- 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
+    m <- cleanMask $ ev_state e
+    ba <- asks buttonActions
+    if isr then userCode $ whenJust (M.lookup (m, b) ba) ($ ev_subwindow e)
+           else focus w
+    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
+                       && ev_detail e /= notifyInferior
+    = 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
+    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
+
+-- 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 =<< asks (logHook . config)
+
+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 :: 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
+         -- "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
+    ems <- extraModifiers
+    ba <- asks buttonActions
+    mapM_ (\(m,b) -> mapM_ (grab b . (m .|.)) ems) (M.keys $ ba)