summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar')
-rw-r--r--src/Xmobar/App/Compile.hs65
-rw-r--r--src/Xmobar/App/Config.hs14
-rw-r--r--src/Xmobar/App/EventLoop.hs3
-rw-r--r--src/Xmobar/App/Main.hs89
-rw-r--r--src/Xmobar/App/Opts.hs70
-rw-r--r--src/Xmobar/Config/Parse.hs5
-rw-r--r--src/Xmobar/Config/Types.hs1
7 files changed, 150 insertions, 97 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-04 21:00:05 +0000