module XMonad.Util.NamedActions (
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
deriving instance Show XMonad.Resize
deriving instance Show XMonad.IncMasterN
sendMessage' :: (Message a, Show a) => a -> NamedAction
sendMessage' x = NamedAction $ (XMonad.sendMessage x,show x)
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
instance HasName (NamedAction,String) where
showName = (:[]) . snd
getAction = getAction . fst
instance HasName NamedAction where
showName (NamedAction x) = showName x
getAction (NamedAction x) = getAction x
data NamedAction = forall a. HasName a => NamedAction a
submapName :: (HasName a) => [((KeyMask, KeySym), a)] -> NamedAction
submapName = NamedAction . (submap . M.map getAction . M.fromList &&& showKm)
. map (second NamedAction)
(^++^) :: (HasName b, HasName b1) =>
[(d, b)] -> [(d, b1)] -> [(d, NamedAction)]
a ^++^ b = map (second NamedAction) a ++ map (second NamedAction) b
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)
xMessage :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
xMessage x = addName "Show Keybindings" $ io $ do
forkProcess $ executeFile "xmessage" True ["-default", "okay", unlines $ showKm x] Nothing
return ()
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)
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 }
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)
, ((modm, xK_p ), addName "Launch dmenu" $ spawn "exe=`dmenu_path | dmenu` && eval \"exec $exe\"")
, ((modm .|. shiftMask, xK_p ), addName "Launch gmrun" $ spawn "gmrun")
, ((modm .|. shiftMask, xK_c ), addName "Close the focused window" kill)
, subtitle "changing layouts"
, ((modm, xK_space ), sendMessage' NextLayout)
, ((modm .|. shiftMask, xK_space ), addName "Reset the layout" $ setLayout $ XMonad.layoutHook conf)
, separator
, ((modm, xK_n ), addName "Refresh" refresh)
, subtitle "move focus up or down the window stack"
, ((modm, xK_Tab ), addName "Focus down" $ windows W.focusDown)
, ((modm .|. shiftMask, xK_Tab ), addName "Focus up" $ windows W.focusUp )
, ((modm, xK_j ), addName "Focus down" $ windows W.focusDown)
, ((modm, xK_k ), addName "Focus up" $ windows W.focusUp )
, ((modm, xK_m ), addName "Focus the master" $ windows W.focusMaster )
, subtitle "modifying the window order"
, ((modm, xK_Return), addName "Swap with the master" $ windows W.swapMaster)
, ((modm .|. shiftMask, xK_j ), addName "Swap down" $ windows W.swapDown )
, ((modm .|. shiftMask, xK_k ), addName "Swap up" $ windows W.swapUp )
, subtitle "resizing the master/slave ratio"
, ((modm, xK_h ), sendMessage' Shrink)
, ((modm, xK_l ), sendMessage' Expand)
, subtitle "floating layer support"
, ((modm, xK_t ), addName "Push floating to tiled" $ withFocused $ windows . W.sink)
, subtitle "change the number of windows in the master area"
, ((modm , xK_comma ), sendMessage' (IncMasterN 1))
, ((modm , xK_period), sendMessage' (IncMasterN (1)))
, subtitle "quit, or restart"
, ((modm .|. shiftMask, xK_q ), addName "Quit" $ io (exitWith ExitSuccess))
, ((modm , xK_q ), addName "Restart" $ spawn "xmonad --recompile && xmonad --restart")
]
++
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]]
++
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..]]
separator :: ((KeyMask,KeySym), NamedAction)
separator = ((0,0), NamedAction (return () :: X (),[] :: [String]))
subtitle :: String -> ((KeyMask, KeySym), NamedAction)
subtitle x = ((0,0), NamedAction $ x ++ ":")
noName :: X () -> NamedAction
noName = NamedAction
oneName :: (X (), String) -> NamedAction
oneName = NamedAction
addName :: String -> X () -> NamedAction
addName = flip (curry NamedAction)