    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Hooks.SetWMName
    -- 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) 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

    -- | sets WM name
    setWMName :: String -> X ()
    setWMName :: String -> X ()
    setWMName name :: String
    name = do
        Atom
    atom_NET_SUPPORTING_WM_CHECK <- X Atom
    netSupportingWMCheckAtom
        Atom
    atom_NET_WM_NAME <- String -> X Atom
    getAtom "_NET_WM_NAME"
        Atom
    atom_NET_SUPPORTED_ATOM <- String -> X Atom
    getAtom "_NET_SUPPORTED"
        Atom
    atom_UTF8_STRING <- String -> X Atom
    getAtom "UTF8_STRING"

        Atom
    root <- (XConf -> Atom) -> X Atom
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Atom
    theRoot
        Atom
    supportWindow <- X Atom
    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
            (Atom -> IO ()) -> [Atom] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (\w :: Atom
    w -> Display -> Atom -> Atom -> Atom -> CInt -> [CLong] -> IO ()
    changeProperty32 Display
    dpy Atom
    w Atom
    atom_NET_SUPPORTING_WM_CHECK Atom
    wINDOW 0 [Atom -> CLong
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Atom
    supportWindow]) [Atom
    root, Atom
    supportWindow]
            -- set WM_NAME in supportWindow (now only accepts latin1 names to eliminate dependency on utf8 encoder)
            Display -> Atom -> Atom -> Atom -> CInt -> [CChar] -> IO ()
    changeProperty8 Display
    dpy Atom
    supportWindow Atom
    atom_NET_WM_NAME Atom
    atom_UTF8_STRING 0 (String -> [CChar]
    latin1StringToCCharList String
    name)
            -- declare which _NET protocols are supported (append to the list if it exists)
            [CLong]
    supportedList <- (Maybe [CLong] -> [CLong]) -> IO (Maybe [CLong]) -> IO [CLong]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ([[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) (IO (Maybe [CLong]) -> IO [CLong])
    -> IO (Maybe [CLong]) -> IO [CLong]
    forall a b. (a -> b) -> a -> b
    $ Display -> Atom -> Atom -> IO (Maybe [CLong])
    getWindowProperty32 Display
    dpy Atom
    atom_NET_SUPPORTED_ATOM Atom
    root
            Display -> Atom -> Atom -> Atom -> CInt -> [CLong] -> IO ()
    changeProperty32 Display
    dpy Atom
    root Atom
    atom_NET_SUPPORTED_ATOM Atom
    aTOM 0 ([CLong] -> [CLong]
    forall a. Eq a => [a] -> [a]
    nub ([CLong] -> [CLong]) -> [CLong] -> [CLong]
    forall a b. (a -> b) -> a -> b
    $ Atom -> CLong
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Atom
    atom_NET_SUPPORTING_WM_CHECK CLong -> [CLong] -> [CLong]
    forall a. a -> [a] -> [a]
    : Atom -> CLong
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Atom
    atom_NET_WM_NAME CLong -> [CLong] -> [CLong]
    forall a. a -> [a] -> [a]
    : [CLong]
    supportedList)
      where
        netSupportingWMCheckAtom :: X Atom
        netSupportingWMCheckAtom :: X Atom
    netSupportingWMCheckAtom = String -> X Atom
    getAtom "_NET_SUPPORTING_WM_CHECK"

        latin1StringToCCharList :: String -> [CChar]
        latin1StringToCCharList :: String -> [CChar]
    latin1StringToCCharList str :: String
    str = (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) String
    str

        getSupportWindow :: X Window
        getSupportWindow :: X Atom
    getSupportWindow = (Display -> X Atom) -> X Atom
    forall a. (Display -> X a) -> X a
    withDisplay ((Display -> X Atom) -> X Atom) -> (Display -> X Atom) -> X Atom
    forall a b. (a -> b) -> a -> b
    $ \dpy :: Display
    dpy -> do
            Atom
    atom_NET_SUPPORTING_WM_CHECK <- X Atom
    netSupportingWMCheckAtom
            Atom
    root <- (XConf -> Atom) -> X Atom
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Atom
    theRoot
            Maybe CLong
    supportWindow <- (Maybe [CLong] -> Maybe CLong)
    -> X (Maybe [CLong]) -> X (Maybe CLong)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Maybe (Maybe CLong) -> Maybe CLong
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join (Maybe (Maybe CLong) -> Maybe CLong)
    -> (Maybe [CLong] -> Maybe (Maybe CLong))
    -> Maybe [CLong]
    -> Maybe CLong
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([CLong] -> Maybe CLong) -> Maybe [CLong] -> Maybe (Maybe CLong)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [CLong] -> Maybe CLong
    forall a. [a] -> Maybe a
    listToMaybe) (X (Maybe [CLong]) -> X (Maybe CLong))
    -> X (Maybe [CLong]) -> X (Maybe CLong)
    forall a b. (a -> b) -> a -> b
    $ IO (Maybe [CLong]) -> X (Maybe [CLong])
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    io (IO (Maybe [CLong]) -> X (Maybe [CLong]))
    -> IO (Maybe [CLong]) -> X (Maybe [CLong])
    forall a b. (a -> b) -> a -> b
    $ Display -> Atom -> Atom -> IO (Maybe [CLong])
    getWindowProperty32 Display
    dpy Atom
    atom_NET_SUPPORTING_WM_CHECK Atom
    root
            Maybe Atom -> X Atom
    validateWindow ((CLong -> Atom) -> Maybe CLong -> Maybe Atom
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap CLong -> Atom
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Maybe CLong
    supportWindow)

        validateWindow :: Maybe Window -> X Window
        validateWindow :: Maybe Atom -> X Atom
    validateWindow w :: Maybe Atom
    w = do
            Bool
    valid <- X Bool -> (Atom -> X Bool) -> Maybe Atom -> 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) Atom -> X Bool
    isValidWindow Maybe Atom
    w
            if Bool
    valid then
                Atom -> X Atom
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Atom -> X Atom) -> Atom -> X Atom
    forall a b. (a -> b) -> a -> b
    $ Maybe Atom -> Atom
    forall a. HasCallStack => Maybe a -> a
    fromJust Maybe Atom
    w
              else
                X Atom
    createSupportWindow

        -- is there a better way to check the validity of the window?
        isValidWindow :: Window -> X Bool
        isValidWindow :: Atom -> X Bool
    isValidWindow w :: Atom
    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
    $ \dpy :: 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
    $ \p :: Ptr WindowAttributes
    p -> do
            CInt
    status <- Display -> Atom -> Ptr WindowAttributes -> IO CInt
    xGetWindowAttributes Display
    dpy Atom
    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
    /= 0)

        -- this code was translated from C (see OpenBox WM, screen.c)
        createSupportWindow :: X Window
        createSupportWindow :: X Atom
    createSupportWindow = (Display -> X Atom) -> X Atom
    forall a. (Display -> X a) -> X a
    withDisplay ((Display -> X Atom) -> X Atom) -> (Display -> X Atom) -> X Atom
    forall a b. (a -> b) -> a -> b
    $ \dpy :: Display
    dpy -> do
            Atom
    root <- (XConf -> Atom) -> X Atom
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Atom
    theRoot
            let visual :: Visual
    visual = Display -> ScreenNumber -> Visual
    defaultVisual Display
    dpy (Display -> ScreenNumber
    defaultScreen Display
    dpy)  -- should be CopyFromParent (=0), but the constructor is hidden in X11.XLib
            Atom
    window <- IO Atom -> X Atom
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    io (IO Atom -> X Atom) -> IO Atom -> X Atom
    forall a b. (a -> b) -> a -> b
    $ (Ptr SetWindowAttributes -> IO Atom) -> IO Atom
    forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
    allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO Atom) -> IO Atom)
    -> (Ptr SetWindowAttributes -> IO Atom) -> IO Atom
    forall a b. (a -> b) -> a -> b
    $ \winAttrs :: 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 -> Atom -> IO ()
    set_event_mask Ptr SetWindowAttributes
    winAttrs Atom
    propertyChangeMask  -- not sure if this is needed
                let bogusX :: Position
    bogusX = -100
                    bogusY :: Position
    bogusY = -100
                  in
                    Display
    -> Atom
    -> Position
    -> Position
    -> ScreenNumber
    -> ScreenNumber
    -> CInt
    -> CInt
    -> CInt
    -> Visual
    -> Atom
    -> Ptr SetWindowAttributes
    -> IO Atom
    createWindow Display
    dpy Atom
    root Position
    bogusX Position
    bogusY 1 1 0 0 CInt
    inputOutput Visual
    visual (Atom
    cWEventMask Atom -> Atom -> Atom
    forall a. Bits a => a -> a -> a
    .|. Atom
    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 -> Atom -> IO ()
    mapWindow Display
    dpy Atom
    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 -> Atom -> IO ()
    lowerWindow Display
    dpy Atom
    window -- not sure if this is needed
            Atom -> X Atom
    forall (m :: * -> *) a. Monad m => a -> m a
    return Atom
    window