xmobar 0.16 → 0.17
raw patch · 19 files changed
+600/−277 lines, 19 filesdep ~X11
Dependency ranges changed: X11
Files
- news.md +27/−0
- readme.md +63/−20
- src/Actions.hs +22/−0
- src/Bitmap.hs +68/−0
- src/Config.hs +39/−26
- src/IPC/DBus.hs +3/−5
- src/Main.hs +75/−55
- src/Parsers.hs +71/−39
- src/Plugins/Mail.hs +0/−1
- src/Plugins/Monitors/Batt.hs +3/−2
- src/Plugins/Monitors/Common.hs +7/−1
- src/Plugins/Monitors/MPD.hs +2/−3
- src/Plugins/Monitors/Mem.hs +8/−6
- src/Plugins/Monitors/Volume.hs +53/−19
- src/Signal.hs +2/−0
- src/Window.hs +76/−62
- src/XUtil.hsc +4/−4
- src/Xmobar.hs +73/−30
- xmobar.cabal +4/−4
news.md view
@@ -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 `<freeratio>` 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_
readme.md view
@@ -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 @@ - `<fc=#FF0000>string</fc>` will print `string` with `#FF0000` color (red). +- `<icon=/path/to/icon.xbm/>` will insert the given bitmap.++- `<action=command>` 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:++ <icon=/path/to/bitmap.xbm/>++which will produce the expected result.++It's also possible to use action directives of the form:++ <action=command>++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: <usedratio>%"] 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="<icon=/home/jao/.xmobar/mem.xbm/><memory> <swap>"++This example will run "xclock" command when date is clicked:++ template="<action=xclock>%date%</action>+ 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: <usedratio>% (<cache>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 <size>, <free>, <used>, <freep> or- <usedp>, <freebar> or <usedbar> for total, free, used, free+ where the template can contain `<size>`, `<free>`, `<used>`, `<freep>` or+ `<usedp>`, `<freebar>` or `<usedbar>` 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 <total>, <read>, <write> for total,+ where the template can contain `<total>`, `<read>`, `<write>` 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
+ src/Actions.hs view
@@ -0,0 +1,22 @@+-----------------------------------------------------------------------------+-- |+-- Module : Xmobar.Actions+-- Copyright : (c) Alexander Polakov+-- License : BSD-style (see LICENSE)+--+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>+-- 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 ++ "&")
+ src/Bitmap.hs view
@@ -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
src/Config.hs view
@@ -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% }{ <fc=#00FF00>%uname%</fc> * <fc=#FF0000>%theDate%</fc>"+ , template = "%StdinReader% }{ " +++ "<fc=#00FF00>%uname%</fc> * <fc=#FF0000>%theDate%</fc>" }
src/IPC/DBus.hs view
@@ -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
src/Main.hs view
@@ -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 = "<xmobar@projects.haskell.org>" 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+
src/Parsers.hs view
@@ -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 "<icon="+ i <- manyTill (noneOf ">") (try (string "/>"))+ return [(Icon i, c, a)]++actionParser :: String -> Parser [(Widget, ColorString, Maybe Action)]+actionParser c = do+ a <- between (string "<action=") (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 "</action>")+ 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 "<fc=") (string ">") colors- s <- manyTill (textParser c <|> colorParser) (try $ string "</fc>")+ s <- manyTill (try (textParser c a) <|> try (iconParser c a) <|>+ try (colorParser a) <|> actionParser c) (try $ string "</fc>") 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."-
src/Plugins/Mail.hs view
@@ -14,7 +14,6 @@ module Plugins.Mail where -import Prelude hiding (catch) import Plugins import Plugins.Utils (expandHome, changeLoop)
src/Plugins/Monitors/Batt.hs view
@@ -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
src/Plugins/Monitors/Common.hs view
@@ -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 $ "<fc=" ++ s ++ ">")++-- | Recognizes icon specification and returns it unchanged+iconSpec :: Parser String+iconSpec = try (do string "<icon="+ i <- manyTill (noneOf ">") (try (string "/>"))+ return $ "<icon=" ++ i ++ "/>") -- | Parses the command part of the template string templateCommandParser :: Parser String
src/Plugins/Monitors/MPD.hs view
@@ -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
src/Plugins/Monitors/Mem.hs view
@@ -19,8 +19,8 @@ memConfig :: IO MConfig memConfig = mkMConfig "Mem: <usedratio>% (<cache>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 _ =
src/Plugins/Monitors/Volume.hs view
@@ -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"
src/Signal.hs view
@@ -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
src/Window.hs view
@@ -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
src/XUtil.hsc view
@@ -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
src/Xmobar.hs view
@@ -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
xmobar.cabal view
@@ -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 <jao@gnu.org> 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