{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, StandaloneDeriving, TupleSections #-}
--------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.NamedActions
-- Description :  A wrapper for keybinding configuration that can list the available keybindings.
-- Copyright   :  2009 Adam Vogt <vogt.adam@gmail.com>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Adam Vogt <vogt.adam@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A wrapper for keybinding configuration that can list the available
-- keybindings.
--
-- Note that xmonad>=0.11 has by default a list of the default keybindings
-- bound to @M-S-/@ or @M-?@.
--------------------------------------------------------------------

module XMonad.Util.NamedActions (
    -- * Usage:
    -- $usage
    sendMessage',
    spawn',
    submapName,
    addDescrKeys,
    addDescrKeys',
    xMessage,

    showKmSimple,
    showKm,

    noName,
    oneName,
    addName,

    separator,
    subtitle,

    (^++^),

    NamedAction(..),
    HasName,
    defaultKeysDescr
    ) where


import XMonad.Actions.Submap(submap)
import XMonad.Prelude (groupBy, keyToString)
import XMonad
import Control.Arrow(Arrow((&&&), second))
import System.Exit(exitSuccess)

import qualified Data.Map as M
import qualified XMonad.StackSet as W

-- $usage
-- Here is an example config that demonstrates the usage of 'sendMessage'',
-- 'mkNamedKeymap', 'addDescrKeys', and '^++^'
--
-- > import XMonad
-- > import XMonad.Util.NamedActions
-- > import XMonad.Util.EZConfig
-- >
-- > main = xmonad $ addDescrKeys ((mod4Mask, xK_F1), xMessage) myKeys
-- >                    def { modMask = mod4Mask }
-- >
-- > myKeys c = (subtitle "Custom Keys":) $ mkNamedKeymap c $
-- >    [("M-x a", addName "useless message" $ spawn "xmessage foo"),
-- >     ("M-c", sendMessage' Expand)]
-- >     ^++^
-- >    [("<XF86AudioPlay>", spawn "mpc toggle" :: X ()),
-- >     ("<XF86AudioNext>", spawn "mpc next")]
--
-- Using '^++^', you can combine bindings whose actions are @X ()@
-- as well as actions that have descriptions. However you cannot mix the two in
-- a single list, unless each is prefixed with 'addName' or 'noName'.
--
-- If you don't like EZConfig, you can still use '^++^' with the basic XMonad
-- keybinding configuration too.
--
-- Also note the unfortunate necessity of a type annotation, since 'spawn' is
-- too general.

-- TODO: squeeze titles that have no entries (consider titles containing \n)
--
-- Output to Multiple columns
--
-- Devin Mullin's suggestions:
--
-- Reduce redundancy wrt mkNamedSubmaps, mkSubmaps and mkNamedKeymap to have a
-- HasName context (and leave mkKeymap as a specific case of it?)
--    Currently kept separate to aid error messages, common lines factored out
--
-- Suggestions for UI:
--
-- - An IO () -> IO () that wraps the main xmonad action and wrests control
--   from it if the user asks for --keys.
--
-- Just a separate binary: keep this as the only way to show keys for simplicity
--
-- - An X () that toggles a cute little overlay like the ? window for gmail
--   and reader.
--
-- Add dzen binding

deriving instance Show XMonad.Resize
deriving instance Show XMonad.IncMasterN

-- | 'sendMessage' but add a description that is @show message@. Note that not
-- all messages have show instances.
sendMessage' :: (Message a, Show a) => a -> NamedAction
sendMessage' :: forall a. (Message a, Show a) => a -> NamedAction
sendMessage' a
x = forall a. HasName a => a -> NamedAction
NamedAction (forall a. Message a => a -> X ()
XMonad.sendMessage a
x,forall a. Show a => a -> String
show a
x)

-- | 'spawn' but the description is the string passed
spawn' :: String -> NamedAction
spawn' :: String -> NamedAction
spawn' String
x = String -> X () -> NamedAction
addName String
x forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m ()
spawn String
x

class HasName a where
    {-# MINIMAL getAction #-}
    showName :: a -> [String]
    showName = forall a b. a -> b -> a
const [String
""]
    getAction :: a -> X ()

instance HasName (X ()) where
    getAction :: X () -> X ()
getAction = forall a. a -> a
id

instance HasName (IO ()) where
    getAction :: IO () -> X ()
getAction = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io

instance HasName [Char] where
    getAction :: String -> X ()
getAction String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    showName :: String -> [String]
showName = (forall a. a -> [a] -> [a]
:[])

instance HasName (X (),String) where
    showName :: (X (), String) -> [String]
showName = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
    getAction :: (X (), String) -> X ()
getAction = forall a b. (a, b) -> a
fst

instance HasName (X (),[String]) where
    showName :: (X (), [String]) -> [String]
showName = forall a b. (a, b) -> b
snd
    getAction :: (X (), [String]) -> X ()
getAction = forall a b. (a, b) -> a
fst

-- show only the outermost description
instance HasName (NamedAction,String) where
    showName :: (NamedAction, String) -> [String]
showName = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
    getAction :: (NamedAction, String) -> X ()
getAction = forall a. HasName a => a -> X ()
getAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst

instance HasName NamedAction where
    showName :: NamedAction -> [String]
showName (NamedAction a
x) = forall a. HasName a => a -> [String]
showName a
x
    getAction :: NamedAction -> X ()
getAction (NamedAction a
x) = forall a. HasName a => a -> X ()
getAction a
x

-- | An existential wrapper so that different types can be combined in lists,
-- and maps
data NamedAction = forall a. HasName a => NamedAction a

-- | 'submap', but propagate the descriptions of the actions. Does this belong
-- in "XMonad.Actions.Submap"?
submapName :: (HasName a) => [((KeyMask, KeySym), a)] -> NamedAction
submapName :: forall a. HasName a => [((KeyMask, KeySym), a)] -> NamedAction
submapName = forall a. HasName a => a -> NamedAction
NamedAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyMask, KeySym) (X ()) -> X ()
submap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall a. HasName a => a -> X ()
getAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [((KeyMask, KeySym), NamedAction)] -> [String]
showKm)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. HasName a => a -> NamedAction
NamedAction)

-- | Combine keymap lists with actions that may or may not have names
(^++^) :: (HasName b, HasName b1) =>
     [(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
[(d, b)]
a ^++^ :: forall b b1 d.
(HasName b, HasName b1) =>
[(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
^++^ [(d, b1)]
b = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. HasName a => a -> NamedAction
NamedAction) [(d, b)]
a forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. HasName a => a -> NamedAction
NamedAction) [(d, b1)]
b

showKmSimple :: [((KeyMask, KeySym), NamedAction)] -> [[Char]]
showKmSimple :: [((KeyMask, KeySym), NamedAction)] -> [String]
showKmSimple = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\((KeyMask, KeySym)
k,NamedAction
e) -> if forall a b. (a, b) -> b
snd (KeyMask, KeySym)
k forall a. Eq a => a -> a -> Bool
== KeySym
0 then String
""forall a. a -> [a] -> [a]
:forall a. HasName a => a -> [String]
showName NamedAction
e else forall a b. (a -> b) -> [a] -> [b]
map (((KeyMask, KeySym) -> String
keyToString (KeyMask, KeySym)
k forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
smartSpace) forall a b. (a -> b) -> a -> b
$ forall a. HasName a => a -> [String]
showName NamedAction
e)

smartSpace :: String -> String
smartSpace :: ShowS
smartSpace [] = []
smartSpace String
xs = Char
' 'forall a. a -> [a] -> [a]
:String
xs

_test :: String
_test :: String
_test = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ [((KeyMask, KeySym), NamedAction)] -> [String]
showKm forall a b. (a -> b) -> a -> b
$ XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
defaultKeysDescr forall a. Default a => a
XMonad.def { layoutHook :: Layout KeySym
XMonad.layoutHook = forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
XMonad.Layout forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> l KeySym
XMonad.layoutHook forall a. Default a => a
XMonad.def }

showKm :: [((KeyMask, KeySym), NamedAction)] -> [String]
showKm :: [((KeyMask, KeySym), NamedAction)] -> [String]
showKm [((KeyMask, KeySym), NamedAction)]
keybindings = [(String, String)] -> [String]
padding forall a b. (a -> b) -> a -> b
$ do
    ((KeyMask, KeySym)
k,NamedAction
e) <- [((KeyMask, KeySym), NamedAction)]
keybindings
    if forall a b. (a, b) -> b
snd (KeyMask, KeySym)
k forall a. Eq a => a -> a -> Bool
== KeySym
0 then forall a b. (a -> b) -> [a] -> [b]
map (String
"",) forall a b. (a -> b) -> a -> b
$ forall a. HasName a => a -> [String]
showName NamedAction
e
        else forall a b. (a -> b) -> [a] -> [b]
map ((,) ((KeyMask, KeySym) -> String
keyToString (KeyMask, KeySym)
k) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
smartSpace) forall a b. (a -> b) -> a -> b
$ forall a. HasName a => a -> [String]
showName NamedAction
e
    where padding :: [(String, String)] -> [String]
padding = let pad :: Int -> (String, String) -> String
pad Int
n (String
k,String
e) = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
k then String
"\n>> "forall a. [a] -> [a] -> [a]
++String
e else forall a. Int -> [a] -> [a]
take Int
n (String
kforall a. [a] -> [a] -> [a]
++forall a. a -> [a]
repeat Char
' ') forall a. [a] -> [a] -> [a]
++ String
e
                        expand :: [(String, String)] -> Int -> [String]
expand [(String, String)]
xs Int
n = forall a b. (a -> b) -> [a] -> [b]
map (Int -> (String, String) -> String
pad Int
n) [(String, String)]
xs
                        getMax :: [[([a], b)]] -> [Int]
getMax = forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst))
            in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [(String, String)] -> Int -> [String]
expand forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {a} {b}. [[([a], b)]] -> [Int]
getMax) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

-- | An action to send to 'addDescrKeys' for showing the keybindings. See also 'showKm' and 'showKmSimple'
xMessage :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
xMessage :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
xMessage [((KeyMask, KeySym), NamedAction)]
x = String -> X () -> NamedAction
addName String
"Show Keybindings" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m ()
xmessage forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ [((KeyMask, KeySym), NamedAction)] -> [String]
showKm [((KeyMask, KeySym), NamedAction)]
x

-- | Merge the supplied keys with 'defaultKeysDescr', also adding a keybinding
-- to run an action for showing the keybindings.
addDescrKeys :: (HasName b1, HasName b) =>
    ((KeyMask, KeySym),[((KeyMask, KeySym), NamedAction)] -> b)
    -> (XConfig Layout -> [((KeyMask, KeySym), b1)])
    -> XConfig l
    -> XConfig l
addDescrKeys :: forall b1 b (l :: * -> *).
(HasName b1, HasName b) =>
((KeyMask, KeySym), [((KeyMask, KeySym), NamedAction)] -> b)
-> (XConfig Layout -> [((KeyMask, KeySym), b1)])
-> XConfig l
-> XConfig l
addDescrKeys ((KeyMask, KeySym), [((KeyMask, KeySym), NamedAction)] -> b)
k XConfig Layout -> [((KeyMask, KeySym), b1)]
ks = forall b (l :: * -> *).
HasName b =>
((KeyMask, KeySym), [((KeyMask, KeySym), NamedAction)] -> b)
-> (XConfig Layout -> [((KeyMask, KeySym), NamedAction)])
-> XConfig l
-> XConfig l
addDescrKeys' ((KeyMask, KeySym), [((KeyMask, KeySym), NamedAction)] -> b)
k (\XConfig Layout
l -> XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
defaultKeysDescr XConfig Layout
l forall b b1 d.
(HasName b, HasName b1) =>
[(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
^++^ XConfig Layout -> [((KeyMask, KeySym), b1)]
ks XConfig Layout
l)

-- | Without merging with 'defaultKeysDescr'
addDescrKeys' :: (HasName b) =>
    ((KeyMask, KeySym),[((KeyMask, KeySym), NamedAction)] -> b)
    -> (XConfig Layout -> [((KeyMask, KeySym), NamedAction)]) -> XConfig l -> XConfig l
addDescrKeys' :: forall b (l :: * -> *).
HasName b =>
((KeyMask, KeySym), [((KeyMask, KeySym), NamedAction)] -> b)
-> (XConfig Layout -> [((KeyMask, KeySym), NamedAction)])
-> XConfig l
-> XConfig l
addDescrKeys' ((KeyMask, KeySym)
k,[((KeyMask, KeySym), NamedAction)] -> b
f) XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
ks XConfig l
conf =
    let shk :: XConfig Layout -> b
shk XConfig Layout
l = [((KeyMask, KeySym), NamedAction)] -> b
f forall a b. (a -> b) -> a -> b
$ [((KeyMask, KeySym)
k,[((KeyMask, KeySym), NamedAction)] -> b
f forall a b. (a -> b) -> a -> b
$ XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
ks XConfig Layout
l)] forall b b1 d.
(HasName b, HasName b1) =>
[(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
^++^ XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
ks XConfig Layout
l
        keylist :: XConfig Layout -> Map (KeyMask, KeySym) (X ())
keylist XConfig Layout
l = forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall a. HasName a => a -> X ()
getAction forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
ks XConfig Layout
l forall b b1 d.
(HasName b, HasName b1) =>
[(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
^++^ [((KeyMask, KeySym)
k, XConfig Layout -> b
shk XConfig Layout
l)]
     in XConfig l
conf { keys :: XConfig Layout -> Map (KeyMask, KeySym) (X ())
keys = XConfig Layout -> Map (KeyMask, KeySym) (X ())
keylist forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *).
XConfig l -> XConfig Layout -> Map (KeyMask, KeySym) (X ())
keys XConfig l
conf }

-- | A version of the default keys from the default configuration, but with
-- 'NamedAction'  instead of @X ()@
defaultKeysDescr :: XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
defaultKeysDescr :: XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
defaultKeysDescr conf :: XConfig Layout
conf@XConfig{modMask :: forall (l :: * -> *). XConfig l -> KeyMask
XMonad.modMask = KeyMask
modm} =
    [ String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"launching and killing programs"
    , ((KeyMask
modm forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_Return), String -> X () -> NamedAction
addName String
"Launch Terminal" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m ()
spawn forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> String
XMonad.terminal XConfig Layout
conf) -- %! Launch terminal
    , ((KeyMask
modm,               KeySym
xK_p     ), String -> X () -> NamedAction
addName String
"Launch dmenu" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m ()
spawn String
"exe=`dmenu_path | dmenu` && eval \"exec $exe\"") -- %! Launch dmenu
    , ((KeyMask
modm forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_p     ), String -> X () -> NamedAction
addName String
"Launch gmrun" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m ()
spawn String
"gmrun") -- %! Launch gmrun
    , ((KeyMask
modm forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_c     ), String -> X () -> NamedAction
addName String
"Close the focused window" X ()
kill) -- %! Close the focused window

    , String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"changing layouts"
    , ((KeyMask
modm,               KeySym
xK_space ), forall a. (Message a, Show a) => a -> NamedAction
sendMessage' ChangeLayout
NextLayout) -- %! Rotate through the available layout algorithms
    , ((KeyMask
modm forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_space ), String -> X () -> NamedAction
addName String
"Reset the layout" forall a b. (a -> b) -> a -> b
$ Layout KeySym -> X ()
setLayout forall a b. (a -> b) -> a -> b
$ forall (l :: * -> *). XConfig l -> l KeySym
XMonad.layoutHook XConfig Layout
conf) -- %!  Reset the layouts on the current workspace to default

    , ((KeyMask, KeySym), NamedAction)
separator
    , ((KeyMask
modm,               KeySym
xK_n     ), String -> X () -> NamedAction
addName String
"Refresh" X ()
refresh) -- %! Resize viewed windows to the correct size

    , String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"move focus up or down the window stack"
    , ((KeyMask
modm,               KeySym
xK_Tab   ), String -> X () -> NamedAction
addName String
"Focus down" forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.focusDown) -- %! Move focus to the next window
    , ((KeyMask
modm forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_Tab   ), String -> X () -> NamedAction
addName String
"Focus up"   forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.focusUp  ) -- %! Move focus to the previous window
    , ((KeyMask
modm,               KeySym
xK_j     ), String -> X () -> NamedAction
addName String
"Focus down" forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.focusDown) -- %! Move focus to the next window
    , ((KeyMask
modm,               KeySym
xK_k     ), String -> X () -> NamedAction
addName String
"Focus up"   forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.focusUp  ) -- %! Move focus to the previous window
    , ((KeyMask
modm,               KeySym
xK_m     ), String -> X () -> NamedAction
addName String
"Focus the master" forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.focusMaster  ) -- %! Move focus to the master window

    , String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"modifying the window order"
    , ((KeyMask
modm,               KeySym
xK_Return), String -> X () -> NamedAction
addName String
"Swap with the master" forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.swapMaster) -- %! Swap the focused window and the master window
    , ((KeyMask
modm forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_j     ), String -> X () -> NamedAction
addName String
"Swap down" forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.swapDown  ) -- %! Swap the focused window with the next window
    , ((KeyMask
modm forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_k     ), String -> X () -> NamedAction
addName String
"Swap up"   forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall i l a s sd. StackSet i l a s sd -> StackSet i l a s sd
W.swapUp    ) -- %! Swap the focused window with the previous window

    , String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"resizing the master/slave ratio"
    , ((KeyMask
modm,               KeySym
xK_h     ), forall a. (Message a, Show a) => a -> NamedAction
sendMessage' Resize
Shrink) -- %! Shrink the master area
    , ((KeyMask
modm,               KeySym
xK_l     ), forall a. (Message a, Show a) => a -> NamedAction
sendMessage' Resize
Expand) -- %! Expand the master area

    , String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"floating layer support"
    , ((KeyMask
modm,               KeySym
xK_t     ), String -> X () -> NamedAction
addName String
"Push floating to tiled" forall a b. (a -> b) -> a -> b
$ (KeySym -> X ()) -> X ()
withFocused forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a i l s sd.
Ord a =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.sink) -- %! Push window back into tiling

    , String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"change the number of windows in the master area"
    , ((KeyMask
modm              , KeySym
xK_comma ), forall a. (Message a, Show a) => a -> NamedAction
sendMessage' (Int -> IncMasterN
IncMasterN Int
1)) -- %! Increment the number of windows in the master area
    , ((KeyMask
modm              , KeySym
xK_period), forall a. (Message a, Show a) => a -> NamedAction
sendMessage' (Int -> IncMasterN
IncMasterN (-Int
1))) -- %! Deincrement the number of windows in the master area

    , String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"quit, or restart"
    , ((KeyMask
modm forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_q     ), String -> X () -> NamedAction
addName String
"Quit" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a. IO a
exitSuccess) -- %! Quit xmonad
    , ((KeyMask
modm              , KeySym
xK_q     ), String -> X () -> NamedAction
addName String
"Restart" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m ()
spawn String
"xmonad --recompile && xmonad --restart") -- %! Restart xmonad
    ]

    -- mod-[1..9] %! Switch to workspace N
    -- mod-shift-[1..9] %! Move client to workspace N
    forall a. [a] -> [a] -> [a]
++
    String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"switching workspaces"forall a. a -> [a] -> [a]
:
    [((KeyMask
m forall a. Bits a => a -> a -> a
.|. KeyMask
modm, KeySym
k), String -> X () -> NamedAction
addName (String
n forall a. [a] -> [a] -> [a]
++ String
i) forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ String -> WindowSet -> WindowSet
f String
i)
        | (String -> WindowSet -> WindowSet
f, KeyMask
m, String
n) <- [(forall s i l a sd.
(Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.greedyView, KeyMask
0, String
"Switch to workspace "), (forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.shift, KeyMask
shiftMask, String
"Move client to workspace ")]
        , (String
i, KeySym
k) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall (l :: * -> *). XConfig l -> [String]
XMonad.workspaces XConfig Layout
conf) [KeySym
xK_1 .. KeySym
xK_9]]
    -- mod-{w,e,r} %! Switch to physical/Xinerama screens 1, 2, or 3
    -- mod-shift-{w,e,r} %! Move client to screen 1, 2, or 3
   forall a. [a] -> [a] -> [a]
++
   String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"switching screens" forall a. a -> [a] -> [a]
:
   [((KeyMask
m forall a. Bits a => a -> a -> a
.|. KeyMask
modm, KeySym
key), String -> X () -> NamedAction
addName (String
n forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScreenId
sc) forall a b. (a -> b) -> a -> b
$ ScreenId -> X (Maybe String)
screenWorkspace ScreenId
sc forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust ((WindowSet -> WindowSet) -> X ()
windows forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> WindowSet -> WindowSet
f))
        | (String -> WindowSet -> WindowSet
f, KeyMask
m, String
n) <- [(forall s i l a sd.
(Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.view, KeyMask
0, String
"Switch to screen number "), (forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.shift, KeyMask
shiftMask, String
"Move client to screen number ")]
        , (KeySym
key, ScreenId
sc) <- forall a b. [a] -> [b] -> [(a, b)]
zip [KeySym
xK_w, KeySym
xK_e, KeySym
xK_r] [ScreenId
0..]]

-- | For a prettier presentation: keymask, keysym of 0 are reserved for this
-- purpose: they do not happen, afaik, and keysymToString 0 would raise an
-- error otherwise
separator :: ((KeyMask,KeySym), NamedAction)
separator :: ((KeyMask, KeySym), NamedAction)
separator = ((KeyMask
0,KeySym
0), forall a. HasName a => a -> NamedAction
NamedAction (forall (m :: * -> *) a. Monad m => a -> m a
return () :: X (),[] :: [String]))

subtitle ::  String -> ((KeyMask, KeySym), NamedAction)
subtitle :: String -> ((KeyMask, KeySym), NamedAction)
subtitle String
x = ((KeyMask
0,KeySym
0), forall a. HasName a => a -> NamedAction
NamedAction forall a b. (a -> b) -> a -> b
$ String
x forall a. [a] -> [a] -> [a]
++ String
":")

-- | These are just the @NamedAction@ constructor but with a more specialized
-- type, so that you don't have to supply any annotations, for ex coercing
-- spawn to @X ()@ from the more general @MonadIO m => m ()@
noName :: X () -> NamedAction
noName :: X () -> NamedAction
noName = forall a. HasName a => a -> NamedAction
NamedAction

oneName :: (X (), String) -> NamedAction
oneName :: (X (), String) -> NamedAction
oneName = forall a. HasName a => a -> NamedAction
NamedAction

addName :: String -> X () -> NamedAction
addName :: String -> X () -> NamedAction
addName = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a. HasName a => a -> NamedAction
NamedAction)