    -----------------------------------------------------------------------------
    -- |
    -- 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.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
    -- <https://xmonad.org/TUTORIAL.html the tutorial> and "XMonad.Doc.Extending".
    -----------------------------------------------------------------------------

    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
        atom_NET_SUPPORTING_WM_CHECK <- X AttributeMask
    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
            -- _NET_SUPPORTING_WM_CHECK atom of root and support windows refers to the support window
            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]) [root, supportWindow]
            -- set WM_NAME in supportWindow (now only accepts latin1 names to eliminate dependency on utf8 encoder)
            changeProperty8 dpy supportWindow atom_NET_WM_NAME atom_UTF8_STRING propModeReplace (latin1StringToCCharList name)
            -- declare which _NET protocols are supported (append to the list if it exists)
            supportedList <- join . maybeToList <$> getWindowProperty32 dpy atom_NET_SUPPORTED_ATOM root
            changeProperty32 dpy root atom_NET_SUPPORTED_ATOM aTOM propModeReplace (nub $ fromIntegral atom_NET_SUPPORTING_WM_CHECK : fromIntegral atom_NET_WM_NAME : 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
        atom_NET_SUPPORTING_WM_CHECK <- X AttributeMask
    netSupportingWMCheckAtom
        root <- asks theRoot
        supportWindow <- (listToMaybe =<<) <$> io (getWindowProperty32 dpy atom_NET_SUPPORTING_WM_CHECK root)
        validateWindow (fmap fromIntegral supportWindow)
      where
        validateWindow :: Maybe Window -> X Window
        validateWindow :: Maybe AttributeMask -> X AttributeMask
    validateWindow Maybe AttributeMask
    w = do
            valid <- X Bool
    -> (AttributeMask -> X Bool) -> Maybe AttributeMask -> 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) AttributeMask -> X Bool
    isValidWindow Maybe AttributeMask
    w
            if valid then
                return $ fromJust w
              else
                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
            status <- Display -> AttributeMask -> Ptr WindowAttributes -> IO CInt
    xGetWindowAttributes Display
    dpy AttributeMask
    w Ptr WindowAttributes
    p
            return (status /= 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
            root <- (XConf -> AttributeMask) -> X AttributeMask
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> AttributeMask
    theRoot
            let visual = Display -> Dimension -> Visual
    defaultVisual Display
    dpy (Display -> Dimension
    defaultScreen Display
    dpy)  -- should be CopyFromParent (=0), but the constructor is hidden in X11.XLib
            window <- io $ allocaSetWindowAttributes $ \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 $ mapWindow dpy window   -- not sure if this is needed
            io $ lowerWindow dpy window -- not sure if this is needed
            return window

    -- | Get WM name.
    getWMName :: X String
    getWMName :: X String
    getWMName = X AttributeMask
    getSupportWindow X AttributeMask -> (AttributeMask -> 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 -> AttributeMask -> X String
    forall a. Query a -> AttributeMask -> X a
    runQuery Query String
    title