{-# 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 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)] -- > ^++^ -- > [("", 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 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)