{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module XMonad.Main (xmonad, buildLaunch, launch) where
import System.Locale.SetLocale
import qualified Control.Exception as E
import Data.Bits
import Data.List ((\\))
import Data.Foldable (traverse_)
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad (filterM, guard, unless, void, when)
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid (getAll)
import Graphics.X11.Xlib hiding (refreshKeyboardMapping)
import Graphics.X11.Xlib.Extras
import XMonad.Core
import qualified XMonad.Config as Default
import XMonad.StackSet (new, floating, member)
import qualified XMonad.StackSet as W
import XMonad.Operations
import System.IO
import System.Directory
import System.Info
import System.Environment (getArgs, getProgName, withArgs)
import System.Posix.Process (executeFile)
import System.Exit (exitFailure)
import System.FilePath
import Paths_xmonad (version)
import Data.Version (showVersion)
import Graphics.X11.Xinerama (compiledWithXinerama)
import Graphics.X11.Xrandr (xrrQueryExtension, xrrUpdateConfiguration)
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
IO ()
forall (m :: * -> *). MonadIO m => m ()
installSignalHandlers
dirs <- IO Directories
getDirectories
let launch' [String]
args = do
IO () -> IO ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
catchIO (Directories -> IO ()
buildLaunch Directories
dirs)
conf'@XConfig { layoutHook = Layout l }
<- XConfig l -> [String] -> XConfig Layout -> IO (XConfig Layout)
forall (l :: * -> *).
XConfig l -> [String] -> XConfig Layout -> IO (XConfig Layout)
handleExtraArgs XConfig l
conf [String]
args XConfig l
conf{ layoutHook = Layout (layoutHook conf) }
withArgs [] $ launch (conf' { layoutHook = l }) dirs
args <- getArgs
case args of
[String
"--help"] -> IO ()
usage
[String
"--recompile"] -> Directories -> Bool -> IO Bool
forall (m :: * -> *). MonadIO m => Directories -> Bool -> m Bool
recompile Directories
dirs Bool
True IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless IO ()
forall a. IO a
exitFailure
[String
"--restart"] -> IO ()
sendRestart
[String
"--version"] -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
shortVersion
[String
"--verbose-version"] -> String -> IO ()
putStrLn (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
shortVersion [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
longVersion
String
"--replace" : [String]
args' -> IO ()
sendReplace IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> IO ()
launch' [String]
args'
[String]
_ -> [String] -> IO ()
launch' [String]
args
where
shortVersion :: [String]
shortVersion = [String
"xmonad", Version -> String
showVersion Version
version]
longVersion :: [String]
longVersion = [ String
"compiled by", String
compilerName, Version -> String
showVersion Version
compilerVersion
, String
"for", String
arch String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
os
, String
"\nXinerama:", Bool -> String
forall a. Show a => a -> String
show Bool
compiledWithXinerama ]
usage :: IO ()
usage :: IO ()
usage = do
self <- IO String
getProgName
putStr . unlines $
[ "Usage: " <> self <> " [OPTION]"
, "Options:"
, " --help Print this message"
, " --version Print the version number"
, " --recompile Recompile your xmonad.hs"
, " --replace Replace the running window manager with xmonad"
, " --restart Request a running xmonad process to restart"
]
buildLaunch :: Directories -> IO ()
buildLaunch :: Directories -> IO ()
buildLaunch Directories
dirs = do
whoami <- IO String
getProgName
let bin = Directories -> String
binFileName Directories
dirs
let compiledConfig = String -> String
takeFileName String
bin
unless (whoami == compiledConfig) $ do
trace $ concat
[ "XMonad is recompiling and replacing itself with another XMonad process because the current process is called "
, show whoami
, " but the compiled configuration should be called "
, show compiledConfig
]
recompile dirs False
args <- getArgs
executeFile bin False args Nothing
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
Category -> Maybe String -> IO (Maybe String)
setLocale Category
LC_ALL (String -> Maybe String
forall a. a -> Maybe a
Just String
"")
IO ()
forall (m :: * -> *). MonadIO m => m ()
installSignalHandlers
let xmc :: XConfig Layout
xmc = XConfig l
initxmc { layoutHook = Layout $ layoutHook initxmc }
dpy <- String -> IO Display
openDisplay String
""
let dflt = Display -> EventType
defaultScreen Display
dpy
rootw <- rootWindow dpy dflt
selectInput dpy rootw $ rootMask initxmc
sync dpy False
xSetErrorHandler
xinesc <- getCleanedScreenInfo dpy
nbc <- do v <- initColor dpy $ normalBorderColor xmc
Just nbc_ <- initColor dpy $ normalBorderColor Default.def
return (fromMaybe nbc_ v)
fbc <- do v <- initColor dpy $ focusedBorderColor xmc
Just fbc_ <- initColor dpy $ focusedBorderColor Default.def
return (fromMaybe fbc_ v)
hSetBuffering stdout NoBuffering
let layout = XConfig Layout -> Layout KeySym
forall (l :: * -> *). XConfig l -> l KeySym
layoutHook XConfig Layout
xmc
initialWinset = let padToLen :: Int -> [String] -> [String]
padToLen Int
n [String]
xs = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs)) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
forall a. a -> [a]
repeat String
""
in Layout KeySym
-> [String]
-> [ScreenDetail]
-> StackSet String (Layout KeySym) a ScreenId ScreenDetail
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 ([Rectangle] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rectangle]
xinesc) (XConfig Layout -> [String]
forall (l :: * -> *). XConfig l -> [String]
workspaces XConfig Layout
xmc)) ([ScreenDetail]
-> StackSet String (Layout KeySym) a ScreenId ScreenDetail)
-> [ScreenDetail]
-> StackSet String (Layout KeySym) a ScreenId ScreenDetail
forall a b. (a -> b) -> a -> b
$ (Rectangle -> ScreenDetail) -> [Rectangle] -> [ScreenDetail]
forall a b. (a -> b) -> [a] -> [b]
map Rectangle -> ScreenDetail
SD [Rectangle]
xinesc
cf = XConf
{ display :: Display
display = Display
dpy
, config :: XConfig Layout
config = XConfig Layout
xmc
, theRoot :: KeySym
theRoot = KeySym
rootw
, normalBorder :: KeySym
normalBorder = KeySym
nbc
, focusedBorder :: KeySym
focusedBorder = KeySym
fbc
, keyActions :: Map (ButtonMask, KeySym) (X ())
keyActions = XConfig Layout -> XConfig Layout -> Map (ButtonMask, KeySym) (X ())
forall (l :: * -> *).
XConfig l -> XConfig Layout -> Map (ButtonMask, KeySym) (X ())
keys XConfig Layout
xmc XConfig Layout
xmc
, buttonActions :: Map (ButtonMask, EventType) (KeySym -> X ())
buttonActions = XConfig Layout
-> XConfig Layout -> Map (ButtonMask, EventType) (KeySym -> X ())
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 = Maybe (Position, Position)
forall a. Maybe a
Nothing
, currentEvent :: Maybe Event
currentEvent = Maybe Event
forall a. Maybe a
Nothing
, directories :: Directories
directories = Directories
drs
}
st = XState
{ windowset :: WindowSet
windowset = WindowSet
forall {a}. StackSet String (Layout KeySym) a ScreenId ScreenDetail
initialWinset
, numberlockMask :: ButtonMask
numberlockMask = ButtonMask
0
, mapped :: Set KeySym
mapped = Set KeySym
forall a. Set a
S.empty
, waitingUnmap :: Map KeySym Int
waitingUnmap = Map KeySym Int
forall k a. Map k a
M.empty
, dragging :: Maybe (Position -> Position -> X (), X ())
dragging = Maybe (Position -> Position -> X (), X ())
forall a. Maybe a
Nothing
, extensibleState :: Map String (Either String StateExtension)
extensibleState = Map String (Either String StateExtension)
forall k a. Map k a
M.empty
}
allocaXEvent $ \XEventPtr
e ->
XConf -> XState -> X 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
serializedSt <- do
path <- (XConf -> String) -> X String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> String) -> X String) -> (XConf -> String) -> X String
forall a b. (a -> b) -> a -> b
$ Directories -> String
stateFileName (Directories -> String)
-> (XConf -> Directories) -> XConf -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Directories
directories
exists <- io (doesFileExist path)
if exists then readStateFile initxmc else return Nothing
let extst = Map String (Either String StateExtension)
-> (XState -> Map String (Either String StateExtension))
-> Maybe XState
-> Map String (Either String StateExtension)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map String (Either String StateExtension)
forall k a. Map k a
M.empty XState -> Map String (Either String StateExtension)
extensibleState Maybe XState
serializedSt
modify (\XState
s -> XState
s {extensibleState = extst})
cacheNumlockMask
grabKeys
grabButtons
io $ sync dpy False
ws <- io $ scan dpy rootw
let winset = WindowSet -> (XState -> WindowSet) -> Maybe XState -> WindowSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WindowSet
forall {a}. StackSet String (Layout KeySym) a ScreenId ScreenDetail
initialWinset XState -> WindowSet
windowset Maybe XState
serializedSt
windows . const . foldr W.delete winset $ W.allWindows winset \\ ws
mapM_ manage (ws \\ W.allWindows winset)
userCode $ startupHook initxmc
rrData <- io $ xrrQueryExtension dpy
mainLoop dpy e rrData
return ()
where
prehandle :: Event -> X ()
prehandle Event
e = let mouse :: Maybe (Position, Position)
mouse = do Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Event -> EventType
ev_event_type Event
e EventType -> [EventType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EventType]
evs)
(Position, Position) -> Maybe (Position, Position)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Event -> CInt
ev_x_root Event
e)
,CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Event -> CInt
ev_y_root Event
e))
in (XConf -> XConf) -> X () -> X ()
forall a. (XConf -> XConf) -> X a -> X a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\XConf
c -> XConf
c { mousePosition = mouse, currentEvent = Just e }) (Event -> X ()
handleWithHook Event
e)
evs :: [EventType]
evs = [ EventType
keyPress, EventType
keyRelease, EventType
enterNotify, EventType
leaveNotify
, EventType
buttonPress, EventType
buttonRelease]
rrUpdate :: XEventPtr -> Maybe a -> IO ()
rrUpdate XEventPtr
e Maybe a
r = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
r) (IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (XEventPtr -> IO CInt
xrrUpdateConfiguration XEventPtr
e))
mainLoop :: Display -> XEventPtr -> Maybe a -> X b
mainLoop Display
d XEventPtr
e Maybe a
r = IO Event -> X Event
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> XEventPtr -> IO ()
nextEvent Display
d XEventPtr
e IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XEventPtr -> Maybe a -> IO ()
forall {a}. XEventPtr -> Maybe a -> IO ()
rrUpdate XEventPtr
e Maybe a
r IO () -> IO Event -> IO Event
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XEventPtr -> IO Event
getEvent XEventPtr
e) X Event -> (Event -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Event -> X ()
prehandle X () -> X b -> X b
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Display -> XEventPtr -> Maybe a -> X b
mainLoop Display
d XEventPtr
e Maybe a
r
handleWithHook :: Event -> X ()
handleWithHook :: Event -> X ()
handleWithHook Event
e = do
evHook <- (XConf -> Event -> X All) -> X (Event -> X All)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> Event -> X All
forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook (XConfig Layout -> Event -> X All)
-> (XConf -> XConfig Layout) -> XConf -> Event -> X All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
whenX (userCodeDef True $ getAll `fmap` evHook e) (handle e)
handle :: Event -> X ()
handle :: Event -> X ()
handle (KeyEvent {ev_event_type :: Event -> EventType
ev_event_type = EventType
t, ev_state :: Event -> ButtonMask
ev_state = ButtonMask
m, ev_keycode :: Event -> KeyCode
ev_keycode = KeyCode
code})
| EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
keyPress = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
s <- IO KeySym -> X KeySym
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO KeySym -> X KeySym) -> IO KeySym -> X KeySym
forall a b. (a -> b) -> a -> b
$ Display -> KeyCode -> CInt -> IO KeySym
keycodeToKeysym Display
dpy KeyCode
code CInt
0
mClean <- cleanMask m
ks <- asks keyActions
userCodeDef () $ whenJust (M.lookup (mClean, s) ks) id
handle (MapRequestEvent {ev_window :: Event -> KeySym
ev_window = KeySym
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 -> KeySym -> (WindowAttributes -> X ()) -> X ()
withWindowAttributes Display
dpy KeySym
w ((WindowAttributes -> X ()) -> X ())
-> (WindowAttributes -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowAttributes
wa -> do
managed <- KeySym -> X Bool
isClient KeySym
w
when (not (wa_override_redirect wa) && not managed) $ manage w
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) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
KeySym -> X ()
unmanage KeySym
w
(XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { mapped = S.delete w (mapped s)
, waitingUnmap = M.delete w (waitingUnmap s)})
Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
e
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) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
e <- (XState -> Int) -> X Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (XState -> Maybe Int) -> XState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeySym -> Map KeySym Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup KeySym
w (Map KeySym Int -> Maybe Int)
-> (XState -> Map KeySym Int) -> XState -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> Map KeySym Int
waitingUnmap)
if synthetic || e == 0
then unmanage w
else modify (\XState
s -> XState
s { waitingUnmap = M.update mpred w (waitingUnmap s) })
where mpred :: a -> Maybe a
mpred a
1 = Maybe a
forall a. Maybe a
Nothing
mpred a
n = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Enum a => a -> a
pred a
n
handle e :: Event
e@(MappingNotifyEvent {}) = do
IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Event -> IO ()
refreshKeyboardMapping Event
e
Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> CInt
ev_request Event
e CInt -> [CInt] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt
mappingKeyboard, CInt
mappingModifier]) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
X ()
cacheNumlockMask
X ()
grabKeys
handle e :: Event
e@(ButtonEvent {ev_event_type :: Event -> EventType
ev_event_type = EventType
t})
| EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
buttonRelease = do
drag <- (XState -> Maybe (Position -> Position -> X (), X ()))
-> X (Maybe (Position -> Position -> X (), X ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> Maybe (Position -> Position -> X (), X ())
dragging
case drag of
Just (Position -> Position -> X ()
_,X ()
f) -> (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\XState
s -> XState
s { dragging = Nothing }) X () -> X () -> X ()
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
f
Maybe (Position -> Position -> X (), X ())
Nothing -> Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
e
handle e :: Event
e@(MotionEvent {ev_event_type :: Event -> EventType
ev_event_type = EventType
_t, ev_x :: Event -> CInt
ev_x = CInt
x, ev_y :: Event -> CInt
ev_y = CInt
y}) = do
drag <- (XState -> Maybe (Position -> Position -> X (), X ()))
-> X (Maybe (Position -> Position -> X (), X ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> Maybe (Position -> Position -> X (), X ())
dragging
case drag of
Just (Position -> Position -> X ()
d,X ()
_) -> Position -> Position -> X ()
d (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
y)
Maybe (Position -> Position -> X (), X ())
Nothing -> Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
e
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 EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
buttonPress = do
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
isr <- isRoot w
m <- cleanMask $ ev_state e
mact <- asks (M.lookup (m, b) . buttonActions)
case mact of
Just KeySym -> X ()
act | Bool
isr -> KeySym -> X ()
act (KeySym -> X ()) -> KeySym -> X ()
forall a b. (a -> b) -> a -> b
$ Event -> KeySym
ev_subwindow Event
e
Maybe (KeySym -> X ())
_ -> do
KeySym -> X ()
focus KeySym
w
ctf <- (XConf -> Bool) -> X Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> Bool
forall (l :: * -> *). XConfig l -> Bool
clickJustFocuses (XConfig Layout -> Bool)
-> (XConf -> XConfig Layout) -> XConf -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
unless ctf $ io (allowEvents dpy replayPointer currentTime)
broadcastMessage e
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 EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
enterNotify Bool -> Bool -> Bool
&& Event -> CInt
ev_mode Event
e CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
notifyNormal
= X Bool -> X () -> X ()
whenX ((XConf -> Bool) -> X Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> Bool) -> X Bool) -> (XConf -> Bool) -> X Bool
forall a b. (a -> b) -> a -> b
$ XConfig Layout -> Bool
forall (l :: * -> *). XConfig l -> Bool
focusFollowsMouse (XConfig Layout -> Bool)
-> (XConf -> XConfig Layout) -> XConf -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
root <- asks theRoot
(_, _, w', _, _, _, _, _) <- io $ queryPointer dpy root
when (w' == 0 || w == w') (focus w)
handle e :: Event
e@(CrossingEvent {ev_event_type :: Event -> EventType
ev_event_type = EventType
t})
| EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
leaveNotify
= do rootw <- (XConf -> KeySym) -> X KeySym
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> KeySym
theRoot
when (ev_window e == rootw && not (ev_same_screen e)) $ setFocusX rootw
handle e :: Event
e@(ConfigureRequestEvent {ev_window :: Event -> KeySym
ev_window = KeySym
w}) = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
bw <- asks (borderWidth . config)
if M.member w (floating ws)
|| not (member w ws)
then do io $ configureWindow dpy w (ev_value_mask e) $ WindowChanges
{ wc_x = ev_x e
, wc_y = ev_y e
, wc_width = ev_width e
, wc_height = ev_height e
, wc_border_width = fromIntegral bw
, wc_sibling = ev_above e
, wc_stack_mode = ev_detail e }
when (member w ws) (float w)
else withWindowAttributes dpy w $ \WindowAttributes
wa -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO ()) -> IO ()
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XEventPtr
ev -> do
XEventPtr -> EventType -> IO ()
setEventType XEventPtr
ev EventType
configureNotify
XEventPtr
-> 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
io $ sync dpy False
handle (ConfigureEvent {ev_window :: Event -> KeySym
ev_window = KeySym
w}) = X Bool -> X () -> X ()
whenX (KeySym -> X Bool
isRoot KeySym
w) X ()
rescreen
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 EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
propertyNotify Bool -> Bool -> Bool
&& KeySym
a KeySym -> KeySym -> Bool
forall a. Eq a => a -> a -> Bool
== KeySym
wM_NAME = (XConf -> X ()) -> X (X ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook (XConfig Layout -> X ())
-> (XConf -> XConfig Layout) -> XConf -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config) X (X ()) -> (X () -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= () -> X () -> X ()
forall a. a -> X a -> X a
userCodeDef () X () -> X () -> X ()
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
event
handle e :: Event
e@ClientMessageEvent { ev_message_type :: Event -> KeySym
ev_message_type = KeySym
mt } = do
a <- String -> X KeySym
getAtom String
"XMONAD_RESTART"
if mt == a
then restart "xmonad" True
else broadcastMessage e
handle Event
e = Event -> X ()
forall a. Message a => a -> X ()
broadcastMessage Event
e
scan :: Display -> Window -> IO [Window]
scan :: Display -> KeySym -> IO [KeySym]
scan Display
dpy KeySym
rootw = do
(_, _, ws) <- Display -> KeySym -> IO (KeySym, KeySym, [KeySym])
queryTree Display
dpy KeySym
rootw
filterM (\KeySym
w -> KeySym -> IO Bool
ok KeySym
w IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO Bool
skip) ws
where ok :: KeySym -> IO Bool
ok KeySym
w = do wa <- Display -> KeySym -> IO WindowAttributes
getWindowAttributes Display
dpy KeySym
w
a <- internAtom dpy "WM_STATE" False
p <- getWindowProperty32 dpy a w
let ic = case Maybe [CLong]
p of
Just (CLong
3:[CLong]
_) -> Bool
True
Maybe [CLong]
_ -> Bool
False
return $ not (wa_override_redirect wa)
&& (wa_map_state wa == waIsViewable || ic)
skip :: E.SomeException -> IO Bool
skip :: SomeException -> IO Bool
skip SomeException
_ = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
grabKeys :: X ()
grabKeys :: X ()
grabKeys = do
XConf { display = dpy, theRoot = rootw } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
io $ ungrabKey dpy anyKey anyModifier rootw
let grab :: (KeyMask, KeyCode) -> X ()
grab (ButtonMask
km, KeyCode
kc) = IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display
-> KeyCode -> ButtonMask -> KeySym -> Bool -> CInt -> CInt -> IO ()
grabKey Display
dpy KeyCode
kc ButtonMask
km KeySym
rootw Bool
True CInt
grabModeAsync CInt
grabModeAsync
traverse_ grab =<< mkGrabs =<< asks (M.keys . keyActions)
grabButtons :: X ()
grabButtons :: X ()
grabButtons = do
XConf { display = dpy, theRoot = rootw } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
let grab EventType
button ButtonMask
mask = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display
-> EventType
-> ButtonMask
-> 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
io $ ungrabButton dpy anyButton anyModifier rootw
ems <- extraModifiers
ba <- asks buttonActions
mapM_ (\(ButtonMask
m,EventType
b) -> (ButtonMask -> X ()) -> [ButtonMask] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (EventType -> ButtonMask -> X ()
forall {m :: * -> *}. MonadIO m => EventType -> ButtonMask -> m ()
grab EventType
b (ButtonMask -> X ())
-> (ButtonMask -> ButtonMask) -> ButtonMask -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ButtonMask
m ButtonMask -> ButtonMask -> ButtonMask
forall a. Bits a => a -> a -> a
.|.)) [ButtonMask]
ems) (M.keys ba)