xmonad-contrib/XMonad/Util/DebugWindow.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.DebugWindow
-- Copyright   :  (c) Brandon S Allbery KF8NH, 2014
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  allbery.b@gmail.com
-- Stability   :  unstable
-- Portability :  not portable
--
-- Module to dump window information for diagnostic/debugging purposes. See 
-- "XMonad.Hooks.DebugEvents" and "XMonad.Hooks.DebugStack" for practical uses.
--
-----------------------------------------------------------------------------

module XMonad.Util.DebugWindow (debugWindow) where

import           Prelude

import           XMonad

import           Codec.Binary.UTF8.String        (decodeString)
import           Control.Exception.Extensible                          as E
import           Control.Monad                   (when)
import           Data.List                       (unfoldr
                                                 ,intercalate
                                                 )
import           Foreign
import           Foreign.C.String
import           Numeric                         (showHex)
import           System.Exit

-- | Output a window by ID in hex, decimal, its ICCCM resource name and class,
--   and its title if available.  Also indicate override_redirect with an
--   exclamation mark, and wrap in brackets if it is unmapped or withdrawn.
debugWindow   :: Window -> X String
debugWindow 0 =  return "-no window-"
debugWindow w =  do
  let wx = pad 8 '0' $ showHex w ""
  w' <- withDisplay $ \d -> io (safeGetWindowAttributes d w)
  case w' of
    Nothing                                   ->
      return $ "(deleted window " ++ wx ++ ")"
    Just (WindowAttributes x y wid ht bw m o) -> do
      c' <- withDisplay $ \d ->
            io (getWindowProperty8 d wM_CLASS w)
      let c = case c' of
                Nothing -> ""
                Just c''  -> intercalate "/" $
                             flip unfoldr (map (toEnum . fromEnum) c'') $
                             \s -> if null s
                                     then Nothing
                                     else let (w'',s'') = break (== '\NUL') s
                                              s'      = if null s''
                                                          then s''
                                                          else tail s''
                                          in Just (w'',s')
      t <- catchX' (wrap `fmap` getEWMHTitle  "VISIBLE" w) $
           catchX' (wrap `fmap` getEWMHTitle  ""        w) $
           catchX' (wrap `fmap` getICCCMTitle           w) $
           return ""
      h' <- getMachine w
      let h = if null h' then "" else '@':h'
      -- if it has WM_COMMAND use it, else use the appName
      -- NB. modern stuff often does not set WM_COMMAND since it's only ICCCM required and not some
      -- horrible gnome/freedesktop session manager thing like Wayland intended. How helpful of them.
      p' <- withDisplay $ \d -> safeGetCommand d w
      let p = if null p' then "" else wrap $ intercalate " " p'
      nWP <- getAtom "_NET_WM_PID"
      pid' <- withDisplay $ \d -> io $ getWindowProperty32 d nWP w
      let pid = case pid' of
                  Just [pid''] -> '(':show pid'' ++ ")"
                  _            -> ""
      let cmd = p ++ pid ++ h
      let (lb,rb) = case () of
                      () | m == waIsViewable -> ("","")
                         | otherwise         -> ("[","]")
          o'      = if o then "!" else ""
      return $ concat [lb
                      ,o'
                      ,wx
                      ,t
                      ," "
                      ,show wid
                      ,'x':show ht
                      ,if bw == 0 then "" else '+':show bw
                      ,"@"
                      ,show x
                      ,',':show y
                      ,if null c then "" else ' ':c
                      ,if null cmd then "" else ' ':cmd 
                      ,rb
                      ]

getEWMHTitle       :: String -> Window -> X String
getEWMHTitle sub w =  do
  a <- getAtom $ "_NET_WM_" ++ (if null sub then "" else '_':sub) ++ "_NAME"
  (Just t) <- withDisplay $ \d -> io $ getWindowProperty32 d a w
  return $ map (toEnum . fromEnum) t

getICCCMTitle   :: Window -> X String
getICCCMTitle w =  getDecodedStringProp w wM_NAME

getDecodedStringProp     :: Window -> Atom -> X String
getDecodedStringProp w a =  do
  t@(TextProperty t' _ 8 _) <- withDisplay $ \d -> io $ getTextProperty d w a
  [s] <- catchX' (tryUTF8     t) $
         catchX' (tryCompound t) $
         io ((:[]) `fmap` peekCString t')
  return s

tryUTF8                          :: TextProperty -> X [String]
tryUTF8 (TextProperty s enc _ _) =  do
  uTF8_STRING <- getAtom "UTF8_STRING"
  when (enc == uTF8_STRING) $ error "String is not UTF8_STRING"
  (map decodeString . splitNul) `fmap` io (peekCString s)

tryCompound                            :: TextProperty -> X [String]
tryCompound t@(TextProperty _ enc _ _) =  do
  cOMPOUND_TEXT <- getAtom "COMPOUND_TEXT"
  when (enc == cOMPOUND_TEXT) $ error "String is not COMPOUND_TEXT"
  withDisplay $ \d -> io $ wcTextPropertyToTextList d t

splitNul    :: String -> [String]
splitNul "" =  []
splitNul s  =  let (s',ss') = break (== '\NUL') s in s' : splitNul ss'

pad       :: Int -> Char -> String -> String
pad w c s =  replicate (w - length s) c ++ s

-- modified 'catchX' without the print to 'stderr'
catchX' :: X a -> X a -> X a
catchX' job errcase = do
  st <- get
  c <- ask
  (a, s') <- io $ runX c st job `E.catch` \e -> case fromException e of
    Just x -> throw e `const` (x `asTypeOf` ExitSuccess)
    _ -> runX c st errcase
  put s'
  return a

wrap   :: String -> String
wrap s =  ' ' : '"' : wrap' s ++ "\""
  where
    wrap' (s':ss) | s' == '"'  = '\\' : s' : wrap' ss
                  | s' == '\\' = '\\' : s' : wrap' ss
                  | otherwise  =        s' : wrap' ss
    wrap' ""                   =             ""

-- Graphics.X11.Extras.getWindowAttributes is bugggggggy
safeGetWindowAttributes     :: Display -> Window -> IO (Maybe WindowAttributes)
safeGetWindowAttributes d w =  alloca $ \p -> do
  s <- xGetWindowAttributes d w p
  case s of
    0 -> return Nothing
    _ -> Just `fmap` peek p

-- and so is getCommand
safeGetCommand     :: Display -> Window -> X [String]
safeGetCommand d w =  do
  wC <- getAtom "WM_COMMAND"
  p <- io $ getWindowProperty8 d wC w
  case p of
    Nothing  -> return []
    Just cs' -> do
      let cs                    = map (toEnum . fromEnum) cs'
          go  (a,(s,"\NUL"))    = (s:a,("",""))
          go  (a,(s,'\NUL':ss)) = go (s:a,go' ss)
          go  r                 = r -- ???
          go'                   = break (== '\NUL')
       in return $ reverse $ fst $ go ([],go' cs)

getMachine   :: Window -> X String
getMachine w =  catchX' (getAtom "WM_CLIENT_MACHINE" >>= getDecodedStringProp w) (return "")