path: root/XMonad/Util/NamedActions.hs

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