diff options
Diffstat (limited to 'src/app')
| -rw-r--r-- | src/app/Configuration.hs | 158 | ||||
| -rw-r--r-- | src/app/Main.hs | 260 |
2 files changed, 418 insertions, 0 deletions
diff --git a/src/app/Configuration.hs b/src/app/Configuration.hs new file mode 100644 index 0000000..db5c109 --- /dev/null +++ b/src/app/Configuration.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE FlexibleContexts #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Configuration +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Wed Nov 21, 2018 23:13 +-- +-- +-- Parsing configuration files +-- +------------------------------------------------------------------------------ + + +module Configuration (parseConfig) where + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Number (int) +import Text.ParserCombinators.Parsec.Perm ((<|?>), (<$?>), permute) + +import qualified Xmobar.Config as C + +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 (C.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 $ C.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 C.font "font" + pFontList = strListField C.additionalFonts "additionalFonts" + pWmClass = strField C.wmClass "wmClass" + pWmName = strField C.wmName "wmName" + pBgColor = strField C.bgColor "bgColor" + pFgColor = strField C.fgColor "fgColor" + pBdColor = strField C.borderColor "borderColor" + pSepChar = strField C.sepChar "sepChar" + pAlignSep = strField C.alignSep "alignSep" + pTemplate = strField C.template "template" + + pTextOffset = readField C.textOffset "textOffset" + pTextOffsets = readIntList C.textOffsets "textOffsets" + pIconOffset = readField C.iconOffset "iconOffset" + pPosition = readField C.position "position" + pHideOnStart = readField C.hideOnStart "hideOnStart" + pLowerOnStart = readField C.lowerOnStart "lowerOnStart" + pPersistent = readField C.persistent "persistent" + pBorder = readField C.border "border" + pBdWidth = readField C.borderWidth "borderWidth" + pAllDesktops = readField C.allDesktops "allDesktops" + pOverrideRedirect = readField C.overrideRedirect "overrideRedirect" + pPickBroadest = readField C.pickBroadest "pickBroadest" + pIconRoot = readField C.iconRoot "iconRoot" + pAlpha = readField C.alpha "alpha" + + pCommands = field C.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 C.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." diff --git a/src/app/Main.hs b/src/app/Main.hs new file mode 100644 index 0000000..c96c47e --- /dev/null +++ b/src/app/Main.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Main +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- The main module of Xmobar, a text based status bar +-- +----------------------------------------------------------------------------- + +module Main ( -- * Main Stuff + -- $main + main + , readConfig + , readDefaultConfig + ) where + +import Xmobar +import Xmobar.Parsers +import Xmobar.Config +import Xmobar.XUtil + +import Data.Foldable (for_) +import Data.List (intercalate) +import qualified Data.Map as Map + +import Data.Version (showVersion) +import Graphics.X11.Xlib +import System.Console.GetOpt +import System.Directory (getHomeDirectory) +import System.Exit +import System.Environment +import System.FilePath ((</>)) +import System.Posix.Files +import Control.Concurrent.Async (Async, cancel) +import Control.Exception (bracket) +import Control.Monad (unless) +import Text.Read (readMaybe) + +import Xmobar.Signal (setupSignalHandler, withDeferSignals) + +import Paths_xmobar (version) +import Configuration + +-- $main + +-- | The main entry point +main :: IO () +main = withDeferSignals $ do + initThreads + d <- openDisplay "" + args <- getArgs + (o,file) <- getOpts args + (c,defaultings) <- case file of + [cfgfile] -> readConfig cfgfile + _ -> readDefaultConfig + + unless (null defaultings) $ putStrLn $ + "Fields missing from config defaulted: " ++ intercalate "," defaultings + + conf <- doOpts c o + fs <- initFont d (font conf) + fl <- mapM (initFont d) (additionalFonts conf) + cls <- mapM (parseTemplate conf) (splitTemplate conf) + sig <- setupSignalHandler + bracket (mapM (mapM $ startCommand sig) cls) + cleanupThreads + $ \vars -> do + (r,w) <- createWin d fs conf + let ic = Map.empty + to = textOffset conf + ts = textOffsets conf ++ replicate (length fl) (-1) + startLoop (XConf d r w (fs:fl) (to:ts) ic conf) sig vars + +cleanupThreads :: [[([Async ()], a)]] -> IO () +cleanupThreads vars = + -- putStrLn "In cleanupThreads" + for_ (concat vars) $ \(asyncs, _) -> + for_ asyncs cancel + +-- | Splits the template in its parts +splitTemplate :: Config -> [String] +splitTemplate conf = + case break (==l) t of + (le,_:re) -> case break (==r) re of + (ce,_:ri) -> [le, ce, ri] + _ -> def + _ -> def + where [l, r] = alignSep + (if length (alignSep conf) == 2 then conf else defaultConfig) + t = template conf + def = [t, "", ""] + + +-- | Reads the configuration files or quits with an error +readConfig :: FilePath -> IO (Config,[String]) +readConfig f = do + file <- io $ fileExist f + s <- io $ 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 + +xdgConfigDir :: IO String +xdgConfigDir = do env <- getEnvironment + case lookup "XDG_CONFIG_HOME" env of + Just val -> return val + Nothing -> fmap (</> ".config") getHomeDirectory + +xmobarConfigDir :: IO FilePath +xmobarConfigDir = fmap (</> "xmobar") xdgConfigDir + +getXdgConfigFile :: IO FilePath +getXdgConfigFile = fmap (</> "xmobarrc") xmobarConfigDir + +-- | Read default configuration file or load the default config +readDefaultConfig :: IO (Config,[String]) +readDefaultConfig = do + xdgConfigFile <- getXdgConfigFile + xdgConfigFileExists <- io $ fileExist xdgConfigFile + home <- io $ getEnv "HOME" + let defaultConfigFile = home ++ "/.xmobarrc" + defaultConfigFileExists <- io $ fileExist defaultConfigFile + if xdgConfigFileExists + then readConfig xdgConfigFile + else if defaultConfigFileExists + then readConfig defaultConfigFile + else return (defaultConfig,[]) + +data Opts = Help + | Version + | Font String + | BgColor String + | FgColor String + | Alpha String + | T + | B + | D + | AlignSep String + | Commands String + | AddCommand String + | SepChar String + | Template String + | OnScr String + | IconRoot String + | Position String + | WmClass String + | WmName String + deriving Show + +options :: [OptDescr Opts] +options = + [ Option "h?" ["help"] (NoArg Help) "This help" + , Option "V" ["version"] (NoArg Version) "Show version information" + , Option "f" ["font"] (ReqArg Font "font name") "The font name" + , Option "w" ["wmclass"] (ReqArg WmClass "class") "X11 WM_CLASS property" + , Option "n" ["wmname"] (ReqArg WmName "name") "X11 WM_NAME property" + , Option "B" ["bgcolor"] (ReqArg BgColor "bg color" ) + "The background color. Default black" + , Option "F" ["fgcolor"] (ReqArg FgColor "fg color") + "The foreground color. Default grey" + , Option "i" ["iconroot"] (ReqArg IconRoot "path") + "Root directory for icon pattern paths. Default '.'" + , Option "A" ["alpha"] (ReqArg Alpha "alpha") + "The transparency: 0 is transparent, 255 is opaque. Default: 255" + , Option "o" ["top"] (NoArg T) "Place xmobar at the top of the screen" + , Option "b" ["bottom"] (NoArg B) + "Place xmobar at the bottom of the screen" + , Option "d" ["dock"] (NoArg D) + "Don't override redirect from WM and function as a dock" + , Option "a" ["alignsep"] (ReqArg AlignSep "alignsep") + "Separators for left, center and right text\nalignment. Default: '}{'" + , Option "s" ["sepchar"] (ReqArg SepChar "char") + ("The character used to separate commands in" ++ + "\nthe output template. Default '%'") + , Option "t" ["template"] (ReqArg Template "template") + "The output template" + , Option "c" ["commands"] (ReqArg Commands "commands") + "The list of commands to be executed" + , Option "C" ["add-command"] (ReqArg AddCommand "command") + "Add to the list of commands to be executed" + , Option "x" ["screen"] (ReqArg OnScr "screen") + "On which X screen number to start" + , Option "p" ["position"] (ReqArg Position "position") + "Specify position of xmobar. Same syntax as in config file" + ] + +getOpts :: [String] -> IO ([Opts], [String]) +getOpts argv = + case getOpt Permute options argv of + (o,n,[]) -> return (o,n) + (_,_,errs) -> error (concat errs ++ usage) + +usage :: String +usage = usageInfo header options ++ footer + where header = "Usage: xmobar [OPTION...] [FILE]\nOptions:" + footer = "\nMail bug reports and suggestions to " ++ mail ++ "\n" + +info :: String +info = "xmobar " ++ showVersion version + ++ "\n (C) 2007 - 2010 Andrea Rossato " + ++ "\n (C) 2010 - 2018 Jose A Ortega Ruiz\n " + ++ mail ++ "\n" ++ license + +mail :: String +mail = "<mail@jao.io>" + +license :: String +license = "\nThis program is distributed in the hope that it will be useful," ++ + "\nbut WITHOUT ANY WARRANTY; without even the implied warranty of" ++ + "\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." ++ + "\nSee the License for more details." + +doOpts :: Config -> [Opts] -> IO Config +doOpts conf [] = + return (conf {lowerOnStart = lowerOnStart conf && overrideRedirect conf}) +doOpts conf (o:oo) = + case o of + Help -> putStr usage >> exitSuccess + Version -> putStrLn info >> exitSuccess + Font s -> doOpts' (conf {font = s}) + WmClass s -> doOpts' (conf {wmClass = s}) + WmName s -> doOpts' (conf {wmName = s}) + BgColor s -> doOpts' (conf {bgColor = s}) + FgColor s -> doOpts' (conf {fgColor = s}) + Alpha n -> doOpts' (conf {alpha = read n}) + T -> doOpts' (conf {position = Top}) + B -> doOpts' (conf {position = Bottom}) + D -> doOpts' (conf {overrideRedirect = False}) + AlignSep s -> doOpts' (conf {alignSep = s}) + SepChar s -> doOpts' (conf {sepChar = s}) + Template s -> doOpts' (conf {template = s}) + IconRoot s -> doOpts' (conf {iconRoot = s}) + OnScr n -> doOpts' (conf {position = OnScreen (read n) $ position conf}) + Commands s -> case readCom 'c' s of + Right x -> doOpts' (conf {commands = x}) + Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) + AddCommand s -> case readCom 'C' s of + Right x -> doOpts' (conf {commands = commands conf ++ x}) + Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) + Position s -> readPosition s + where readCom c str = + case readStr str of + [x] -> Right x + _ -> Left ("xmobar: cannot read list of commands " ++ + "specified with the -" ++ c:" option\n") + readStr str = [x | (x,t) <- reads str, ("","") <- lex t] + doOpts' opts = doOpts opts oo + readPosition string = + case readMaybe string of + Just x -> doOpts' (conf { position = x }) + Nothing -> do + putStrLn "Can't parse position option, ignoring" + doOpts' conf |