diff options
| -rw-r--r-- | app/Main.hs | 41 | ||||
| -rw-r--r-- | readme.md | 3 | ||||
| -rw-r--r-- | src/Xmobar.hs | 6 | ||||
| -rw-r--r-- | src/Xmobar/App/Compile.hs | 65 | ||||
| -rw-r--r-- | src/Xmobar/App/Config.hs | 14 | ||||
| -rw-r--r-- | src/Xmobar/App/EventLoop.hs | 3 | ||||
| -rw-r--r-- | src/Xmobar/App/Main.hs | 89 | ||||
| -rw-r--r-- | src/Xmobar/App/Opts.hs | 70 | ||||
| -rw-r--r-- | src/Xmobar/Config/Parse.hs | 5 | ||||
| -rw-r--r-- | src/Xmobar/Config/Types.hs | 1 | ||||
| -rw-r--r-- | xmobar.cabal | 5 |
11 files changed, 158 insertions, 144 deletions
diff --git a/app/Main.hs b/app/Main.hs index 3c17447..ac618ce 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Xmobar.Main @@ -15,45 +14,7 @@ module Main (main) where -import Data.List (intercalate) - -import System.Environment (getArgs) -import Control.Monad (unless) -import System.Posix.Files (fileExist) - import Xmobar -import Xmobar.App.Main -import Xmobar.App.Opts - --- $main --- | The main entry point main :: IO () -main = do - (o,file) <- getArgs >>= getOpts - (c,defaultings) <- case file of - [cfgfile] -> config cfgfile usage - _ -> defConfig usage - unless (null defaultings || notElem Debug o) $ putStrLn $ - "Fields missing from config defaulted: " ++ intercalate "," defaultings - doOpts c o >>= xmobar - --- | Read default configuration file or load the default config -defConfig :: String -> IO (Config,[String]) -defConfig msg = do - xdgConfigFile <- xmobarConfigFile - xdgConfigFileExists <- fileExist xdgConfigFile - if xdgConfigFileExists - then config xdgConfigFile msg - else return (defaultConfig,[]) - -config :: FilePath -> String -> IO (Config,[String]) -config f msg = do - let err m = error $ f ++ ": " ++ m - file <- fileExist f - r <- if file - then readConfig defaultConfig f - else err $ "file not found" ++ "\n" ++ msg - case r of - Left e -> err (show e) - Right res -> return res +main = xmobarMain @@ -364,7 +364,8 @@ xmobar --help): Options: -h, -? --help This help -V --version Show version information - -D --debug Emit verbose debugging messages + -v --verbose Emit verbose debugging messages + -r --recompile Force recompilation (for Haskell FILE) -f font name --font=font name Font name -w class --wmclass=class X11 WM_CLASS property -n name --wmname=name X11 WM_NAME property diff --git a/src/Xmobar.hs b/src/Xmobar.hs index f6a8463..4f912a2 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -16,8 +16,8 @@ ----------------------------------------------------------------------------- module Xmobar (xmobar + , xmobarMain , defaultConfig - , xmobarConfigFile , Runnable (..) , Exec (..) , module Xmobar.Config.Types @@ -63,5 +63,5 @@ import Xmobar.Plugins.PipeReader import Xmobar.Plugins.StdinReader import Xmobar.Plugins.XMonadLog -import Xmobar.App.Main(xmobar) -import Xmobar.App.Config(defaultConfig, xmobarConfigFile) +import Xmobar.App.Main(xmobar, xmobarMain) +import Xmobar.App.Config(defaultConfig) diff --git a/src/Xmobar/App/Compile.hs b/src/Xmobar/App/Compile.hs index c3f52f9..3332c45 100644 --- a/src/Xmobar/App/Compile.hs +++ b/src/Xmobar/App/Compile.hs @@ -15,7 +15,7 @@ ------------------------------------------------------------------------------ -module Xmobar.App.Compile(recompile) where +module Xmobar.App.Compile(recompile, xmessage) where import Control.Monad.IO.Class import Control.Monad.Fix (fix) @@ -33,25 +33,23 @@ import System.Posix.Process(executeFile, forkProcess, getAnyProcessStatus) import System.Posix.Types(ProcessID) import System.Posix.Signals -import Xmobar.App.Config - isExecutable :: FilePath -> IO Bool isExecutable f = E.catch (executable <$> getPermissions f) (\(SomeException _) -> return False) -checkBuildScript :: FilePath -> IO Bool -checkBuildScript buildscript = do +checkBuildScript :: Bool -> FilePath -> IO Bool +checkBuildScript verb buildscript = do exists <- doesFileExist buildscript if exists then do isExe <- isExecutable buildscript if isExe then do - trace $ "Xmobar will use build script at " - ++ show buildscript ++ " to recompile." + trace verb $ "Xmobar will use build script at " + ++ show buildscript ++ " to recompile." return True else do - trace $ unlines + trace verb $ unlines [ "Xmobar will not use build script, because " ++ show buildscript ++ " is not executable." , "Suggested resolution to use it: chmod u+x " @@ -59,23 +57,23 @@ checkBuildScript buildscript = do ] return False else do - trace $ "Xmobar will use ghc to recompile, because " - ++ show buildscript ++ " does not exist." + trace verb $ "Xmobar will use ghc to recompile, because " + ++ show buildscript ++ " does not exist." return False -shouldRecompile :: FilePath -> FilePath -> FilePath -> IO Bool -shouldRecompile src bin lib = do +shouldRecompile :: Bool -> FilePath -> FilePath -> FilePath -> IO Bool +shouldRecompile verb src bin lib = do libTs <- mapM getModTime . filter isSource =<< allFiles lib srcT <- getModTime src binT <- getModTime bin if any (binT <) (srcT : libTs) then do - trace "Xmobar doing recompile because some files have changed." + trace verb "Xmobar doing recompile because some files have changed." return True else do - trace "Xmobar skipping recompile because it is not forced \ - \ (e.g. via --recompile), and not any *.hs / *.lhs / *.hsc \ - \ files in lib/ have been changed." + trace verb "Xmobar skipping recompile because it is not forced \ + \ (e.g. via --recompile), and not any *.hs / *.lhs / *.hsc \ + \ files in lib/ have been changed." return False where isSource = flip elem [".hs",".lhs",".hsc"] . takeExtension allFiles t = do @@ -109,8 +107,8 @@ ghcErrorMsg src status ghcErr = return . unlines $ -- | A 'trace' for the 'X' monad. Logs a string to stderr. The result may -- be found in your .xsession-errors file -trace :: MonadIO m => String -> m () -trace = liftIO . hPutStrLn stderr +trace :: MonadIO m => Bool -> String -> m () +trace verb msg = when verb (liftIO $ hPutStrLn stderr msg) -- | 'recompile force', recompile the xmobar configuration file when -- any of the following apply: @@ -126,24 +124,22 @@ trace = liftIO . hPutStrLn stderr -- and any files in the aforementioned @lib@ directory. -- -- Compilation errors (if any) are logged to the @xmobar.errors@ file --- in the xmobar data directory. If GHC indicates failure with a +-- in the given directory. If GHC indicates failure with a -- non-zero exit code, an xmessage displaying that file is spawned. -- -- 'False' is returned if there are compilation errors. -- -recompile :: MonadIO m => String -> Bool -> m Bool -recompile execName force = liftIO $ do - cfgdir <- xmobarConfigDir - datadir <- xmobarDataDir - let bin = datadir </> execName - err = datadir </> (execName ++ ".errors") - src = cfgdir </> (execName ++ ".hs") - lib = cfgdir </> "lib" - script = cfgdir </> "build" - useScript <- checkBuildScript script +recompile :: MonadIO m => String -> String -> Bool -> Bool -> m Bool +recompile dir execName force verb = liftIO $ do + let bin = dir </> execName + err = dir </> (execName ++ ".errors") + src = dir </> (execName ++ ".hs") + lib = dir </> "lib" + script = dir </> "build" + useScript <- checkBuildScript verb script sc <- if useScript || force then return True - else shouldRecompile src bin lib + else shouldRecompile verb src bin lib if sc then do uninstallSignalHandlers @@ -151,16 +147,15 @@ recompile execName force = liftIO $ do \errHandle -> waitForProcess =<< if useScript - then runScript script bin cfgdir errHandle - else runGHC bin cfgdir errHandle + then runScript script bin dir errHandle + else runGHC bin dir errHandle installSignalHandlers if status == ExitSuccess - then trace "Xmobar recompilation process exited with success!" + then trace verb "Xmobar recompilation process exited with success!" else do msg <- readFile err >>= ghcErrorMsg src status hPutStrLn stderr msg - xmessage msg - return () + exitWith (ExitFailure 1) return (status == ExitSuccess) else return True where opts bin = ["--make" , execName ++ ".hs" , "-i" , "-ilib" diff --git a/src/Xmobar/App/Config.hs b/src/Xmobar/App/Config.hs index 7b1171f..431ee10 100644 --- a/src/Xmobar/App/Config.hs +++ b/src/Xmobar/App/Config.hs @@ -61,6 +61,7 @@ defaultConfig = , alignSep = "}{" , template = "%StdinReader% }{ " ++ "<fc=#00FF00>%uname%</fc> * <fc=#FF0000>%theDate%</fc>" + , verbose = False } -- | Return the path to the xmobar configuration directory. This @@ -136,8 +137,11 @@ findFirstDirWithEnv envName paths = do Nothing -> findFirstDirOf paths Just envPath -> findFirstDirOf (return envPath:paths) -xmobarConfigFile :: IO FilePath -xmobarConfigFile = do - f <- fmap (</> "xmobarrc") xmobarConfigDir - fe <- fileExist f - if fe then return f else fmap (</> ".xmobarrc") getHomeDirectory +xmobarConfigFile :: IO (Maybe FilePath) +xmobarConfigFile = + ffirst [ xdg "xmobar.hs", xdg "xmobarrc", home ".xmobarrc"] + where xdg p = fmap (</> p) xmobarConfigDir + home p = fmap (</> p) getHomeDirectory + ffirst [] = return Nothing + ffirst (f:fs) = + f >>= fileExist >>= \e -> if e then fmap Just f else ffirst fs diff --git a/src/Xmobar/App/EventLoop.hs b/src/Xmobar/App/EventLoop.hs index 0d96578..7a76ee6 100644 --- a/src/Xmobar/App/EventLoop.hs +++ b/src/Xmobar/App/EventLoop.hs @@ -99,7 +99,8 @@ startLoop xcfg@(XConf _ _ w _ _ _ _) sig vs = do ConfigureEvent {} -> atomically $ putTMVar signal Reposition ExposeEvent {} -> atomically $ putTMVar signal Wakeup RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition - ButtonEvent {} -> atomically $ putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) + ButtonEvent {} -> atomically $ + putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) _ -> return () -- | Send signal to eventLoop every time a var is updated diff --git a/src/Xmobar/App/Main.hs b/src/Xmobar/App/Main.hs index efc2753..b5de2ef 100644 --- a/src/Xmobar/App/Main.hs +++ b/src/Xmobar/App/Main.hs @@ -15,18 +15,24 @@ ------------------------------------------------------------------------------ -module Xmobar.App.Main (xmobar, doOpts) where +module Xmobar.App.Main (xmobar, xmobarMain) where + +import Control.Concurrent.Async (Async, cancel) +import Control.Exception (bracket) +import Control.Monad (unless) import Data.Foldable (for_) import qualified Data.Map as Map -import System.Exit -import Text.Read (readMaybe) +import Data.List (intercalate) +import System.Posix.Process (executeFile) +import System.Environment (getArgs) +import System.FilePath +import System.FilePath.Posix (takeBaseName, takeDirectory) import Graphics.X11.Xlib -import Control.Concurrent.Async (Async, cancel) -import Control.Exception (bracket) import Xmobar.Config.Types +import Xmobar.Config.Parse import Xmobar.System.Signal (setupSignalHandler, withDeferSignals) import Xmobar.Run.Template import Xmobar.X11.Types @@ -34,6 +40,8 @@ import Xmobar.X11.Text import Xmobar.X11.Window import Xmobar.App.Opts import Xmobar.App.EventLoop (startLoop, startCommand) +import Xmobar.App.Compile (recompile) +import Xmobar.App.Config xmobar :: Config -> IO () xmobar conf = withDeferSignals $ do @@ -58,45 +66,32 @@ cleanupThreads vars = for_ (concat vars) $ \(asyncs, _) -> for_ asyncs cancel -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 - Debug -> doOpts' conf - 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' c = doOpts c oo - readPosition string = - case readMaybe string of - Just x -> doOpts' (conf { position = x }) - Nothing -> do - putStrLn "Can't parse position option, ignoring" - doOpts' conf +buildLaunch :: Bool -> Bool -> FilePath -> IO () +buildLaunch verb force p = do + let exec = takeBaseName p + dir = takeDirectory p + recompile dir exec force verb + executeFile (dir </> exec) False [] Nothing + +xmobar' :: Config -> [String] -> IO () +xmobar' cfg defs = do + unless (null defs || not (verbose cfg)) $ putStrLn $ + "Fields missing from config defaulted: " ++ intercalate "," defs + xmobar cfg + +xmobarMain :: IO () +xmobarMain = do + args <- getArgs + (flags, rest) <- getOpts args + cf <- case rest of + (c:_) -> return (Just c) + _ -> xmobarConfigFile + case cf of + Nothing -> case rest of + (c:_) -> error $ c ++ ": file not found" + _ -> xmobar defaultConfig + Just p -> do d <- doOpts defaultConfig flags + r <- readConfig d p + case r of + Left _ -> buildLaunch (verbose d) (forceRecompile flags) p + Right (c, defs) -> xmobar' c defs diff --git a/src/Xmobar/App/Opts.hs b/src/Xmobar/App/Opts.hs index 842744b..34e2c9e 100644 --- a/src/Xmobar/App/Opts.hs +++ b/src/Xmobar/App/Opts.hs @@ -14,16 +14,21 @@ -- ------------------------------------------------------------------------------ - module Xmobar.App.Opts where +import Control.Monad (when) import System.Console.GetOpt +import System.Exit (exitSuccess, exitWith, ExitCode(..)) import Data.Version (showVersion) +import Text.Read (readMaybe) import Paths_xmobar (version) +import Xmobar.Config.Types + data Opts = Help - | Debug + | Verbose + | Recompile | Version | Font String | BgColor String @@ -47,7 +52,8 @@ data Opts = Help options :: [OptDescr Opts] options = [ Option "h?" ["help"] (NoArg Help) "This help" - , Option "D" ["debug"] (NoArg Debug) "Emit verbose debugging messages" + , Option "v" ["verbose"] (NoArg Verbose) "Emit verbose debugging messages" + , Option "r" ["recompile"] (NoArg Recompile) "Force recompilation" , Option "V" ["version"] (NoArg Version) "Show version information" , Option "f" ["font"] (ReqArg Font "font name") "Font name" , Option "w" ["wmclass"] (ReqArg WmClass "class") "X11 WM_CLASS property" @@ -83,10 +89,13 @@ options = ] getOpts :: [String] -> IO ([Opts], [String]) -getOpts argv = - case getOpt Permute options argv of - (o,n,[]) -> return (o,n) - (_,_,errs) -> error (concat errs ++ usage) +getOpts argv = do + (o,n) <- case getOpt Permute options argv of + (o,n,[]) -> return (o,n) + (_,_,errs) -> error (concat errs ++ usage) + when (Help `elem` o) (putStr usage >> exitSuccess) + when (Version `elem` o) (putStr info >> exitSuccess) + return (o, n) usage :: String usage = usageInfo header options ++ footer @@ -107,3 +116,50 @@ 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 -> doOpts' conf + Version -> doOpts' conf + Recompile -> doOpts' conf + Verbose -> doOpts' (conf {verbose = True}) + 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' c = doOpts c oo + readPosition string = + case readMaybe string of + Just x -> doOpts' (conf { position = x }) + Nothing -> do + putStrLn "Can't parse position option, ignoring" + doOpts' conf + +forceRecompile :: [Opts] -> Bool +forceRecompile = elem Recompile diff --git a/src/Xmobar/Config/Parse.hs b/src/Xmobar/Config/Parse.hs index 1a57ffa..00ce99c 100644 --- a/src/Xmobar/Config/Parse.hs +++ b/src/Xmobar/Config/Parse.hs @@ -67,7 +67,7 @@ parseConfig defaultConfig = <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate - + <|?> pVerbose fields = [ "font", "additionalFonts","bgColor", "fgColor" , "wmClass", "wmName", "sepChar" @@ -75,7 +75,7 @@ parseConfig defaultConfig = , "position" , "textOffset", "textOffsets", "iconOffset" , "allDesktops", "overrideRedirect", "pickBroadest" , "hideOnStart", "lowerOnStart", "persistent", "iconRoot" - , "alpha", "commands" + , "alpha", "commands", "verbose" ] pFont = strField font "font" @@ -103,6 +103,7 @@ parseConfig defaultConfig = pPickBroadest = readField pickBroadest "pickBroadest" pIconRoot = readField iconRoot "iconRoot" pAlpha = readField alpha "alpha" + pVerbose = readField verbose "verbose" pCommands = field commands "commands" readCommands diff --git a/src/Xmobar/Config/Types.hs b/src/Xmobar/Config/Types.hs index ab85d5b..d59c993 100644 --- a/src/Xmobar/Config/Types.hs +++ b/src/Xmobar/Config/Types.hs @@ -64,6 +64,7 @@ data Config = , alignSep :: String -- ^ Separators for left, center and -- right text alignment , template :: String -- ^ The output template + , verbose :: Bool -- ^ Emit additional debug messages } deriving (Read) data XPosition = Top diff --git a/xmobar.cabal b/xmobar.cabal index 1ab39a3..e96c4a2 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -95,8 +95,6 @@ library hs-source-dirs: src exposed-modules: Xmobar - Xmobar.App.Main - Xmobar.App.Opts other-modules: Paths_xmobar, Xmobar.Config.Types, @@ -107,6 +105,8 @@ library Xmobar.Run.Runnable Xmobar.App.EventLoop, Xmobar.App.Config, + Xmobar.App.Main, + Xmobar.App.Opts, Xmobar.App.Compile, Xmobar.System.Utils, Xmobar.System.StatFS, @@ -260,7 +260,6 @@ library executable xmobar hs-source-dirs: app main-is: Main.hs --- other-modules: Paths_xmobar build-depends: base, containers, async, |