{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.UrgencyHook
-- Description :  Configure an action to occur when a window demands your attention.
-- 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

                                 -- * 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, filterUrgencyHook',
                                 minutes, seconds,
                                 askUrgent, doAskUrgent,
                                 -- * Stuff for developers:
                                 readUrgents, withUrgents, clearUrgents',
                                 StdoutUrgencyHook(..),
                                 SpawnUrgencyHook(..),
                                 UrgencyHook(urgencyHook),
                                 Interval,
                                 borderUrgencyHook, focusHook, spawnUrgencyHook, stdoutUrgencyHook
                                 ) where

import XMonad
import XMonad.Prelude (fi, delete, fromMaybe, listToMaybe, maybeToList, when, (\\))
import qualified XMonad.StackSet as W

import XMonad.Hooks.ManageHelpers (windowTag)
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 Data.Bits (testBit)
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.StatusBar.PP" must be set up to display the urgent
-- windows. If you're using the 'dzen' (from "XMonad.Hooks.DynamicLog") 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'.

-- $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 :: forall (l :: * -> *) h.
(LayoutClass l Atom, UrgencyHook h) =>
h -> XConfig l -> XConfig l
withUrgencyHook h
hook = h -> UrgencyConfig -> XConfig l -> XConfig l
forall (l :: * -> *) h.
(LayoutClass l Atom, UrgencyHook h) =>
h -> UrgencyConfig -> XConfig l -> XConfig l
withUrgencyHookC h
hook UrgencyConfig
forall a. Default a => a
def

-- | This lets you modify the defaults set in 'urgencyConfig'. An example:
--
-- > withUrgencyHookC dzenUrgencyHook { ... } def { 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 :: forall (l :: * -> *) h.
(LayoutClass l Atom, UrgencyHook h) =>
h -> UrgencyConfig -> XConfig l -> XConfig l
withUrgencyHookC h
hook UrgencyConfig
urgConf XConfig l
conf = XConfig l
conf {
        handleEventHook :: Event -> X All
handleEventHook = \Event
e -> WithUrgencyHook h -> Event -> X ()
forall h. UrgencyHook h => WithUrgencyHook h -> Event -> X ()
handleEvent (h -> UrgencyConfig -> WithUrgencyHook h
forall h. h -> UrgencyConfig -> WithUrgencyHook h
WithUrgencyHook h
hook UrgencyConfig
urgConf) Event
e X () -> X All -> X All
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XConfig l -> Event -> X All
forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig l
conf Event
e,
        logHook :: X ()
logHook = SuppressWhen -> X ()
cleanupUrgents (UrgencyConfig -> SuppressWhen
suppressWhen UrgencyConfig
urgConf) X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XConfig l -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook XConfig l
conf,
        startupHook :: X ()
startupHook = X ()
cleanupStaleUrgents X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XConfig l -> X ()
forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig l
conf
    }

newtype Urgents = Urgents { Urgents -> [Atom]
fromUrgents :: [Window] } deriving (ReadPrec [Urgents]
ReadPrec Urgents
Int -> ReadS Urgents
ReadS [Urgents]
(Int -> ReadS Urgents)
-> ReadS [Urgents]
-> ReadPrec Urgents
-> ReadPrec [Urgents]
-> Read Urgents
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Urgents]
$creadListPrec :: ReadPrec [Urgents]
readPrec :: ReadPrec Urgents
$creadPrec :: ReadPrec Urgents
readList :: ReadS [Urgents]
$creadList :: ReadS [Urgents]
readsPrec :: Int -> ReadS Urgents
$creadsPrec :: Int -> ReadS Urgents
Read,Int -> Urgents -> ShowS
[Urgents] -> ShowS
Urgents -> WorkspaceId
(Int -> Urgents -> ShowS)
-> (Urgents -> WorkspaceId) -> ([Urgents] -> ShowS) -> Show Urgents
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [Urgents] -> ShowS
$cshowList :: [Urgents] -> ShowS
show :: Urgents -> WorkspaceId
$cshow :: Urgents -> WorkspaceId
showsPrec :: Int -> Urgents -> ShowS
$cshowsPrec :: Int -> Urgents -> ShowS
Show)

onUrgents :: ([Window] -> [Window]) -> Urgents -> Urgents
onUrgents :: ([Atom] -> [Atom]) -> Urgents -> Urgents
onUrgents [Atom] -> [Atom]
f = [Atom] -> Urgents
Urgents ([Atom] -> Urgents) -> (Urgents -> [Atom]) -> Urgents -> Urgents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Atom] -> [Atom]
f ([Atom] -> [Atom]) -> (Urgents -> [Atom]) -> Urgents -> [Atom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Urgents -> [Atom]
fromUrgents

instance ExtensionClass Urgents where
    initialValue :: Urgents
initialValue = [Atom] -> Urgents
Urgents []
    extensionType :: Urgents -> StateExtension
extensionType = Urgents -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

-- | Global configuration, applied to all types of 'UrgencyHook'. See
-- 'urgencyConfig' for the defaults.
data UrgencyConfig = UrgencyConfig
    { UrgencyConfig -> SuppressWhen
suppressWhen :: SuppressWhen -- ^ when to trigger the urgency hook
    , UrgencyConfig -> RemindWhen
remindWhen   :: RemindWhen   -- ^ when to re-trigger the urgency hook
    } deriving (ReadPrec [UrgencyConfig]
ReadPrec UrgencyConfig
Int -> ReadS UrgencyConfig
ReadS [UrgencyConfig]
(Int -> ReadS UrgencyConfig)
-> ReadS [UrgencyConfig]
-> ReadPrec UrgencyConfig
-> ReadPrec [UrgencyConfig]
-> Read UrgencyConfig
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UrgencyConfig]
$creadListPrec :: ReadPrec [UrgencyConfig]
readPrec :: ReadPrec UrgencyConfig
$creadPrec :: ReadPrec UrgencyConfig
readList :: ReadS [UrgencyConfig]
$creadList :: ReadS [UrgencyConfig]
readsPrec :: Int -> ReadS UrgencyConfig
$creadsPrec :: Int -> ReadS UrgencyConfig
Read, Int -> UrgencyConfig -> ShowS
[UrgencyConfig] -> ShowS
UrgencyConfig -> WorkspaceId
(Int -> UrgencyConfig -> ShowS)
-> (UrgencyConfig -> WorkspaceId)
-> ([UrgencyConfig] -> ShowS)
-> Show UrgencyConfig
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [UrgencyConfig] -> ShowS
$cshowList :: [UrgencyConfig] -> ShowS
show :: UrgencyConfig -> WorkspaceId
$cshow :: UrgencyConfig -> WorkspaceId
showsPrec :: Int -> UrgencyConfig -> ShowS
$cshowsPrec :: Int -> UrgencyConfig -> ShowS
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 (ReadPrec [SuppressWhen]
ReadPrec SuppressWhen
Int -> ReadS SuppressWhen
ReadS [SuppressWhen]
(Int -> ReadS SuppressWhen)
-> ReadS [SuppressWhen]
-> ReadPrec SuppressWhen
-> ReadPrec [SuppressWhen]
-> Read SuppressWhen
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SuppressWhen]
$creadListPrec :: ReadPrec [SuppressWhen]
readPrec :: ReadPrec SuppressWhen
$creadPrec :: ReadPrec SuppressWhen
readList :: ReadS [SuppressWhen]
$creadList :: ReadS [SuppressWhen]
readsPrec :: Int -> ReadS SuppressWhen
$creadsPrec :: Int -> ReadS SuppressWhen
Read, Int -> SuppressWhen -> ShowS
[SuppressWhen] -> ShowS
SuppressWhen -> WorkspaceId
(Int -> SuppressWhen -> ShowS)
-> (SuppressWhen -> WorkspaceId)
-> ([SuppressWhen] -> ShowS)
-> Show SuppressWhen
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [SuppressWhen] -> ShowS
$cshowList :: [SuppressWhen] -> ShowS
show :: SuppressWhen -> WorkspaceId
$cshow :: SuppressWhen -> WorkspaceId
showsPrec :: Int -> SuppressWhen -> ShowS
$cshowsPrec :: Int -> SuppressWhen -> ShowS
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 (ReadPrec [RemindWhen]
ReadPrec RemindWhen
Int -> ReadS RemindWhen
ReadS [RemindWhen]
(Int -> ReadS RemindWhen)
-> ReadS [RemindWhen]
-> ReadPrec RemindWhen
-> ReadPrec [RemindWhen]
-> Read RemindWhen
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RemindWhen]
$creadListPrec :: ReadPrec [RemindWhen]
readPrec :: ReadPrec RemindWhen
$creadPrec :: ReadPrec RemindWhen
readList :: ReadS [RemindWhen]
$creadList :: ReadS [RemindWhen]
readsPrec :: Int -> ReadS RemindWhen
$creadsPrec :: Int -> ReadS RemindWhen
Read, Int -> RemindWhen -> ShowS
[RemindWhen] -> ShowS
RemindWhen -> WorkspaceId
(Int -> RemindWhen -> ShowS)
-> (RemindWhen -> WorkspaceId)
-> ([RemindWhen] -> ShowS)
-> Show RemindWhen
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [RemindWhen] -> ShowS
$cshowList :: [RemindWhen] -> ShowS
show :: RemindWhen -> WorkspaceId
$cshow :: RemindWhen -> WorkspaceId
showsPrec :: Int -> RemindWhen -> ShowS
$cshowsPrec :: Int -> RemindWhen -> ShowS
Show)

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

-- | The default 'UrgencyConfig': @urgencyConfig = 'def'@.
urgencyConfig :: UrgencyConfig
urgencyConfig :: UrgencyConfig
urgencyConfig = UrgencyConfig
forall a. Default a => a
def
{-# DEPRECATED urgencyConfig "Use def insetad." #-}

-- | The default 'UrgencyConfig': @suppressWhen = 'Visible', remindWhen = 'Dont'@.
-- Use a variation of this in your config just as you would use any
-- other instance of 'def'.
instance Default UrgencyConfig where
  def :: UrgencyConfig
def = UrgencyConfig :: SuppressWhen -> RemindWhen -> UrgencyConfig
UrgencyConfig { suppressWhen :: SuppressWhen
suppressWhen = SuppressWhen
Visible, remindWhen :: RemindWhen
remindWhen = 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 :: X ()
focusUrgent = ([Atom] -> X ()) -> X ()
forall a. ([Atom] -> X a) -> X a
withUrgents (([Atom] -> X ()) -> X ()) -> ([Atom] -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ (Maybe Atom -> (Atom -> X ()) -> X ())
-> (Atom -> X ()) -> Maybe Atom -> X ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe Atom -> (Atom -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust ((WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (Atom -> WindowSet -> WindowSet) -> Atom -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Atom -> WindowSet -> WindowSet
forall s a i l sd.
(Eq s, Eq a, Eq i) =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.focusWindow) (Maybe Atom -> X ()) -> ([Atom] -> Maybe Atom) -> [Atom] -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Atom] -> Maybe Atom
forall a. [a] -> Maybe a
listToMaybe

-- | Just makes the urgents go away.
-- Example keybinding:
--
-- > , ((modm .|. shiftMask, xK_BackSpace), clearUrgents)
clearUrgents :: X ()
clearUrgents :: X ()
clearUrgents = ([Atom] -> X ()) -> X ()
forall a. ([Atom] -> X a) -> X a
withUrgents [Atom] -> X ()
clearUrgents'

-- | 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 :: X [Atom]
readUrgents = (Urgents -> [Atom]) -> X [Atom]
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets Urgents -> [Atom]
fromUrgents

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

-- | Cleanup urgency and reminders for windows that no longer exist.
cleanupStaleUrgents :: X ()
cleanupStaleUrgents :: X ()
cleanupStaleUrgents = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws -> do
    ([Atom] -> [Atom]) -> X ()
adjustUrgents ((Atom -> Bool) -> [Atom] -> [Atom]
forall a. (a -> Bool) -> [a] -> [a]
filter (Atom -> WindowSet -> Bool
forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Bool
`W.member` WindowSet
ws))
    ([Reminder] -> [Reminder]) -> X ()
adjustReminders ((Reminder -> Bool) -> [Reminder] -> [Reminder]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Atom -> WindowSet -> Bool
forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Bool
`W.member` WindowSet
ws) (Atom -> Bool) -> (Reminder -> Atom) -> Reminder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reminder -> Atom
window))

adjustUrgents :: ([Window] -> [Window]) -> X ()
adjustUrgents :: ([Atom] -> [Atom]) -> X ()
adjustUrgents = (Urgents -> Urgents) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((Urgents -> Urgents) -> X ())
-> (([Atom] -> [Atom]) -> Urgents -> Urgents)
-> ([Atom] -> [Atom])
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Atom] -> [Atom]) -> Urgents -> Urgents
onUrgents

type Interval = Rational

-- | An urgency reminder, as reified for 'RemindWhen'.
-- The last value is the countdown number, for 'Repeatedly'.
data Reminder = Reminder { Reminder -> Int
timer     :: TimerId
                         , Reminder -> Atom
window    :: Window
                         , Reminder -> Rational
interval  :: Interval
                         , Reminder -> Maybe Int
remaining :: Maybe Int
                         } deriving (Int -> Reminder -> ShowS
[Reminder] -> ShowS
Reminder -> WorkspaceId
(Int -> Reminder -> ShowS)
-> (Reminder -> WorkspaceId)
-> ([Reminder] -> ShowS)
-> Show Reminder
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [Reminder] -> ShowS
$cshowList :: [Reminder] -> ShowS
show :: Reminder -> WorkspaceId
$cshow :: Reminder -> WorkspaceId
showsPrec :: Int -> Reminder -> ShowS
$cshowsPrec :: Int -> Reminder -> ShowS
Show,ReadPrec [Reminder]
ReadPrec Reminder
Int -> ReadS Reminder
ReadS [Reminder]
(Int -> ReadS Reminder)
-> ReadS [Reminder]
-> ReadPrec Reminder
-> ReadPrec [Reminder]
-> Read Reminder
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Reminder]
$creadListPrec :: ReadPrec [Reminder]
readPrec :: ReadPrec Reminder
$creadPrec :: ReadPrec Reminder
readList :: ReadS [Reminder]
$creadList :: ReadS [Reminder]
readsPrec :: Int -> ReadS Reminder
$creadsPrec :: Int -> ReadS Reminder
Read,Reminder -> Reminder -> Bool
(Reminder -> Reminder -> Bool)
-> (Reminder -> Reminder -> Bool) -> Eq Reminder
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Reminder -> Reminder -> Bool
$c/= :: Reminder -> Reminder -> Bool
== :: Reminder -> Reminder -> Bool
$c== :: Reminder -> Reminder -> Bool
Eq)

instance ExtensionClass [Reminder] where
    initialValue :: [Reminder]
initialValue = []
    extensionType :: [Reminder] -> StateExtension
extensionType = [Reminder] -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

-- | Stores the list of urgency reminders.

readReminders :: X [Reminder]
readReminders :: X [Reminder]
readReminders = X [Reminder]
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get

adjustReminders :: ([Reminder] -> [Reminder]) -> X ()
adjustReminders :: ([Reminder] -> [Reminder]) -> X ()
adjustReminders = ([Reminder] -> [Reminder]) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify


data WithUrgencyHook h = WithUrgencyHook h UrgencyConfig
    deriving (ReadPrec [WithUrgencyHook h]
ReadPrec (WithUrgencyHook h)
Int -> ReadS (WithUrgencyHook h)
ReadS [WithUrgencyHook h]
(Int -> ReadS (WithUrgencyHook h))
-> ReadS [WithUrgencyHook h]
-> ReadPrec (WithUrgencyHook h)
-> ReadPrec [WithUrgencyHook h]
-> Read (WithUrgencyHook h)
forall h. Read h => ReadPrec [WithUrgencyHook h]
forall h. Read h => ReadPrec (WithUrgencyHook h)
forall h. Read h => Int -> ReadS (WithUrgencyHook h)
forall h. Read h => ReadS [WithUrgencyHook h]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WithUrgencyHook h]
$creadListPrec :: forall h. Read h => ReadPrec [WithUrgencyHook h]
readPrec :: ReadPrec (WithUrgencyHook h)
$creadPrec :: forall h. Read h => ReadPrec (WithUrgencyHook h)
readList :: ReadS [WithUrgencyHook h]
$creadList :: forall h. Read h => ReadS [WithUrgencyHook h]
readsPrec :: Int -> ReadS (WithUrgencyHook h)
$creadsPrec :: forall h. Read h => Int -> ReadS (WithUrgencyHook h)
Read, Int -> WithUrgencyHook h -> ShowS
[WithUrgencyHook h] -> ShowS
WithUrgencyHook h -> WorkspaceId
(Int -> WithUrgencyHook h -> ShowS)
-> (WithUrgencyHook h -> WorkspaceId)
-> ([WithUrgencyHook h] -> ShowS)
-> Show (WithUrgencyHook h)
forall h. Show h => Int -> WithUrgencyHook h -> ShowS
forall h. Show h => [WithUrgencyHook h] -> ShowS
forall h. Show h => WithUrgencyHook h -> WorkspaceId
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [WithUrgencyHook h] -> ShowS
$cshowList :: forall h. Show h => [WithUrgencyHook h] -> ShowS
show :: WithUrgencyHook h -> WorkspaceId
$cshow :: forall h. Show h => WithUrgencyHook h -> WorkspaceId
showsPrec :: Int -> WithUrgencyHook h -> ShowS
$cshowsPrec :: forall h. Show h => Int -> WithUrgencyHook h -> ShowS
Show)

-- | Change the _NET_WM_STATE property by applying a function to the list of atoms.
changeNetWMState :: Display -> Window -> ([CLong] -> [CLong]) -> X ()
changeNetWMState :: Display -> Atom -> ([CLong] -> [CLong]) -> X ()
changeNetWMState Display
dpy Atom
w [CLong] -> [CLong]
f = do
   Atom
wmstate <- WorkspaceId -> X Atom
getAtom WorkspaceId
"_NET_WM_STATE"
   [CLong]
wstate  <- [CLong] -> Maybe [CLong] -> [CLong]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [CLong] -> [CLong]) -> X (Maybe [CLong]) -> X [CLong]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> Atom -> X (Maybe [CLong])
getProp32 Atom
wmstate Atom
w
   IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> Atom -> Atom -> CInt -> [CLong] -> IO ()
changeProperty32 Display
dpy Atom
w Atom
wmstate Atom
aTOM CInt
propModeReplace ([CLong] -> [CLong]
f [CLong]
wstate)
   () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Add an atom to the _NET_WM_STATE property.
addNetWMState :: Display -> Window -> Atom -> X ()
addNetWMState :: Display -> Atom -> Atom -> X ()
addNetWMState Display
dpy Atom
w Atom
atom = Display -> Atom -> ([CLong] -> [CLong]) -> X ()
changeNetWMState Display
dpy Atom
w (Atom -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Atom
atom CLong -> [CLong] -> [CLong]
forall a. a -> [a] -> [a]
:)

-- | Remove an atom from the _NET_WM_STATE property.
removeNetWMState :: Display -> Window -> Atom -> X ()
removeNetWMState :: Display -> Atom -> Atom -> X ()
removeNetWMState Display
dpy Atom
w Atom
atom = Display -> Atom -> ([CLong] -> [CLong]) -> X ()
changeNetWMState Display
dpy Atom
w (([CLong] -> [CLong]) -> X ()) -> ([CLong] -> [CLong]) -> X ()
forall a b. (a -> b) -> a -> b
$ CLong -> [CLong] -> [CLong]
forall a. Eq a => a -> [a] -> [a]
delete (Atom -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Atom
atom)

-- | Get the _NET_WM_STATE propertly as a [CLong]
getNetWMState :: Window -> X [CLong]
getNetWMState :: Atom -> X [CLong]
getNetWMState Atom
w = do
    Atom
a_wmstate <- WorkspaceId -> X Atom
getAtom WorkspaceId
"_NET_WM_STATE"
    [CLong] -> Maybe [CLong] -> [CLong]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [CLong] -> [CLong]) -> X (Maybe [CLong]) -> X [CLong]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> Atom -> X (Maybe [CLong])
getProp32 Atom
a_wmstate Atom
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 :: forall h. UrgencyHook h => WithUrgencyHook h -> Event -> X ()
handleEvent WithUrgencyHook h
wuh Event
event =
    case Event
event of
     -- WM_HINTS urgency flag
      PropertyEvent { ev_event_type :: Event -> EventType
ev_event_type = EventType
t, ev_atom :: Event -> Atom
ev_atom = Atom
a, ev_window :: Event -> Atom
ev_window = Atom
w } ->
          Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (EventType
t EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
propertyNotify Bool -> Bool -> Bool
&& Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
wM_HINTS) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
              WMHints { wmh_flags :: WMHints -> CLong
wmh_flags = CLong
flags } <- IO WMHints -> X WMHints
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO WMHints -> X WMHints) -> IO WMHints -> X WMHints
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> IO WMHints
getWMHints Display
dpy Atom
w
              if CLong -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit CLong
flags Int
urgencyHintBit then Atom -> X ()
markUrgent Atom
w else Atom -> X ()
markNotUrgent Atom
w
      -- Window destroyed
      DestroyWindowEvent {ev_window :: Event -> Atom
ev_window = Atom
w} ->
          Atom -> X ()
markNotUrgent Atom
w
      -- _NET_WM_STATE_DEMANDS_ATTENTION requested by client
      ClientMessageEvent {ev_event_display :: Event -> Display
ev_event_display = Display
dpy, ev_window :: Event -> Atom
ev_window = Atom
w, ev_message_type :: Event -> Atom
ev_message_type = Atom
t, ev_data :: Event -> [CInt]
ev_data = CInt
action:[CInt]
atoms} -> do
          Atom
a_wmstate <- WorkspaceId -> X Atom
getAtom WorkspaceId
"_NET_WM_STATE"
          Atom
a_da      <- WorkspaceId -> X Atom
getAtom WorkspaceId
"_NET_WM_STATE_DEMANDS_ATTENTION"
          [CLong]
wstate    <- Atom -> X [CLong]
getNetWMState Atom
w
          let demandsAttention :: Bool
demandsAttention = Atom -> CLong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Atom
a_da CLong -> [CLong] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLong]
wstate
              remove :: CInt
remove = CInt
0
              add :: CInt
add    = CInt
1
              toggle :: CInt
toggle = CInt
2
          Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Atom
t Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
a_wmstate Bool -> Bool -> Bool
&& Atom -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Atom
a_da CInt -> [CInt] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt]
atoms) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
            Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
action CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
add Bool -> Bool -> Bool
|| (CInt
action CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
toggle Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
demandsAttention)) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
              Atom -> X ()
markUrgent Atom
w
              Display -> Atom -> Atom -> X ()
addNetWMState Display
dpy Atom
w Atom
a_da
            Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
action CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
remove Bool -> Bool -> Bool
|| (CInt
action CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
toggle Bool -> Bool -> Bool
&& Bool
demandsAttention)) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
              Atom -> X ()
markNotUrgent Atom
w
              Display -> Atom -> Atom -> X ()
removeNetWMState Display
dpy Atom
w Atom
a_da
      Event
_ ->
          (Reminder -> X (Maybe Any)) -> [Reminder] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Reminder -> X (Maybe Any)
forall {a}. Reminder -> X (Maybe a)
handleReminder ([Reminder] -> X ()) -> X [Reminder] -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X [Reminder]
readReminders
      where handleReminder :: Reminder -> X (Maybe a)
handleReminder Reminder
reminder = Int -> Event -> X (Maybe a) -> X (Maybe a)
forall a. Int -> Event -> X (Maybe a) -> X (Maybe a)
handleTimer (Reminder -> Int
timer Reminder
reminder) Event
event (X (Maybe a) -> X (Maybe a)) -> X (Maybe a) -> X (Maybe a)
forall a b. (a -> b) -> a -> b
$ WithUrgencyHook h -> Reminder -> X (Maybe a)
forall h a.
UrgencyHook h =>
WithUrgencyHook h -> Reminder -> X (Maybe a)
reminderHook WithUrgencyHook h
wuh Reminder
reminder
            markUrgent :: Atom -> X ()
markUrgent Atom
w = do
                ([Atom] -> [Atom]) -> X ()
adjustUrgents (\[Atom]
ws -> if Atom
w Atom -> [Atom] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Atom]
ws then [Atom]
ws else Atom
w Atom -> [Atom] -> [Atom]
forall a. a -> [a] -> [a]
: [Atom]
ws)
                WithUrgencyHook h -> Atom -> X ()
forall h. UrgencyHook h => WithUrgencyHook h -> Atom -> X ()
callUrgencyHook WithUrgencyHook h
wuh Atom
w
                () -> X () -> X ()
forall a. a -> X a -> X a
userCodeDef () (X () -> X ()) -> X (X ()) -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XConf -> X ()) -> X (X ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook (XConfig Layout -> X ())
-> (XConf -> XConfig Layout) -> XConf -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
            markNotUrgent :: Atom -> X ()
markNotUrgent Atom
w = do
                ([Atom] -> [Atom]) -> X ()
adjustUrgents (Atom -> [Atom] -> [Atom]
forall a. Eq a => a -> [a] -> [a]
delete Atom
w) X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ([Reminder] -> [Reminder]) -> X ()
adjustReminders ((Reminder -> Bool) -> [Reminder] -> [Reminder]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Reminder -> Bool) -> [Reminder] -> [Reminder])
-> (Reminder -> Bool) -> [Reminder] -> [Reminder]
forall a b. (a -> b) -> a -> b
$ (Atom
w Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Atom -> Bool) -> (Reminder -> Atom) -> Reminder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reminder -> Atom
window)
                () -> X () -> X ()
forall a. a -> X a -> X a
userCodeDef () (X () -> X ()) -> X (X ()) -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XConf -> X ()) -> X (X ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook (XConfig Layout -> X ())
-> (XConf -> XConfig Layout) -> XConf -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)

callUrgencyHook :: UrgencyHook h => WithUrgencyHook h -> Window -> X ()
callUrgencyHook :: forall h. UrgencyHook h => WithUrgencyHook h -> Atom -> X ()
callUrgencyHook (WithUrgencyHook h
hook UrgencyConfig { suppressWhen :: UrgencyConfig -> SuppressWhen
suppressWhen = SuppressWhen
sw, remindWhen :: UrgencyConfig -> RemindWhen
remindWhen = RemindWhen
rw }) Atom
w =
    X Bool -> X () -> X ()
whenX (Bool -> Bool
not (Bool -> Bool) -> X Bool -> X Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SuppressWhen -> Atom -> X Bool
shouldSuppress SuppressWhen
sw Atom
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
        () -> X () -> X ()
forall a. a -> X a -> X a
userCodeDef () (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ h -> Atom -> X ()
forall h. UrgencyHook h => h -> Atom -> X ()
urgencyHook h
hook Atom
w
        case RemindWhen
rw of
            Repeatedly Int
times Rational
int -> Atom -> Rational -> Maybe Int -> X ()
addReminder Atom
w Rational
int (Maybe Int -> X ()) -> Maybe Int -> X ()
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
times
            Every Rational
int            -> Atom -> Rational -> Maybe Int -> X ()
addReminder Atom
w Rational
int Maybe Int
forall a. Maybe a
Nothing
            RemindWhen
Dont                 -> () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

addReminder :: Window -> Rational -> Maybe Int -> X ()
addReminder :: Atom -> Rational -> Maybe Int -> X ()
addReminder Atom
w Rational
int Maybe Int
times = do
    Int
timerId <- Rational -> X Int
startTimer Rational
int
    let reminder :: Reminder
reminder = Int -> Atom -> Rational -> Maybe Int -> Reminder
Reminder Int
timerId Atom
w Rational
int Maybe Int
times
    ([Reminder] -> [Reminder]) -> X ()
adjustReminders (\[Reminder]
rs -> if Atom
w Atom -> [Atom] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Reminder -> Atom) -> [Reminder] -> [Atom]
forall a b. (a -> b) -> [a] -> [b]
map Reminder -> Atom
window [Reminder]
rs then [Reminder]
rs else Reminder
reminder Reminder -> [Reminder] -> [Reminder]
forall a. a -> [a] -> [a]
: [Reminder]
rs)

reminderHook :: UrgencyHook h => WithUrgencyHook h -> Reminder -> X (Maybe a)
reminderHook :: forall h a.
UrgencyHook h =>
WithUrgencyHook h -> Reminder -> X (Maybe a)
reminderHook (WithUrgencyHook h
hook UrgencyConfig
_) Reminder
reminder = do
    case Reminder -> Maybe Int
remaining Reminder
reminder of
        Just Int
x | Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> Maybe Int -> X ()
remind (Maybe Int -> X ()) -> Maybe Int -> X ()
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        Just Int
_         -> ([Reminder] -> [Reminder]) -> X ()
adjustReminders (([Reminder] -> [Reminder]) -> X ())
-> ([Reminder] -> [Reminder]) -> X ()
forall a b. (a -> b) -> a -> b
$ Reminder -> [Reminder] -> [Reminder]
forall a. Eq a => a -> [a] -> [a]
delete Reminder
reminder
        Maybe Int
Nothing        -> Maybe Int -> X ()
remind Maybe Int
forall a. Maybe a
Nothing
    Maybe a -> X (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
  where remind :: Maybe Int -> X ()
remind Maybe Int
remaining' = do X () -> X (Maybe ())
forall a. X a -> X (Maybe a)
userCode (X () -> X (Maybe ())) -> X () -> X (Maybe ())
forall a b. (a -> b) -> a -> b
$ h -> Atom -> X ()
forall h. UrgencyHook h => h -> Atom -> X ()
urgencyHook h
hook (Reminder -> Atom
window Reminder
reminder)
                               ([Reminder] -> [Reminder]) -> X ()
adjustReminders (([Reminder] -> [Reminder]) -> X ())
-> ([Reminder] -> [Reminder]) -> X ()
forall a b. (a -> b) -> a -> b
$ Reminder -> [Reminder] -> [Reminder]
forall a. Eq a => a -> [a] -> [a]
delete Reminder
reminder
                               Atom -> Rational -> Maybe Int -> X ()
addReminder (Reminder -> Atom
window Reminder
reminder) (Reminder -> Rational
interval Reminder
reminder) Maybe Int
remaining'

shouldSuppress :: SuppressWhen -> Window -> X Bool
shouldSuppress :: SuppressWhen -> Atom -> X Bool
shouldSuppress SuppressWhen
sw Atom
w = Atom -> [Atom] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Atom
w ([Atom] -> Bool) -> X [Atom] -> X Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SuppressWhen -> X [Atom]
suppressibleWindows SuppressWhen
sw

cleanupUrgents :: SuppressWhen -> X ()
cleanupUrgents :: SuppressWhen -> X ()
cleanupUrgents SuppressWhen
sw = [Atom] -> X ()
clearUrgents' ([Atom] -> X ()) -> X [Atom] -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SuppressWhen -> X [Atom]
suppressibleWindows SuppressWhen
sw

-- | Clear urgency status of selected windows.
clearUrgents' :: [Window] -> X ()
clearUrgents' :: [Atom] -> X ()
clearUrgents' [Atom]
ws = do
    Atom
a_da <- WorkspaceId -> X Atom
getAtom WorkspaceId
"_NET_WM_STATE_DEMANDS_ATTENTION"
    Display
dpy <- (Display -> X Display) -> X Display
forall a. (Display -> X a) -> X a
withDisplay Display -> X Display
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Atom -> X ()) -> [Atom] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Atom
w -> Display -> Atom -> Atom -> X ()
removeNetWMState Display
dpy Atom
w Atom
a_da) [Atom]
ws
    ([Atom] -> [Atom]) -> X ()
adjustUrgents ([Atom] -> [Atom] -> [Atom]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Atom]
ws) X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ([Reminder] -> [Reminder]) -> X ()
adjustReminders ((Reminder -> Bool) -> [Reminder] -> [Reminder]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Atom -> [Atom] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Atom]
ws) (Atom -> Bool) -> (Reminder -> Atom) -> Reminder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reminder -> Atom
window))

suppressibleWindows :: SuppressWhen -> X [Window]
suppressibleWindows :: SuppressWhen -> X [Atom]
suppressibleWindows SuppressWhen
Visible  = (XState -> [Atom]) -> X [Atom]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> [Atom]) -> X [Atom]) -> (XState -> [Atom]) -> X [Atom]
forall a b. (a -> b) -> a -> b
$ Set Atom -> [Atom]
forall a. Set a -> [a]
S.toList (Set Atom -> [Atom]) -> (XState -> Set Atom) -> XState -> [Atom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> Set Atom
mapped
suppressibleWindows SuppressWhen
OnScreen = (XState -> [Atom]) -> X [Atom]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> [Atom]) -> X [Atom]) -> (XState -> [Atom]) -> X [Atom]
forall a b. (a -> b) -> a -> b
$ WindowSet -> [Atom]
forall i l a s sd. StackSet i l a s sd -> [a]
W.index (WindowSet -> [Atom]) -> (XState -> WindowSet) -> XState -> [Atom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
suppressibleWindows SuppressWhen
Focused  = (XState -> [Atom]) -> X [Atom]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> [Atom]) -> X [Atom]) -> (XState -> [Atom]) -> X [Atom]
forall a b. (a -> b) -> a -> b
$ Maybe Atom -> [Atom]
forall a. Maybe a -> [a]
maybeToList (Maybe Atom -> [Atom])
-> (XState -> Maybe Atom) -> XState -> [Atom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> Maybe Atom
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek (WindowSet -> Maybe Atom)
-> (XState -> WindowSet) -> XState -> Maybe Atom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
suppressibleWindows SuppressWhen
Never    = [Atom] -> X [Atom]
forall (m :: * -> *) a. Monad m => a -> m a
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 :: (Atom -> X ()) -> Atom -> X ()
urgencyHook = (Atom -> X ()) -> Atom -> X ()
forall a. a -> a
id

data NoUrgencyHook = NoUrgencyHook deriving (ReadPrec [NoUrgencyHook]
ReadPrec NoUrgencyHook
Int -> ReadS NoUrgencyHook
ReadS [NoUrgencyHook]
(Int -> ReadS NoUrgencyHook)
-> ReadS [NoUrgencyHook]
-> ReadPrec NoUrgencyHook
-> ReadPrec [NoUrgencyHook]
-> Read NoUrgencyHook
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [NoUrgencyHook]
$creadListPrec :: ReadPrec [NoUrgencyHook]
readPrec :: ReadPrec NoUrgencyHook
$creadPrec :: ReadPrec NoUrgencyHook
readList :: ReadS [NoUrgencyHook]
$creadList :: ReadS [NoUrgencyHook]
readsPrec :: Int -> ReadS NoUrgencyHook
$creadsPrec :: Int -> ReadS NoUrgencyHook
Read, Int -> NoUrgencyHook -> ShowS
[NoUrgencyHook] -> ShowS
NoUrgencyHook -> WorkspaceId
(Int -> NoUrgencyHook -> ShowS)
-> (NoUrgencyHook -> WorkspaceId)
-> ([NoUrgencyHook] -> ShowS)
-> Show NoUrgencyHook
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [NoUrgencyHook] -> ShowS
$cshowList :: [NoUrgencyHook] -> ShowS
show :: NoUrgencyHook -> WorkspaceId
$cshow :: NoUrgencyHook -> WorkspaceId
showsPrec :: Int -> NoUrgencyHook -> ShowS
$cshowsPrec :: Int -> NoUrgencyHook -> ShowS
Show)

instance UrgencyHook NoUrgencyHook where
    urgencyHook :: NoUrgencyHook -> Atom -> X ()
urgencyHook NoUrgencyHook
_ Atom
_ = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Your set of options for configuring a dzenUrgencyHook.
data DzenUrgencyHook = DzenUrgencyHook {
                         DzenUrgencyHook -> Int
duration :: Int, -- ^ number of microseconds to display the dzen
                                          --   (hence, you'll probably want to use 'seconds')
                         DzenUrgencyHook -> [WorkspaceId]
args :: [String] -- ^ list of extra args (as 'String's) to pass to dzen
                       }
    deriving (ReadPrec [DzenUrgencyHook]
ReadPrec DzenUrgencyHook
Int -> ReadS DzenUrgencyHook
ReadS [DzenUrgencyHook]
(Int -> ReadS DzenUrgencyHook)
-> ReadS [DzenUrgencyHook]
-> ReadPrec DzenUrgencyHook
-> ReadPrec [DzenUrgencyHook]
-> Read DzenUrgencyHook
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DzenUrgencyHook]
$creadListPrec :: ReadPrec [DzenUrgencyHook]
readPrec :: ReadPrec DzenUrgencyHook
$creadPrec :: ReadPrec DzenUrgencyHook
readList :: ReadS [DzenUrgencyHook]
$creadList :: ReadS [DzenUrgencyHook]
readsPrec :: Int -> ReadS DzenUrgencyHook
$creadsPrec :: Int -> ReadS DzenUrgencyHook
Read, Int -> DzenUrgencyHook -> ShowS
[DzenUrgencyHook] -> ShowS
DzenUrgencyHook -> WorkspaceId
(Int -> DzenUrgencyHook -> ShowS)
-> (DzenUrgencyHook -> WorkspaceId)
-> ([DzenUrgencyHook] -> ShowS)
-> Show DzenUrgencyHook
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [DzenUrgencyHook] -> ShowS
$cshowList :: [DzenUrgencyHook] -> ShowS
show :: DzenUrgencyHook -> WorkspaceId
$cshow :: DzenUrgencyHook -> WorkspaceId
showsPrec :: Int -> DzenUrgencyHook -> ShowS
$cshowsPrec :: Int -> DzenUrgencyHook -> ShowS
Show)

instance UrgencyHook DzenUrgencyHook where
    urgencyHook :: DzenUrgencyHook -> Atom -> X ()
urgencyHook DzenUrgencyHook { duration :: DzenUrgencyHook -> Int
duration = Int
d, args :: DzenUrgencyHook -> [WorkspaceId]
args = [WorkspaceId]
a } Atom
w = do
        NamedWindow
name <- Atom -> X NamedWindow
getName Atom
w
        WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
        Maybe WorkspaceId -> (WorkspaceId -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (Atom -> WindowSet -> Maybe WorkspaceId
forall a i l s sd. Eq a => a -> StackSet i l a s sd -> Maybe i
W.findTag Atom
w WindowSet
ws) (NamedWindow -> WorkspaceId -> X ()
forall {a}. Show a => a -> WorkspaceId -> X ()
flash NamedWindow
name)
      where flash :: a -> WorkspaceId -> X ()
flash a
name WorkspaceId
index =
                  WorkspaceId -> [WorkspaceId] -> Int -> X ()
dzenWithArgs (a -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show a
name WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
" requests your attention on workspace " WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
index) [WorkspaceId]
a Int
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 :: Atom -> X ()
focusHook = FocusHook -> Atom -> X ()
forall h. UrgencyHook h => h -> Atom -> X ()
urgencyHook FocusHook
FocusHook
data FocusHook = FocusHook deriving (ReadPrec [FocusHook]
ReadPrec FocusHook
Int -> ReadS FocusHook
ReadS [FocusHook]
(Int -> ReadS FocusHook)
-> ReadS [FocusHook]
-> ReadPrec FocusHook
-> ReadPrec [FocusHook]
-> Read FocusHook
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FocusHook]
$creadListPrec :: ReadPrec [FocusHook]
readPrec :: ReadPrec FocusHook
$creadPrec :: ReadPrec FocusHook
readList :: ReadS [FocusHook]
$creadList :: ReadS [FocusHook]
readsPrec :: Int -> ReadS FocusHook
$creadsPrec :: Int -> ReadS FocusHook
Read, Int -> FocusHook -> ShowS
[FocusHook] -> ShowS
FocusHook -> WorkspaceId
(Int -> FocusHook -> ShowS)
-> (FocusHook -> WorkspaceId)
-> ([FocusHook] -> ShowS)
-> Show FocusHook
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [FocusHook] -> ShowS
$cshowList :: [FocusHook] -> ShowS
show :: FocusHook -> WorkspaceId
$cshow :: FocusHook -> WorkspaceId
showsPrec :: Int -> FocusHook -> ShowS
$cshowsPrec :: Int -> FocusHook -> ShowS
Show)

instance UrgencyHook FocusHook where
    urgencyHook :: FocusHook -> Atom -> X ()
urgencyHook FocusHook
_ Atom
_ = X ()
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 :: WorkspaceId -> Atom -> X ()
borderUrgencyHook = BorderUrgencyHook -> Atom -> X ()
forall h. UrgencyHook h => h -> Atom -> X ()
urgencyHook (BorderUrgencyHook -> Atom -> X ())
-> (WorkspaceId -> BorderUrgencyHook)
-> WorkspaceId
-> Atom
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceId -> BorderUrgencyHook
BorderUrgencyHook
newtype BorderUrgencyHook = BorderUrgencyHook { BorderUrgencyHook -> WorkspaceId
urgencyBorderColor :: String }
                       deriving (ReadPrec [BorderUrgencyHook]
ReadPrec BorderUrgencyHook
Int -> ReadS BorderUrgencyHook
ReadS [BorderUrgencyHook]
(Int -> ReadS BorderUrgencyHook)
-> ReadS [BorderUrgencyHook]
-> ReadPrec BorderUrgencyHook
-> ReadPrec [BorderUrgencyHook]
-> Read BorderUrgencyHook
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BorderUrgencyHook]
$creadListPrec :: ReadPrec [BorderUrgencyHook]
readPrec :: ReadPrec BorderUrgencyHook
$creadPrec :: ReadPrec BorderUrgencyHook
readList :: ReadS [BorderUrgencyHook]
$creadList :: ReadS [BorderUrgencyHook]
readsPrec :: Int -> ReadS BorderUrgencyHook
$creadsPrec :: Int -> ReadS BorderUrgencyHook
Read, Int -> BorderUrgencyHook -> ShowS
[BorderUrgencyHook] -> ShowS
BorderUrgencyHook -> WorkspaceId
(Int -> BorderUrgencyHook -> ShowS)
-> (BorderUrgencyHook -> WorkspaceId)
-> ([BorderUrgencyHook] -> ShowS)
-> Show BorderUrgencyHook
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [BorderUrgencyHook] -> ShowS
$cshowList :: [BorderUrgencyHook] -> ShowS
show :: BorderUrgencyHook -> WorkspaceId
$cshow :: BorderUrgencyHook -> WorkspaceId
showsPrec :: Int -> BorderUrgencyHook -> ShowS
$cshowsPrec :: Int -> BorderUrgencyHook -> ShowS
Show)

instance UrgencyHook BorderUrgencyHook where
  urgencyHook :: BorderUrgencyHook -> Atom -> X ()
urgencyHook BorderUrgencyHook { urgencyBorderColor :: BorderUrgencyHook -> WorkspaceId
urgencyBorderColor = WorkspaceId
cs } Atom
w =
    (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
      Maybe Atom
c' <- IO (Maybe Atom) -> X (Maybe Atom)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> WorkspaceId -> IO (Maybe Atom)
initColor Display
dpy WorkspaceId
cs)
      case Maybe Atom
c' of
        Just Atom
c -> Display -> Atom -> WorkspaceId -> Atom -> X ()
setWindowBorderWithFallback Display
dpy Atom
w WorkspaceId
cs Atom
c
        Maybe Atom
_      -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Handle -> WorkspaceId -> IO ()
hPutStrLn Handle
stderr (WorkspaceId -> IO ()) -> WorkspaceId -> IO ()
forall a b. (a -> b) -> a -> b
$ [WorkspaceId] -> WorkspaceId
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [WorkspaceId
"Warning: bad urgentBorderColor "
                                                 ,ShowS
forall a. Show a => a -> WorkspaceId
show WorkspaceId
cs
                                                 ,WorkspaceId
" 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
dzenUrgencyHook = DzenUrgencyHook
forall a. Default a => a
def

-- | @'def' = 'dzenUrgencyHook'@.
instance Default DzenUrgencyHook where
  def :: DzenUrgencyHook
def = DzenUrgencyHook :: Int -> [WorkspaceId] -> DzenUrgencyHook
DzenUrgencyHook { duration :: Int
duration = Rational -> Int
seconds Rational
5, args :: [WorkspaceId]
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 :: WorkspaceId -> Atom -> X ()
spawnUrgencyHook = SpawnUrgencyHook -> Atom -> X ()
forall h. UrgencyHook h => h -> Atom -> X ()
urgencyHook (SpawnUrgencyHook -> Atom -> X ())
-> (WorkspaceId -> SpawnUrgencyHook) -> WorkspaceId -> Atom -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceId -> SpawnUrgencyHook
SpawnUrgencyHook
newtype SpawnUrgencyHook = SpawnUrgencyHook String deriving (ReadPrec [SpawnUrgencyHook]
ReadPrec SpawnUrgencyHook
Int -> ReadS SpawnUrgencyHook
ReadS [SpawnUrgencyHook]
(Int -> ReadS SpawnUrgencyHook)
-> ReadS [SpawnUrgencyHook]
-> ReadPrec SpawnUrgencyHook
-> ReadPrec [SpawnUrgencyHook]
-> Read SpawnUrgencyHook
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SpawnUrgencyHook]
$creadListPrec :: ReadPrec [SpawnUrgencyHook]
readPrec :: ReadPrec SpawnUrgencyHook
$creadPrec :: ReadPrec SpawnUrgencyHook
readList :: ReadS [SpawnUrgencyHook]
$creadList :: ReadS [SpawnUrgencyHook]
readsPrec :: Int -> ReadS SpawnUrgencyHook
$creadsPrec :: Int -> ReadS SpawnUrgencyHook
Read, Int -> SpawnUrgencyHook -> ShowS
[SpawnUrgencyHook] -> ShowS
SpawnUrgencyHook -> WorkspaceId
(Int -> SpawnUrgencyHook -> ShowS)
-> (SpawnUrgencyHook -> WorkspaceId)
-> ([SpawnUrgencyHook] -> ShowS)
-> Show SpawnUrgencyHook
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [SpawnUrgencyHook] -> ShowS
$cshowList :: [SpawnUrgencyHook] -> ShowS
show :: SpawnUrgencyHook -> WorkspaceId
$cshow :: SpawnUrgencyHook -> WorkspaceId
showsPrec :: Int -> SpawnUrgencyHook -> ShowS
$cshowsPrec :: Int -> SpawnUrgencyHook -> ShowS
Show)

instance UrgencyHook SpawnUrgencyHook where
    urgencyHook :: SpawnUrgencyHook -> Atom -> X ()
urgencyHook (SpawnUrgencyHook WorkspaceId
prefix) Atom
w = WorkspaceId -> X ()
forall (m :: * -> *). MonadIO m => WorkspaceId -> m ()
spawn (WorkspaceId -> X ()) -> WorkspaceId -> X ()
forall a b. (a -> b) -> a -> b
$ WorkspaceId
prefix WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ Atom -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show Atom
w

-- | For debugging purposes, really.
stdoutUrgencyHook :: Window -> X ()
stdoutUrgencyHook :: Atom -> X ()
stdoutUrgencyHook = StdoutUrgencyHook -> Atom -> X ()
forall h. UrgencyHook h => h -> Atom -> X ()
urgencyHook StdoutUrgencyHook
StdoutUrgencyHook
data StdoutUrgencyHook = StdoutUrgencyHook deriving (ReadPrec [StdoutUrgencyHook]
ReadPrec StdoutUrgencyHook
Int -> ReadS StdoutUrgencyHook
ReadS [StdoutUrgencyHook]
(Int -> ReadS StdoutUrgencyHook)
-> ReadS [StdoutUrgencyHook]
-> ReadPrec StdoutUrgencyHook
-> ReadPrec [StdoutUrgencyHook]
-> Read StdoutUrgencyHook
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StdoutUrgencyHook]
$creadListPrec :: ReadPrec [StdoutUrgencyHook]
readPrec :: ReadPrec StdoutUrgencyHook
$creadPrec :: ReadPrec StdoutUrgencyHook
readList :: ReadS [StdoutUrgencyHook]
$creadList :: ReadS [StdoutUrgencyHook]
readsPrec :: Int -> ReadS StdoutUrgencyHook
$creadsPrec :: Int -> ReadS StdoutUrgencyHook
Read, Int -> StdoutUrgencyHook -> ShowS
[StdoutUrgencyHook] -> ShowS
StdoutUrgencyHook -> WorkspaceId
(Int -> StdoutUrgencyHook -> ShowS)
-> (StdoutUrgencyHook -> WorkspaceId)
-> ([StdoutUrgencyHook] -> ShowS)
-> Show StdoutUrgencyHook
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [StdoutUrgencyHook] -> ShowS
$cshowList :: [StdoutUrgencyHook] -> ShowS
show :: StdoutUrgencyHook -> WorkspaceId
$cshow :: StdoutUrgencyHook -> WorkspaceId
showsPrec :: Int -> StdoutUrgencyHook -> ShowS
$cshowsPrec :: Int -> StdoutUrgencyHook -> ShowS
Show)

instance UrgencyHook StdoutUrgencyHook where
    urgencyHook :: StdoutUrgencyHook -> Atom -> X ()
urgencyHook    StdoutUrgencyHook
_ Atom
w = IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> IO ()
putStrLn (WorkspaceId -> IO ()) -> WorkspaceId -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkspaceId
"Urgent: " WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ Atom -> WorkspaceId
forall a. Show a => a -> WorkspaceId
show Atom
w

-- | urgencyhook such that windows on certain workspaces
-- never get urgency set.
--
-- Useful for scratchpad workspaces perhaps:
--
-- > main = xmonad (withUrgencyHook (filterUrgencyHook ["NSP", "SP"]) def)
filterUrgencyHook :: [WorkspaceId] -> Window -> X ()
filterUrgencyHook :: [WorkspaceId] -> Atom -> X ()
filterUrgencyHook [WorkspaceId]
skips = Query Bool -> Atom -> X ()
filterUrgencyHook' (Query Bool -> Atom -> X ()) -> Query Bool -> Atom -> X ()
forall a b. (a -> b) -> a -> b
$ Bool -> (WorkspaceId -> Bool) -> Maybe WorkspaceId -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (WorkspaceId -> [WorkspaceId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WorkspaceId]
skips) (Maybe WorkspaceId -> Bool)
-> Query (Maybe WorkspaceId) -> Query Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query (Maybe WorkspaceId)
windowTag

-- | 'filterUrgencyHook' that takes a generic 'Query' to select which windows
-- should never be marked urgent.
filterUrgencyHook' :: Query Bool -> Window -> X ()
filterUrgencyHook' :: Query Bool -> Atom -> X ()
filterUrgencyHook' Query Bool
q Atom
w = X Bool -> X () -> X ()
whenX (Query Bool -> Atom -> X Bool
forall a. Query a -> Atom -> X a
runQuery Query Bool
q Atom
w) ([Atom] -> X ()
clearUrgents' [Atom
w])

-- | Mark the given window urgent.
--
-- (The implementation is a bit hacky: send a _NET_WM_STATE ClientMessage to
-- ourselves. This is so that we respect the 'SuppressWhen' of the configured
-- urgency hooks. If this module if ever migrated to the ExtensibleConf
-- infrastrcture, we'll then invoke markUrgent directly.)
askUrgent :: Window -> X ()
askUrgent :: Atom -> X ()
askUrgent Atom
w = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
    Atom
rw <- (XConf -> Atom) -> X Atom
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Atom
theRoot
    Atom
a_wmstate <- WorkspaceId -> X Atom
getAtom WorkspaceId
"_NET_WM_STATE"
    Atom
a_da      <- WorkspaceId -> X Atom
getAtom WorkspaceId
"_NET_WM_STATE_DEMANDS_ATTENTION"
    let state_add :: CInt
state_add = CInt
1
    let source_pager :: CInt
source_pager = CInt
2
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO ()) -> IO ()
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
        XEventPtr -> EventType -> IO ()
setEventType XEventPtr
e EventType
clientMessage
        XEventPtr -> Atom -> Atom -> CInt -> [CInt] -> IO ()
setClientMessageEvent' XEventPtr
e Atom
w Atom
a_wmstate CInt
32 [CInt
state_add, Atom -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Atom
a_da, CInt
0, CInt
source_pager]
        Display -> Atom -> Bool -> Atom -> XEventPtr -> IO ()
sendEvent Display
dpy Atom
rw Bool
False (Atom
substructureRedirectMask Atom -> Atom -> Atom
forall a. Bits a => a -> a -> a
.|. Atom
substructureNotifyMask) XEventPtr
e

-- | Helper for 'ManageHook' that marks the window as urgent (unless
-- suppressed, see 'SuppressWhen'). Useful in
-- 'XMonad.Hooks.EwmhDesktops.setEwmhActivateHook' and also in combination
-- with "XMonad.Hooks.InsertPosition", "XMonad.Hooks.Focus".
doAskUrgent :: ManageHook
doAskUrgent :: Query (Endo WindowSet)
doAskUrgent = Query Atom
forall r (m :: * -> *). MonadReader r m => m r
ask Query Atom
-> (Atom -> Query (Endo WindowSet)) -> Query (Endo WindowSet)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Atom
w -> X () -> Query ()
forall a. X a -> Query a
liftX (Atom -> X ()
askUrgent Atom
w) Query () -> Query (Endo WindowSet) -> Query (Endo WindowSet)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Query (Endo WindowSet)
forall a. Monoid a => a
mempty