From c2218350dfd21f60707e34eb1db112a0ae2ba548 Mon Sep 17 00:00:00 2001 From: "allbery.b" Date: Sun, 3 Aug 2014 04:05:30 +0200 Subject: debug-debug Ignore-this: cbb2b1d99293e3a4d02a256c2733aeb0 Various fixes and enhancements to DebugWindow and DebugStack. ManageDebug requires these fixes, but some of them are significant even if not using ManageDebug. darcs-hash:20140803020530-181ff-f11b9446cddb31d970d1e227e63ec6ec5a45a0d2.gz --- XMonad/Hooks/DebugStack.hs | 113 ++++++++++++++++++++++++++------------------- XMonad/Util/DebugWindow.hs | 58 ++++++++++++++++++----- 2 files changed, 111 insertions(+), 60 deletions(-) diff --git a/XMonad/Hooks/DebugStack.hs b/XMonad/Hooks/DebugStack.hs index a07495d..bb42696 100644 --- a/XMonad/Hooks/DebugStack.hs +++ b/XMonad/Hooks/DebugStack.hs @@ -1,26 +1,30 @@ ----------------------------------------------------------------------------- -- | -- Module : XMonad.Hooks.DebugStack --- Copyright : (c) Brandon S Allbery KF8NH, 2012 +-- Copyright : (c) Brandon S Allbery KF8NH, 2014 -- License : BSD3-style (see LICENSE) -- -- Maintainer : allbery.b@gmail.com -- Stability : unstable -- Portability : not portable -- --- Dump the state of the 'StackSet'. A @logHook@ and @handleEventHook@ are +-- Dump the state of the 'StackSet'. A @logHook@ and @handleEventHook@ are -- also provided. -- ----------------------------------------------------------------------------- module XMonad.Hooks.DebugStack (debugStack + ,debugStackFull ,debugStackString + ,debugStackFullString ,debugStackLogHook + ,debugStackFullLogHook ,debugStackEventHook + ,debugStackFullEventHook ) where import XMonad.Core -import qualified XMonad.StackSet as W +import qualified XMonad.StackSet as W import XMonad.Util.DebugWindow @@ -28,66 +32,79 @@ import Graphics.X11.Types (Window) import Graphics.X11.Xlib.Extras (Event) import Control.Monad (foldM) -import Data.Map (toList) +import Data.Map (member) import Data.Monoid (All(..)) +import Data.List (intercalate) --- | Print the state of the current window stack to @stderr@, which for most --- installations goes to @~/.xsession-errors@. "XMonad.Util.DebugWindow" --- is used to display the individual windows. +-- | Print the state of the current window stack for the current workspace to +-- @stderr@, which for most installations goes to @~/.xsession-errors@. +-- "XMonad.Util.DebugWindow" is used to display the individual windows. debugStack :: X () debugStack = debugStackString >>= trace --- | The above packaged as a 'logHook'. (Currently this is identical.) +-- | Print the state of the current window stack for all workspaces to +-- @stderr@, which for most installations goes to @~/.xsession-errors@. +-- "XMonad.Util.DebugWindow" is used to display the individual windows. +debugStackFull :: X () +debugStackFull = debugStackFullString >>= trace + +-- | 'debugStack' packaged as a 'logHook'. (Currently this is identical.) debugStackLogHook :: X () debugStackLogHook = debugStack --- | The above packaged as a 'handleEventHook'. You almost certainly do not +-- | 'debugStackFull packaged as a 'logHook'. (Currently this is identical.) +debugStackFullLogHook :: X () +debugStackFullLogHook = debugStackFull + +-- | 'debugStack' packaged as a 'handleEventHook'. You almost certainly do not -- want to use this unconditionally, as it will cause massive amounts of -- output and possibly slow @xmonad@ down severely. debugStackEventHook :: Event -> X All debugStackEventHook _ = debugStack >> return (All True) --- | Dump the state of the current 'StackSet' as a multiline 'String'. +-- | 'debugStackFull' packaged as a 'handleEventHook'. You almost certainly do +-- not want to use this unconditionally, as it will cause massive amounts of +-- output and possibly slow @xmonad@ down severely. + +debugStackFullEventHook :: Event -> X All +debugStackFullEventHook _ = debugStackFull >> return (All True) + +-- | Dump the state of the current workspace in the 'StackSet' as a multiline 'String'. +debugStackString :: X String +debugStackString = withWindowSet $ debugStackWs . W.workspace . W.current + +-- | Dump the state of all workspaces in the 'StackSet' as a multiline 'String'. +-- @@@ this is in stackset order, which is roughly lru-ish +debugStackFullString :: X String +debugStackFullString = withWindowSet $ fmap (intercalate "\n") . mapM debugStackWs . W.workspaces + +-- | Dump the state of a workspace in the current 'StackSet' as a multiline 'String'. -- @ --- stack [ mm --- ,(*) ww --- , ww --- ] --- float { ww --- , ww --- } +-- Workspace "foo:: +-- mm +-- * ww +-- ^ww -- @ --- --- One thing I'm not sure of is where the zipper is when focus is on a --- floating window. -debugStackString :: X String -debugStackString = withWindowSet $ \ws -> do - s <- emit "stack" ("[","]") (W.peek ws) $ W.index ws - f <- emit "float" ("{","}") (W.peek ws) $ map fst $ toList $ W.floating ws - return $ s ++ f +-- * indicates the focused window, ^ indicates a floating window +debugStackWs :: W.Workspace String (Layout Window) Window -> X String +debugStackWs w = withWindowSet $ \ws -> do + let cur = if wt == W.currentTag ws then " (current)" else "" + wt = W.tag w + s <- emit ws $ W.integrate' . W.stack $ w + return $ intercalate "\n" $ ("Workspace " ++ show wt ++ cur):s where - emit :: String -> (String,String) -> Maybe Window -> [Window] -> X String - emit title (lb,rb) _ [] = return $ title ++ " " ++ lb ++ rb ++ "]\n" - emit title (lb,rb) focused ws = do - (_,_,_,_,ss) <- foldM emit' (title,lb,rb,focused,"") ws - return $ ss ++ - replicate (length title + 1) ' ' ++ - rb ++ - "\n" - - emit' :: (String,String,String,Maybe Window,String) + emit :: WindowSet -> [Window] -> X [String] + emit _ [] = return [" -empty workspace-"] + emit ww ws = do + (_,ss) <- foldM emit' (ww,[]) ws + return ss + + emit' :: (WindowSet,[String]) -> Window - -> X (String,String,String,Maybe Window,String) - emit' (t,l,r,f,a) w = do - w' <- emit'' f w - return (replicate (length t) ' ' - ,',' : replicate (length l - 1) ' ' - ,r - ,f - ,a ++ t ++ " " ++ l ++ w' ++ "\n" - ) - emit'' :: Maybe Window -> Window -> X String - emit'' focus win = - let fi f = if win == f then "(*) " else " " - in (maybe " " fi focus ++) `fmap` debugWindow win + -> X (WindowSet,[String]) + emit' (ws,a) w' = do + let focus = if Just w' == W.peek ws then '*' else ' ' + float = if w' `member` W.floating ws then '^' else ' ' + s <- debugWindow w' + return (ws,(focus:float:s):a) diff --git a/XMonad/Util/DebugWindow.hs b/XMonad/Util/DebugWindow.hs index 9fe5817..d4f5138 100644 --- a/XMonad/Util/DebugWindow.hs +++ b/XMonad/Util/DebugWindow.hs @@ -1,14 +1,14 @@ ----------------------------------------------------------------------------- -- | -- Module : XMonad.Util.DebugWindow --- Copyright : (c) Brandon S Allbery KF8NH, 2012 +-- 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 +-- Module to dump window information for diagnostic/debugging purposes. See -- "XMonad.Hooks.DebugEvents" and "XMonad.Hooks.DebugStack" for practical uses. -- ----------------------------------------------------------------------------- @@ -20,7 +20,7 @@ import Prelude import XMonad import Codec.Binary.UTF8.String (decodeString) -import Control.Exception.Extensible as E +import Control.Exception.Extensible as E import Control.Monad (when) import Data.List (unfoldr ,intercalate @@ -34,7 +34,7 @@ import System.Exit -- 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 "None" +debugWindow 0 = return "-no window-" debugWindow w = do let wx = pad 8 '0' $ showHex w "" w' <- withDisplay $ \d -> io (safeGetWindowAttributes d w) @@ -59,23 +59,36 @@ debugWindow w = do 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' - ,"window " ,wx ,t - ," (" + ," " ,show wid - ,',':show ht - ,')':if bw == 0 then "" else '+':show bw - ,"@(" + ,'x':show ht + ,if bw == 0 then "" else '+':show bw + ,"@" ,show x ,',':show y - ,')':if null c then "" else ' ':c + ,if null c then "" else ' ':c + ,if null cmd then "" else ' ':cmd ,rb ] @@ -86,8 +99,11 @@ getEWMHTitle sub w = do return $ map (toEnum . fromEnum) t getICCCMTitle :: Window -> X String -getICCCMTitle w = do - t@(TextProperty t' _ 8 _) <- withDisplay $ \d -> io $ getTextProperty d w wM_NAME +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') @@ -138,3 +154,21 @@ safeGetWindowAttributes d w = alloca $ \p -> do 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 "") -- cgit v1.2.3