diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,27 +0,0 @@ -Copyright (c) Andrea Rossato - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. diff --git a/license b/license new file mode 100644 --- /dev/null +++ b/license @@ -0,0 +1,27 @@ +Copyright (c) Andrea Rossato + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/news.md b/news.md --- a/news.md +++ b/news.md @@ -1,5 +1,53 @@ % xmobar - Release notes +## Version 0.16 (Dec 3, 2012) + +_New features_ + + - New monitor `AutoMPD`, which uses asynchronous events to display + MPD status (thanks to Ben Boeckel). + - New monitor `BufferedPipeReader` displaying data from multiple + pipes (thanks to Jochen Keil). + - New monitor `DynNetwork`, which detects the active interface + automatically, by Reto Hablützel + - New monitor, `Locks`, displaying the status of lock keys, by + Patrick Chilton. + - Extension for DBUS signal handling (Jochen Keil) + - Hide/Reveal: one can send signals to xmobar and make it (un)hide + itself (Jochen again). + - `PipeReader`'s default text is now configurable, by Reto Hablützel. + - Dependencies updated to latest mtl and libmpd (thanks to Sergei + Trofimovich). + - Dependencies on the deprecated dbus-core removed in favour of + dbus 0.10 (thanks to Jochen Keil). + - MPris2 now includes genre and composer among its fields. + +_Bug fixes_ + + - `DiskIO` now can report overall activity in all partitions of a device + which is not mounted itself (e.g., sda when sda1, sda3, etc. are + the mounted partitions). Thanks to John Soros. See [github #73]. + - `DiskU`, the disk usage monitor, works again correctly on Linux, + instead of randomly crashing every now and then, and reporting + wrong used size. + - When using antialiased fonts, we were causing a memory leak in the + X server by repeatedly allocating colors that, apparently, the + server doesn't know how to get rid of (even when told so!). We're + caching them now and X server memory doesn't grow. + - Compilation errors and warnings with GHC 7.6 removed (thanks to + Raghavendra D Prabhu for his reports in [github #71]). + +_Known problems_ + +Some users have reported problems with xmobar compiled with GHC 7.6 in +ArchLinux: see [github #78] and pointers therein. Please, send +reports of any problems or successes in that regard so that we can fix +any remaining issues. Thanks! + +[github #71]: https://github.com/jaor/xmobar/issues/71 +[github #73]: https://github.com/jaor/xmobar/issues/73 +[github #78]: https://github.com/jaor/xmobar/issues/78 + ## Version 0.15 (June 4, 2012) _Incompatible changes_ diff --git a/readme.md b/readme.md --- a/readme.md +++ b/readme.md @@ -11,7 +11,7 @@ features, like dynamic color management, output templates, and extensibility through plugins. -This page documents xmobar 0.15 (see [release notes]). +This page documents xmobar 0.16 (see [release notes]). [This screenshot] shows xmobar running under [sawfish], with antialiased fonts. And [this one] is my desktop with [xmonad] and two @@ -52,26 +52,27 @@ If you don't have `cabal-install` installed, you can get xmobar's source code in a variety of ways: - - From [Hackage]. Just download [xmobar-0.15.tar.gz] from xmobar's + - From [Hackage]. Just download the latest release from xmobar's hackage page. - From [Github]. You can also obtain a tarball in [Github's downloads page]. You'll find there links to each tagged release. - From the bleeding edge repo. If you prefer to live dangerously, just get the latest and greatest (and buggiest, i guess) using git: + git clone git://github.com/jaor/xmobar -[xmobar-0.15.tar.gz]: http://hackage.haskell.org/packages/archive/xmobar/0.15/xmobar-0.15.tar.gz + [Github's downloads page]: https://github.com/jaor/xmobar/downloads -To install simply run (if needed): +If you have cabal installed, you can now use it from within xmobar's +source tree: - tar xvfz xmobar-0.15 - cd xmobar-0.15 + cabal install -fall_extensions -If you have cabal installed, you can now use it from within xmobar's -source tree. Otherwise, run the configure script: +Otherwise, run the configure script: + runhaskell Setup.lhs configure # To enable UTF-8 support run: @@ -100,6 +101,10 @@ automatically downloaded and installed if you're using cabal install. Otherwise, you'll need to install them yourself. +`with_dbus` +: Enables support for DBUS by making xmobar to publish a service on + the session bus. Requires the [dbus] package. + `with_threaded` : Uses GHC's threaded runtime. Use this option if xmobar enters a high-CPU regime right after starting. @@ -121,7 +126,7 @@ `with_mpris` : Enables support for MPRIS v1/v2 protocol. - Requires the [dbus-core] and [text] packages. + Requires the [dbus] and [text] packages. `with_inotify` : Support for inotify in modern linux kernels. This option is needed @@ -221,6 +226,18 @@ : position = Top +`lowerOnStart` +: When True the window is sent the bottom of the window stack initially. + +`hideOnStart` +: When set to True the window is initially not mapped, i.e. hidden. It then + can be toggled manually (for example using the dbus interface) or + automatically (by a plugin) to make it reappear. + +`persistent` +: When True the window status is fixed i.e. hiding or revealing is not + possible. This option can be toggled at runtime. + `border` : TopB, TopBM, BottomB, BottomBM, FullB, FullBM or NoBorder (default). @@ -293,6 +310,103 @@ Mail bug reports and suggestions to +## The DBus Interface + +When compiled with the optional `with_dbus` flag, xmobar can be +controlled over dbus. All signals defined in [src/Signal.hs] as `data +SignalType` can now be sent over dbus to xmobar. Due to current +limitations of the implementation only one process of xmobar can +aquire the dbus. This is handled on a first-come-first-seved basis, +meaning that the first process will get the dbus interface. Other +processes will run without further problems, yet have no dbus +interface. + +[src/Signal.hs]: https://github.com/jaor/xmobar/raw/master/src/Signal.hs + +- Bus Name: `org.Xmobar.Control` +- Object Path: `/org/Xmobar/Control` +- Member Name: Any of SignalType, e.g. `string:Reveal` +- Interface Name: `org.Xmobar.Control` + +An example using the `dbus-send` command line utility: + + dbus-send \ + --session \ + --dest=org.Xmobar.Control \ + --type=method_call \ + --print-reply \ + '/org/Xmobar/Control' \ + org.Xmobar.Control.SendSignal \ + "string:Toggle" + +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" + +### Example for using the DBus IPC interface with XMonad + +Bind the key which should {,un}map xmobar to a dummy value. This is necessary +for {,un}grabKey in xmonad. + + ((0, xK_Alt_L ), return ()) + +Also, install `avoidStruts` layout modifier from `XMonad.Hooks.ManageDocks` + +Finally, install these two event hooks (`handleEventHook` in `XConfig`) +`myDocksEventHook` is a replacement for `docksEventHook` which reacts on unmap +events as well (which `docksEventHook` doesn't). + + import qualified XMonad.Util.ExtensibleState as XS + + data DockToggleTime = DTT { lastTime :: Time } deriving (Eq, Show, Typeable) + + instance ExtensionClass DockToggleTime where + initialValue = DTT 0 + + toggleDocksHook :: Int -> KeySym -> Event -> X All + toggleDocksHook to ks ( KeyEvent { ev_event_display = d + , ev_event_type = et + , ev_keycode = ekc + , ev_time = etime + } ) = + io (keysymToKeycode d ks) >>= toggleDocks >> return (All True) + where + toggleDocks kc + | ekc == kc && et == keyPress = do + safeSendSignal ["Reveal 0", "TogglePersistent"] + XS.put ( DTT etime ) + | ekc == kc && et == keyRelease = do + gap <- XS.gets ( (-) etime . lastTime ) + safeSendSignal [ "TogglePersistent" + , "Hide " ++ show (if gap < 400 then to else 0) + ] + | otherwise = return () + + safeSendSignal s = catchX (io $ sendSignal s) (return ()) + sendSignal = withSession . callSignal + withSession mc = connectSession >>= \c -> callNoReply c mc >> disconnect c + callSignal :: [String] -> MethodCall + callSignal s = ( methodCall + ( objectPath_ "/org/Xmobar/Control" ) + ( interfaceName_ "org.Xmobar.Control" ) + ( memberName_ "SendSignal" ) + ) { methodCallDestination = Just $ busName_ "org.Xmobar.Control" + , methodCallBody = map toVariant s + } + + toggleDocksHook _ _ _ = return (All True) + + myDocksEventHook :: Event -> X All + myDocksEventHook e = do + when (et == mapNotify || et == unmapNotify) $ + whenX ((not `fmap` (isClient w)) <&&> runQuery checkDock w) refresh + return (All True) + where w = ev_window e + et = ev_event_type e + + ## The Output Template The output template must contain at least one command. xmobar will @@ -338,16 +452,138 @@ ## System Monitor Plugins -This is the description of the system monitor plugins that are -installed by default. +This is the description of the system monitor plugins available in +xmobar. Some of them are only installed when an optional build option +is set: we mention that fact, when needed, in their description. Each monitor has an `alias` to be used in the output template. -Monitors have default aliases. +Monitors have default aliases. The sections below describe every +monitor in turn, but before we provide a list of the configuration +options (or *monitor arguments*) they all share. + +### Default Monitor Arguments + +Monitors accept a common set of arguments, described in the first +subsection below. In additon, some monitors accept additional options +that are specific to them. When specifying the list of arguments in +your configuration, the common options come first, followed by "--", +followed by any monitor-specific options. + +These are the options available for all monitors below: + +- `-t` _string_ Output template + - Template for the monitor output. Field names must be enclosed + between pointy brackets (``) and will be substituted by the + computed values. You can also specify the foreground (and + optionally, background) color for a region by bracketing it + between `` (or ``) and + ``. The rest of the template is output verbatim. + - Long option: `--template` + - Default value: per monitor (see above). +- `-H` _number_ The high threshold. + - Numerical values higher than _number_ will be displayed with the + color specified by `-h` (see below). + - Long option: `--High` + - Default value: 66 +- `-L` _number_ The low threshold. + - Numerical values higher than _number_ and lower than the high + threshold will be displayed with the color specified by `-n` + (see below). Values lower than _number_ will use the `-l` color. + - Long option: `--Low` + - Default value: 33 +- `-h` _color_ High threshold color. + - Color for displaying values above the high threshold. _color_ can + be either a name (e.g. "blue") or an hexadecimal RGB (e.g. + "#FF0000"). + - Long option: `--high` + - Default: none (use the default foreground). +- `-n` _color_ Color for 'normal' values + - Color used for values greater than the low threshold but lower + than the high one. + - Long option: `--normal` + - Default: none (use the default foreground). +- `-l` _color_ The low threshold color + - Color for displaying values below the low threshold. + - Long option: `--low` + - Default: none (use the default foreground). +- `-S` _boolean_ Display optional suffixes + - When set to a true designator ("True", "Yes" or "On"), optional + value suffixes such as the '%' symbol or optional units will be + displayed. + - Long option: `--suffix` + - Default: False. +- `-p` _number_ Percentages padding + - Width, in number of digits, for quantities representing + percentages. For instance `-p 3` means that all percentages + in the monitor will be represented using 3 digits. + - Long option: `--ppad` + - Default value: 0 (don't pad) +- `-d` _number_ Decimal digits + - Number of digits after the decimal period to use in float values. + - Long option: `--ddigits` + - Default value: 0 (display only integer part) +- `-m` _number_ Minimum field width + - Minimum width, in number of characters, of the fields in the + monitor template. Values whose printed representation is shorter + than this value will be padded using the padding characters + given by the `-c` option with the alignment specified by `-a` + (see below). + - Long option: `--minwidth` + - Default: 0 +- `-M` _number_ Maximum field width + - Maximum width, in number of characters, of the fields in the + monitor template. Values whose printed representation is longer + than this value will be truncated. + - Long option: `--maxwidth` + - Default: 0 (no maximum width) +- `-w` _number_ Fixed field width + - All fields will be set to this width, padding or truncating as + needed. + - Long option: `--width` + - Default: 0 (variable width) +- `-c` _string_ + - Characters used for padding. The characters of _string_ are used + cyclically. E.g., with `-P +- -w 6`, a field with value "foo" + will be represented as "+-+foo". + - Long option: `--padchars` + - Default value: " " +- `-a` r|l Field alignment + - Whether to use right (r) or left (l) alignment of field values + when padding. + - Long option: `--align` + - Default value: r (padding to the left) +- `-b` _string_ Bar background + - Characters used, cyclically, to draw the background of bars. + For instance, if you set this option to "·.", an empty bar will + look like this: `·.·.·.·.·.` + - Long option: `--bback` + - Default value: ":" +- `-f` _string_ Bar foreground + - Characters used, cyclically, to draw the foreground of bars. + - Long option: `--bfore` + - Default value: "#" +- `-W` _number_ Bar width + - Total number of characters used to draw bars. + - Long option: `--bwidth` + - Default value: 10 + +Commands' arguments must be set as a list. E.g.: + + Run Weather "EGPF" ["-t", ": C"] 36000 + +In this case xmobar will run the weather monitor, getting information +for the weather station ID EGPF (Glasgow Airport, as a homage to GHC) +every hour (36000 tenth of seconds), with a template that will output +something like: + + Glasgow Airport: 16.0C + + ### `Uptime Args RefreshRate` - Aliases to `uptime` -- Args: default monitor arguments (see below). The low and high +- Args: default monitor arguments. The low and high thresholds refer to the number of days. - Variables that can be used with the `-t`/`--template` argument: `days`, `hours`, `minutes`, `seconds`. The total uptime is the @@ -358,7 +594,7 @@ ### `Weather StationID Args RefreshRate` - Aliases to the Station ID: so `Weather "LIPB" []` can be used in template as `%LIPB%` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `station`, `stationState`, `year`, `month`, `day`, `hour`, `wind`, `visibility`, `skyCondition`, `tempC`, `tempF`, @@ -371,7 +607,7 @@ - Aliases to the interface name: so `Network "eth0" []` can be used as `%eth0%` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `dev`, `rx`, `tx`, `rxbar`, `txbar`. Reception and transmission rates (`rx` and `tx`) are displayed in Kbytes per second, and you @@ -379,11 +615,23 @@ string "Kb/s"). - Default template: `: KB|KB` +### `DynNetwork Args RefreshRate` + +- Active interface is detected automatically +- Aliases to "dynnetwork" +- Args: default monitor arguments +- Variables that can be used with the `-t`/`--template` argument: + `dev`, `rx`, `tx`, `rxbar`, `txbar`. Reception and transmission + rates (`rx` and `tx`) are displayed in Kbytes per second, and you + can set the `-S` to "True" to make them displayed with units (the + string "Kb/s"). +- Default template: `: KB|KB` + ### `Wireless Interface Args RefreshRate` - Aliases to the interface name with the suffix "wi": thus, `Wirelss "wlan0" []` can be used as `%wlan0wi%` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `essid`, `quality`, `qualitybar` - Default template: ` ` @@ -394,7 +642,7 @@ ### `Memory Args RefreshRate` - Aliases to `memory` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `total`, `free`, `buffer`, `cache`, `rest`, `used`, `usedratio`, `usedbar`, `freebar` @@ -403,7 +651,7 @@ ### `Swap Args RefreshRate` - Aliases to `swap` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `total`, `used`, `free`, `usedratio` - Default template: `Swap: %` @@ -411,7 +659,7 @@ ### `Cpu Args RefreshRate` - Aliases to `cpu` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `total`, `bar`, `user`, `nice`, `system`, `idle`, `iowait` - Default template: `Cpu: %` @@ -419,7 +667,7 @@ ### `MultiCpu Args RefreshRate` - Aliases to `multicpu` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `autototal`, `autobar`, `autouser`, `autonice`, `autosystem`, `autoidle`, `total`, `bar`, `user`, `nice`, @@ -440,17 +688,19 @@ look for the ACPI files of each battery. Example: `["BAT0","BAT1","BAT2"]`. Only the first 3 directories will be searched. -- Args: default monitor arguments (see below), plus the following specif ones: - - `-O`: string for AC "on" status (default: "On") - - `-o`: string for AC "off" status (default: "Off") - - `-L`: low power (`watts`) threshold (default: -12) - - `-H`: high power threshold (default: -10) - - `-l`: color to display power lower than the `-L` threshold - - `-m`: color to display power lower than the `-H` threshold - - `-h`: color to display power highter than the `-H` threshold - - `-p`: color to display positive power (battery charging) - - `-f`: file in `/sys/class/power_supply` with AC info (default: - "AC/online") +- Args: default monitor arguments, plus the following specific ones + (these options, being specific to the monitor, are to be specified + after a `--` in the argument list): + - `-O`: string for AC "on" status (default: "On") + - `-o`: string for AC "off" status (default: "Off") + - `-L`: low power (`watts`) threshold (default: -12) + - `-H`: high power threshold (default: -10) + - `-l`: color to display power lower than the `-L` threshold + - `-m`: color to display power lower than the `-H` threshold + - `-h`: color to display power highter than the `-H` threshold + - `-p`: color to display positive power (battery charging) + - `-f`: file in `/sys/class/power_supply` with AC info (default: + "AC/online") - Variables that can be used with the `-t`/`--template` argument: `left`, `leftbar`, `timeleft`, `watts`, `acstatus` @@ -465,14 +715,17 @@ "-L", "-15", "-H", "-5", "-l", "red", "-m", "blue", "-h", "green"] 600 + In the above example, the thresholds before the "--" separator - refer to the `` field, while those after the separator affect - how `` is displayed. + affect only the `` and `` fields, while those after + the separator affect how `` is displayed. For this monitor, + neither the generic nor the specific options have any effect on + ``. ### `TopProc Args RefreshRate` - Aliases to `top` -- Args: default monitor arguments (see below). The low and high +- Args: default monitor arguments. The low and high thresholds (`-L` and `-H`) denote, for memory entries, the percent of the process memory over the total amount of memory currently in use and, for cpu entries, the activity percentage (i.e., the value @@ -489,7 +742,7 @@ ### `TopMem Args RefreshRate` - Aliases to `topmem` -- Args: default monitor arguments (see below). The low and high +- Args: default monitor arguments. The low and high thresholds (`-L` and `-H`) denote the percent of the process memory over the total amount of memory currently in use. - Variables that can be used with the `-t`/`--template` argument: @@ -506,7 +759,7 @@ where the template can contain , , , or , or for total, free, used, free percentage and used percentage of the given file system capacity. -- Args: default monitor arguments (see below). `-t`/`--template` is ignored. +- Args: default monitor arguments. `-t`/`--template` is ignored. - Default template: none (you must specify a template for each file system). - Example: @@ -520,17 +773,17 @@ - Disks: list of pairs of the form (device or mount point, template), where the template can contain , , for total, read and write speed, respectively. -- Args: default monitor arguments (see below). `-t`/`--template` is ignored. +- Args: default monitor arguments. `-t`/`--template` is ignored. - Default template: none (you must specify a template for each file system). - Example: - Disks [("/", " "), ("sdb1", "")] [] 10 + DiskIO [("/", " "), ("sdb1", "")] [] 10 ### `ThermalZone Number Args RefreshRate` - Aliases to "thermaln": so `ThermalZone 0 []` can be used in template as `%thermal0%` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `temp` - Default template: `C` @@ -548,7 +801,7 @@ - Aliases to the Zone: so `Thermal "THRM" []` can be used in template as `%THRM%` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `temp` - Default template: `Thm: C` @@ -561,7 +814,7 @@ ### `CpuFreq Args RefreshRate` - Aliases to `cpufreq` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `cpu0`, `cpu1`, .., `cpuN` - Default template: `Freq: GHz` @@ -574,7 +827,7 @@ ### `CoreTemp Args RefreshRate` - Aliases to `coretemp` -- Args: default monitor arguments (see below) +- Args: default monitor arguments - Variables that can be used with the `-t`/`--template` argument: `core0`, `core1`, .., `coreN` - Default template: `Temp: C` @@ -589,7 +842,7 @@ - Aliases to the mixer name and element name separated by a colon. Thus, `Volume "default" "Master" [] 10` can be used as `%default:Master%`. -- Args: default monitor arguments (see below). Also accepts: +- Args: default monitor arguments. Also accepts: - `-O` _string_ On string - The string used in place of `` when the mixer element is on. Defaults to "[on]". @@ -622,7 +875,7 @@ - This monitor will only be compiled if you ask for it using the `with_mpd` flag. It needs [libmpd] 5.0 or later (available on Hackage). - Aliases to `mpd` -- Args: default monitor arguments (see below). In addition you can provide +- Args: default monitor arguments. In addition you can provide `-P`, `-S` and `-Z`, with an string argument, to represent the playing, stopped and paused states in the `statei` template field. The environment variables `MPD_HOST` and `MPD_PORT` are used to configure the @@ -644,7 +897,7 @@ ### `Mpris1 PlayerName Args RefreshRate` - Aliases to `mpris1` -- Requires [dbus-core] and [text] packages. +- Requires [dbus] and [text] packages. To activate, pass `--flags="with_mpris"` during compilation. - PlayerName: player supporting MPRIS v1 protocol, in lowercase. - Args: default monitor arguments. @@ -653,14 +906,23 @@ - Default template: ` - ` - Example: - Run Mpris1 "clementine" ["-t", - "<artist> - [<tracknumber>] <title>"] 10 + Run Mpris1 "clementine" ["-t", "<artist> - [<tracknumber>] <title>"] 10 ### `Mpris2 PlayerName Args RefreshRate` -- Just like Mpris1. - Supposed to be used with mediaplayers which support MPRIS v2. +- Aliases to `mpris1` +- Requires [dbus] and [text] packages. + To activate, pass `--flags="with_mpris"` during compilation. +- PlayerName: player supporting MPRIS v2 protocol, in lowercase. +- Args: default monitor arguments. +- Variables that can be used with the `-t`/`--template` argument: + `album`, `artist`, `arturl`, `length`, `title`, + `tracknumber`, `composer`, `genre` +- Default template: `<artist> - <title>` +- Example: + Run Mpris2 "clementine" ["-t", "<artist> - [<composer>] <title>"] 10 + ### `Mail Args Alias` - Args: list of maildirs in form @@ -718,7 +980,7 @@ ### `Brightness Args RefreshRate` - Aliases to `bright` -- Args: default monitor arguments (see below), plus the following specif ones: +- Args: default monitor arguments, plus the following specif ones: - `-D`: directory in `/sys/class/backlight/` with files in it (default: "acpi_video0") - `-C`: file with the current brightness (default: @@ -744,118 +1006,13 @@ Run Kbd [("us(dvorak)", "DV"), ("us", "US")] - -## Monitor Plugins Commands Arguments - -These are the arguments that can be used for internal commands in the -`commands` configuration option: - -- `-t` _string_ Output template - - Template for the monitor output. Field names must be enclosed - between pointy brackets (`<foo>`) and will be substituted by the - computed values. You can also specify the foreground (and - optionally, background) color for a region by bracketing it - between `<fc=fgcolor>` (or `<fc=fgcolor,bgcolor>`) and - `</fc>`. The rest of the template is output verbatim. - - Long option: `--template` - - Default value: per monitor (see above). -- `-H` _number_ The high threshold. - - Numerical values higher than _number_ will be displayed with the - color specified by `-h` (see below). - - Long option: `--High` - - Default value: 66 -- `-L` _number_ The low threshold. - - Numerical values higher than _number_ and lower than the high - threshold will be displayed with the color specified by `-m` - (see below). Values lower than _number_ will use the `-l` color. - - Long option: `--Low` - Default value: 80 - - Default value: 33 -- `-h` _color_ High threshold color. - - Color for displaying values above the high threshold. _color_ can - be either a name (e.g. "blue") or an hexadecimal RGB (e.g. - "#FF0000"). - - Long option: `--high` - - Default: none (use the default foreground). -- `-n` _color_ Color for 'normal' values - - Color used for values greater than the low threshold but lower - than the high one. - - Long option: `--normal` - - Default: none (use the default foreground). -- `-l` _color_ The low threshold color - - Color for displaying values below the low threshold. - - Long option: `--low` - - Default: none (use the default foreground). -- `-S` _boolean_ Display optional suffixes - - When set to a true designator ("True", "Yes" or "On"), optional - value suffixes such as the '%' symbol or optional units will be - displayed. - - Long option: `--suffix` - - Default: False. -- `-p` _number_ Percentages padding - - Width, in number of digits, for quantities representing - percentages. For instance `-p 3` means that all percentages - in the monitor will be represented using 3 digits. - - Long option: `--ppad` - - Default value: 0 (don't pad) -- `-d` _number_ Decimal digits - - Number of digits after the decimal period to use in float values. - - Long option: `--ddigits` - - Default value: 0 (display only integer part) -- `-m` _number_ Minimum field width - - Minimum width, in number of characters, of the fields in the - monitor template. Values whose printed representation is shorter - than this value will be padded using the padding characters - given by the `-c` option with the alignment specified by `-a` - (see below). - - Long option: `--minwidth` - - Default: 0 -- `-M` _number_ Maximum field width - - Maximum width, in number of characters, of the fields in the - monitor template. Values whose printed representation is longer - than this value will be truncated. - - Long option: `--maxwidth` - - Default: 0 (no maximum width) -- `-w` _number_ Fixed field width - - All fields will be set to this width, padding or truncating as - needed. - - Long option: `--width` - - Default: 0 (variable width) -- `-c` _string_ - - Characters used for padding. The characters of _string_ are used - cyclically. E.g., with `-P +- -w 6`, a field with value "foo" - will be represented as "+-+foo". - - Long option: `--padchars` - - Default value: " " -- `-a` r|l Field alignment - - Whether to use right (r) or left (l) alignment of field values - when padding. - - Long option: `--align` - - Default value: r (padding to the left) -- `-b` _string_ Bar background - - Characters used, cyclically, to draw the background of bars. - For instance, if you set this option to "·.", an empty bar will - look like this: `·.·.·.·.·.` - - Long option: `--bback` - - Default value: ":" -- `-f` _string_ Bar foreground - - Characters used, cyclically, to draw the foreground of bars. - - Long option: `--bfore` - - Default value: "#" -- `-W` _number_ Bar width - - Total number of characters used to draw bars. - - Long option: `--bwidth` - - Default value: 10 - -Commands' arguments must be set as a list. E.g.: - - Run Weather "EGPF" ["-t", "<station>: <tempC>C"] 36000 +### `Locks` -In this case xmobar will run the weather monitor, getting information -for the weather station ID EGPF (Glasgow Airport, as a homage to GHC) -every hour (36000 tenth of seconds), with a template that will output -something like: +- Displays the status of Caps Lock, Num Lock and Scroll Lock. +- Aliases to `locks` +- Example: - Glasgow Airport: 16.0C + Run Locks ## Executing External Commands @@ -915,10 +1072,40 @@ - Runs the given program, and displays its standard output. -`PipeReader "/path/to/pipe" Alias` +`PipeReader "default text:/path/to/pipe" Alias` - Reads its displayed output from the given pipe. +- Prefix an optional default text separated by a colon +`BufferedPipeReader Alias [ (Timeout, Bool, "/path/to/pipe1") + , (Timeout, Bool, "/path/to/pipe2") + , .. + ]` + +- Display data from multiple pipes. +- Timeout (in tenth of seconds) is the value after which the previous content is + restored i.e. if there was already something from a previous pipe it will be + put on display again, overwriting the current status. +- A pipe with Timout of 0 will be displayed permanently, just like `PipeReader` +- The boolean option indicates whether new data for this pipe should make xmobar + appear (unhide, reveal). In this case, the Timeout additionally specifies when + the window should be hidden again. The output is restored in any case. +- Use it for OSD like status bars e.g. for setting the volume or brightness: + + Run BufferedPipeReader "bpr" + [ ( 0, False, "/tmp/xmobar_window" ) + , ( 15, True, "/tmp/xmobar_status" ) + ] + + Have your window manager send window titles to `"/tmp/xmobar_window"`. They will + always be shown and not reveal your xmobar. + Sending some status information to `"/tmp/xmobar_status"` will reveal xmonad + for 1.5 seconds and temporarily overwrite the window titles. +- Take a look at [samples/status.sh] + +[samples/status.sh]: http://github.com/jaor/xmobar/raw/master/samples/status.sh + + `XMonadLog` - Aliases to XMonadLog @@ -1063,12 +1250,12 @@ the greater Haskell community. In particular, xmobar [incorporates patches] by Ben Boeckel, Roman -Cheplyaka, John Goerzen, Juraj Hercek, Tomas Janousek, Spencer -Janssen, Lennart Kolmodin, Krzysztof Kosciuszkiewicz, Dmitry -Kurochkin, Svein Ove, Martin Perner, Jens Petersen, Petr Rockai, -Andrew Sackville-West, Alexander Solovyov, Artem Tarasov, Sergei -Trofimovich, Thomas Tuegel, Jan Vornberger, Daniel Wagner and Norbert -Zeh. +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. [incorporates patches]: http://www.ohloh.net/p/xmobar/contributors @@ -1127,7 +1314,7 @@ [iwlib]: http://www.hpl.hp.com/personal/Jean_Tourrilhes/Linux/Tools.html [hinotify]: http://hackage.haskell.org/package/hinotify/ [libmpd]: http://hackage.haskell.org/package/libmpd/ -[dbus-core]: http://hackage.haskell.org/package/dbus-core +[dbus]: http://hackage.haskell.org/package/dbus [text]: http://hackage.haskell.org/package/text [sawfish]: http://sawfish.wikia.com/ [utf8-string]: http://hackage.haskell.org/package/utf8-string/ diff --git a/samples/xmobar.config b/samples/xmobar.config --- a/samples/xmobar.config +++ b/samples/xmobar.config @@ -5,6 +5,7 @@ , fgColor = "grey" , position = Top , lowerOnStart = True + , persistent = False , commands = [ Run Weather "EGPF" ["-t","<station>: <tempC>C","-L","18","-H","25","--normal","green","--high","red","--low","lightblue"] 36000 , Run Network "eth0" ["-L","0","-H","32","--normal","green","--high","red"] 10 , Run Network "eth1" ["-L","0","-H","32","--normal","green","--high","red"] 10 diff --git a/src/ColorCache.hs b/src/ColorCache.hs new file mode 100644 --- /dev/null +++ b/src/ColorCache.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +------------------------------------------------------------------------------ +-- | +-- Module: ColorCache +-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Mon Sep 10, 2012 00:27 +-- +-- +-- Caching X colors +-- +------------------------------------------------------------------------------ + +#if defined XFT + +module ColorCache(withColors, withDrawingColors) where + +import MinXft + +#else +module ColorCache(withColors) where + +#endif + +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Exception (SomeException, handle) +import Graphics.X11.Xlib + +data DynPixel = DynPixel Bool Pixel + +initColor :: Display -> String -> IO DynPixel +initColor dpy c = handle black $ (initColor' dpy c) + where + black :: SomeException -> IO DynPixel + black = (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy)) + +type ColorCache = [(String, Color)] +{-# NOINLINE colorCache #-} +colorCache :: IORef ColorCache +colorCache = unsafePerformIO $ newIORef [] + +getCachedColor :: String -> IO (Maybe Color) +getCachedColor color_name = lookup color_name `fmap` readIORef colorCache + +putCachedColor :: String -> Color -> IO () +putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c + +initColor' :: Display -> String -> IO DynPixel +initColor' dpy c = do + let colormap = defaultColormap dpy (defaultScreen dpy) + cached_color <- getCachedColor c + c' <- case cached_color of + Just col -> return col + _ -> do (c'', _) <- allocNamedColor dpy colormap c + putCachedColor c c'' + return c'' + return $ DynPixel True (color_pixel c') + +withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a +withColors d cs f = do + ps <- mapM (liftIO . initColor d) cs + f $ map (\(DynPixel _ pixel) -> pixel) ps + +#ifdef XFT + +type AXftColorCache = [(String, AXftColor)] +{-# NOINLINE xftColorCache #-} +xftColorCache :: IORef AXftColorCache +xftColorCache = unsafePerformIO $ newIORef [] + +getXftCachedColor :: String -> IO (Maybe AXftColor) +getXftCachedColor name = lookup name `fmap` readIORef xftColorCache + +putXftCachedColor :: String -> AXftColor -> IO () +putXftCachedColor name cptr = + modifyIORef xftColorCache $ \c -> (name, cptr) : c + +initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor +initAXftColor' d v cm c = do + cc <- getXftCachedColor c + c' <- case cc of + Just col -> return col + _ -> do c'' <- mallocAXftColor d v cm c + putXftCachedColor c c'' + return c'' + return c' + +initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor +initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c) + where + black :: SomeException -> IO AXftColor + black = (const $ initAXftColor' d v cm "black") + +withDrawingColors :: -- MonadIO m => + Display -> Drawable -> String -> String + -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO () +withDrawingColors dpy drw fc bc f = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + fc' <- initAXftColor dpy visual colormap fc + bc' <- initAXftColor dpy visual colormap bc + withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc' +#endif diff --git a/src/Commands.hs b/src/Commands.hs --- a/src/Commands.hs +++ b/src/Commands.hs @@ -23,25 +23,29 @@ , tenthSeconds ) where -import Prelude hiding (catch) +import Prelude import Control.Concurrent -import Control.Exception +import Control.Exception (handle, SomeException(..)) import Data.Char import System.Process import System.Exit import System.IO (hClose) + +import Signal import XUtil class Show e => Exec e where - alias :: e -> String - alias e = takeWhile (not . isSpace) $ show e - rate :: e -> Int - rate _ = 10 - run :: e -> IO String - run _ = return "" - start :: e -> (String -> IO ()) -> IO () - start e cb = go + alias :: e -> String + alias e = takeWhile (not . isSpace) $ show e + rate :: e -> Int + rate _ = 10 + run :: e -> IO String + run _ = return "" + start :: e -> (String -> IO ()) -> IO () + start e cb = go where go = run e >>= cb >> tenthSeconds (rate e) >> go + trigger :: e -> (Maybe SignalType -> IO ()) -> IO () + trigger _ sh = sh Nothing data Command = Com Program Args Alias Rate deriving (Show,Read,Eq) @@ -61,12 +65,12 @@ (i,o,e,p) <- runInteractiveCommand (unwords (prog:args)) exit <- waitForProcess p let closeHandles = hClose o >> hClose i >> hClose e + getL = handle (\(SomeException _) -> return "") + (hGetLineSafe o) case exit of - ExitSuccess -> do - str <- catch (hGetLineSafe o) - (\(SomeException _) -> return "") - closeHandles - cb str + ExitSuccess -> do str <- getL + closeHandles + cb str _ -> do closeHandles cb $ "Could not execute command " ++ prog diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -28,11 +28,13 @@ import Plugins.Monitors import Plugins.Date import Plugins.PipeReader +import Plugins.BufferedPipeReader import Plugins.CommandReader import Plugins.StdinReader import Plugins.XMonadLog import Plugins.EWMH import Plugins.Kbd +import Plugins.Locks #ifdef INOTIFY import Plugins.Mail @@ -54,8 +56,12 @@ , 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 @@ -94,7 +100,9 @@ , position = Top , border = NoBorder , borderColor = "#BFBFBF" + , hideOnStart = False , lowerOnStart = True + , persistent = False , commands = [ Run $ Date "%a %b %_d %Y * %H:%M:%S" "theDate" 10 , Run StdinReader] , sepChar = "%" @@ -113,7 +121,7 @@ -- the 'Runnable.Runnable' Read instance. To install a plugin just add -- the plugin's type to the list of types (separated by ':*:') appearing in -- this function's type signature. -runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: CommandReader :*: StdinReader :*: XMonadLog :*: EWMH :*: Kbd :*: +runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*: BufferedPipeReader :*: CommandReader :*: StdinReader :*: XMonadLog :*: EWMH :*: Kbd :*: Locks :*: #ifdef INOTIFY Mail :*: MBox :*: #endif diff --git a/src/IPC/DBus.hs b/src/IPC/DBus.hs new file mode 100644 --- /dev/null +++ b/src/IPC/DBus.hs @@ -0,0 +1,63 @@ +----------------------------------------------------------------------------- +-- | +-- Module : DBus +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil <jochen dot keil at gmail dot com> +-- Stability : unstable +-- Portability : unportable +-- +-- DBus IPC module for Xmobar +-- +----------------------------------------------------------------------------- + +module IPC.DBus ( runIPC ) where + +import Prelude hiding (catch) + +import DBus +import DBus.Client +import Control.Monad (when) +import Control.Concurrent.STM +import Control.Exception (catch) +import System.IO (stderr, hPutStrLn) + +import Signal + +busName :: BusName +busName = busName_ "org.Xmobar.Control" + +objectPath :: ObjectPath +objectPath = objectPath_ "/org/Xmobar/Control" + +interfaceName :: InterfaceName +interfaceName = interfaceName_ "org.Xmobar.Control" + +runIPC :: TMVar SignalType -> IO () +runIPC mvst = catch exportConnection printException + where + printException :: ClientError -> IO () + printException = hPutStrLn stderr . clientErrorMessage + exportConnection = do + client <- connectSession + requestName client busName [ nameDoNotQueue ] + export client objectPath [ sendSignalMethod mvst ] + +sendSignalMethod :: TMVar SignalType -> Method +sendSignalMethod mvst = method interfaceName sendSignalName + (signature_ [variantType $ toVariant $ (undefined :: SignalType)]) + (signature_ []) + sendSignalMethodCall + where + sendSignalName :: MemberName + sendSignalName = memberName_ "SendSignal" + + sendSignalMethodCall :: MethodCall -> IO Reply + sendSignalMethodCall mc = do + when ( methodCallMember mc == sendSignalName ) + $ mapM_ (sendSignal . fromVariant) (methodCallBody mc) + return ( replyReturn [] ) + + sendSignal :: Maybe SignalType -> IO () + sendSignal = maybe (return ()) (atomically . putTMVar mvst) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -36,6 +36,8 @@ import System.Posix.Files import Control.Monad (unless) +import Signal (setupSignalHandler) + -- $main -- | The main entry point @@ -55,9 +57,10 @@ conf <- doOpts c o fs <- initFont d (font conf) cls <- mapM (parseTemplate conf) (splitTemplate conf) - vars <- mapM (mapM startCommand) cls + sig <- setupSignalHandler + vars <- mapM (mapM $ startCommand sig) cls (r,w) <- createWin d fs conf - startLoop (XConf d r w fs conf) vars + startLoop (XConf d r w fs conf) sig vars -- | Splits the template in its parts splitTemplate :: Config -> [String] diff --git a/src/MinXft.hsc b/src/MinXft.hsc new file mode 100644 --- /dev/null +++ b/src/MinXft.hsc @@ -0,0 +1,139 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +------------------------------------------------------------------------------ +-- | +-- Module: MinXft +-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz +-- (c) Clemens Fruhwirth <clemens@endorphin.org> 2007 +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Mon Sep 10, 2012 18:12 +-- +-- +-- Pared down Xft library, based on Graphics.X11.Xft and providing +-- explicit management of XftColors, so that they can be cached. +-- +-- Most of the code is lifted from Clemens's. +-- +------------------------------------------------------------------------------ + +module MinXft ( AXftColor + , AXftDraw (..) + , AXftFont + , mallocAXftColor + , freeAXftColor + , withAXftDraw + , drawXftString + , drawXftRect + , openAXftFont + , closeAXftFont + , xftTxtExtents + , xft_ascent + , xft_descent + , xft_height + ) + +where + +import Graphics.X11 +import Graphics.X11.Xlib.Types +import Graphics.X11.Xrender + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Codec.Binary.UTF8.String as UTF8 + +#include <X11/Xft/Xft.h> + +-- Color Handling + +newtype AXftColor = AXftColor (Ptr AXftColor) + +foreign import ccall "XftColorAllocName" + cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (#type Bool) + +-- this is the missing bit in X11.Xft, not implementable from the +-- outside because XftColor does not export a constructor. +mallocAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor +mallocAXftColor d v cm n = do + color <- mallocBytes (#size XftColor) + withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color) + return (AXftColor color) + +foreign import ccall "XftColorFree" + freeAXftColor :: Display -> Visual -> Colormap -> AXftColor -> IO () + +-- Font handling + +newtype AXftFont = AXftFont (Ptr AXftFont) + +xft_ascent :: AXftFont -> IO Int +xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent} + +xft_descent :: AXftFont -> IO Int +xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent} + +xft_height :: AXftFont -> IO Int +xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height} + +foreign import ccall "XftTextExtentsUtf8" + cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO () + +xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo +xftTxtExtents d f string = + withArrayLen (map fi (UTF8.encode string)) $ + \len str_ptr -> alloca $ + \cglyph -> do + cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph + peek cglyph + +foreign import ccall "XftFontOpenName" + c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont + +openAXftFont :: Display -> Screen -> String -> IO AXftFont +openAXftFont dpy screen name = + withCAString name $ + \cname -> c_xftFontOpen dpy (fi (screenNumberOfScreen screen)) cname + +foreign import ccall "XftFontClose" + closeAXftFont :: Display -> AXftFont -> IO () + +-- Drawing + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +newtype AXftDraw = AXftDraw (Ptr AXftDraw) + +foreign import ccall "XftDrawCreate" + c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw + +foreign import ccall "XftDrawDestroy" + c_xftDrawDestroy :: AXftDraw -> IO () + +withAXftDraw :: Display -> Drawable -> Visual -> Colormap -> (AXftDraw -> IO a) -> IO a +withAXftDraw d p v c act = do + draw <- c_xftDrawCreate d p v c + a <- act draw + c_xftDrawDestroy draw + return a + +foreign import ccall "XftDrawStringUtf8" + cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO () + +drawXftString :: (Integral a1, Integral a) => + AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO () +drawXftString d c f x y string = + withArrayLen (map fi (UTF8.encode string)) + (\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len)) + +foreign import ccall "XftDrawRect" + cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO () + +drawXftRect :: (Integral a3, Integral a2, Integral a1, Integral a) => + 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) diff --git a/src/Parsers.hs b/src/Parsers.hs --- a/src/Parsers.hs +++ b/src/Parsers.hs @@ -131,13 +131,16 @@ <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition <|?> pBorder <|?> pBdColor - <|?> pLowerOnStart <|?> pCommands + <|?> pHideOnStart <|?> pLowerOnStart + <|?> pPersistent <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep" , "border", "borderColor" ,"template", "position" - , "lowerOnStart", "commands"] + , "hideOnStart", "lowerOnStart", "persistent", "commands" + ] + pFont = strField font "font" pBgColor = strField bgColor "bgColor" pFgColor = strField fgColor "fgColor" @@ -147,7 +150,9 @@ 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 diff --git a/src/Plugins/BufferedPipeReader.hs b/src/Plugins/BufferedPipeReader.hs new file mode 100644 --- /dev/null +++ b/src/Plugins/BufferedPipeReader.hs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.BufferedPipeReader +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil <jochen dot keil at gmail dot com> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading (temporarily) from named pipes with reset +-- +----------------------------------------------------------------------------- + +module Plugins.BufferedPipeReader where + +import Control.Monad(forM_, when) +import Control.Concurrent +import Control.Concurrent.STM +import System.IO +import System.IO.Unsafe(unsafePerformIO) + +import Plugins +import Signal + +data BufferedPipeReader = BufferedPipeReader String [(Int, Bool, String)] + deriving (Read, Show) + +signal :: MVar SignalType +signal = unsafePerformIO newEmptyMVar + +instance Exec BufferedPipeReader where + alias ( BufferedPipeReader a _ ) = a + + trigger br@( BufferedPipeReader _ _ ) sh = + takeMVar signal >>= sh . Just >> trigger br sh + + start ( BufferedPipeReader _ ps ) cb = do + + (chan, str, rst) <- initV + forM_ ps $ \p -> forkIO $ reader p chan + writer chan str rst + + where + initV :: IO ( TChan (Int, Bool, String), TVar (Maybe String), TVar Bool ) + initV = atomically $ do + tc <- newTChan + ts <- newTVar Nothing + tb <- newTVar False + return (tc, ts, tb) + + reader :: (Int, Bool, FilePath) -> TChan (Int, Bool, String) -> IO () + reader p@(to, tg, fp) tc = do + openFile fp ReadWriteMode >>= hGetLineSafe >>= \dt -> + atomically $ writeTChan tc (to, tg, dt) + reader p tc + + writer :: TChan (Int, Bool, String) + -> TVar (Maybe String) -> TVar Bool -> IO () + writer tc ts otb = do + (to, tg, dt, ntb) <- update + cb dt + when tg $ putMVar signal $ Reveal 0 + when (to /= 0) $ sfork $ reset to tg ts ntb + writer tc ts ntb + + where + sfork :: IO () -> IO () + sfork f = forkIO f >> return () + + update :: IO (Int, Bool, String, TVar Bool) + update = atomically $ do + (to, tg, dt) <- readTChan tc + when (to == 0) $ writeTVar ts $ Just dt + writeTVar otb False + tb <- newTVar True + return (to, tg, dt, tb) + + reset :: Int -> Bool -> TVar (Maybe String) -> TVar Bool -> IO () + reset to tg ts tb = do + threadDelay ( to * 100 * 1000 ) + readTVarIO tb >>= \b -> when b $ do + when tg $ putMVar signal $ Hide 0 + atomically (readTVar ts) >>= maybe (return ()) cb diff --git a/src/Plugins/Locks.hs b/src/Plugins/Locks.hs new file mode 100644 --- /dev/null +++ b/src/Plugins/Locks.hs @@ -0,0 +1,51 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Locks +-- Copyright : (c) Patrick Chilton +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Patrick Chilton <chpatrick@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin that displays the status of the lock keys. +-- +----------------------------------------------------------------------------- + +module Plugins.Locks where + +import Graphics.X11 +import Data.List +import Data.Bits +import Control.Monad +import Graphics.X11.Xlib.Extras +import Plugins + +data Locks = Locks + deriving (Read, Show) + +locks :: [ ( KeySym, String )] +locks = [ ( xK_Caps_Lock, "CAPS" ) + , ( xK_Num_Lock, "NUM" ) + , ( xK_Scroll_Lock, "SCROLL" ) + ] + +instance Exec Locks where + alias Locks = "locks" + rate Locks = 2 + run Locks = do + d <- openDisplay "" + root <- rootWindow d (defaultScreen d) + + modMap <- getModifierMapping d + ( _, _, _, _, _, _, _, m ) <- queryPointer d root + + ls <- filterM ( \( ks, _ ) -> do + kc <- keysymToKeycode d ks + return $ case find (elem kc . snd) modMap of + Nothing -> False + Just ( i, _ ) -> testBit m (fromIntegral i) + ) locks + closeDisplay d + + return $ unwords $ map snd ls diff --git a/src/Plugins/MBox.hs b/src/Plugins/MBox.hs --- a/src/Plugins/MBox.hs +++ b/src/Plugins/MBox.hs @@ -14,13 +14,13 @@ module Plugins.MBox (MBox(..)) where -import Prelude hiding (catch) +import Prelude import Plugins import Plugins.Utils (changeLoop, expandHome) import Control.Monad (when) import Control.Concurrent.STM -import Control.Exception (SomeException, handle, evaluate) +import Control.Exception (SomeException (..), handle, evaluate) import System.Console.GetOpt import System.Directory (doesFileExist) @@ -99,7 +99,7 @@ countMails :: FilePath -> IO Int countMails f = - handle ((\_ -> evaluate 0) :: SomeException -> IO Int) + handle (\(SomeException _) -> evaluate 0) (do txt <- B.readFile f evaluate $! length . filter (B.isPrefixOf from) . B.lines $ txt) where from = B.pack "From " diff --git a/src/Plugins/Monitors.hs b/src/Plugins/Monitors.hs --- a/src/Plugins/Monitors.hs +++ b/src/Plugins/Monitors.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Xmobar.Plugins.Monitors --- Copyright : (c) 2010, 2011 Jose Antonio Ortega Ruiz +-- Copyright : (c) 2010, 2011, 2012 Jose Antonio Ortega Ruiz -- (c) 2007-10 Andrea Rossato -- License : BSD-style (see LICENSE) -- @@ -19,7 +19,7 @@ import Plugins -import Plugins.Monitors.Common ( runM ) +import Plugins.Monitors.Common (runM) import Plugins.Monitors.Weather import Plugins.Monitors.Net import Plugins.Monitors.Mem @@ -40,6 +40,7 @@ #endif #ifdef LIBMPD import Plugins.Monitors.MPD +import Plugins.Monitors.Common (runMB) #endif #ifdef ALSA import Plugins.Monitors.Volume @@ -48,29 +49,31 @@ import Plugins.Monitors.Mpris #endif -data Monitors = Weather Station Args Rate - | Network Interface Args Rate - | BatteryP [String] Args Rate - | DiskU DiskSpec Args Rate - | DiskIO DiskSpec Args Rate - | Thermal Zone Args Rate - | ThermalZone ZoneNo Args Rate - | Memory Args Rate - | Swap Args Rate - | Cpu Args Rate - | MultiCpu Args Rate - | Battery Args Rate - | Brightness Args Rate - | CpuFreq Args Rate - | CoreTemp Args Rate - | TopProc Args Rate - | TopMem Args Rate - | Uptime Args Rate +data Monitors = Weather Station Args Rate + | Network Interface Args Rate + | DynNetwork Args Rate + | BatteryP [String] Args Rate + | DiskU DiskSpec Args Rate + | DiskIO DiskSpec Args Rate + | Thermal Zone Args Rate + | ThermalZone ZoneNo Args Rate + | Memory Args Rate + | Swap Args Rate + | Cpu Args Rate + | MultiCpu Args Rate + | Battery Args Rate + | Brightness Args Rate + | CpuFreq Args Rate + | CoreTemp Args Rate + | TopProc Args Rate + | TopMem Args Rate + | Uptime Args Rate #ifdef IWLIB | Wireless Interface Args Rate #endif #ifdef LIBMPD | MPD Args Rate + | AutoMPD Args #endif #ifdef ALSA | Volume String String Args Rate @@ -94,6 +97,7 @@ instance Exec Monitors where alias (Weather s _ _) = s alias (Network i _ _) = i + alias (DynNetwork _ _) = "dynnetwork" alias (Thermal z _ _) = z alias (ThermalZone z _ _) = "thermal" ++ show z alias (Memory _ _) = "memory" @@ -115,6 +119,7 @@ #endif #ifdef LIBMPD alias (MPD _ _) = "mpd" + alias (AutoMPD _) = "autompd" #endif #ifdef ALSA alias (Volume m c _ _) = m ++ ":" ++ c @@ -124,6 +129,7 @@ alias (Mpris2 _ _ _) = "mpris2" #endif start (Network i a r) = startNet i a r + start (DynNetwork a r) = startDynNet a r start (Cpu a r) = startCpu a r start (MultiCpu a r) = startMultiCpu a r start (TopProc a r) = startTop a r @@ -147,6 +153,7 @@ #endif #ifdef LIBMPD start (MPD a r) = runM a mpdConfig runMPD r + start (AutoMPD a) = runMB a mpdConfig runMPD mpdWait #endif #ifdef ALSA start (Volume m c a r) = runM a volumeConfig (runVolume m c) r diff --git a/src/Plugins/Monitors/Bright.hs b/src/Plugins/Monitors/Bright.hs --- a/src/Plugins/Monitors/Bright.hs +++ b/src/Plugins/Monitors/Bright.hs @@ -14,105 +14,92 @@ module Plugins.Monitors.Bright (brightConfig, runBright) where -import Plugins.Monitors.Common +import Control.Exception (SomeException, handle) import qualified Data.ByteString.Lazy.Char8 as B import Data.Char import System.FilePath ((</>)) import System.Posix.Files (fileExist) import System.Console.GetOpt -data BrightOpts = BrightOpts - { subDir :: String - , currBright :: String - , maxBright :: String - } +import Plugins.Monitors.Common +data BrightOpts = BrightOpts { subDir :: String + , currBright :: String + , maxBright :: String + } + defaultOpts :: BrightOpts -defaultOpts = BrightOpts - { subDir = "acpi_video0" - , currBright = "actual_brightness" - , maxBright = "max_brightness" - } +defaultOpts = BrightOpts { subDir = "acpi_video0" + , currBright = "actual_brightness" + , maxBright = "max_brightness" + } options :: [OptDescr (BrightOpts -> BrightOpts)] -options = - [ Option "D" ["device"] (ReqArg (\x o -> o { subDir = x }) "") "" - , Option "C" ["curr"] (ReqArg (\x o -> o { currBright = x }) "") "" - , Option "M" ["max"] (ReqArg (\x o -> o { maxBright = x }) "") "" - ] +options = [ Option "D" ["device"] (ReqArg (\x o -> o { subDir = x }) "") "" + , Option "C" ["curr"] (ReqArg (\x o -> o { currBright = x }) "") "" + , Option "M" ["max"] (ReqArg (\x o -> o { maxBright = x }) "") "" + ] -- from Batt.hs parseOpts :: [String] -> IO BrightOpts parseOpts argv = - case getOpt Permute options argv of - (o, _, []) -> return $ foldr id defaultOpts o - (_, _, errs) -> ioError . userError $ concat errs + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs sysDir :: FilePath sysDir = "/sys/class/backlight/" brightConfig :: IO MConfig -brightConfig = mkMConfig - "<percent>" -- template - ["hbar", "percent", "bar"] -- replacements +brightConfig = mkMConfig "<percent>" -- template + ["hbar", "percent", "bar"] -- replacements -data Files = Files - { fCurr :: String - , fMax :: String - } | NoFiles +data Files = Files { fCurr :: String + , fMax :: String + } + | NoFiles brightFiles :: BrightOpts -> IO Files -brightFiles opts = - do - is_curr <- fileExist $ (fCurr files) - is_max <- fileExist $ (fCurr files) - if is_curr && is_max - then return files - else return NoFiles - where - prefix = sysDir </> (subDir opts) - files = Files { fCurr = prefix </> (currBright opts) - , fMax = prefix </> (maxBright opts) - } - +brightFiles opts = do + is_curr <- fileExist $ (fCurr files) + is_max <- fileExist $ (fCurr files) + if is_curr && is_max then return files else return NoFiles + where prefix = sysDir </> (subDir opts) + files = Files { fCurr = prefix </> (currBright opts) + , fMax = prefix </> (maxBright opts) + } runBright :: [String] -> Monitor String runBright args = do - opts <- io $ parseOpts args - f <- io $ brightFiles opts - c <- io $ readBright f - case f of - NoFiles -> return "hurz" - _ -> do x <- fmtPercent c - parseTemplate (x) - where - fmtPercent :: Float -> Monitor [String] - fmtPercent c = do - r <- showHorizontalBar (100 * c) - s <- showPercentWithColors c - t <- showPercentBar (100 * c) c - return [r,s,t] + opts <- io $ parseOpts args + f <- io $ brightFiles opts + c <- io $ readBright f + case f of + NoFiles -> return "hurz" + _ -> fmtPercent c >>= parseTemplate + where fmtPercent :: Float -> Monitor [String] + fmtPercent c = do r <- showHorizontalBar (100 * c) + s <- showPercentWithColors c + t <- showPercentBar (100 * c) c + return [r,s,t] readBright :: Files -> IO Float readBright NoFiles = return 0 -readBright files = - do - currVal<- grab $ (fCurr files) - maxVal <- grab $ (fMax files) - return $ (currVal / maxVal) - where - grab f = catch (fmap (read . B.unpack) $ B.readFile f)(\_ -> return 0) - +readBright files = do + currVal<- grab $ (fCurr files) + maxVal <- grab $ (fMax files) + return $ (currVal / maxVal) + where grab f = handle handler (fmap (read . B.unpack) $ B.readFile f) + handler = const (return 0) :: SomeException -> IO Float showHorizontalBar :: Float -> Monitor String showHorizontalBar x = do - return $ [convert x] - where - convert :: Float -> Char - convert val - | t <= 9600 = ' ' - | t > 9608 = chr 9608 - | otherwise = chr t - where - -- we scale from 0 to 100, we have 8 slots (9 elements), 100/8 = 12 - t = 9600 + ((round val) `div` 12) + return $ [convert x] + where convert :: Float -> Char + convert val + | t <= 9600 = ' ' + | t > 9608 = chr 9608 + | otherwise = chr t + where + -- we scale from 0 to 100, we have 8 slots (9 elements), 100/8 = 12 + t = 9600 + ((round val) `div` 12) diff --git a/src/Plugins/Monitors/Common.hs b/src/Plugins/Monitors/Common.hs --- a/src/Plugins/Monitors/Common.hs +++ b/src/Plugins/Monitors/Common.hs @@ -23,6 +23,7 @@ , getConfigValue , mkMConfig , runM + , runMB , io -- * Parsers -- $parsers @@ -207,9 +208,13 @@ runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int -> (String -> IO ()) -> IO () -runM args conf action r cb = handle (cb . showException) loop +runM args conf action r = runMB args conf action (tenthSeconds r) + +runMB :: [String] -> IO MConfig -> ([String] -> Monitor String) + -> IO () -> (String -> IO ()) -> IO () +runMB args conf action wait cb = handle (cb . showException) loop where ac = doArgs args action - loop = conf >>= runReaderT ac >>= cb >> tenthSeconds r >> loop + loop = conf >>= runReaderT ac >>= cb >> wait >> loop showException :: SomeException -> String showException = ("error: "++) . show . flip asTypeOf undefined diff --git a/src/Plugins/Monitors/CoreCommon.hs b/src/Plugins/Monitors/CoreCommon.hs --- a/src/Plugins/Monitors/CoreCommon.hs +++ b/src/Plugins/Monitors/CoreCommon.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards, CPP #-} +{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | diff --git a/src/Plugins/Monitors/Disk.hs b/src/Plugins/Monitors/Disk.hs --- a/src/Plugins/Monitors/Disk.hs +++ b/src/Plugins/Monitors/Disk.hs @@ -43,7 +43,7 @@ parse `fmap` mapM canon (devs s) where canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} - devs = filter isDev . map (firstTwo . B.words) . B.lines + devs = filter isDev . map (firstTwo . B.words) . B.lines parse = map undev . filter isReq firstTwo (a:b:_) = (B.unpack a, B.unpack b) firstTwo _ = ("", "") @@ -51,6 +51,26 @@ isReq (d, p) = p `elem` req || drop 5 d `elem` req undev (d, f) = (drop 5 d, f) +diskDevices :: [String] -> IO [(DevName, Path)] +diskDevices req = do + s <- B.readFile "/proc/diskstats" + parse `fmap` mapM canon (devs s) + where + canon (d, p) = do {d' <- canonicalizePath (d); return (d', p)} + devs = map (third . B.words) . B.lines + parse = map undev . filter isReq + third (_:_:c:_) = ("/dev/" ++ (B.unpack c), B.unpack c) + third _ = ("", "") + isReq (d, p) = p `elem` req || drop 5 d `elem` req + undev (d, f) = (drop 5 d, f) + +mountedOrDiskDevices :: [String] -> IO [(DevName, Path)] +mountedOrDiskDevices req = do + mnt <- mountedDevices req + case mnt of + [] -> diskDevices req + other -> return other + diskData :: IO [(DevName, [Float])] diskData = do s <- B.readFile "/proc/diskstats" @@ -77,15 +97,6 @@ dat' = if length xs > 6 then [sp, rSp, wSp] else [0, 0, 0] in (dev, dat') -fsStats :: String -> IO [Integer] -fsStats path = do - stats <- getFileSystemStats path - case stats of - Nothing -> return [0, 0, 0] - Just f -> let tot = fsStatByteCount f - free = fsStatBytesAvailable f - in return [tot, free, tot - free] - speedToStr :: Float -> String speedToStr = showWithUnits 2 1 @@ -118,18 +129,28 @@ runDiskIO :: DevDataRef -> [(String, String)] -> [String] -> Monitor String runDiskIO dref disks _ = do - mounted <- io $ mountedDevices (map fst disks) - dat <- io $ mountedData dref (map fst mounted) - strs <- mapM runDiskIO' $ devTemplates disks mounted dat + dev <- io $ mountedOrDiskDevices (map fst disks) + dat <- io $ mountedData dref (map fst dev) + strs <- mapM runDiskIO' $ devTemplates disks dev dat return $ unwords strs startDiskIO :: [(String, String)] -> [String] -> Int -> (String -> IO ()) -> IO () startDiskIO disks args rate cb = do - mounted <- mountedDevices (map fst disks) - dref <- newIORef (map (\d -> (fst d, repeat 0)) mounted) - _ <- mountedData dref (map fst mounted) + dev <- mountedOrDiskDevices (map fst disks) + dref <- newIORef (map (\d -> (fst d, repeat 0)) dev) + _ <- mountedData dref (map fst dev) runM args diskIOConfig (runDiskIO dref disks) rate cb + +fsStats :: String -> IO [Integer] +fsStats path = do + stats <- getFileSystemStats path + case stats of + Nothing -> return [0, 0, 0] + Just f -> let tot = fsStatByteCount f + free = fsStatBytesAvailable f + used = fsStatBytesUsed f + in return [tot, free, used] runDiskU' :: String -> String -> Monitor String runDiskU' tmp path = do diff --git a/src/Plugins/Monitors/MPD.hs b/src/Plugins/Monitors/MPD.hs --- a/src/Plugins/Monitors/MPD.hs +++ b/src/Plugins/Monitors/MPD.hs @@ -12,7 +12,7 @@ -- ----------------------------------------------------------------------------- -module Plugins.Monitors.MPD ( mpdConfig, runMPD ) where +module Plugins.Monitors.MPD ( mpdConfig, runMPD, mpdWait ) where import Plugins.Monitors.Common import System.Console.GetOpt @@ -55,6 +55,10 @@ s <- parseMPD status song opts parseTemplate s +mpdWait :: IO () +mpdWait = M.withMPD idle >> return () + where idle = M.idle [M.PlayerS, M.MixerS] + mopts :: [String] -> IO MOpts mopts argv = case getOpt Permute options argv of @@ -91,10 +95,10 @@ parseSong (Right (Just s)) = let join [] = "" join (x:xs) = foldl (\a o -> a ++ ", " ++ o) x xs - str sel = maybe "" join (M.sgGetTag sel s) + str sel = maybe "" (join . 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.sgFilePath s : map str sels + fields = M.toString (M.sgFilePath s) : map str sels in mapM showWithPadding fields showTime :: Integer -> String diff --git a/src/Plugins/Monitors/Mpris.hs b/src/Plugins/Monitors/Mpris.hs --- a/src/Plugins/Monitors/Mpris.hs +++ b/src/Plugins/Monitors/Mpris.hs @@ -21,54 +21,64 @@ import Plugins.Monitors.Common import Text.Printf (printf) -import qualified DBus.Client.Simple as C -import DBus.Types -import DBus.Connection ( ConnectionError ) + +import DBus +import qualified DBus.Client as DC + import Data.Maybe ( fromJust ) import Data.Int ( Int32, Int64 ) import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Text as T import Control.Exception (try) class MprisVersion a where - getProxy :: a -> C.Client -> String -> IO C.Proxy - getMetadataReply :: a -> C.Client -> String -> IO [Variant] + getMethodCall :: a -> String -> MethodCall + getMetadataReply :: a -> DC.Client -> String -> IO [Variant] + getMetadataReply mv c p = fmap methodReturnBody (DC.call_ c $ getMethodCall mv p) fieldsList :: a -> [String] data MprisVersion1 = MprisVersion1 instance MprisVersion MprisVersion1 where - getProxy MprisVersion1 c p = do - let playerBusName = T.concat ["org.mpris.", T.pack p] - C.proxy c (C.busName_ playerBusName) "/Player" - getMetadataReply MprisVersion1 c p = do - player <- getProxy MprisVersion1 c p - C.call player "org.freedesktop.MediaPlayer" "GetMetadata" [] - fieldsList MprisVersion1 = [ "album", "artist", "arturl", "mtime", "title", "tracknumber" ] + getMethodCall MprisVersion1 p = (methodCall objectPath interfaceName memberName) + { methodCallDestination = Just busName + } + where + busName = busName_ $ "org.mpris." ++ p + objectPath = objectPath_ $ "/Player" + interfaceName = interfaceName_ $ "org.freedesktop.MediaPlayer" + memberName = memberName_ $ "GetMetadata" + fieldsList MprisVersion1 = [ "album", "artist", "arturl", "mtime", "title" + , "tracknumber" ] + data MprisVersion2 = MprisVersion2 instance MprisVersion MprisVersion2 where - getProxy MprisVersion2 c p = do - let playerBusName = T.concat ["org.mpris.MediaPlayer2.", T.pack p] - C.proxy c (C.busName_ playerBusName) "/org/mpris/MediaPlayer2" - getMetadataReply MprisVersion2 c p = do - player <- getProxy MprisVersion2 c p - C.call player "org.freedesktop.DBus.Properties" - "Get" - (map (toVariant::String -> Variant) - ["org.mpris.MediaPlayer2.Player", "Metadata"] - ) + getMethodCall MprisVersion2 p = (methodCall objectPath interfaceName memberName) + { methodCallDestination = Just busName + , methodCallBody = arguments + } + where + busName = busName_ $ "org.mpris.MediaPlayer2." ++ p + objectPath = objectPath_ $ "/org/mpris/MediaPlayer2" + interfaceName = interfaceName_ $ "org.freedesktop.DBus.Properties" + memberName = memberName_ $ "Get" + arguments = map (toVariant::String -> Variant) + ["org.mpris.MediaPlayer2.Player", "Metadata"] + fieldsList MprisVersion2 = [ "xesam:album", "xesam:artist", "mpris:artUrl" - , "mpris:length", "xesam:title", "xesam:trackNumber" + , "mpris:length", "xesam:title", + "xesam:trackNumber", "xesam:composer", + "xesam:genre" ] mprisConfig :: IO MConfig mprisConfig = mkMConfig "<artist> - <title>" - [ "album", "artist", "arturl", "length" , "title", "tracknumber" + [ "album", "artist", "arturl", "length" + , "title", "tracknumber" , "composer", "genre" ] -dbusClient :: C.Client -dbusClient = unsafePerformIO C.connectSession +dbusClient :: DC.Client +dbusClient = unsafePerformIO DC.connectSession runMPRIS :: (MprisVersion a) => a -> String -> [String] -> Monitor String runMPRIS version playerName _ = do @@ -95,10 +105,10 @@ TypeStructure _ -> unpack $ head $ structureItems $ fromVar v _ -> [] -getMetadata :: (MprisVersion a) => a -> C.Client -> String -> IO [(String, Variant)] +getMetadata :: (MprisVersion a) => a -> DC.Client -> String -> IO [(String, Variant)] getMetadata version client player = do reply <- try (getMetadataReply version client player) :: - IO (Either ConnectionError [Variant]) + IO (Either DC.ClientError [Variant]) return $ case reply of Right metadata -> unpackMetadata metadata; Left _ -> [] diff --git a/src/Plugins/Monitors/Net.hs b/src/Plugins/Monitors/Net.hs --- a/src/Plugins/Monitors/Net.hs +++ b/src/Plugins/Monitors/Net.hs @@ -13,12 +13,18 @@ -- ----------------------------------------------------------------------------- -module Plugins.Monitors.Net (startNet) where +module Plugins.Monitors.Net ( + startNet + , startDynNet + ) where import Plugins.Monitors.Common import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) +import Control.Monad (forM, filterM) +import System.Directory (getDirectoryContents, doesFileExist) +import System.FilePath ((</>)) import qualified Data.ByteString.Lazy.Char8 as B @@ -28,14 +34,39 @@ type NetDevRef = IORef (NetDev, UTCTime) +-- The more information available, the better. +-- Note that names don't matter. Therefore, if only the names differ, +-- a compare evaluates to EQ while (==) evaluates to False. +instance Ord NetDev where + compare NA NA = EQ + compare NA _ = LT + compare _ NA = GT + compare (NI _) (NI _) = EQ + compare (NI _) (ND _ _ _) = LT + compare (ND _ _ _) (NI _) = GT + compare (ND _ x1 y1) (ND _ x2 y2) = + if downcmp /= EQ + then downcmp + else y1 `compare` y2 + where downcmp = x1 `compare` x2 + netConfig :: IO MConfig netConfig = mkMConfig "<dev>: <rx>KB|<tx>KB" -- template ["dev", "rx", "tx", "rxbar", "txbar"] -- available replacements +operstateDir :: String -> FilePath +operstateDir d = "/sys/class/net" </> d </> "operstate" + +existingDevs :: IO [String] +existingDevs = getDirectoryContents "/sys/class/net" >>= filterM isDev + where isDev d | d `elem` excludes = return False + | otherwise = doesFileExist (operstateDir d) + excludes = [".", "..", "lo"] + isUp :: String -> IO Bool isUp d = do - operstate <- B.readFile $ "/sys/class/net/" ++ d ++ "/operstate" + operstate <- B.readFile (operstateDir d) return $ "up" == (B.unpack . head . B.lines) operstate readNetDev :: [String] -> IO NetDev @@ -103,9 +134,27 @@ runNet :: NetDevRef -> String -> [String] -> Monitor String runNet nref i _ = io (parseNet nref i) >>= printNet +parseNets :: [(NetDevRef, String)] -> IO [NetDev] +parseNets = mapM $ \(ref, i) -> parseNet ref i + +runNets :: [(NetDevRef, String)] -> [String] -> Monitor String +runNets refs _ = io (parseActive refs) >>= printNet + where parseActive refs' = parseNets refs' >>= return . selectActive + selectActive = maximum + startNet :: String -> [String] -> Int -> (String -> IO ()) -> IO () startNet i a r cb = do t0 <- getCurrentTime nref <- newIORef (NA, t0) _ <- parseNet nref i runM a netConfig (runNet nref i) r cb + +startDynNet :: [String] -> Int -> (String -> IO ()) -> IO () +startDynNet a r cb = do + devs <- existingDevs + refs <- forM devs $ \d -> do + t <- getCurrentTime + nref <- newIORef (NA, t) + _ <- parseNet nref d + return (nref, d) + runM a netConfig (runNets refs) r cb diff --git a/src/Plugins/PipeReader.hs b/src/Plugins/PipeReader.hs --- a/src/Plugins/PipeReader.hs +++ b/src/Plugins/PipeReader.hs @@ -23,6 +23,12 @@ instance Exec PipeReader where alias (PipeReader _ a) = a start (PipeReader p _) cb = do - h <- openFile p ReadWriteMode + let (def, pipe) = split ':' p + h <- openFile pipe ReadWriteMode + cb def forever (hGetLineSafe h >>= cb) - where forever a = a >> forever a + where + forever a = a >> forever a + split c xs | c `elem` xs = let (pre, post) = span ((/=) c) xs + in (pre, dropWhile ((==) c) post) + | otherwise = ([], xs) diff --git a/src/Plugins/StdinReader.hs b/src/Plugins/StdinReader.hs --- a/src/Plugins/StdinReader.hs +++ b/src/Plugins/StdinReader.hs @@ -14,11 +14,11 @@ module Plugins.StdinReader where -import Prelude hiding (catch) +import Prelude import System.Posix.Process import System.Exit import System.IO -import Control.Exception (SomeException(..),catch) +import Control.Exception (SomeException(..), handle) import Plugins data StdinReader = StdinReader @@ -26,8 +26,8 @@ instance Exec StdinReader where start StdinReader cb = do - cb =<< catch (hGetLineSafe stdin) - (\(SomeException e) -> do hPrint stderr e; return "") + cb =<< handle (\(SomeException e) -> do hPrint stderr e; return "") + (hGetLineSafe stdin) eof <- hIsEOF stdin if eof then exitImmediately ExitSuccess diff --git a/src/Plugins/Utils.hs b/src/Plugins/Utils.hs --- a/src/Plugins/Utils.hs +++ b/src/Plugins/Utils.hs @@ -15,7 +15,7 @@ ------------------------------------------------------------------------------ -module Plugins.Utils (expandHome, changeLoop) where +module Plugins.Utils (expandHome, changeLoop, safeHead) where import Control.Monad import Control.Concurrent.STM @@ -37,3 +37,7 @@ new <- s guard (new /= old) return new) + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x diff --git a/src/Runnable.hs b/src/Runnable.hs --- a/src/Runnable.hs +++ b/src/Runnable.hs @@ -29,8 +29,9 @@ data Runnable = forall r . (Exec r, Read r, Show r) => Run r instance Exec Runnable where - start (Run a) = start a - alias (Run a) = alias a + start (Run a) = start a + alias (Run a) = alias a + trigger (Run a) = trigger a instance Show Runnable where show (Run x) = show x diff --git a/src/Signal.hs b/src/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Signal.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveDataTypeable, CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Signal +-- Copyright : (c) Andrea Rosatto +-- : (c) Jose A. Ortega Ruiz +-- : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Signal handling, including DBUS when available +-- +----------------------------------------------------------------------------- + +module Signal where + +import Data.Typeable (Typeable) +import Control.Concurrent.STM +import Control.Exception hiding (handle) +import System.Posix.Signals + +#ifdef DBUS +import DBus (IsVariant(..)) +import Control.Monad ((>=>)) +#endif + +import Plugins.Utils (safeHead) + +data WakeUp = WakeUp deriving (Show,Typeable) +instance Exception WakeUp + +data SignalType = Wakeup + | Reposition + | ChangeScreen + | Hide Int + | Reveal Int + | Toggle Int + | TogglePersistent + deriving (Read, Show) + +#ifdef DBUS +instance IsVariant SignalType where + toVariant = toVariant . show + fromVariant = fromVariant >=> parseSignalType +#endif + +parseSignalType :: String -> Maybe SignalType +parseSignalType = fmap fst . safeHead . reads + +-- | Signal handling +setupSignalHandler :: IO (TMVar SignalType) +setupSignalHandler = do + tid <- newEmptyTMVarIO + installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing + installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing + return tid + +updatePosHandler :: TMVar SignalType -> IO () +updatePosHandler sig = do + atomically $ putTMVar sig Reposition + return () + +changeScreenHandler :: TMVar SignalType -> IO () +changeScreenHandler sig = do + atomically $ putTMVar sig ChangeScreen + return () diff --git a/src/StatFS.hsc b/src/StatFS.hsc --- a/src/StatFS.hsc +++ b/src/StatFS.hsc @@ -54,7 +54,7 @@ #ifdef IS_BSD_SYSTEM foreign import ccall unsafe "sys/mount.h statfs" #else -foreign import ccall unsafe "sys/vfs.h statfs64" +foreign import ccall unsafe "sys/statvfs.h statvfs" #endif c_statfs :: CString -> Ptr CStatfs -> IO CInt @@ -66,7 +66,7 @@ allocaBytes (#size struct statfs) $ \vfs -> useAsCString (pack path) $ \cpath -> do res <- c_statfs cpath vfs - if res == -1 then return Nothing + if res /= 0 then return Nothing else do bsize <- (#peek struct statfs, f_bsize) vfs bcount <- (#peek struct statfs, f_blocks) vfs @@ -79,5 +79,5 @@ , fsStatByteCount = toI bcount * bpb , fsStatBytesFree = toI bfree * bpb , fsStatBytesAvailable = toI bavail * bpb - , fsStatBytesUsed = toI (bcount - bavail) * bpb + , fsStatBytesUsed = toI (bcount - bfree) * bpb } diff --git a/src/Window.hs b/src/Window.hs new file mode 100644 --- /dev/null +++ b/src/Window.hs @@ -0,0 +1,175 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Window +-- Copyright : (c) 2011-12 Jose A. Ortega Ruiz +-- : (c) 2012 Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Window manipulation functions +-- +----------------------------------------------------------------------------- + +module Window where + +import Prelude +import Control.Monad (when) +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xinerama + +import Data.Maybe(fromMaybe) +import System.Posix.Process (getProcessID) + +import Config +import XUtil + +-- $window + +-- | The function to create the initial window +createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) +createWin d fs c = do + let dflt = defaultScreen d + 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 + 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 + (as,ds) <- textExtents fs "0" + 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 + return r + +setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool) +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) + 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) + 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') + 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 + + 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] + + getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral + +getRootWindowHeight :: [Rectangle] -> Int +getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) + where + getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) + +getStrutValues :: Rectangle -> XPosition -> Int -> [Int] +getStrutValues r@(Rectangle x y w h) p rwh = + case p of + OnScreen _ p' -> getStrutValues r p' rwh + Top -> [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] + 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) + +-- get some reaonable strut values for static placement. +getStaticStrutValues :: XPosition -> Int -> [Int] +getStaticStrutValues (Static cx cy cw ch) rwh + -- 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] + where st = cy + ch + sb = rwh - cy + xs = cx -- a simple calculation for horizontal (x) placement + xe = xs + cw +getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] + +drawBorder :: Border -> Display -> Drawable -> GC -> Pixel + -> Dimension -> Dimension -> IO () +drawBorder b d p gc c wi ht = case b of + NoBorder -> return () + TopB -> drawBorder (TopBM 0) d p gc c w h + BottomB -> drawBorder (BottomBM 0) d p gc c w h + FullB -> drawBorder (FullBM 0) d p gc c w h + TopBM m -> sf >> drawLine d p gc 0 (fi m) (fi w) 0 + BottomBM m -> let rw = fi h - fi m in + sf >> drawLine d p gc 0 rw (fi w) rw + FullBM m -> let pad = 2 * fi m; mp = fi m in + sf >> drawRectangle d p gc mp mp (w - pad) (h - pad) + where sf = setForeground d gc c + (w, h) = (wi - 1, ht - 1) + +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 + 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 + +isMapped :: Display -> Window -> IO Bool +isMapped d w = fmap ism $ getWindowAttributes d w + where ism (WindowAttributes { wa_map_state = wms }) = wms /= waIsUnmapped diff --git a/src/XUtil.hsc b/src/XUtil.hsc --- a/src/XUtil.hsc +++ b/src/XUtil.hsc @@ -2,8 +2,8 @@ ----------------------------------------------------------------------------- -- | -- Module : XUtil --- Copyright : (C) 2007 Andrea Rossato --- (C) 2011, 2012 Jose Antonio Ortega Ruiz +-- Copyright : (C) 2011, 2012 Jose Antonio Ortega Ruiz +-- (C) 2007 Andrea Rossato -- License : BSD3 -- -- Maintainer : jao@gnu.org @@ -20,20 +20,17 @@ , textExtents , textWidth , printString - , initColor , newWindow , nextEvent' , readFileSafe , hGetLineSafe , io , fi - , withColors - , DynPixel(..) ) where import Control.Concurrent import Control.Monad.Trans -import Data.IORef +import Control.Exception (SomeException, handle) import Foreign -- import Foreign.C.Types import Graphics.X11.Xlib hiding (textExtents, textWidth) @@ -51,10 +48,12 @@ #endif #if defined XFT import Data.List -import Graphics.X11.Xft +import MinXft import Graphics.X11.Xrender #endif +import ColorCache + readFileSafe :: FilePath -> IO String #if defined XFT || defined UTF8 readFileSafe = UTF8.readFile @@ -73,11 +72,11 @@ data XFont = Core FontStruct | Utf8 FontSet #ifdef XFT - | Xft XftFont + | Xft AXftFont #endif --- | When initFont gets a font name that starts with 'xft:' it switchs to the Xft backend --- Example: 'xft:Sans-10' +-- | When initFont gets a font name that starts with 'xft:' it switchs +-- to the Xft backend Example: 'xft:Sans-10' initFont :: Display ->String -> IO XFont initFont d s = #ifdef XFT @@ -92,33 +91,38 @@ fmap Core $ initCoreFont d s #endif +miscFixedFont :: String +miscFixedFont = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + -- | Given a fontname returns the font structure. If the font name is -- not valid the default font will be loaded and returned. initCoreFont :: Display -> String -> IO FontStruct initCoreFont d s = do - f <- catch getIt fallBack + f <- handle fallBack getIt addFinalizer f (freeFont d f) return f - where getIt = loadQueryFont d s - fallBack = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + where getIt = loadQueryFont d s + fallBack :: SomeException -> IO FontStruct + fallBack = const $ loadQueryFont d miscFixedFont -- | Given a fontname returns the font structure. If the font name is -- not valid the default font will be loaded and returned. initUtf8Font :: Display -> String -> IO FontSet initUtf8Font d s = do setupLocale - (_,_,f) <- catch getIt fallBack + (_,_,f) <- handle fallBack getIt addFinalizer f (freeFontSet d f) return f - where getIt = createFontSet d s - fallBack = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + where getIt = createFontSet d s + fallBack :: SomeException -> IO ([String], String, FontSet) + fallBack = const $ createFontSet d miscFixedFont #ifdef XFT -initXftFont :: Display -> String -> IO XftFont +initXftFont :: Display -> String -> IO AXftFont initXftFont d s = do setupLocale - f <- xftFontOpen d (defaultScreenOfDisplay d) (drop 4 s) - addFinalizer f (xftFontClose d f) + f <- openAXftFont d (defaultScreenOfDisplay d) (drop 4 s) + addFinalizer f (closeAXftFont d f) return f #endif @@ -127,7 +131,7 @@ textWidth _ (Core fs) s = return $ fi $ Xlib.textWidth fs s #ifdef XFT textWidth dpy (Xft xftdraw) s = do - gi <- xftTextExtents dpy xftdraw s + gi <- xftTxtExtents dpy xftdraw s return $ xglyphinfo_xOff gi #endif @@ -142,8 +146,8 @@ return (ascent, descent) #ifdef XFT textExtents (Xft xftfont) _ = do - ascent <- fi `fmap` xftfont_ascent xftfont - descent <- fi `fmap` xftfont_descent xftfont + ascent <- fi `fmap` xft_ascent xftfont + descent <- fi `fmap` xft_descent xftfont return (ascent, descent) #endif @@ -163,59 +167,17 @@ io $ wcDrawImageString d p fs gc x y s #ifdef XFT -printString dpy drw fs@(Xft font) gc fc bc x y s = do - let screen = defaultScreenOfDisplay dpy - colormap = defaultColormapOfScreen screen - visual = defaultVisualOfScreen screen - withColors dpy [bc] $ \[bcolor] -> do - (a,d) <- textExtents fs s - gi <- xftTextExtents dpy font s - setForeground dpy gc bcolor - fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) - (y - fi (a + d)) - (fi $ xglyphinfo_xOff gi) - (fi $ 4 + a + d) - withXftDraw dpy drw visual colormap $ - \draw -> withXftColorName dpy visual colormap fc $ - \color -> xftDrawString draw color font x (y - 2) s +printString dpy drw fs@(Xft font) _ fc bc x y s = do + (a,d) <- textExtents fs s + gi <- xftTxtExtents dpy font 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)) >> + (drawXftString draw fc' font x (y - 2) s) #endif -data DynPixel = DynPixel { allocated :: Bool - , pixel :: Pixel - } - --- | Get the Pixel value for a named color: if an invalid name is --- given the black pixel will be returned. -initColor :: Display -> String -> IO DynPixel -initColor dpy c = (initColor' dpy c) `catch` - (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy)) - -type ColorCache = [(String, Color)] -{-# NOINLINE colorCache #-} -colorCache :: IORef ColorCache -colorCache = unsafePerformIO $ newIORef [] - -getCachedColor :: String -> IO (Maybe Color) -getCachedColor color_name = lookup color_name `fmap` readIORef colorCache - -putCachedColor :: String -> Color -> IO () -putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c - -initColor' :: Display -> String -> IO DynPixel -initColor' dpy c = do - let colormap = defaultColormap dpy (defaultScreen dpy) - cached_color <- getCachedColor c - c' <- case cached_color of - Just col -> return col - _ -> do (c'', _) <- allocNamedColor dpy colormap c - putCachedColor c c'' - return c'' - return $ DynPixel True (color_pixel c') - -withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a -withColors d cs f = do - ps <- mapM (io . initColor d) cs - f $ map pixel ps -- | Creates a window with the attribute override_redirect set to True. -- Windows Managers should not touch this kind of windows. diff --git a/src/Xmobar.hs b/src/Xmobar.hs --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -29,7 +29,7 @@ , drawInWin, printStrings ) where -import Prelude hiding (catch) +import Prelude import Graphics.X11.Xlib hiding (textExtents, textWidth) import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama @@ -39,19 +39,26 @@ import Control.Monad.Reader import Control.Concurrent import Control.Concurrent.STM -import Control.Exception hiding (handle) +import Control.Exception (handle, SomeException(..)) import Data.Bits -import Data.Maybe(fromMaybe) -import Data.Typeable (Typeable) -import System.Posix.Process (getProcessID) -import System.Posix.Signals import Config import Parsers import Commands import Runnable +import Signal +import Window import XUtil +import ColorCache +#ifdef XFT +import Graphics.X11.Xft +#endif + +#ifdef DBUS +import IPC.DBus +#endif + -- $main -- -- The Xmobar data type and basic loops and functions. @@ -72,30 +79,29 @@ runX :: XConf -> X () -> IO () runX xc f = runReaderT f xc -data WakeUp = WakeUp deriving (Show,Typeable) -instance Exception WakeUp - -data SignalType = Wakeup | Reposition | ChangeScreen - -- | Starts the main event loop and threads -startLoop :: XConf -> [[(Maybe ThreadId, TVar String)]] -> IO () -startLoop xcfg@(XConf _ _ w _ _) vs = do +startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () +startLoop xcfg@(XConf _ _ w _ _) sig vs = do +#ifdef XFT + xftInitFtLibrary +#endif tv <- atomically $ newTVar [] - sig <- setupSignalHandler - _ <- forkIO (checker tv [] vs sig `catch` - \(SomeException _) -> void (putStrLn "Thread checker failed")) + _ <- forkIO (handle (handler "checker") (checker tv [] vs sig)) #ifdef THREADED_RUNTIME - _ <- forkOS (eventer sig `catch` + _ <- forkOS (handle (handler "eventer") (eventer sig)) #else - _ <- forkIO (eventer sig `catch` + _ <- forkIO (handle (handler "eventer") (eventer sig)) #endif - \(SomeException _) -> void (putStrLn "Thread eventer failed")) +#ifdef DBUS + runIPC sig +#endif eventLoop tv xcfg sig where + handler thing (SomeException _) = + putStrLn ("Thread " ++ thing ++ " failed") >> return () -- Reacts on events from X eventer signal = allocaXEvent $ \e -> do - dpy <- openDisplay "" xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask selectInput dpy w (exposureMask .|. structureNotifyMask) @@ -108,16 +114,16 @@ #endif ev <- getEvent e case ev of - ConfigureEvent {} -> putMVar signal Reposition - ExposeEvent {} -> putMVar signal Wakeup - RRScreenChangeNotifyEvent {} -> putMVar signal Reposition + ConfigureEvent {} -> atomically $ putTMVar signal Reposition + ExposeEvent {} -> atomically $ putTMVar signal Wakeup + RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition _ -> return () -- | Send signal to eventLoop every time a var is updated checker :: TVar [String] -> [String] -> [[(Maybe ThreadId, TVar String)]] - -> MVar SignalType + -> TMVar SignalType -> IO () checker tvar ov vs signal = do nval <- atomically $ do @@ -125,16 +131,16 @@ guard (nv /= ov) writeTVar tvar nv return nv - putMVar signal Wakeup + atomically $ putTMVar signal Wakeup checker tvar nval vs signal where concatV = fmap concat . mapM (readTVar . snd) -- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: TVar [String] -> XConf -> MVar SignalType -> IO () -eventLoop tv xc@(XConf d _ w fs cfg) signal = do - typ <- takeMVar signal +eventLoop :: TVar [String] -> XConf -> TMVar SignalType -> IO () +eventLoop tv xc@(XConf d r w fs cfg) signal = do + typ <- atomically $ takeTMVar signal case typ of Wakeup -> do runX xc (updateWin tv) @@ -147,7 +153,38 @@ ncfg <- updateConfigPosition cfg reposWindow ncfg + Hide t -> hide (t*100*1000) + Reveal t -> reveal (t*100*1000) + Toggle t -> toggle t + + TogglePersistent -> eventLoop + tv xc { config = cfg { persistent = not $ persistent cfg } } signal + where + isPersistent = not $ persistent cfg + + hide t + | t == 0 = + when isPersistent (hideWindow d w) >> eventLoop tv xc signal + | otherwise = do + void $ forkIO + $ threadDelay t >> atomically (putTMVar signal $ Hide 0) + eventLoop tv xc signal + + reveal t + | t == 0 = do + when isPersistent (showWindow r cfg d w) + eventLoop tv xc signal + | otherwise = do + void $ forkIO + $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) + eventLoop tv xc signal + + toggle t = do + ismapped <- isMapped d w + atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) + eventLoop tv xc signal + reposWindow rcfg = do r' <- repositionWin d w fs rcfg eventLoop tv (XConf d r' w fs rcfg) signal @@ -163,149 +200,25 @@ o -> return (ocfg {position = OnScreen 1 o}) - --- | Signal handling -setupSignalHandler :: IO (MVar SignalType) -setupSignalHandler = do - tid <- newEmptyMVar - installHandler sigUSR2 (Catch $ updatePosHandler tid) Nothing - installHandler sigUSR1 (Catch $ changeScreenHandler tid) Nothing - return tid - -updatePosHandler :: MVar SignalType -> IO () -updatePosHandler sig = do - putMVar sig Reposition - return () - -changeScreenHandler :: MVar SignalType -> IO () -changeScreenHandler sig = do - putMVar sig ChangeScreen - return () - -- $command -- | Runs a command as an independent thread and returns its thread id -- and the TVar the command will be writing to. -startCommand :: (Runnable,String,String) -> IO (Maybe ThreadId, TVar String) -startCommand (com,s,ss) +startCommand :: TMVar SignalType + -> (Runnable,String,String) + -> IO (Maybe ThreadId, TVar String) +startCommand sig (com,s,ss) | 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) where is = s ++ "Updating..." ++ ss --- $window - --- | The function to create the initial window -createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) -createWin d fs c = do - let dflt = defaultScreen d - 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) - mapWindow 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 - (as,ds) <- textExtents fs "0" - 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 - return r - -setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool) -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) - 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) - 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') - 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 - - setTextProperty d w "xmobar" wM_CLASS - setTextProperty d w "xmobar" wM_NAME - - changeProperty32 d w a1 c1 propModeReplace $ map fi $ - getStrutValues r (position c) (getRootWindowHeight srs) - changeProperty32 d w a2 c2 propModeReplace [fromIntegral v] - - getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral - -getRootWindowHeight :: [Rectangle] -> Int -getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) - where - getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) - -getStrutValues :: Rectangle -> XPosition -> Int -> [Int] -getStrutValues r@(Rectangle x y w h) p rwh = - case p of - OnScreen _ p' -> getStrutValues r p' rwh - Top -> [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] - 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) - --- get some reaonable strut values for static placement. -getStaticStrutValues :: XPosition -> Int -> [Int] -getStaticStrutValues (Static cx cy cw ch) rwh - -- 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] - where st = cy + ch - sb = rwh - cy - xs = cx -- a simple calculation for horizontal (x) placement - xe = xs + cw -getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] - updateWin :: TVar [String] -> X () updateWin v = do xc <- ask @@ -346,21 +259,6 @@ -- resync io $ sync d True -drawBorder :: Border -> Display -> Drawable -> GC -> Pixel - -> Dimension -> Dimension -> IO () -drawBorder b d p gc c wi ht = case b of - NoBorder -> return () - TopB -> drawBorder (TopBM 0) d p gc c w h - BottomB -> drawBorder (BottomBM 0) d p gc c w h - FullB -> drawBorder (FullBM 0) d p gc c w h - TopBM m -> sf >> drawLine d p gc 0 (fi m) (fi w) 0 - BottomBM m -> let rw = fi h - fi m in - sf >> drawLine d p gc 0 rw (fi w) rw - FullBM m -> let pad = 2 * fi m; mp = fi m in - sf >> drawRectangle d p gc mp mp (w - pad) (h - pad) - where sf = setForeground d gc c - (w, h) = (wi - 1, ht - 1) - -- | An easy way to print the stuff we need to print printStrings :: Drawable -> GC -> XFont -> Position -> Align -> [(String, String, Position)] -> X () @@ -371,7 +269,7 @@ let (conf,d) = (config &&& display) r Rectangle _ _ wid ht = rect r totSLen = foldr (\(_,_,len) -> (+) len) 0 sl - valign = (fi ht `div` 2) + (fi (as + ds) `div` 3) + valign = -1 + (fi ht + fi (as + ds)) `div` 2 remWidth = fi wid - fi totSLen offset = case a of C -> (remWidth + offs) `div` 2 @@ -380,8 +278,5 @@ (fc,bc) = case break (==',') c of (f,',':b) -> (f, b ) (f, _) -> (f, bgColor conf) - withColors d [bc] $ \[bc'] -> do - io $ setForeground d gc bc' - io $ fillRectangle d dr gc offset 0 (fi l) ht io $ printString d dr fontst gc fc bc offset valign s printStrings dr gc fontst (offs + l) a xs diff --git a/xmobar.cabal b/xmobar.cabal --- a/xmobar.cabal +++ b/xmobar.cabal @@ -1,5 +1,5 @@ name: xmobar -version: 0.15 +version: 0.16 homepage: http://projects.haskell.org/xmobar/ bug-reports: http://code.google.com/p/xmobar/issues synopsis: A Minimalistic Text Based Status Bar @@ -10,7 +10,7 @@ and extensibility through plugins. category: System license: BSD3 -license-file: LICENSE +license-file: license author: Andrea Rossato maintainer: Jose A. Ortega Ruiz <jao@gnu.org> cabal-version: >= 1.6 @@ -26,9 +26,6 @@ location: git://github.com/jaor/xmobar.git branch: master -flag small_base - description: Choose the new smaller, split-up base package. - flag with_xft description: Use Xft to render text. UTF-8 support included. default: False @@ -58,25 +55,31 @@ default: False flag with_datezone - description: Enables localized date support + description: Enables localized date support. default: False flag with_mpris - description: MPRIS v1, v2 support + description: MPRIS v1, v2 support. default: False +flag with_dbus + description: Publish a service on the session bus for controlling xmobar. + default: False + flag with_threaded - description: Use threaded runtime + description: Use threaded runtime. default: False executable xmobar hs-source-dirs: src main-is: Main.hs other-modules: - Xmobar, Config, Parsers, Commands, Localize, XUtil, StatFS, Runnable, - Plugins, Plugins.CommandReader, Plugins.Date, Plugins.EWMH, + Xmobar, Config, Parsers, Commands, Localize, + XUtil, StatFS, Runnable, ColorCache, Window, Signal, + Plugins, Plugins.BufferedPipeReader, + Plugins.CommandReader, Plugins.Date, Plugins.EWMH, Plugins.PipeReader, Plugins.StdinReader, Plugins.XMonadLog, - Plugins.Utils, Plugins.Kbd, Plugins.Monitors, + Plugins.Utils, Plugins.Kbd, Plugins.Locks, Plugins.Monitors, Plugins.Monitors.Batt, Plugins.Monitors.Common, Plugins.Monitors.CoreCommon, Plugins.Monitors.CoreTemp, Plugins.Monitors.CpuFreq, Plugins.Monitors.Cpu, @@ -88,47 +91,37 @@ Plugins.Monitors.Bright ghc-prof-options: -prof -auto-all + ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-do-bind + extra-libraries: Xrandr - if true - ghc-options: -funbox-strict-fields -Wall - extra-libraries: Xrandr + build-depends: + base == 4.*, + containers, + process, + old-locale, + bytestring, + directory, + unix, + time, + filepath, + X11 == 1.6.*, + mtl >= 2.0 && < 2.2, + parsec == 3.1.*, + stm >= 2.3 && < 2.5 if flag(with_threaded) - -- -threaded is a workaround 100% CPU busy loop - -- (http://hackage.haskell.org/trac/ghc/ticket/4934) + -- -threaded is a workaround for 100% CPU busy loop + -- (http://hackage.haskell.org/trac/ghc/ticket/4934). -- See also comments in https://github.com/jaor/xmobar/pull/36 ghc-options: -threaded cpp-options: -DTHREADED_RUNTIME - if impl (ghc >= 6.12.1) - ghc-options: -fno-warn-unused-do-bind - - -- for instance declaration in src/Plugins/Monitors/CoreCommon.hs if impl (ghc < 7) cpp-options: -DGHC6 - build-depends: - unix, - time, - filepath, - X11 == 1.6.*, - mtl == 2.0.*, - parsec == 3.1.*, - stm == 2.3.* - - if flag(small_base) - build-depends: - base == 4.*, - containers, - process, - old-locale, - bytestring, - directory - else - build-depends: base < 3 - if flag(with_xft) || flag(all_extensions) build-depends: utf8-string == 0.3.*, X11-xft >= 0.2 && < 0.4 + other-modules: MinXft cpp-options: -DXFT if flag(with_utf8) || flag(all_extensions) @@ -146,7 +139,7 @@ cpp-options: -DIWLIB if flag(with_mpd) || flag(all_extensions) - build-depends: libmpd == 0.7.* + build-depends: libmpd == 0.8.* other-modules: Plugins.Monitors.MPD cpp-options: -DLIBMPD @@ -162,6 +155,11 @@ cpp-options: -DDATEZONE if flag(with_mpris) || flag(all_extensions) - build-depends: dbus-core >= 0.9.2.1, text >= 0.11.1.5 && < 0.12 + build-depends: dbus >= 0.10 other-modules: Plugins.Monitors.Mpris cpp-options: -DMPRIS + + if flag(with_dbus) || flag(all_extensions) + build-depends: dbus >= 0.10 + other-modules: IPC.DBus + cpp-options: -DDBUS