{-# 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)
import XMonad
import Control.Arrow(Arrow((&&&), second, (***)))
import Data.Bits(Bits((.&.), complement))
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' :: a -> NamedAction
sendMessage' a
x = (X (), String) -> NamedAction
forall a. HasName a => a -> NamedAction
NamedAction (a -> X ()
forall a. Message a => a -> X ()
XMonad.sendMessage a
x,a -> String
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 (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn String
x

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

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

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

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

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

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

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

instance HasName NamedAction where
    showName :: NamedAction -> [String]
showName (NamedAction a
x) = a -> [String]
forall a. HasName a => a -> [String]
showName a
x
    getAction :: NamedAction -> X ()
getAction (NamedAction a
x) = 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 :: [((KeyMask, KeySym), a)] -> NamedAction
submapName = (X (), [String]) -> NamedAction
forall a. HasName a => a -> NamedAction
NamedAction ((X (), [String]) -> NamedAction)
-> ([((KeyMask, KeySym), a)] -> (X (), [String]))
-> [((KeyMask, KeySym), a)]
-> NamedAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyMask, KeySym) (X ()) -> X ()
submap (Map (KeyMask, KeySym) (X ()) -> X ())
-> ([((KeyMask, KeySym), NamedAction)]
    -> Map (KeyMask, KeySym) (X ()))
-> [((KeyMask, KeySym), NamedAction)]
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedAction -> X ())
-> Map (KeyMask, KeySym) NamedAction
-> Map (KeyMask, KeySym) (X ())
forall a b k. (a -> b) -> Map k a -> Map k b
M.map NamedAction -> X ()
forall a. HasName a => a -> X ()
getAction (Map (KeyMask, KeySym) NamedAction -> Map (KeyMask, KeySym) (X ()))
-> ([((KeyMask, KeySym), NamedAction)]
    -> Map (KeyMask, KeySym) NamedAction)
-> [((KeyMask, KeySym), NamedAction)]
-> Map (KeyMask, KeySym) (X ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((KeyMask, KeySym), NamedAction)]
-> Map (KeyMask, KeySym) NamedAction
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, KeySym), NamedAction)] -> X ())
-> ([((KeyMask, KeySym), NamedAction)] -> [String])
-> [((KeyMask, KeySym), NamedAction)]
-> (X (), [String])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [((KeyMask, KeySym), NamedAction)] -> [String]
showKm)
                ([((KeyMask, KeySym), NamedAction)] -> (X (), [String]))
-> ([((KeyMask, KeySym), a)] -> [((KeyMask, KeySym), NamedAction)])
-> [((KeyMask, KeySym), a)]
-> (X (), [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((KeyMask, KeySym), a) -> ((KeyMask, KeySym), NamedAction))
-> [((KeyMask, KeySym), a)] -> [((KeyMask, KeySym), NamedAction)]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> NamedAction)
-> ((KeyMask, KeySym), a) -> ((KeyMask, KeySym), NamedAction)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second a -> NamedAction
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 ^++^ :: [(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
^++^ [(d, b1)]
b = ((d, b) -> (d, NamedAction)) -> [(d, b)] -> [(d, NamedAction)]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> NamedAction) -> (d, b) -> (d, NamedAction)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second b -> NamedAction
forall a. HasName a => a -> NamedAction
NamedAction) [(d, b)]
a [(d, NamedAction)] -> [(d, NamedAction)] -> [(d, NamedAction)]
forall a. [a] -> [a] -> [a]
++ ((d, b1) -> (d, NamedAction)) -> [(d, b1)] -> [(d, NamedAction)]
forall a b. (a -> b) -> [a] -> [b]
map ((b1 -> NamedAction) -> (d, b1) -> (d, NamedAction)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second b1 -> NamedAction
forall a. HasName a => a -> NamedAction
NamedAction) [(d, b1)]
b

-- | Or allow another lookup table?
modToString :: KeyMask -> String
modToString :: KeyMask -> String
modToString KeyMask
mask = ShowS -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> ShowS
forall a. [a] -> [a] -> [a]
++String
"-") ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
                ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((KeyMask, String) -> String) -> [(KeyMask, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((KeyMask -> ShowS) -> (KeyMask, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry KeyMask -> ShowS
pick)
                [(KeyMask
mod1Mask, String
"M1")
                ,(KeyMask
mod2Mask, String
"M2")
                ,(KeyMask
mod3Mask, String
"M3")
                ,(KeyMask
mod4Mask, String
"M4")
                ,(KeyMask
mod5Mask, String
"M5")
                ,(KeyMask
controlMask, String
"C")
                ,(KeyMask
shiftMask,String
"Shift")]
    where pick :: KeyMask -> ShowS
pick KeyMask
m String
str = if KeyMask
m KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.&. KeyMask -> KeyMask
forall a. Bits a => a -> a
complement KeyMask
mask KeyMask -> KeyMask -> Bool
forall a. Eq a => a -> a -> Bool
== KeyMask
0 then String
str else String
""

keyToString :: (KeyMask, KeySym) -> [Char]
keyToString :: (KeyMask, KeySym) -> String
keyToString = (String -> ShowS) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> ShowS
forall a. [a] -> [a] -> [a]
(++) ((String, String) -> String)
-> ((KeyMask, KeySym) -> (String, String))
-> (KeyMask, KeySym)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyMask -> String
modToString (KeyMask -> String)
-> (KeySym -> String) -> (KeyMask, KeySym) -> (String, String)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** KeySym -> String
keysymToString)

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

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

_test :: String
_test :: String
_test = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [((KeyMask, KeySym), NamedAction)] -> [String]
showKm ([((KeyMask, KeySym), NamedAction)] -> [String])
-> [((KeyMask, KeySym), NamedAction)] -> [String]
forall a b. (a -> b) -> a -> b
$ XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
defaultKeysDescr XConfig (Choose Tall (Choose (Mirror Tall) Full))
forall a. Default a => a
XMonad.def { layoutHook :: Layout KeySym
XMonad.layoutHook = Choose Tall (Choose (Mirror Tall) Full) KeySym -> Layout KeySym
forall a (l :: * -> *).
(LayoutClass l a, Read (l a)) =>
l a -> Layout a
XMonad.Layout (Choose Tall (Choose (Mirror Tall) Full) KeySym -> Layout KeySym)
-> Choose Tall (Choose (Mirror Tall) Full) KeySym -> Layout KeySym
forall a b. (a -> b) -> a -> b
$ XConfig (Choose Tall (Choose (Mirror Tall) Full))
-> Choose Tall (Choose (Mirror Tall) Full) KeySym
forall (l :: * -> *). XConfig l -> l KeySym
XMonad.layoutHook XConfig (Choose Tall (Choose (Mirror Tall) Full))
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 ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ do
    ((KeyMask, KeySym)
k,NamedAction
e) <- [((KeyMask, KeySym), NamedAction)]
keybindings
    if (KeyMask, KeySym) -> KeySym
forall a b. (a, b) -> b
snd (KeyMask, KeySym)
k KeySym -> KeySym -> Bool
forall a. Eq a => a -> a -> Bool
== KeySym
0 then (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String
"",) ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ NamedAction -> [String]
forall a. HasName a => a -> [String]
showName NamedAction
e
        else (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) ((KeyMask, KeySym) -> String
keyToString (KeyMask, KeySym)
k) (String -> (String, String)) -> ShowS -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
smartSpace) ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ NamedAction -> [String]
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 String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
k then String
"\n>> "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
e else Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
n (String
kString -> ShowS
forall a. [a] -> [a] -> [a]
++Char -> String
forall a. a -> [a]
repeat Char
' ') String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
                        expand :: [(String, String)] -> Int -> [String]
expand [(String, String)]
xs Int
n = ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> (String, String) -> String
pad Int
n) [(String, String)]
xs
                        getMax :: [[([a], b)]] -> [Int]
getMax = ([([a], b)] -> Int) -> [[([a], b)]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> ([([a], b)] -> [Int]) -> [([a], b)] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([a], b) -> Int) -> [([a], b)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> (([a], b) -> [a]) -> ([a], b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a], b) -> [a]
forall a b. (a, b) -> a
fst))
            in [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String])
-> ([(String, String)] -> [[String]])
-> [(String, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(String, String)] -> Int -> [String])
-> [[(String, String)]] -> [Int] -> [[String]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [(String, String)] -> Int -> [String]
expand ([[(String, String)]] -> [Int] -> [[String]])
-> ([[(String, String)]] -> [Int])
-> [[(String, String)]]
-> [[String]]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[(String, String)]] -> [Int]
forall a b. [[([a], b)]] -> [Int]
getMax) ([[(String, String)]] -> [[String]])
-> ([(String, String)] -> [[(String, String)]])
-> [(String, String)]
-> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> (String, String) -> Bool)
-> [(String, String)] -> [[(String, String)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (((String, String) -> Bool)
-> (String, String) -> (String, String) -> Bool
forall a b. a -> b -> a
const (((String, String) -> Bool)
 -> (String, String) -> (String, String) -> Bool)
-> ((String, String) -> Bool)
-> (String, String)
-> (String, String)
-> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool)
-> ((String, String) -> Bool) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
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" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
xmessage (String -> X ()) -> String -> X ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
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 :: ((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 = ((KeyMask, KeySym), [((KeyMask, KeySym), NamedAction)] -> b)
-> (XConfig Layout -> [((KeyMask, KeySym), NamedAction)])
-> XConfig l
-> XConfig l
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 [((KeyMask, KeySym), NamedAction)]
-> [((KeyMask, KeySym), b1)] -> [((KeyMask, KeySym), NamedAction)]
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' :: ((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 ([((KeyMask, KeySym), NamedAction)] -> b)
-> [((KeyMask, KeySym), NamedAction)] -> b
forall a b. (a -> b) -> a -> b
$ [((KeyMask, KeySym)
k,[((KeyMask, KeySym), NamedAction)] -> b
f ([((KeyMask, KeySym), NamedAction)] -> b)
-> [((KeyMask, KeySym), NamedAction)] -> b
forall a b. (a -> b) -> a -> b
$ XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
ks XConfig Layout
l)] [((KeyMask, KeySym), b)]
-> [((KeyMask, KeySym), NamedAction)]
-> [((KeyMask, KeySym), NamedAction)]
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 = (NamedAction -> X ())
-> Map (KeyMask, KeySym) NamedAction
-> Map (KeyMask, KeySym) (X ())
forall a b k. (a -> b) -> Map k a -> Map k b
M.map NamedAction -> X ()
forall a. HasName a => a -> X ()
getAction (Map (KeyMask, KeySym) NamedAction -> Map (KeyMask, KeySym) (X ()))
-> Map (KeyMask, KeySym) NamedAction
-> Map (KeyMask, KeySym) (X ())
forall a b. (a -> b) -> a -> b
$ [((KeyMask, KeySym), NamedAction)]
-> Map (KeyMask, KeySym) NamedAction
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, KeySym), NamedAction)]
 -> Map (KeyMask, KeySym) NamedAction)
-> [((KeyMask, KeySym), NamedAction)]
-> Map (KeyMask, KeySym) NamedAction
forall a b. (a -> b) -> a -> b
$ XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
ks XConfig Layout
l [((KeyMask, KeySym), NamedAction)]
-> [((KeyMask, KeySym), b)] -> [((KeyMask, KeySym), NamedAction)]
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 }

-- | 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 KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_Return), String -> X () -> NamedAction
addName String
"Launch Terminal" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn (String -> X ()) -> String -> X ()
forall a b. (a -> b) -> a -> b
$ XConfig Layout -> String
forall (l :: * -> *). XConfig l -> String
XMonad.terminal XConfig Layout
conf) -- %! Launch terminal
    , ((KeyMask
modm,               KeySym
xK_p     ), String -> X () -> NamedAction
addName String
"Launch dmenu" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn String
"exe=`dmenu_path | dmenu` && eval \"exec $exe\"") -- %! Launch dmenu
    , ((KeyMask
modm KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_p     ), String -> X () -> NamedAction
addName String
"Launch gmrun" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn String
"gmrun") -- %! Launch gmrun
    , ((KeyMask
modm KeyMask -> KeyMask -> KeyMask
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 ), ChangeLayout -> NamedAction
forall a. (Message a, Show a) => a -> NamedAction
sendMessage' ChangeLayout
NextLayout) -- %! Rotate through the available layout algorithms
    , ((KeyMask
modm KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_space ), String -> X () -> NamedAction
addName String
"Reset the layout" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ Layout KeySym -> X ()
setLayout (Layout KeySym -> X ()) -> Layout KeySym -> X ()
forall a b. (a -> b) -> a -> b
$ XConfig Layout -> Layout KeySym
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" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows WindowSet -> WindowSet
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 KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_Tab   ), String -> X () -> NamedAction
addName String
"Focus up"   (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows WindowSet -> WindowSet
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" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows WindowSet -> WindowSet
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"   (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows WindowSet -> WindowSet
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" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows WindowSet -> WindowSet
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" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows WindowSet -> WindowSet
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 KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_j     ), String -> X () -> NamedAction
addName String
"Swap down" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows WindowSet -> WindowSet
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 KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_k     ), String -> X () -> NamedAction
addName String
"Swap up"   (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows WindowSet -> WindowSet
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     ), Resize -> NamedAction
forall a. (Message a, Show a) => a -> NamedAction
sendMessage' Resize
Shrink) -- %! Shrink the master area
    , ((KeyMask
modm,               KeySym
xK_l     ), Resize -> NamedAction
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" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ (KeySym -> X ()) -> X ()
withFocused ((KeySym -> X ()) -> X ()) -> (KeySym -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (KeySym -> WindowSet -> WindowSet) -> KeySym -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeySym -> WindowSet -> WindowSet
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 ), IncMasterN -> NamedAction
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), IncMasterN -> NamedAction
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 KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_q     ), String -> X () -> NamedAction
addName String
"Quit" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO ()
forall a. IO a
exitSuccess) -- %! Quit xmonad
    , ((KeyMask
modm              , KeySym
xK_q     ), String -> X () -> NamedAction
addName String
"Restart" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ String -> X ()
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
    [((KeyMask, KeySym), NamedAction)]
-> [((KeyMask, KeySym), NamedAction)]
-> [((KeyMask, KeySym), NamedAction)]
forall a. [a] -> [a] -> [a]
++
    String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"switching workspaces"((KeyMask, KeySym), NamedAction)
-> [((KeyMask, KeySym), NamedAction)]
-> [((KeyMask, KeySym), NamedAction)]
forall a. a -> [a] -> [a]
:
    [((KeyMask
m KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
modm, KeySym
k), String -> X () -> NamedAction
addName (String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i) (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ String -> WindowSet -> WindowSet
f String
i)
        | (String -> WindowSet -> WindowSet
f, KeyMask
m, String
n) <- [(String -> WindowSet -> WindowSet
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 "), (String -> WindowSet -> WindowSet
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) <- [String] -> [KeySym] -> [(String, KeySym)]
forall a b. [a] -> [b] -> [(a, b)]
zip (XConfig Layout -> [String]
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
   [((KeyMask, KeySym), NamedAction)]
-> [((KeyMask, KeySym), NamedAction)]
-> [((KeyMask, KeySym), NamedAction)]
forall a. [a] -> [a] -> [a]
++
   String -> ((KeyMask, KeySym), NamedAction)
subtitle String
"switching screens" ((KeyMask, KeySym), NamedAction)
-> [((KeyMask, KeySym), NamedAction)]
-> [((KeyMask, KeySym), NamedAction)]
forall a. a -> [a] -> [a]
:
   [((KeyMask
m KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
modm, KeySym
key), String -> X () -> NamedAction
addName (String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScreenId -> String
forall a. Show a => a -> String
show ScreenId
sc) (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ ScreenId -> X (Maybe String)
screenWorkspace ScreenId
sc X (Maybe String) -> (Maybe String -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe String -> (String -> X ()) -> X ())
-> (String -> X ()) -> Maybe String -> X ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe String -> (String -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust ((WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (String -> WindowSet -> WindowSet) -> String -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> WindowSet -> WindowSet
f))
        | (String -> WindowSet -> WindowSet
f, KeyMask
m, String
n) <- [(String -> WindowSet -> WindowSet
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 "), (String -> WindowSet -> WindowSet
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) <- [KeySym] -> [ScreenId] -> [(KeySym, ScreenId)]
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), (X (), [String]) -> NamedAction
forall a. HasName a => a -> NamedAction
NamedAction (() -> X ()
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), String -> NamedAction
forall a. HasName a => a -> NamedAction
NamedAction (String -> NamedAction) -> String -> NamedAction
forall a b. (a -> b) -> a -> b
$ String
x String -> ShowS
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 = X () -> NamedAction
forall a. HasName a => a -> NamedAction
NamedAction

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

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