-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.DebugStack
-- Description :  Dump the state of the StackSet.
-- 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
-- also provided.
--
-----------------------------------------------------------------------------

module XMonad.Hooks.DebugStack (debugStack
                               ,debugStackFull
                               ,debugStackString
                               ,debugStackFullString
                               ,debugStackLogHook
                               ,debugStackFullLogHook
                               ,debugStackEventHook
                               ,debugStackFullEventHook
                               ) where

import           XMonad.Core
import           XMonad.Prelude
import qualified XMonad.StackSet                                       as W

import           XMonad.Util.DebugWindow

import           Graphics.X11.Types                  (Window)
import           Graphics.X11.Xlib.Extras            (Event)

import           Data.Map                            (member)

-- | 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 :: X ()
debugStack =  X String
debugStackString X String -> (String -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace

-- | 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 :: X ()
debugStackFull =  X String
debugStackFullString X String -> (String -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace

-- | 'debugStack' packaged as a 'logHook'. (Currently this is identical.)
debugStackLogHook :: X ()
debugStackLogHook :: X ()
debugStackLogHook =  X ()
debugStack

-- | 'debugStackFull packaged as a 'logHook'. (Currently this is identical.)
debugStackFullLogHook :: X ()
debugStackFullLogHook :: X ()
debugStackFullLogHook =  X ()
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 :: Event -> X All
debugStackEventHook Event
_ =  X ()
debugStack X () -> X All -> X All
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

-- | '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 :: Event -> X All
debugStackFullEventHook Event
_ =  X ()
debugStackFull X () -> X All -> X All
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)

-- | Dump the state of the current workspace in the 'StackSet' as a multiline 'String'.
debugStackString :: X String
debugStackString :: X String
debugStackString =  (WindowSet -> X String) -> X String
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X String) -> X String)
-> (WindowSet -> X String) -> X String
forall a b. (a -> b) -> a -> b
$ Workspace String (Layout Window) Window -> X String
debugStackWs (Workspace String (Layout Window) Window -> X String)
-> (WindowSet -> Workspace String (Layout Window) Window)
-> WindowSet
-> X String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Window) Window ScreenId ScreenDetail
-> Workspace String (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> Workspace String (Layout Window) Window)
-> (WindowSet
    -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> WindowSet
-> Workspace String (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
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 :: X String
debugStackFullString =  (WindowSet -> X String) -> X String
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X String) -> X String)
-> (WindowSet -> X String) -> X String
forall a b. (a -> b) -> a -> b
$ ([String] -> String) -> X [String] -> X String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n") (X [String] -> X String)
-> (WindowSet -> X [String]) -> WindowSet -> X String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Workspace String (Layout Window) Window -> X String)
-> [Workspace String (Layout Window) Window] -> X [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Workspace String (Layout Window) Window -> X String
debugStackWs ([Workspace String (Layout Window) Window] -> X [String])
-> (WindowSet -> [Workspace String (Layout Window) Window])
-> WindowSet
-> X [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> [Workspace String (Layout Window) Window]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
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 :: Workspace String (Layout Window) Window -> X String
debugStackWs Workspace String (Layout Window) Window
w =  (WindowSet -> X String) -> X String
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X String) -> X String)
-> (WindowSet -> X String) -> X String
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws -> do
  let cur :: String
cur = if String
wt String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== WindowSet -> String
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
ws then String
" (current)" else String
""
      wt :: String
wt  = Workspace String (Layout Window) Window -> String
forall i l a. Workspace i l a -> i
W.tag Workspace String (Layout Window) Window
w
  [String]
s <- WindowSet -> [Window] -> X [String]
emit WindowSet
ws ([Window] -> X [String]) -> [Window] -> X [String]
forall a b. (a -> b) -> a -> b
$ Maybe (Stack Window) -> [Window]
forall a. Maybe (Stack a) -> [a]
W.integrate' (Maybe (Stack Window) -> [Window])
-> (Workspace String (Layout Window) Window
    -> Maybe (Stack Window))
-> Workspace String (Layout Window) Window
-> [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace String (Layout Window) Window -> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace String (Layout Window) Window -> [Window])
-> Workspace String (Layout Window) Window -> [Window]
forall a b. (a -> b) -> a -> b
$ Workspace String (Layout Window) Window
w
  String -> X String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> X String) -> String -> X String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String
"Workspace " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
wt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cur)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
s
  where
    emit       :: WindowSet -> [Window] -> X [String]
    emit :: WindowSet -> [Window] -> X [String]
emit WindowSet
_  [] =  [String] -> X [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"    -empty workspace-"]
    emit WindowSet
ww [Window]
ws = do
      (WindowSet
_,[String]
ss) <- ((WindowSet, [String]) -> Window -> X (WindowSet, [String]))
-> (WindowSet, [String]) -> [Window] -> X (WindowSet, [String])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (WindowSet, [String]) -> Window -> X (WindowSet, [String])
emit' (WindowSet
ww,[]) [Window]
ws
      [String] -> X [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
ss

    emit' :: (WindowSet,[String])
          -> Window
          -> X (WindowSet,[String])
    emit' :: (WindowSet, [String]) -> Window -> X (WindowSet, [String])
emit' (WindowSet
ws,[String]
a) Window
w' = do
      let focus :: Char
focus = if Window -> Maybe Window
forall a. a -> Maybe a
Just Window
w' Maybe Window -> Maybe Window -> Bool
forall a. Eq a => a -> a -> Bool
== WindowSet -> Maybe Window
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek WindowSet
ws then Char
'*' else Char
' '
          float :: Char
float = if Window
w' Window -> Map Window RationalRect -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`member` WindowSet -> Map Window RationalRect
forall i l a sid sd. StackSet i l a sid sd -> Map a RationalRect
W.floating WindowSet
ws then Char
'^' else Char
' '
      String
s <- Window -> X String
debugWindow Window
w'
      (WindowSet, [String]) -> X (WindowSet, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (WindowSet
ws,(Char
focusChar -> String -> String
forall a. a -> [a] -> [a]
:Char
floatChar -> String -> String
forall a. a -> [a] -> [a]
:String
s)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
a)