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

import System.Locale.SetLocale
import qualified Control.Exception as E
import Data.Bits
import Data.List ((\\))
import Data.Foldable (traverse_)
import Data.Function
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad.Reader
import Control.Monad.State
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 Window, Read (l Window)) =>
XConfig l -> IO ()
xmonad XConfig l
conf = do
    IO ()
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
              IO () -> IO ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
catchIO (Directories -> IO ()
buildLaunch Directories
dirs)
              conf' :: XConfig Layout
conf'@XConfig { layoutHook :: forall (l :: * -> *). XConfig l -> l Window
layoutHook = Layout l Window
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 Window
layoutHook = l Window -> Layout Window
forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
Layout (XConfig l -> l Window
forall (l :: * -> *). XConfig l -> l Window
layoutHook XConfig l
conf) }
              [String] -> IO () -> IO ()
forall a. [String] -> IO a -> IO a
withArgs [] (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ XConfig l -> Directories -> IO ()
forall (l :: * -> *).
(LayoutClass l Window, Read (l Window)) =>
XConfig l -> Directories -> IO ()
launch (XConfig Layout
conf' { layoutHook :: l Window
layoutHook = l Window
l }) Directories
dirs

    [String]
args <- IO [String]
getArgs
    case [String]
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 (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 (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
    String
self <- IO String
getProgName
    String -> IO ()
putStr (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [ String
"Usage: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
self String -> String -> String
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
whoami String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
compiledConfig) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
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 "
        , String -> String
forall a. Show a => a -> String
show String
whoami
        , String
" but the compiled configuration should be called "
        , String -> String
forall a. Show a => a -> String
show String
compiledConfig
        ]
      Directories -> Bool -> IO Bool
forall (m :: * -> *). MonadIO m => Directories -> Bool -> m Bool
recompile Directories
dirs Bool
False
      [String]
args <- IO [String]
getArgs
      String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile String
bin Bool
False [String]
args Maybe [(String, String)]
forall a. Maybe a
Nothing

sendRestart :: IO ()
sendRestart :: IO ()
sendRestart = do
    Display
dpy <- String -> IO Display
openDisplay String
""
    Window
rw <- Display -> ScreenNumber -> IO Window
rootWindow Display
dpy (ScreenNumber -> IO Window) -> ScreenNumber -> IO Window
forall a b. (a -> b) -> a -> b
$ Display -> ScreenNumber
defaultScreen Display
dpy
    Window
xmonad_restart <- Display -> String -> Bool -> IO Window
internAtom Display
dpy String
"XMONAD_RESTART" Bool
False
    (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
e -> do
        XEventPtr -> ScreenNumber -> IO ()
setEventType XEventPtr
e ScreenNumber
clientMessage
        XEventPtr -> Window -> Window -> CInt -> [CInt] -> IO ()
setClientMessageEvent' XEventPtr
e Window
rw Window
xmonad_restart CInt
32 []
        Display -> Window -> Bool -> Window -> XEventPtr -> IO ()
sendEvent Display
dpy Window
rw Bool
False Window
structureNotifyMask XEventPtr
e
    Display -> Bool -> IO ()
sync Display
dpy Bool
False

-- | a wrapper for 'replace'
sendReplace :: IO ()
sendReplace :: IO ()
sendReplace = do
    Display
dpy <- String -> IO Display
openDisplay String
""
    let dflt :: ScreenNumber
dflt = Display -> ScreenNumber
defaultScreen Display
dpy
    Window
rootw  <- Display -> ScreenNumber -> IO Window
rootWindow Display
dpy ScreenNumber
dflt
    Display -> ScreenNumber -> Window -> IO ()
replace Display
dpy ScreenNumber
dflt Window
rootw

-- | 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 Window, Read (l Window)) =>
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 Window
layoutHook = l Window -> Layout Window
forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
Layout (l Window -> Layout Window) -> l Window -> Layout Window
forall a b. (a -> b) -> a -> b
$ XConfig l -> l Window
forall (l :: * -> *). XConfig l -> l Window
layoutHook XConfig l
initxmc }
    Display
dpy   <- String -> IO Display
openDisplay String
""
    let dflt :: ScreenNumber
dflt = Display -> ScreenNumber
defaultScreen Display
dpy

    Window
rootw  <- Display -> ScreenNumber -> IO Window
rootWindow Display
dpy ScreenNumber
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 -> Window -> Window -> IO ()
selectInput Display
dpy Window
rootw (Window -> IO ()) -> Window -> IO ()
forall a b. (a -> b) -> a -> b
$ XConfig l -> Window
forall (l :: * -> *). XConfig l -> Window
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 <- Display -> IO [Rectangle]
forall (m :: * -> *). MonadIO m => Display -> m [Rectangle]
getCleanedScreenInfo Display
dpy

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

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

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

    let layout :: Layout Window
layout = XConfig Layout -> Layout Window
forall (l :: * -> *). XConfig l -> l Window
layoutHook XConfig Layout
xmc
        initialWinset :: StackSet String (Layout Window) a ScreenId ScreenDetail
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 (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 Window
-> [String]
-> [ScreenDetail]
-> StackSet String (Layout Window) a ScreenId ScreenDetail
forall s l i sd a.
Integral s =>
l -> [i] -> [sd] -> StackSet i l a s sd
new Layout Window
layout (Int -> [String] -> [String]
padToLen ([Rectangle] -> 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 Window) a ScreenId ScreenDetail)
-> [ScreenDetail]
-> StackSet String (Layout Window) 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
cf = XConf :: Display
-> XConfig Layout
-> Window
-> Window
-> Window
-> Map (ButtonMask, Window) (X ())
-> Map (ButtonMask, ScreenNumber) (Window -> X ())
-> Bool
-> Maybe (Position, Position)
-> Maybe Event
-> Directories
-> XConf
XConf
            { display :: Display
display       = Display
dpy
            , config :: XConfig Layout
config        = XConfig Layout
xmc
            , theRoot :: Window
theRoot       = Window
rootw
            , normalBorder :: Window
normalBorder  = Window
nbc
            , focusedBorder :: Window
focusedBorder = Window
fbc
            , keyActions :: Map (ButtonMask, Window) (X ())
keyActions    = XConfig Layout -> XConfig Layout -> Map (ButtonMask, Window) (X ())
forall (l :: * -> *).
XConfig l -> XConfig Layout -> Map (ButtonMask, Window) (X ())
keys XConfig Layout
xmc XConfig Layout
xmc
            , buttonActions :: Map (ButtonMask, ScreenNumber) (Window -> X ())
buttonActions = XConfig Layout
-> XConfig Layout
-> Map (ButtonMask, ScreenNumber) (Window -> X ())
forall (l :: * -> *).
XConfig l
-> XConfig Layout
-> Map (ButtonMask, ScreenNumber) (Window -> 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
st = XState :: WindowSet
-> Set Window
-> Map Window Int
-> Maybe (Position -> Position -> X (), X ())
-> ButtonMask
-> Map String (Either String StateExtension)
-> XState
XState
            { windowset :: WindowSet
windowset       = WindowSet
forall {a}. StackSet String (Layout Window) a ScreenId ScreenDetail
initialWinset
            , numberlockMask :: ButtonMask
numberlockMask  = ButtonMask
0
            , mapped :: Set Window
mapped          = Set Window
forall a. Set a
S.empty
            , waitingUnmap :: Map Window Int
waitingUnmap    = Map Window 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
            }

    (XEventPtr -> IO (Any, XState)) -> IO (Any, XState)
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO (Any, XState)) -> IO (Any, XState))
-> (XEventPtr -> IO (Any, XState)) -> IO (Any, XState)
forall a b. (a -> b) -> a -> b
$ \XEventPtr
e ->
        XConf -> XState -> X Any -> IO (Any, XState)
forall a. XConf -> XState -> X a -> IO (a, XState)
runX XConf
cf XState
st (X Any -> IO (Any, XState)) -> X Any -> IO (Any, XState)
forall a b. (a -> b) -> a -> b
$ do
            -- check for serialized state in a file.
            Maybe XState
serializedSt <- do
                String
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
                Bool
exists <- IO Bool -> X Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> IO Bool
doesFileExist String
path)
                if Bool
exists then XConfig l -> X (Maybe XState)
forall (l :: * -> *).
(LayoutClass l Window, Read (l Window)) =>
XConfig l -> X (Maybe XState)
readStateFile XConfig l
initxmc else Maybe XState -> X (Maybe XState)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe XState
forall a. Maybe a
Nothing

            -- restore extensibleState if we read it from a file.
            let extst :: Map String (Either String StateExtension)
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
            (XState -> XState) -> X ()
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

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

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

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

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

            Maybe (CInt, CInt)
rrData <- IO (Maybe (CInt, CInt)) -> X (Maybe (CInt, CInt))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe (CInt, CInt)) -> X (Maybe (CInt, CInt)))
-> IO (Maybe (CInt, CInt)) -> X (Maybe (CInt, CInt))
forall a b. (a -> b) -> a -> b
$ Display -> IO (Maybe (CInt, CInt))
xrrQueryExtension Display
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)
            Display -> XEventPtr -> Maybe (CInt, CInt) -> X Any
forall {a} {b}. Display -> XEventPtr -> Maybe a -> X b
mainLoop Display
dpy XEventPtr
e Maybe (CInt, CInt)
rrData

    () -> IO ()
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 Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Event -> ScreenNumber
ev_event_type Event
e ScreenNumber -> [ScreenNumber] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ScreenNumber]
evs)
                                     (Position, Position) -> Maybe (Position, Position)
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 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 = Event -> Maybe Event
forall a. a -> Maybe a
Just Event
e }) (Event -> X ()
handleWithHook Event
e)
        evs :: [ScreenNumber]
evs = [ ScreenNumber
keyPress, ScreenNumber
keyRelease, ScreenNumber
enterNotify, ScreenNumber
leaveNotify
              , ScreenNumber
buttonPress, ScreenNumber
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XEventPtr -> IO Event
getEvent XEventPtr
e) X Event -> (Event -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Event -> X ()
prehandle X () -> 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
  Event -> X All
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)
  X Bool -> X () -> X ()
whenX (Bool -> X Bool -> X Bool
forall a. a -> X a -> X a
userCodeDef Bool
True (X Bool -> X Bool) -> X Bool -> X Bool
forall a b. (a -> b) -> a -> b
$ All -> Bool
getAll (All -> Bool) -> X All -> X Bool
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 -> ScreenNumber
ev_event_type = ScreenNumber
t, ev_state :: Event -> ButtonMask
ev_state = ButtonMask
m, ev_keycode :: Event -> KeyCode
ev_keycode = KeyCode
code})
    | ScreenNumber
t ScreenNumber -> ScreenNumber -> Bool
forall a. Eq a => a -> a -> Bool
== ScreenNumber
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
        Window
s  <- IO Window -> X Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Window -> X Window) -> IO Window -> X Window
forall a b. (a -> b) -> a -> b
$ Display -> KeyCode -> CInt -> IO Window
keycodeToKeysym Display
dpy KeyCode
code CInt
0
        ButtonMask
mClean <- ButtonMask -> X ButtonMask
cleanMask ButtonMask
m
        Map (ButtonMask, Window) (X ())
ks <- (XConf -> Map (ButtonMask, Window) (X ()))
-> X (Map (ButtonMask, Window) (X ()))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Map (ButtonMask, Window) (X ())
keyActions
        () -> X () -> X ()
forall a. a -> X a -> X a
userCodeDef () (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ Maybe (X ()) -> (X () -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust ((ButtonMask, Window)
-> Map (ButtonMask, Window) (X ()) -> Maybe (X ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ButtonMask
mClean, Window
s) Map (ButtonMask, Window) (X ())
ks) X () -> X ()
forall a. a -> a
id

-- manage a new window
handle (MapRequestEvent    {ev_window :: Event -> Window
ev_window = Window
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 -> Window -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes Display
dpy Window
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
      Bool
managed <- Window -> X Bool
isClient Window
w
      Bool -> X () -> X ()
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) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ Window -> X ()
manage Window
w

-- window destroyed, unmanage it
-- window gone,      unmanage it
-- broadcast to layouts
handle e :: Event
e@(DestroyWindowEvent {ev_window :: Event -> Window
ev_window = Window
w}) = do
  X Bool -> X () -> X ()
whenX (Window -> X Bool
isClient Window
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    Window -> X ()
unmanage Window
w
    (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { mapped :: Set Window
mapped       = Window -> Set Window -> Set Window
forall a. Ord a => a -> Set a -> Set a
S.delete Window
w (XState -> Set Window
mapped XState
s)
                    , waitingUnmap :: Map Window Int
waitingUnmap = Window -> Map Window Int -> Map Window Int
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Window
w (XState -> Map Window 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
  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 -> Window
ev_window = Window
w, ev_send_event :: Event -> Bool
ev_send_event = Bool
synthetic}) = X Bool -> X () -> X ()
whenX (Window -> X Bool
isClient Window
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    Int
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
. Window -> Map Window Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Window
w (Map Window Int -> Maybe Int)
-> (XState -> Map Window Int) -> XState -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> Map Window Int
waitingUnmap)
    if Bool
synthetic Bool -> Bool -> Bool
|| Int
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then Window -> X ()
unmanage Window
w
        else (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { waitingUnmap :: Map Window Int
waitingUnmap = (Int -> Maybe Int) -> Window -> Map Window Int -> Map Window Int
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update Int -> Maybe Int
forall {a}. (Eq a, Num a, Enum a) => a -> Maybe a
mpred Window
w (XState -> Map Window Int
waitingUnmap XState
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 (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 -> ScreenNumber
ev_event_type = ScreenNumber
t})
    | ScreenNumber
t ScreenNumber -> ScreenNumber -> Bool
forall a. Eq a => a -> a -> Bool
== ScreenNumber
buttonRelease = do
    Maybe (Position -> Position -> X (), X ())
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 Maybe (Position -> Position -> X (), X ())
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 :: Maybe (Position -> Position -> X (), X ())
dragging = Maybe (Position -> Position -> X (), X ())
forall a. Maybe a
Nothing }) X () -> X () -> X ()
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 -> ScreenNumber
ev_event_type = ScreenNumber
_t, ev_x :: Event -> CInt
ev_x = CInt
x, ev_y :: Event -> CInt
ev_y = CInt
y}) = do
    Maybe (Position -> Position -> X (), X ())
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 Maybe (Position -> Position -> X (), X ())
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 -> Window
ev_window = Window
w,ev_event_type :: Event -> ScreenNumber
ev_event_type = ScreenNumber
t,ev_button :: Event -> ScreenNumber
ev_button = ScreenNumber
b })
    | ScreenNumber
t ScreenNumber -> ScreenNumber -> Bool
forall a. Eq a => a -> a -> Bool
== ScreenNumber
buttonPress = do
    -- If it's the root window, then it's something we
    -- grabbed in grabButtons. Otherwise, it's click-to-focus.
    Display
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    Bool
isr <- Window -> X Bool
isRoot Window
w
    ButtonMask
m <- ButtonMask -> X ButtonMask
cleanMask (ButtonMask -> X ButtonMask) -> ButtonMask -> X ButtonMask
forall a b. (a -> b) -> a -> b
$ Event -> ButtonMask
ev_state Event
e
    Maybe (Window -> X ())
mact <- (XConf -> Maybe (Window -> X ())) -> X (Maybe (Window -> X ()))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((ButtonMask, ScreenNumber)
-> Map (ButtonMask, ScreenNumber) (Window -> X ())
-> Maybe (Window -> X ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ButtonMask
m, ScreenNumber
b) (Map (ButtonMask, ScreenNumber) (Window -> X ())
 -> Maybe (Window -> X ()))
-> (XConf -> Map (ButtonMask, ScreenNumber) (Window -> X ()))
-> XConf
-> Maybe (Window -> X ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Map (ButtonMask, ScreenNumber) (Window -> X ())
buttonActions)
    case Maybe (Window -> X ())
mact of
        Just Window -> X ()
act | Bool
isr -> Window -> X ()
act (Window -> X ()) -> Window -> X ()
forall a b. (a -> b) -> a -> b
$ Event -> Window
ev_subwindow Event
e
        Maybe (Window -> X ())
_              -> do
            Window -> X ()
focus Window
w
            Bool
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)
            Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ctf (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> CInt -> Window -> IO ()
allowEvents Display
dpy CInt
replayPointer Window
currentTime)
    Event -> X ()
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 -> Window
ev_window = Window
w, ev_event_type :: Event -> ScreenNumber
ev_event_type = ScreenNumber
t})
    | ScreenNumber
t ScreenNumber -> ScreenNumber -> Bool
forall a. Eq a => a -> a -> Bool
== ScreenNumber
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
        Display
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
        Window
root <- (XConf -> Window) -> X Window
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Window
theRoot
        (Bool
_, Window
_, Window
w', CInt
_, CInt
_, CInt
_, CInt
_, ButtonMask
_) <- IO (Bool, Window, Window, CInt, CInt, CInt, CInt, ButtonMask)
-> X (Bool, Window, Window, CInt, CInt, CInt, CInt, ButtonMask)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Bool, Window, Window, CInt, CInt, CInt, CInt, ButtonMask)
 -> X (Bool, Window, Window, CInt, CInt, CInt, CInt, ButtonMask))
-> IO (Bool, Window, Window, CInt, CInt, CInt, CInt, ButtonMask)
-> X (Bool, Window, Window, CInt, CInt, CInt, CInt, ButtonMask)
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> IO (Bool, Window, Window, CInt, CInt, CInt, CInt, ButtonMask)
queryPointer Display
dpy Window
root
        -- when Xlib cannot find a child that contains the pointer,
        -- it returns None(0)
        Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
w' Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
0 Bool -> Bool -> Bool
|| Window
w Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
w') (Window -> X ()
focus Window
w)

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

-- configure a window
handle e :: Event
e@(ConfigureRequestEvent {ev_window :: Event -> Window
ev_window = Window
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
    WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
    ScreenNumber
bw <- (XConf -> ScreenNumber) -> X ScreenNumber
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> ScreenNumber
forall (l :: * -> *). XConfig l -> ScreenNumber
borderWidth (XConfig Layout -> ScreenNumber)
-> (XConf -> XConfig Layout) -> XConf -> ScreenNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)

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

-- property notify
handle event :: Event
event@(PropertyEvent { ev_event_type :: Event -> ScreenNumber
ev_event_type = ScreenNumber
t, ev_atom :: Event -> Window
ev_atom = Window
a })
    | ScreenNumber
t ScreenNumber -> ScreenNumber -> Bool
forall a. Eq a => a -> a -> Bool
== ScreenNumber
propertyNotify Bool -> Bool -> Bool
&& Window
a Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
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 (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 (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 -> Window
ev_message_type = Window
mt } = do
    Window
a <- String -> X Window
getAtom String
"XMONAD_RESTART"
    if Window
mt Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
a
        then String -> Bool -> X ()
restart String
"xmonad" Bool
True
        else Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
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 -> Window -> IO [Window]
scan Display
dpy Window
rootw = do
    (Window
_, Window
_, [Window]
ws) <- Display -> Window -> IO (Window, Window, [Window])
queryTree Display
dpy Window
rootw
    (Window -> IO Bool) -> [Window] -> IO [Window]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\Window
w -> Window -> IO Bool
ok Window
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) [Window]
ws
  -- TODO: scan for windows that are either 'IsViewable' or where WM_STATE ==
  -- Iconic
  where ok :: Window -> IO Bool
ok Window
w = do WindowAttributes
wa <- Display -> Window -> IO WindowAttributes
getWindowAttributes Display
dpy Window
w
                  Window
a  <- Display -> String -> Bool -> IO Window
internAtom Display
dpy String
"WM_STATE" Bool
False
                  Maybe [CLong]
p  <- Display -> Window -> Window -> IO (Maybe [CLong])
getWindowProperty32 Display
dpy Window
a Window
w
                  let ic :: Bool
ic = case Maybe [CLong]
p of
                            Just (CLong
3:[CLong]
_) -> Bool
True -- 3 for iconified
                            Maybe [CLong]
_          -> Bool
False
                  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
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 CInt -> CInt -> Bool
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
_ = Bool -> IO Bool
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 -> Window
theRoot = Window
rootw } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    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 -> Window -> IO ()
ungrabKey Display
dpy KeyCode
anyKey ButtonMask
anyModifier Window
rootw
    let grab :: (KeyMask, KeyCode) -> X ()
        grab :: (ButtonMask, 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 -> Window -> Bool -> CInt -> CInt -> IO ()
grabKey Display
dpy KeyCode
kc ButtonMask
km Window
rootw Bool
True CInt
grabModeAsync CInt
grabModeAsync
    ((ButtonMask, KeyCode) -> X ()) -> [(ButtonMask, KeyCode)] -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ButtonMask, KeyCode) -> X ()
grab ([(ButtonMask, KeyCode)] -> X ())
-> X [(ButtonMask, KeyCode)] -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(ButtonMask, Window)] -> X [(ButtonMask, KeyCode)]
mkGrabs ([(ButtonMask, Window)] -> X [(ButtonMask, KeyCode)])
-> X [(ButtonMask, Window)] -> X [(ButtonMask, KeyCode)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XConf -> [(ButtonMask, Window)]) -> X [(ButtonMask, Window)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Map (ButtonMask, Window) (X ()) -> [(ButtonMask, Window)]
forall k a. Map k a -> [k]
M.keys (Map (ButtonMask, Window) (X ()) -> [(ButtonMask, Window)])
-> (XConf -> Map (ButtonMask, Window) (X ()))
-> XConf
-> [(ButtonMask, Window)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Map (ButtonMask, Window) (X ())
keyActions)

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

-- | @replace@ to signals compliant window managers to exit.
replace :: Display -> ScreenNumber -> Window -> IO ()
replace :: Display -> ScreenNumber -> Window -> IO ()
replace Display
dpy ScreenNumber
dflt Window
rootw = do
    -- check for other WM
    Window
wmSnAtom <- Display -> String -> Bool -> IO Window
internAtom Display
dpy (String
"WM_S" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ScreenNumber -> String
forall a. Show a => a -> String
show ScreenNumber
dflt) Bool
False
    Window
currentWmSnOwner <- Display -> Window -> IO Window
xGetSelectionOwner Display
dpy Window
wmSnAtom
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
currentWmSnOwner Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
/= Window
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- prepare to receive destroyNotify for old WM
        Display -> Window -> Window -> IO ()
selectInput Display
dpy Window
currentWmSnOwner Window
structureNotifyMask

        -- create off-screen window
        Window
netWmSnOwner <- (Ptr SetWindowAttributes -> IO Window) -> IO Window
forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO Window) -> IO Window)
-> (Ptr SetWindowAttributes -> IO Window) -> IO Window
forall a b. (a -> b) -> a -> b
$ \Ptr SetWindowAttributes
attributes -> do
            Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
attributes Bool
True
            Ptr SetWindowAttributes -> Window -> IO ()
set_event_mask Ptr SetWindowAttributes
attributes Window
propertyChangeMask
            let screen :: Screen
screen = Display -> Screen
defaultScreenOfDisplay Display
dpy
                visual :: Visual
visual = Screen -> Visual
defaultVisualOfScreen Screen
screen
                attrmask :: Window
attrmask = Window
cWOverrideRedirect Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
cWEventMask
            Display
-> Window
-> Position
-> Position
-> ScreenNumber
-> ScreenNumber
-> CInt
-> CInt
-> CInt
-> Visual
-> Window
-> Ptr SetWindowAttributes
-> IO Window
createWindow Display
dpy Window
rootw (-Position
100) (-Position
100) ScreenNumber
1 ScreenNumber
1 CInt
0 CInt
copyFromParent CInt
copyFromParent Visual
visual Window
attrmask Ptr SetWindowAttributes
attributes

        -- try to acquire wmSnAtom, this should signal the old WM to terminate
        Display -> Window -> Window -> Window -> IO ()
xSetSelectionOwner Display
dpy Window
wmSnAtom Window
netWmSnOwner Window
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
        (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
again -> do
            ScreenNumber
evt <- (XEventPtr -> IO ScreenNumber) -> IO ScreenNumber
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO ScreenNumber) -> IO ScreenNumber)
-> (XEventPtr -> IO ScreenNumber) -> IO ScreenNumber
forall a b. (a -> b) -> a -> b
$ \XEventPtr
event -> do
                Display -> Window -> Window -> XEventPtr -> IO ()
windowEvent Display
dpy Window
currentWmSnOwner Window
structureNotifyMask XEventPtr
event
                XEventPtr -> IO ScreenNumber
get_EventType XEventPtr
event

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ScreenNumber
evt ScreenNumber -> ScreenNumber -> Bool
forall a. Eq a => a -> a -> Bool
/= ScreenNumber
destroyNotify) IO ()
again