From 6a6dc927416c5c488aa73d3ee13f6640ed3b617e Mon Sep 17 00:00:00 2001 From: Alexander Sulfrian Date: Thu, 3 Jul 2014 00:43:19 +0200 Subject: initial commit --- .gitignore | 8 + lib/EZConfig.hs | 729 +++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/HistoryGrid.hs | 42 +++ lib/Pass.hs | 142 +++++++++++ xmonad.hs | 456 +++++++++++++++++++++++++++++++++ 5 files changed, 1377 insertions(+) create mode 100644 .gitignore create mode 100644 lib/EZConfig.hs create mode 100644 lib/HistoryGrid.hs create mode 100644 lib/Pass.hs create mode 100644 xmonad.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..4973643 --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +*.hi +*.o +xmonad.errors +# this is the compiled xmoand binary (xmoand--) +xmonad-*-* + +# history file for XMonad.Prompt +history diff --git a/lib/EZConfig.hs b/lib/EZConfig.hs new file mode 100644 index 0000000..075d7ed --- /dev/null +++ b/lib/EZConfig.hs @@ -0,0 +1,729 @@ +-------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.EZConfig +-- Copyright : Devin Mullins +-- Brent Yorgey (key parsing) +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Devin Mullins +-- +-- 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 EZConfig ( + -- * Usage + -- $usage + + -- * Adding or removing keybindings + + additionalKeys, additionalKeysP, + removeKeys, removeKeysP, + additionalMouseBindings, removeMouseBindings, + + -- * Emacs-style keybinding specifications + + mkKeymap, checkKeymap, + mkNamedKeymap, + + parseKey -- used by XMonad.Util.Paste + ) where + +import XMonad +import XMonad.Actions.Submap + +import XMonad.Util.NamedActions + +import qualified Data.Map as M +import Data.List (foldl', sortBy, groupBy, nub) +import Data.Ord (comparing) +import Data.Maybe +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. You can use 'additionalKeys', 'removeKeys', +-- 'additionalMouseBindings', and 'removeMouseBindings' to easily add +-- and remove keybindings or mouse bindings. You can use 'mkKeymap' +-- to create a keymap using emacs-style keybinding specifications +-- like @\"M-x\"@ instead of @(modMask, xK_x)@, or 'additionalKeysP' +-- and 'removeKeysP' to easily add or remove emacs-style keybindings. +-- If you use emacs-style keybindings, the 'checkKeymap' function is +-- provided, suitable for adding to your 'startupHook', which can warn +-- you of any parse errors or duplicate bindings in your keymap. +-- +-- For more information and usage examples, see the documentation +-- provided with each exported function, and check the xmonad config +-- archive () +-- for some real examples of use. + +-- | +-- Add or override keybindings from the existing set. Example use: +-- +-- > main = xmonad $ defaultConfig { terminal = "urxvt" } +-- > `additionalKeys` +-- > [ ((mod1Mask, xK_m ), spawn "echo 'Hi, mom!' | dzen2 -p 4") +-- > , ((mod1Mask, xK_BackSpace), withFocused hide) -- N.B. this is an absurd thing to do +-- > ] +-- +-- This overrides the previous definition of mod-m. +-- +-- Note that, unlike in xmonad 0.4 and previous, you can't use modMask to refer +-- 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 keyList = + 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-", 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: +-- +-- > main = xmonad $ defaultConfig { terminal = "urxvt" } +-- > `removeKeys` [(mod1Mask .|. shiftMask, n) | n <- [xK_1 .. xK_9]] +removeKeys :: XConfig a -> [(ButtonMask, KeySym)] -> XConfig a +removeKeys conf keyList = + conf { keys = \cnf -> keys conf cnf `M.difference` M.fromList (zip keyList $ repeat ()) } + +-- | 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 mouse bindings. +removeMouseBindings :: XConfig a -> [(ButtonMask, Button)] -> XConfig a +removeMouseBindings conf mouseBindingList = + conf { mouseBindings = \cnf -> mouseBindings conf cnf `M.difference` + M.fromList (zip mouseBindingList $ repeat ()) } + + +-------------------------------------------------------------- +-- 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. Note that if +-- you want to make a keybinding using \'alt\' even though you use a +-- different key (like the \'windows\' key) for \'mod\', you can use +-- something like @\"M1-x\"@ for alt+x (check the output of @xmodmap@ +-- to see which mod key \'alt\' is bound to). Some special keys can +-- also be specified by enclosing their name in angle brackets. +-- +-- For example, @\"M-C-x\"@ denotes mod+ctrl+x; @\"S-\\"@ +-- denotes shift-escape; @\"M1-C-\\"@ denotes alt+ctrl+delete +-- (assuming alt is bound to mod1, which is common). +-- +-- Sequences of keys can also be specified by separating the key +-- descriptions with spaces. For example, @\"M-x y \\"@ 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-", 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. If there are other +-- special keys you would like to see supported, feel free to submit a +-- patch, or ask on the xmonad mailing list; adding special keys is +-- quite simple. +-- +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > , +-- > +-- > +-- > , +-- > , +-- > , +-- > , +-- > +-- > +-- > +-- > +-- > +-- > +-- > - +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > - +-- +-- Long list of multimedia keys. Please note that not all keys may be +-- present in your particular setup although most likely they will do. +-- +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > -, - +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > +-- > - +-- > +-- > +-- > +-- > + +mkKeymap :: XConfig l -> [(String, X ())] -> M.Map (KeyMask, KeySym) (X ()) +mkKeymap c = M.fromList . mkSubmaps . readKeymap c + +mkNamedKeymap :: XConfig l -> [(String, NamedAction)] -> [((KeyMask, KeySym), NamedAction)] +mkNamedKeymap c = mkNamedSubmaps . readKeymap c + +-- | Given a list of pairs of parsed key sequences and actions, +-- group them into submaps in the appropriate way. + +mkNamedSubmaps :: [([(KeyMask, KeySym)], NamedAction)] -> [((KeyMask, KeySym), NamedAction)] +mkNamedSubmaps = mkSubmaps' submapName + +mkSubmaps :: [ ([(KeyMask,KeySym)], X ()) ] -> [((KeyMask, KeySym), X ())] +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, + subm . mkSubmaps' subm $ 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, t)] -> [([(KeyMask, KeySym)], t)] +readKeymap c = mapMaybe (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 = listToMaybe . parses + 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 $ indexMod (read [n] - 1) + where indexMod = (!!) [mod1Mask,mod2Mask,mod3Mask,mod4Mask,mod5Mask] + +-- | Parse an unmodified basic key, like @\"x\"@, @\"\"@, 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 ++ multimediaKeys + +-- | A list pairing function key descriptor strings (e.g. @\"\"@) with +-- the associated KeySyms. +functionKeys :: [(String, KeySym)] +functionKeys = [ ('F' : show n, k) + | (n,k) <- zip ([1..24] :: [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) + , ("Print" , xK_Print) + , ("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) + , ("KP_Space" , xK_KP_Space) + , ("KP_Tab" , xK_KP_Tab) + , ("KP_Enter" , xK_KP_Enter) + , ("KP_F1" , xK_KP_F1) + , ("KP_F2" , xK_KP_F2) + , ("KP_F3" , xK_KP_F3) + , ("KP_F4" , xK_KP_F4) + , ("KP_Home" , xK_KP_Home) + , ("KP_Left" , xK_KP_Left) + , ("KP_Up" , xK_KP_Up) + , ("KP_Right" , xK_KP_Right) + , ("KP_Down" , xK_KP_Down) + , ("KP_Prior" , xK_KP_Prior) + , ("KP_Page_Up" , xK_KP_Page_Up) + , ("KP_Next" , xK_KP_Next) + , ("KP_Page_Down", xK_KP_Page_Down) + , ("KP_End" , xK_KP_End) + , ("KP_Begin" , xK_KP_Begin) + , ("KP_Insert" , xK_KP_Insert) + , ("KP_Delete" , xK_KP_Delete) + , ("KP_Equal" , xK_KP_Equal) + , ("KP_Multiply", xK_KP_Multiply) + , ("KP_Add" , xK_KP_Add) + , ("KP_Separator", xK_KP_Separator) + , ("KP_Subtract", xK_KP_Subtract) + , ("KP_Decimal" , xK_KP_Decimal) + , ("KP_Divide" , xK_KP_Divide) + , ("KP_0" , xK_KP_0) + , ("KP_1" , xK_KP_1) + , ("KP_2" , xK_KP_2) + , ("KP_3" , xK_KP_3) + , ("KP_4" , xK_KP_4) + , ("KP_5" , xK_KP_5) + , ("KP_6" , xK_KP_6) + , ("KP_7" , xK_KP_7) + , ("KP_8" , xK_KP_8) + , ("KP_9" , xK_KP_9) + , ("ssharp" , xK_ssharp) + , ("acute" , xK_acute) + ] + +-- | List of multimedia keys. If X server does not know about some +-- | keysym it's omitted from list. (stringToKeysym returns noSymbol in this case) +multimediaKeys :: [(String, KeySym)] +multimediaKeys = filter ((/= noSymbol) . snd) . map (id &&& stringToKeysym) $ + [ "XF86ModeLock" + , "XF86MonBrightnessUp" + , "XF86MonBrightnessDown" + , "XF86KbdLightOnOff" + , "XF86KbdBrightnessUp" + , "XF86KbdBrightnessDown" + , "XF86Standby" + , "XF86AudioLowerVolume" + , "XF86AudioMute" + , "XF86AudioRaiseVolume" + , "XF86AudioPlay" + , "XF86AudioStop" + , "XF86AudioPrev" + , "XF86AudioNext" + , "XF86HomePage" + , "XF86Mail" + , "XF86Start" + , "XF86Search" + , "XF86AudioRecord" + , "XF86Calculator" + , "XF86Memo" + , "XF86ToDoList" + , "XF86Calendar" + , "XF86PowerDown" + , "XF86ContrastAdjust" + , "XF86RockerUp" + , "XF86RockerDown" + , "XF86RockerEnter" + , "XF86Back" + , "XF86Forward" + , "XF86Stop" + , "XF86Refresh" + , "XF86PowerOff" + , "XF86WakeUp" + , "XF86Eject" + , "XF86ScreenSaver" + , "XF86WWW" + , "XF86Sleep" + , "XF86Favorites" + , "XF86AudioPause" + , "XF86AudioMedia" + , "XF86MyComputer" + , "XF86VendorHome" + , "XF86LightBulb" + , "XF86Shop" + , "XF86History" + , "XF86OpenURL" + , "XF86AddFavorite" + , "XF86HotLinks" + , "XF86BrightnessAdjust" + , "XF86Finance" + , "XF86Community" + , "XF86AudioRewind" + , "XF86BackForward" + , "XF86Launch0" + , "XF86Launch1" + , "XF86Launch2" + , "XF86Launch3" + , "XF86Launch4" + , "XF86Launch5" + , "XF86Launch6" + , "XF86Launch7" + , "XF86Launch8" + , "XF86Launch9" + , "XF86LaunchA" + , "XF86LaunchB" + , "XF86LaunchC" + , "XF86LaunchD" + , "XF86LaunchE" + , "XF86LaunchF" + , "XF86ApplicationLeft" + , "XF86ApplicationRight" + , "XF86Book" + , "XF86CD" + , "XF86Calculater" + , "XF86Clear" + , "XF86Close" + , "XF86Copy" + , "XF86Cut" + , "XF86Display" + , "XF86DOS" + , "XF86Documents" + , "XF86Excel" + , "XF86Explorer" + , "XF86Game" + , "XF86Go" + , "XF86iTouch" + , "XF86LogOff" + , "XF86Market" + , "XF86Meeting" + , "XF86MenuKB" + , "XF86MenuPB" + , "XF86MySites" + , "XF86New" + , "XF86News" + , "XF86OfficeHome" + , "XF86Open" + , "XF86Option" + , "XF86Paste" + , "XF86Phone" + , "XF86Q" + , "XF86Reply" + , "XF86Reload" + , "XF86RotateWindows" + , "XF86RotationPB" + , "XF86RotationKB" + , "XF86Save" + , "XF86ScrollUp" + , "XF86ScrollDown" + , "XF86ScrollClick" + , "XF86Send" + , "XF86Spell" + , "XF86SplitScreen" + , "XF86Support" + , "XF86TaskPane" + , "XF86Terminal" + , "XF86Tools" + , "XF86Travel" + , "XF86UserPB" + , "XF86User1KB" + , "XF86User2KB" + , "XF86Video" + , "XF86WheelButton" + , "XF86Word" + , "XF86Xfer" + , "XF86ZoomIn" + , "XF86ZoomOut" + , "XF86Away" + , "XF86Messenger" + , "XF86WebCam" + , "XF86MailForward" + , "XF86Pictures" + , "XF86Music" + , "XF86TouchpadToggle" + , "XF86_Switch_VT_1" + , "XF86_Switch_VT_2" + , "XF86_Switch_VT_3" + , "XF86_Switch_VT_4" + , "XF86_Switch_VT_5" + , "XF86_Switch_VT_6" + , "XF86_Switch_VT_7" + , "XF86_Switch_VT_8" + , "XF86_Switch_VT_9" + , "XF86_Switch_VT_10" + , "XF86_Switch_VT_11" + , "XF86_Switch_VT_12" + , "XF86_Ungrab" + , "XF86_ClearGrab" + , "XF86_Next_VMode" + , "XF86_Prev_VMode" ] + +-- | 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 = return () >> checkKeymap myConfig myKeymap +-- > ... +-- > } +-- +-- NOTE: the @return ()@ in the example above is very important! +-- Otherwise, you might run into problems with infinite mutual +-- recursion: the definition of myConfig depends on the definition of +-- startupHook, which depends on the definition of myConfig, ... and +-- so on. Actually, it's likely that the above example in particular +-- would be OK without the @return ()@, but making @myKeymap@ take +-- @myConfig@ as a parameter would definitely lead to +-- problems. Believe me. It, uh, happened to my friend. In... a +-- dream. Yeah. In any event, the @return () >>@ introduces enough +-- laziness to break the deadlock. +-- +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 = unwords . 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 diff --git a/lib/HistoryGrid.hs b/lib/HistoryGrid.hs new file mode 100644 index 0000000..2c53fe6 --- /dev/null +++ b/lib/HistoryGrid.hs @@ -0,0 +1,42 @@ +module HistoryGrid (openLastHistoryGrid) where + +import Prelude hiding (catch) + +import Control.Exception.Extensible hiding (handle) +import Control.Monad.IO.Class +import Data.List +import qualified Data.Map as M +import Data.Maybe +import System.Directory +import System.IO + +import XMonad.Core +import XMonad.Actions.GridSelect + + +type History = M.Map String [String] + +emptyHistory :: History +emptyHistory = M.empty + +getHistoryFile :: IO FilePath +getHistoryFile = fmap (++ "/history") $ getAppUserDataDirectory "xmonad" + +readHistory :: IO History +readHistory = readHist `catch` \(SomeException _) -> return emptyHistory + where + readHist = do + path <- getHistoryFile + xs <- bracket (openFile path ReadMode) hClose hGetLine + readIO xs + +getLastHistoryItems :: History -> Int -> [String] +getLastHistoryItems hist i = take i $ nub $ fromMaybe [] $ M.lookup "Run: " hist + +getLastHistory :: Int -> IO [String] +getLastHistory count = readHistory >>= \hist -> return $ getLastHistoryItems hist count + +openLastHistoryGrid :: GSConfig String -> Int -> X() +openLastHistoryGrid config count = do + hist <- liftIO $ getLastHistory count + spawnSelected config hist diff --git a/lib/Pass.hs b/lib/Pass.hs new file mode 100644 index 0000000..f29df27 --- /dev/null +++ b/lib/Pass.hs @@ -0,0 +1,142 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Pass +-- Copyright : (c) 2014 Igor Babuschkin, Antoine R. Dumont, Alexander Sulfrian +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Antoine R. Dumont +-- Stability : unstable +-- Portability : unportable +-- +-- This module provides 3 to ease passwords manipulation (generate, read): +-- +-- - one to lookup passwords in the password-storage (located on user's home @$HOME\/.password-store@). +-- +-- - one to generate a password for a given password label that the user inputs. +-- +-- - one to delete a stored password for a given password label that the user inputs. +-- +-- All those prompts benefit from the completion system provided by the module . +-- +-- +-- Source: +-- +-- - The password storage implementation is . +-- +-- - Inspired from +-- +----------------------------------------------------------------------------- + +module Pass ( -- * Usages + -- $usages + passPrompt + , passGeneratePrompt + ) where + +import XMonad (X, io, xfork) +import XMonad.Prompt ( XPrompt + , showXPrompt + , commandToComplete + , nextCompletion + , getNextCompletion + , XPConfig + , mkXPrompt + , mkComplFunFromList) +import XMonad.Util.Run (safeSpawn, runProcessWithInput) +import System.Directory (getHomeDirectory) +import Data.List (isSuffixOf) + +-- $usages +-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: +-- +-- > import XMonad.Prompt.Pass +-- +-- Then add a keybinding for 'passPrompt' or 'passGeneratePrompt': +-- +-- > , ((modMask x , xK_p) , passPrompt xpconfig) +-- > , ((modMask x .|. controlMask, xK_p) , passGeneratePrompt xpconfig) +-- +-- For detailed instructions on: +-- +-- - editing your key bindings, see "XMonad.Doc.Extending#Editing_key_bindings". +-- +-- - how to setup the password storage, see +-- + +type PromptLabel = String + +data Pass = Pass PromptLabel + +instance XPrompt Pass where + showXPrompt (Pass prompt) = prompt ++ ": " + commandToComplete _ c = c + nextCompletion _ = getNextCompletion + +-- | A pass prompt factory. +-- +mkPassPrompt :: PromptLabel -> (String -> X ()) -> XPConfig -> X () +mkPassPrompt promptLabel passwordFunction xpconfig = + io getPasswords >>= + \ passwords -> mkXPrompt (Pass promptLabel) xpconfig (mkComplFunFromList passwords) passwordFunction + +-- | A prompt to retrieve a password from a given entry. +-- +passPrompt :: XPConfig -> X () +passPrompt = mkPassPrompt "Select password" selectPassword + +-- | A prompt to generate a password for a given entry. +-- This can be used to override an already stored entry. +-- (Beware that no confirmation is asked) +-- +passGeneratePrompt :: XPConfig -> X () +passGeneratePrompt = mkPassPrompt "Generate password" generatePassword + +-- | Select a password. +-- +selectPassword :: String -> X () +selectPassword passLabel = io $ do + xfork $ typePassword passLabel + return () + +typePassword :: String -> IO () +typePassword passLabel = do + pass <- runProcessWithInput "pass" ["show", passLabel] [] + runProcessWithInput "xdotool" ["-"] $ getTypeCommand pass + runProcessWithInput "dzen2" + ["-p", "1", "-fn", ":Bold", + "-w", "280", "-h", "50", + "-y", "900", "-x", "700", + "-bg", "darkred", "-fg", "white"] + "Done\n" + return () + +getTypeCommand :: String -> String +getTypeCommand content = "type --clearmodifiers '" ++ getPass content ++ "'" + where + getPass = escapeString . head . lines + escapeString = concat . map escapeChar + escapeChar c + | (c == '\'') = "'\n\"'\"\n'" + | otherwise = [c] + +-- | Generate a 30 characters password for a given entry. +-- If the entry already exists, it is updated with a new password. +-- +generatePassword :: String -> X () +generatePassword passLabel = safeSpawn "pass" ["generate", "--force", passLabel, "30"] + +-- | Retrieve the list of passwords from the default password storage in $HOME/.password-store +-- +getPasswords :: IO [String] +getPasswords = do + home <- getHomeDirectory + files <- runProcessWithInput "find" [home ++ "/.password-store","-type", "f", "-name", "*.gpg", "-printf", "%P\n"] [] + return $ map removeGpgExtension $ lines files + +removeGpgExtension :: String -> String +removeGpgExtension file = + if isSuffixOf ".gpg" file then + reverse $ drop 4 $ reverse file + else + file diff --git a/xmonad.hs b/xmonad.hs new file mode 100644 index 0000000..8865171 --- /dev/null +++ b/xmonad.hs @@ -0,0 +1,456 @@ +import System.IO +import System.Directory +import Data.Ratio ((%)) +import Data.List +import qualified Data.Map as M + +import XMonad +import XMonad.Core +import XMonad.Config +import XMonad.ManageHook +import qualified XMonad.StackSet as W +import qualified XMonad.Prompt as P + +import XMonad.Layout.DecorationMadness +import XMonad.Layout.Grid +import XMonad.Layout.IM +import XMonad.Layout.MosaicAlt +import XMonad.Layout.Named +import XMonad.Layout.NoBorders +import XMonad.Layout.PerWorkspace +import XMonad.Layout.Reflect +import XMonad.Layout.Tabbed +import XMonad.Layout.ThreeColumns +import XMonad.Layout.TrackFloating +import qualified XMonad.Layout.Magnifier as Mag + +import XMonad.Actions.CopyWindow +import XMonad.Actions.CycleWS +import XMonad.Actions.DynamicWorkspaces +import XMonad.Actions.FindEmptyWorkspace +import XMonad.Actions.FloatSnap +import XMonad.Actions.GridSelect +import XMonad.Actions.SinkAll +import XMonad.Actions.UpdateFocus +import qualified XMonad.Actions.FlexibleManipulate as Flex + +import XMonad.Hooks.DynamicLog +import XMonad.Hooks.EwmhDesktops +import XMonad.Hooks.ManageDocks +import XMonad.Hooks.ManageHelpers +import XMonad.Hooks.ServerMode +import XMonad.Hooks.SetWMName +import XMonad.Hooks.UrgencyHook +import XMonad.Hooks.XPropManage + +import XMonad.Prompt.AppLauncher +import XMonad.Prompt.Man +import XMonad.Prompt.Shell +import XMonad.Prompt.Ssh +import XMonad.Prompt.XMonad + +import XMonad.Util.NamedScratchpad + +-- taffybar +import System.Taffybar.Hooks.PagerHints (pagerHints) + +-- --replace handling +import XMonad.Util.Replace (replace) +import Control.Monad (when) +import System.Environment (getArgs) + +-- custom modules +import HistoryGrid +import EZConfig +import Pass + +font :: String +font = "-*-terminus-medium-r-normal-*-12-*-*-*-*-*-*-*" + +term :: String +term = "urxvt" + +browser :: String +browser = "viewurl-opera.sh" + +myWorkspaces :: [String] +myWorkspaces = ["1:web", "2:mail" ,"3:irc", "4:im", "5:code"] ++ map show [6 .. 9 :: Int] ++ ["0", "video", "music"] + +modM = mod4Mask -- mod1Mask = Alt, mod2Mask = , mod3Mask= , mod4Mask = Win, mod5Mask = AltGr + +myDzenUrgencyConfig = DzenUrgencyHook + { args = ["-bg", "red", "-fg", "black", "-fn", font, + "-w", "480", "-ta", "c", "-x", "480"] + , duration = seconds 5 + } + +main = do + args <- getArgs + when ("--replace" `elem` args) replace + + dzenStatusDir <- getAppUserDataDirectory "xmonad" + dzenStatusFile <- openFile (dzenStatusDir ++ "/dzenStatus") WriteMode + xmonad + -- Do _not_ use "ewhm" here, this would add the ewhm hooks to the + -- end of your custom hooks (esp. the startup hook) and this would + -- overwrite the setWMName "LG3D" and some Java apps will not work. + $ pagerHints + $ withUrgencyHook myDzenUrgencyConfig + $ myConfig dzenStatusFile + +myConfig statusFile = defaultConfig + { modMask = modM + , terminal = term + , borderWidth = 1 + , normalBorderColor = "#545454" + , focusedBorderColor = "#A00000" + , logHook = myLogHook statusFile + , manageHook = myManageHook + , keys = \c -> mkKeymap c $ myKeys c + , mouseBindings = \c -> M.union (M.fromList $ myMouse c) $ mouseBindings defaultConfig c + , layoutHook = myLayout + , workspaces = myWorkspaces + , handleEventHook = myEventHook + , startupHook = myStartupHook + } + +-- +-- Prompts +-- + +data MyShell = MyShell +instance XPrompt MyShell where + showXPrompt MyShell = "Run: " +myShellPrompt :: XPConfig -> X () +myShellPrompt c = do + cmds <- io getCommands + mkXPrompt MyShell c (getShellCompl cmds) spawn + +-- +-- Scratchpads +-- + +scratchpads = + [ NS "hotot" "hotot" (className =? "Hotot") + (customFloating $ W.RationalRect 0.01 0.01 0.4 0.98) + , NS "log" "urxvt -name logtail -e logtail" (appName =? "logtail") + (customFloating $ W.RationalRect 0.03 0.03 0.94 0.6) + ] + +hiddenWS :: X (WindowSpace -> Bool) +hiddenWS = do hs <- gets (map W.tag . W.hidden . windowset) + return (\w -> W.tag w `elem` hs) + +notNspWS :: X (WindowSpace -> Bool) +notNspWS = return $ ("NSP" /=) . W.tag + +notNspHiddenWS :: X (WindowSpace -> Bool) +notNspHiddenWS = do nn <- notNspWS + hi <- hiddenWS + return (\w -> hi w && nn w) + + +-- +-- Themes +-- +myPP statusFile = namedScratchpadFilterOutWorkspacePP $ defaultPP + { ppCurrent = wrap "^fg(#FF0000) " " " + , ppVisible = wrap "^fg(#0000FF) " " " + , ppHiddenNoWindows = \(_)->"" + , ppUrgent = wrap "^bg(#FFFF00)^fg(#FF0000) " " " + , ppHidden = pad + , ppWsSep = "^fg(#888)^bg(#000):" + , ppSep = "^fg(#888)^bg(#000):" + , ppLayout = wrap "^fg(#fff)" "^fg(#888)" . pad . (\x -> transformLayout x) + , ppTitle = ("^fg(#FF0000) " ++) . dzenEscape + , ppOrder = \(ws:l:t:[]) -> ["^fg(#888)^bg(#000)" ++ ws,l,t] + , ppOutput = dzenWriteStatus statusFile + } + where + dzenWriteStatus file status = do + hPutStrLn file status + hFlush file + -- helper for better Layoutnames + transformLayout x = foldl1 (++) + $ layoutTransform + $ magnifierTransform + $ [] : words x + magnifierTransform (prefix:magnifier:status:xs) + | magnifier == "Magnifier" && status == "(off)" = (prefix ++ "+"):xs + | magnifier == "Magnifier" = (prefix ++ "*"):status:xs + | otherwise = ((prefix ++ unwords [magnifier, status]):xs) + layoutTransform (prefix:l) + | unwords l == "ThreeCol" = [prefix, "|||"] + | unwords l == "Tabbed" = [prefix, "[ ]"] + | unwords l == "Mirror Tall" = [prefix, "=|="] + | unwords l == "Tall" = [prefix, "[]="] + | otherwise = prefix:l + +alexTheme :: Theme +alexTheme = defaultTheme + { inactiveBorderColor = "#545454" + , activeBorderColor = "#6E0000" + , activeColor = "#6E0000" + , inactiveColor = "#424242" + , inactiveTextColor = "#ffffff" + , activeTextColor = "#ffffff" + , fontName = font + , decoHeight = 15 + } + +historyGridConfig = defaultGSConfig + { gs_cellheight = 50 + , gs_cellwidth = 300 + , gs_navigate = navNSearch + , gs_font = "xft:Droid Sans Mono Slashed-8" + } + +-- +-- Hooks +-- +myLogHook statusFile = do + ewmhDesktopsLogHook + dynamicLogWithPP $ myPP statusFile + +myEventHook = do + ewmhDesktopsEventHook + serverModeEventHook + focusOnMouseMove + docksEventHook + +myStartupHook = do + ewmhDesktopsStartup + adjustEventInput + setWMName "LG3D" + +myManageHook = + namedScratchpadManageHook scratchpads + <+> xPropManageHook xPropMatches + <+> manageDocks + <+> (isDialog + --> doCenterFloat) + + <+> (appName =? "hexcalc" --> + (doRectFloat $ W.RationalRect 0.75 0.505 0.2 0.395)) + <+> (appName =? "xcalc" --> + (doRectFloat $ W.RationalRect 0.75 0.1 0.2 0.395)) + <+> (appName =? "wpa_gui" --> + (doRectFloat $ W.RationalRect 0.01 0.01 0.4 0.25)) + <+> (className =? "Vncviewer" --> + doCenterFloat) + + -- (yt) flash fullscreen mode + <+> (className =? "Operapluginwrapper-native" --> + doFullFloat) + <+> (className =? "Exe" --> + doFullFloat) + + -- xcalendar + <+> (appName =? "dayEditor" --> + (doRectFloat $ W.RationalRect 0.5 0.02 0.33 0.3)) + <+> (appName =? "xcalendar" --> + (doRectFloat $ W.RationalRect 0.83 0.02 0.15 0.3)) + + -- emacs compose mail + <+> (appName =? "wanderlust-draft" --> + (doRectFloat $ W.RationalRect 0.1 0.1 0.8 0.8)) + + <+> (className =? "Gxmessage" --> + doCenterFloat) + +xPropMatches :: [XPropMatch] +xPropMatches = + [ ([ (xprop, any (app `op`))], pmP (W.shift target)) | (xprop, op, app, target) <- myShifts] ++ + [ ([ (xprop, any (app ==))], pmX (float)) | (xprop, app) <- myFloats] + where + myFloats = + [ (wM_CLASS, "vlc") + , (wM_CLASS, "Xmessage") + , (wM_CLASS, "XVkbd") + , (wM_CLASS, "Xdialog") + , (wM_CLASS, "Pinentry") + , (wM_CLASS, "Pinentry-gtk-2") + , (wM_CLASS, "Tiemu") + , (wM_CLASS, "ultrastardx") + , (wM_CLASS, "Ediff") + , (wM_CLASS, "xtensoftphone") + , (wM_CLASS, "Pqiv") + , (wM_CLASS, "XNots") + , (wM_CLASS, "TeamViewer.exe") + , (wM_CLASS, "AmsnWebcam") + , (wM_NAME, "glxgears") + , (wM_NAME, "Passphrase Required") + , (wM_NAME, "Mark all as read") + , (wM_NAME, "Xplanet 1.2.0") + , (wM_NAME, "Eclipse") + ] + + myShifts = + [ (wM_CLASS, (==), "Opera", "1:web") + , (wM_CLASS, (==), "Chrome", "1:web") + , (wM_CLASS, (==), "Chromium-browser", "1:web") + , (wM_CLASS, (==), "Firefox-bin", "1:web") + + , (wM_CLASS, (==), "Claws-mail", "2:mail") + , (wM_CLASS, (==), "Mitter", "2:mail") + , (wM_CLASS, (==), "wanderlust", "2:mail") + , (wM_NAME, (==), "newsbeuter", "2:mail") + + , (wM_CLASS, (==), "Hexchat", "3:irc") + + -- tkabber roater + , (wM_CLASS, (==), "Tkabber", "4:im") + -- tkabber single messages + , (wM_CLASS, (==), "headlines", "4:im") + , (wM_CLASS, isPrefixOf, "chat_##xmpp##1_zedatconferencejabberfuberlinde", "4:im") + , (wM_CLASS, isPrefixOf, "chat_##xmpp##1_mailanimuxdeSyslogBot", "4:im") + + , (wM_CLASS, (==), "emacs", "5:code") + + , (wM_CLASS, (==), "MPlayer", "video") + , (wM_CLASS, (==), "Amarokapp", "music") + ] + +-- +-- Keys +-- +myKeys c = + -- this line is critical to reload config - DON'T REMOVE + [ ("M-q", broadcastMessage ReleaseResources >> restart "xmonad" True) + + , ("M-S-", spawn term) + , ("M-", openLastHistoryGrid historyGridConfig 30) + + -- kill current, kill all + , ("M-S-c", kill1) + , ("M-C-c", kill) + + -- sticky + , ("M-S-v", windows copyToAll) + , ("M-C-v", killAllOtherCopies) + + , ("M-", sendMessage NextLayout) + , ("M-S-", setLayout $ XMonad.layoutHook c) + + , ("M-", windows W.focusDown) + , ("M-S-", windows W.focusUp) + , ("M-j", windows W.focusDown) + , ("M-k", windows W.focusUp) + + , ("M-S-j", windows W.swapDown) + , ("M-S-k", windows W.swapUp) + + , ("M-m", selectWorkspace P.defaultXPConfig) + , ("M-S-m", withWorkspace P.defaultXPConfig (windows . W.shift)) + , ("M-S-", removeWorkspace) + + , ("M-h", sendMessage Shrink) + , ("M-l", sendMessage Expand) + + -- sink / sinkAll + , ("M-t", withFocused $ windows . W.sink) + , ("M-S-t", sinkAll) + + , ("M-z", namedScratchpadAction scratchpads "hotot") + , ("M5-l", namedScratchpadAction scratchpads "log") + + , ("M-,", sendMessage (IncMasterN 1)) + , ("M-.", sendMessage (IncMasterN (-1))) + + , ("M-b", sendMessage ToggleStruts) + + , ("M-i", spawn "xprop | gxmessage -file -") + + , ("M-", moveTo Prev $ WSIs notNspHiddenWS) + , ("M-", moveTo Next $ WSIs notNspHiddenWS) + + , ("M-d", spawn "fbsetroot -solid black") + , ("M-f", spawn "fbsetroot -l") + + , ("M-^", viewEmptyWorkspace) + , ("M-S-^", tagToEmptyWorkspace) + + , ("M-p", myShellPrompt P.defaultXPConfig) + , ("M-e", launchApp P.defaultXPConfig "emacsclient" >> (windows (W.greedyView "5:code"))) + + , ("M-o M-k", passPrompt P.defaultXPConfig) + , ("M-o M-S-k", passGeneratePrompt P.defaultXPConfig) + , ("M-o M-m", manPrompt P.defaultXPConfig) + , ("M-o M-b", safePrompt browser P.defaultXPConfig) + , ("M-o M-s", sshPrompt P.defaultXPConfig) + , ("M-o M-x", xmonadPrompt P.defaultXPConfig) + + , ("M-g", goToSelected defaultGSConfig) + , ("M-S-g", bringSelected defaultGSConfig) + + , ("M-", focusUrgent) + + , ("M-+", sendMessage Mag.MagnifyMore) + , ("M-S-+", sendMessage Mag.MagnifyLess) + , ("M-#", sendMessage Mag.Toggle) + + -- multimedia keys + , ("", spawn "amixer -c0 -- set Master playback 2dB-") + , ("", spawn "amixer -c0 -- set Master playback 2dB+") + , ("", spawn "amixer -q -c0 set Master toggle") + + -- Screenshot + , ("", spawn "scrot '%Y-%m-%d_%s_$wx$h.png' -e 'mv $f ~/images/screenshot/; pqiv ~/images/screenshot/$n'") + + ] + ++ + + -- switch to / move / copy to workspace + [ + (m ++ k, windows $ f i) + | (i, k) <- zip myWorkspaces $ [[k] | k <- "1234567890"] ++ ["", ""], + (m, f) <- [("M-", W.view), ("M-S-", W.shift), ("M-C-", copy)] + ] + ++ + + [ + (m ++ k, screenWorkspace s >>= flip whenJust (windows . f)) + | (k, s) <- [("a", 0), ("s", 1)], + (m, f) <- [("M-", W.view), ("M-S-", W.shift), ("M-C-", copy)] + ] + +myMouse c = + [ ((modM, button1), + (\w -> focus w >> mouseMoveWindow w >> snapMagicMove (Just 50) (Just 50) w)) + + , ((modM .|. shiftMask, button1), + (\w -> focus w >> mouseMoveWindow w >> snapMagicMouseResize 0.8 (Just 50) (Just 50) w)) + + , ((modM, button3), + (\w -> focus w >> Flex.mouseWindow Flex.resize w)) + ] + +-- +-- Layout +-- +myLayout = + avoidStruts + $ smartBorders + $ Mag.magnifierOff + $ trackFloating + + $ onWorkspace "2:mail" layoutsTabbed + $ onWorkspace "4:im" (imgrid ||| imtab ||| immosaic) + $ onWorkspace "5:code" layoutsTabbed + $ onWorkspace "video" (noBorders tabbed) + $ onWorkspace "gimp" gimp + $ layouts + where + layouts = tiled ||| Mirror tiled ||| ThreeColMid 1 (3/100) (1/2) ||| tabbed + layoutsTabbed = tabbed ||| tiled ||| Mirror tiled ||| ThreeColMid 1 (3/100) (1/2) + tiled = Tall 1 (3/100) (1/2) + gimp = named "gimp" + $ withIM (0.11) (Role "gimp-toolbox") + $ reflectHoriz + $ withIM (0.15) (Role "gimp-dock") (trackFloating tabbed) + tabbed = named "Tabbed" + $ tabbedBottom shrinkText alexTheme + imbase a = withIM (1%7) (Or (ClassName "Tkabber") (Role "roster")) a + imgrid = imbase Grid + imtab = imbase tabbed + immosaic = imbase $ MosaicAlt M.empty -- cgit v1.2.3