{-# 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, forever)
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 KeySym, Read (l KeySym)) =>
XConfig l -> IO ()
xmonad XConfig l
conf = do
    forall (m :: * -> *). MonadIO m => m ()
installSignalHandlers -- important to ignore SIGCHLD to avoid zombies

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

    [String]
args <- IO [String]
getArgs
    case [String]
args of
        [String
"--help"]            -> IO ()
usage
        [String
"--recompile"]       -> forall (m :: * -> *). MonadIO m => Directories -> Bool -> m Bool
recompile Directories
dirs Bool
True forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless forall a. IO a
exitFailure
        [String
"--restart"]         -> IO ()
sendRestart
        [String
"--version"]         -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
shortVersion
        [String
"--verbose-version"] -> String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ [String]
shortVersion forall a. [a] -> [a] -> [a]
++ [String]
longVersion
        String
"--replace" : [String]
args'   -> IO ()
sendReplace 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 forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++ String
os
                   , String
"\nXinerama:", forall a. Show a => a -> String
show Bool
compiledWithXinerama ]


usage :: IO ()
usage :: IO ()
usage = do
    String
self <- IO String
getProgName
    String -> IO ()
putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
        [ String
"Usage: " forall a. Semigroup a => a -> a -> a
<> String
self forall a. Semigroup a => a -> a -> a
<> String
" [OPTION]"
        , String
"Options:"
        , String
"  --help                       Print this message"
        , String
"  --version                    Print the version number"
        , String
"  --recompile                  Recompile your xmonad.hs"
        , String
"  --replace                    Replace the running window manager with xmonad"
        , String
"  --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
    String
whoami <- IO String
getProgName
    let bin :: String
bin = Directories -> String
binFileName Directories
dirs
    let compiledConfig :: String
compiledConfig = String -> String
takeFileName String
bin
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
whoami forall a. Eq a => a -> a -> Bool
== String
compiledConfig) forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *). MonadIO m => String -> m ()
trace forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"XMonad is recompiling and replacing itself with another XMonad process because the current process is called "
        , forall a. Show a => a -> String
show String
whoami
        , String
" but the compiled configuration should be called "
        , forall a. Show a => a -> String
show String
compiledConfig
        ]
      forall (m :: * -> *). MonadIO m => Directories -> Bool -> m Bool
recompile Directories
dirs Bool
False
      [String]
args <- IO [String]
getArgs
      forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile String
bin Bool
False [String]
args forall a. Maybe a
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 KeySym, Read (l KeySym)) =>
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 (forall a. a -> Maybe a
Just String
"")
    -- ignore SIGPIPE and SIGCHLD
    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 KeySym
layoutHook = forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
Layout forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> l KeySym
layoutHook XConfig l
initxmc }
    Display
dpy   <- String -> IO Display
openDisplay String
""
    let dflt :: EventType
dflt = Display -> EventType
defaultScreen Display
dpy

    KeySym
rootw  <- Display -> EventType -> IO KeySym
rootWindow Display
dpy EventType
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.
    Display -> KeySym -> KeySym -> IO ()
selectInput Display
dpy KeySym
rootw forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> KeySym
rootMask XConfig l
initxmc

    Display -> Bool -> IO ()
sync Display
dpy Bool
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)
    IO ()
xSetErrorHandler -- in C, I'm too lazy to write the binding: dons

    [Rectangle]
xinesc <- forall (m :: * -> *). MonadIO m => Display -> m [Rectangle]
getCleanedScreenInfo Display
dpy

    KeySym
nbc    <- do Maybe KeySym
v         <- Display -> String -> IO (Maybe KeySym)
initColor Display
dpy forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> String
normalBorderColor  XConfig Layout
xmc
                 Just KeySym
nbc_ <- Display -> String -> IO (Maybe KeySym)
initColor Display
dpy forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> String
normalBorderColor forall a. Default a => a
Default.def
                 forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a -> a
fromMaybe KeySym
nbc_ Maybe KeySym
v)

    KeySym
fbc    <- do Maybe KeySym
v <- Display -> String -> IO (Maybe KeySym)
initColor Display
dpy forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> String
focusedBorderColor XConfig Layout
xmc
                 Just KeySym
fbc_ <- Display -> String -> IO (Maybe KeySym)
initColor Display
dpy forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> String
focusedBorderColor forall a. Default a => a
Default.def
                 forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a -> a
fromMaybe KeySym
fbc_ Maybe KeySym
v)

    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering

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

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

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

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

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

            X ()
cacheNumlockMask
            X ()
grabKeys
            X ()
grabButtons

            forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Bool -> IO ()
sync Display
dpy Bool
False

            [KeySym]
ws <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> KeySym -> IO [KeySym]
scan Display
dpy KeySym
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
winset = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. StackSet String (Layout KeySym) a ScreenId ScreenDetail
initialWinset XState -> WindowSet
windowset Maybe XState
serializedSt
            (WindowSet -> WindowSet) -> X ()
windows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a i l s sd.
Ord a =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.delete WindowSet
winset forall a b. (a -> b) -> a -> b
$ forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows WindowSet
winset forall a. Eq a => [a] -> [a] -> [a]
\\ [KeySym]
ws

            -- manage the as-yet-unmanaged windows
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ KeySym -> X ()
manage ([KeySym]
ws forall a. Eq a => [a] -> [a] -> [a]
\\ forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows WindowSet
winset)

            forall a. X a -> X (Maybe a)
userCode forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig l
initxmc

            Maybe (CInt, CInt)
rrData <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> IO (Maybe (CInt, CInt))
xrrQueryExtension Display
dpy
            let rrUpdate :: XEventPtr -> IO ()
rrUpdate = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (CInt, CInt)
rrData) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. XEventPtr -> IO CInt
xrrUpdateConfiguration

            -- main loop, for all you HOF/recursion fans out there.
            forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ Event -> X ()
prehandle forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> XEventPtr -> IO ()
nextEvent Display
dpy XEventPtr
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XEventPtr -> IO ()
rrUpdate XEventPtr
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XEventPtr -> IO Event
getEvent XEventPtr
e)

    forall (m :: * -> *) a. Monad m => a -> m a
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 forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Event -> EventType
ev_event_type Event
e forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EventType]
evs)
                                     forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Event -> CInt
ev_x_root Event
e)
                                            ,forall a b. (Integral a, Num b) => a -> b
fromIntegral (Event -> CInt
ev_y_root Event
e))
                      in forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\XConf
c -> XConf
c { mousePosition :: Maybe (Position, Position)
mousePosition = Maybe (Position, Position)
mouse, currentEvent :: Maybe Event
currentEvent = forall a. a -> Maybe a
Just Event
e }) (Event -> X ()
handleWithHook Event
e)
        evs :: [EventType]
evs = [ EventType
keyPress, EventType
keyRelease, EventType
enterNotify, EventType
leaveNotify
              , EventType
buttonPress, EventType
buttonRelease]


-- | 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
  Event -> X All
evHook <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
  X Bool -> X () -> X ()
whenX (forall a. a -> X a -> X a
userCodeDef Bool
True forall a b. (a -> b) -> a -> b
$ All -> Bool
getAll forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Event -> X All
evHook Event
e) (Event -> X ()
handle Event
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 forall a. Eq a => a -> a -> Bool
== EventType
keyPress = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
        KeySym
s  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> KeyCode -> CInt -> IO KeySym
keycodeToKeysym Display
dpy KeyCode
code CInt
0
        ButtonMask
mClean <- ButtonMask -> X ButtonMask
cleanMask ButtonMask
m
        Map (ButtonMask, KeySym) (X ())
ks <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Map (ButtonMask, KeySym) (X ())
keyActions
        forall a. a -> X a -> X a
userCodeDef () forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ButtonMask
mClean, KeySym
s) Map (ButtonMask, KeySym) (X ())
ks) forall a. a -> a
id

-- manage a new window
handle (MapRequestEvent    {ev_window :: Event -> KeySym
ev_window = KeySym
w}) = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    Display -> KeySym -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes Display
dpy KeySym
w 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
      Bool
managed <- KeySym -> X Bool
isClient KeySym
w
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (WindowAttributes -> Bool
wa_override_redirect WindowAttributes
wa) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
managed) forall a b. (a -> b) -> a -> b
$ KeySym -> X ()
manage KeySym
w

-- window destroyed, unmanage it
-- window gone,      unmanage it
-- broadcast to layouts
handle e :: Event
e@(DestroyWindowEvent {ev_window :: Event -> KeySym
ev_window = KeySym
w}) = do
  X Bool -> X () -> X ()
whenX (KeySym -> X Bool
isClient KeySym
w) forall a b. (a -> b) -> a -> b
$ do
    KeySym -> X ()
unmanage KeySym
w
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { mapped :: Set KeySym
mapped       = forall a. Ord a => a -> Set a -> Set a
S.delete KeySym
w (XState -> Set KeySym
mapped XState
s)
                    , waitingUnmap :: Map KeySym Int
waitingUnmap = forall k a. Ord k => k -> Map k a -> Map k a
M.delete KeySym
w (XState -> Map KeySym Int
waitingUnmap XState
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
  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 -> KeySym
ev_window = KeySym
w, ev_send_event :: Event -> Bool
ev_send_event = Bool
synthetic}) = X Bool -> X () -> X ()
whenX (KeySym -> X Bool
isClient KeySym
w) forall a b. (a -> b) -> a -> b
$ do
    Int
e <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. a -> Maybe a -> a
fromMaybe Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup KeySym
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> Map KeySym Int
waitingUnmap)
    if Bool
synthetic Bool -> Bool -> Bool
|| Int
e forall a. Eq a => a -> a -> Bool
== Int
0
        then KeySym -> X ()
unmanage KeySym
w
        else forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { waitingUnmap :: Map KeySym Int
waitingUnmap = forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update forall {a}. (Eq a, Num a, Enum a) => a -> Maybe a
mpred KeySym
w (XState -> Map KeySym Int
waitingUnmap XState
s) })
 where mpred :: a -> Maybe a
mpred a
1 = forall a. Maybe a
Nothing
       mpred a
n = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
pred a
n

-- set keyboard mapping
handle e :: Event
e@(MappingNotifyEvent {}) = do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Event -> IO ()
refreshKeyboardMapping Event
e
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> CInt
ev_request Event
e forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt
mappingKeyboard, CInt
mappingModifier]) 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 forall a. Eq a => a -> a -> Bool
== EventType
buttonRelease = do
    Maybe (Position -> Position -> X (), X ())
drag <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> Maybe (Position -> Position -> X (), X ())
dragging
    case Maybe (Position -> Position -> X (), X ())
drag of
        -- we're done dragging and have released the mouse:
        Just (Position -> Position -> X ()
_,X ()
f) -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { dragging :: Maybe (Position -> Position -> X (), X ())
dragging = forall a. Maybe a
Nothing }) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
f
        Maybe (Position -> Position -> X (), X ())
Nothing    -> 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
    Maybe (Position -> Position -> X (), X ())
drag <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> Maybe (Position -> Position -> X (), X ())
dragging
    case Maybe (Position -> Position -> X (), X ())
drag of
        Just (Position -> Position -> X ()
d,X ()
_) -> Position -> Position -> X ()
d (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
y) -- we're dragging
        Maybe (Position -> Position -> X (), X ())
Nothing -> 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 -> KeySym
ev_window = KeySym
w,ev_event_type :: Event -> EventType
ev_event_type = EventType
t,ev_button :: Event -> EventType
ev_button = EventType
b })
    | EventType
t 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.
    Display
dpy <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    Bool
isr <- KeySym -> X Bool
isRoot KeySym
w
    ButtonMask
m <- ButtonMask -> X ButtonMask
cleanMask forall a b. (a -> b) -> a -> b
$ Event -> ButtonMask
ev_state Event
e
    Maybe (KeySym -> X ())
mact <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ButtonMask
m, EventType
b) forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Map (ButtonMask, EventType) (KeySym -> X ())
buttonActions)
    case Maybe (KeySym -> X ())
mact of
        Just KeySym -> X ()
act | Bool
isr -> KeySym -> X ()
act forall a b. (a -> b) -> a -> b
$ Event -> KeySym
ev_subwindow Event
e
        Maybe (KeySym -> X ())
_              -> do
            KeySym -> X ()
focus KeySym
w
            Bool
ctf <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (l :: * -> *). XConfig l -> Bool
clickJustFocuses forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ctf forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> CInt -> KeySym -> IO ()
allowEvents Display
dpy CInt
replayPointer KeySym
currentTime)
    forall a. Message a => a -> X ()
broadcastMessage Event
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 -> KeySym
ev_window = KeySym
w, ev_event_type :: Event -> EventType
ev_event_type = EventType
t})
    | EventType
t forall a. Eq a => a -> a -> Bool
== EventType
enterNotify Bool -> Bool -> Bool
&& Event -> CInt
ev_mode   Event
e forall a. Eq a => a -> a -> Bool
== CInt
notifyNormal
    = X Bool -> X () -> X ()
whenX (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> Bool
focusFollowsMouse forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config) forall a b. (a -> b) -> a -> b
$ do
        Display
dpy <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
        KeySym
root <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> KeySym
theRoot
        (Bool
_, KeySym
_, KeySym
w', CInt
_, CInt
_, CInt
_, CInt
_, ButtonMask
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> KeySym
-> IO (Bool, KeySym, KeySym, CInt, CInt, CInt, CInt, ButtonMask)
queryPointer Display
dpy KeySym
root
        -- when Xlib cannot find a child that contains the pointer,
        -- it returns None(0)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeySym
w' forall a. Eq a => a -> a -> Bool
== KeySym
0 Bool -> Bool -> Bool
|| KeySym
w forall a. Eq a => a -> a -> Bool
== KeySym
w') (KeySym -> X ()
focus KeySym
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 forall a. Eq a => a -> a -> Bool
== EventType
leaveNotify
    = do KeySym
rootw <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> KeySym
theRoot
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> KeySym
ev_window Event
e forall a. Eq a => a -> a -> Bool
== KeySym
rootw Bool -> Bool -> Bool
&& Bool -> Bool
not (Event -> Bool
ev_same_screen Event
e)) forall a b. (a -> b) -> a -> b
$ KeySym -> X ()
setFocusX KeySym
rootw

-- configure a window
handle e :: Event
e@(ConfigureRequestEvent {ev_window :: Event -> KeySym
ev_window = KeySym
w}) = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    WindowSet
ws <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
    EventType
bw <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (l :: * -> *). XConfig l -> EventType
borderWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)

    if forall k a. Ord k => k -> Map k a -> Bool
M.member KeySym
w (forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
floating WindowSet
ws)
        Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Bool
member KeySym
w WindowSet
ws)
        then do forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> KeySym -> CULong -> WindowChanges -> IO ()
configureWindow Display
dpy KeySym
w (Event -> CULong
ev_value_mask Event
e) forall a b. (a -> b) -> a -> b
$ WindowChanges
                    { wc_x :: CInt
wc_x            = Event -> CInt
ev_x Event
e
                    , wc_y :: CInt
wc_y            = Event -> CInt
ev_y Event
e
                    , wc_width :: CInt
wc_width        = Event -> CInt
ev_width Event
e
                    , wc_height :: CInt
wc_height       = Event -> CInt
ev_height Event
e
                    , wc_border_width :: CInt
wc_border_width = forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
bw
                    , wc_sibling :: KeySym
wc_sibling      = Event -> KeySym
ev_above Event
e
                    , wc_stack_mode :: CInt
wc_stack_mode   = Event -> CInt
ev_detail Event
e }
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Bool
member KeySym
w WindowSet
ws) (KeySym -> X ()
float KeySym
w)
        else Display -> KeySym -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes Display
dpy KeySym
w forall a b. (a -> b) -> a -> b
$ \WindowAttributes
wa -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent forall a b. (a -> b) -> a -> b
$ \XEventPtr
ev -> do
                 XEventPtr -> EventType -> IO ()
setEventType XEventPtr
ev EventType
configureNotify
                 XEventPtr
-> KeySym
-> KeySym
-> CInt
-> CInt
-> CInt
-> CInt
-> CInt
-> KeySym
-> Bool
-> IO ()
setConfigureEvent XEventPtr
ev KeySym
w KeySym
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) KeySym
none (WindowAttributes -> Bool
wa_override_redirect WindowAttributes
wa)
                 Display -> KeySym -> Bool -> KeySym -> XEventPtr -> IO ()
sendEvent Display
dpy KeySym
w Bool
False KeySym
0 XEventPtr
ev
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Bool -> IO ()
sync Display
dpy Bool
False

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

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

handle e :: Event
e@ClientMessageEvent { ev_message_type :: Event -> KeySym
ev_message_type = KeySym
mt } = do
    KeySym
a <- String -> X KeySym
getAtom String
"XMONAD_RESTART"
    if KeySym
mt forall a. Eq a => a -> a -> Bool
== KeySym
a
        then String -> Bool -> X ()
restart String
"xmonad" Bool
True
        else forall a. Message a => a -> X ()
broadcastMessage Event
e

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

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

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

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