----------------------------------------------------------------------------- -- | -- Module : XMonad.Util.DebugWindow -- Description : Dump window information for diagnostic\/debugging purposes. -- 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 XMonad.Prelude import Codec.Binary.UTF8.String (decodeString) import Control.Exception as E import Foreign.C.String import Numeric (showHex) import System.Exit -- | Output a window by ID in hex, decimal, its ICCCM resource name and class, -- its title if available, and EWMH type and state 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 d <- asks display let wx = pad 8 '0' $ showHex w "" w' <- safeGetWindowAttributes w case w' of Nothing -> return $ "(deleted window " ++ wx ++ ")" Just WindowAttributes { wa_x = x , wa_y = y , wa_width = wid , wa_height = ht , wa_border_width = bw , wa_map_state = m , wa_override_redirect = o } -> do c' <- 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 <$> getEWMHTitle "VISIBLE" w) $ catchX' (wrap <$> getEWMHTitle "" w) $ catchX' (wrap <$> 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' <- safeGetCommand d w let p = if null p' then "" else wrap $ unwords p' nWP <- getAtom "_NET_WM_PID" pid' <- 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 "" wT <- getAtom "_NET_WM_WINDOW_TYPE" wt' <- io $ getWindowProperty32 d wT w ewmh <- case wt' of Just wt'' -> windowType d w (fmap fi wt'') _ -> return "" 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 ,ewmh ,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 ((:[]) <$> 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 <$> 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' "" = "" -- 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 "") -- if it's one EWMH atom then we strip prefix and lowercase, otherwise we -- return the whole thing. we also get the state here, with similar rules -- (all EWMH = all prefixes removed and lowercased) windowType :: Display -> Window -> [Atom] -> X String windowType d w ts = do tstr <- decodeType ts wS <- getAtom "_NET_WM_STATE" ss' <- io $ getWindowProperty32 d wS w sstr <- case ss' of Just ss -> windowState (fmap fi ss) _ -> return "" return $ " (" ++ tstr ++ sstr ++ ")" where decodeType :: [Atom] -> X String decodeType [] = return "" decodeType [t] = simplify "_NET_WM_WINDOW_TYPE_" t decodeType tys = unAtoms tys " (" False unAtoms :: [Atom] -> String -> Bool -> X String unAtoms [] t i = return $ if i then t else t ++ ")" unAtoms (a:as) t i = do s' <- io $ getAtomName d a let s = case s' of Just s'' -> s'' _ -> '<':show a ++ ">" unAtoms as (t ++ (if i then ' ':s else s)) True simplify :: String -> Atom -> X String simplify pfx a = do s' <- io $ getAtomName d a case s' of Nothing -> return $ '<':show a ++ ">" Just s -> if pfx `isPrefixOf` s then return $ map toLower (drop (length pfx) s) else return s -- note that above it says this checks all of them before simplifying. -- I'll do that after I'm confident this works as intended. windowState :: [Atom] -> X String windowState [] = return "" windowState as' = go as' ";" where go [] t = return t go (a:as) t = simplify "_NET_WM_STATE_" a >>= \t' -> go as (t ++ ' ':t')