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