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