module XMonad.Hooks.SetWMName (
setWMName) where
import Control.Monad (join)
import Data.Char (ord)
import Data.List (nub)
import Data.Maybe (fromJust, listToMaybe, maybeToList)
import Foreign.C.Types (CChar)
import Foreign.Marshal.Alloc (alloca)
import XMonad
setWMName :: String -> X ()
setWMName name = do
atom_NET_SUPPORTING_WM_CHECK <- netSupportingWMCheckAtom
atom_NET_WM_NAME <- getAtom "_NET_WM_NAME"
atom_NET_SUPPORTED_ATOM <- getAtom "_NET_SUPPORTED"
atom_UTF8_STRING <- getAtom "UTF8_STRING"
root <- asks theRoot
supportWindow <- getSupportWindow
dpy <- asks display
io $ do
mapM_ (\w -> changeProperty32 dpy w atom_NET_SUPPORTING_WM_CHECK wINDOW 0 [fromIntegral supportWindow]) [root, supportWindow]
changeProperty8 dpy supportWindow atom_NET_WM_NAME atom_UTF8_STRING 0 (latin1StringToCCharList name)
supportedList <- fmap (join . maybeToList) $ getWindowProperty32 dpy atom_NET_SUPPORTED_ATOM root
changeProperty32 dpy root atom_NET_SUPPORTED_ATOM aTOM 0 (nub $ fromIntegral atom_NET_SUPPORTING_WM_CHECK : fromIntegral atom_NET_WM_NAME : supportedList)
where
netSupportingWMCheckAtom :: X Atom
netSupportingWMCheckAtom = getAtom "_NET_SUPPORTING_WM_CHECK"
latin1StringToCCharList :: String -> [CChar]
latin1StringToCCharList str = map (fromIntegral . ord) str
getSupportWindow :: X Window
getSupportWindow = withDisplay $ \dpy -> do
atom_NET_SUPPORTING_WM_CHECK <- netSupportingWMCheckAtom
root <- asks theRoot
supportWindow <- fmap (join . fmap listToMaybe) $ io $ getWindowProperty32 dpy atom_NET_SUPPORTING_WM_CHECK root
validateWindow (fmap fromIntegral supportWindow)
validateWindow :: Maybe Window -> X Window
validateWindow w = do
valid <- maybe (return False) isValidWindow w
if valid then
return $ fromJust w
else
createSupportWindow
isValidWindow :: Window -> X Bool
isValidWindow w = withDisplay $ \dpy -> io $ alloca $ \p -> do
status <- xGetWindowAttributes dpy w p
return (status /= 0)
createSupportWindow :: X Window
createSupportWindow = withDisplay $ \dpy -> do
root <- asks theRoot
let visual = defaultVisual dpy (defaultScreen dpy)
window <- io $ allocaSetWindowAttributes $ \winAttrs -> do
set_override_redirect winAttrs True
set_event_mask winAttrs propertyChangeMask
let bogusX = -100
bogusY = -100
in
createWindow dpy root bogusX bogusY 1 1 0 0 inputOutput visual (cWEventMask .|. cWOverrideRedirect) winAttrs
io $ mapWindow dpy window
io $ lowerWindow dpy window
return window