{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}

----------------------------------------------------------------------------
-- |
-- 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, buildLaunch, launch) where

import System.Locale.SetLocale
import qualified Control.Exception as E
import Data.Bits
import Data.List ((\\))
import Data.Foldable (traverse_)
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad (filterM, guard, unless, void, when)
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid (getAll)

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
import System.Directory
import System.Info
import System.Environment (getArgs, getProgName, withArgs)
import System.Posix.Process (executeFile)
import System.Exit (exitFailure)
import System.FilePath

import Paths_xmonad (version)
import Data.Version (showVersion)

import Graphics.X11.Xinerama (compiledWithXinerama)
import Graphics.X11.Xrandr (xrrQueryExtension, xrrUpdateConfiguration)

------------------------------------------------------------------------


-- |
-- | The entry point into xmonad. Attempts to compile any custom main
-- for xmonad, and if it doesn't find one, just launches the default.
xmonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
xmonad :: forall (l :: * -> *).
(LayoutClass l EventType, Read (l EventType)) =>
XConfig l -> IO ()
xmonad XConfig l
conf = do
    IO ()
forall (m :: * -> *). MonadIO m => m ()
installSignalHandlers -- important to ignore SIGCHLD to avoid zombies

    dirs <- IO Directories
getDirectories
    let launch' [String]
args = do
              IO () -> IO ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
catchIO (Directories -> IO ()
buildLaunch Directories
dirs)
              conf'@XConfig { layoutHook = Layout l }
                  <- XConfig l -> [String] -> XConfig Layout -> IO (XConfig Layout)
forall (l :: * -> *).
XConfig l -> [String] -> XConfig Layout -> IO (XConfig Layout)
handleExtraArgs XConfig l
conf [String]
args XConfig l
conf{ layoutHook = Layout (layoutHook conf) }
              withArgs [] $ launch (conf' { layoutHook = l }) dirs

    args <- getArgs
    case args of
        [String
"--help"]            -> IO ()
usage
        [String
"--recompile"]       -> Directories -> Bool -> IO Bool
forall (m :: * -> *). MonadIO m => Directories -> Bool -> m Bool
recompile Directories
dirs Bool
True IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless IO ()
forall a. IO a
exitFailure
        [String
"--restart"]         -> IO ()
sendRestart
        [String
"--version"]         -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
shortVersion
        [String
"--verbose-version"] -> String -> IO ()
putStrLn (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
shortVersion [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
longVersion
        String
"--replace" : [String]
args'   -> IO ()
sendReplace IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> IO ()
launch' [String]
args'
        [String]
_                     -> [String] -> IO ()
launch' [String]
args
 where
    shortVersion :: [String]
shortVersion = [String
"xmonad", Version -> String
showVersion Version
version]
    longVersion :: [String]
longVersion  = [ String
"compiled by", String
compilerName, Version -> String
showVersion Version
compilerVersion
                   , String
"for",  String
arch String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
os
                   , String
"\nXinerama:", Bool -> String
forall a. Show a => a -> String
show Bool
compiledWithXinerama ]


usage :: IO ()
usage :: IO ()
usage = do
    self <- IO String
getProgName
    putStr . unlines $
        [ "Usage: " <> self <> " [OPTION]"
        , "Options:"
        , "  --help                       Print this message"
        , "  --version                    Print the version number"
        , "  --recompile                  Recompile your xmonad.hs"
        , "  --replace                    Replace the running window manager with xmonad"
        , "  --restart                    Request a running xmonad process to restart"
        ]

-- | Build the xmonad configuration file with ghc, then execute it.
-- If there are no errors, this function does not return.  An
-- exception is raised in any of these cases:
--
--   * ghc missing
--
--   * both the configuration file and executable are missing
--
--   * xmonad.hs fails to compile
--
--      ** wrong ghc in path (fails to compile)
--
--      ** type error, syntax error, ..
--
--   * Missing XMonad\/XMonadContrib modules due to ghc upgrade
--
buildLaunch :: Directories -> IO ()
buildLaunch :: Directories -> IO ()
buildLaunch Directories
dirs = do
    whoami <- IO String
getProgName
    let bin = Directories -> String
binFileName Directories
dirs
    let compiledConfig = String -> String
takeFileName String
bin
    unless (whoami == compiledConfig) $ do
      trace $ concat
        [ "XMonad is recompiling and replacing itself with another XMonad process because the current process is called "
        , show whoami
        , " but the compiled configuration should be called "
        , show compiledConfig
        ]
      recompile dirs False
      args <- getArgs
      executeFile bin False args Nothing

-- | Entry point into xmonad for custom builds.
--
-- This function isn't meant to be called by the typical xmonad user
-- because it:
--
--   * Does not process any command line arguments.
--
--   * Therefore doesn't know how to restart a running xmonad.
--
--   * Does not compile your configuration file since it assumes it's
--     actually running from within your compiled configuration.
--
-- Unless you know what you are doing, you should probably be using
-- the 'xmonad' function instead.
--
-- However, if you are using a custom build environment (such as
-- stack, cabal, make, etc.) you will likely want to call this
-- function instead of 'xmonad'.  You probably also want to have a key
-- binding to the 'XMonad.Operations.restart` function that restarts
-- your custom binary with the resume flag set to @True@.
launch :: (LayoutClass l Window, Read (l Window)) => XConfig l -> Directories -> IO ()
launch :: forall (l :: * -> *).
(LayoutClass l EventType, Read (l EventType)) =>
XConfig l -> Directories -> IO ()
launch XConfig l
initxmc Directories
drs = do
    -- setup locale information from environment
    Category -> Maybe String -> IO (Maybe String)
setLocale Category
LC_ALL (String -> Maybe String
forall a. a -> Maybe a
Just String
"")
    -- ignore SIGPIPE and SIGCHLD
    IO ()
forall (m :: * -> *). MonadIO m => m ()
installSignalHandlers
    -- First, wrap the layout in an existential, to keep things pretty:
    let xmc :: XConfig Layout
xmc = XConfig l
initxmc { layoutHook = Layout $ layoutHook initxmc }
    dpy   <- String -> IO Display
openDisplay String
""
    let dflt = Display -> EventType
defaultScreen Display
dpy

    rootw  <- rootWindow dpy dflt

    -- 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 = XConfig Layout -> Layout EventType
forall (l :: * -> *). XConfig l -> l EventType
layoutHook XConfig Layout
xmc
        initialWinset = let padToLen :: Int -> [String] -> [String]
padToLen Int
n [String]
xs = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs)) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
forall a. a -> [a]
repeat String
""
            in Layout EventType
-> [String]
-> [ScreenDetail]
-> StackSet String (Layout EventType) a ScreenId ScreenDetail
forall s l i sd a.
Integral s =>
l -> [i] -> [sd] -> StackSet i l a s sd
new Layout EventType
layout (Int -> [String] -> [String]
padToLen ([Rectangle] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rectangle]
xinesc) (XConfig Layout -> [String]
forall (l :: * -> *). XConfig l -> [String]
workspaces XConfig Layout
xmc)) ([ScreenDetail]
 -> StackSet String (Layout EventType) a ScreenId ScreenDetail)
-> [ScreenDetail]
-> StackSet String (Layout EventType) a ScreenId ScreenDetail
forall a b. (a -> b) -> a -> b
$ (Rectangle -> ScreenDetail) -> [Rectangle] -> [ScreenDetail]
forall a b. (a -> b) -> [a] -> [b]
map Rectangle -> ScreenDetail
SD [Rectangle]
xinesc

        cf = XConf
            { display :: Display
display       = Display
dpy
            , config :: XConfig Layout
config        = XConfig Layout
xmc
            , theRoot :: EventType
theRoot       = EventType
rootw
            , normalBorder :: EventType
normalBorder  = EventType
nbc
            , focusedBorder :: EventType
focusedBorder = EventType
fbc
            , keyActions :: Map (ButtonMask, EventType) (X ())
keyActions    = XConfig Layout
-> XConfig Layout -> Map (ButtonMask, EventType) (X ())
forall (l :: * -> *).
XConfig l -> XConfig Layout -> Map (ButtonMask, EventType) (X ())
keys XConfig Layout
xmc XConfig Layout
xmc
            , buttonActions :: Map (ButtonMask, EventType) (EventType -> X ())
buttonActions = XConfig Layout
-> XConfig Layout
-> Map (ButtonMask, EventType) (EventType -> X ())
forall (l :: * -> *).
XConfig l
-> XConfig Layout
-> Map (ButtonMask, EventType) (EventType -> X ())
mouseBindings XConfig Layout
xmc XConfig Layout
xmc
            , mouseFocused :: Bool
mouseFocused  = Bool
False
            , mousePosition :: Maybe (Position, Position)
mousePosition = Maybe (Position, Position)
forall a. Maybe a
Nothing
            , currentEvent :: Maybe Event
currentEvent  = Maybe Event
forall a. Maybe a
Nothing
            , directories :: Directories
directories   = Directories
drs
            }

        st = XState
            { windowset :: WindowSet
windowset       = WindowSet
forall {a}.
StackSet String (Layout EventType) a ScreenId ScreenDetail
initialWinset
            , numberlockMask :: ButtonMask
numberlockMask  = ButtonMask
0
            , mapped :: Set EventType
mapped          = Set EventType
forall a. Set a
S.empty
            , waitingUnmap :: Map EventType Int
waitingUnmap    = Map EventType Int
forall k a. Map k a
M.empty
            , dragging :: Maybe (Position -> Position -> X (), X ())
dragging        = Maybe (Position -> Position -> X (), X ())
forall a. Maybe a
Nothing
            , extensibleState :: Map String (Either String StateExtension)
extensibleState = Map String (Either String StateExtension)
forall k a. Map k a
M.empty
            }

    allocaXEvent $ \XEventPtr
e ->
        XConf -> XState -> X (ZonkAny 0) -> IO (ZonkAny 0, XState)
forall a. XConf -> XState -> X a -> IO (a, XState)
runX XConf
cf XState
st (X (ZonkAny 0) -> IO (ZonkAny 0, XState))
-> X (ZonkAny 0) -> IO (ZonkAny 0, XState)
forall a b. (a -> b) -> a -> b
$ do
            -- check for serialized state in a file.
            serializedSt <- do
                path <- (XConf -> String) -> X String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> String) -> X String) -> (XConf -> String) -> X String
forall a b. (a -> b) -> a -> b
$ Directories -> String
stateFileName (Directories -> String)
-> (XConf -> Directories) -> XConf -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Directories
directories
                exists <- io (doesFileExist path)
                if exists then readStateFile initxmc else return Nothing

            -- restore extensibleState if we read it from a file.
            let extst = Map String (Either String StateExtension)
-> (XState -> Map String (Either String StateExtension))
-> Maybe XState
-> Map String (Either String StateExtension)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map String (Either String StateExtension)
forall k a. Map k a
M.empty XState -> Map String (Either String StateExtension)
extensibleState Maybe XState
serializedSt
            modify (\XState
s -> XState
s {extensibleState = extst})

            cacheNumlockMask
            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.
            let winset = WindowSet -> (XState -> WindowSet) -> Maybe XState -> WindowSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WindowSet
forall {a}.
StackSet String (Layout EventType) a ScreenId ScreenDetail
initialWinset XState -> WindowSet
windowset Maybe XState
serializedSt
            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

            rrData <- io $ xrrQueryExtension dpy

            -- main loop, for all you HOF/recursion fans out there.
            -- forever $ prehandle =<< io (nextEvent dpy e >> rrUpdate e >> getEvent e)
            -- sadly, 9.2.{1,2,3} join points mishandle the above and trash the heap (see #389)
            mainLoop dpy e rrData

    return ()
      where
        -- if the event gives us the position of the pointer, set mousePosition
        prehandle :: Event -> X ()
prehandle Event
e = let mouse :: Maybe (Position, Position)
mouse = do Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Event -> EventType
ev_event_type Event
e EventType -> [EventType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EventType]
evs)
                                     (Position, Position) -> Maybe (Position, Position)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Event -> CInt
ev_x_root Event
e)
                                            ,CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Event -> CInt
ev_y_root Event
e))
                      in (XConf -> XConf) -> X () -> X ()
forall a. (XConf -> XConf) -> X a -> X a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\XConf
c -> XConf
c { mousePosition = mouse, currentEvent = Just e }) (Event -> X ()
handleWithHook Event
e)
        evs :: [EventType]
evs = [ EventType
keyPress, EventType
keyRelease, EventType
enterNotify, EventType
leaveNotify
              , EventType
buttonPress, EventType
buttonRelease]
        rrUpdate :: XEventPtr -> Maybe a -> IO ()
rrUpdate XEventPtr
e Maybe a
r = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
r) (IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (XEventPtr -> IO CInt
xrrUpdateConfiguration XEventPtr
e))
        mainLoop :: Display -> XEventPtr -> Maybe a -> X b
mainLoop Display
d XEventPtr
e Maybe a
r = IO Event -> X Event
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> XEventPtr -> IO ()
nextEvent Display
d XEventPtr
e IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XEventPtr -> Maybe a -> IO ()
forall {a}. XEventPtr -> Maybe a -> IO ()
rrUpdate XEventPtr
e Maybe a
r IO () -> IO Event -> IO Event
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XEventPtr -> IO Event
getEvent XEventPtr
e) X Event -> (Event -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Event -> X ()
prehandle X () -> X b -> X b
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Display -> XEventPtr -> Maybe a -> X b
mainLoop Display
d XEventPtr
e Maybe a
r


-- | Runs handleEventHook from the configuration and runs the default handler
-- function if it returned True.
handleWithHook :: Event -> X ()
handleWithHook :: Event -> X ()
handleWithHook Event
e = do
  evHook <- (XConf -> Event -> X All) -> X (Event -> X All)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> Event -> X All
forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook (XConfig Layout -> Event -> X All)
-> (XConf -> XConfig Layout) -> XConf -> Event -> X All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
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 :: Event -> X ()
handle (KeyEvent {ev_event_type :: Event -> EventType
ev_event_type = EventType
t, ev_state :: Event -> ButtonMask
ev_state = ButtonMask
m, ev_keycode :: Event -> KeyCode
ev_keycode = KeyCode
code})
    | EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
keyPress = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
        s  <- IO EventType -> X EventType
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO EventType -> X EventType) -> IO EventType -> X EventType
forall a b. (a -> b) -> a -> b
$ Display -> KeyCode -> CInt -> IO EventType
keycodeToKeysym Display
dpy KeyCode
code CInt
0
        mClean <- cleanMask m
        ks <- asks keyActions
        userCodeDef () $ whenJust (M.lookup (mClean, s) ks) id

-- manage a new window
handle (MapRequestEvent    {ev_window :: Event -> EventType
ev_window = EventType
w}) = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    Display -> EventType -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes Display
dpy EventType
w ((WindowAttributes -> X ()) -> X ())
-> (WindowAttributes -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowAttributes
wa -> do -- ignore override windows
      -- need to ignore mapping requests by managed windows not on the current workspace
      managed <- EventType -> X Bool
isClient EventType
w
      when (not (wa_override_redirect wa) && not managed) $ manage w

-- window destroyed, unmanage it
-- window gone,      unmanage it
-- broadcast to layouts
handle e :: Event
e@(DestroyWindowEvent {ev_window :: Event -> EventType
ev_window = EventType
w}) = do
  X Bool -> X () -> X ()
whenX (EventType -> X Bool
isClient EventType
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    EventType -> X ()
unmanage EventType
w
    (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { mapped       = S.delete w (mapped s)
                    , waitingUnmap = M.delete w (waitingUnmap s)})
  -- the window is already unmanged, but we broadcast the event to all layouts
  -- to trigger garbage-collection in case they hold window-specific resources
  Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
e

-- 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 :: Event -> EventType
ev_window = EventType
w, ev_send_event :: Event -> Bool
ev_send_event = Bool
synthetic}) = X Bool -> X () -> X ()
whenX (EventType -> X Bool
isClient EventType
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    e <- (XState -> Int) -> X Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (XState -> Maybe Int) -> XState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventType -> Map EventType Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup EventType
w (Map EventType Int -> Maybe Int)
-> (XState -> Map EventType Int) -> XState -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> Map EventType Int
waitingUnmap)
    if synthetic || e == 0
        then unmanage w
        else modify (\XState
s -> XState
s { waitingUnmap = M.update mpred w (waitingUnmap s) })
 where mpred :: a -> Maybe a
mpred a
1 = Maybe a
forall a. Maybe a
Nothing
       mpred a
n = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Enum a => a -> a
pred a
n

-- set keyboard mapping
handle e :: Event
e@(MappingNotifyEvent {}) = do
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Event -> IO ()
refreshKeyboardMapping Event
e
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> CInt
ev_request Event
e CInt -> [CInt] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt
mappingKeyboard, CInt
mappingModifier]) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
        X ()
cacheNumlockMask
        X ()
grabKeys

-- handle button release, which may finish dragging.
handle e :: Event
e@(ButtonEvent {ev_event_type :: Event -> EventType
ev_event_type = EventType
t})
    | EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
buttonRelease = do
    drag <- (XState -> Maybe (Position -> Position -> X (), X ()))
-> X (Maybe (Position -> Position -> X (), X ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> Maybe (Position -> Position -> X (), X ())
dragging
    case drag of
        -- we're done dragging and have released the mouse:
        Just (Position -> Position -> X ()
_,X ()
f) -> (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { dragging = Nothing }) X () -> X () -> X ()
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
f
        Maybe (Position -> Position -> X (), X ())
Nothing    -> Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
e

-- handle motionNotify event, which may mean we are dragging.
handle e :: Event
e@(MotionEvent {ev_event_type :: Event -> EventType
ev_event_type = EventType
_t, ev_x :: Event -> CInt
ev_x = CInt
x, ev_y :: Event -> CInt
ev_y = CInt
y}) = do
    drag <- (XState -> Maybe (Position -> Position -> X (), X ()))
-> X (Maybe (Position -> Position -> X (), X ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> Maybe (Position -> Position -> X (), X ())
dragging
    case drag of
        Just (Position -> Position -> X ()
d,X ()
_) -> Position -> Position -> X ()
d (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
y) -- we're dragging
        Maybe (Position -> Position -> X (), X ())
Nothing -> Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
e

-- click on an unfocused window, makes it focused on this workspace
handle e :: Event
e@(ButtonEvent {ev_window :: Event -> EventType
ev_window = EventType
w,ev_event_type :: Event -> EventType
ev_event_type = EventType
t,ev_button :: Event -> EventType
ev_button = EventType
b })
    | EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
buttonPress = do
    -- If it's the root window, then it's something we
    -- grabbed in grabButtons. Otherwise, it's click-to-focus.
    dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    isr <- isRoot w
    m <- cleanMask $ ev_state e
    mact <- asks (M.lookup (m, b) . buttonActions)
    case mact of
        Just EventType -> X ()
act | Bool
isr -> EventType -> X ()
act (EventType -> X ()) -> EventType -> X ()
forall a b. (a -> b) -> a -> b
$ Event -> EventType
ev_subwindow Event
e
        Maybe (EventType -> X ())
_              -> do
            EventType -> X ()
focus EventType
w
            ctf <- (XConf -> Bool) -> X Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> Bool
forall (l :: * -> *). XConfig l -> Bool
clickJustFocuses (XConfig Layout -> Bool)
-> (XConf -> XConfig Layout) -> XConf -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
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 :: Event
e@(CrossingEvent {ev_window :: Event -> EventType
ev_window = EventType
w, ev_event_type :: Event -> EventType
ev_event_type = EventType
t})
    | EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
enterNotify Bool -> Bool -> Bool
&& Event -> CInt
ev_mode   Event
e CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
notifyNormal
    = X Bool -> X () -> X ()
whenX ((XConf -> Bool) -> X Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> Bool) -> X Bool) -> (XConf -> Bool) -> X Bool
forall a b. (a -> b) -> a -> b
$ XConfig Layout -> Bool
forall (l :: * -> *). XConfig l -> Bool
focusFollowsMouse (XConfig Layout -> Bool)
-> (XConf -> XConfig Layout) -> XConf -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
        dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
        root <- asks theRoot
        (_, _, w', _, _, _, _, _) <- io $ queryPointer dpy root
        -- when Xlib cannot find a child that contains the pointer,
        -- it returns None(0)
        when (w' == 0 || w == w') (focus w)

-- left a window, check if we need to focus root
handle e :: Event
e@(CrossingEvent {ev_event_type :: Event -> EventType
ev_event_type = EventType
t})
    | EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
leaveNotify
    = do rootw <- (XConf -> EventType) -> X EventType
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> EventType
theRoot
         when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw

-- configure a window
handle e :: Event
e@(ConfigureRequestEvent {ev_window :: Event -> EventType
ev_window = EventType
w}) = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
    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 withWindowAttributes dpy w $ \WindowAttributes
wa -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO ()) -> IO ()
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XEventPtr
ev -> do
                 XEventPtr -> EventType -> IO ()
setEventType XEventPtr
ev EventType
configureNotify
                 XEventPtr
-> EventType
-> EventType
-> CInt
-> CInt
-> CInt
-> CInt
-> CInt
-> EventType
-> Bool
-> IO ()
setConfigureEvent XEventPtr
ev EventType
w EventType
w
                     (WindowAttributes -> CInt
wa_x WindowAttributes
wa) (WindowAttributes -> CInt
wa_y WindowAttributes
wa) (WindowAttributes -> CInt
wa_width WindowAttributes
wa)
                     (WindowAttributes -> CInt
wa_height WindowAttributes
wa) (Event -> CInt
ev_border_width Event
e) EventType
none (WindowAttributes -> Bool
wa_override_redirect WindowAttributes
wa)
                 Display -> EventType -> Bool -> EventType -> XEventPtr -> IO ()
sendEvent Display
dpy EventType
w Bool
False EventType
0 XEventPtr
ev
    io $ sync dpy False

-- configuration changes in the root may mean display settings have changed
handle (ConfigureEvent {ev_window :: Event -> EventType
ev_window = EventType
w}) = X Bool -> X () -> X ()
whenX (EventType -> X Bool
isRoot EventType
w) X ()
rescreen

-- property notify
handle event :: Event
event@(PropertyEvent { ev_event_type :: Event -> EventType
ev_event_type = EventType
t, ev_atom :: Event -> EventType
ev_atom = EventType
a })
    | EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
propertyNotify Bool -> Bool -> Bool
&& EventType
a EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
wM_NAME = (XConf -> X ()) -> X (X ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook (XConfig Layout -> X ())
-> (XConf -> XConfig Layout) -> XConf -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config) X (X ()) -> (X () -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= () -> X () -> X ()
forall a. a -> X a -> X a
userCodeDef () X () -> X () -> X ()
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                                         Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
event

handle e :: Event
e@ClientMessageEvent { ev_message_type :: Event -> EventType
ev_message_type = EventType
mt } = do
    a <- String -> X EventType
getAtom String
"XMONAD_RESTART"
    if mt == a
        then restart "xmonad" True
        else broadcastMessage e

handle Event
e = Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
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 :: Display -> EventType -> IO [EventType]
scan Display
dpy EventType
rootw = do
    (_, _, ws) <- Display -> EventType -> IO (EventType, EventType, [EventType])
queryTree Display
dpy EventType
rootw
    filterM (\EventType
w -> EventType -> IO Bool
ok EventType
w IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO Bool
skip) ws
  -- TODO: scan for windows that are either 'IsViewable' or where WM_STATE ==
  -- Iconic
  where ok :: EventType -> IO Bool
ok EventType
w = do wa <- Display -> EventType -> IO WindowAttributes
getWindowAttributes Display
dpy EventType
w
                  a  <- internAtom dpy "WM_STATE" False
                  p  <- getWindowProperty32 dpy a w
                  let ic = case Maybe [CLong]
p of
                            Just (CLong
3:[CLong]
_) -> Bool
True -- 3 for iconified
                            Maybe [CLong]
_          -> Bool
False
                  return $ not (wa_override_redirect wa)
                         && (wa_map_state wa == waIsViewable || ic)

        skip :: E.SomeException -> IO Bool
        skip :: SomeException -> IO Bool
skip SomeException
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Grab the keys back
grabKeys :: X ()
grabKeys :: X ()
grabKeys = do
    XConf { display = dpy, theRoot = rootw } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    io $ ungrabKey dpy anyKey anyModifier rootw
    let grab :: (KeyMask, KeyCode) -> X ()
        grab (ButtonMask
km, KeyCode
kc) = IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display
-> KeyCode
-> ButtonMask
-> EventType
-> Bool
-> CInt
-> CInt
-> IO ()
grabKey Display
dpy KeyCode
kc ButtonMask
km EventType
rootw Bool
True CInt
grabModeAsync CInt
grabModeAsync
    traverse_ grab =<< mkGrabs =<< asks (M.keys . keyActions)

-- | Grab the buttons
grabButtons :: X ()
grabButtons :: X ()
grabButtons = do
    XConf { display = dpy, theRoot = rootw } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    let grab EventType
button ButtonMask
mask = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display
-> EventType
-> ButtonMask
-> EventType
-> Bool
-> EventType
-> CInt
-> CInt
-> EventType
-> EventType
-> IO ()
grabButton Display
dpy EventType
button ButtonMask
mask EventType
rootw Bool
False EventType
buttonPressMask
                                           CInt
grabModeAsync CInt
grabModeSync EventType
none EventType
none
    io $ ungrabButton dpy anyButton anyModifier rootw
    ems <- extraModifiers
    ba <- asks buttonActions
    mapM_ (\(ButtonMask
m,EventType
b) -> (ButtonMask -> X ()) -> [ButtonMask] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (EventType -> ButtonMask -> X ()
forall {m :: * -> *}. MonadIO m => EventType -> ButtonMask -> m ()
grab EventType
b (ButtonMask -> X ())
-> (ButtonMask -> ButtonMask) -> ButtonMask -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ButtonMask
m ButtonMask -> ButtonMask -> ButtonMask
forall a. Bits a => a -> a -> a
.|.)) [ButtonMask]
ems) (M.keys ba)