bluetile-0.5: src/ConfigParser.hs
{-# LANGUAGE FlexibleContexts #-}
----------------------------------------------------------------------------
-- |
-- Module : ConfigParser
-- Copyright : (c) Jan Vornberger 2010
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de
-- Stability : unstable
-- Portability : not portable
--
-- This module helps to parse Bluetile's configuration file
--
-----------------------------------------------------------------------------
module ConfigParser (
parseConfigFile,
BluetileRC(..),
displayIdentifiers
) where
import XMonad
import qualified Data.ConfigFile as CF
import Control.Monad.Error
import Data.Char
import Data.List
import Text.Regex
import System.Exit
data BluetileRC = BluetileRC { defaultModifierBRC :: KeyMask
, focusFollowsMouseBRC :: Bool
, terminalBRC :: String
, startDockBRC :: Bool
, keysBRC :: [(String, (KeyMask, KeySym))]
} deriving (Show)
maskKeywordsBRC :: [(String, KeyMask)]
maskKeywordsBRC = [ ("Shift", shiftMask)
, ("Lock", lockMask)
, ("Ctrl", controlMask)
, ("Mod1", mod1Mask)
, ("Mod2", mod2Mask)
, ("Mod3", mod3Mask)
, ("Mod4", mod4Mask)
, ("Mod5", mod5Mask)
]
keysKeywordsBRC :: [(String, KeySym)]
keysKeywordsBRC = [ ("BackSpace", xK_BackSpace)
, ("Tab", xK_Tab)
, ("Linefeed", xK_Linefeed)
, ("Clear", xK_Clear)
, ("Return", xK_Return)
, ("Pause", xK_Pause)
, ("Scroll_Lock", xK_Scroll_Lock)
, ("Sys_Req", xK_Sys_Req)
, ("Escape", xK_Escape)
, ("Delete", xK_Delete)
, ("Home", xK_Home)
, ("Left", xK_Left)
, ("Up", xK_Up)
, ("Right", xK_Right)
, ("Down", xK_Down)
, ("Prior", xK_Prior)
, ("Page_Up", xK_Page_Up)
, ("Next", xK_Next)
, ("Page_Down", xK_Page_Down)
, ("End", xK_End)
, ("Begin", xK_Begin)
, ("Select", xK_Select)
, ("Print", xK_Print)
, ("Execute", xK_Execute)
, ("Insert", xK_Insert)
, ("Undo", xK_Undo)
, ("Redo", xK_Redo)
, ("Menu", xK_Menu)
, ("Find", xK_Find)
, ("Cancel", xK_Cancel)
, ("Help", xK_Help)
, ("Break", xK_Break)
, ("Num_Lock", xK_Num_Lock)
, ("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)
, ("F1", xK_F1)
, ("F2", xK_F2)
, ("F3", xK_F3)
, ("F4", xK_F4)
, ("F5", xK_F5)
, ("F6", xK_F6)
, ("F7", xK_F7)
, ("F8", xK_F8)
, ("F9", xK_F9)
, ("F10", xK_F10)
, ("F11", xK_F11)
, ("L1", xK_L1)
, ("F12", xK_F12)
, ("L2", xK_L2)
, ("F13", xK_F13)
, ("L3", xK_L3)
, ("F14", xK_F14)
, ("L4", xK_L4)
, ("F15", xK_F15)
, ("L5", xK_L5)
, ("F16", xK_F16)
, ("L6", xK_L6)
, ("F17", xK_F17)
, ("L7", xK_L7)
, ("F18", xK_F18)
, ("L8", xK_L8)
, ("F19", xK_F19)
, ("L9", xK_L9)
, ("F20", xK_F20)
, ("L10", xK_L10)
, ("F21", xK_F21)
, ("R1", xK_R1)
, ("F22", xK_F22)
, ("R2", xK_R2)
, ("F23", xK_F23)
, ("R3", xK_R3)
, ("F24", xK_F24)
, ("R4", xK_R4)
, ("F25", xK_F25)
, ("R5", xK_R5)
, ("F26", xK_F26)
, ("R6", xK_R6)
, ("F27", xK_F27)
, ("R7", xK_R7)
, ("F28", xK_F28)
, ("R8", xK_R8)
, ("F29", xK_F29)
, ("R9", xK_R9)
, ("F30", xK_F30)
, ("R10", xK_R10)
, ("F31", xK_F31)
, ("R11", xK_R11)
, ("F32", xK_F32)
, ("R12", xK_R12)
, ("F33", xK_F33)
, ("R13", xK_R13)
, ("F34", xK_F34)
, ("R14", xK_R14)
, ("F35", xK_F35)
, ("R15", xK_R15)
, ("space", xK_space)
, ("exclam", xK_exclam)
, ("quotedbl", xK_quotedbl)
, ("numbersign", xK_numbersign)
, ("dollar", xK_dollar)
, ("percent", xK_percent)
, ("ampersand", xK_ampersand)
, ("apostrophe", xK_apostrophe)
, ("quoteright", xK_quoteright)
, ("parenleft", xK_parenleft)
, ("parenright", xK_parenright)
, ("asterisk", xK_asterisk)
, ("plus", xK_plus)
, ("comma", xK_comma)
, ("minus", xK_minus)
, ("period", xK_period)
, ("slash", xK_slash)
, ("0", xK_0)
, ("1", xK_1)
, ("2", xK_2)
, ("3", xK_3)
, ("4", xK_4)
, ("5", xK_5)
, ("6", xK_6)
, ("7", xK_7)
, ("8", xK_8)
, ("9", xK_9)
, ("colon", xK_colon)
, ("semicolon", xK_semicolon)
, ("less", xK_less)
, ("equal", xK_equal)
, ("greater", xK_greater)
, ("question", xK_question)
, ("at", xK_at)
, ("bracketleft", xK_bracketleft)
, ("backslash", xK_backslash)
, ("bracketright", xK_bracketright)
, ("asciicircum", xK_asciicircum)
, ("underscore", xK_underscore)
, ("grave", xK_grave)
, ("quoteleft", xK_quoteleft)
, ("a", xK_a)
, ("b", xK_b)
, ("c", xK_c)
, ("d", xK_d)
, ("e", xK_e)
, ("f", xK_f)
, ("g", xK_g)
, ("h", xK_h)
, ("i", xK_i)
, ("j", xK_j)
, ("k", xK_k)
, ("l", xK_l)
, ("m", xK_m)
, ("n", xK_n)
, ("o", xK_o)
, ("p", xK_p)
, ("q", xK_q)
, ("r", xK_r)
, ("s", xK_s)
, ("t", xK_t)
, ("u", xK_u)
, ("v", xK_v)
, ("w", xK_w)
, ("x", xK_x)
, ("y", xK_y)
, ("z", xK_z)
, ("braceleft", xK_braceleft)
, ("bar", xK_bar)
, ("braceright", xK_braceright)
, ("asciitilde", xK_asciitilde)
, ("nobreakspace", xK_nobreakspace)
, ("exclamdown", xK_exclamdown)
, ("cent", xK_cent)
, ("sterling", xK_sterling)
, ("currency", xK_currency)
, ("yen", xK_yen)
, ("brokenbar", xK_brokenbar)
, ("section", xK_section)
, ("diaeresis", xK_diaeresis)
, ("copyright", xK_copyright)
, ("ordfeminine", xK_ordfeminine)
, ("guillemotleft", xK_guillemotleft)
, ("notsign", xK_notsign)
, ("hyphen", xK_hyphen)
, ("registered", xK_registered)
, ("macron", xK_macron)
, ("degree", xK_degree)
, ("plusminus", xK_plusminus)
, ("twosuperior", xK_twosuperior)
, ("threesuperior", xK_threesuperior)
, ("acute", xK_acute)
, ("mu", xK_mu)
, ("paragraph", xK_paragraph)
, ("periodcentered", xK_periodcentered)
, ("cedilla", xK_cedilla)
, ("onesuperior", xK_onesuperior)
, ("masculine", xK_masculine)
, ("guillemotright", xK_guillemotright)
, ("onequarter", xK_onequarter)
, ("onehalf", xK_onehalf)
, ("threequarters", xK_threequarters)
, ("questiondown", xK_questiondown)
, ("Agrave", xK_Agrave)
, ("Aacute", xK_Aacute)
, ("Acircumflex", xK_Acircumflex)
, ("Atilde", xK_Atilde)
, ("Adiaeresis", xK_Adiaeresis)
, ("Aring", xK_Aring)
, ("AE", xK_AE)
, ("Ccedilla", xK_Ccedilla)
, ("Egrave", xK_Egrave)
, ("Eacute", xK_Eacute)
, ("Ecircumflex", xK_Ecircumflex)
, ("Ediaeresis", xK_Ediaeresis)
, ("Igrave", xK_Igrave)
, ("Iacute", xK_Iacute)
, ("Icircumflex", xK_Icircumflex)
, ("Idiaeresis", xK_Idiaeresis)
, ("ETH", xK_ETH)
, ("Eth", xK_Eth)
, ("Ntilde", xK_Ntilde)
, ("Ograve", xK_Ograve)
, ("Oacute", xK_Oacute)
, ("Ocircumflex", xK_Ocircumflex)
, ("Otilde", xK_Otilde)
, ("Odiaeresis", xK_Odiaeresis)
, ("multiply", xK_multiply)
, ("Ooblique", xK_Ooblique)
, ("Ugrave", xK_Ugrave)
, ("Uacute", xK_Uacute)
, ("Ucircumflex", xK_Ucircumflex)
, ("Udiaeresis", xK_Udiaeresis)
, ("Yacute", xK_Yacute)
, ("THORN", xK_THORN)
, ("Thorn", xK_Thorn)
, ("ssharp", xK_ssharp)
, ("agrave", xK_agrave)
, ("aacute", xK_aacute)
, ("acircumflex", xK_acircumflex)
, ("atilde", xK_atilde)
, ("adiaeresis", xK_adiaeresis)
, ("aring", xK_aring)
, ("ae", xK_ae)
, ("ccedilla", xK_ccedilla)
, ("egrave", xK_egrave)
, ("eacute", xK_eacute)
, ("ecircumflex", xK_ecircumflex)
, ("ediaeresis", xK_ediaeresis)
, ("igrave", xK_igrave)
, ("iacute", xK_iacute)
, ("icircumflex", xK_icircumflex)
, ("idiaeresis", xK_idiaeresis)
, ("eth", xK_eth)
, ("ntilde", xK_ntilde)
, ("ograve", xK_ograve)
, ("oacute", xK_oacute)
, ("ocircumflex", xK_ocircumflex)
, ("otilde", xK_otilde)
, ("odiaeresis", xK_odiaeresis)
, ("division", xK_division)
, ("oslash", xK_oslash)
, ("ugrave", xK_ugrave)
, ("uacute", xK_uacute)
, ("ucircumflex", xK_ucircumflex)
, ("udiaeresis", xK_udiaeresis)
, ("yacute", xK_yacute)
, ("thorn", xK_thorn)
, ("ydiaeresis", xK_ydiaeresis)
]
maskKeywordsBRC' :: [(String, KeyMask)]
maskKeywordsBRC' = map (\(k, v) -> (map toLower k, v)) maskKeywordsBRC
keysKeywordsBRC' :: [(String, KeySym)]
keysKeywordsBRC' = map (\(k, v) -> (map toLower k, v)) keysKeywordsBRC
lookupMask :: MonadError CF.CPError m => [(String, KeyMask)] -> String -> m KeyMask
lookupMask t k = case (lookup (map toLower k) t) of
(Just v) -> return v
(Nothing) -> throwError (CF.OtherProblem ("Unknown modifier '" ++ k ++ "'"), "other_problem")
lookupKey :: MonadError CF.CPError m => String -> m KeySym
lookupKey k = case (lookup (map toLower k) keysKeywordsBRC') of
(Just v) -> return v
(Nothing) -> throwError (CF.OtherProblem ("Unknown key '" ++ k ++ "'"), "other_problem")
parseKeyCombo :: MonadError CF.CPError m => [(String, KeyMask)] -> String -> m (KeyMask, KeySym)
parseKeyCombo maskKBRC combo = do
let parts = splitRegex (mkRegex "\\+") combo
if (length parts > 0)
then do
masks <- mapM (lookupMask maskKBRC) (init parts)
key <- lookupKey (last parts)
return (foldl (.|.) 0 masks, key)
else throwError (CF.OtherProblem ("Empty key binding"), "other_problem")
parseKeyBinding :: MonadError CF.CPError m => [(String, KeyMask)] -> (String, String) -> m (String, (KeyMask, KeySym))
parseKeyBinding maskKBRC (desc, keyCombo) = do
keyBinding <- parseKeyCombo maskKBRC keyCombo
return (desc, keyBinding)
parseConfigFile :: FilePath -> FilePath -> IO BluetileRC
parseConfigFile systemConfig userConfig = do
rv <- runErrorT $ do
-- read files
cpDefault <- join $ liftIO $ CF.readfile CF.emptyCP systemConfig
cp <- join $ liftIO $ CF.readfile cpDefault userConfig
-- global options
defaultModifierCF <- lookupMask maskKeywordsBRC' =<< CF.get cp "DEFAULT" "default_modifier"
terminalCF <- CF.get cp "DEFAULT" "terminal"
focusFollowsMouseCF <- CF.get cp "DEFAULT" "focus_follows_mouse"
startDockCF <- CF.get cp "DEFAULT" "start_dock"
let maskKeywordsBRCwithDefault = maskKeywordsBRC' ++ [("defaultmod", defaultModifierCF)]
-- keys
itemsCF <- CF.items cp "DEFAULT"
let keyBindingsCFstr = filter (\(k, _) -> isPrefixOf "key_" k) itemsCF
keyBindingsCF <- mapM (parseKeyBinding maskKeywordsBRCwithDefault) keyBindingsCFstr
let bluetilerc = BluetileRC { defaultModifierBRC = defaultModifierCF
, focusFollowsMouseBRC = focusFollowsMouseCF
, terminalBRC = terminalCF
, startDockBRC = startDockCF
, keysBRC = keyBindingsCF }
return bluetilerc
case rv of
(Left err) -> do
putStrLn "There was a problem reading the configuration. This is what the parser told me:"
putStrLn (show err)
exitFailure
(Right bluetilerc) -> do
return bluetilerc
displayIdentifiers :: IO ()
displayIdentifiers = do
putStrLn "The following modifiers can be used in Bluetile's configuration:"
putStrLn $ concat $ intersperse ", " ("DefaultMod" : (map fst maskKeywordsBRC))
putStrLn ""
putStrLn "The following keys can be used in Bluetile's configuration:"
putStrLn $ concat $ intersperse ", " (map fst keysKeywordsBRC)