debug-debug

Various fixes and enhancements to DebugWindow and DebugStack. ManageDebug
requires these fixes, but some of them are significant even if not using
ManageDebug.

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
+-- | Print the state of the current window stack for the current workspace to
---   installations goes to @~/.xsession-errors@.  "XMonad.Util.DebugWindow"
+--   @stderr@, which for most installations goes to @~/.xsession-errors@.
---   is used to display the individual windows.
+--   "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
---   stack [    mm
+--   output and possibly slow @xmonad@ down severely.
---         ,(*) ww
---         ,    ww
---         ]
---   float {    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
-  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)
+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'.
+--   @
+--   Workspace "foo::
+--     mm
+--   * ww
+--    ^ww
+--   @
+--   * 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       :: 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)
+          -> X (WindowSet,[String])
-    emit' (t,l,r,f,a) w = do
+    emit' (ws,a) w' = do
-      w' <- emit'' f w
+      let focus = if Just w' == W.peek ws then '*' else ' '
-      return (replicate (length t) ' '
+          float = if w' `member` W.floating ws then '^' else ' '
-             ,',' : replicate (length l - 1) ' '
+      s <- debugWindow w'
-             ,r
+      return (ws,(focus:float:s):a)
-             ,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

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
+                      ,'x':show ht
-                      ,')':if bw == 0 then "" else '+':show bw
+                      ,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
+getICCCMTitle w =  getDecodedStringProp w wM_NAME
-  t@(TextProperty t' _ 8 _) <- withDisplay $ \d -> io $ getTextProperty d 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 "")