mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-05-19 11:30:22 -07:00
222 lines
8.6 KiB
Haskell
222 lines
8.6 KiB
Haskell
-----------------------------------------------------------------------------
|
|
-- |
|
|
-- 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' = drop 1 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"
|
|
getDecodedStringProp w a -- should always be UTF8_STRING but rules are made to be broken
|
|
|
|
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) $ -- shouldn't happen but some apps do it
|
|
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 (peekCAString 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')
|