EZConfig: add an emacs-style keybinding parser!

Now, instead of writing out incredibly dull things like

  ((modMask conf .|. controlMask .|. shiftMask, xK_F2), ...)

you can just write

  ("M-C-S-<F2>", ...)

Hooray!

XMonad/Util/EZConfig.hs

@@ -2,25 +2,52 @@
 -- |
 -- Module      :  XMonad.Util.EZConfig
 -- Copyright   :  Devin Mullins <me@twifkak.com>
+--                Brent Yorgey <byorgey@gmail.com> (key parsing)
 -- License     :  BSD3-style (see LICENSE)
 --
 -- Maintainer  :  Devin Mullins <me@twifkak.com>
 --
--- Useful helper functions for amending the defaultConfig.
+-- Useful helper functions for amending the defaultConfig, and for
+-- parsing keybindings specified in a special (emacs-like) format.
 --
 -- (See also "XMonad.Util.CustomKeys" in xmonad-contrib.)
 --
 --------------------------------------------------------------------
 
 module XMonad.Util.EZConfig (
-                             additionalKeys, removeKeys,
+                             -- * Usage
-                             additionalMouseBindings, removeMouseBindings
+                             -- $usage
+
+                             -- * Adding or removing keybindings
+
+                             additionalKeys, additionalKeysP,
+                             removeKeys, removeKeysP,
+                             additionalMouseBindings, removeMouseBindings,
+
+                             -- * Nicer keybinding specifications
+
+                             mkKeymap, checkKeymap,
                             ) where
--- TODO: write tests
 
 import XMonad
+import XMonad.Actions.Submap
 
 import qualified Data.Map as M
+import Data.List (foldl', intersperse, sortBy, groupBy, nub)
+import Data.Ord (comparing)
+import Data.Maybe (catMaybes, isNothing, isJust, fromJust)
+import Control.Arrow (first, (&&&))
+
+import Text.ParserCombinators.ReadP
+
+-- $usage
+-- To use this module, first import it into your @~\/.xmonad\/xmonad.hs@:
+--
+-- > import XMonad.Util.EZConfig
+--
+-- Then, use one of the provided functions to modify your
+-- configuration. See the documentation provided with each exported
+-- function for more information.
 
 -- |
 -- Add or override keybindings from the existing set. Example use:
@@ -37,8 +64,22 @@ import qualified Data.Map as M
 -- to the modMask you configured earlier. You must specify mod1Mask (or
 -- whichever), or add your own @myModMask = mod1Mask@ line.
 additionalKeys :: XConfig a -> [((ButtonMask, KeySym), X ())] -> XConfig a
-additionalKeys conf keysList =
+additionalKeys conf keyList =
-    conf { keys = \cnf -> M.union (M.fromList keysList) (keys conf cnf) }
+    conf { keys = \cnf -> M.union (M.fromList keyList) (keys conf cnf) }
+
+-- | Like 'additionalKeys', except using short @String@ key
+--   descriptors like @\"M-m\"@ instead of @(modMask, xK_m)@, as
+--   described in the documentation for 'mkKeymap'.  For example:
+--
+-- > main = xmonad $ defaultConfig { terminal = "urxvt" }
+-- >                 `additionalKeysP`
+-- >                 [ ("M-m", spawn "echo 'Hi, mom!' | dzen2 -p 4")
+-- >                 , ("M-<Backspace>", withFocused hide) -- N.B. this is an absurd thing to do
+-- >                 ]
+
+additionalKeysP :: XConfig l -> [(String, X ())] -> XConfig l
+additionalKeysP conf keyList =
+    conf { keys = \cnf -> M.union (mkKeymap cnf keyList) (keys conf cnf) }
 
 -- |
 -- Remove standard keybindings you're not using. Example use:
@@ -49,13 +90,243 @@ removeKeys :: XConfig a -> [(ButtonMask, KeySym)] -> XConfig a
 removeKeys conf keyList =
     conf { keys = \cnf -> keys conf cnf `M.difference` M.fromList (zip keyList $ return ()) }
 
--- | Like additionalKeys, but for mouseBindings.
+-- | Like 'removeKeys', except using short @String@ key descriptors
+--   like @\"M-m\"@ instead of @(modMask, xK_m)@, as described in the
+--   documentation for 'mkKeymap'. For example:
+--
+-- > main = xmonad $ defaultConfig { terminal = "urxvt" }
+-- >                 `removeKeysP` ["M-S-" ++ [n] | n <- ['1'..'9']]
+
+removeKeysP :: XConfig l -> [String] -> XConfig l
+removeKeysP conf keyList =
+    conf { keys = \cnf -> keys conf cnf `M.difference` mkKeymap cnf (zip keyList $ repeat (return ())) }
+
+-- | Like 'additionalKeys', but for mouse bindings.
 additionalMouseBindings :: XConfig a -> [((ButtonMask, Button), Window -> X ())] -> XConfig a
 additionalMouseBindings conf mouseBindingsList =
     conf { mouseBindings = \cnf -> M.union (M.fromList mouseBindingsList) (mouseBindings conf cnf) }
 
--- | Like removeKeys, but for mouseBindings.
+-- | Like 'removeKeys', but for mouse bindings.
 removeMouseBindings :: XConfig a -> [(ButtonMask, Button)] -> XConfig a
 removeMouseBindings conf mouseBindingList =
     conf { mouseBindings = \cnf -> mouseBindings conf cnf `M.difference`
                                    M.fromList (zip mouseBindingList $ return ()) }
+
+
+--------------------------------------------------------------
+--  Keybinding parsing  ---------------------------------------
+--------------------------------------------------------------
+
+-- | Given a config (used to determine the proper modifier key to use)
+--   and a list of @(String, X ())@ pairs, create a key map by parsing
+--   the key sequence descriptions contained in the Strings.  The key
+--   sequence descriptions are \"emacs-style\": @M-@, @C-@, @S-@, and
+--   @M\#-@ denote mod, control, shift, and mod1-mod5 (where @\#@ is
+--   replaced by the appropriate number) respectively; some special
+--   keys can be specified by enclosing their name in angle brackets.
+--
+--   For example, @\"M-C-x\"@ denotes mod+ctrl+x; @\"S-\<Escape\>\"@ denotes
+--   shift-escape.
+--
+--   Sequences of keys can also be specified by separating the key
+--   descriptions with spaces. For example, @\"M-x y \<Down\>\"@ denotes the
+--   sequence of keys mod+x, y, down.  Submaps (see
+--   "XMonad.Actions.Submap") will be automatically generated to
+--   correctly handle these cases.
+--
+--   So, for example, a complete key map might be specified as
+--
+-- > keys = \c -> mkKeymap c $
+-- >     [ ("M-S-<Return>", spawn $ terminal c)
+-- >     , ("M-x w", spawn "xmessage 'woohoo!'")  -- type mod+x then w to pop up 'woohoo!'
+-- >     , ("M-x y", spawn "xmessage 'yay!'")     -- type mod+x then y to pop up 'yay!'
+-- >     , ("M-S-c", kill)
+-- >     ]
+--
+-- Alternatively, you can use 'additionalKeysP' to automatically
+-- create a keymap and add it to your config.
+--
+-- Here is a complete list of supported special keys.  Note that a few
+-- keys, such as the arrow keys, have synonyms:
+--
+-- > <Backspace>
+-- > <Tab>
+-- > <Return>
+-- > <Pause>
+-- > <Scroll_lock>
+-- > <Sys_Req>
+-- > <Escape>, <Esc>
+-- > <Delete>
+-- > <Home>
+-- > <Left>, <L>
+-- > <Up>, <U>
+-- > <Right>, <R>
+-- > <Down>, <D>
+-- > <Page_Up>
+-- > <Page_Down>
+-- > <End>
+-- > <Insert>
+-- > <Break>
+-- > <Space>
+-- > <F1>-<F12>
+
+mkKeymap :: XConfig l -> [(String, X ())] -> M.Map (KeyMask, KeySym) (X ())
+mkKeymap c = M.fromList . mkSubmaps . readKeymap c
+
+-- | Given a list of pairs of parsed key sequences and actions,
+--   group them into submaps in the appropriate way.
+mkSubmaps :: [ ([(KeyMask,KeySym)], X ()) ] -> [((KeyMask, KeySym), X ())]
+mkSubmaps binds = map combine gathered
+  where gathered = groupBy fstKey
+                 . sortBy (comparing fst)
+                 $ binds
+        combine [([k],act)] = (k,act)
+        combine ks = (head . fst . head $ ks,
+                      submap . M.fromList . mkSubmaps $ map (first tail) ks)
+        fstKey = (==) `on` (head . fst)
+
+on :: (a -> a -> b) -> (c -> a) -> c -> c -> b
+op `on` f = \x y -> f x `op` f y
+
+-- | Given a configuration record and a list of (key sequence
+--   description, action) pairs, parse the key sequences into lists of
+--   @(KeyMask,KeySym)@ pairs.  Key sequences which fail to parse will
+--   be ignored.
+readKeymap :: XConfig l -> [(String, X())] -> [([(KeyMask,KeySym)], X())]
+readKeymap c = catMaybes . map (maybeKeys . first (readKeySequence c))
+  where maybeKeys (Nothing,_) = Nothing
+        maybeKeys (Just k, act) = Just (k, act)
+
+-- | Parse a sequence of keys, returning Nothing if there is
+--   a parse failure (no parse, or ambiguous parse).
+readKeySequence :: XConfig l -> String -> Maybe [(KeyMask, KeySym)]
+readKeySequence c s = case parses s of
+    [k] -> Just k
+    _   -> Nothing
+  where parses = map fst . filter (null.snd) . readP_to_S (parseKeySequence c)
+
+-- | Parse a sequence of key combinations separated by spaces, e.g.
+--   @\"M-c x C-S-2\"@ (mod+c, x, ctrl+shift+2).
+parseKeySequence :: XConfig l -> ReadP [(KeyMask, KeySym)]
+parseKeySequence c = sepBy1 (parseKeyCombo c) (many1 $ char ' ')
+
+-- | Parse a modifier-key combination such as "M-C-s" (mod+ctrl+s).
+parseKeyCombo :: XConfig l -> ReadP (KeyMask, KeySym)
+parseKeyCombo c = do mods <- many (parseModifier c)
+                     k <- parseKey
+                     return (foldl' (.|.) 0 mods, k)
+
+-- | Parse a modifier: either M- (user-defined mod-key),
+--   C- (control), S- (shift), or M#- where # is an integer
+--   from 1 to 5 (mod1Mask through mod5Mask).
+parseModifier :: XConfig l -> ReadP KeyMask
+parseModifier c =  (string "M-" >> return (modMask c))
+               +++ (string "C-" >> return controlMask)
+               +++ (string "S-" >> return shiftMask)
+               +++ do char 'M'
+                      n <- satisfy (`elem` ['1'..'5'])
+                      char '-'
+                      return (mod1Mask + (read [n]) - 1)
+
+-- | Parse an unmodified basic key, like @\"x\"@, @\"<F1>\"@, etc.
+parseKey :: ReadP KeySym
+parseKey = parseRegular +++ parseSpecial
+
+-- | Parse a regular key name (represented by itself).
+parseRegular :: ReadP KeySym
+parseRegular = choice [ char s >> return k
+                      | (s,k) <- zip ['!'..'~'] [xK_exclam..xK_asciitilde]
+                      ]
+
+-- | Parse a special key name (one enclosed in angle brackets).
+parseSpecial :: ReadP KeySym
+parseSpecial = do char '<'
+                  key <- choice [ string name >> return k
+                                | (name,k) <- keyNames
+                                ]
+                  char '>'
+                  return key
+
+-- | A list of all special key names and their associated KeySyms.
+keyNames :: [(String, KeySym)]
+keyNames = functionKeys ++ specialKeys
+
+-- | A list pairing function key descriptor strings (e.g. @\"<F2>\"@) with
+--   the associated KeySyms.
+functionKeys :: [(String, KeySym)]
+functionKeys = [ ("F" ++ show n, k)
+               | (n,k) <- zip ([1..12] :: [Int]) [xK_F1..] ]
+
+-- | A list of special key names and their corresponding KeySyms.
+specialKeys :: [(String, KeySym)]
+specialKeys = [ ("Backspace", xK_BackSpace)
+              , ("Tab"      , xK_Tab      )
+              , ("Return"   , xK_Return)
+              , ("Pause"    , xK_Pause)
+              , ("Scroll_lock", xK_Scroll_Lock)
+              , ("Sys_Req"  , xK_Sys_Req)
+              , ("Escape"   , xK_Escape)
+              , ("Esc"      , xK_Escape)
+              , ("Delete"   , xK_Delete)
+              , ("Home"     , xK_Home)
+              , ("Left"     , xK_Left)
+              , ("Up"       , xK_Up)
+              , ("Right"    , xK_Right)
+              , ("Down"     , xK_Down)
+              , ("L"        , xK_Left)
+              , ("U"        , xK_Up)
+              , ("R"        , xK_Right)
+              , ("D"        , xK_Down)
+              , ("Page_Up"  , xK_Page_Up)
+              , ("Page_Down", xK_Page_Down)
+              , ("End"      , xK_End)
+              , ("Insert"   , xK_Insert)
+              , ("Break"    , xK_Break)
+              , ("Space"    , xK_space)
+              ]
+
+-- | Given a configuration record and a list of (key sequence
+--   description, action) pairs, check the key sequence descriptions
+--   for validity, and warn the user (via a popup xmessage window) of
+--   any unparseable or duplicate key sequences.  This function is
+--   appropriate for adding to your @startupHook@, and you are highly
+--   encouraged to do so; otherwise, duplicate or unparseable
+--   keybindings will be silently ignored.
+--
+--   For example, you might do something like this:
+--
+-- > main = xmonad $ myConfig
+-- >
+-- > myKeymap = [("S-M-c", kill), ...]
+-- > myConfig = defaultConfig {
+-- >     ...
+-- >     keys = \c -> mkKeymap c myKeymap
+-- >     startupHook = checkKeymap myConfig myKeymap
+-- >     ...
+-- > }
+--
+checkKeymap :: XConfig l -> [(String, a)] -> X ()
+checkKeymap conf km = warn (doKeymapCheck conf km)
+  where warn ([],[])   = return ()
+        warn (bad,dup) = spawn $ "xmessage 'Warning:\n"
+                            ++ msg "bad" bad ++ "\n"
+                            ++ msg "duplicate" dup ++ "'"
+        msg _ [] = ""
+        msg m xs = m ++ " keybindings detected: " ++ showBindings xs
+        showBindings = concat . intersperse " " . map ((++"\"") . ("\""++))
+
+-- | Given a config and a list of (key sequence description, action)
+--   pairs, check the key sequence descriptions for validity,
+--   returning a list of unparseable key sequences, and a list of
+--   duplicate key sequences.
+doKeymapCheck :: XConfig l -> [(String,a)] -> ([String], [String])
+doKeymapCheck conf km = (bad,dups)
+  where ks = map ((readKeySequence conf &&& id) . fst) km
+        bad = nub . map snd . filter (isNothing . fst) $ ks
+        dups = map (snd . head)
+             . filter ((>1) . length)
+             . groupBy ((==) `on` fst)
+             . sortBy (comparing fst)
+             . map (first fromJust)
+             . filter (isJust . fst)
+             $ ks