From c2a125cefb0bf41140db398248a5b8523b46a42e Mon Sep 17 00:00:00 2001 From: jao Date: Mon, 26 Nov 2018 00:49:33 +0000 Subject: Xmobar.Config.Parse --- app/Configuration.hs | 156 ++-------------------------------------- app/Main.hs | 6 +- src/Xmobar.hs | 2 + src/Xmobar/Config/Parse.hs | 176 +++++++++++++++++++++++++++++++++++++++++++++ src/Xmobar/Run/Template.hs | 2 +- xmobar.cabal | 3 +- 6 files changed, 189 insertions(+), 156 deletions(-) create mode 100644 src/Xmobar/Config/Parse.hs diff --git a/app/Configuration.hs b/app/Configuration.hs index 6f6a0db..340124a 100644 --- a/app/Configuration.hs +++ b/app/Configuration.hs @@ -19,9 +19,6 @@ module Configuration (readConfig, readDefaultConfig) where -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Number (int) -import Text.ParserCombinators.Parsec.Perm ((<|?>), (<$?>), permute) import Control.Monad.IO.Class (liftIO) import System.Environment @@ -29,158 +26,15 @@ import System.Posix.Files (fileExist) import qualified Xmobar as X -#if defined XFT || defined UTF8 -import qualified System.IO as S (readFile,hGetLine) -#endif - -readFileSafe :: FilePath -> IO String -#if defined XFT || defined UTF8 -readFileSafe = S.readFile -#else -readFileSafe = readFile -#endif - -stripComments :: String -> String -stripComments = - unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines - where strip m ('-':'-':xs) = if m then "--" ++ strip m xs else "" - strip m ('"':xs) = '"': strip (not m) xs - strip m (x:xs) = x : strip m xs - strip _ [] = [] - --- | Parse the config, logging a list of fields that were missing and replaced --- by the default definition. -parseConfig :: String -> Either ParseError (X.Config,[String]) -parseConfig = runParser parseConf fields "Config" . stripComments - where - parseConf = do - many space - sepEndSpc ["Config","{"] - x <- perms - eof - s <- getState - return (x,s) - - perms = permute $ X.Config - <$?> pFont <|?> pFontList <|?> pWmClass <|?> pWmName - <|?> pBgColor <|?> pFgColor - <|?> pPosition <|?> pTextOffset <|?> pTextOffsets - <|?> pIconOffset <|?> pBorder - <|?> pBdColor <|?> pBdWidth <|?> pAlpha <|?> pHideOnStart - <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest - <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot - <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate - - - fields = [ "font", "additionalFonts","bgColor", "fgColor" - , "wmClass", "wmName", "sepChar" - , "alignSep" , "border", "borderColor" ,"template" - , "position" , "textOffset", "textOffsets", "iconOffset" - , "allDesktops", "overrideRedirect", "pickBroadest" - , "hideOnStart", "lowerOnStart", "persistent", "iconRoot" - , "alpha", "commands" - ] - - pFont = strField X.font "font" - pFontList = strListField X.additionalFonts "additionalFonts" - pWmClass = strField X.wmClass "wmClass" - pWmName = strField X.wmName "wmName" - pBgColor = strField X.bgColor "bgColor" - pFgColor = strField X.fgColor "fgColor" - pBdColor = strField X.borderColor "borderColor" - pSepChar = strField X.sepChar "sepChar" - pAlignSep = strField X.alignSep "alignSep" - pTemplate = strField X.template "template" - - pTextOffset = readField X.textOffset "textOffset" - pTextOffsets = readIntList X.textOffsets "textOffsets" - pIconOffset = readField X.iconOffset "iconOffset" - pPosition = readField X.position "position" - pHideOnStart = readField X.hideOnStart "hideOnStart" - pLowerOnStart = readField X.lowerOnStart "lowerOnStart" - pPersistent = readField X.persistent "persistent" - pBorder = readField X.border "border" - pBdWidth = readField X.borderWidth "borderWidth" - pAllDesktops = readField X.allDesktops "allDesktops" - pOverrideRedirect = readField X.overrideRedirect "overrideRedirect" - pPickBroadest = readField X.pickBroadest "pickBroadest" - pIconRoot = readField X.iconRoot "iconRoot" - pAlpha = readField X.alpha "alpha" - - pCommands = field X.commands "commands" readCommands - - staticPos = do string "Static" - wrapSkip (string "{") - p <- many (noneOf "}") - wrapSkip (string "}") - string "," - return ("Static {" ++ p ++ "}") - tillFieldEnd = staticPos <|> many (noneOf ",}\n\r") - - commandsEnd = wrapSkip (string "]") >> (string "}" <|> notNextRun) - notNextRun = do {string "," - ; notFollowedBy $ wrapSkip $ string "Run" - ; return "," - } - readCommands = manyTill anyChar (try commandsEnd) >>= - read' commandsErr . flip (++) "]" - strField e n = field e n strMulti - - strMulti = scan '"' - where - scan lead = do - spaces - char lead - s <- manyTill anyChar (rowCont <|> unescQuote) - (char '"' >> return s) <|> fmap (s ++) (scan '\\') - rowCont = try $ char '\\' >> string "\n" - unescQuote = lookAhead (noneOf "\\") >> lookAhead (string "\"") - - strListField e n = field e n strList - strList = do - spaces - char '[' - list <- sepBy (strMulti >>= \x -> spaces >> return x) (char ',') - spaces - char ']' - return list - - wrapSkip x = many space >> x >>= \r -> many space >> return r - sepEndSpc = mapM_ (wrapSkip . try . string) - fieldEnd = many $ space <|> oneOf ",}" - field e n c = (,) (e X.defaultConfig) $ - updateState (filter (/= n)) >> sepEndSpc [n,"="] >> - wrapSkip c >>= \r -> fieldEnd >> return r - readField a n = field a n $ tillFieldEnd >>= read' n - - readIntList d n = field d n intList - intList = do - spaces - char '[' - list <- sepBy (spaces >> int >>= \x-> spaces >> return x) (char ',') - spaces - char ']' - return list - - read' d s = case reads s of - [(x, _)] -> return x - _ -> fail $ "error reading the " ++ d ++ " field: " ++ s - -commandsErr :: String -commandsErr = "commands: this usually means that a command could not" ++ - "\nbe parsed." ++ - "\nThe error could be located at the begining of the command" ++ - "\nwhich follows the offending one." - -- | Reads the configuration files or quits with an error readConfig :: FilePath -> String -> IO (X.Config,[String]) readConfig f usage = do + let err m = error $ f ++ ": " ++ m ++ "\n" ++ usage file <- liftIO $ fileExist f - s <- liftIO $ if file then readFileSafe f else error $ - f ++ ": file not found!\n" ++ usage - either (\err -> error $ f ++ - ": configuration file contains errors at:\n" ++ show err) - return $ parseConfig s + r <- if file then X.readConfig X.defaultConfig f else err "file not found" + case r of + Left e -> err (show e) + Right res -> return res -- | Read default configuration file or load the default config readDefaultConfig :: String -> IO (X.Config,[String]) diff --git a/app/Main.hs b/app/Main.hs index c37fb89..35bff7d 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -27,7 +27,7 @@ import Text.Read (readMaybe) import Xmobar import Paths_xmobar (version) -import Configuration (readConfig, readDefaultConfig) +import Configuration as C (readConfig, readDefaultConfig) -- $main @@ -36,8 +36,8 @@ main :: IO () main = do (o,file) <- getArgs >>= getOpts (c,defaultings) <- case file of - [cfgfile] -> readConfig cfgfile usage - _ -> readDefaultConfig usage + [cfgfile] -> C.readConfig cfgfile usage + _ -> C.readDefaultConfig usage unless (null defaultings) $ putStrLn $ "Fields missing from config defaulted: " ++ intercalate "," defaultings doOpts c o >>= xmobar diff --git a/src/Xmobar.hs b/src/Xmobar.hs index dda56db..bee6f29 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -21,6 +21,7 @@ module Xmobar (xmobar , Runnable (..) , Exec (..) , module Xmobar.Config.Types + , module Xmobar.Config.Parse , module Xmobar.Plugins.BufferedPipeReader , module Xmobar.Plugins.CommandReader , module Xmobar.Plugins.Date @@ -43,6 +44,7 @@ module Xmobar (xmobar import Xmobar.Run.Runnable import Xmobar.Run.Commands import Xmobar.Config.Types +import Xmobar.Config.Parse import Xmobar.Plugins.BufferedPipeReader import Xmobar.Plugins.CommandReader import Xmobar.Plugins.Date diff --git a/src/Xmobar/Config/Parse.hs b/src/Xmobar/Config/Parse.hs new file mode 100644 index 0000000..1a57ffa --- /dev/null +++ b/src/Xmobar/Config/Parse.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE FlexibleContexts, CPP #-} +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Config.Parse +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sun Nov 25, 2018 23:56 +-- +-- +-- Parsing of configuration files +-- +------------------------------------------------------------------------------ + + +module Xmobar.Config.Parse(readConfig, parseConfig) where + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Number (int) +import Text.ParserCombinators.Parsec.Perm ((<|?>), (<$?>), permute) +import Control.Monad.IO.Class (liftIO) + +import Xmobar.Config.Types + +#if defined XFT || defined UTF8 +import qualified System.IO as S (readFile) +#endif + +readFileSafe :: FilePath -> IO String +#if defined XFT || defined UTF8 +readFileSafe = S.readFile +#else +readFileSafe = readFile +#endif + +stripComments :: String -> String +stripComments = + unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines + where strip m ('-':'-':xs) = if m then "--" ++ strip m xs else "" + strip m ('"':xs) = '"': strip (not m) xs + strip m (x:xs) = x : strip m xs + strip _ [] = [] + +-- | Parse the config, logging a list of fields that were missing and replaced +-- by the default definition. +parseConfig :: Config -> String -> Either ParseError (Config,[String]) +parseConfig defaultConfig = + runParser parseConf fields "Config" . stripComments + where + parseConf = do + many space + sepEndSpc ["Config","{"] + x <- perms + eof + s <- getState + return (x,s) + + perms = permute $ Config + <$?> pFont <|?> pFontList <|?> pWmClass <|?> pWmName + <|?> pBgColor <|?> pFgColor + <|?> pPosition <|?> pTextOffset <|?> pTextOffsets + <|?> pIconOffset <|?> pBorder + <|?> pBdColor <|?> pBdWidth <|?> pAlpha <|?> pHideOnStart + <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest + <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot + <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate + + + fields = [ "font", "additionalFonts","bgColor", "fgColor" + , "wmClass", "wmName", "sepChar" + , "alignSep" , "border", "borderColor" ,"template" + , "position" , "textOffset", "textOffsets", "iconOffset" + , "allDesktops", "overrideRedirect", "pickBroadest" + , "hideOnStart", "lowerOnStart", "persistent", "iconRoot" + , "alpha", "commands" + ] + + pFont = strField font "font" + pFontList = strListField additionalFonts "additionalFonts" + pWmClass = strField wmClass "wmClass" + pWmName = strField wmName "wmName" + pBgColor = strField bgColor "bgColor" + pFgColor = strField fgColor "fgColor" + pBdColor = strField borderColor "borderColor" + pSepChar = strField sepChar "sepChar" + pAlignSep = strField alignSep "alignSep" + pTemplate = strField template "template" + + pTextOffset = readField textOffset "textOffset" + pTextOffsets = readIntList textOffsets "textOffsets" + pIconOffset = readField iconOffset "iconOffset" + pPosition = readField position "position" + pHideOnStart = readField hideOnStart "hideOnStart" + pLowerOnStart = readField lowerOnStart "lowerOnStart" + pPersistent = readField persistent "persistent" + pBorder = readField border "border" + pBdWidth = readField borderWidth "borderWidth" + pAllDesktops = readField allDesktops "allDesktops" + pOverrideRedirect = readField overrideRedirect "overrideRedirect" + pPickBroadest = readField pickBroadest "pickBroadest" + pIconRoot = readField iconRoot "iconRoot" + pAlpha = readField alpha "alpha" + + pCommands = field commands "commands" readCommands + + staticPos = do string "Static" + wrapSkip (string "{") + p <- many (noneOf "}") + wrapSkip (string "}") + string "," + return ("Static {" ++ p ++ "}") + tillFieldEnd = staticPos <|> many (noneOf ",}\n\r") + + commandsEnd = wrapSkip (string "]") >> (string "}" <|> notNextRun) + notNextRun = do {string "," + ; notFollowedBy $ wrapSkip $ string "Run" + ; return "," + } + readCommands = manyTill anyChar (try commandsEnd) >>= + read' commandsErr . flip (++) "]" + strField e n = field e n strMulti + + strMulti = scan '"' + where + scan lead = do + spaces + char lead + s <- manyTill anyChar (rowCont <|> unescQuote) + (char '"' >> return s) <|> fmap (s ++) (scan '\\') + rowCont = try $ char '\\' >> string "\n" + unescQuote = lookAhead (noneOf "\\") >> lookAhead (string "\"") + + strListField e n = field e n strList + strList = do + spaces + char '[' + list <- sepBy (strMulti >>= \x -> spaces >> return x) (char ',') + spaces + char ']' + return list + + wrapSkip x = many space >> x >>= \r -> many space >> return r + sepEndSpc = mapM_ (wrapSkip . try . string) + fieldEnd = many $ space <|> oneOf ",}" + field e n c = (,) (e defaultConfig) $ + updateState (filter (/= n)) >> sepEndSpc [n,"="] >> + wrapSkip c >>= \r -> fieldEnd >> return r + readField a n = field a n $ tillFieldEnd >>= read' n + + readIntList d n = field d n intList + intList = do + spaces + char '[' + list <- sepBy (spaces >> int >>= \x-> spaces >> return x) (char ',') + spaces + char ']' + return list + + read' d s = case reads s of + [(x, _)] -> return x + _ -> fail $ "error reading the " ++ d ++ " field: " ++ s + +commandsErr :: String +commandsErr = "commands: this usually means that a command could not" ++ + "\nbe parsed." ++ + "\nThe error could be located at the begining of the command" ++ + "\nwhich follows the offending one." + +-- | Reads the configuration from a file or an error if it cannot be +-- parsed. +readConfig :: Config -> FilePath -> IO (Either ParseError (Config,[String])) +readConfig defaultConfig f = + liftIO (readFileSafe f) >>= return . parseConfig defaultConfig diff --git a/src/Xmobar/Run/Template.hs b/src/Xmobar/Run/Template.hs index 5b1e2f2..749edcd 100644 --- a/src/Xmobar/Run/Template.hs +++ b/src/Xmobar/Run/Template.hs @@ -75,5 +75,5 @@ splitTemplate alignSep template = (ce,_:ri) -> [le, ce, ri] _ -> def _ -> def - where [l, r] = if (length alignSep == 2) then alignSep else defaultAlign + where [l, r] = if length alignSep == 2 then alignSep else defaultAlign def = [template, "", ""] diff --git a/xmobar.cabal b/xmobar.cabal index 38b7a60..5e74efb 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -97,6 +97,7 @@ library exposed-modules: Xmobar other-modules: Xmobar.Config.Types, + Xmobar.Config.Parse, Xmobar.Run.Types, Xmobar.Run.Template, Xmobar.Run.Commands, @@ -167,6 +168,7 @@ library X11 >= 1.6.1, mtl >= 2.1 && < 2.3, parsec == 3.1.*, + parsec-numbers >= 0.1.0, stm >= 2.3 && < 2.6, async @@ -263,7 +265,6 @@ executable xmobar filepath, unix, parsec, - parsec-numbers >= 0.1.0, xmobar ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind -- cgit v1.2.3