module XMonad.Hooks.SetWMName (
setWMName
, getWMName
)
where
import Foreign.C.Types (CChar)
import Foreign.Marshal.Alloc (alloca)
import XMonad
import XMonad.Prelude (fromJust, join, listToMaybe, maybeToList, nub, ord)
setWMName :: String -> X ()
setWMName :: String -> X ()
setWMName String
name = do
AttributeMask
atom_NET_SUPPORTING_WM_CHECK <- X AttributeMask
netSupportingWMCheckAtom
AttributeMask
atom_NET_WM_NAME <- String -> X AttributeMask
getAtom String
"_NET_WM_NAME"
AttributeMask
atom_NET_SUPPORTED_ATOM <- String -> X AttributeMask
getAtom String
"_NET_SUPPORTED"
AttributeMask
atom_UTF8_STRING <- String -> X AttributeMask
getAtom String
"UTF8_STRING"
AttributeMask
root <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> AttributeMask
theRoot
AttributeMask
supportWindow <- X AttributeMask
getSupportWindow
Display
dpy <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\AttributeMask
w -> Display
-> AttributeMask
-> AttributeMask
-> AttributeMask
-> CInt
-> [CLong]
-> IO ()
changeProperty32 Display
dpy AttributeMask
w AttributeMask
atom_NET_SUPPORTING_WM_CHECK AttributeMask
wINDOW CInt
propModeReplace [forall a b. (Integral a, Num b) => a -> b
fromIntegral AttributeMask
supportWindow]) [AttributeMask
root, AttributeMask
supportWindow]
Display
-> AttributeMask
-> AttributeMask
-> AttributeMask
-> CInt
-> [CChar]
-> IO ()
changeProperty8 Display
dpy AttributeMask
supportWindow AttributeMask
atom_NET_WM_NAME AttributeMask
atom_UTF8_STRING CInt
propModeReplace (String -> [CChar]
latin1StringToCCharList String
name)
[CLong]
supportedList <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> [a]
maybeToList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> AttributeMask -> AttributeMask -> IO (Maybe [CLong])
getWindowProperty32 Display
dpy AttributeMask
atom_NET_SUPPORTED_ATOM AttributeMask
root
Display
-> AttributeMask
-> AttributeMask
-> AttributeMask
-> CInt
-> [CLong]
-> IO ()
changeProperty32 Display
dpy AttributeMask
root AttributeMask
atom_NET_SUPPORTED_ATOM AttributeMask
aTOM CInt
propModeReplace (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral AttributeMask
atom_NET_SUPPORTING_WM_CHECK forall a. a -> [a] -> [a]
: forall a b. (Integral a, Num b) => a -> b
fromIntegral AttributeMask
atom_NET_WM_NAME forall a. a -> [a] -> [a]
: [CLong]
supportedList)
where
latin1StringToCCharList :: String -> [CChar]
latin1StringToCCharList :: String -> [CChar]
latin1StringToCCharList = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord)
netSupportingWMCheckAtom :: X Atom
netSupportingWMCheckAtom :: X AttributeMask
netSupportingWMCheckAtom = String -> X AttributeMask
getAtom String
"_NET_SUPPORTING_WM_CHECK"
getSupportWindow :: X Window
getSupportWindow :: X AttributeMask
getSupportWindow = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
AttributeMask
atom_NET_SUPPORTING_WM_CHECK <- X AttributeMask
netSupportingWMCheckAtom
AttributeMask
root <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> AttributeMask
theRoot
Maybe CLong
supportWindow <- (forall a. [a] -> Maybe a
listToMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> AttributeMask -> AttributeMask -> IO (Maybe [CLong])
getWindowProperty32 Display
dpy AttributeMask
atom_NET_SUPPORTING_WM_CHECK AttributeMask
root)
Maybe AttributeMask -> X AttributeMask
validateWindow (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Maybe CLong
supportWindow)
where
validateWindow :: Maybe Window -> X Window
validateWindow :: Maybe AttributeMask -> X AttributeMask
validateWindow Maybe AttributeMask
w = do
Bool
valid <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) AttributeMask -> X Bool
isValidWindow Maybe AttributeMask
w
if Bool
valid then
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust Maybe AttributeMask
w
else
X AttributeMask
createSupportWindow
isValidWindow :: Window -> X Bool
isValidWindow :: AttributeMask -> X Bool
isValidWindow AttributeMask
w = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr WindowAttributes
p -> do
CInt
status <- Display -> AttributeMask -> Ptr WindowAttributes -> IO CInt
xGetWindowAttributes Display
dpy AttributeMask
w Ptr WindowAttributes
p
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
status forall a. Eq a => a -> a -> Bool
/= CInt
0)
createSupportWindow :: X Window
createSupportWindow :: X AttributeMask
createSupportWindow = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
AttributeMask
root <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> AttributeMask
theRoot
let visual :: Visual
visual = Display -> Dimension -> Visual
defaultVisual Display
dpy (Display -> Dimension
defaultScreen Display
dpy)
AttributeMask
window <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes forall a b. (a -> b) -> a -> b
$ \Ptr SetWindowAttributes
winAttrs -> do
Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
winAttrs Bool
True
Ptr SetWindowAttributes -> AttributeMask -> IO ()
set_event_mask Ptr SetWindowAttributes
winAttrs AttributeMask
propertyChangeMask
let bogusX :: Position
bogusX = -Position
100
bogusY :: Position
bogusY = -Position
100
in
Display
-> AttributeMask
-> Position
-> Position
-> Dimension
-> Dimension
-> CInt
-> CInt
-> CInt
-> Visual
-> AttributeMask
-> Ptr SetWindowAttributes
-> IO AttributeMask
createWindow Display
dpy AttributeMask
root Position
bogusX Position
bogusY Dimension
1 Dimension
1 CInt
0 CInt
0 CInt
inputOutput Visual
visual (AttributeMask
cWEventMask forall a. Bits a => a -> a -> a
.|. AttributeMask
cWOverrideRedirect) Ptr SetWindowAttributes
winAttrs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> AttributeMask -> IO ()
mapWindow Display
dpy AttributeMask
window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> AttributeMask -> IO ()
lowerWindow Display
dpy AttributeMask
window
forall (m :: * -> *) a. Monad m => a -> m a
return AttributeMask
window
getWMName :: X String
getWMName :: X String
getWMName = X AttributeMask
getSupportWindow forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Query a -> AttributeMask -> X a
runQuery Query String
title