diff options
Diffstat (limited to '')
| -rw-r--r-- | XMonad/Config/PlainConfig.hs | 527 |
1 files changed, 527 insertions, 0 deletions
diff --git a/XMonad/Config/PlainConfig.hs b/XMonad/Config/PlainConfig.hs new file mode 100644 index 0000000..dc0f178 --- /dev/null +++ b/XMonad/Config/PlainConfig.hs @@ -0,0 +1,527 @@ +{-# LANGUAGE + FlexibleInstances, + FlexibleContexts, + MultiParamTypeClasses, + ExistentialQuantification + #-} + +------------------------------------------------------------------------- +-- | +-- Module : XMonad.Config.PlainConfig +-- Copyright : Braden Shepherdson <Braden.Shepherdson@gmail.com> +-- License : BSD3 +-- +-- Maintainer : Braden Shepherdson <Braden.Shepherdson@gmail.com> +-- +-- Proof-of-concept (but usable) plain-text configuration file +-- parser, for use instead of xmonad.hs. Does not require recompilation, +-- allowing xmonad to be free of the GHC dependency. +-- +------------------------------------------------------------------------- + + +module XMonad.Config.PlainConfig + ( + -- * Introduction + -- $usage + + -- * Supported Layouts + -- $layouts + + -- * Support Key Bindings + -- $keys + + -- * Other Notes + -- $notes + + -- * Example Config File + -- $example + + plainConfig ,readConfig, checkConfig + ) +where + + +import XMonad +import System.Exit + +import qualified XMonad.StackSet as W +import qualified Data.Map as M +import Data.List +import Data.Maybe (isJust,fromJust) +import Data.Char (isSpace) + + +--import Control.Monad +import Control.Monad.Error +import Control.Monad.Identity + +import Control.Arrow ((&&&)) + +import Text.ParserCombinators.ReadP + +import System.IO +import Control.Exception (bracket) + +import XMonad.Util.EZConfig (mkKeymap) + + + +-- $usage +-- The @xmonad.hs@ file is very minimal when used with PlainConfig. +-- It typically contains only the following: +-- +-- > module Main where +-- > import XMonad +-- > import XMonad.Config.PlainConfig (plainConfig) +-- > main = plainConfig +-- +-- The 'plainConfig' function parses @~\/.xmonad\/xmonad.conf@, +-- the format of which is described below. + + +-- $layouts +-- Only 'Tall', 'Wide' and 'Full' are supported at present. + + + +-- $keys +-- +-- Key bindings are specified as a pair of an arbitrary EZConfig and +-- one of the following: +-- +-- @ Name Haskell equivalent Default binding(s)@ +-- +-- * @spawn \<cmd\> spawn \"\<cmd\>\" none@ +-- +-- * @kill kill M-S-c@ +-- +-- * @nextLayout sendMessage NextLayout M-\<Space\>@ +-- +-- * @refresh refresh M-S-\<Space\>@ +-- +-- * @focusDown windows W.focusDown M-\<Tab\>, M-j@ +-- +-- * @focusUp windows W.focusUp M-k@ +-- +-- * @focusMaster windows W.focusMaster M-m@ +-- +-- * @swapDown windows W.swapDown M-S-j@ +-- +-- * @swapUp windows W.swapUp M-S-k@ +-- +-- * @swapMaster windows W.swapMaster M-\<Return\>@ +-- +-- * @shrink sendMessage Shrink M-h@ +-- +-- * @expand sendMessage Expand M-l@ +-- +-- * @sink withFocused $ windows . W.sink M-t@ +-- +-- * @incMaster sendMessage (IncMasterN 1) M-,@ +-- +-- * @decMaster sendMessage (IncMasterN (-1)) M-.@ +-- +-- * @quit io $ exitWith ExitSuccess M-S-q@ +-- +-- * @restart broadcastMessageReleaseResources >> restart \"xmonad\" True M-q@ +-- + + +-- $notes +-- Submaps are allowed. +-- These settings override the defaults. Changes made here will be used over +-- the default bindings for those keys. + + +-- $example +-- An example @~\/.xmonad\/xmonad.conf@ file follows: +-- +-- @modMask = 3@ +-- +-- @numlockMask = 2@ +-- +-- @borderWidth = 1@ +-- +-- @normalBorderColor = #dddddd@ +-- +-- @focusedBorderColor = #00ff00@ +-- +-- @terminal=urxvt@ +-- +-- @workspaces=[\"1: IRC\",\"2: Web\", \"3\", \"4\", \"5\", \"6\", \"7\", \"8\", \"9\"]@ +-- +-- @focusFollowsMouse=True@ +-- +-- @layouts=[\"Tall\",\"Full\",\"Wide\"]@ +-- +-- @key=(\"M-x t\", \"spawn xmessage Test\")@ +-- +-- @manageHook=(ClassName \"MPlayer\" , \"float\" )@ +-- +-- @manageHook=(ClassName \"Gimp\" , \"float\" )@ +-- +-- @manageHook=(Resource \"desktop_window\", \"ignore\" )@ +-- +-- @manageHook=(Resource \"kdesktop\" , \"ignore\" )@ +-- +-- @manageHook=(Resource \"gnome-panel\" , \"ignore\" )@ +-- + + + + + + +---------------------------------------------------------------- +------ Several functions for parsing the key-value file. ------- +---------------------------------------------------------------- + +parseKVBy :: Char -> ReadP (String,String) +parseKVBy sep = do + skipSpaces + k <- munch1 (\x -> x /= ' ' && x /= sep) + skipSpaces + char kvSep + skipSpaces + v <- munch1 (\x -> x /= ' ') --or EOS + return (k,v) + +parseKVVBy :: Char -> ReadP (String,String) +parseKVVBy sep = do + skipSpaces + k <- munch1 (\x -> x /= ' ' && x /= sep) + skipSpaces + char kvSep + skipSpaces + v <- munch1 (const True) -- until EOS + return (k,v) + + +kvSep :: Char +kvSep = '=' + +parseKV, parseKVV :: ReadP (String,String) +parseKV = parseKVBy kvSep +parseKVV = parseKVVBy kvSep + + + +readKV :: String -> Integer -> RC (String,String) +readKV s ln = case readP_to_S parseKV s of + [((k,v),"")] -> return (k,v) --single, correct parse + [] -> throwError [(ln,"No parse")] + _ -> do + case readP_to_S parseKVV s of + [((k,v),"")] -> return (k,v) --single, correct parse + [] -> throwError [(ln,"No parse")] + xs -> throwError [(ln,"Ambiguous parse: " + ++ show xs)] + + + +isComment :: String -> Bool +isComment = not . null . readP_to_S parseComment + where parseComment = skipSpaces >> char '#' >> return () + -- null means failed parse, so _not_ a comment. + + +isBlank :: String -> Bool +isBlank = null . filter (not . isSpace) + + +type RC = ErrorT [(Integer,String)] Identity + +instance Error [(Integer,String)] where + noMsg = [(-1, "Unknown error.")] + strMsg s = [(-1, s)] + + +parseFile :: [String] -> RC (XConfig Layout) +parseFile ss = parseLines baseConfig theLines + where theLines = filter (not . liftM2 (||) isComment isBlank . snd) + $ zip [1..] ss + + + +parseLines :: XConfig Layout -> [(Integer,String)] -> RC (XConfig Layout) +parseLines = foldM parse + + +parse :: XConfig Layout -> (Integer, String) -> RC (XConfig Layout) +parse xc (ln,s) = do + (k,v) <- readKV s ln + case M.lookup k commands of + Nothing -> throwError [(ln,"Unknown command: "++k)] + Just f -> f v ln xc + + + + +---------------------------------------------------------------- +-- Now the semantic parts, that convert from the relevant -- +-- key-value entries to values in an XConfig -- +---------------------------------------------------------------- + + + +type Command = String -> Integer -> XConfig Layout -> RC (XConfig Layout) + +commands :: M.Map String Command +commands = M.fromList $ + [("modMask" , cmd_modMask ) + ,("numlockMask" , cmd_numlockMask ) + ,("normalBorderColor" , cmd_normalBorderColor ) + ,("focusedBorderColor" , cmd_focusedBorderColor) + ,("terminal" , cmd_terminal ) + ,("workspaces" , cmd_workspaces ) + ,("focusFollowsMouse" , cmd_focusFollowsMouse ) + ,("layouts" , cmd_layouts ) + ,("key" , cmd_key ) + ,("manageHook" , cmd_manageHook ) + ,("borderWidth" , cmd_borderWidth ) + ] + + +-- | Behind-the-scenes helper for both 'cmd_modMask' and 'cmd_numlockMask'. +genericModKey :: (KeyMask -> XConfig Layout) -> Command +genericModKey f s ln _ = do + x <- rcRead s ln :: RC Integer + case lookup x (zip [1..] [mod1Mask,mod2Mask,mod3Mask,mod4Mask,mod5Mask]) of + Just y -> return $ f y + Nothing -> throwError [(ln,"Invalid mod key number: "++ show x)] + + +-- | Reads the mod key modifier number. +cmd_modMask :: Command +cmd_modMask s ln xc = genericModKey (\k -> xc{modMask = k}) s ln xc + +-- | Reads the numlock key modifier number. +cmd_numlockMask :: Command +cmd_numlockMask s ln xc = genericModKey (\k -> xc{numlockMask = k}) s ln xc + + +-- | Reads the border width. +cmd_borderWidth :: Command +cmd_borderWidth s ln xc = do + w <- rcRead s ln + return $ xc { borderWidth = w } + + +-- | Reads the colors but just keeps them as RRGGBB Strings. +cmd_normalBorderColor, cmd_focusedBorderColor :: Command +cmd_normalBorderColor s _ xc = return $ xc{ normalBorderColor = s } +cmd_focusedBorderColor s _ xc = return $ xc{ focusedBorderColor = s } + + +-- | Reads the terminal. It is just a String, no parsing. +cmd_terminal :: Command +cmd_terminal s _ xc = return $ xc{ terminal = s } + + +-- | Reads the workspace tag list. This is given as a Haskell [String]. +cmd_workspaces :: Command +cmd_workspaces s ln xc = rcRead s ln >>= \x -> return xc{ workspaces = x } + + +-- | Reads the focusFollowsMouse, as a Haskell Bool. +cmd_focusFollowsMouse :: Command +cmd_focusFollowsMouse s ln xc = rcRead s ln >>= + \x -> return xc{focusFollowsMouse = x} + + +-- | The list known layouts, mapped by name. +-- An easy location for improvement is to add more contrib layouts here. +layouts :: M.Map String (Layout Window) +layouts = M.fromList + [("Tall", Layout (Tall 1 (3/100) (1/2))) + ,("Wide", Layout (Mirror (Tall 1 (3/100) (1/2)))) + ,("Full", Layout Full) + ] + + +-- | Expects a [String], the strings being layout names. Quotes required. +-- Draws from the `layouts' list above. +cmd_layouts :: Command +cmd_layouts s ln xc = do + xs <- rcRead s ln -- read the list of strings + let ls = map (id &&& (flip M.lookup) layouts) xs + when (null ls) $ throwError [(ln,"Empty layout list")] + case filter (not . isJust . snd) ls of + [] -> return $ xc{ layoutHook = foldr1 + (\(Layout l) (Layout r) -> + Layout (l ||| r)) (map (fromJust . snd) ls) + } + ys -> throwError $ map (\(x,_) -> (ln, "Unknown layout: "++ x)) ys + + + +-- | A Map from names to key binding actions. +key_actions :: M.Map String (X ()) +key_actions = M.fromList + [("kill" , kill ) + ,("nextLayout" , sendMessage NextLayout ) + --,("prevLayout" , sendMessage PrevLayout ) + --,("resetLayout" , setLayout $ XMonad.layoutHook conf) + ,("refresh" , refresh ) + ,("focusDown" , windows W.focusDown ) + ,("focusUp" , windows W.focusUp ) + ,("focusMaster" , windows W.focusMaster ) + ,("swapMaster" , windows W.swapMaster ) + ,("swapDown" , windows W.swapDown ) + ,("swapUp" , windows W.swapUp ) + ,("shrink" , sendMessage Shrink ) + ,("expand" , sendMessage Expand ) + ,("sink" , withFocused $ windows . W.sink) + ,("incMaster" , sendMessage (IncMasterN 1)) + ,("decMaster" , sendMessage (IncMasterN (-1))) + ,("quit" , io $ exitWith ExitSuccess) + ,("restart" , broadcastMessage ReleaseResources + >> restart "xmonad" True) + ] + + +-- | Expects keys as described in the preamble, as +-- (\"EZConfig key name\", \"action name\"), +-- eg. (\"M-S-t\", \"spawn thunderbird\") +-- One key per "key=" line. +cmd_key :: Command +cmd_key s ln xc = do + (k,v) <- rcRead s ln + if "spawn " `isPrefixOf` v + then return $ xc { + keys = \c -> M.union (mkKeymap c + [(k, spawn (drop 6 v))] + ) ((keys xc) c) + } + else do + case M.lookup v key_actions of + Nothing -> throwError [(ln, "Unknown key action \"" ++ v ++ "\"")] + Just ac -> return $ + xc { keys = \c -> M.union (mkKeymap c [(k, ac)]) + ((keys xc) c) + } + + + +-- | Map of names to actions for 'ManageHook's. +manageHook_actions :: M.Map String ManageHook +manageHook_actions = M.fromList + [("float" , doFloat ) + ,("ignore" , doIgnore ) + ] + + +-- | Parses 'ManageHook's in the form given in the preamble. +-- eg. (ClassName \"MPlayer\", \"float\") +cmd_manageHook :: Command +cmd_manageHook s ln xc = do + (k,v) <- rcRead s ln + let q = parseQuery k + if "toWorkspace " `isPrefixOf` v + then return $ xc { manageHook = manageHook xc <+> + (q --> doShift (drop 12 v)) + } + else case M.lookup v manageHook_actions of + Nothing -> throwError [(ln, "Unknown ManageHook action \"" + ++ v ++ "\"")] + Just ac -> return $ xc { manageHook = manageHook xc <+> (q --> ac) } + + + +-- | Core of the ManageHook expression parser. +-- Taken from Roman Cheplyaka's WindowProperties +parseQuery :: Property -> Query Bool +parseQuery (Title s) = title =? s +parseQuery (ClassName s) = className =? s +parseQuery (Resource s) = resource =? s +parseQuery (And p q) = parseQuery p <&&> parseQuery q +parseQuery (Or p q) = parseQuery p <&&> parseQuery q +parseQuery (Not p) = not `fmap` parseQuery p +parseQuery (Const b) = return b + + +-- | Property constructors are quite self-explaining. +-- Taken from Roman Cheplyaka's WindowProperties +data Property = Title String + | ClassName String + | Resource String + | And Property Property + | Or Property Property + | Not Property + | Const Bool + deriving (Read, Show) + + + +-- | A wrapping of the read function into the RC monad. +rcRead :: (Read a) => String -> Integer -> RC a +rcRead s ln = case reads s of + [(x,"")] -> return x + _ -> throwError [(ln, "Failed to parse value")] + + + +-- | The standard Config.hs 'defaultConfig', with the layout wrapped. +baseConfig :: XConfig Layout +baseConfig = defaultConfig{ layoutHook = Layout (layoutHook defaultConfig) } + + + +-- | Core function that attempts to parse @~\/.xmonad\/xmonad.conf@ +readConfig :: IO (Maybe (XConfig Layout)) +readConfig = do + cs <- bracket (openFile "/home/braden/.xmonad/xmonad.conf" ReadMode) + (\h -> hClose h) -- vv force the lazy IO + (\h -> (lines `fmap` hGetContents h) >>= \ss -> + length ss `seq` return ss) + let xce = runIdentity $ runErrorT $ parseFile cs + case xce of + Left es -> mapM_ (\(ln,e) -> + putStrLn $ "readConfig error: line "++show ln++ + ": "++ e) es + >> return Nothing + Right xc -> return $ Just xc + + +-- | Attempts to run readConfig, and checks if it failed. +checkConfig :: IO Bool +checkConfig = isJust `fmap` readConfig + + + +{- REMOVED: It was for debugging, and causes an 'orphaned instances' + warning to boot. + + + +-- | Reads in the config, and then prints the resulting XConfig +dumpConfig :: IO () +dumpConfig = readConfig >>= print + + +instance Show (XConfig Layout) where + show x = "XConfig { " + ++ "normalBorderColor = "++ normalBorderColor x ++", " + ++ "focusedBorderColor = "++ focusedBorderColor x++", " + ++ "terminal = "++ terminal x ++", " + ++ "workspaces = "++ show (workspaces x) ++", " + ++ "numlockMask = "++ show (numlockMask x) ++", " + ++ "modMask = "++ show (modMask x) ++", " + ++ "borderWidth = "++ show (borderWidth x) ++", " + ++ "focusFollowsMouse = "++ show (focusFollowsMouse x) ++", " + ++ "layouts = "++ show (layoutHook x) ++" }" + +-} + +-- | Handles the unwrapping of the Layout. Intended for use as +-- @main = plainConfig@ +plainConfig :: IO () +plainConfig = do + conf <- readConfig + case conf of + (Just xc@XConfig{layoutHook= (Layout l)}) -> + xmonad (xc{ layoutHook = l }) + Nothing -> + spawn $ "xmessage Failed to read xmonad.conf. See xmonad.errors." + |