diff --git a/news.md b/news.md --- a/news.md +++ b/news.md @@ -1,5 +1,32 @@ % xmobar - Release notes +## Version 0.17 (May 5, 2013) + +_New features_ + + - Icons support: it's now possible to insert bitmaps in the template + (Edward O'Callaghan, Alexander Polakov and Tomáš Janoušek). + - Initial support for reacting to mouse clicks (Alexander Polakov). + - New `TopP` and `BottomP` alignments, taking left and right + paddings (thanks to Dmitry Malikov). + - New `` field for memory monitor (Peter Simons). + - New `allDesktops` and `overrideRedirect` configuration options, + providing dock behaviour in tiling WMs (when set to True and False + respectively). Cf. discussion at [github #105]. + - Experimental `-d` (start as a dock) option, may address [github #67] + in some window managers. + +_Bug fixes_ + + - Partial (as reports go) fix for [github #77]. + - Safer volume plugin (Dmitry Malikov). + - Battery percentage capped at 100% (RJ Regenold). + +[github #67]: https://github.com/jaor/xmobar/issues/77 +[github #77]: https://github.com/jaor/xmobar/issues/77 +[github #105]: https://github.com/jaor/xmobar/issues/105 + + ## Version 0.16 (Dec 3, 2012) _New features_ diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -3,15 +3,15 @@ About ===== -xmobar is a minimalistic, text based, status bar. It was originally -designed and implemented by Andrea Rossato to work with [xmonad], -but it's actually usable with any window-manager. +xmobar is a minimalistic, mostly text based, status bar. It was +originally designed and implemented by Andrea Rossato to work with +[xmonad], but it's actually usable with any window-manager. xmobar was inspired by the [Ion3] status bar, and supports similar -features, like dynamic color management, output templates, and +features, like dynamic color management, icons, output templates, and extensibility through plugins. -This page documents xmobar 0.16 (see [release notes]). +This page documents xmobar 0.17 (see [release notes]). [This screenshot] shows xmobar running under [sawfish], with antialiased fonts. And [this one] is my desktop with [xmonad] and two @@ -188,6 +188,10 @@ - `string` will print `string` with `#FF0000` color (red). +- `` will insert the given bitmap. + +- `` will execute given command. + Other configuration options: `font` @@ -200,9 +204,11 @@ : Default font color. `position` -: Top, TopW, TopSize, Bottom, BottomW, BottomSize or Static (with x, y, - width and height). +: Top, TopP, TopW, TopSize, Bottom, BottomP, BottomW, BottomSize or Static + (with x, y, width and height). +: TopP and BottomP take 2 arguments: left padding and right padding. + : TopW and BottomW take 2 arguments: an alignment parameter (L for left, C for centered, R for Right) and an integer for the percentage width xmobar window will have in respect to the @@ -218,6 +224,13 @@ : to place xmobar at the bottom, centered with the 75% of the screen width. +: Or: + +: position = BottomP 120 0 + +: to place xmobar at the bottom, with 120 pixel indent of the left. + + : Or : position = Static { xpos = 0 , ypos = 0, width = 1024, height = 15 } @@ -234,9 +247,19 @@ can be toggled manually (for example using the dbus interface) or automatically (by a plugin) to make it reappear. +`allDesktops` +: When set to True (the default), xmobar will tell the window manager + explicitily to be shown in all desktops, by setting + `_NET_WM_DESKTOP` to 0xffffffff. + +`overrideRedirect` +: If you're running xmobar in a tiling window manager, you might need + to set this option to `False` so that it behaves as a docked + application. Defaults to `True`. + `persistent` : When True the window status is fixed i.e. hiding or revealing is not - possible. This option can be toggled at runtime. + possible. This option can be toggled at runtime. Defaults to False. `border` : TopB, TopBM, BottomB, BottomBM, FullB, FullBM or NoBorder (default). @@ -299,6 +322,7 @@ -F fg color --fgcolor=fg color The foreground color. Default grey -o --top Place xmobar at the top of the screen -b --bottom Place xmobar at the bottom of the screen + -d --dock Try to start xmobar as a dock -a alignsep --alignsep=alignsep Separators for left, center and right text alignment. Default: '}{' -s char --sepchar=char The character used to separate commands in @@ -421,6 +445,19 @@ template. If the execution is not successful an error will be reported. +It's possible to insert in the global templates icon directives of the +form: + + + +which will produce the expected result. + +It's also possible to use action directives of the form: + + + +which will be executed when clicked on. + ## The `commands` Configuration Option The `commands` configuration option is a list of commands information @@ -437,18 +474,23 @@ [Run Memory ["-t","Mem: %"] 10, Run Swap [] 10] to run the Memory monitor plugin with the specified template, and the -swap monitor plugin, with default options, every second. +swap monitor plugin, with default options, every second. And here's +an example of a template for the commands above using an icon: + template=" " + +This example will run "xclock" command when date is clicked: + + template="%date% + The only internal available command is `Com` (see below Executing External Commands). All other commands are provided by plugins. xmobar comes with some plugins, providing a set of system monitors, a standard input reader, an Unix named pipe reader, a configurable date plugin, and much more: we list all available plugins below. -To remove them see below Installing/Removing a Plugin - Other commands can be created as plugins with the Plugin -infrastructure. See below Writing a Plugin +infrastructure. See below. ## System Monitor Plugins @@ -645,7 +687,7 @@ - Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `total`, `free`, `buffer`, `cache`, `rest`, `used`, - `usedratio`, `usedbar`, `freebar` + `usedratio`, `usedbar`, `freeratio`, `freebar` - Default template: `Mem: % (M)` ### `Swap Args RefreshRate` @@ -756,8 +798,8 @@ - Aliases to `disku` - Disks: list of pairs of the form (device or mount point, template), - where the template can contain , , , or - , or for total, free, used, free + where the template can contain ``, ``, ``, `` or + ``, `` or `` for total, free, used, free percentage and used percentage of the given file system capacity. - Args: default monitor arguments. `-t`/`--template` is ignored. - Default template: none (you must specify a template for each file system). @@ -771,7 +813,7 @@ - Aliases to `diskio` - Disks: list of pairs of the form (device or mount point, template), - where the template can contain , , for total, + where the template can contain ``, ``, `` for total, read and write speed, respectively. - Args: default monitor arguments. `-t`/`--template` is ignored. - Default template: none (you must specify a template for each file system). @@ -1252,10 +1294,11 @@ In particular, xmobar [incorporates patches] by Ben Boeckel, Roman Cheplyaka, Patrick Chilton, John Goerzen, Reto Hablützel, Juraj Hercek, Tomas Janousek, Spencer Janssen, Jochen Keil, Lennart -Kolmodin, Krzysztof Kosciuszkiewicz, Dmitry Kurochkin, Svein Ove, -Martin Perner, Jens Petersen, Petr Rockai, Andrew Sackville-West, -Alexander Solovyov, John Soros, Artem Tarasov, Sergei Trofimovich, -Thomas Tuegel, Jan Vornberger, Daniel Wagner and Norbert Zeh. +Kolmodin, Krzysztof Kosciuszkiewicz, Dmitry Kurochkin, Dmitry Malikov, +Edward O'Callaghan, Svein Ove, Martin Perner, Jens Petersen, Alexander +Polakov, Petr Rockai, Peter Simons, Andrew Sackville-West, Alexander +Solovyov, John Soros, Artem Tarasov, Sergei Trofimovich, Thomas +Tuegel, Jan Vornberger, Daniel Wagner and Norbert Zeh. [incorporates patches]: http://www.ohloh.net/p/xmobar/contributors diff --git a/src/Actions.hs b/src/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Actions.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Actions +-- Copyright : (c) Alexander Polakov +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Actions where + +import System.Process (system) +import Control.Monad (void) + +data Action = Spawn String + deriving (Eq) + +runAction :: Action -> IO () +runAction (Spawn s) = void $ system (s ++ "&") diff --git a/src/Bitmap.hs b/src/Bitmap.hs new file mode 100644 --- /dev/null +++ b/src/Bitmap.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Bitmap +-- Copyright : (C) 2013 Alexander Polakov +-- License : BSD3 +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Bitmap + ( updateCache + , drawBitmap + , Bitmap(..)) where + +import Control.Monad +import Data.Map hiding (foldr, map, filter) +import Graphics.X11.Xlib +import System.Directory (doesFileExist) +import System.Mem.Weak ( addFinalizer ) +import ColorCache +import Parsers (Widget(..)) +import Actions (Action) + +data Bitmap = Bitmap { width :: Dimension + , height :: Dimension + , pixmap :: Pixmap + } + +updateCache :: Display -> Window -> Map FilePath Bitmap -> + [[(Widget, String, Maybe Action)]] -> IO (Map FilePath Bitmap) +updateCache dpy win cache ps = do + let paths = map (\(Icon p, _, _) -> p) . concatMap (filter icons) $ ps + icons (Icon _, _, _) = True + icons _ = False + go m path = if member path m + then return m + else do bitmap <- loadBitmap dpy win path + return $ maybe m (\b -> insert path b m) bitmap + foldM go cache paths + +loadBitmap :: Display -> Drawable -> FilePath -> IO (Maybe Bitmap) +loadBitmap d w p = do + exist <- doesFileExist p + if exist + then do + bmap <- readBitmapFile d w p + case bmap of + Right (bw, bh, bp, _, _) -> do + addFinalizer bp (freePixmap d bp) + return $ Just $ Bitmap bw bh bp + Left err -> do + putStrLn err + return Nothing + else + return Nothing + +drawBitmap :: Display -> Drawable -> GC -> String -> String + -> Position -> Position -> Bitmap -> IO () +drawBitmap d p gc fc bc x y i = + withColors d [fc, bc] $ \[fc', bc'] -> do + let w = width i + h = height i + setForeground d gc fc' + setBackground d gc bc' + copyPlane d (pixmap i) p gc 0 0 w h x (1 + y - fromIntegral h `div` 2) 1 diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -23,6 +23,7 @@ , runnableTypes ) where + import Commands import {-# SOURCE #-} Runnable import Plugins.Monitors @@ -50,30 +51,39 @@ -- | The configuration data type data Config = - Config { font :: String -- ^ Font - , bgColor :: String -- ^ Backgroud color - , fgColor :: String -- ^ Default font color - , position :: XPosition -- ^ Top Bottom or Static - , border :: Border -- ^ NoBorder TopB BottomB or FullB - , borderColor :: String -- ^ Border color - , hideOnStart :: Bool -- ^ Hide (Unmap) the window on - -- initialization - , lowerOnStart :: Bool -- ^ Lower to the bottom of the - -- window stack on initialization - , persistent :: Bool -- ^ Whether automatic hiding should - -- be enabled or disabled - , commands :: [Runnable] -- ^ For setting the command, the command arguments - -- and refresh rate for the programs to run (optional) - , sepChar :: String -- ^ The character to be used for indicating - -- commands in the output template (default '%') - , alignSep :: String -- ^ Separators for left, center and right text alignment - , template :: String -- ^ The output template + Config { font :: String -- ^ Font + , bgColor :: String -- ^ Backgroud color + , fgColor :: String -- ^ Default font color + , position :: XPosition -- ^ Top Bottom or Static + , border :: Border -- ^ NoBorder TopB BottomB or FullB + , borderColor :: String -- ^ Border color + , hideOnStart :: Bool -- ^ Hide (Unmap) the window on + -- initialization + , allDesktops :: Bool -- ^ Tell the WM to map to all desktops + , overrideRedirect :: Bool -- ^ Needed for dock behaviour in some + -- non-tiling WMs + , lowerOnStart :: Bool -- ^ lower to the bottom of the + -- window stack on initialization + , persistent :: Bool -- ^ Whether automatic hiding should + -- be enabled or disabled + , commands :: [Runnable] -- ^ For setting the command, + -- the command arguments + -- and refresh rate for the programs + -- to run (optional) + , sepChar :: String -- ^ The character to be used for indicating + -- commands in the output template + -- (default '%') + , alignSep :: String -- ^ Separators for left, center and + -- right text alignment + , template :: String -- ^ The output template } deriving (Read) data XPosition = Top | TopW Align Int | TopSize Align Int Int + | TopP Int Int | Bottom + | BottomP Int Int | BottomW Align Int | BottomSize Align Int Int | Static {xpos, ypos, width, height :: Int} @@ -94,20 +104,23 @@ -- | The default configuration values defaultConfig :: Config defaultConfig = - Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - , bgColor = "#000000" - , fgColor = "#BFBFBF" + Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , bgColor = "#000000" + , fgColor = "#BFBFBF" , position = Top , border = NoBorder - , borderColor = "#BFBFBF" - , hideOnStart = False + , borderColor = "#BFBFBF" + , hideOnStart = False , lowerOnStart = True - , persistent = False + , persistent = False + , allDesktops = True + , overrideRedirect = True , commands = [ Run $ Date "%a %b %_d %Y * %H:%M:%S" "theDate" 10 , Run StdinReader] - , sepChar = "%" + , sepChar = "%" , alignSep = "}{" - , template = "%StdinReader% }{ %uname% * %theDate%" + , template = "%StdinReader% }{ " ++ + "%uname% * %theDate%" } diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs --- a/src/IPC/DBus.hs +++ b/src/IPC/DBus.hs @@ -12,15 +12,13 @@ -- ----------------------------------------------------------------------------- -module IPC.DBus ( runIPC ) where - -import Prelude hiding (catch) +module IPC.DBus (runIPC) where import DBus import DBus.Client import Control.Monad (when) import Control.Concurrent.STM -import Control.Exception (catch) +import Control.Exception (handle) import System.IO (stderr, hPutStrLn) import Signal @@ -35,7 +33,7 @@ interfaceName = interfaceName_ "org.Xmobar.Control" runIPC :: TMVar SignalType -> IO () -runIPC mvst = catch exportConnection printException +runIPC mvst = handle printException exportConnection where printException :: ClientError -> IO () printException = hPutStrLn stderr . clientErrorMessage diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -26,6 +26,7 @@ import XUtil import Data.List (intercalate) +import qualified Data.Map as Map import Paths_xmobar (version) import Data.Version (showVersion) @@ -44,15 +45,15 @@ main :: IO () main = do initThreads - d <- openDisplay "" - args <- getArgs + d <- openDisplay "" + args <- getArgs (o,file) <- getOpts args (c,defaultings) <- case file of [cfgfile] -> readConfig cfgfile - _ -> readDefaultConfig + _ -> readDefaultConfig - unless (null defaultings) $ putStrLn $ "Fields missing from config defaulted: " - ++ intercalate "," defaultings + unless (null defaultings) $ putStrLn $ + "Fields missing from config defaulted: " ++ intercalate "," defaultings conf <- doOpts c o fs <- initFont d (font conf) @@ -60,7 +61,8 @@ sig <- setupSignalHandler vars <- mapM (mapM $ startCommand sig) cls (r,w) <- createWin d fs conf - startLoop (XConf d r w fs conf) sig vars + let ic = Map.empty + startLoop (XConf d r w fs ic conf) sig vars -- | Splits the template in its parts splitTemplate :: Config -> [String] @@ -70,9 +72,8 @@ (ce,_:ri) -> [le, ce, ri] _ -> def _ -> def - where [l, r] = if length (alignSep conf) == 2 - then alignSep conf - else alignSep defaultConfig + where [l, r] = alignSep + (if length (alignSep conf) == 2 then conf else defaultConfig) t = template conf def = [t, "", ""] @@ -81,8 +82,10 @@ 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) + 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 -- | Read default configuration file or load the default config @@ -100,6 +103,7 @@ | FgColor String | T | B + | D | AlignSep String | Commands String | AddCommand String @@ -110,19 +114,31 @@ 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 ['B' ] ["bgcolor" ] (ReqArg BgColor "bg color" ) "The background color. Default black" - , Option ['F' ] ["fgcolor" ] (ReqArg FgColor "fg color" ) "The foreground color. Default grey" - , 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 ['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 "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 "B" ["bgcolor"] (ReqArg BgColor "bg color" ) + "The background color. Default black" + , Option "F" ["fgcolor"] (ReqArg FgColor "fg color") + "The foreground color. Default grey" + , 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" ] getOpts :: [String] -> IO ([Opts], [String]) @@ -132,49 +148,53 @@ (_,_,errs) -> error (concat errs ++ usage) usage :: String -usage = (usageInfo header options) ++ footer +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 - 2011 Jose A Ortega Ruiz\n " + ++ "\n (C) 2010 - 2013 Jose A Ortega Ruiz\n " ++ mail ++ "\n" ++ license mail :: String mail = "" license :: String -license = "\nThis program is distributed in the hope that it will be useful,\n" ++ - "but WITHOUT ANY WARRANTY; without even the implied warranty of\n" ++ - "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n" ++ - "See the License for more details." +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 +doOpts conf [] = + return (conf {lowerOnStart = lowerOnStart conf && overrideRedirect conf}) doOpts conf (o:oo) = - case o of - Help -> putStr usage >> exitWith ExitSuccess - Version -> putStrLn info >> exitWith ExitSuccess - Font s -> doOpts (conf {font = s }) oo - BgColor s -> doOpts (conf {bgColor = s }) oo - FgColor s -> doOpts (conf {fgColor = s }) oo - T -> doOpts (conf {position = Top }) oo - B -> doOpts (conf {position = Bottom}) oo - AlignSep s -> doOpts (conf {alignSep = s }) oo - SepChar s -> doOpts (conf {sepChar = s }) oo - Template s -> doOpts (conf {template = s }) oo - OnScr n -> doOpts (conf {position = OnScreen (read n) $ position conf}) oo - Commands s -> case readCom 'c' s of - Right x -> doOpts (conf { commands = x }) oo - Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) - AddCommand s -> case readCom 'C' s of - Right x -> doOpts (conf { commands = commands conf ++ x }) oo - Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) - 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] + case o of + Help -> putStr usage >> exitSuccess + Version -> putStrLn info >> exitSuccess + Font s -> doOpts' (conf {font = s}) + BgColor s -> doOpts' (conf {bgColor = s}) + FgColor s -> doOpts' (conf {fgColor = s}) + 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}) + 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) + 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 + diff --git a/src/Parsers.hs b/src/Parsers.hs --- a/src/Parsers.hs +++ b/src/Parsers.hs @@ -17,35 +17,47 @@ ( parseString , parseTemplate , parseConfig + , Widget(..) ) where import Config import Runnable import Commands +import Actions import qualified Data.Map as Map import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Perm +data Widget = Icon String | Text String + +type ColorString = String + -- | Runs the string parser -parseString :: Config -> String -> IO [(String, String)] +parseString :: Config -> String -> IO [(Widget, ColorString, Maybe Action)] parseString c s = - case parse (stringParser (fgColor c)) "" s of - Left _ -> return [("Could not parse string: " ++ s, fgColor c)] + case parse (stringParser (fgColor c) Nothing) "" s of + Left _ -> return [(Text $ "Could not parse string: " ++ s, fgColor c, Nothing)] Right x -> return (concat x) -- | Gets the string and combines the needed parsers -stringParser :: String -> Parser [[(String, String)]] -stringParser c = manyTill (textParser c <|> colorParser) eof +stringParser :: String -> Maybe Action -> Parser [[(Widget, ColorString, Maybe Action)]] +stringParser c a = manyTill (textParser c a <|> try (iconParser c a) <|> + try (actionParser c) <|> colorParser a) eof -- | Parses a maximal string without color markup. -textParser :: String -> Parser [(String, String)] -textParser c = do s <- many1 $ - noneOf "<" <|> - ( try $ notFollowedBy' (char '<') - (string "fc=" <|> string "/fc>" ) ) - return [(s, c)] +textParser :: String -> Maybe Action -> Parser [(Widget, ColorString, Maybe Action)] +textParser c a = do s <- many1 $ + noneOf "<" <|> + try (notFollowedBy' (char '<') + (try (string "fc=") <|> + try (string "action=") <|> + try (string "/action>") <|> + try (string "icon=") <|> + string "/fc>")) + return [(Text s, c, a)] + -- | Wrapper for notFollowedBy that returns the result of the first parser. -- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy -- accepts only parsers with return type Char. @@ -54,11 +66,26 @@ notFollowedBy $ try (e >> return '*') return x +iconParser :: String -> Maybe Action -> Parser [(Widget, ColorString, Maybe Action)] +iconParser c a = do + string "") (try (string "/>")) + return [(Icon i, c, a)] + +actionParser :: String -> Parser [(Widget, ColorString, Maybe Action)] +actionParser c = do + a <- between (string "") (many1 (noneOf ">")) + let a' = Just (Spawn a) + s <- manyTill (try (textParser c a') <|> try (iconParser c a') <|> + try (colorParser a') <|> actionParser c) (try $ string "") + return (concat s) + -- | Parsers a string wrapped in a color specification. -colorParser :: Parser [(String, String)] -colorParser = do +colorParser :: Maybe Action -> Parser [(Widget, ColorString, Maybe Action)] +colorParser a = do c <- between (string "") colors - s <- manyTill (textParser c <|> colorParser) (try $ string "") + s <- manyTill (try (textParser c a) <|> try (iconParser c a) <|> + try (colorParser a) <|> actionParser c) (try $ string "") return (concat s) -- | Parses a color specification (hex or named) @@ -128,34 +155,35 @@ return (x,s) perms = permute $ Config - <$?> pFont <|?> pBgColor - <|?> pFgColor <|?> pPosition - <|?> pBorder <|?> pBdColor - <|?> pHideOnStart <|?> pLowerOnStart - <|?> pPersistent <|?> pCommands - <|?> pSepChar <|?> pAlignSep - <|?> pTemplate + <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition + <|?> pBorder <|?> pBdColor <|?> pHideOnStart <|?> pAllDesktops + <|?> pOverrideRedirect <|?> pLowerOnStart <|?> pPersistent + <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep" , "border", "borderColor" ,"template", "position" + , "allDesktops", "overrideRedirect" , "hideOnStart", "lowerOnStart", "persistent", "commands" ] - pFont = strField font "font" - pBgColor = strField bgColor "bgColor" - pFgColor = strField fgColor "fgColor" - pBdColor = strField borderColor "borderColor" - pSepChar = strField sepChar "sepChar" + pFont = strField font "font" + pBgColor = strField bgColor "bgColor" + pFgColor = strField fgColor "fgColor" + pBdColor = strField borderColor "borderColor" + pSepChar = strField sepChar "sepChar" pAlignSep = strField alignSep "alignSep" pTemplate = strField template "template" - pPosition = field position "position" $ tillFieldEnd >>= read' "position" - pHideOnStart = field hideOnStart "hideOnStart" $ tillFieldEnd >>= read' "hideOnStart" - pLowerOnStart = field lowerOnStart "lowerOnStart" $ tillFieldEnd >>= read' "lowerOnStart" - pPersistent = field persistent "persistent" $ tillFieldEnd >>= read' "persistent" - pBorder = field border "border" $ tillFieldEnd >>= read' "border" - pCommands = field commands "commands" $ readCommands + pPosition = readField position "position" + pHideOnStart = readField hideOnStart "hideOnStart" + pLowerOnStart = readField lowerOnStart "lowerOnStart" + pPersistent = readField persistent "persistent" + pBorder = readField border "border" + pAllDesktops = readField allDesktops "allDesktops" + pOverrideRedirect = readField overrideRedirect "overrideRedirect" + pCommands = field commands "commands" readCommands + staticPos = do string "Static" wrapSkip (string "{") p <- many (noneOf "}") @@ -165,12 +193,17 @@ tillFieldEnd = staticPos <|> many (noneOf ",}\n\r") commandsEnd = wrapSkip (string "]") >> (string "}" <|> notNextRun) - notNextRun = do { string ","; notFollowedBy $ wrapSkip $ string "Run"; return ","} + notNextRun = do {string "," + ; notFollowedBy $ wrapSkip $ string "Run" + ; return "," + } readCommands = manyTill anyChar (try commandsEnd) >>= read' commandsErr . flip (++) "]" - strField e n = field e n . between (strDel "start" n) (strDel "end" n) . many $ noneOf "\"\n\r" - strDel t n = char '"' strErr t n - strErr t n = "the " ++ t ++ " of the string field " ++ n ++ " - a double quote (\")." + strField e n = field e n . between (strDel "start" n) (strDel "end" n) . + many $ noneOf "\"\n\r" + strDel t n = char '"' strErr t n + strErr t n = "the " ++ t ++ " of the string field " ++ n ++ + " - a double quote (\")." wrapSkip x = many space >> x >>= \r -> many space >> return r sepEndSpc = mapM_ (wrapSkip . try . string) @@ -178,12 +211,11 @@ 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 read' d s = case reads s of [(x, _)] -> return x - _ -> fail $ "error reading the " ++ d ++ " field: " ++ s + _ -> fail $ "error reading the " ++ d ++ " field: " ++ s commandsErr :: String commandsErr = "commands: this usually means that a command could not be parsed.\n" ++ "The error could be located at the begining of the command which follows the offending one." - diff --git a/src/Plugins/Mail.hs b/src/Plugins/Mail.hs --- a/src/Plugins/Mail.hs +++ b/src/Plugins/Mail.hs @@ -14,7 +14,6 @@ module Plugins.Mail where -import Prelude hiding (catch) import Plugins import Plugins.Utils (expandHome, changeLoop) diff --git a/src/Plugins/Monitors/Batt.hs b/src/Plugins/Monitors/Batt.hs --- a/src/Plugins/Monitors/Batt.hs +++ b/src/Plugins/Monitors/Batt.hs @@ -162,8 +162,9 @@ NA -> return "N/A" where fmtPercent :: Float -> Monitor [String] fmtPercent x = do - p <- showPercentWithColors x - b <- showPercentBar (100 * x) x + let x' = minimum [1, x] + p <- showPercentWithColors x' + b <- showPercentBar (100 * x') x' return [b, p] fmtWatts x o s d = color x o $ showDigits d x ++ (if s then "W" else "") fmtTime :: Integer -> String diff --git a/src/Plugins/Monitors/Common.hs b/src/Plugins/Monitors/Common.hs --- a/src/Plugins/Monitors/Common.hs +++ b/src/Plugins/Monitors/Common.hs @@ -265,7 +265,7 @@ } where nonPlaceHolder = liftM concat . many $ - many1 (noneOf "<") <|> colorSpec + many1 (noneOf "<") <|> colorSpec <|> iconSpec -- | Recognizes color specification and returns it unchanged colorSpec :: Parser String @@ -274,6 +274,12 @@ s <- many1 (alphaNum <|> char ',' <|> char '#') char '>' return $ "") + +-- | Recognizes icon specification and returns it unchanged +iconSpec :: Parser String +iconSpec = try (do string "") (try (string "/>")) + return $ "") -- | Parses the command part of the template string templateCommandParser :: Parser String diff --git a/src/Plugins/Monitors/MPD.hs b/src/Plugins/Monitors/MPD.hs --- a/src/Plugins/Monitors/MPD.hs +++ b/src/Plugins/Monitors/MPD.hs @@ -14,6 +14,7 @@ module Plugins.Monitors.MPD ( mpdConfig, runMPD, mpdWait ) where +import Data.List import Plugins.Monitors.Common import System.Console.GetOpt import qualified Network.MPD as M @@ -93,9 +94,7 @@ parseSong (Left _) = return $ repeat "" parseSong (Right Nothing) = return $ repeat "" parseSong (Right (Just s)) = - let join [] = "" - join (x:xs) = foldl (\a o -> a ++ ", " ++ o) x xs - str sel = maybe "" (join . map M.toString) (M.sgGetTag sel s) + let str sel = maybe "" (intercalate ", " . map M.toString) (M.sgGetTag sel s) sels = [ M.Name, M.Artist, M.Composer, M.Performer , M.Album, M.Title, M.Track, M.Genre ] fields = M.toString (M.sgFilePath s) : map str sels diff --git a/src/Plugins/Monitors/Mem.hs b/src/Plugins/Monitors/Mem.hs --- a/src/Plugins/Monitors/Mem.hs +++ b/src/Plugins/Monitors/Mem.hs @@ -19,8 +19,8 @@ memConfig :: IO MConfig memConfig = mkMConfig "Mem: % (M)" -- template - ["usedbar", "freebar", "usedratio", "total", - "free", "buffer", "cache", "rest", "used"] -- available replacements + ["usedbar", "freebar", "usedratio", "freeratio", "total", + "free", "buffer", "cache", "rest", "used"] -- available replacements fileMEM :: IO String fileMEM = readFile "/proc/meminfo" @@ -33,7 +33,8 @@ rest = free + buffer + cache used = total - rest usedratio = used / total - return [usedratio, total, free, buffer, cache, rest, used] + freeratio = free / total + return [usedratio, freeratio, total, free, buffer, cache, rest, used, freeratio] totalMem :: IO Float totalMem = fmap ((*1024) . (!!1)) parseMEM @@ -42,15 +43,16 @@ usedMem = fmap ((*1024) . (!!6)) parseMEM formatMem :: [Float] -> Monitor [String] -formatMem (r:xs) = +formatMem (r:fr:xs) = do let f = showDigits 0 rr = 100 * r ub <- showPercentBar rr r fb <- showPercentBar (100 - rr) (1 - r) rs <- showPercentWithColors r + fs <- showPercentWithColors fr s <- mapM (showWithColors f) xs - return (ub:fb:rs:s) -formatMem _ = return $ replicate 9 "N/A" + return (ub:fb:rs:fs:s) +formatMem _ = return $ replicate 10 "N/A" runMem :: [String] -> Monitor String runMem _ = diff --git a/src/Plugins/Monitors/Volume.hs b/src/Plugins/Monitors/Volume.hs --- a/src/Plugins/Monitors/Volume.hs +++ b/src/Plugins/Monitors/Volume.hs @@ -14,12 +14,12 @@ module Plugins.Monitors.Volume (runVolume, volumeConfig) where -import Prelude hiding ( catch ) -import Control.Monad ( liftM, mplus ) -import Data.Maybe +import Control.Applicative ((<$>)) +import Control.Monad ( join, liftM2, liftM3, mplus ) +import Data.Traversable (sequenceA) import Plugins.Monitors.Common import Sound.ALSA.Mixer -import Sound.ALSA.Exception ( catch ) +import qualified Sound.ALSA.Exception as AE import System.Console.GetOpt volumeConfig :: IO MConfig @@ -110,19 +110,53 @@ runVolume :: String -> String -> [String] -> Monitor String runVolume mixerName controlName argv = do opts <- io $ parseOpts argv - control <- liftM fromJust $ io $ getControlByName mixerName controlName - let volumeControl = fromJust $ mplus (playback $ volume control) - (common $ volume control) - switchControl = fromJust $ mplus (playback $ switch control) - (common $ switch control) - maybeNA = maybe (return "N/A") - (lo, hi) <- io $ getRange volumeControl - val <- io $ getChannel FrontLeft $ value volumeControl - db <- io $ catch (getChannel FrontLeft $ dB volumeControl) - (\_ -> return $ Just 0) - sw <- io $ getChannel FrontLeft switchControl - p <- maybeNA (formatVol lo hi) val - b <- maybeNA (formatVolBar lo hi) val - d <- maybeNA (formatDb opts) db - s <- maybeNA (formatSwitch opts) sw + control <- io $ getControlByName mixerName controlName + (lo, hi) <- io . liftMaybe $ getRange <$> volumeControl control + val <- getVal $ volumeControl control + db <- getDB $ volumeControl control + sw <- getSw $ switchControl control + p <- liftMonitor $ liftM3 formatVol lo hi val + b <- liftMonitor $ liftM3 formatVolBar lo hi val + d <- getFormatDB opts db + s <- getFormatSwitch opts sw parseTemplate [p, b, d, s] + + where + + volumeControl :: Maybe Control -> Maybe Volume + volumeControl c = join $ + (playback . volume <$> c) `mplus` (common . volume <$> c) + + switchControl :: Maybe Control -> Maybe Switch + switchControl c = join $ + (playback . switch <$> c) `mplus` (common . switch <$> c) + + liftMaybe :: Maybe (IO (a,b)) -> IO (Maybe a, Maybe b) + liftMaybe = fmap (liftM2 (,) (fmap fst) (fmap snd)) . sequenceA + + liftMonitor :: Maybe (Monitor String) -> Monitor String + liftMonitor Nothing = return unavailable + liftMonitor (Just m) = m + + getDB :: Maybe Volume -> Monitor (Maybe Integer) + getDB Nothing = return Nothing + getDB (Just v) = io $ AE.catch (getChannel FrontLeft $ dB v) + (const $ return $ Just 0) + + getVal :: Maybe Volume -> Monitor (Maybe Integer) + getVal Nothing = return Nothing + getVal (Just v) = io $ getChannel FrontLeft $ value v + + getSw :: Maybe Switch -> Monitor (Maybe Bool) + getSw Nothing = return Nothing + getSw (Just s) = io $ getChannel FrontLeft s + + getFormatDB :: VolumeOpts -> Maybe Integer -> Monitor String + getFormatDB _ Nothing = return unavailable + getFormatDB opts (Just d) = formatDb opts d + + getFormatSwitch :: VolumeOpts -> Maybe Bool -> Monitor String + getFormatSwitch _ Nothing = return unavailable + getFormatSwitch opts (Just sw) = formatSwitch opts sw + + unavailable = "N/A" diff --git a/src/Signal.hs b/src/Signal.hs --- a/src/Signal.hs +++ b/src/Signal.hs @@ -22,6 +22,7 @@ import Control.Concurrent.STM import Control.Exception hiding (handle) import System.Posix.Signals +import Graphics.X11.Xlib.Types (Position) #ifdef DBUS import DBus (IsVariant(..)) @@ -40,6 +41,7 @@ | Reveal Int | Toggle Int | TogglePersistent + | Action Position deriving (Read, Show) #ifdef DBUS diff --git a/src/Window.hs b/src/Window.hs --- a/src/Window.hs +++ b/src/Window.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Window --- Copyright : (c) 2011-12 Jose A. Ortega Ruiz +-- Copyright : (c) 2011-13 Jose A. Ortega Ruiz -- : (c) 2012 Jochen Keil -- License : BSD-style (see LICENSE) -- @@ -16,10 +16,11 @@ module Window where import Prelude -import Control.Monad (when) +import Control.Monad (when, unless) import Graphics.X11.Xlib hiding (textExtents, textWidth) import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama +import Foreign.C.Types (CLong) import Data.Maybe(fromMaybe) import System.Posix.Process (getProcessID) @@ -33,78 +34,94 @@ createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) createWin d fs c = do let dflt = defaultScreen d - srs <- getScreenInfo d - rootw <- rootWindow d dflt + srs <- getScreenInfo d + rootw <- rootWindow d dflt (as,ds) <- textExtents fs "0" - let ht = as + ds + 4 - (r,o) = setPosition (position c) srs (fi ht) - win <- newWindow d (defaultScreenOfDisplay d) rootw r o - setProperties r c d win srs - when (lowerOnStart c) (lowerWindow d win) - when (not $ hideOnStart c) $ mapWindow d win + let ht = as + ds + 4 + r = setPosition (position c) srs (fi ht) + win <- newWindow d (defaultScreenOfDisplay d) rootw r (overrideRedirect c) + setProperties c d win + setStruts r c d win srs + when (lowerOnStart c) $ lowerWindow d win + unless (hideOnStart c) $ showWindow r c d win return (r,win) -- | Updates the size and position of the window repositionWin :: Display -> Window -> XFont -> Config -> IO Rectangle repositionWin d win fs c = do - srs <- getScreenInfo d + srs <- getScreenInfo d (as,ds) <- textExtents fs "0" - let ht = as + ds + 4 - (r,_) = setPosition (position c) srs (fi ht) + let ht = as + ds + 4 + r = setPosition (position c) srs (fi ht) moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) - setProperties r c d win srs + setStruts r c d win srs return r -setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool) +setPosition :: XPosition -> [Rectangle] -> Dimension -> Rectangle setPosition p rs ht = case p' of - Top -> (Rectangle rx ry rw h, True) - TopW a i -> (Rectangle (ax a i) ry (nw i) h, True) - TopSize a i ch -> (Rectangle (ax a i) ry (nw i) (mh ch), True) - Bottom -> (Rectangle rx ny rw h, True) - BottomW a i -> (Rectangle (ax a i) ny (nw i) h, True) - BottomSize a i ch -> (Rectangle (ax a i) (ny' ch) (nw i) (mh ch), True) - Static cx cy cw ch -> (Rectangle (fi cx) (fi cy) (fi cw) (fi ch), True) + Top -> Rectangle rx ry rw h + TopP l r -> Rectangle (rx + fi l) ry (rw - fi l - fi r) h + TopW a i -> Rectangle (ax a i) ry (nw i) h + TopSize a i ch -> Rectangle (ax a i) ry (nw i) (mh ch) + Bottom -> Rectangle rx ny rw h + BottomW a i -> Rectangle (ax a i) ny (nw i) h + BottomP l r -> Rectangle (rx + fi l) ny (rw - fi l - fi r) h + BottomSize a i ch -> Rectangle (ax a i) (ny' ch) (nw i) (mh ch) + Static cx cy cw ch -> Rectangle (fi cx) (fi cy) (fi cw) (fi ch) OnScreen _ p'' -> setPosition p'' [scr] ht where (scr@(Rectangle rx ry rw rh), p') = case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x) _ -> (head rs, p) - ny = ry + fi (rh - ht) + ny = ry + fi (rh - ht) center i = rx + fi (div (remwid i) 2) right i = rx + fi (remwid i) remwid i = rw - pw (fi i) - ax L = const rx - ax R = right - ax C = center - pw i = rw * min 100 i `div` 100 - nw = fi . pw . fi - h = fi ht - mh h' = max (fi h') h - ny' h' = ry + fi (rh - mh h') + ax L = const rx + ax R = right + ax C = center + pw i = rw * min 100 i `div` 100 + nw = fi . pw . fi + h = fi ht + mh h' = max (fi h') h + ny' h' = ry + fi (rh - mh h') safeIndex i = lookup i . zip [0..] -setProperties :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () -setProperties r c d w srs = do - a1 <- internAtom d "_NET_WM_STRUT_PARTIAL" False - c1 <- internAtom d "CARDINAL" False - a2 <- internAtom d "_NET_WM_WINDOW_TYPE" False - c2 <- internAtom d "ATOM" False - v <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False - p <- internAtom d "_NET_WM_PID" False +setProperties :: Config -> Display -> Window -> IO () +setProperties c d w = do + let mkatom n = internAtom d n False + card <- mkatom "CARDINAL" + atom <- mkatom "ATOM" setTextProperty d w "xmobar" wM_CLASS setTextProperty d w "xmobar" wM_NAME - ismapped <- isMapped d w - changeProperty32 d w a1 c1 propModeReplace $ - if ismapped - then map fi $ getStrutValues r (position c) (getRootWindowHeight srs) - else replicate 12 0 - changeProperty32 d w a2 c2 propModeReplace [fromIntegral v] + wtype <- mkatom "_NET_WM_WINDOW_TYPE" + dock <- mkatom "_NET_WM_WINDOW_TYPE_DOCK" + changeProperty32 d w wtype atom propModeReplace [fi dock] - getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral + when (allDesktops c) $ do + desktop <- mkatom "_NET_WM_DESKTOP" + changeProperty32 d w desktop card propModeReplace [0xffffffff] + pid <- mkatom "_NET_WM_PID" + getProcessID >>= changeProperty32 d w pid card propModeReplace . return . fi + +setStruts' :: Display -> Window -> [Foreign.C.Types.CLong] -> IO () +setStruts' d w svs = do + let mkatom n = internAtom d n False + card <- mkatom "CARDINAL" + pstrut <- mkatom "_NET_WM_STRUT_PARTIAL" + strut <- mkatom "_NET_WM_STRUT" + changeProperty32 d w pstrut card propModeReplace svs + changeProperty32 d w strut card propModeReplace (take 4 svs) + +setStruts :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () +setStruts r c d w rs = do + let svs = map fi $ getStrutValues r (position c) (getRootWindowHeight rs) + setStruts' d w svs + getRootWindowHeight :: [Rectangle] -> Int getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) where @@ -112,19 +129,21 @@ getStrutValues :: Rectangle -> XPosition -> Int -> [Int] getStrutValues r@(Rectangle x y w h) p rwh = - case p of + case p of OnScreen _ p' -> getStrutValues r p' rwh Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + TopP _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + BottomP _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] Static {} -> getStaticStrutValues p rwh - where st = fi y + fi h - sb = rwh - fi y - nx = fi x - nw = fi (x + fi w - 1) + where st = fi y + fi h + sb = rwh - fi y + nx = fi x + nw = fi (x + fi w - 1) -- get some reaonable strut values for static placement. getStaticStrutValues :: XPosition -> Int -> [Int] @@ -132,7 +151,7 @@ -- if the yPos is in the top half of the screen, then assume a Top -- placement, otherwise, it's a Bottom placement | cy < (rwh `div` 2) = [0, 0, st, 0, 0, 0, 0, 0, xs, xe, 0, 0] - | otherwise = [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, xs, xe] + | otherwise = [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, xs, xe] where st = cy + ch sb = rwh - cy xs = cx -- a simple calculation for horizontal (x) placement @@ -156,19 +175,14 @@ hideWindow :: Display -> Window -> IO () hideWindow d w = do - a <- internAtom d "_NET_WM_STRUT_PARTIAL" False - c <- internAtom d "CARDINAL" False - changeProperty32 d w a c propModeReplace $ replicate 12 0 + setStruts' d w (replicate 12 0) unmapWindow d w >> sync d False showWindow :: Rectangle -> Config -> Display -> Window -> IO () -showWindow r cfg d w = do - srs <- getScreenInfo d - a <- internAtom d "_NET_WM_STRUT_PARTIAL" False - c <- internAtom d "CARDINAL" False - changeProperty32 d w a c propModeReplace $ map fi $ - getStrutValues r (position cfg) (getRootWindowHeight srs) - mapWindow d w >> sync d False +showWindow r c d w = do + mapWindow d w + getScreenInfo d >>= setStruts r c d w + sync d False isMapped :: Display -> Window -> IO Bool isMapped d w = fmap ism $ getWindowAttributes d w diff --git a/src/XUtil.hsc b/src/XUtil.hsc --- a/src/XUtil.hsc +++ b/src/XUtil.hsc @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : XUtil --- Copyright : (C) 2011, 2012 Jose Antonio Ortega Ruiz +-- Copyright : (C) 2011, 2012, 2013 Jose Antonio Ortega Ruiz -- (C) 2007 Andrea Rossato -- License : BSD3 -- @@ -32,13 +32,13 @@ import Control.Monad.Trans import Control.Exception (SomeException, handle) import Foreign --- import Foreign.C.Types import Graphics.X11.Xlib hiding (textExtents, textWidth) import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) import Graphics.X11.Xlib.Extras import System.Mem.Weak ( addFinalizer ) import System.Posix.Types (Fd(..)) import System.IO + #if defined XFT || defined UTF8 # if __GLASGOW_HASKELL__ < 612 import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine) @@ -183,8 +183,8 @@ -- Windows Managers should not touch this kind of windows. newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window newWindow dpy scr rw (Rectangle x y w h) o = do - let visual = defaultVisualOfScreen scr - attrmask = cWOverrideRedirect + let visual = defaultVisualOfScreen scr + attrmask = if o then cWOverrideRedirect else 0 allocaSetWindowAttributes $ \attributes -> do set_override_redirect attributes o diff --git a/src/Xmobar.hs b/src/Xmobar.hs --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -23,13 +23,13 @@ , startCommand -- * Window Management -- $window - , createWin, updateWin + , createWin -- * Printing -- $print , drawInWin, printStrings ) where -import Prelude +import Prelude hiding (lookup) import Graphics.X11.Xlib hiding (textExtents, textWidth) import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama @@ -41,10 +41,14 @@ import Control.Concurrent.STM import Control.Exception (handle, SomeException(..)) import Data.Bits +import Data.Map hiding (foldr, map, filter) +import Data.Maybe (fromJust) +import Bitmap import Config import Parsers import Commands +import Actions import Runnable import Signal import Window @@ -72,6 +76,7 @@ , rect :: Rectangle , window :: Window , fontS :: XFont + , iconS :: Map FilePath Bitmap , config :: Config } @@ -81,7 +86,7 @@ -- | Starts the main event loop and threads startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () -startLoop xcfg@(XConf _ _ w _ _) sig vs = do +startLoop xcfg@(XConf _ _ w _ _ _) sig vs = do #ifdef XFT xftInitFtLibrary #endif @@ -95,16 +100,16 @@ #ifdef DBUS runIPC sig #endif - eventLoop tv xcfg sig + eventLoop tv xcfg [] sig where handler thing (SomeException _) = - putStrLn ("Thread " ++ thing ++ " failed") >> return () + void $ putStrLn ("Thread " ++ thing ++ " failed") -- Reacts on events from X eventer signal = allocaXEvent $ \e -> do dpy <- openDisplay "" xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask - selectInput dpy w (exposureMask .|. structureNotifyMask) + selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) forever $ do #ifdef THREADED_RUNTIME @@ -117,6 +122,7 @@ ConfigureEvent {} -> atomically $ putTMVar signal Reposition ExposeEvent {} -> atomically $ putTMVar signal Wakeup RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition + ButtonEvent {} -> atomically $ putTMVar signal (Action (fi $ ev_x ev)) _ -> return () -- | Send signal to eventLoop every time a var is updated @@ -138,13 +144,16 @@ -- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: TVar [String] -> XConf -> TMVar SignalType -> IO () -eventLoop tv xc@(XConf d r w fs cfg) signal = do +eventLoop :: TVar [String] -> XConf -> [(Action, Position, Position)] -> TMVar SignalType -> IO () +eventLoop tv xc@(XConf d r w fs is cfg) as signal = do typ <- atomically $ takeTMVar signal case typ of Wakeup -> do - runX xc (updateWin tv) - eventLoop tv xc signal + str <- updateString cfg tv + xc' <- updateCache d w is str >>= \c -> return xc { iconS = c } + as' <- updateActions xc r str + runX xc' $ drawInWin r str + eventLoop tv xc' as' signal Reposition -> reposWindow cfg @@ -158,36 +167,38 @@ Toggle t -> toggle t TogglePersistent -> eventLoop - tv xc { config = cfg { persistent = not $ persistent cfg } } signal + tv xc { config = cfg { persistent = not $ persistent cfg } } as signal + Action x -> action x + where isPersistent = not $ persistent cfg hide t | t == 0 = - when isPersistent (hideWindow d w) >> eventLoop tv xc signal + when isPersistent (hideWindow d w) >> eventLoop tv xc as signal | otherwise = do void $ forkIO $ threadDelay t >> atomically (putTMVar signal $ Hide 0) - eventLoop tv xc signal + eventLoop tv xc as signal reveal t | t == 0 = do when isPersistent (showWindow r cfg d w) - eventLoop tv xc signal + eventLoop tv xc as signal | otherwise = do void $ forkIO $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) - eventLoop tv xc signal + eventLoop tv xc as signal toggle t = do ismapped <- isMapped d w atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) - eventLoop tv xc signal + eventLoop tv xc as signal reposWindow rcfg = do r' <- repositionWin d w fs rcfg - eventLoop tv (XConf d r' w fs rcfg) signal + eventLoop tv (XConf d r' w fs is rcfg) as signal updateConfigPosition ocfg = case position ocfg of @@ -200,6 +211,9 @@ o -> return (ocfg {position = OnScreen 1 o}) + action x = do mapM_ (\(a,_,_) -> runAction a) $ filter (\(_, from, to) -> x >= from && x <= to) as + eventLoop tv xc as signal + -- $command -- | Runs a command as an independent thread and returns its thread id @@ -219,24 +233,49 @@ return (Just h,var) where is = s ++ "Updating..." ++ ss -updateWin :: TVar [String] -> X () -updateWin v = do - xc <- ask - s <- io $ atomically $ readTVar v - let (conf,rec) = (config &&& rect) xc - l:c:r:_ = s ++ repeat "" - ps <- io $ mapM (parseString conf) [l, c, r] - drawInWin rec ps +updateString :: Config -> TVar [String] -> IO [[(Widget, String, Maybe Action)]] +updateString conf v = do + s <- atomically $ readTVar v + let l:c:r:_ = s ++ repeat "" + io $ mapM (parseString conf) [l, c, r] +updateActions :: XConf -> Rectangle -> [[(Widget, String, Maybe Action)]] -> + IO [(Action, Position, Position)] +updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do + let (d,fs) = (display &&& fontS) conf + strLn :: [(Widget, String, Maybe Action)] -> IO [(Maybe Action, Position, Position)] + strLn = io . mapM getCoords + iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf) + getCoords (Text s,_,a) = textWidth d fs s >>= \tw -> return (a, 0, fi tw) + getCoords (Icon s,_,a) = return (a, 0, fi $ iconW s) + partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $ + filter (\(a, _,_) -> a /= Nothing) $ + scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) (Nothing, 0, off) xs + + totSLen = foldr (\(_,_,len) -> (+) len) 0 + remWidth xs = fi wid - totSLen xs + offs = 1 + offset a xs = case a of + C -> (remWidth xs + offs) `div` 2 + R -> remWidth xs + L -> offs + + fmap concat $ mapM (\(a,xs) -> fmap (\xs' -> partCoord (offset a xs') xs') $ strLn xs) $ + zip [L,C,R] [left,center,right] + -- $print -- | Draws in and updates the window -drawInWin :: Rectangle -> [[(String, String)]] -> X () +drawInWin :: Rectangle -> [[(Widget, String, Maybe Action)]] -> X () drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do r <- ask let (c,d ) = (config &&& display) r (w,fs) = (window &&& fontS ) r - strLn = io . mapM (\(s,cl) -> textWidth d fs s >>= \tw -> return (s,cl,fi tw)) + strLn = io . mapM getWidth + iconW i = maybe 0 Bitmap.width (lookup i $ iconS r) + getWidth (Text s,cl,_) = textWidth d fs s >>= \tw -> return (Text s,cl,fi tw) + getWidth (Icon s,cl,_) = return (Icon s,cl,fi $ iconW s) + withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do gc <- io $ createGC d w -- create a pixmap to write to and fill it with a rectangle @@ -261,11 +300,13 @@ -- | An easy way to print the stuff we need to print printStrings :: Drawable -> GC -> XFont -> Position - -> Align -> [(String, String, Position)] -> X () + -> Align -> [(Widget, String, Position)] -> X () printStrings _ _ _ _ _ [] = return () printStrings dr gc fontst offs a sl@((s,c,l):xs) = do r <- ask - (as,ds) <- io $ textExtents fontst s + (as,ds) <- case s of + Text t -> io $ textExtents fontst t + Icon _ -> return (0, 0) let (conf,d) = (config &&& display) r Rectangle _ _ wid ht = rect r totSLen = foldr (\(_,_,len) -> (+) len) 0 sl @@ -278,5 +319,7 @@ (fc,bc) = case break (==',') c of (f,',':b) -> (f, b ) (f, _) -> (f, bgColor conf) - io $ printString d dr fontst gc fc bc offset valign s + case s of + (Text t) -> io $ printString d dr fontst gc fc bc offset valign t + (Icon p) -> io $ maybe (return ()) (drawBitmap d dr gc fc bc offset valign) (lookup p (iconS r)) printStrings dr gc fontst (offs + l) a xs diff --git a/xmobar.cabal b/xmobar.cabal --- a/xmobar.cabal +++ b/xmobar.cabal @@ -1,5 +1,5 @@ name: xmobar -version: 0.16 +version: 0.17 homepage: http://projects.haskell.org/xmobar/ bug-reports: http://code.google.com/p/xmobar/issues synopsis: A Minimalistic Text Based Status Bar @@ -11,7 +11,7 @@ category: System license: BSD3 license-file: license -author: Andrea Rossato +author: Andrea Rossato, Jose A. Ortega Ruiz maintainer: Jose A. Ortega Ruiz cabal-version: >= 1.6 build-type: Simple @@ -74,7 +74,7 @@ hs-source-dirs: src main-is: Main.hs other-modules: - Xmobar, Config, Parsers, Commands, Localize, + Xmobar, Actions, Bitmap, Config, Parsers, Commands, Localize, XUtil, StatFS, Runnable, ColorCache, Window, Signal, Plugins, Plugins.BufferedPipeReader, Plugins.CommandReader, Plugins.Date, Plugins.EWMH, @@ -104,7 +104,7 @@ unix, time, filepath, - X11 == 1.6.*, + X11 >= 1.6.1, mtl >= 2.0 && < 2.2, parsec == 3.1.*, stm >= 2.3 && < 2.5