-----------------------------------------------------------------------------
-- |
-- 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
                                ,manageDebug'
                                ,maybeManageDebug
                                ,manageDebugLogHook
                                ,debugNextManagedWindow
                                ) where

import           XMonad
import           XMonad.Hooks.DebugStack
import           XMonad.Util.DebugWindow
import           XMonad.Util.EZConfig
import qualified XMonad.Util.ExtensibleState as XS

import           Control.Monad       (when)
import           System.IO
import           System.Process

-- state for manageHook debugging to trigger logHook debugging
data MSDFinal = DoLogHook Handle Bool | SkipLogHook deriving Int -> MSDFinal -> ShowS
[MSDFinal] -> ShowS
MSDFinal -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MSDFinal] -> ShowS
$cshowList :: [MSDFinal] -> ShowS
show :: MSDFinal -> String
$cshow :: MSDFinal -> String
showsPrec :: Int -> MSDFinal -> ShowS
$cshowsPrec :: Int -> MSDFinal -> ShowS
Show
data MSDTrigger = MSDActivated Handle Bool | MSDInactive deriving Int -> MSDTrigger -> ShowS
[MSDTrigger] -> ShowS
MSDTrigger -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MSDTrigger] -> ShowS
$cshowList :: [MSDTrigger] -> ShowS
show :: MSDTrigger -> String
$cshow :: MSDTrigger -> String
showsPrec :: Int -> MSDTrigger -> ShowS
$cshowsPrec :: Int -> MSDTrigger -> ShowS
Show
data ManageStackDebug = MSD MSDFinal MSDTrigger deriving Int -> ManageStackDebug -> ShowS
[ManageStackDebug] -> ShowS
ManageStackDebug -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ManageStackDebug] -> ShowS
$cshowList :: [ManageStackDebug] -> ShowS
show :: ManageStackDebug -> String
$cshow :: ManageStackDebug -> String
showsPrec :: Int -> ManageStackDebug -> ShowS
$cshowsPrec :: Int -> ManageStackDebug -> ShowS
Show
instance ExtensionClass ManageStackDebug where
  initialValue :: ManageStackDebug
initialValue = MSDFinal -> MSDTrigger -> ManageStackDebug
MSD MSDFinal
SkipLogHook MSDTrigger
MSDInactive

-- | A combinator to add full 'ManageHook' debugging in a single operation.
debugManageHook :: XConfig l -> XConfig l
debugManageHook :: forall (l :: * -> *). XConfig l -> XConfig l
debugManageHook XConfig l
cf = XConfig l
cf {logHook :: X ()
logHook    = X ()
manageDebugLogHook forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *). XConfig l -> X ()
logHook    XConfig l
cf
                        ,manageHook :: Query (Endo WindowSet)
manageHook = Query (Endo WindowSet)
manageDebug        forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *). XConfig l -> Query (Endo WindowSet)
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 :: forall (l :: * -> *). String -> XConfig l -> XConfig l
debugManageHookOn String
key XConfig l
cf = XConfig l
cf {logHook :: X ()
logHook    = X ()
manageDebugLogHook forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *). XConfig l -> X ()
logHook    XConfig l
cf
                              ,manageHook :: Query (Endo WindowSet)
manageHook = Query (Endo WindowSet)
maybeManageDebug   forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *). XConfig l -> Query (Endo WindowSet)
manageHook XConfig l
cf
                              }
                           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'.
--
--   This logs to 'stderr' because there's no way to pass it a message handle,
--   and to maintain backward compatibility. See @manageDebug'@ for an
--   alternative that accepts a 'Handle'.
manageDebug :: ManageHook
manageDebug :: Query (Endo WindowSet)
manageDebug = Handle -> Bool -> Query (Endo WindowSet)
manageDebug' Handle
stderr Bool
False

-- | @manageDebug@ to a 'Handle'. The flag specifies whether the 'Handle' should
--   be closed after logging. @debugNextManagedWindow@ uses this to log to
--   'xmessage', but it can be used to log to any chosen process or file.
--
--   Logging is incremental, so if your 'Handle' is to something that can show
--   output before the 'logHook' prints the final 'StackSet' and optionally
--   closes it, you can see it before it completes.
--
--   You should be careful to pass 'False' if you are logging to 'stdout' or
--   'stderr', and to pass 'True' if you are logging to a process. Also remember
--   that 'xmonad' subprocesses are auto-reaped, so don't try to wait for one.
manageDebug' :: Handle -> Bool -> ManageHook
manageDebug' :: Handle -> Bool -> Query (Endo WindowSet)
manageDebug' Handle
h Bool
cp = do
  Window
w <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall a. X a -> Query a
liftX forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
"\n== manageHook; current stack =="
    X String
debugStackString forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
h
    String
ws <- Window -> X String
debugWindow Window
w
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h forall a b. (a -> b) -> a -> b
$ String
"\nnew window:\n  " forall a. [a] -> [a] -> [a]
++ String
ws
    forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall a b. (a -> b) -> a -> b
$ \(MSD MSDFinal
_ MSDTrigger
go) -> MSDFinal -> MSDTrigger -> ManageStackDebug
MSD (Handle -> Bool -> MSDFinal
DoLogHook Handle
h Bool
cp) MSDTrigger
go
  forall m. Monoid m => m
idHook

-- | @manageDebug@ only if the user requested it with @debugNextManagedWindow@.
maybeManageDebug :: ManageHook
maybeManageDebug :: Query (Endo WindowSet)
maybeManageDebug = do
  MSDTrigger
go <- forall a. X a -> Query a
liftX forall a b. (a -> b) -> a -> b
$ do
    MSD MSDFinal
_ MSDTrigger
go' <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    -- leave it active, as we may manage multiple windows before the 'logHook'
    -- so we now deactivate it there
    forall (m :: * -> *) a. Monad m => a -> m a
return MSDTrigger
go'
  case MSDTrigger
go of
    MSDActivated Handle
h Bool
cp -> Handle -> Bool -> Query (Endo WindowSet)
manageDebug' Handle
h Bool
cp
    MSDTrigger
_                 -> forall m. Monoid m => m
idHook

-- | If @manageDebug'@ has set the debug-stack flag, show the stack.
manageDebugLogHook :: X ()
manageDebugLogHook :: X ()
manageDebugLogHook = do
                       MSD MSDFinal
log' MSDTrigger
_ <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
                       case MSDFinal
log' of
                         DoLogHook Handle
h Bool
cp -> do
                                            forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
"\n== manageHook; final stack =="
                                            X String
debugStackFullString forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
h
                                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cp forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
h
                                            -- see comment in maybeManageDebug
                                            forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ MSDFinal -> MSDTrigger -> ManageStackDebug
MSD MSDFinal
SkipLogHook MSDTrigger
MSDInactive
                         MSDFinal
_              -> 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. The output is sent to
--   '$XMONAD_XMESSAGE' or 'xmessage'.
debugNextManagedWindow :: X ()
debugNextManagedWindow :: X ()
debugNextManagedWindow = do
  let cpd :: CreateProcess
cpd = (String -> CreateProcess
shell String
"${XMONAD_XMESSAGE:-xmessage} \
                      \-file - \
                      \-default okay \
                      \-xrm '*international:true' \
                      \-xrm '*fontSet:-*-fixed-medium-r-normal-*-18-*-*-*-*-*-*-*,\
                                     \-*-fixed-*-*-*-*-18-*-*-*-*-*-*-*,\
                                     \-*-*-*-*-*-*-18-*-*-*-*-*-*-*'"){std_in :: StdStream
std_in = StdStream
CreatePipe}
  Maybe (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
hs <- forall a. X a -> X a -> X a
catchX (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cpd) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
  case Maybe (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
hs of
    Just (Just Handle
h, Maybe Handle
_, Maybe Handle
_, ProcessHandle
_) -> do
                                forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
                                forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall a b. (a -> b) -> a -> b
$ \(MSD MSDFinal
log' MSDTrigger
_) -> MSDFinal -> MSDTrigger -> ManageStackDebug
MSD MSDFinal
log' (Handle -> Bool -> MSDTrigger
MSDActivated Handle
h Bool
True)
    Maybe (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
_                      -> forall (m :: * -> *) a. Monad m => a -> m a
return ()