mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-05-19 03:20:21 -07:00
306 lines
12 KiB
Haskell
306 lines
12 KiB
Haskell
{-# 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.
|
|
--------------------------------------------------------------------
|
|
|
|
module XMonad.Util.NamedActions (
|
|
-- * Usage:
|
|
-- $usage
|
|
sendMessage',
|
|
spawn',
|
|
submapName,
|
|
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
|
|
-- > defaultConfig { 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' x = NamedAction $ (XMonad.sendMessage x,show x)
|
|
|
|
-- | 'spawn' but the description is the string passed
|
|
spawn' :: String -> NamedAction
|
|
spawn' x = addName x $ spawn x
|
|
|
|
class HasName a where
|
|
showName :: a -> [String]
|
|
showName = const [""]
|
|
getAction :: a -> X ()
|
|
|
|
instance HasName (X ()) where
|
|
getAction = id
|
|
|
|
instance HasName (IO ()) where
|
|
getAction = io
|
|
|
|
instance HasName [Char] where
|
|
getAction _ = return ()
|
|
showName = (:[])
|
|
|
|
instance HasName (X (),String) where
|
|
showName = (:[]) . snd
|
|
getAction = fst
|
|
|
|
instance HasName (X (),[String]) where
|
|
showName = snd
|
|
getAction = fst
|
|
|
|
-- show only the outermost description
|
|
instance HasName (NamedAction,String) where
|
|
showName = (:[]) . snd
|
|
getAction = getAction . fst
|
|
|
|
instance HasName NamedAction where
|
|
showName (NamedAction x) = showName x
|
|
getAction (NamedAction x) = getAction 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 = NamedAction . (submap . M.map getAction . M.fromList &&& showKm)
|
|
. map (second NamedAction)
|
|
|
|
-- | Combine keymap lists with actions that may or may not have names
|
|
(^++^) :: (HasName b, HasName b1) =>
|
|
[(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
|
|
a ^++^ b = map (second NamedAction) a ++ map (second NamedAction) b
|
|
|
|
-- | Or allow another lookup table?
|
|
modToString :: KeyMask -> String
|
|
modToString mask = concatMap (++"-") $ filter (not . null)
|
|
$ map (uncurry pick)
|
|
[(mod1Mask, "M1")
|
|
,(mod2Mask, "M2")
|
|
,(mod3Mask, "M3")
|
|
,(mod4Mask, "M4")
|
|
,(mod5Mask, "M5")
|
|
,(controlMask, "C")
|
|
,(shiftMask,"Shift")]
|
|
where pick m str = if m .&. complement mask == 0 then str else ""
|
|
|
|
keyToString :: (KeyMask, KeySym) -> [Char]
|
|
keyToString = uncurry (++) . (modToString *** keysymToString)
|
|
|
|
showKmSimple :: [((KeyMask, KeySym), NamedAction)] -> [[Char]]
|
|
showKmSimple = concatMap (\(k,e) -> if snd k == 0 then "":showName e else map ((keyToString k ++) . smartSpace) $ showName e)
|
|
|
|
smartSpace :: String -> String
|
|
smartSpace [] = []
|
|
smartSpace xs = ' ':xs
|
|
|
|
_test :: String
|
|
_test = unlines $ showKm $ defaultKeysDescr XMonad.defaultConfig { XMonad.layoutHook = XMonad.Layout $ XMonad.layoutHook XMonad.defaultConfig }
|
|
|
|
showKm :: [((KeyMask, KeySym), NamedAction)] -> [String]
|
|
showKm keybindings = padding $ do
|
|
(k,e) <- keybindings
|
|
if snd k == 0 then map ((,) "") $ showName e
|
|
else map ((,) (keyToString k) . smartSpace) $ showName e
|
|
where padding = let pad n (k,e) = if null k then "\n>> "++e else take n (k++repeat ' ') ++ e
|
|
expand xs n = map (pad n) xs
|
|
getMax = map (maximum . map (length . fst))
|
|
in concat . (zipWith expand <*> getMax) . groupBy (const $ not . null . fst)
|
|
|
|
-- | An action to send to 'addDescrKeys' for showing the keybindings. See also 'showKm' and 'showKmSimple'
|
|
xMessage :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
|
|
xMessage x = addName "Show Keybindings" $ io $ do
|
|
xfork $ executeFile "xmessage" True ["-default", "okay", unlines $ showKm x] Nothing
|
|
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 k ks = addDescrKeys' k (\l -> defaultKeysDescr l ^++^ ks l)
|
|
|
|
-- | Without merging with 'defaultKeysDescr'
|
|
addDescrKeys' :: (HasName b) =>
|
|
((KeyMask, KeySym),[((KeyMask, KeySym), NamedAction)] -> b)
|
|
-> (XConfig Layout -> [((KeyMask, KeySym), NamedAction)]) -> XConfig l -> XConfig l
|
|
addDescrKeys' (k,f) ks conf =
|
|
let shk l = f $ [(k,f $ ks l)] ^++^ ks l
|
|
keylist l = M.map getAction $ M.fromList $ ks l ^++^ [(k, shk l)]
|
|
in conf { keys = keylist }
|
|
|
|
-- | A version of the default keys from 'XMonad.Config.defaultConfig', but with
|
|
-- 'NamedAction' instead of @X ()@
|
|
defaultKeysDescr :: XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
|
|
defaultKeysDescr conf@(XConfig {XMonad.modMask = modm}) =
|
|
[ subtitle "launching and killing programs"
|
|
, ((modm .|. shiftMask, xK_Return), addName "Launch Terminal" $ spawn $ XMonad.terminal conf) -- %! Launch terminal
|
|
, ((modm, xK_p ), addName "Launch dmenu" $ spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"") -- %! Launch dmenu
|
|
, ((modm .|. shiftMask, xK_p ), addName "Launch gmrun" $ spawn "gmrun") -- %! Launch gmrun
|
|
, ((modm .|. shiftMask, xK_c ), addName "Close the focused window" kill) -- %! Close the focused window
|
|
|
|
, subtitle "changing layouts"
|
|
, ((modm, xK_space ), sendMessage' NextLayout) -- %! Rotate through the available layout algorithms
|
|
, ((modm .|. shiftMask, xK_space ), addName "Reset the layout" $ setLayout $ XMonad.layoutHook conf) -- %! Reset the layouts on the current workspace to default
|
|
|
|
, separator
|
|
, ((modm, xK_n ), addName "Refresh" refresh) -- %! Resize viewed windows to the correct size
|
|
|
|
, subtitle "move focus up or down the window stack"
|
|
, ((modm, xK_Tab ), addName "Focus down" $ windows W.focusDown) -- %! Move focus to the next window
|
|
, ((modm .|. shiftMask, xK_Tab ), addName "Focus up" $ windows W.focusUp ) -- %! Move focus to the previous window
|
|
, ((modm, xK_j ), addName "Focus down" $ windows W.focusDown) -- %! Move focus to the next window
|
|
, ((modm, xK_k ), addName "Focus up" $ windows W.focusUp ) -- %! Move focus to the previous window
|
|
, ((modm, xK_m ), addName "Focus the master" $ windows W.focusMaster ) -- %! Move focus to the master window
|
|
|
|
, subtitle "modifying the window order"
|
|
, ((modm, xK_Return), addName "Swap with the master" $ windows W.swapMaster) -- %! Swap the focused window and the master window
|
|
, ((modm .|. shiftMask, xK_j ), addName "Swap down" $ windows W.swapDown ) -- %! Swap the focused window with the next window
|
|
, ((modm .|. shiftMask, xK_k ), addName "Swap up" $ windows W.swapUp ) -- %! Swap the focused window with the previous window
|
|
|
|
, subtitle "resizing the master/slave ratio"
|
|
, ((modm, xK_h ), sendMessage' Shrink) -- %! Shrink the master area
|
|
, ((modm, xK_l ), sendMessage' Expand) -- %! Expand the master area
|
|
|
|
, subtitle "floating layer support"
|
|
, ((modm, xK_t ), addName "Push floating to tiled" $ withFocused $ windows . W.sink) -- %! Push window back into tiling
|
|
|
|
, subtitle "change the number of windows in the master area"
|
|
, ((modm , xK_comma ), sendMessage' (IncMasterN 1)) -- %! Increment the number of windows in the master area
|
|
, ((modm , xK_period), sendMessage' (IncMasterN (-1))) -- %! Deincrement the number of windows in the master area
|
|
|
|
, subtitle "quit, or restart"
|
|
, ((modm .|. shiftMask, xK_q ), addName "Quit" $ io (exitWith ExitSuccess)) -- %! Quit xmonad
|
|
, ((modm , xK_q ), addName "Restart" $ spawn "xmonad --recompile && xmonad --restart") -- %! Restart xmonad
|
|
]
|
|
|
|
-- mod-[1..9] %! Switch to workspace N
|
|
-- mod-shift-[1..9] %! Move client to workspace N
|
|
++
|
|
subtitle "switching workspaces":
|
|
[((m .|. modm, k), addName (n ++ i) $ windows $ f i)
|
|
| (f, m, n) <- [(W.greedyView, 0, "Switch to workspace "), (W.shift, shiftMask, "Move client to workspace ")]
|
|
, (i, k) <- zip (XMonad.workspaces conf) [xK_1 .. 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
|
|
++
|
|
subtitle "switching screens" :
|
|
[((m .|. modm, key), addName (n ++ show sc) $ screenWorkspace sc >>= flip whenJust (windows . f))
|
|
| (f, m, n) <- [(W.view, 0, "Switch to screen number "), (W.shift, shiftMask, "Move client to screen number ")]
|
|
, (key, sc) <- zip [xK_w, xK_e, 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 = ((0,0), NamedAction (return () :: X (),[] :: [String]))
|
|
|
|
subtitle :: String -> ((KeyMask, KeySym), NamedAction)
|
|
subtitle x = ((0,0), NamedAction $ x ++ ":")
|
|
|
|
-- | 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 = NamedAction
|
|
|
|
oneName :: (X (), String) -> NamedAction
|
|
oneName = NamedAction
|
|
|
|
addName :: String -> X () -> NamedAction
|
|
addName = flip (curry NamedAction)
|