-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.ToggleHook
-- Description :  Hook and keybindings for toggling hook behavior.
-- Copyright   :  Ben Boeckel <mathstuf@gmail.com>
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Ben Boeckel <mathstuf@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Hook and keybindings for toggling hook behavior.
-----------------------------------------------------------------------------

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

                                 -- * The hook
                                 toggleHook
                               , toggleHook'

                                 -- * Actions
                               , hookNext
                               , toggleHookNext
                               , hookAllNew
                               , toggleHookAllNew

                                 -- * Queries
                               , willHook
                               , willHookNext
                               , willHookAllNew

                                 -- * Status bar utilities
                                 -- $pp
                               , willHookNextPP
                               , willHookAllNewPP
                               , runLogHook ) where

import Prelude hiding (all)

import XMonad
import XMonad.Prelude (guard, join)
import qualified XMonad.Util.ExtensibleState as XS

import Control.Arrow (first, second)

import Data.Map

{- Helper functions -}

_set :: String -> ((a -> a) -> (Bool, Bool) -> (Bool, Bool)) -> a -> X ()
_set :: String -> ((a -> a) -> (Bool, Bool) -> (Bool, Bool)) -> a -> X ()
_set String
n (a -> a) -> (Bool, Bool) -> (Bool, Bool)
f a
b = String -> ((Bool, Bool) -> (Bool, Bool)) -> X ()
modify' String
n ((a -> a) -> (Bool, Bool) -> (Bool, Bool)
f ((a -> a) -> (Bool, Bool) -> (Bool, Bool))
-> (a -> a) -> (Bool, Bool) -> (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a b. a -> b -> a
const a
b)

_toggle :: String -> ((Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)) -> X ()
_toggle :: String -> ((Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)) -> X ()
_toggle String
n (Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)
f = String -> ((Bool, Bool) -> (Bool, Bool)) -> X ()
modify' String
n ((Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)
f Bool -> Bool
not)

_get :: String -> ((Bool, Bool) -> a) -> X a
_get :: String -> ((Bool, Bool) -> a) -> X a
_get String
n (Bool, Bool) -> a
f = (HookState -> a) -> X a
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ((HookState -> a) -> X a) -> (HookState -> a) -> X a
forall a b. (a -> b) -> a -> b
$ (Bool, Bool) -> a
f ((Bool, Bool) -> a)
-> (HookState -> (Bool, Bool)) -> HookState -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, Bool) -> String -> Map String (Bool, Bool) -> (Bool, Bool)
forall k a. Ord k => a -> k -> Map k a -> a
findWithDefault (Bool
False, Bool
False) String
n (Map String (Bool, Bool) -> (Bool, Bool))
-> (HookState -> Map String (Bool, Bool))
-> HookState
-> (Bool, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HookState -> Map String (Bool, Bool)
hooks)

_pp :: String -> ((Bool, Bool) -> Bool) -> String -> (String -> String) -> X (Maybe String)
_pp :: String
-> ((Bool, Bool) -> Bool)
-> String
-> (String -> String)
-> X (Maybe String)
_pp String
n (Bool, Bool) -> Bool
f String
s String -> String
st = (\Bool
b -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
b Maybe () -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Maybe String
forall a. a -> Maybe a
Just (String -> String
st String
s)) (Bool -> Maybe String) -> X Bool -> X (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ((Bool, Bool) -> Bool) -> X Bool
forall a. String -> ((Bool, Bool) -> a) -> X a
_get String
n (Bool, Bool) -> Bool
f

{- The current state is kept here -}

newtype HookState = HookState { HookState -> Map String (Bool, Bool)
hooks :: Map String (Bool, Bool) } deriving (ReadPrec [HookState]
ReadPrec HookState
Int -> ReadS HookState
ReadS [HookState]
(Int -> ReadS HookState)
-> ReadS [HookState]
-> ReadPrec HookState
-> ReadPrec [HookState]
-> Read HookState
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HookState]
$creadListPrec :: ReadPrec [HookState]
readPrec :: ReadPrec HookState
$creadPrec :: ReadPrec HookState
readList :: ReadS [HookState]
$creadList :: ReadS [HookState]
readsPrec :: Int -> ReadS HookState
$creadsPrec :: Int -> ReadS HookState
Read, Int -> HookState -> String -> String
[HookState] -> String -> String
HookState -> String
(Int -> HookState -> String -> String)
-> (HookState -> String)
-> ([HookState] -> String -> String)
-> Show HookState
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [HookState] -> String -> String
$cshowList :: [HookState] -> String -> String
show :: HookState -> String
$cshow :: HookState -> String
showsPrec :: Int -> HookState -> String -> String
$cshowsPrec :: Int -> HookState -> String -> String
Show)

instance ExtensionClass HookState where
    initialValue :: HookState
initialValue = Map String (Bool, Bool) -> HookState
HookState Map String (Bool, Bool)
forall k a. Map k a
empty
    extensionType :: HookState -> StateExtension
extensionType = HookState -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

modify' :: String -> ((Bool, Bool) -> (Bool, Bool)) -> X ()
modify' :: String -> ((Bool, Bool) -> (Bool, Bool)) -> X ()
modify' String
n (Bool, Bool) -> (Bool, Bool)
f = (HookState -> HookState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify (Map String (Bool, Bool) -> HookState
HookState (Map String (Bool, Bool) -> HookState)
-> (HookState -> Map String (Bool, Bool)) -> HookState -> HookState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String (Bool, Bool) -> Map String (Bool, Bool)
setter (Map String (Bool, Bool) -> Map String (Bool, Bool))
-> (HookState -> Map String (Bool, Bool))
-> HookState
-> Map String (Bool, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HookState -> Map String (Bool, Bool)
hooks)
    where
        setter :: Map String (Bool, Bool) -> Map String (Bool, Bool)
setter Map String (Bool, Bool)
m = String
-> (Bool, Bool)
-> Map String (Bool, Bool)
-> Map String (Bool, Bool)
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert String
n ((Bool, Bool) -> (Bool, Bool)
f ((Bool, Bool) -> String -> Map String (Bool, Bool) -> (Bool, Bool)
forall k a. Ord k => a -> k -> Map k a -> a
findWithDefault (Bool
False, Bool
False) String
n Map String (Bool, Bool)
m)) Map String (Bool, Bool)
m

-- $usage
-- This module provides actions (that can be set as keybindings)
-- to be able to cause hooks to be occur on a conditional basis.
--
-- You can use it by including the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Hooks.ToggleHook
--
-- and adding 'toggleHook name hook' to your 'ManageHook' where @name@ is the
-- name of the hook and @hook@ is the hook to execute based on the state.
--
-- > myManageHook = toggleHook "float" doFloat <+> manageHook def
--
-- Additionally, toggleHook' is provided to toggle between two hooks (rather
-- than on/off).
--
-- > myManageHook = toggleHook' "oldfocus" (const id) W.focusWindow <+> manageHook def
--
-- The 'hookNext' and 'toggleHookNext' functions can be used in key
-- bindings to set whether the hook is applied or not.
--
-- > , ((modm, xK_e), toggleHookNext "float")
--
-- 'hookAllNew' and 'toggleHookAllNew' are similar but float all
-- spawned windows until disabled again.
--
-- > , ((modm, xK_r), toggleHookAllNew "float")

-- | This 'ManageHook' will selectively apply a hook as set
-- by 'hookNext' and 'hookAllNew'.
toggleHook :: String -> ManageHook -> ManageHook
toggleHook :: String -> ManageHook -> ManageHook
toggleHook String
n ManageHook
h = String -> ManageHook -> ManageHook -> ManageHook
toggleHook' String
n ManageHook
h ManageHook
forall m. Monoid m => m
idHook

toggleHook' :: String -> ManageHook -> ManageHook -> ManageHook
toggleHook' :: String -> ManageHook -> ManageHook -> ManageHook
toggleHook' String
n ManageHook
th ManageHook
fh = do Map String (Bool, Bool)
m <- X (Map String (Bool, Bool)) -> Query (Map String (Bool, Bool))
forall a. X a -> Query a
liftX (X (Map String (Bool, Bool)) -> Query (Map String (Bool, Bool)))
-> X (Map String (Bool, Bool)) -> Query (Map String (Bool, Bool))
forall a b. (a -> b) -> a -> b
$ (HookState -> Map String (Bool, Bool))
-> X (Map String (Bool, Bool))
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets HookState -> Map String (Bool, Bool)
hooks
                         (Bool
next, Bool
all) <- (Bool, Bool) -> Query (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Bool) -> Query (Bool, Bool))
-> (Bool, Bool) -> Query (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ (Bool, Bool) -> String -> Map String (Bool, Bool) -> (Bool, Bool)
forall k a. Ord k => a -> k -> Map k a -> a
findWithDefault (Bool
False, Bool
False) String
n Map String (Bool, Bool)
m
                         X () -> Query ()
forall a. X a -> Query a
liftX (X () -> Query ()) -> X () -> Query ()
forall a b. (a -> b) -> a -> b
$ HookState -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (HookState -> X ()) -> HookState -> X ()
forall a b. (a -> b) -> a -> b
$ Map String (Bool, Bool) -> HookState
HookState (Map String (Bool, Bool) -> HookState)
-> Map String (Bool, Bool) -> HookState
forall a b. (a -> b) -> a -> b
$ String
-> (Bool, Bool)
-> Map String (Bool, Bool)
-> Map String (Bool, Bool)
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert String
n (Bool
False, Bool
all) Map String (Bool, Bool)
m
                         if Bool
next Bool -> Bool -> Bool
|| Bool
all then ManageHook
th else ManageHook
fh

-- | @hookNext name True@ arranges for the next spawned window to
-- have the hook @name@ applied, @hookNext name False@ cancels it.
hookNext :: String -> Bool -> X ()
hookNext :: String -> Bool -> X ()
hookNext String
n = String
-> ((Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)) -> Bool -> X ()
forall a.
String -> ((a -> a) -> (Bool, Bool) -> (Bool, Bool)) -> a -> X ()
_set String
n (Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first

toggleHookNext :: String -> X ()
toggleHookNext :: String -> X ()
toggleHookNext String
n = String -> ((Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)) -> X ()
_toggle String
n (Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first

-- | @hookAllNew name True@ arranges for new windows to
-- have the hook @name@ applied, @hookAllNew name False@ cancels it
hookAllNew :: String -> Bool -> X ()
hookAllNew :: String -> Bool -> X ()
hookAllNew String
n = String
-> ((Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)) -> Bool -> X ()
forall a.
String -> ((a -> a) -> (Bool, Bool) -> (Bool, Bool)) -> a -> X ()
_set String
n (Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second

toggleHookAllNew :: String -> X ()
toggleHookAllNew :: String -> X ()
toggleHookAllNew String
n = String -> ((Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)) -> X ()
_toggle String
n (Bool -> Bool) -> (Bool, Bool) -> (Bool, Bool)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second

-- | Query what will happen at the next ManageHook call for the hook @name@.
willHook :: String -> X Bool
willHook :: String -> X Bool
willHook String
n = String -> X Bool
willHookNext String
n X Bool -> X Bool -> X Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<||> String -> X Bool
willHookAllNew String
n

-- | Whether the next window will trigger the hook @name@.
willHookNext :: String -> X Bool
willHookNext :: String -> X Bool
willHookNext String
n = String -> ((Bool, Bool) -> Bool) -> X Bool
forall a. String -> ((Bool, Bool) -> a) -> X a
_get String
n (Bool, Bool) -> Bool
forall a b. (a, b) -> a
fst

-- | Whether new windows will trigger the hook @name@.
willHookAllNew :: String -> X Bool
willHookAllNew :: String -> X Bool
willHookAllNew String
n = String -> ((Bool, Bool) -> Bool) -> X Bool
forall a. String -> ((Bool, Bool) -> a) -> X a
_get String
n (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd

-- $pp
-- The following functions are used to display the current
-- state of 'hookNext' and 'hookAllNew' in your
-- "XMonad.Hooks.StatusBar". 'willHookNextPP' and
-- 'willHookAllNewPP' should be added to the
-- 'XMonad.Hooks.StatusBar.PP.ppExtras' field of your
-- "XMonad.Hooks.StatusBar.PP".
--
-- Use 'runLogHook' to refresh the output of your 'logHook', so
-- that the effects of a 'hookNext'/... will be visible
-- immediately:
--
-- > , ((modm, xK_e), toggleHookNext "float" >> runLogHook)
--
-- The @String -> String@ parameters to 'willHookNextPP' and
-- 'willHookAllNewPP' will be applied to their output, you
-- can use them to set the text color, etc., or you can just
-- pass them 'id'.

willHookNextPP :: String -> (String -> String) -> X (Maybe String)
willHookNextPP :: String -> (String -> String) -> X (Maybe String)
willHookNextPP String
n = String
-> ((Bool, Bool) -> Bool)
-> String
-> (String -> String)
-> X (Maybe String)
_pp String
n (Bool, Bool) -> Bool
forall a b. (a, b) -> a
fst String
"Next"

willHookAllNewPP :: String -> (String -> String) -> X (Maybe String)
willHookAllNewPP :: String -> (String -> String) -> X (Maybe String)
willHookAllNewPP String
n = String
-> ((Bool, Bool) -> Bool)
-> String
-> (String -> String)
-> X (Maybe String)
_pp String
n (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd String
"All"

runLogHook :: X ()
runLogHook :: X ()
runLogHook = X (X ()) -> X ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (X (X ()) -> X ()) -> X (X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ (XConf -> X ()) -> X (X ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((XConf -> X ()) -> X (X ())) -> (XConf -> X ()) -> X (X ())
forall a b. (a -> b) -> a -> b
$ 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