path: root/XMonad/Hooks/UrgencyHook.hs

{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeSynonymInstances, PatternGuards, DeriveDataTypeable,
  FlexibleInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.UrgencyHook
-- Copyright   :  Devin Mullins <me@twifkak.com>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Devin Mullins <me@twifkak.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- UrgencyHook lets you configure an action to occur when a window demands
-- your attention. (In traditional WMs, this takes the form of \"flashing\"
-- on your \"taskbar.\" Blech.)
--
-----------------------------------------------------------------------------

module XMonad.Hooks.UrgencyHook (
                                 -- * Usage
                                 -- $usage

                                 -- ** Pop up a temporary dzen
                                 -- $temporary

                                 -- ** Highlight in existing dzen
                                 -- $existing

                                 -- ** Useful keybinding
                                 -- $keybinding

                                 -- ** Note
                                 -- $note

                                 -- * Troubleshooting
                                 -- $troubleshooting

                                 -- * Example: Setting up irssi + rxvt-unicode
                                 -- $example

                                 -- ** Configuring irssi
                                 -- $irssi

                                 -- ** Configuring screen
                                 -- $screen

                                 -- ** Configuring rxvt-unicode
                                 -- $urxvt

                                 -- ** Configuring xmonad
                                 -- $xmonad

                                 -- * Stuff for your config file:
                                 withUrgencyHook, withUrgencyHookC,
                                 UrgencyConfig(..), urgencyConfig,
                                 SuppressWhen(..), RemindWhen(..),
                                 focusUrgent, clearUrgents,
                                 dzenUrgencyHook,
                                 DzenUrgencyHook(..),
                                 NoUrgencyHook(..),
                                 BorderUrgencyHook(..),
                                 FocusHook(..),
                                 filterUrgencyHook,
                                 minutes, seconds,
                                 -- * Stuff for developers:
                                 readUrgents, withUrgents,
                                 StdoutUrgencyHook(..),
                                 SpawnUrgencyHook(..),
                                 UrgencyHook(urgencyHook),
                                 Interval,
                                 borderUrgencyHook, focusHook, spawnUrgencyHook, stdoutUrgencyHook
                                 ) where

import XMonad
import qualified XMonad.StackSet as W

import XMonad.Util.Dzen (dzenWithArgs, seconds)
import qualified XMonad.Util.ExtensibleState as XS
import XMonad.Util.NamedWindows (getName)
import XMonad.Util.Timer (TimerId, startTimer, handleTimer)
import XMonad.Util.WindowProperties (getProp32)

import Control.Applicative ((<$>))
import Control.Monad (when)
import Data.Bits (testBit)
import Data.List (delete, (\\))
import Data.Maybe (listToMaybe, maybeToList, fromMaybe)
import qualified Data.Set as S
import System.IO (hPutStrLn, stderr)
import Foreign.C.Types (CLong)

-- $usage
--
-- To wire this up, first add:
--
-- > import XMonad.Hooks.UrgencyHook
--
-- to your import list in your config file. Now, you have a decision to make:
-- When a window deems itself urgent, do you want to pop up a temporary dzen
-- bar telling you so, or do you have an existing dzen wherein you would like to
-- highlight urgent workspaces?

-- $temporary
--
-- Enable your urgency hook by wrapping your config record in a call to
-- 'withUrgencyHook'. For example:
--
-- > main = xmonad $ withUrgencyHook dzenUrgencyHook { args = ["-bg", "darkgreen", "-xs", "1"] }
-- >               $ def
--
-- This will pop up a dzen bar for five seconds telling you you've got an
-- urgent window.

-- $existing
--
-- In order for xmonad to track urgent windows, you must install an urgency hook.
-- You can use the above 'dzenUrgencyHook', or if you're not interested in the
-- extra popup, install NoUrgencyHook, as so:
--
-- > main = xmonad $ withUrgencyHook NoUrgencyHook
-- >               $ def
--
-- Now, your "XMonad.Hooks.DynamicLog" must be set up to display the urgent
-- windows. If you're using the 'dzen' or 'dzenPP' functions from that module,
-- then you should be good. Otherwise, you want to figure out how to set
-- 'ppUrgent'.

-- $keybinding
--
-- You can set up a keybinding to jump to the window that was recently marked
-- urgent. See an example at 'focusUrgent'.

-- $note
-- Note: UrgencyHook installs itself as a LayoutModifier, so if you modify your
-- urgency hook and restart xmonad, you may need to rejigger your layout by
-- hitting mod-shift-space.

-- $troubleshooting
--
-- There are three steps to get right:
--
-- 1. The X client must set the UrgencyHint flag. How to configure this
--    depends on the application. If you're using a terminal app, this is in
--    two parts:
--
--      * The console app must send a ^G (bell). In bash, a helpful trick is
--        @sleep 1; echo -e \'\\a\'@.
--
--      * The terminal must convert the bell into UrgencyHint.
--
-- 2. XMonad must be configured to notice UrgencyHints. If you've added
--    withUrgencyHook, you may need to hit mod-shift-space to reset the layout.
--
-- 3. The dzen must run when told. Run @dzen2 -help@ and make sure that it
--    supports all of the arguments you told DzenUrgencyHook to pass it. Also,
--    set up a keybinding to the 'dzen' action in "XMonad.Util.Dzen" to test
--    if that works.
--
-- As best you can, try to isolate which one(s) of those is failing.

-- $example
--
-- This is a commonly asked example. By default, the window doesn't get flagged
-- urgent when somebody messages you in irssi. You will have to configure some
-- things. If you're using different tools than this, your mileage will almost
-- certainly vary. (For example, in Xchat2, it's just a simple checkbox.)

-- $irssi
-- @Irssi@ is not an X11 app, so it can't set the @UrgencyHint@ flag on @XWMHints@.
-- However, on all console applications is bestown the greatest of all notification
-- systems: the bell. That's right, Ctrl+G, ASCII code 7, @echo -e '\a'@, your
-- friend, the bell. To configure @irssi@ to send a bell when you receive a message:
--
-- > /set beep_msg_level MSGS NOTICES INVITES DCC DCCMSGS HILIGHT
--
-- Consult your local @irssi@ documentation for more detail.

-- $screen
-- A common way to run @irssi@ is within the lovable giant, @screen@. Some distros
-- (e.g. Ubuntu) like to configure @screen@ to trample on your poor console
-- applications -- in particular, to turn bell characters into evil, smelly
-- \"visual bells.\" To turn this off, add:
--
-- > vbell off # or remove the existing 'vbell on' line
--
-- to your .screenrc, or hit @C-a C-g@ within a running @screen@ session for an
-- immediate but temporary fix.

-- $urxvt
-- Rubber, meet road. Urxvt is the gateway between console apps and X11. To tell
-- urxvt to set an @UrgencyHint@ when it receives a bell character, first, have
-- an urxvt version 8.3 or newer, and second, set the following in your
-- @.Xdefaults@:
--
-- > urxvt.urgentOnBell: true
--
-- Depending on your setup, you may need to @xrdb@ that.

-- $xmonad
-- Hopefully you already read the section on how to configure xmonad. If not,
-- hopefully you know where to find it.

-- | This is the method to enable an urgency hook. It uses the default
-- 'urgencyConfig' to control behavior. To change this, use 'withUrgencyHookC'
-- instead.
withUrgencyHook :: (LayoutClass l Window, UrgencyHook h) =>
                   h -> XConfig l -> XConfig l
withUrgencyHook hook conf = withUrgencyHookC hook urgencyConfig conf

-- | This lets you modify the defaults set in 'urgencyConfig'. An example:
--
-- > withUrgencyHookC dzenUrgencyHook { ... } urgencyConfig { suppressWhen = Focused }
--
-- (Don't type the @...@, you dolt.) See 'UrgencyConfig' for details on configuration.
withUrgencyHookC :: (LayoutClass l Window, UrgencyHook h) =>
                    h -> UrgencyConfig -> XConfig l -> XConfig l
withUrgencyHookC hook urgConf conf = conf {
        handleEventHook = \e -> handleEvent (WithUrgencyHook hook urgConf) e >> handleEventHook conf e,
        logHook = cleanupUrgents (suppressWhen urgConf) >> logHook conf
    }

data Urgents = Urgents { fromUrgents :: [Window] } deriving (Read,Show,Typeable)

onUrgents :: ([Window] -> [Window]) -> Urgents -> Urgents
onUrgents f = Urgents . f . fromUrgents

instance ExtensionClass Urgents where
    initialValue = Urgents []
    extensionType = PersistentExtension

-- | Global configuration, applied to all types of 'UrgencyHook'. See
-- 'urgencyConfig' for the defaults.
data UrgencyConfig = UrgencyConfig
    { suppressWhen :: SuppressWhen -- ^ when to trigger the urgency hook
    , remindWhen   :: RemindWhen   -- ^ when to re-trigger the urgency hook
    } deriving (Read, Show)

-- | A set of choices as to /when/ you should (or rather, shouldn't) be notified of an urgent window.
-- The default is 'Visible'. Prefix each of the following with \"don't bug me when\":
data SuppressWhen = Visible  -- ^ the window is currently visible
                  | OnScreen -- ^ the window is on the currently focused physical screen
                  | Focused  -- ^ the window is currently focused
                  | Never    -- ^ ... aww, heck, go ahead and bug me, just in case.
                  deriving (Read, Show)

-- | A set of choices as to when you want to be re-notified of an urgent
-- window. Perhaps you focused on something and you miss the dzen popup bar. Or
-- you're AFK. Or you feel the need to be more distracted. I don't care.
--
-- The interval arguments are in seconds. See the 'minutes' helper.
data RemindWhen = Dont                    -- ^ triggering once is enough
                | Repeatedly Int Interval -- ^ repeat <arg1> times every <arg2> seconds
                | Every Interval          -- ^ repeat every <arg1> until the urgency hint is cleared
                deriving (Read, Show)

-- | A prettified way of multiplying by 60. Use like: @(5 `minutes`)@.
minutes :: Rational -> Rational
minutes secs = secs * 60

-- | The default 'UrgencyConfig'. suppressWhen = Visible, remindWhen = Dont.
-- Use a variation of this in your config just as you use a variation of
-- 'def' for your xmonad definition.
urgencyConfig :: UrgencyConfig
urgencyConfig = UrgencyConfig { suppressWhen = Visible, remindWhen = Dont }

-- | Focuses the most recently urgent window. Good for what ails ya -- I mean, your keybindings.
-- Example keybinding:
--
-- > , ((modm              , xK_BackSpace), focusUrgent)
focusUrgent :: X ()
focusUrgent = withUrgents $ flip whenJust (windows . W.focusWindow) . listToMaybe

-- | Just makes the urgents go away.
-- Example keybinding:
--
-- > , ((modm .|. shiftMask, xK_BackSpace), clearUrgents)
clearUrgents :: X ()
clearUrgents = adjustUrgents (const []) >> adjustReminders (const [])

-- | X action that returns a list of currently urgent windows. You might use
-- it, or 'withUrgents', in your custom logHook, to display the workspaces that
-- contain urgent windows.
readUrgents :: X [Window]
readUrgents = XS.gets fromUrgents

-- | An HOF version of 'readUrgents', for those who prefer that sort of thing.
withUrgents :: ([Window] -> X a) -> X a
withUrgents f = readUrgents >>= f

adjustUrgents :: ([Window] -> [Window]) -> X ()
adjustUrgents = XS.modify . onUrgents

type Interval = Rational

-- | An urgency reminder, as reified for 'RemindWhen'.
-- The last value is the countdown number, for 'Repeatedly'.
data Reminder = Reminder { timer     :: TimerId
                         , window    :: Window
                         , interval  :: Interval
                         , remaining :: Maybe Int
                         } deriving (Show,Read,Eq,Typeable)

instance ExtensionClass [Reminder] where
    initialValue = []
    extensionType = PersistentExtension

-- | Stores the list of urgency reminders.

readReminders :: X [Reminder]
readReminders = XS.get

adjustReminders :: ([Reminder] -> [Reminder]) -> X ()
adjustReminders = XS.modify


data WithUrgencyHook h = WithUrgencyHook h UrgencyConfig
    deriving (Read, Show)

-- | Change the _NET_WM_STATE property by applying a function to the list of atoms.
changeNetWMState :: Display -> Window -> ([CLong] -> [CLong]) -> X ()
changeNetWMState dpy w f = do
   wmstate <- getAtom "_NET_WM_STATE"
   wstate  <- fromMaybe [] `fmap` getProp32 wmstate w
   let ptype = 4 -- atom property type for changeProperty
   io $ changeProperty32 dpy w wmstate ptype propModeReplace (f wstate)
   return ()

-- | Add an atom to the _NET_WM_STATE property.
addNetWMState :: Display -> Window -> Atom -> X ()
addNetWMState dpy w atom = changeNetWMState dpy w $ ((fromIntegral atom):)

-- | Remove an atom from the _NET_WM_STATE property.
removeNetWMState :: Display -> Window -> Atom -> X ()
removeNetWMState dpy w atom = changeNetWMState dpy w $ delete (fromIntegral atom)

-- | Get the _NET_WM_STATE propertly as a [CLong]
getNetWMState :: Window -> X [CLong]
getNetWMState w = do
    a_wmstate <- getAtom "_NET_WM_STATE"
    fromMaybe [] `fmap` getProp32 a_wmstate w
   

-- The Non-ICCCM Manifesto:
-- Note: Some non-standard choices have been made in this implementation to
-- account for the fact that things are different in a tiling window manager:
--   1. In normal window managers, windows may overlap, so clients wait for focus to
--      be set before urgency is cleared. In a tiling WM, it's sufficient to be able
--      see the window, since we know that means you can see it completely.
--   2. The urgentOnBell setting in rxvt-unicode sets urgency even when the window
--      has focus, and won't clear until it loses and regains focus. This is stupid.
-- In order to account for these quirks, we track the list of urgent windows
-- ourselves, allowing us to clear urgency when a window is visible, and not to
-- set urgency if a window is visible. If you have a better idea, please, let us
-- know!
handleEvent :: UrgencyHook h => WithUrgencyHook h -> Event -> X ()
handleEvent wuh event =
    case event of
     -- WM_HINTS urgency flag
      PropertyEvent { ev_event_type = t, ev_atom = a, ev_window = w } -> do
          when (t == propertyNotify && a == wM_HINTS) $ withDisplay $ \dpy -> do
              WMHints { wmh_flags = flags } <- io $ getWMHints dpy w
              if (testBit flags urgencyHintBit) then markUrgent w else markNotUrgent w
      -- Window destroyed
      DestroyWindowEvent {ev_window = w} ->
          markNotUrgent w
      -- _NET_WM_STATE_DEMANDS_ATTENTION requested by client
      ClientMessageEvent {ev_event_display = dpy, ev_window = w, ev_message_type = t, ev_data = action:atoms} -> do
          a_wmstate <- getAtom "_NET_WM_STATE"
          a_da      <- getAtom "_NET_WM_STATE_DEMANDS_ATTENTION"
          wstate    <- getNetWMState w
          let demandsAttention = fromIntegral a_da `elem` wstate
              remove = 0
              add    = 1
              toggle = 2
          when (t == a_wmstate && fromIntegral a_da `elem` atoms) $ do
            when (action == add || (action == toggle && not demandsAttention)) $ do
              markUrgent w
              addNetWMState dpy w a_da
            when (action == remove || (action == toggle && demandsAttention)) $ do
              markNotUrgent w
              removeNetWMState dpy w a_da
      _ ->
          mapM_ handleReminder =<< readReminders
      where handleReminder reminder = handleTimer (timer reminder) event $ reminderHook wuh reminder
            markUrgent w = do
                adjustUrgents (\ws -> if elem w ws then ws else w : ws)
                callUrgencyHook wuh w
                userCodeDef () =<< asks (logHook . config)
            markNotUrgent w = do
                adjustUrgents (delete w) >> adjustReminders (filter $ (w /=) . window)
                userCodeDef () =<< asks (logHook . config)

callUrgencyHook :: UrgencyHook h => WithUrgencyHook h -> Window -> X ()
callUrgencyHook (WithUrgencyHook hook UrgencyConfig { suppressWhen = sw, remindWhen = rw }) w =
    whenX (not <$> shouldSuppress sw w) $ do
        userCodeDef () $ urgencyHook hook w
        case rw of
            Repeatedly times int -> addReminder w int $ Just times
            Every int            -> addReminder w int Nothing
            Dont                 -> return ()

addReminder :: Window -> Rational -> Maybe Int -> X ()
addReminder w int times = do
    timerId <- startTimer int
    let reminder = Reminder timerId w int times
    adjustReminders (\rs -> if w `elem` map window rs then rs else reminder : rs)

reminderHook :: UrgencyHook h => WithUrgencyHook h -> Reminder -> X (Maybe a)
reminderHook (WithUrgencyHook hook _) reminder = do
    case remaining reminder of
        Just x | x > 0 -> remind $ Just (x - 1)
        Just _         -> adjustReminders $ delete reminder
        Nothing        -> remind Nothing
    return Nothing
  where remind remaining' = do userCode $ urgencyHook hook (window reminder)
                               adjustReminders $ delete reminder
                               addReminder (window reminder) (interval reminder) remaining'

shouldSuppress :: SuppressWhen -> Window -> X Bool
shouldSuppress sw w = elem w <$> suppressibleWindows sw

cleanupUrgents :: SuppressWhen -> X ()
cleanupUrgents sw = do
    sw' <- suppressibleWindows sw
    a_da <- getAtom "_NET_WM_STATE_DEMANDS_ATTENTION"
    dpy <- withDisplay (\dpy -> return dpy)
    mapM_ (\w -> removeNetWMState dpy w a_da) sw'
    adjustUrgents (\\ sw') >> adjustReminders (filter $ ((`notElem` sw') . window))

suppressibleWindows :: SuppressWhen -> X [Window]
suppressibleWindows Visible  = gets $ S.toList . mapped
suppressibleWindows OnScreen = gets $ W.index . windowset
suppressibleWindows Focused  = gets $ maybeToList . W.peek . windowset
suppressibleWindows Never    = return []

--------------------------------------------------------------------------------
-- Urgency Hooks

-- | The class definition, and some pre-defined instances.

class UrgencyHook h where
    urgencyHook :: h -> Window -> X ()

instance UrgencyHook (Window -> X ()) where
    urgencyHook = id

data NoUrgencyHook = NoUrgencyHook deriving (Read, Show)

instance UrgencyHook NoUrgencyHook where
    urgencyHook _ _ = return ()

-- | Your set of options for configuring a dzenUrgencyHook.
data DzenUrgencyHook = DzenUrgencyHook {
                         duration :: Int, -- ^ number of microseconds to display the dzen
                                          --   (hence, you'll probably want to use 'seconds')
                         args :: [String] -- ^ list of extra args (as 'String's) to pass to dzen
                       }
    deriving (Read, Show)

instance UrgencyHook DzenUrgencyHook where
    urgencyHook DzenUrgencyHook { duration = d, args = a } w = do
        name <- getName w
        ws <- gets windowset
        whenJust (W.findTag w ws) (flash name)
      where flash name index =
                  dzenWithArgs (show name ++ " requests your attention on workspace " ++ index) a d

{- | A hook which will automatically send you to anything which sets the urgent
  flag (as opposed to printing some sort of message. You would use this as
  usual, eg.

  > withUrgencyHook FocusHook $ myconfig { ...
-}
focusHook :: Window -> X ()
focusHook = urgencyHook FocusHook
data FocusHook = FocusHook deriving (Read, Show)

instance UrgencyHook FocusHook where
    urgencyHook _ _ = focusUrgent

-- | A hook that sets the border color of an urgent window.  The color
--   will remain until the next time the window gains or loses focus, at
--   which point the standard border color from the XConfig will be applied.
--   You may want to use suppressWhen = Never with this:
--
--   > withUrgencyHookC BorderUrgencyHook { urgencyBorderColor = "#ff0000" } urgencyConfig { suppressWhen = Never } ...
--
--   (This should be @urgentBorderColor@ but that breaks "XMonad.Layout.Decoration".
--   @borderColor@ breaks anyone using 'XPConfig' from "XMonad.Prompt".  We need to
--   think a bit more about namespacing issues, maybe.)

borderUrgencyHook :: String -> Window -> X ()
borderUrgencyHook = urgencyHook . BorderUrgencyHook
data BorderUrgencyHook = BorderUrgencyHook { urgencyBorderColor :: !String }
                       deriving (Read, Show)

instance UrgencyHook BorderUrgencyHook where
  urgencyHook BorderUrgencyHook { urgencyBorderColor = cs } w =
    withDisplay $ \dpy -> io $ do
      c' <- initColor dpy cs
      case c' of
        Just c -> setWindowBorder dpy w c
        _      -> hPutStrLn stderr $ concat ["Warning: bad urgentBorderColor "
                                            ,show cs
                                            ," in BorderUrgencyHook"
                                            ]

-- | Flashes when a window requests your attention and you can't see it.
-- Defaults to a duration of five seconds, and no extra args to dzen.
-- See 'DzenUrgencyHook'.
dzenUrgencyHook :: DzenUrgencyHook
dzenUrgencyHook = DzenUrgencyHook { duration = seconds 5, args = [] }

-- | Spawn a commandline thing, appending the window id to the prefix string
-- you provide. (Make sure to add a space if you need it.) Do your crazy
-- xcompmgr thing.
spawnUrgencyHook :: String -> Window -> X ()
spawnUrgencyHook = urgencyHook . SpawnUrgencyHook
newtype SpawnUrgencyHook = SpawnUrgencyHook String deriving (Read, Show)

instance UrgencyHook SpawnUrgencyHook where
    urgencyHook (SpawnUrgencyHook prefix) w = spawn $ prefix ++ show w

-- | For debugging purposes, really.
stdoutUrgencyHook :: Window -> X ()
stdoutUrgencyHook = urgencyHook StdoutUrgencyHook
data StdoutUrgencyHook = StdoutUrgencyHook deriving (Read, Show)

instance UrgencyHook StdoutUrgencyHook where
    urgencyHook    _ w = io $ putStrLn $ "Urgent: " ++ show w

-- | urgencyhook such that windows on certain workspaces
-- never get urgency set.
--
-- Useful for scratchpad workspaces perhaps:
--
-- > main = xmonad (withUrgencyHook (filterUrgencyHook ["NSP", "SP"]) defaultConfig)
filterUrgencyHook :: [WorkspaceId] -> Window -> X ()
filterUrgencyHook skips w = do
    ws <- gets windowset
    case W.findTag w ws of
        Just tag -> when (tag `elem` skips)
                        $ adjustUrgents (delete w)
        _ -> return ()