module XMonad.Config.PlainConfig
(
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.Error
import Control.Monad.Identity
import Control.Arrow ((&&&))
import Text.ParserCombinators.ReadP
import System.IO
import Control.Exception (bracket)
import XMonad.Util.EZConfig (mkKeymap)
parseKVBy :: Char -> ReadP (String,String)
parseKVBy sep = do
skipSpaces
k <- munch1 (\x -> x /= ' ' && x /= sep)
skipSpaces
char kvSep
skipSpaces
v <- munch1 (\x -> x /= ' ')
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)
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)
[] -> throwError [(ln,"No parse")]
_ -> do
case readP_to_S parseKVV s of
[((k,v),"")] -> return (k,v)
[] -> 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 ()
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
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 )
]
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)]
cmd_modMask :: Command
cmd_modMask s ln xc = genericModKey (\k -> xc{modMask = k}) s ln xc
cmd_numlockMask :: Command
cmd_numlockMask s ln xc = genericModKey (\k -> xc{numlockMask = k}) s ln xc
cmd_borderWidth :: Command
cmd_borderWidth s ln xc = do
w <- rcRead s ln
return $ xc { borderWidth = w }
cmd_normalBorderColor, cmd_focusedBorderColor :: Command
cmd_normalBorderColor s _ xc = return $ xc{ normalBorderColor = s }
cmd_focusedBorderColor s _ xc = return $ xc{ focusedBorderColor = s }
cmd_terminal :: Command
cmd_terminal s _ xc = return $ xc{ terminal = s }
cmd_workspaces :: Command
cmd_workspaces s ln xc = rcRead s ln >>= \x -> return xc{ workspaces = x }
cmd_focusFollowsMouse :: Command
cmd_focusFollowsMouse s ln xc = rcRead s ln >>=
\x -> return xc{focusFollowsMouse = x}
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)
]
cmd_layouts :: Command
cmd_layouts s ln xc = do
xs <- rcRead s ln
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
key_actions :: M.Map String (X ())
key_actions = M.fromList
[("kill" , kill )
,("nextLayout" , sendMessage NextLayout )
,("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)
]
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)
}
manageHook_actions :: M.Map String ManageHook
manageHook_actions = M.fromList
[("float" , doFloat )
,("ignore" , doIgnore )
]
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) }
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
data Property = Title String
| ClassName String
| Resource String
| And Property Property
| Or Property Property
| Not Property
| Const Bool
deriving (Read, Show)
rcRead :: (Read a) => String -> Integer -> RC a
rcRead s ln = case reads s of
[(x,"")] -> return x
_ -> throwError [(ln, "Failed to parse value")]
baseConfig :: XConfig Layout
baseConfig = defaultConfig{ layoutHook = Layout (layoutHook defaultConfig) }
readConfig :: IO (Maybe (XConfig Layout))
readConfig = do
dir <- getXMonadDir
cs <- bracket (openFile (dir++"/xmonad.conf") ReadMode)
(\h -> hClose h)
(\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
checkConfig :: IO Bool
checkConfig = isJust `fmap` readConfig
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."