{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, StandaloneDeriving #-} -------------------------------------------------------------------- -- | -- Module : XMonad.Util.NamedActions -- Copyright : 2009 Adam Vogt -- License : BSD3-style (see LICENSE) -- -- Maintainer : Adam Vogt -- 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(KeySym, KeyMask, X, Layout, Message, XConfig(keys, layoutHook, modMask, terminal, workspaces, XConfig), io, spawn, whenJust, ChangeLayout(NextLayout), IncMasterN(..), Resize(..), kill, refresh, screenWorkspace, sendMessage, setLayout, windows, withFocused, controlMask, mod1Mask, mod2Mask, mod3Mask, mod4Mask, mod5Mask, shiftMask, xK_1, xK_9, xK_Return, xK_Tab, xK_c, xK_comma, xK_e, xK_h, xK_j, xK_k, xK_l, xK_m, xK_n, xK_p, xK_period, xK_q, xK_r, xK_space, xK_t, xK_w, keysymToString) import System.Posix.Process(executeFile, forkProcess) import Control.Arrow(Arrow((&&&), second, (***))) import Data.Bits(Bits((.&.), complement, (.|.))) import Data.Function((.), const, ($), flip, id) import Data.List((++), filter, zip, map, concatMap, null, unlines, groupBy) import System.Exit(ExitCode(ExitSuccess), exitWith) import Control.Applicative ((<*>)) import qualified Data.Map as M import qualified XMonad.StackSet as W import qualified XMonad -- $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)] -- > ^++^ -- > [("", spawn "mpc toggle" :: X ()), -- > ("", 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 forkProcess $ 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)