From d232c5796869493fda17fd66a846f3dcfab82eb8 Mon Sep 17 00:00:00 2001 From: Adam Vogt Date: Sun, 26 Jul 2009 05:20:03 +0200 Subject: U.NamedActions: align the descriptions for each section, refactor its integration with EZConfig Ignore-this: f7132388b1f1fd2dbf03885ffa534c20 darcs-hash:20090726032003-1499c-264671a5613ef3610a9e807c0e6645a629becab2.gz --- XMonad/Util/EZConfig.hs | 16 +++----- XMonad/Util/NamedActions.hs | 92 +++++++++++++++++++++++++-------------------- 2 files changed, 57 insertions(+), 51 deletions(-) (limited to 'XMonad/Util') diff --git a/XMonad/Util/EZConfig.hs b/XMonad/Util/EZConfig.hs index cf7545c..6e0a4c3 100644 --- a/XMonad/Util/EZConfig.hs +++ b/XMonad/Util/EZConfig.hs @@ -359,23 +359,19 @@ mkNamedKeymap c = mkNamedSubmaps . readKeymap c -- group them into submaps in the appropriate way. mkNamedSubmaps :: [([(KeyMask, KeySym)], NamedAction)] -> [((KeyMask, KeySym), NamedAction)] -mkNamedSubmaps binds = map combine gathered - where gathered = groupBy fstKey - . sortBy (comparing fst) - $ binds - combine [([k],act)] = (k,act) - combine ks = (head . fst . head $ ks, - submapName . mkNamedSubmaps $ map (first tail) ks) - fstKey = (==) `on` (head . fst) +mkNamedSubmaps = mkSubmaps' submapName mkSubmaps :: [ ([(KeyMask,KeySym)], X ()) ] -> [((KeyMask, KeySym), X ())] -mkSubmaps binds = map combine gathered +mkSubmaps = mkSubmaps' $ submap . M.fromList + +mkSubmaps' :: (Ord a) => ([(a, c)] -> c) -> [([a], c)] -> [(a, c)] +mkSubmaps' subm 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) + subm . mkSubmaps' subm $ map (first tail) ks) fstKey = (==) `on` (head . fst) on :: (a -> a -> b) -> (c -> a) -> c -> c -> b diff --git a/XMonad/Util/NamedActions.hs b/XMonad/Util/NamedActions.hs index 089d7c8..70544e4 100644 --- a/XMonad/Util/NamedActions.hs +++ b/XMonad/Util/NamedActions.hs @@ -1,17 +1,17 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances, StandaloneDeriving #-} -{-# LANGUAGE ExistentialQuantification, FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, StandaloneDeriving #-} -------------------------------------------------------------------- -- | -- Module : XMonad.Util.NamedActions --- Copyright : Adam Vogt +-- Copyright : 2009 Adam Vogt -- License : BSD3-style (see LICENSE) -- -- Maintainer : Adam Vogt -- Stability : unstable -- Portability : unportable -- --- Present a list of the keybindings in use. +-- A wrapper for keybinding configuration that can list the available +-- keybindings. -------------------------------------------------------------------- module XMonad.Util.NamedActions ( @@ -40,9 +40,10 @@ module XMonad.Util.NamedActions ( defaultKeysDescr ) where + import XMonad.Actions.Submap(submap) import XMonad(KeySym, KeyMask, X, Layout, Message, - XConfig(workspaces, terminal, modMask, layoutHook, keys, XConfig), + 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, @@ -50,15 +51,18 @@ import XMonad(KeySym, KeyMask, X, Layout, Message, 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, (&&&), first)) -import Data.Bits(Bits((.|.), complement, (.&.))) -import Data.Function((.), const, ($), flip, id, on) -import Data.List((++), filter, zip, map, concatMap, elem, head, - last, null, unlines, groupBy, intercalate, partition, sortBy) +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'', @@ -68,34 +72,35 @@ import qualified XMonad.StackSet as W -- > import XMonad.Util.NamedActions -- > import XMonad.Util.EZConfig -- > --- > main = xmonad $ addDescrKeys ((mod4Mask, xK_d), xMessage) myKeys +-- > main = xmonad $ addDescrKeys ((mod4Mask, xK_F1), xMessage) myKeys -- > defaultConfig { modMask = mod4Mask } -- > --- > myKeys = flip mkNamedKeymap $ --- > [("M-x a", addName "useless..." $ spawn "xmessage foo"), +-- > 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"] +-- > ("", spawn "mpc next")] -- --- Due to the type of '^++^', you can combine bindings whose actions are @X ()@ +-- 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'. '^++^' --- works with traditional-style keybindings too. +-- 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) -- --- pad as if by columns --- --- Multiple columns +-- 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?) +-- 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: -- @@ -171,7 +176,7 @@ 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 w) + $ map (uncurry pick) [(mod1Mask, "M1") ,(mod2Mask, "M2") ,(mod3Mask, "M3") @@ -179,26 +184,30 @@ modToString mask = concatMap (++"-") $ filter (not . null) ,(mod5Mask, "M5") ,(controlMask, "C") ,(shiftMask,"Shift")] - where w m str = if m .&. complement mask == 0 then str else "" + where pick m str = if m .&. complement mask == 0 then str else "" keyToString :: (KeyMask, KeySym) -> [Char] keyToString = uncurry (++) . (modToString *** keysymToString) --- | Squeezes bindings from [xK_1 .. xK_9] -showKm :: [((KeyMask, KeySym), NamedAction)] -> [[Char]] -showKm = uncurry (flip (++)) - . second showKmSimple - . first (map ( intercalate " ... " . showKmSimple . uncurry (:) - . (head &&& (:[]) . last) - . sortBy (compare `on` (snd . fst))) - . groupBy ((==) `on` (fst . fst)) - ) - . partition ((`elem` [xK_1 .. xK_9]) . snd . fst) - showKmSimple :: [((KeyMask, KeySym), NamedAction)] -> [[Char]] showKmSimple = concatMap (\(k,e) -> if snd k == 0 then "":showName e else map ((keyToString k ++) . smartSpace) $ showName e) - where smartSpace [] = [] - smartSpace xs = ' ':xs + +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 @@ -206,7 +215,8 @@ xMessage x = addName "Show Keybindings" $ io $ do forkProcess $ executeFile "xmessage" True ["-default", "okay", unlines $ showKm x] Nothing return () --- | Merge the supplied keys with 'defaultKeysDescr' +-- | 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)]) @@ -259,7 +269,7 @@ defaultKeysDescr conf@(XConfig {XMonad.modMask = modm}) = , subtitle "floating layer support" , ((modm, xK_t ), addName "Push floating to tiled" $ withFocused $ windows . W.sink) -- %! Push window back into tiling - , subtitle "increase or decrease number of windows in the master area" + , 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 @@ -284,8 +294,8 @@ defaultKeysDescr conf@(XConfig {XMonad.modMask = modm}) = , (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 error --- otherwise +-- 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])) -- cgit v1.2.3