{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, StandaloneDeriving #-}
--------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.NamedActions
-- 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
import System.Posix.Process(executeFile)
import Control.Arrow(Arrow((&&&), second, (***)))
import Data.Bits(Bits((.&.), complement))
import Data.List (groupBy)
import System.Exit(ExitCode(ExitSuccess), exitWith)

import Control.Applicative ((<*>))

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' x :: a
x = (X (), String) -> NamedAction
forall a. HasName a => a -> NamedAction
NamedAction ((X (), String) -> NamedAction) -> (X (), String) -> NamedAction
forall a b. (a -> b) -> a -> b
$ (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' x :: 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
    showName :: a -> [String]
    showName = [String] -> a -> [String]
forall a b. a -> b -> a
const [""]
    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 _ = () -> 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 x :: a
x) = a -> [String]
forall a. HasName a => a -> [String]
showName a
x
    getAction :: NamedAction -> X ()
getAction (NamedAction x :: 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)]
a :: [(d, b)]
a ^++^ :: [(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
^++^ b :: [(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 mask :: 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
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, "M1")
                ,(KeyMask
mod2Mask, "M2")
                ,(KeyMask
mod3Mask, "M3")
                ,(KeyMask
mod4Mask, "M4")
                ,(KeyMask
mod5Mask, "M5")
                ,(KeyMask
controlMask, "C")
                ,(KeyMask
shiftMask,"Shift")]
    where pick :: KeyMask -> ShowS
pick m :: KeyMask
m str :: 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
== 0 then String
str else ""

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 (\(k :: (KeyMask, KeySym)
k,e :: 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
== 0 then ""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 xs :: String
xs = ' '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 keybindings :: [((KeyMask, KeySym), NamedAction)]
keybindings = [(String, String)] -> [String]
padding ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ do
    (k :: (KeyMask, KeySym)
k,e :: 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
== 0 then (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) "") ([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 n :: Int
n (k :: String
k,e :: String
e) = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
k then "\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 ' ') String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
                        expand :: [(String, String)] -> Int -> [String]
expand xs :: [(String, String)]
xs n :: 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 x :: [((KeyMask, KeySym), NamedAction)]
x = String -> X () -> NamedAction
addName "Show Keybindings" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> IO ProcessID
forall (m :: * -> *). MonadIO m => IO () -> m ProcessID
xfork (IO () -> IO ProcessID) -> IO () -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ String -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile "xmessage" Bool
True ["-default", "okay", [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [((KeyMask, KeySym), NamedAction)] -> [String]
showKm [((KeyMask, KeySym), NamedAction)]
x] Maybe [(String, String)]
forall a. Maybe a
Nothing
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | 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 k :: ((KeyMask, KeySym), [((KeyMask, KeySym), NamedAction)] -> b)
k ks :: 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 (\l :: 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' (k :: (KeyMask, KeySym)
k,f :: [((KeyMask, KeySym), NamedAction)] -> b
f) ks :: XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
ks conf :: XConfig l
conf =
    let shk :: XConfig Layout -> b
shk l :: 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 l :: 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 "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 "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 "Launch dmenu" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn "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 "Launch gmrun" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn "gmrun") -- %! Launch gmrun
    , ((KeyMask
modm KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_c     ), String -> X () -> NamedAction
addName "Close the focused window" X ()
kill) -- %! Close the focused window

    , String -> ((KeyMask, KeySym), NamedAction)
subtitle "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 "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 "Refresh" X ()
refresh) -- %! Resize viewed windows to the correct size

    , String -> ((KeyMask, KeySym), NamedAction)
subtitle "move focus up or down the window stack"
    , ((KeyMask
modm,               KeySym
xK_Tab   ), String -> X () -> NamedAction
addName "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 "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 "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 "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 "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 "modifying the window order"
    , ((KeyMask
modm,               KeySym
xK_Return), String -> X () -> NamedAction
addName "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 "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 "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 "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 "floating layer support"
    , ((KeyMask
modm,               KeySym
xK_t     ), String -> X () -> NamedAction
addName "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 "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 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 (-1))) -- %! Deincrement the number of windows in the master area

    , String -> ((KeyMask, KeySym), NamedAction)
subtitle "quit, or restart"
    , ((KeyMask
modm KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.|. KeyMask
shiftMask, KeySym
xK_q     ), String -> X () -> NamedAction
addName "Quit" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess)) -- %! Quit xmonad
    , ((KeyMask
modm              , KeySym
xK_q     ), String -> X () -> NamedAction
addName "Restart" (X () -> NamedAction) -> X () -> NamedAction
forall a b. (a -> b) -> a -> b
$ String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn "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 "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)
        | (f :: String -> WindowSet -> WindowSet
f, m :: KeyMask
m, n :: 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, 0, "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, "Move client to workspace ")]
        , (i :: String
i, k :: 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 "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))
        | (f :: String -> WindowSet -> WindowSet
f, m :: KeyMask
m, n :: 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, 0, "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, "Move client to screen number ")]
        , (key :: KeySym
key, sc :: ScreenId
sc) <- [KeySym] -> [ScreenId] -> [(KeySym, ScreenId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [KeySym
xK_w, KeySym
xK_e, KeySym
xK_r] [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 = ((0,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 x :: String
x = ((0,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]
++ ":")

-- | 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)