-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.SetWMName
-- Description :  Set the WM name to a given string.
-- Copyright   :  © 2007 Ivan Tarasov <Ivan.Tarasov@gmail.com>
-- License     :  BSD
--
-- Maintainer  :  Ivan.Tarasov@gmail.com
-- Stability   :  experimental
-- Portability :  unportable
--
-- Sets the WM name to a given string, so that it could be detected using
-- _NET_SUPPORTING_WM_CHECK protocol.
--
-- May be useful for making Java GUI programs work, just set WM name to "LG3D"
-- and use Java 1.6u1 (1.6.0_01-ea-b03 works for me) or later.
--
-- To your @~\/.xmonad\/xmonad.hs@ file, add the following line:
--
-- > import XMonad.Hooks.SetWMName
--
-- Then edit your @startupHook@:
--
-- > startupHook = setWMName "LG3D"
--
-- For details on the problems with running Java GUI programs in non-reparenting
-- WMs, see <http://bugs.sun.com/bugdatabase/view_bug.do?bug_id=6429775> and
-- related bugs.
--
-- Setting WM name to "compiz" does not solve the problem, because of yet
-- another bug in AWT code (related to insets). For LG3D insets are explicitly
-- set to 0, while for other WMs the insets are \"guessed\" and the algorithm
-- fails miserably by guessing absolutely bogus values.
--
-- For detailed instructions on editing your hooks, see
-- "XMonad.Doc.Extending#4".
-----------------------------------------------------------------------------

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)

-- | sets WM name
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 <- (XConf -> AttributeMask) -> X AttributeMask
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> AttributeMask
theRoot
    AttributeMask
supportWindow <- X AttributeMask
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
        -- _NET_SUPPORTING_WM_CHECK atom of root and support windows refers to the support window
        (AttributeMask -> IO ()) -> [AttributeMask] -> IO ()
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 [AttributeMask -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral AttributeMask
supportWindow]) [AttributeMask
root, AttributeMask
supportWindow]
        -- set WM_NAME in supportWindow (now only accepts latin1 names to eliminate dependency on utf8 encoder)
        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)
        -- declare which _NET protocols are supported (append to the list if it exists)
        [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 -> 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 ([CLong] -> [CLong]
forall a. Eq a => [a] -> [a]
nub ([CLong] -> [CLong]) -> [CLong] -> [CLong]
forall a b. (a -> b) -> a -> b
$ AttributeMask -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral AttributeMask
atom_NET_SUPPORTING_WM_CHECK CLong -> [CLong] -> [CLong]
forall a. a -> [a] -> [a]
: AttributeMask -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral AttributeMask
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 AttributeMask
netSupportingWMCheckAtom = String -> X AttributeMask
getAtom String
"_NET_SUPPORTING_WM_CHECK"

getSupportWindow :: X Window
getSupportWindow :: X AttributeMask
getSupportWindow = (Display -> X AttributeMask) -> X AttributeMask
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X AttributeMask) -> X AttributeMask)
-> (Display -> X AttributeMask) -> X AttributeMask
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    AttributeMask
atom_NET_SUPPORTING_WM_CHECK <- X AttributeMask
netSupportingWMCheckAtom
    AttributeMask
root <- (XConf -> AttributeMask) -> X AttributeMask
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> AttributeMask
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 -> AttributeMask -> AttributeMask -> IO (Maybe [CLong])
getWindowProperty32 Display
dpy AttributeMask
atom_NET_SUPPORTING_WM_CHECK AttributeMask
root)
    Maybe AttributeMask -> X AttributeMask
validateWindow ((CLong -> AttributeMask) -> Maybe CLong -> Maybe AttributeMask
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CLong -> AttributeMask
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 <- X Bool
-> (AttributeMask -> X Bool) -> Maybe AttributeMask -> X Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) AttributeMask -> X Bool
isValidWindow Maybe AttributeMask
w
        if Bool
valid then
            AttributeMask -> X AttributeMask
forall (m :: * -> *) a. Monad m => a -> m a
return (AttributeMask -> X AttributeMask)
-> AttributeMask -> X AttributeMask
forall a b. (a -> b) -> a -> b
$ Maybe AttributeMask -> AttributeMask
forall a. HasCallStack => Maybe a -> a
fromJust Maybe AttributeMask
w
          else
            X AttributeMask
createSupportWindow

    -- is there a better way to check the validity of the window?
    isValidWindow :: Window -> X Bool
    isValidWindow :: AttributeMask -> X Bool
isValidWindow AttributeMask
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 -> AttributeMask -> Ptr WindowAttributes -> IO CInt
xGetWindowAttributes Display
dpy AttributeMask
w Ptr WindowAttributes
p
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
status CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0)

    -- this code was translated from C (see OpenBox WM, screen.c)
    createSupportWindow :: X Window
    createSupportWindow :: X AttributeMask
createSupportWindow = (Display -> X AttributeMask) -> X AttributeMask
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X AttributeMask) -> X AttributeMask)
-> (Display -> X AttributeMask) -> X AttributeMask
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
        AttributeMask
root <- (XConf -> AttributeMask) -> X AttributeMask
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)  -- should be CopyFromParent (=0), but the constructor is hidden in X11.XLib
        AttributeMask
window <- IO AttributeMask -> X AttributeMask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO AttributeMask -> X AttributeMask)
-> IO AttributeMask -> X AttributeMask
forall a b. (a -> b) -> a -> b
$ (Ptr SetWindowAttributes -> IO AttributeMask) -> IO AttributeMask
forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO AttributeMask) -> IO AttributeMask)
-> (Ptr SetWindowAttributes -> IO AttributeMask)
-> IO AttributeMask
forall a b. (a -> b) -> a -> b
$ \Ptr SetWindowAttributes
winAttrs -> do
            Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
winAttrs Bool
True         -- WM cannot decorate/move/close this window
            Ptr SetWindowAttributes -> AttributeMask -> IO ()
set_event_mask Ptr SetWindowAttributes
winAttrs AttributeMask
propertyChangeMask  -- not sure if this is needed
            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 AttributeMask -> AttributeMask -> AttributeMask
forall a. Bits a => a -> a -> a
.|. AttributeMask
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 -> AttributeMask -> IO ()
mapWindow Display
dpy AttributeMask
window   -- not sure if this is needed
        IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> AttributeMask -> IO ()
lowerWindow Display
dpy AttributeMask
window -- not sure if this is needed
        AttributeMask -> X AttributeMask
forall (m :: * -> *) a. Monad m => a -> m a
return AttributeMask
window

-- | Get WM name.
getWMName :: X String
getWMName :: X String
getWMName = X AttributeMask
getSupportWindow X AttributeMask -> (AttributeMask -> X String) -> X String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Query String -> AttributeMask -> X String
forall a. Query a -> AttributeMask -> X a
runQuery Query String
title