xmobar 0.22.1 → 0.23
raw patch · 15 files changed
+479/−214 lines, 15 filesdep ~HTTP
Dependency ranges changed: HTTP
Files
- news.md +28/−0
- readme.md +73/−39
- samples/xmobar.config +4/−0
- src/Bitmap.hs +3/−3
- src/Config.hs +8/−0
- src/Main.hs +6/−1
- src/MinXft.hsc +114/−2
- src/Parsers.hs +71/−43
- src/Plugins/Monitors/CpuFreq.hs +12/−10
- src/Plugins/Monitors/MPD.hs +11/−2
- src/Plugins/Monitors/Mem.hs +19/−17
- src/Plugins/Monitors/Weather.hs +7/−1
- src/XUtil.hsc +17/−16
- src/Xmobar.hs +103/−77
- xmobar.cabal +3/−3
news.md view
@@ -1,5 +1,33 @@ % xmobar - Release notes +## Version 0.23 (Mar 8, 2015)++_New features_++ - Xmobar can now use a (semi)transparent background: set it with the+ new configuration option `alpha` (thanks to Edward Z. Yang, see+ [issue #114]).+ - Multiple fonts available by means of the new configuration+ parameter `additionalFonts` and the template markers+ `<fn=1>...</fn>`, by Markus Scherer.+ - New variables in `Mem` monitor for available memory as reported by+ Linux 3.14 and newer, by Samuli Thomasson.+ - New configuration parameters `textOffset` and `iconOffset` (see+ discussion in [issue #171] and [issue #201]).+ - New template variable `flags` in `MPD` monitor, by Duncan Burke.++[issue #171]: https://github.com/jaor/xmobar/issues/171+[issue #201]: https://github.com/jaor/xmobar/issues/201+[issue #114]: https://github.com/jaor/xmobar/issues/114++_Bug fixes_++ - We honour the `-S` (show suffix) monitor flag in `CpuFreq`.+ - Better `Weather` parsing of wind direction, by Dino Morelli (see+ [pull #212]).++[pull #212]: https://github.com/jaor/xmobar/pull/212+ ## Version 0.22.1 (Oct 11, 2014) _Bug fixes_
readme.md view
@@ -1,7 +1,6 @@ % xmobar - a minimalistic status bar -About-=====+# About xmobar is a minimalistic, mostly text based, status bar. It was originally designed and implemented by Andrea Rossato to work with@@ -11,7 +10,7 @@ features, like dynamic color management, icons, output templates, and extensibility through plugins. -This page documents xmobar 0.22.1 (see [release notes]).+This page documents xmobar 0.23 (see [release notes]). [This screenshot] shows xmobar running under [sawfish], with antialiased fonts. And [this one] is my desktop with [xmonad] and two@@ -23,8 +22,7 @@ [This screenshot]: http://projects.haskell.org/xmobar/xmobar-sawfish.png [this one]: http://projects.haskell.org/xmobar/xmobar-xmonad.png -Bug Reports-===========+# Bug Reports To submit bug reports you can use the [bug tracker over at Github] or send mail to our [Mailing list].@@ -34,8 +32,7 @@ [bug tracker over at Github]: https://github.com/jaor/xmobar/issues -Installation-============+# Installation ## Using cabal-install @@ -163,8 +160,7 @@ `all_extensions` : Enables all the extensions above. -Running xmobar-==============+# Running xmobar You can now run xmobar with: @@ -186,8 +182,7 @@ - After receiving SIGUSR2 xmobar repositions it self on the current screen. -Configuration-=============+# Configuration ## Quick Start @@ -203,6 +198,9 @@ - `<fc=#FF0000>string</fc>` will print `string` with `#FF0000` color (red). +- `<fn=1>string</fn>` will print `string` with the first font from `additionalFonts`.+ The index `0` corresponds to the standard font.+ - `<icon=/path/to/icon.xbm/>` will insert the given bitmap. XPM image format is also supported when compiled with `--flags="with_xpm"`. @@ -232,12 +230,19 @@ `font` : Name of the font to be used. Use the `xft:` prefix for XFT fonts. +`additionalFonts`+: Haskell-style list of fonts to be used with the `fn`-template.+ Use the `xft:` prefix for XFT fonts.+ `bgColor` : Background color. `fgColor` : Default font color. +`alpha`+: The transparency. 0 is transparent, 255 is opaque.+ `position` : Top, TopP, TopW, TopSize, Bottom, BottomP, BottomW, BottomSize or Static (with x, y, width and height).@@ -274,6 +279,15 @@ : position = Top +`textOffset`+: The vertical offset, in pixels, for the text baseline. If+ negative or not given, xmobar will try to center text+ vertically.++`iconOffset`+: The vertical offset, in pixels, for icons bottom line. If negative+ or not given, xmobar will try to center icons vertically.+ `lowerOnStart` : When True the window is sent the bottom of the window stack initially. @@ -370,6 +384,7 @@ -f font name --font=font name The font name -B bg color --bgcolor=bg color The background color. Default black -F fg color --fgcolor=fg color The foreground color. Default grey+ -A alpha --alpha=alpha The transparency: 0 is transparent, 255 (the default) is opaque -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@@ -412,14 +427,18 @@ --print-reply \ '/org/Xmobar/Control' \ org.Xmobar.Control.SendSignal \- "string:Toggle"+ "string:Toggle 0" It is also possible to send multiple signals at once: # send to another screen, reveal and toggle the persistent flag dbus-send [..] \- "string:ChangeScreen" "string:Reveal 0" "string:TogglePersistent"+ "string:ChangeScreen 0" "string:Reveal 0" "string:TogglePersistent" +The `Toggle`, `Reveal`, and `Hide` signals take an additional integer+argument that denotes an initial delay, in tenths of a second, before+the command takes effect.+ ### Example for using the DBus IPC interface with XMonad Bind the key which should {,un}map xmobar to a dummy value. This is necessary@@ -712,6 +731,7 @@ - Aliases to the Station ID: so `Weather "LIPB" []` can be used in template as `%LIPB%`+- Thresholds refer to temperature in the selected units - Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `station`, `stationState`, `year`, `month`, `day`, `hour`,@@ -725,6 +745,7 @@ - Aliases to the interface name: so `Network "eth0" []` can be used as `%eth0%`+- Thresholds refer to velocities expressed in Kb/s - Args: default monitor arguments, plus: - `--rx-icon-pattern`: dynamic string for reception rate in `rxipat`. - `--tx-icon-pattern`: dynamic string for transmission rate in `txipat`.@@ -739,6 +760,7 @@ - Active interface is detected automatically - Aliases to "dynnetwork"+- Thresholds are expressed in Kb/s - Args: default monitor arguments, plus: - `--rx-icon-pattern`: dynamic string for reception rate in `rxipat`. - `--tx-icon-pattern`: dynamic string for transmission rate in `txipat`.@@ -757,10 +779,11 @@ - `--quality-icon-pattern`: dynamic string for connection quality in `qualityipat`. - Variables that can be used with the `-t`/`--template` argument: `essid`, `quality`, `qualitybar`, `qualityvbar`, `qualityipat`+- Thresholds refer to link quality in a `[0, 100]` scale - Default template: `<essid> <quality>` - Requires the C library [iwlib] (part of the wireless tools suite) installed in your system. In addition, to activate this plugin you- must pass `--flags="with_iwlib"` during compilation.+ must pass `--flags="with_iwlib"` during compilation ### `Memory Args RefreshRate` @@ -768,16 +791,20 @@ - Args: default monitor arguments, plus: - `--used-icon-pattern`: dynamic string for used memory ratio in `usedipat`. - `--free-icon-pattern`: dynamic string for free memory ratio in `freeipat`.+ - `--available-icon-pattern`: dynamic string for available memory ratio in `availableipat`.+- Thresholds refer to percentage of used memory - Variables that can be used with the `-t`/`--template` argument:- `total`, `free`, `buffer`, `cache`, `rest`, `used`,+ `total`, `free`, `buffer`, `cache`, `available`, `used`, `usedratio`, `usedbar`, `usedvbar`, `usedipat`,- `freeratio`, `freebar`, `freevbar`, `freeipat`+ `freeratio`, `freebar`, `freevbar`, `freeipat`,+ `availableratio`, `availablebar`, `availablevbar`, `availableipat` - Default template: `Mem: <usedratio>% (<cache>M)` ### `Swap Args RefreshRate` - Aliases to `swap` - Args: default monitor arguments+- Thresholds refer to percentage of used swap - Variables that can be used with the `-t`/`--template` argument: `total`, `used`, `free`, `usedratio` - Default template: `Swap: <usedratio>%`@@ -786,7 +813,8 @@ - Aliases to `cpu` - Args: default monitor arguments, plus:- - `--load-icon-pattern`: dynamic string for cpu load in `ipat`.+ - `--load-icon-pattern`: dynamic string for cpu load in `ipat`+- Thresholds refer to percentage of CPU load - Variables that can be used with the `-t`/`--template` argument: `total`, `bar`, `vbar`, `ipat`, `user`, `nice`, `system`, `idle`, `iowait` - Default template: `Cpu: <total>%`@@ -799,6 +827,7 @@ - `--load-icon-patterns`: dynamic string for each cpu load in `autoipat`, `ipat{i}`. This option can be specified several times. nth option corresponds to nth cpu.+- Thresholds refer to percentage of CPU load - Variables that can be used with the `-t`/`--template` argument: `autototal`, `autobar`, `autovbar`, `autoipat`, `autouser`, `autonice`, `autosystem`, `autoidle`, `total`, `bar`, `vbar`, `ipat`, `user`, `nice`,@@ -917,6 +946,7 @@ `<usedp>`, `<freebar>`, `<freevbar>`, `<freeipat>`, `<usedbar>`, `<usedvbar>` or `<usedipat>` for total, free, used, free percentage and used percentage of the given file system capacity.+- Thresholds refer to usage percentage. - Args: default monitor arguments. `-t`/`--template` is ignored. Plus - `--free-icon-pattern`: dynamic string for free disk space in `freeipat`. - `--used-icon-pattern`: dynamic string for used disk space in `usedipat`.@@ -936,6 +966,7 @@ `<totalbar>`, `<totalvbar>`, `<totalipat>`, `<readbar>`, `<readvbar>`, `<readipat>`, `<writebar>`, `<writevbar>`, and `<writeipat>`.+- Thresholds refer to speed in b/s - Args: default monitor arguments. `-t`/`--template` is ignored. Plus - `--total-icon-pattern`: dynamic string for total disk I/O in `<totalipat>`. - `--write-icon-pattern`: dynamic string for write disk I/O in `<writeipat>`.@@ -949,6 +980,7 @@ - Aliases to "thermaln": so `ThermalZone 0 []` can be used in template as `%thermal0%`+- Thresholds refer to temperature in degrees - Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `temp`@@ -968,6 +1000,7 @@ - Aliases to the Zone: so `Thermal "THRM" []` can be used in template as `%THRM%` - Args: default monitor arguments+- Thresholds refer to temperature in degrees - Variables that can be used with the `-t`/`--template` argument: `temp` - Default template: `Thm: <temp>C`@@ -981,6 +1014,7 @@ - Aliases to `cpufreq` - Args: default monitor arguments+- Thresholds refer to frequency in GHz - Variables that can be used with the `-t`/`--template` argument: `cpu0`, `cpu1`, .., `cpuN` - Default template: `Freq: <cpu0>GHz`@@ -994,6 +1028,7 @@ - Aliases to `coretemp` - Args: default monitor arguments+- Thresholds refer to temperature in degrees - Variables that can be used with the `-t`/`--template` argument: `core0`, `core1`, .., `coreN` - Default template: `Temp: <core0>C`@@ -1052,6 +1087,7 @@ `bar`, `vbar`, `ipat`, `state`, `statei`, `volume`, `length`, `lapsed`, `remaining`, `plength` (playlist length), `ppos` (playlist position),+ `flags` (ncmpcpp-style playback mode), `name`, `artist`, `composer`, `performer`, `album`, `title`, `track`, `file`, `genre` - Default template: `MPD: <state>`@@ -1059,7 +1095,7 @@ MPD's specific ones): Run MPD ["-t",- "<composer> <title> (<album>) <track>/<plength> <statei> ",+ "<composer> <title> (<album>) <track>/<plength> <statei> [<flags>]", "--", "-P", ">>", "-Z", "|", "-S", "><"] 10 ### `Mpris1 PlayerName Args RefreshRate`@@ -1197,9 +1233,9 @@ Run Locks -### `CatInt n fn`+### `CatInt n filename` -- Reads and displays an integer from the file whose path is `fn`+- Reads and displays an integer from the file whose path is `filename` (especially useful with files in `/sys`). - Aliases as `catn` (e.g. `Cat 0` as `cat0`, etc.) so you can have several.@@ -1359,8 +1395,7 @@ logHook = dynamicLogString myPP >>= xmonadPropLog } -Plugins-=======+# Plugins ## Writing a Plugin @@ -1476,24 +1511,25 @@ 3. rebuild xmobar. -Authors and credits-===================+# Authors and credits Andrea Rossato originally designed and implemented xmobar up to version 0.11.1. Since then, it is maintained and developed by [jao], with the help of the greater xmobar and Haskell communities. In particular, xmobar [incorporates patches] by Axel Angel, Ben-Boeckel, Roman Cheplyaka, Patrick Chilton, Nathaniel Wesley Filardo,-John Goerzen, Reto Hablützel, Juraj Hercek, Tomas Janousek, Spencer-Janssen, Jochen Keil, Lennart Kolmodin, Krzysztof Kosciuszkiewicz,-Dmitry Kurochkin, Todd Lunter, Robert J. Macomber, Dmitry Malikov,-David McLean, Marcin Mikołajczyk, Tony Morris, Eric Mrak, Thiago-Negri, Edward O'Callaghan, Svein Ove, Martin Perner, Jens Petersen,-Alexander Polakov, Petr Rockai, Andrew Sackville-West, Alexander-Shabalin, Peter Simons, Alexander Solovyov, John Soros, Travis Staton,-Artem Tarasov, Sergei Trofimovich, Thomas Tuegel, Jan Vornberger,-Anton Vorontsov, Daniel Wagner, Phil Xiaojun Hu and Norbert Zeh.+Boeckel, Duncan Burke, Roman Cheplyaka, Patrick Chilton, Nathaniel+Wesley Filardo, John Goerzen, Reto Hablützel, Juraj Hercek, Tomas+Janousek, Spencer Janssen, Jochen Keil, Lennart Kolmodin, Krzysztof+Kosciuszkiewicz, Dmitry Kurochkin, Todd Lunter, Robert J. Macomber,+Dmitry Malikov, David McLean, Marcin Mikołajczyk, Dino Morelli, Tony+Morris, Eric Mrak, Thiago Negri, Edward O'Callaghan, Svein Ove, Martin+Perner, Jens Petersen, Alexander Polakov, Petr Rockai, Andrew+Sackville-West, Markus Scherer, Alexander Shabalin, Peter Simons,+Alexander Solovyov, John Soros, Travis Staton, Artem Tarasov, Samuli+Thomasson, Sergei Trofimovich, Thomas Tuegel, Jan Vornberger, Anton+Vorontsov, Daniel Wagner, Phil Xiaojun Hu, Edward Z. Yang and Norbert+Zeh. [jao]: http://jao.io [incorporates patches]: http://www.ohloh.net/p/xmobar/contributors@@ -1514,8 +1550,7 @@ Thanks to Andrea for creating xmobar in the first place, and for giving me the chance to contribute. -Useful links-============+# Useful links - [Github page]. - [Mailing list].@@ -1531,13 +1566,12 @@ [this tutorial]: http://www.haskell.org/haskellwiki/X_window_programming_in_Haskell [sawflibs]: http://github.com/jaor/sawflibs -License-=======+# License This software is released under a BSD-style license. See [LICENSE] for more details. -Copyright © 2010-2013 Jose Antonio Ortega Ruiz+Copyright © 2010-2014 Jose Antonio Ortega Ruiz Copyright © 2007-2010 Andrea Rossato
samples/xmobar.config view
@@ -1,9 +1,13 @@ Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"+ , addtionalFonts = [] , borderColor = "black" , border = TopB , bgColor = "black" , fgColor = "grey"+ , alpha = 255 , position = Top+ , textOffset = -1+ , iconOffset = -1 , lowerOnStart = True , pickBroadest = False , persistent = False
src/Bitmap.hs view
@@ -54,10 +54,10 @@ } updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath ->- [[(Widget, String, Maybe [Action])]] -> IO (Map FilePath Bitmap)+ [[(Widget, String, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap) updateCache dpy win cache iconRoot ps = do- let paths = map (\(Icon p, _, _) -> p) . concatMap (filter icons) $ ps- icons (Icon _, _, _) = True+ let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps+ icons (Icon _, _, _, _) = True icons _ = False expandPath path@('/':_) = path expandPath path@('.':'/':_) = path
src/Config.hs view
@@ -49,12 +49,16 @@ -- | The configuration data type data Config = Config { font :: String -- ^ Font+ , additionalFonts :: [String] -- ^ List of alternative fonts , bgColor :: String -- ^ Backgroud color , fgColor :: String -- ^ Default font color , position :: XPosition -- ^ Top Bottom or Static+ , textOffset :: Int -- ^ Offset from top of window for text+ , iconOffset :: Int -- ^ Offset from top of window for icons , border :: Border -- ^ NoBorder TopB BottomB or FullB , borderColor :: String -- ^ Border color , borderWidth :: Int -- ^ Border width+ , alpha :: Int -- ^ Transparency from 0 (transparent) to 255 (opaque) , hideOnStart :: Bool -- ^ Hide (Unmap) the window on -- initialization , allDesktops :: Bool -- ^ Tell the WM to map to all desktops@@ -107,12 +111,16 @@ defaultConfig :: Config defaultConfig = Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"+ , additionalFonts = [] , bgColor = "#000000" , fgColor = "#BFBFBF"+ , alpha = 255 , position = Top , border = NoBorder , borderColor = "#BFBFBF" , borderWidth = 1+ , textOffset = -1+ , iconOffset = -1 , hideOnStart = False , lowerOnStart = True , persistent = False
src/Main.hs view
@@ -59,12 +59,13 @@ conf <- doOpts c o fs <- initFont d (font conf)+ fl <- mapM (initFont d) (additionalFonts conf) cls <- mapM (parseTemplate conf) (splitTemplate conf) sig <- setupSignalHandler vars <- mapM (mapM $ startCommand sig) cls (r,w) <- createWin d fs conf let ic = Map.empty- startLoop (XConf d r w fs ic conf) sig vars+ startLoop (XConf d r w (fs:fl) ic conf) sig vars -- | Splits the template in its parts splitTemplate :: Config -> [String]@@ -121,6 +122,7 @@ | Font String | BgColor String | FgColor String+ | Alpha String | T | B | D@@ -144,6 +146,8 @@ "The foreground color. Default grey" , Option "i" ["iconroot"] (ReqArg IconRoot "path") "Root directory for icon pattern paths. Default '.'"+ , Option "A" ["alpha"] (ReqArg Alpha "alpha")+ "The transparency: 0 is transparent, 255 is opaque. Default: 255" , Option "o" ["top"] (NoArg T) "Place xmobar at the top of the screen" , Option "b" ["bottom"] (NoArg B) "Place xmobar at the bottom of the screen"@@ -200,6 +204,7 @@ Font s -> doOpts' (conf {font = s}) BgColor s -> doOpts' (conf {bgColor = s}) FgColor s -> doOpts' (conf {fgColor = s})+ Alpha n -> doOpts' (conf {alpha = read n}) T -> doOpts' (conf {position = Top}) B -> doOpts' (conf {position = Bottom}) D -> doOpts' (conf {overrideRedirect = False})
src/MinXft.hsc view
@@ -1,8 +1,7 @@-{-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ -- | -- Module: MinXft--- Copyright: (c) 2012, 2014 Jose Antonio Ortega Ruiz+-- Copyright: (c) 2012, 2014, 2015 Jose Antonio Ortega Ruiz -- (c) Clemens Fruhwirth <clemens@endorphin.org> 2007 -- License: BSD3-style (see LICENSE) --@@ -19,6 +18,8 @@ -- ------------------------------------------------------------------------------ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+ module MinXft ( AXftColor , AXftDraw (..) , AXftFont@@ -27,6 +28,7 @@ , withAXftDraw , drawXftString , drawXftString'+ , drawBackground , drawXftRect , openAXftFont , closeAXftFont@@ -45,6 +47,7 @@ import Graphics.X11 import Graphics.X11.Xlib.Types import Graphics.X11.Xrender+import Graphics.X11.Xlib.Extras (xGetWindowProperty, xFree) import Foreign import Foreign.C.Types@@ -52,6 +55,8 @@ import Codec.Binary.UTF8.String as UTF8 import Data.Char (ord) +import Control.Monad (when)+ #include <X11/Xft/Xft.h> -- Color Handling@@ -219,3 +224,110 @@ AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO () drawXftRect draw color x y width height = cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height)++#include <X11/extensions/Xrender.h>++type Picture = XID+type PictOp = CInt++data XRenderPictFormat+data XRenderPictureAttributes = XRenderPictureAttributes++-- foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFillRectangle"+ -- xRenderFillRectangle :: Display -> PictOp -> Picture -> Ptr XRenderColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()+foreign import ccall unsafe "X11/extensions/Xrender.h XRenderComposite"+ xRenderComposite :: Display -> PictOp -> Picture -> Picture -> Picture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CUInt -> CUInt -> IO ()+foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreateSolidFill"+ xRenderCreateSolidFill :: Display -> Ptr XRenderColor -> IO Picture+foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFreePicture"+ xRenderFreePicture :: Display -> Picture -> IO ()+foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO ()+foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFindStandardFormat"+ xRenderFindStandardFormat :: Display -> CInt -> IO (Ptr XRenderPictFormat)+foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreatePicture"+ xRenderCreatePicture :: Display -> Drawable -> Ptr XRenderPictFormat -> CULong -> Ptr XRenderPictureAttributes -> IO Picture+++-- Attributes not supported+instance Storable XRenderPictureAttributes where+ sizeOf _ = #{size XRenderPictureAttributes}+ alignment _ = alignment (undefined :: CInt)+ peek _ = return XRenderPictureAttributes+ poke p XRenderPictureAttributes = do+ memset p 0 #{size XRenderPictureAttributes}++-- | Convenience function, gives us an XRender handle to a traditional+-- Pixmap. Don't let it escape.+withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO ()+withRenderPicture d p f = do+ format <- xRenderFindStandardFormat d 1 -- PictStandardRGB24+ alloca $ \attr -> do+ pic <- xRenderCreatePicture d p format 0 attr+ f pic+ xRenderFreePicture d pic++-- | Convenience function, gives us an XRender picture that is a solid+-- fill of color 'c'. Don't let it escape.+withRenderFill :: Display -> XRenderColor -> (Picture -> IO a) -> IO ()+withRenderFill d c f = do+ pic <- with c (xRenderCreateSolidFill d)+ f pic+ xRenderFreePicture d pic++-- | Drawing the background to a pixmap and taking into account+-- transparency+drawBackground :: Display -> Drawable -> String -> Int -> Rectangle -> IO ()+drawBackground d p bgc alpha (Rectangle x y wid ht) = do+ let render opt bg pic m =+ xRenderComposite d opt bg m pic+ (fromIntegral x) (fromIntegral y) 0 0+ 0 0 (fromIntegral wid) (fromIntegral ht)+ withRenderPicture d p $ \pic -> do+ -- Handle background color+ bgcolor <- parseRenderColor d bgc+ withRenderFill d bgcolor $ \bgfill ->+ withRenderFill d+ (XRenderColor 0 0 0 (257 * alpha))+ (render pictOpSrc bgfill pic)+ -- Handle transparency+ internAtom d "_XROOTPMAP_ID" False >>= \xid ->+ let xroot = defaultRootWindow d in+ alloca $ \x1 ->+ alloca $ \x2 ->+ alloca $ \x3 ->+ alloca $ \x4 ->+ alloca $ \pprop -> do+ xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop+ prop <- peek pprop+ when (prop /= nullPtr) $ do+ rootbg <- peek (castPtr prop) :: IO Pixmap+ xFree prop+ withRenderPicture d rootbg $ \bgpic ->+ withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha))+ (render pictOpAdd bgpic pic)++-- | Parses color into XRender color (allocation not necessary!)+parseRenderColor :: Display -> String -> IO XRenderColor+parseRenderColor d c = do+ let colormap = defaultColormap d (defaultScreen d)+ Color _ red green blue _ <- parseColor d colormap c+ return $ XRenderColor (fromIntegral red) (fromIntegral green) (fromIntegral blue) 0xFFFF++pictOpSrc, pictOpAdd :: PictOp+pictOpSrc = 1+pictOpAdd = 12++-- pictOpMinimum = 0+-- pictOpClear = 0+-- pictOpDst = 2+-- pictOpOver = 3+-- pictOpOverReverse = 4+-- pictOpIn = 5+-- pictOpInReverse = 6+-- pictOpOut = 7+-- pictOpOutReverse = 8+-- pictOpAtop = 9+-- pictOpAtopReverse = 10+-- pictOpXor = 11+-- pictOpSaturate = 13+-- pictOpMaximum = 13
src/Parsers.hs view
@@ -34,44 +34,50 @@ data Widget = Icon String | Text String type ColorString = String+type FontIndex = Int -- | Runs the string parser-parseString :: Config -> String -> IO [(Widget, ColorString, Maybe [Action])]+parseString :: Config -> String -> IO [(Widget, ColorString, FontIndex, Maybe [Action])] parseString c s =- case parse (stringParser (fgColor c) Nothing) "" s of+ case parse (stringParser (fgColor c) 0 Nothing) "" s of Left _ -> return [(Text $ "Could not parse string: " ++ s , fgColor c+ , 0 , Nothing)] Right x -> return (concat x) allParsers :: ColorString+ -> FontIndex -> Maybe [Action]- -> Parser [(Widget, ColorString, Maybe [Action])]-allParsers c a =- textParser c a- <|> try (iconParser c a)- <|> try (rawParser c a)- <|> try (actionParser c a)- <|> colorParser a+ -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]+allParsers c f a =+ textParser c f a+ <|> try (iconParser c f a)+ <|> try (rawParser c f a)+ <|> try (actionParser c f a)+ <|> try (fontParser c a)+ <|> colorParser f a -- | Gets the string and combines the needed parsers-stringParser :: String -> Maybe [Action]- -> Parser [[(Widget, ColorString, Maybe [Action])]]-stringParser c a = manyTill (allParsers c a) eof+stringParser :: String -> FontIndex -> Maybe [Action]+ -> Parser [[(Widget, ColorString, FontIndex, Maybe [Action])]]+stringParser c f a = manyTill (allParsers c f a) eof -- | Parses a maximal string without color markup.-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=") <|>- try (string "raw=") <|>- string "/fc>"))- return [(Text s, c, a)]+textParser :: String -> FontIndex -> Maybe [Action]+ -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]+textParser c f a = do s <- many1 $+ noneOf "<" <|>+ try (notFollowedBy' (char '<')+ (try (string "fc=") <|>+ try (string "fn=") <|>+ try (string "action=") <|>+ try (string "/action>") <|>+ try (string "icon=") <|>+ try (string "raw=") <|>+ try (string "/fn>") <|>+ string "/fc>"))+ return [(Text s, c, f, a)] -- | Parse a "raw" tag, which we use to prevent other tags from creeping in. -- The format here is net-string-esque: a literal "<raw=" followed by a@@ -79,9 +85,10 @@ -- a literal ":" as digit-string-terminator, the raw string itself, and -- then a literal "/>". rawParser :: ColorString+ -> FontIndex -> Maybe [Action]- -> Parser [(Widget, ColorString, Maybe [Action])]-rawParser c a = do+ -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]+rawParser c f a = do string "<raw=" lenstr <- many1 digit char ':'@@ -90,7 +97,7 @@ guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) s <- count (fromIntegral len) anyChar string "/>"- return [(Text s, c, a)]+ return [(Text s, c, f, a)] _ -> mzero -- | Wrapper for notFollowedBy that returns the result of the first parser.@@ -101,15 +108,15 @@ notFollowedBy $ try (e >> return '*') return x -iconParser :: String -> Maybe [Action]- -> Parser [(Widget, ColorString, Maybe [Action])]-iconParser c a = do+iconParser :: String -> FontIndex -> Maybe [Action]+ -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]+iconParser c f a = do string "<icon=" i <- manyTill (noneOf ">") (try (string "/>"))- return [(Icon i, c, a)]+ return [(Icon i, c, f, a)] -actionParser :: String -> Maybe [Action] -> Parser [(Widget, ColorString, Maybe [Action])]-actionParser c act = do+actionParser :: String -> FontIndex -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]+actionParser c f act = do string "<action=" command <- choice [between (char '`') (char '`') (many1 (noneOf "`")), many1 (noneOf ">")]@@ -119,19 +126,26 @@ a' = case act of Nothing -> Just [a] Just act' -> Just $ a : act'- s <- manyTill (allParsers c a') (try $ string "</action>")+ s <- manyTill (allParsers c f a') (try $ string "</action>") return (concat s) toButtons :: String -> [Button] toButtons = map (\x -> read [x]) -- | Parsers a string wrapped in a color specification.-colorParser :: Maybe [Action] -> Parser [(Widget, ColorString, Maybe [Action])]-colorParser a = do+colorParser :: FontIndex -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]+colorParser f a = do c <- between (string "<fc=") (string ">") colors- s <- manyTill (allParsers c a) (try $ string "</fc>")+ s <- manyTill (allParsers c f a) (try $ string "</fc>") return (concat s) +-- | Parsers a string wrapped in a font specification.+fontParser :: ColorString -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]+fontParser c a = do+ f <- between (string "<fn=") (string ">") colors+ s <- manyTill (allParsers c (read f) a) (try $ string "</fn>")+ return (concat s)+ -- | Parses a color specification (hex or named) colors :: Parser String colors = many1 (alphaNum <|> char ',' <|> char '#')@@ -198,21 +212,24 @@ return (x,s) perms = permute $ Config- <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition- <|?> pBorder <|?> pBdColor <|?> pBdWidth <|?> pHideOnStart+ <$?> pFont <|?> pFontList <|?> pBgColor <|?> pFgColor+ <|?> pPosition <|?> pTextOffset <|?> pIconOffset <|?> pBorder+ <|?> pBdColor <|?> pBdWidth <|?> pAlpha <|?> pHideOnStart <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate - fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep"- , "border", "borderColor" ,"template", "position"+ fields = [ "font", "additionalFonts","bgColor", "fgColor", "sepChar"+ , "alignSep" , "border", "borderColor" ,"template"+ , "position" , "textOffset", "iconOffset" , "allDesktops", "overrideRedirect", "pickBroadest" , "hideOnStart", "lowerOnStart", "persistent", "iconRoot"- , "commands"+ , "alpha", "commands" ] pFont = strField font "font"+ pFontList = strListField additionalFonts "additionalFonts" pBgColor = strField bgColor "bgColor" pFgColor = strField fgColor "fgColor" pBdColor = strField borderColor "borderColor"@@ -220,6 +237,8 @@ pAlignSep = strField alignSep "alignSep" pTemplate = strField template "template" + pTextOffset = readField textOffset "textOffset"+ pIconOffset = readField iconOffset "iconOffset" pPosition = readField position "position" pHideOnStart = readField hideOnStart "hideOnStart" pLowerOnStart = readField lowerOnStart "lowerOnStart"@@ -230,6 +249,7 @@ pOverrideRedirect = readField overrideRedirect "overrideRedirect" pPickBroadest = readField pickBroadest "pickBroadest" pIconRoot = readField iconRoot "iconRoot"+ pAlpha = readField alpha "alpha" pCommands = field commands "commands" readCommands @@ -248,7 +268,6 @@ } readCommands = manyTill anyChar (try commandsEnd) >>= read' commandsErr . flip (++) "]"- strField e n = field e n strMulti strMulti = scan '"'@@ -260,6 +279,15 @@ (char '"' >> return s) <|> liftM (s ++) (scan '\\') rowCont = try $ char '\\' >> string "\n" unescQuote = lookAhead (noneOf "\\") >> lookAhead (string "\"")++ strListField e n = field e n strList+ strList = do+ spaces+ char '['+ list <- sepBy (strMulti >>= \x -> spaces >> return x) (char ',')+ spaces+ char ']'+ return list wrapSkip x = many space >> x >>= \r -> many space >> return r sepEndSpc = mapM_ (wrapSkip . try . string)
src/Plugins/Monitors/CpuFreq.hs view
@@ -18,22 +18,24 @@ import Plugins.Monitors.CoreCommon -- |--- Cpu frequency default configuration. Default template contains only one--- core frequency, user should specify custom template in order to get more--- cpu frequencies.+-- Cpu frequency default configuration. Default template contains only+-- one core frequency, user should specify custom template in order to+-- get more cpu frequencies. cpuFreqConfig :: IO MConfig-cpuFreqConfig = mkMConfig- "Freq: <cpu0>" -- template- (map ((++) "cpu" . show) [0 :: Int ..]) -- available- -- replacements+cpuFreqConfig =+ mkMConfig "Freq: <cpu0>" (map ((++) "cpu" . show) [0 :: Int ..]) + -- |--- Function retrieves monitor string holding the cpu frequency (or frequencies)+-- Function retrieves monitor string holding the cpu frequency (or+-- frequencies) runCpuFreq :: [String] -> Monitor String runCpuFreq _ = do+ suffix <- getConfigValue useSuffix let path = ["/sys/devices/system/cpu/cpu", "/cpufreq/scaling_cur_freq"] divisor = 1e6 :: Double- fmt x | x < 1 = show (round (x * 1000) :: Integer) ++ "MHz"- | otherwise = show x ++ "GHz"+ fmt x | x < 1 = show (round (x * 1000) :: Integer) +++ if suffix then "MHz" else ""+ | otherwise = show x ++ if suffix then "GHz" else "" failureMessage <- getConfigValue naString checkedDataRetrieval failureMessage [path] Nothing (/divisor) fmt
src/Plugins/Monitors/MPD.hs view
@@ -24,7 +24,7 @@ mpdConfig :: IO MConfig mpdConfig = mkMConfig "MPD: <state>" [ "bar", "vbar", "ipat", "state", "statei", "volume", "length"- , "lapsed", "remaining", "plength", "ppos", "file"+ , "lapsed", "remaining", "plength", "ppos", "flags", "file" , "name", "artist", "composer", "performer" , "album", "title", "track", "genre" ]@@ -93,7 +93,7 @@ bar <- showPercentBar (100 * b) b vbar <- showVerticalBar (100 * b) b ipat <- showIconPattern (mLapsedIconPattern opts) b- return $ [bar, vbar, ipat, ss, si, vol, len, lap, remain, plen, ppos] ++ songData+ return $ [bar, vbar, ipat, ss, si, vol, len, lap, remain, plen, ppos, flags] ++ songData where s = M.stState st ss = show s si = stateGlyph s opts@@ -103,6 +103,7 @@ b = if t > 0 then realToFrac $ p / fromIntegral t else 0 plen = int2str $ M.stPlaylistLength st ppos = maybe "" (int2str . (+1)) $ M.stSongPos st+ flags = playbackMode st stateGlyph :: M.State -> MOpts -> String stateGlyph s o =@@ -110,6 +111,14 @@ M.Playing -> mPlaying o M.Paused -> mPaused o M.Stopped -> mStopped o++playbackMode :: M.Status -> String+playbackMode s =+ concat [if p s then f else "-" |+ (p,f) <- [(M.stRepeat,"r"),+ (M.stRandom,"z"),+ (M.stSingle,"s"),+ (M.stConsume,"c")]] parseSong :: M.Response (Maybe M.Song) -> Monitor [String] parseSong (Left _) = return $ repeat ""
src/Plugins/Monitors/Mem.hs view
@@ -21,12 +21,14 @@ data MemOpts = MemOpts { usedIconPattern :: Maybe IconPattern , freeIconPattern :: Maybe IconPattern+ , availableIconPattern :: Maybe IconPattern } defaultOpts :: MemOpts defaultOpts = MemOpts { usedIconPattern = Nothing , freeIconPattern = Nothing+ , availableIconPattern = Nothing } options :: [OptDescr (MemOpts -> MemOpts)]@@ -35,6 +37,8 @@ o { usedIconPattern = Just $ parseIconPattern x }) "") "" , Option "" ["free-icon-pattern"] (ReqArg (\x o -> o { freeIconPattern = Just $ parseIconPattern x }) "") ""+ , Option "" ["available-icon-pattern"] (ReqArg (\x o ->+ o { availableIconPattern = Just $ parseIconPattern x }) "") "" ] parseOpts :: [String] -> IO MemOpts@@ -46,8 +50,10 @@ memConfig :: IO MConfig memConfig = mkMConfig "Mem: <usedratio>% (<cache>M)" -- template- ["usedbar", "usedvbar", "usedipat", "freebar", "freevbar", "freeipat", "usedratio", "freeratio",- "total", "free", "buffer", "cache", "rest", "used"] -- available replacements+ ["usedbar", "usedvbar", "usedipat", "freebar", "freevbar", "freeipat",+ "availablebar", "availablevbar", "availableipat",+ "usedratio", "freeratio", "availableratio",+ "total", "free", "buffer", "cache", "available", "used"] -- available replacements fileMEM :: IO String fileMEM = readFile "/proc/meminfo"@@ -58,11 +64,12 @@ let content = map words $ take 8 $ lines file info = M.fromList $ map (\line -> (head line, (read $ line !! 1 :: Float) / 1024)) content [total, free, buffer, cache] = map (info M.!) ["MemTotal:", "MemFree:", "Buffers:", "Cached:"]- rest = free + buffer + cache- used = total - M.findWithDefault rest "MemAvailable:" info+ available = M.findWithDefault (free + buffer + cache) "MemAvailable:" info+ used = total - available usedratio = used / total freeratio = free / total- return [usedratio, freeratio, total, free, buffer, cache, rest, used, freeratio]+ availableratio = available / total+ return [usedratio, freeratio, availableratio, total, free, buffer, cache, available, used] totalMem :: IO Float totalMem = fmap ((*1024) . (!!1)) parseMEM@@ -71,19 +78,14 @@ usedMem = fmap ((*1024) . (!!6)) parseMEM formatMem :: MemOpts -> [Float] -> Monitor [String]-formatMem opts (r:fr:xs) =+formatMem opts (r:fr:ar:xs) = do let f = showDigits 0- rr = 100 * r- ub <- showPercentBar rr r- uvb <- showVerticalBar rr r- uipat <- showIconPattern (usedIconPattern opts) r- fb <- showPercentBar (100 - rr) (1 - r)- fvb <- showVerticalBar (100 - rr) ( 1 - r)- fipat <- showIconPattern (freeIconPattern opts) (1 - r)- rs <- showPercentWithColors r- fs <- showPercentWithColors fr- s <- mapM (showWithColors f) xs- return (ub:uvb:uipat:fb:fvb:fipat:rs:fs:s)+ mon i x = [showPercentBar (100 * x) x, showVerticalBar (100 * x) x, showIconPattern i x]+ sequence $ mon (usedIconPattern opts) r+ ++ mon (freeIconPattern opts) fr+ ++ mon (availableIconPattern opts) ar+ ++ map showPercentWithColors [r, fr, ar]+ ++ map (showWithColors f) xs formatMem _ _ = replicate 10 `fmap` getConfigValue naString runMem :: [String] -> Monitor String
src/Plugins/Monitors/Weather.hs view
@@ -99,6 +99,12 @@ let tospace = manyTill anyChar (char ' ') wind0 = do manyTill skipRestOfLine (string "Wind: Calm:0") return pWind0+ windVar = do manyTill skipRestOfLine (string "Wind: Variable at ")+ mph <- tospace+ string "MPH ("+ knot <- tospace+ manyTill anyChar newline+ return ("μ", "μ", mph, knot) wind = do manyTill skipRestOfLine (string "Wind: from the ") cardinal <- tospace char '('@@ -109,7 +115,7 @@ knot <- tospace manyTill anyChar newline return (cardinal, azimuth, mph, knot)- in try wind0 <|> wind+ in try wind0 <|> try windVar <|> wind pTemp :: Parser (Int, Int) pTemp = do let num = digit <|> char '-' <|> char '.'
src/XUtil.hsc view
@@ -1,8 +1,7 @@-{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : XUtil--- Copyright : (C) 2011, 2012, 2013, 2014 Jose Antonio Ortega Ruiz+-- Copyright : (C) 2011, 2012, 2013, 2014, 2015 Jose Antonio Ortega Ruiz -- (C) 2007 Andrea Rossato -- License : BSD3 --@@ -12,6 +11,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+ module XUtil ( XFont , initFont@@ -29,6 +30,7 @@ ) where import Control.Concurrent+import Control.Monad (when) import Control.Monad.Trans import Control.Exception (SomeException, handle) import Foreign@@ -92,7 +94,7 @@ #endif miscFixedFont :: String-miscFixedFont = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"+miscFixedFont = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*" -- | Given a fontname returns the font structure. If the font name is -- not valid the default font will be loaded and returned.@@ -162,29 +164,28 @@ #endif printString :: Display -> Drawable -> XFont -> GC -> String -> String- -> Position -> Position -> String -> IO ()-printString d p (Core fs) gc fc bc x y s = do+ -> Position -> Position -> String -> Int -> IO ()+printString d p (Core fs) gc fc bc x y s a = do setFont d gc $ fontFromFontStruct fs withColors d [fc, bc] $ \[fc', bc'] -> do setForeground d gc fc'- setBackground d gc bc'+ when (a == 255) (setBackground d gc bc') drawImageString d p gc x y s -printString d p (Utf8 fs) gc fc bc x y s =+printString d p (Utf8 fs) gc fc bc x y s a = withColors d [fc, bc] $ \[fc', bc'] -> do setForeground d gc fc'- setBackground d gc bc'+ when (a == 255) (setBackground d gc bc') io $ wcDrawImageString d p fs gc x y s #ifdef XFT-printString dpy drw fs@(Xft fonts) _ fc bc x y s = do- (a,d) <- textExtents fs s- gi <- xftTxtExtents' dpy fonts s- withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' ->- (drawXftRect draw bc' (x + 1 - fi (xglyphinfo_x gi))- (y - (a + d) + 1)- (xglyphinfo_xOff gi)- (a + d)) >>+printString dpy drw fs@(Xft fonts) _ fc bc x y s al = do+ withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' -> do+ when (al == 255) $ do+ (a,d) <- textExtents fs s+ gi <- xftTxtExtents' dpy fonts s+ drawXftRect draw bc' (x + 1 - fi (xglyphinfo_x gi))+ (y - (a + d) + 1) (xglyphinfo_xOff gi) (a + d) (drawXftString' draw fc' fonts (toInteger x) (toInteger (y - 2)) s) #endif
src/Xmobar.hs view
@@ -2,7 +2,8 @@ ----------------------------------------------------------------------------- -- | -- Module : Xmobar--- Copyright : (c) Andrea Rossato+-- Copyright : (c) 2011, 2012, 2013, 2014, 2015 Jose Antonio Ortega Ruiz+-- (c) 2007 Andrea Rossato -- License : BSD-style (see LICENSE) -- -- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>@@ -58,6 +59,7 @@ #ifdef XFT import Graphics.X11.Xft+import MinXft (drawBackground) #endif #ifdef DBUS@@ -73,12 +75,12 @@ -- | The ReaderT inner component data XConf =- XConf { display :: Display- , rect :: Rectangle- , window :: Window- , fontS :: XFont- , iconS :: Map FilePath Bitmap- , config :: Config+ XConf { display :: Display+ , rect :: Rectangle+ , window :: Window+ , fontListS :: [XFont]+ , iconS :: Map FilePath Bitmap+ , config :: Config } -- | Runs the ReaderT@@ -86,7 +88,8 @@ runX xc f = runReaderT f xc -- | Starts the main event loop and threads-startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO ()+startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]]+ -> IO () startLoop xcfg@(XConf _ _ w _ _ _) sig vs = do #ifdef XFT xftInitFtLibrary@@ -109,8 +112,8 @@ eventer signal = allocaXEvent $ \e -> do dpy <- openDisplay ""- xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask- selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask)+ xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask+ selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) forever $ do #ifdef THREADED_RUNTIME@@ -151,7 +154,8 @@ case typ of Wakeup -> do str <- updateString cfg tv- xc' <- updateCache d w is (iconRoot cfg) str >>= \c -> return xc { iconS = c }+ xc' <- updateCache d w is (iconRoot cfg) str >>=+ \c -> return xc { iconS = c } as' <- updateActions xc r str runX xc' $ drawInWin r str eventLoop tv xc' as' signal@@ -198,7 +202,7 @@ eventLoop tv xc as signal reposWindow rcfg = do- r' <- repositionWin d w fs rcfg+ r' <- repositionWin d w (fs!!0) rcfg eventLoop tv (XConf d r' w fs is rcfg) as signal updateConfigPosition ocfg =@@ -210,8 +214,7 @@ (ocfg {position = OnScreen 1 o}) else (ocfg {position = OnScreen (n+1) o}))- o ->- return (ocfg {position = OnScreen 1 o})+ o -> return (ocfg {position = OnScreen 1 o}) action button x = do mapM_ runAction $@@ -231,66 +234,74 @@ | alias com == "" = do var <- atomically $ newTVar is atomically $ writeTVar var (s ++ ss) return (Nothing,var)- | otherwise = do var <- atomically $ newTVar is- let cb str = atomically $ writeTVar var (s ++ str ++ ss)- h <- forkIO $ start com cb- _ <- forkIO $ trigger com- $ maybe (return ()) (atomically . putTMVar sig)- return (Just h,var)+ | otherwise = do var <- atomically $ newTVar is+ let cb str = atomically $ writeTVar var (s ++ str ++ ss)+ h <- forkIO $ start com cb+ _ <- forkIO $ trigger com $ maybe (return ())+ (atomically . putTMVar sig)+ return (Just h,var) where is = s ++ "Updating..." ++ ss -updateString :: Config -> TVar [String] ->- IO [[(Widget, String, Maybe [Action])]]+updateString :: Config -> TVar [String]+ -> IO [[(Widget, String, Int, 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 :: XConf -> Rectangle -> [[(Widget, String, Int, 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)]+ let (d,fs) = (display &&& fontListS) conf+ strLn :: [(Widget, String, Int, 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)+ getCoords (Text s,_,i,a) = textWidth d (fs!!i) 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, _,_) -> isJust a) $- 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) -> (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $- zip [L,C,R] [left,center,right]+ 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) ->+ (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $+ zip [L,C,R] [left,center,right] -- $print -- | Draws in and updates the window-drawInWin :: Rectangle -> [[(Widget, String, Maybe [Action])]] -> X ()-drawInWin (Rectangle _ _ wid ht) ~[left,center,right] = do+drawInWin :: Rectangle -> [[(Widget, String, Int, Maybe [Action])]] -> X ()+drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do r <- ask- let (c,d ) = (config &&& display) r- (w,fs) = (window &&& fontS ) r- strLn = io . mapM getWidth+ let (c,d) = (config &&& display) r+ (w,fs) = (window &&& fontListS ) r+ 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)+ getWidth (Text s,cl,i,_) =+ textWidth d (fs!!i) s >>= \tw -> return (Text s,cl,i,fi tw)+ getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s) + p <- io $ createPixmap d w wid ht+ (defaultDepthOfScreen (defaultScreenOfDisplay d))+#if XFT+ when (alpha c /= 255) (io $ drawBackground d p (bgColor c) (alpha c) wr)+#endif 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- p <- io $ createPixmap d w wid ht- (defaultDepthOfScreen (defaultScreenOfDisplay d))- -- the fgcolor of the rectangle will be the bgcolor of the window- io $ setForeground d gc bgcolor- io $ fillRectangle d p gc 0 0 wid ht+#if XFT+ when (alpha c == 255) $ do+#else+ do+#endif+ io $ setForeground d gc bgcolor+ io $ fillRectangle d p gc 0 0 wid ht -- write to the pixmap the new string printStrings p gc fs 1 L =<< strLn left printStrings p gc fs 1 R =<< strLn right@@ -298,36 +309,51 @@ -- draw 1 pixel border if requested io $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht -- copy the pixmap with the new string to the window- io $ copyArea d p w gc 0 0 wid ht 0 0+ io $ copyArea d p w gc 0 0 wid ht 0 0 -- free up everything (we do not want to leak memory!)- io $ freeGC d gc+ io $ freeGC d gc io $ freePixmap d p -- resync- io $ sync d True+ io $ sync d True +verticalOffset :: (Integral b, Integral a, MonadIO m) =>+ a -> Widget -> XFont -> Config -> m b+verticalOffset ht (Text t) fontst conf+ | textOffset conf > -1 = return $ fi (textOffset conf)+ | otherwise = do+ (as,ds) <- io $ textExtents fontst t+ let bwidth = borderOffset (border conf) (borderWidth conf)+ verticalMargin = fi ht - fi (as + ds) - 2 * fi (abs bwidth)+ return $ fi ht - fi ds - (verticalMargin `div` 2) + bwidth + 1+verticalOffset _ (Icon _) _ conf+ | iconOffset conf > -1 = return $ fi (iconOffset conf)+ | otherwise = do+ let bwidth = borderOffset (border conf) (borderWidth conf)+ return $ bwidth + 1+ -- | An easy way to print the stuff we need to print-printStrings :: Drawable -> GC -> XFont -> Position- -> Align -> [(Widget, String, Position)] -> X ()+printStrings :: Drawable -> GC -> [XFont] -> Position+ -> Align -> [(Widget, String, Int, Position)] -> X () printStrings _ _ _ _ _ [] = return ()-printStrings dr gc fontst offs a sl@((s,c,l):xs) = do+printStrings dr gc fontlist offs a sl@((s,c,i,l):xs) = do r <- ask- (as,ds) <- case s of- Text t -> io $ textExtents fontst t- Icon _ -> return (0, 0)- let (conf,d) = (config &&& display) r- boffs = borderOffset (border conf) (borderWidth conf)+ let (conf,d) = (config &&& display) r+ alph = alpha conf Rectangle _ _ wid ht = rect r- totSLen = foldr (\(_,_,len) -> (+) len) 0 sl- valign = boffs-1 + (fi ht + fi (as + ds)) `div` 2- remWidth = fi wid - fi totSLen- offset = case a of- C -> (remWidth + offs) `div` 2- R -> remWidth- L -> offs- (fc,bc) = case break (==',') c of- (f,',':b) -> (f, b )- (f, _) -> (f, bgColor conf)+ totSLen = foldr (\(_,_,_,len) -> (+) len) 0 sl+ remWidth = fi wid - fi totSLen+ fontst = fontlist !! i+ offset = case a of+ C -> (remWidth + offs) `div` 2+ R -> remWidth+ L -> offs+ (fc,bc) = case break (==',') c of+ (f,',':b) -> (f, b )+ (f, _) -> (f, bgColor conf)+ valign <- verticalOffset ht s fontst conf 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+ (Text t) -> io $ printString d dr fontst gc fc bc offset valign t alph+ (Icon p) -> io $ maybe (return ())+ (drawBitmap d dr gc fc bc offset valign)+ (lookup p (iconS r))+ printStrings dr gc fontlist (offs + l) a xs
xmobar.cabal view
@@ -1,5 +1,5 @@ name: xmobar-version: 0.22.1+version: 0.23 homepage: http://xmobar.org synopsis: A Minimalistic Text Based Status Bar description: Xmobar is a minimalistic text based status bar.@@ -97,7 +97,7 @@ ghc-prof-options: -prof -auto-all ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind- extra-libraries: Xrandr+ extra-libraries: Xrandr Xrender build-depends: base == 4.*,@@ -114,7 +114,7 @@ X11 >= 1.6.1, mtl >= 2.1 && < 2.3, parsec == 3.1.*,- HTTP >= 4000,+ HTTP >= 4000.2.4, stm >= 2.3 && < 2.5 if flag(with_threaded)