-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.ManageDebug
-- Description :  A manageHook and associated logHook for debugging "ManageHooks".
-- Copyright   :  (c) Brandon S Allbery KF8NH, 2014
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  allbery.b@gmail.com
-- Stability   :  unstable
-- Portability :  not portable
--
-- A @manageHook@ and associated @logHook@ for debugging 'ManageHook's.
-- Simplest usage: wrap your xmonad config in the @debugManageHook@ combinator.
-- Or use @debugManageHookOn@ for a triggerable version, specifying the
-- triggering key sequence in 'XMonad.Util.EZConfig' syntax. Or use the
-- individual hooks in whatever way you see fit.
--
-----------------------------------------------------------------------------
--
--

module XMonad.Hooks.ManageDebug (debugManageHook
                                ,debugManageHookOn
                                ,manageDebug
                                ,maybeManageDebug
                                ,manageDebugLogHook
                                ,debugNextManagedWindow
                                ) where

import           XMonad
import           XMonad.Prelude (when)
import           XMonad.Hooks.DebugStack
import           XMonad.Util.DebugWindow
import           XMonad.Util.EZConfig
import qualified XMonad.Util.ExtensibleState                                                 as XS

-- persistent state for manageHook debugging to trigger logHook debugging
newtype ManageStackDebug = MSD (Bool,Bool)
instance ExtensionClass ManageStackDebug where
  initialValue :: ManageStackDebug
initialValue = (Bool, Bool) -> ManageStackDebug
MSD (Bool
False,Bool
False)

-- | A combinator to add full 'ManageHook' debugging in a single operation.
debugManageHook :: XConfig l -> XConfig l
debugManageHook :: XConfig l -> XConfig l
debugManageHook XConfig l
cf = XConfig l
cf {logHook :: X ()
logHook    = X ()
manageDebugLogHook X () -> X () -> X ()
forall m. Monoid m => m -> m -> m
<+> XConfig l -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook    XConfig l
cf
                        ,manageHook :: ManageHook
manageHook = ManageHook
manageDebug        ManageHook -> ManageHook -> ManageHook
forall m. Monoid m => m -> m -> m
<+> XConfig l -> ManageHook
forall (l :: * -> *). XConfig l -> ManageHook
manageHook XConfig l
cf
                        }

-- | A combinator to add triggerable 'ManageHook' debugging in a single operation.
--   Specify a key sequence as a string in 'XMonad.Util.EZConfig' syntax; press
--   this key before opening the window to get just that logged.
debugManageHookOn :: String -> XConfig l -> XConfig l
debugManageHookOn :: String -> XConfig l -> XConfig l
debugManageHookOn String
key XConfig l
cf = XConfig l
cf {logHook :: X ()
logHook    = X ()
manageDebugLogHook X () -> X () -> X ()
forall m. Monoid m => m -> m -> m
<+> XConfig l -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook    XConfig l
cf
                              ,manageHook :: ManageHook
manageHook = ManageHook
maybeManageDebug   ManageHook -> ManageHook -> ManageHook
forall m. Monoid m => m -> m -> m
<+> XConfig l -> ManageHook
forall (l :: * -> *). XConfig l -> ManageHook
manageHook XConfig l
cf
                              }
                           XConfig l -> [(String, X ())] -> XConfig l
forall (l :: * -> *). XConfig l -> [(String, X ())] -> XConfig l
`additionalKeysP`
                           [(String
key,X ()
debugNextManagedWindow)]

-- | Place this at the start of a 'ManageHook', or possibly other places for a
--   more limited view. It will show the current 'StackSet' state and the new
--   window, and set a flag so that @manageDebugLogHook@ will display the
--   final 'StackSet' state.
--
--   Note that the initial state shows only the current workspace; the final
--   one shows all workspaces, since your 'ManageHook' might use e.g. 'doShift',
manageDebug :: ManageHook
manageDebug :: ManageHook
manageDebug = do
  Window
w <- Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask
  X () -> Query ()
forall a. X a -> Query a
liftX (X () -> Query ()) -> X () -> Query ()
forall a b. (a -> b) -> a -> b
$ do
    String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace String
"== manageHook; current stack =="
    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
    String
ws <- Window -> X String
debugWindow Window
w
    String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace (String -> X ()) -> String -> X ()
forall a b. (a -> b) -> a -> b
$ String
"new:\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ws
    (ManageStackDebug -> ManageStackDebug) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((ManageStackDebug -> ManageStackDebug) -> X ())
-> (ManageStackDebug -> ManageStackDebug) -> X ()
forall a b. (a -> b) -> a -> b
$ \(MSD (Bool
_,Bool
key)) -> (Bool, Bool) -> ManageStackDebug
MSD (Bool
True,Bool
key)
  ManageHook
forall m. Monoid m => m
idHook

-- | @manageDebug@ only if the user requested it with @debugNextManagedWindow@.
maybeManageDebug :: ManageHook
maybeManageDebug :: ManageHook
maybeManageDebug = do
  Bool
go <- X Bool -> Query Bool
forall a. X a -> Query a
liftX (X Bool -> Query Bool) -> X Bool -> Query Bool
forall a b. (a -> b) -> a -> b
$ do
    MSD (Bool
log_,Bool
go') <- X ManageStackDebug
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    ManageStackDebug -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (ManageStackDebug -> X ()) -> ManageStackDebug -> X ()
forall a b. (a -> b) -> a -> b
$ (Bool, Bool) -> ManageStackDebug
MSD (Bool
log_,Bool
False)
    Bool -> X Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
go'
  if Bool
go then ManageHook
manageDebug else ManageHook
forall m. Monoid m => m
idHook

-- | If @manageDebug@ has set the debug-stack flag, show the stack.
manageDebugLogHook :: X ()
manageDebugLogHook :: X ()
manageDebugLogHook = do
                       MSD (Bool
go,Bool
key) <- X ManageStackDebug
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
                       Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
go (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
                         String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
trace String
"== manageHook; final stack =="
                         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
                         ManageStackDebug -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (ManageStackDebug -> X ()) -> ManageStackDebug -> X ()
forall a b. (a -> b) -> a -> b
$ (Bool, Bool) -> ManageStackDebug
MSD (Bool
False,Bool
key)
                       X ()
forall m. Monoid m => m
idHook

-- | Request that the next window to be managed be @manageDebug@-ed. This can
--   be used anywhere an X action can, such as key bindings, mouse bindings
--   (presumably with 'const'), 'startupHook', etc.
debugNextManagedWindow :: X ()
debugNextManagedWindow :: X ()
debugNextManagedWindow = (ManageStackDebug -> ManageStackDebug) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((ManageStackDebug -> ManageStackDebug) -> X ())
-> (ManageStackDebug -> ManageStackDebug) -> X ()
forall a b. (a -> b) -> a -> b
$ \(MSD (Bool
log_,Bool
_)) -> (Bool, Bool) -> ManageStackDebug
MSD (Bool
log_,Bool
True)