diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,71 @@ -# Unreleased +# 4.0.3 +## Breaking Changes + + * Taffybar is tested with GHC versions >= 9.2 && < 9.10. + Other versions may or may not work. + + * The following symbols have been deprecated (not removed): + - `System.Taffybar.SimpleConfig.toTaffyConfig` - + Use [`toTaffybarConfig`][toTaffybarConfig] instead. + - `System.Taffybar.Support.PagerHints` - + Use the [`XMonad.Hooks.TaffybarPagerHints`][TaffybarPagerHints] module instead. + - `System.Taffybar.Util`: + * `liftReader` - Use [`Control.Monad.Trans.Reader.mapReaderT`][mapReaderT] instead. + * `logPrintFDebug` - Use [`logPrintF`][logPrintF] instead. + * `(??)` - Use `f <*> pure a` instead. + * `runCommandFromPath` - Use [`runCommand`][runCommand] instead. + +[toTaffybarConfig]: https://hackage.haskell.org/package/taffybar-4.0.3/docs/System-Taffybar-SimpleConfig.html#v:toTaffybarConfig +[TaffybarPagerHints]: https://hackage.haskell.org/package/xmonad-contrib-0.18.1/docs/XMonad-Hooks-TaffybarPagerHints.html +[mapReaderT]: https://hackage.haskell.org/package/transformers-0.6.1.0/docs/Control-Monad-Trans-Reader.html#v:mapReaderT +[logPrintF]: https://hackage.haskell.org/package/taffybar-4.0.3/docs/System-Taffybar-Util.html#v:logPrintF +[runCommand]: https://hackage.haskell.org/package/taffybar-4.0.3/docs/System-Taffybar-Util.html#v:runCommand + +## Improvements + + * Revise and expand documentation. + + * Some code cleanups such as applying HLint suggestions, fixing + compiler warnings, cleaning module imports. + + * The Nix code for `flake.nix` was streamlined, because upstream + nixpkgs already contains the necessary derivation overrides. + ## Bug Fixes - * Gtk.widgetShowAll is run on the widget created by `cryptoPriceLabelWithIcon`, + * Fix handling of Ctrl-C. + + * Improve logging in [`System.Taffybar.Information.Battery`](https://hackage.haskell.org/package/taffybar-4.0.3/docs/System-Taffybar-Information-Battery.html) + and [`System.Taffybar.WindowIcon`](https://hackage.haskell.org/package/taffybar-4.0.3/docs/System-Taffybar-WindowIcon.html). + + +# 4.0.2 + + * Taffybar can now build with GHC 9.6. + + * Allow building with Scotty 0.22. + + * Drop unused `ConfigFile` dependency. + + +# 4.0.1 + +## Improvements + + * Taffybar can now build with GHC 9.4. + + * Adds a `flake.nix`. + +## Bug Fixes + + * `Gtk.widgetShowAll` is run on the widget created by `cryptoPriceLabelWithIcon`, so that it shows up by default. + + * Fix misleading precision of rgba() parameters in `taffybar.css`. + + * Remove `cryptocurrency` Cabal flag, which is now unnecessary. + # 4.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,170 +1,83 @@ # Taffybar -[![Build Status](https://github.com/taffybar/taffybar/actions/workflows/nix.yml/badge.svg)](https://github.com/taffybar/taffybar/actions/workflows/nix.yml) [![Hackage](https://img.shields.io/hackage/v/taffybar.svg?logo=haskell&label=taffybar)](https://hackage.haskell.org/package/taffybar) [![Commits](https://img.shields.io/github/commits-since/taffybar/taffybar/latest-release.svg?label=unreleased%20commits)](https://github.com/taffybar/taffybar/compare/latest-release...master) [![Stackage LTS](http://stackage.org/package/taffybar/badge/lts)](http://stackage.org/lts/package/taffybar) [![Stackage Nightly](http://stackage.org/package/taffybar/badge/nightly)](http://stackage.org/nightly/package/taffybar) [![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) [![Matrix Chat](https://img.shields.io/matrix/taffybar:matrix.org)](https://matrix.to/#/#taffybar:matrix.org) [![Gitter Chat](https://badges.gitter.im/gitterHQ/gitter.png)](https://gitter.im/taffybar/Lobby) [![License BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/taffybar/taffybar/blob/master/LICENSE) ![https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png) +[![Build Status](https://github.com/taffybar/taffybar/actions/workflows/nix.yml/badge.svg)](https://github.com/taffybar/taffybar/actions/workflows/nix.yml) [![Hackage](https://img.shields.io/hackage/v/taffybar.svg?logo=haskell&label=taffybar)](https://hackage.haskell.org/package/taffybar) [![Commits](https://img.shields.io/github/commits-since/taffybar/taffybar/latest-release.svg?label=unreleased%20commits)](https://github.com/taffybar/taffybar/compare/latest-release...master) [![Stackage LTS](http://stackage.org/package/taffybar/badge/lts)](http://stackage.org/lts/package/taffybar) [![Stackage Nightly](http://stackage.org/package/taffybar/badge/nightly)](http://stackage.org/nightly/package/taffybar) [![Matrix Chat](https://img.shields.io/matrix/taffybar:matrix.org)](https://matrix.to/#/#taffybar:matrix.org) [![Gitter Chat](https://badges.gitter.im/gitterHQ/gitter.png)](https://gitter.im/taffybar/Lobby) [![License BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/taffybar/taffybar/blob/master/LICENSE) -Taffybar is a gtk+3 [(through -gi-gtk)](https://github.com/taffybar/taffybar/issues/256) based desktop -information bar, intended primarily for use with XMonad, though it can also +## Summary + +Taffybar is a desktop +information bar, intended primarily for use with [XMonad][], though it can also function alongside other EWMH compliant window managers. It is similar in spirit -to xmobar, but it differs in that it gives up some simplicity for a reasonable -helping of eye candy. +to [xmobar][], but it differs in that it gives up some simplicity for a reasonable +helping of [GTK 3][] eye candy. -Before Installing ------------------ +[![Screenshot](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png)](https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png) -Taffybar's installation procedure varies depending on whether or not you intend -to setup a new haskell project and use `startTaffybar` or use the `dyreTaffybar` -with a global haskell installation . It is important for you to read this -section so you can understand what all of that means before you decide how you -want to install taffybar. +[GTK 3]: https://www.gtk.org/ +[XMonad]: https://xmonad.org/ +[dwm]: https://dwm.suckless.org/ +[xmobar]: https://codeberg.org/xmobar/xmobar +[gi-gtk]: https://hackage.haskell.org/package/gi-gtk +[Haskell]: https://www.haskell.org/ +[GHC]: https://www.haskell.org/ghc/ -### Taffybar is a library +## Taffybar is a library -As with window managers like XMonad and dwm, taffybar is most appropriately +As with window managers like [XMonad][] and [dwm][], Taffybar is most appropriately described as a library that allows you to build an executable that is customized -to your tastes. This means that taffybar must be installed alongside a haskell -compiler (ghc) that can compile the user's configuration source file. - -### The taffybar binary and `startTaffybar` vs `dyreTaffybar` - -Taffybar can be started from your configuration file in two different ways: - -#### `dyreTaffybar` - -The `dyreTaffybar` entry point to taffybar uses the [dyre -library](https://github.com/willdonnelly/dyre) to automatically recompile your -taffybar configuration whenever it detects that it has changed. The binary that -is distributed with taffybar does nothing more than call this entry point. The -main downside of this approach is that it does not allow the user to use any -sort of project files for their configuration, and they must have any packages -that are necessary for compilation of their configuration available in their -global ghc environment. - -#### `startTaffybar` - -The `startTaffybar` entry point to taffybar simply starts taffybar with the -provided configuration. The user binary will not be automatically recompiled -when source files change. The advantage of using `startTaffybar` directly is -that you can use that in the main function of a cabal project. - -Distribution Packaging ----------------------- -Several linux distributions package taffybar -([nixos](https://github.com/NixOS/nixpkgs/blob/master/pkgs/applications/window-managers/taffybar/default.nix), -[arch/aur](https://aur.archlinux.org/packages/taffybar/), -[debian](https://aur.archlinux.org/packages/taffybar/)). Of these, only the -NixOS distribution is officially supported by the maintainers. Using any of the -others should be pretty similar to using a bare cabal installation of taffybar. - -#### NixOS - -If you wish to use the NixOS package for taffybar, make sure that you are using -the -[module](https://github.com/NixOS/nixpkgs/blob/master/pkgs/applications/window-managers/taffybar/default.nix), -and not simply the haskellPackage for taffybar. If you need to add additional -haskell packages to the environment that compiles your taffybar.hs you will need -to invoke that module and use the packages parameter to allow this. - -It is also possible to run/use taffybar on NixOS without using this module by -using a standalone haskell project for the taffybar configuration. - -##### Using the overlay.nix when taffybar is broken in nixpkgs -The taffybar haskell package in nixpkgs has been broken in the unstable channel -from time to time. This repository provides a nix overlay file which can be used -to build taffybar with current versions of nixpkgs. See [this -comment](https://github.com/taffybar/taffybar/issues/464#issuecomment-503258726) -for details on how to use the overlay. - -Installation From Hackage/Source --------------------------------- - -### Prerequisites - -If you are not using distribution packaging of taffybar or the nix package -manager (it will handle getting all the necessary packages for you), you will -need to install all of taffybar's non-haskell dependencies manually. - -Start by making sure you have installed everything that is needed for [haskell-gi](https://github.com/haskell-gi/haskell-gi). Taffybar also needs the -equivalent of `libdbusmenu-gtk3-dev` and `libgirepository1.0-dev` on Debian. - -You can also get some idea of what the necessary dependencies are by looking at -the nix section of the stack.yaml file in the taffybar repository. - -### Cabal - -Cabal installation is a simple matter of installing taffybar from hackage: -``` -cabal install taffybar -``` - -You do not need to do this if you are using the project approach with cabal. +to your tastes. Like [xmobar][] and [XMonad][], Taffybar is configured in [Haskell][]. -### The project approach -The project approach to installing/using taffybar involves maintaining a small -haskell project that produces the users taffybar binary. No matter which package -manager you choose to use you will need to make a .cabal file for this project. -It is recommended that you use [this -example](https://github.com/taffybar/taffybar/blob/master/example/my-taffybar.cabal) -as a template. In that example, the users configuration resides in the file -`taffybar.hs` in the same directory, but that can be changed as needed. As of -right now, `dyreTaffybar` is incompatible with this approach because dyre simply -calls ghc directly. +Taffybar has a reasonably useful default configuration built in. -### Cabal +To use a different configuration, however, you must install a Haskell compiler +([GHC][]) that can compile your [`taffybar.hs`](https://github.com/taffybar/taffybar/blob/master/example/taffybar.hs) source file. -Simply run `cabal new-install` to install the binary. +You then select from [the list of available widgets][widgets] for +functionality to add to your Taffybar. If the widget you need doesn't +exist, then create your own with GTK. -### Stack +[widgets]: http://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Widget.html -With stack, you will also need to maintain a stack.yaml file. Run `stack -install` to install the binary. See [this -example](https://github.com/taffybar/taffybar/blob/master/example/stack.yaml) +## Documentation -### Nix +* [**Installation**][install] -You will need to add default.nix file to your package. See [this -example](https://github.com/taffybar/taffybar/blob/master/example/default.nix) + Taffybar can be installed from Linux distribution packages, + or compiled from source. -You may also need to use the overlay provided by this repository. See [this -comment](https://github.com/taffybar/taffybar/issues/464#issuecomment-503258726) -for details. +* [**Configuration** (and compilation)][config] -#### Overlay + Taffybar can recompile itself from `taffybar.hs`, similar to how + [XMonad][] recompiles itself from `xmonad.hs`. -The taffybar haskell package is currently broken in nixpkgs, because some of its -dependencies are not compiling correctly/are not sufficiently new. The -environment.nix file in this repository fixes these build issues with an -overlay. The overlay.nix file extends the environment overlay so that it -overrides the taffybar package's build description to build the nix taffybar -package from the repository source directory. An example of how to set up -nixpkgs to use the taffybar overlay can be found -[here](https://github.com/ivanmalison/dotfiles/blob/a20b11a070472d182e09cf39f2b0149f39eac9ac/dotfiles/config/taffybar/base.nix#L1). + There are a number of ways to compile your configuration. +* [**Customization**][custom] -Configuration -------------- + Taffybar has a library of functions and widgets for collecting and + displaying information. -Like xmobar and XMonad, taffybar is configured in haskell. Taffybar depends on -dyre to automatically detect changes to its configuration file -(`$XDG_CONFIG_HOME/taffybar/taffybar.hs`) and recompile when appropriate. + Many aspects of the bar's appearance can be changed using CSS. -For more details about how to configure taffybar, see the [full -documentation](https://hackage.haskell.org/package/taffybar). You can find a -list of available widgets -[here](http://hackage.haskell.org/package/taffybar-2.0.0/docs/System-Taffybar-Widget.html). +* [**Running**][run] -FAQ ---- + Taffybar is one component of a desktop environment. To work + correctly, it requires other desktop components and system services. -For the time being, taffybar's frequently asked questions page lives in [this -github issue](https://github.com/taffybar/taffybar/issues/332). +* [**FAQ**][faq] -Contributing ------------- + Assorted information. -Taffybar desperately needs contributors. If you want to help, but don't know -where to get started you can check out our "help wanted" and "easy" labels: +* [**Contributing**][contrib] + [![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) + [![Easy Issues](https://img.shields.io/github/issues/taffybar/taffybar/easy.svg)](https://github.com/taffybar/taffybar/labels/easy) -[![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) -[![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/easy.svg)](https://github.com/taffybar/taffybar/labels/easy) + Taffybar desperately needs contributors. + There is plenty to do; enquire within. + +[install]: https://github.com/taffybar/taffybar/blob/master/doc/install.md +[config]: https://github.com/taffybar/taffybar/blob/master/doc/config.md +[custom]: https://github.com/taffybar/taffybar/blob/master/doc/custom.md +[run]: https://github.com/taffybar/taffybar/blob/master/doc/run.md +[faq]: https://github.com/taffybar/taffybar/blob/master/doc/faq.md +[contrib]: https://github.com/taffybar/taffybar/blob/master/doc/contrib.md diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -50,7 +50,7 @@ -- XXX: The configuration record here does not get used, this just calls in to dyre. then dyreTaffybar def else do - logM "System.Taffybar" WARNING $ + logM "System.Taffybar" WARNING ( printf "No taffybar configuration file found at %s." taffyFilepath ++ " Starting with example configuration." ) diff --git a/doc/config.md b/doc/config.md new file mode 100644 --- /dev/null +++ b/doc/config.md @@ -0,0 +1,129 @@ +# Configuration (and compilation) + +[dyre]: https://github.com/willdonnelly/dyre + +There are broadly three ways of building your configuration: + +1. [Install](./install.md) Taffybar, use the default configuration (i.e. absent + `taffybar.hs`) and don't compile anything yourself. +2. Let [Dyre][] handle compilation of `taffybar.hs`. +3. Compile your Taffybar executable some other way. Typically this + would be done with the "Project Approach" (see below). + +## Before installing + +Taffybar's [installation procedure](./install.md) varies depending +your chosen option. + +For example, it's not always necessary to install the `taffybar` +executable globally using a distro package or `cabal install +taffybar`. + +Read this section so you can understand what all of that means before +you decide how you want to install Taffybar. + +## Comparison + +| | **Dyre** | **Not Dyre** | +| ------------------------ | -------- | ------------- | +| Config file location | `$XDG_CONFIG_HOME/taffybar/taffybar.hs` | Anywhere | +| Automatic reloading | Yes | No | +| Multiple modules | No | Yes | +| Boilerplate code/config | Little | Some | +| Entry point | [`dyreTaffybar`][dyreTaffybar] | [`startTaffybar`][startTaffybar] | +| Installation environment | Global | Project-local | + +[dyreTaffybar]: https://hackage.haskell.org/package/taffybar-4.0.2/docs/System-Taffybar.html#v:dyreTaffybar +[startTaffybar]: https://hackage.haskell.org/package/taffybar-4.0.2/docs/System-Taffybar.html#v:startTaffybar + +## Entry point + +### `dyreTaffybar` (Dyre) + +Dyre simply calls `ghc` directly to compile the config file. Any +Haskell packages used by the config (e.g. `taffybar`, +`xmonad-contrib`) must be installed and available to +`ghc-pkg`. Usually this means with a global Haskell installation. + +The [`dyreTaffybar`][dyreTaffybar] entry point to Taffybar uses the +[Dyre library][dyre] to automatically recompile your +configuration whenever it detects that it has changed. + +The binary that is distributed with Taffybar does nothing more than +call this entry point. + +The main downside of this approach is that it does not allow the user to use any +sort of project files for their configuration, and they must have any packages +that are necessary for compilation of their configuration available in their +global ghc environment. + +### `startTaffybar` (not Dyre) + +Not using Dyre, you can compile your Taffybar configuration the same +way you compile other Haskell projects that you work on. + +The user binary will _not_ be automatically recompiled when source +files change. + +The [`startTaffybar`][startTaffybar] entry point simply starts +Taffybar with the given configuration. + +The advantage of using `startTaffybar` directly is +that you can use that in the `main` function of a Cabal project. + +## The Project Approach + +The "project approach" to configuring and installing Taffybar involves +maintaining a small Haskell project that produces the `taffybar` +binary. + +With this approach, you can build your Taffybar using proper build +tools rather than just `ghc -o taffybar taffybar.hs ...`, which is +essentially what [Dyre][] uses. The "Main" disadvantage of Dyre is +that you can't easily split your configuration into multiple modules. + +It is recommended that you use [this example `my-taffybar.cabal`][example-cabal] +as a template. In that example, the user's configuration resides in the file +`taffybar.hs` within the same directory, but that can be changed as needed. + +[example-cabal]: https://github.com/taffybar/taffybar/blob/master/example/my-taffybar.cabal + +### Main + +Example: [Main](https://github.com/taffybar/taffybar/blob/master/example/taffybar.hs) + +The `Main` module and any other module(s) listed in the `.cabal` file +are therefore your configuration. + +Your `main` function needs to call the `startTaffybar` entrypoint with +a `TaffybarConfig` value. See [Customization](./custom.md) for further +information. + +### Build tool examples + +Use your chosen build tool to compile the `taffybar` executable of +your configuration. The build tool can then install `taffybar` to a +system location such as `/usr/local/bin`. + +#### Cabal + +Example: [`my-taffybar.cabal`][example-cabal] + +Run `cabal install` within the project to install the executable. + +#### Stack + +Example: [`stack.yaml`](https://github.com/taffybar/taffybar/blob/master/example/stack.yaml) + +With Stack, you will also need to maintain a `stack.yaml` file in +addition to the `.cabal` file. When choosing a "resolver" for +`stack.yaml`, the latest [LTS Haskell](https://www.stackage.org/lts) +is usually a good choice. + +Run `stack install` within the project to install the executable. + +#### Nix + +Example derivation: [`default.nix`](https://github.com/taffybar/taffybar/blob/master/example/default.nix). + +This could be installed into your Nix user environment with `nix-env -i -f default.nix`. diff --git a/doc/contrib.md b/doc/contrib.md new file mode 100644 --- /dev/null +++ b/doc/contrib.md @@ -0,0 +1,10 @@ +# Contributing + + + +If you want to help, but don't know where to get started you can check +out these issue labels: + +- [Help Wanted](https://github.com/taffybar/taffybar/labels/help%20wanted) +- [Easy](https://github.com/taffybar/taffybar/labels/easy) + diff --git a/doc/custom.md b/doc/custom.md new file mode 100644 --- /dev/null +++ b/doc/custom.md @@ -0,0 +1,67 @@ +# Customization + +For details about the library modules for configuring your Taffybar, +see the [full documentation][hackage]. + +[hackage]: https://hackage.haskell.org/package/taffybar +[gi-gtk]: https://hackage.haskell.org/package/gi-gtk + +- [`taffybar` package documentation][hackage] - `System.Taffybar` +- [`gi-gtk` package documentation][gi-gtk] - `GI.Gtk` + +## Config file location + +Taffybar uses the directory `$XDG_CONFIG_HOME/taffybar/`. As per the +[XDG Base Directory Specification][basedir-spec], an unset or empty +`XDG_CONFIG_HOME` environment variable is taken to mean `~/.config`. + +[basedir-spec]: https://specifications.freedesktop.org/basedir-spec/latest/#variables + +## `TaffybarConfig` + +Be aware that the `TaffybarConfig` value required by `dyreTaffybar`/`startTaffybar` is normally constructed via a [`SimpleConfig`](https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-SimpleConfig.html#t:SimpleTaffyConfig) value and [`toTaffybarConfig`](https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-SimpleConfig.html#v:toTaffybarConfig). + +## CSS + +[#308 Add styling tips section to README/docs](https://github.com/taffybar/taffybar/issues/308) + +Appearance of Taffybar widgets can be controlled with CSS rules. These +are by default loaded from `$XDG_CONFIG_HOME/taffybar/taffybar.css`. Taffybar +must be restarted for changes in `taffybar.css` to take effect. + +### GTK Documentation + +CSS styling is a feature of GTK. It uses a limited version of CSS, so +the following articles from the GTK documentation are useful: +- [CSS in GTK](https://docs.gtk.org/gtk3/css-overview.html) +- [GTK CSS Properties](https://docs.gtk.org/gtk3/css-properties.html) + +### GTK Inspector + +Run Taffybar with the environment variable `GTK_DEBUG=interactive` to +enable the [GTK Inspector][inspector]. This will let you figure out +CSS class names of widgets. The GTK Inspector also lets you +interactively try CSS rules, which is immensely helpful. + +[inspector]: https://developer.gnome.org/documentation/tools/inspector.html + +### Specifying colours + +Note that the first three parameters of `rgba()` are integers in the +range 0—255, but the fourth is a float in the range 0.0—1.0. For example: + +```css +.taffy-box { + background-color: rgba(255, 250, 205, 0.3); +} +``` + +### Adding CSS classes to Taffybar widgets + +Use [`System.Taffybar.Util.widgetSetClassGI`][widgetSetClassGI] to add +a CSS class to a widget in your Taffybar config. + +This can be used for example to apply different styling to widgets of +the same type. + +[widgetSetClassGI]: https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Widget-Util.html#v:widgetSetClassGI diff --git a/doc/faq.md b/doc/faq.md new file mode 100644 --- /dev/null +++ b/doc/faq.md @@ -0,0 +1,6 @@ +# FAQ + +For the time being, Taffybar's frequently asked questions page lives in +[issue #332 - Add a FAQ section to README/Docs/Wiki](https://github.com/taffybar/taffybar/issues/332). + +Some of this information is collected in [Running Taffybar](./run.md). diff --git a/doc/index.md b/doc/index.md new file mode 100644 --- /dev/null +++ b/doc/index.md @@ -0,0 +1,83 @@ +# Taffybar + +[![Build Status](https://github.com/taffybar/taffybar/actions/workflows/nix.yml/badge.svg)](https://github.com/taffybar/taffybar/actions/workflows/nix.yml) [![Hackage](https://img.shields.io/hackage/v/taffybar.svg?logo=haskell&label=taffybar)](https://hackage.haskell.org/package/taffybar) [![Commits](https://img.shields.io/github/commits-since/taffybar/taffybar/latest-release.svg?label=unreleased%20commits)](https://github.com/taffybar/taffybar/compare/latest-release...master) [![Stackage LTS](http://stackage.org/package/taffybar/badge/lts)](http://stackage.org/lts/package/taffybar) [![Stackage Nightly](http://stackage.org/package/taffybar/badge/nightly)](http://stackage.org/nightly/package/taffybar) [![Matrix Chat](https://img.shields.io/matrix/taffybar:matrix.org)](https://matrix.to/#/#taffybar:matrix.org) [![Gitter Chat](https://badges.gitter.im/gitterHQ/gitter.png)](https://gitter.im/taffybar/Lobby) [![License BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/taffybar/taffybar/blob/master/LICENSE) + +## Summary + +Taffybar is a desktop +information bar, intended primarily for use with [XMonad][], though it can also +function alongside other EWMH compliant window managers. It is similar in spirit +to [xmobar][], but it differs in that it gives up some simplicity for a reasonable +helping of [GTK 3][] eye candy. + +[![Screenshot](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png)](https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png) + +[GTK 3]: https://www.gtk.org/ +[XMonad]: https://xmonad.org/ +[dwm]: https://dwm.suckless.org/ +[xmobar]: https://codeberg.org/xmobar/xmobar +[gi-gtk]: https://hackage.haskell.org/package/gi-gtk +[Haskell]: https://www.haskell.org/ +[GHC]: https://www.haskell.org/ghc/ + +## Taffybar is a library + +As with window managers like [XMonad][] and [dwm][], Taffybar is most appropriately +described as a library that allows you to build an executable that is customized +to your tastes. Like [xmobar][] and [XMonad][], Taffybar is configured in [Haskell][]. + +Taffybar has a reasonably useful default configuration built in. + +To use a different configuration, however, you must install a Haskell compiler +([GHC][]) that can compile your [`taffybar.hs`](https://github.com/taffybar/taffybar/blob/master/example/taffybar.hs) source file. + +You then select from [the list of available widgets][widgets] for +functionality to add to your Taffybar. If the widget you need doesn't +exist, then create your own with GTK. + +[widgets]: http://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Widget.html + +## Documentation + +* [**Installation**][install] + + Taffybar can be installed from Linux distribution packages, + or compiled from source. + +* [**Configuration** (and compilation)][config] + + Taffybar can recompile itself from `taffybar.hs`, similar to how + [XMonad][] recompiles itself from `xmonad.hs`. + + There are a number of ways to compile your configuration. + +* [**Customization**][custom] + + Taffybar has a library of functions and widgets for collecting and + displaying information. + + Many aspects of the bar's appearance can be changed using CSS. + +* [**Running**][run] + + Taffybar is one component of a desktop environment. To work + correctly, it requires other desktop components and system services. + +* [**FAQ**][faq] + + Assorted information. + +* [**Contributing**][contrib] + + [![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) + [![Easy Issues](https://img.shields.io/github/issues/taffybar/taffybar/easy.svg)](https://github.com/taffybar/taffybar/labels/easy) + + Taffybar desperately needs contributors. + There is plenty to do; enquire within. + +[install]: https://github.com/taffybar/taffybar/blob/master/doc/install.md +[config]: https://github.com/taffybar/taffybar/blob/master/doc/config.md +[custom]: https://github.com/taffybar/taffybar/blob/master/doc/custom.md +[run]: https://github.com/taffybar/taffybar/blob/master/doc/run.md +[faq]: https://github.com/taffybar/taffybar/blob/master/doc/faq.md +[contrib]: https://github.com/taffybar/taffybar/blob/master/doc/contrib.md diff --git a/doc/install.md b/doc/install.md new file mode 100644 --- /dev/null +++ b/doc/install.md @@ -0,0 +1,77 @@ +# Installation + +- [#535 - Fix up README](https://github.com/taffybar/taffybar/issues/535) + +## Distribution Packaging + +Several Linux distributions package Taffybar: + +- [NixOS (nixpkgs)](https://github.com/NixOS/nixpkgs/blob/master/pkgs/applications/window-managers/taffybar/default.nix) +- [arch/aur](https://aur.archlinux.org/packages/taffybar/) +- [Debian (main)](https://packages.debian.org/unstable/taffybar) +- [Ubuntu (universe)](https://packages.ubuntu.com/taffybar) + +Of these, only the NixOS distribution is officially supported by the +maintainers. Using any of the others would be pretty similar to using +a bare Cabal installation of Taffybar. + +### NixOS Package + +If you wish to use the NixOS package, make sure that you are using +the top-level [`pkgs.taffybar`](https://github.com/NixOS/nixpkgs/blob/master/pkgs/applications/window-managers/taffybar/default.nix) +and not simply `pkgs.haskellPackages.taffybar`. + +The top-level package (`pkgs.taffybar`) provides an environment for +Dyre containing `ghc` and libraries for compiling the configuration. + +If you need to add additional Haskell dependencies, then override the +`packages` parameter. For example: + +```nix +pkgs.taffybar.override { + packages = hp: [ hp.xmonad-contrib hp.dbus ]; +} +``` + +It is also possible to use Taffybar on NixOS without using this +module, for example by using `pkgs.haskellPackages.taffybar` as a +library in another package (see [Configuration (and compilation)](./config.md)). + +### Debian/Ubuntu + +On Debian/Ubuntu the `taffybar` package contains the executable +only. Install the `libghc-taffybar-dev` package to get the +`System.Taffybar` Haskell library. + +The development package `libghc-taffybar-dev` should also pull in the +GHC compiler and other system dependencies such as the `libgtk-3-dev` +package. Therefore it is useful to have, even if you intend to install +Taffybar from source and not use distribution binaries. + +# Installation from source + +## Prerequisites + +If not using a distribution package of Taffybar which handles getting +all the necessary development libraries for you, then you will need to +install all of Taffybar's non-Haskell dependencies manually. + +### System Dependencies + +Start by making sure you have installed everything that is needed for [haskell-gi](https://github.com/haskell-gi/haskell-gi). Taffybar also needs the +equivalent of [`libdbusmenu-gtk3-dev`](https://packages.debian.org/sid/libdbusmenu-gtk3-dev) and [`libgirepository1.0-dev`](https://packages.debian.org/sid/libgirepository-1.0-dev) on Debian. + +You can also get some idea of what the necessary dependencies are by looking at +the `nix` section of the [`stack.yaml`](https://github.com/taffybar/taffybar/blob/master/stack.yaml) file in the Taffybar repository. + +### Haskell Compiler + +For the greatest chance of success, use one of the GHC versions listed in [`taffybar.cabal` (tested-with)](https://github.com/taffybar/taffybar/blob/master/taffybar.cabal). Currently, GHC 9.6 is a good choice. + +## Cabal + +Once the prerequisites are in place, Cabal installation is a simple matter of installing [Taffybar from Hackage](https://hackage.haskell.org/package/taffybar): + +``` +cabal install taffybar +``` diff --git a/doc/run.md b/doc/run.md new file mode 100644 --- /dev/null +++ b/doc/run.md @@ -0,0 +1,159 @@ +# Running Taffybar + +Being a desktop component, Taffybar has various runtime dependencies, +depending on your configuration. + +## X11 Compisitor + +Run an X11 compositor such as [Picom][] for transparency and rounded +window corners. + +This is optional and Taffybar looks fine without these features. + +[Picom]: https://picom.app/ + +## XMonad + +Example: [`xmonad.hs`](https://github.com/taffybar/taffybar/blob/master/example/xmonad.hs) + +Your XMonad configuration should have: +1. [`XMonad.Hooks.ManageDocks.docks`][ManageDocks] - so that Taffybar windows are managed like docks +2. [`XMonad.Hooks.ManageDocks.avoidStruts`][ManageDocks] - so that other windows don't cover Taffybar. +1. [`XMonad.Hooks.EwmhDesktops.ewmh`][EwmhDesktops] - so that Taffybar knows about workspaces and windows managed by XMonad. +2. [`XMonad.Hooks.TaffybarPagerHints.pagerHints`][TaffybarPagerHints] - so that Taffybar knows about the current layout used by XMonad, and which workspaces are visible. + +[ManageDocks]: https://hackage.haskell.org/package/xmonad-contrib/docs/XMonad-Hooks-ManageDocks.html +[EwmhDesktops]: https://hackage.haskell.org/package/xmonad-contrib/docs/XMonad-Hooks-EwmhDesktops.html +[TaffybarPagerHints]: https://hackage.haskell.org/package/xmonad-contrib/docs/XMonad-Hooks-TaffybarPagerHints.html + +## D-Bus + +Taffybar connects to both the system bus and session bus. These days +it would be a rare Linux system which doesn't have a working D-Bus +_system bus_. + +However there can sometimes be problems configuring the per-user +_session bus_. Ensure that: + +1. The D-Bus session bus (i.e. `dbus-daemon` or `dbus-broker`) is + running for the user, or is able to be socket-activated. If you are + using `gnome-session` then D-Bus is guaranteed to be running. + +2. The `taffybar` process has the `DBUS_SESSION_BUS_ADDRESS` + environment variable set correctly. + + It can happen that Taffybar doesn't have `DBUS_SESSION_BUS_ADDRESS` + if it is started from an `xsession` script before `dbus-launch`. + + Or it can happen if Taffybar is running as a `systemd --user` + service, and the service gets started before + `DBUS_SESSION_BUS_ADDRESS` is imported into the systemd manager + environment. + +## Battery Status + +[UPower][] is required for [`System.Taffybar.Information.Battery`][Battery]. + +To test that it's running and working, run: + +``` +$ upower -i /org/freedesktop/UPower/devices/DisplayDevice + power supply: yes + updated: Sun 13 Oct 2024 09:13:24 (35002 seconds ago) + has history: no + has statistics: no + battery + present: yes + state: fully-charged + warning-level: none + energy: 49.9776 Wh + energy-full: 49.9776 Wh + energy-rate: 0.0076 W + charge-cycles: N/A + percentage: 100% + icon-name: 'battery-full-charged-symbolic' +``` + +### Incorrect battery state? + +If the battery icon is not updating or the battery state is not reported +correctly (e.g. [issue #330](https://github.com/taffybar/taffybar/issues/330), +you could try a workaround: + +1. Run UPower with the `--debug` option added. +2. Apply [`System.Taffybar.Hooks.withBatteryRefresh`][withBatteryRefresh] + to your `TaffybarConfig`. + +[Battery]: https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Information-Battery.html +[withBatteryRefresh]: https://hackage.haskell.org/package/taffybar-4.0.2/docs/System-Taffybar-Hooks.html#v:withBatteryRefresh +[UPower]: https://upower.freedesktop.org/ + +## System Tray + +Run [`status-notifier-watcher`](https://github.com/taffybar/status-notifier-item) +to track registration/deregistration of [StatusNotifierItem (SNI)][sni] +tray icons. This is an implementation of the StatusNotifierWatcher +interface which runs separately to Taffybar, so that tray icons can +survive restarts of Taffybar. + +[`System.Taffybar.Widget.SNITray.sniTrayNew`][SNITray] uses D-Bus to ask +StatusNotifierWatcher for the list of tray icons. Therefore, if using +[SNITray][], ensure that `status-notifier-watcher` is started before +Taffybar. + +[sni]: https://www.freedesktop.org/wiki/Specifications/StatusNotifierItem/ +[SNITray]: https://hackage.haskell.org/package/taffybar/docs/System-Taffybar-Widget-SNITray.html + +### Network Manager Tray Icon (`nm-applet`) + +`nm-applet` needs to be started with the `--indicator` option so that +it registers with the StatusNotifierWatcher. + +If using XDG autostart, then edit the `Exec=` line of +[`nm-applet.desktop`](https://gitlab.gnome.org/GNOME/network-manager-applet/-/blob/main/nm-applet.desktop.in?ref_type=heads) +in `~/.config/autostart`. + +(Sometimes a `nm-applet --sm-disable` option is mentioned. +This option is not needed [1](https://askubuntu.com/a/525273), [2](https://mail.gnome.org/archives/networkmanager-list/2011-May/msg00141.html).) + +## NixOS + +### GDK pixbuf loaders cache + +Under NixOS, it's not possible to have a global mutable file such as +`/usr/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache`. + +So graphical applications using `gdk-pixbuf` on NixOS need to have the +environment variable `GDK_PIXBUF_MODULE_FILE` set according to the +system configuration, _and_ available in the process execution +environment _before_ they are started. + +Applications started from within `gnome-session`, being child +processes of it, will naturally have `GDK_PIXBUF_MODULE_FILE` in their +process environment. + +Applications run as `systemd --user` services will not necesarily have +any environment variables at all. + +So if you run Taffybar as a `systemd --user` service, then add this to +your NixOS configuration: + +```nix +services.xserver.displayManager.importedVariables = [ + "GDK_PIXBUF_MODULE_FILE" +] +``` + +If using home-manager, and the option [`services.taffybar.enable`](https://github.com/nix-community/home-manager/blob/master/modules/services/taffybar.nix), +this is done for you. + +### `XDG_DATA_DIRS` + +For loading of desktop entry files and icons, Taffybar needs to be run +with a correctly configured `XDG_DATA_DIRS` environment variable. + +If you run Taffybar as a `systemd --user` service, the the correct +value of `XDG_DATA_DIRS` needs to be imported into the service manager +environment, _before_ `taffybar.service` is started. + +If using home-manager and the option [`xsession.enable`](https://github.com/nix-community/home-manager/blob/master/modules/xsession.nix), this is done for you. diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs --- a/src/System/Taffybar.hs +++ b/src/System/Taffybar.hs @@ -12,30 +12,30 @@ module System.Taffybar ( -- | Taffybar is a system status bar meant for use with window managers like - -- XMonad and i3wm. Taffybar is somewhat similar to xmobar, but it opts to use - -- more heavy weight GUI in the form of gtk+ rather than the mostly textual + -- "XMonad" and i3wm. Taffybar is somewhat similar to xmobar, but it opts to use + -- more heavy weight GUI in the form of GTK rather than the mostly textual -- approach favored by the latter. This allows it to provide features like an -- SNI system tray, and a workspace widget with window icons. -- - -- * Config File + -- * Configuration -- | - -- The interface that taffybar provides to the end user is roughly as follows: - -- you give Taffybar a list of ([Taffy]IO actions that build) gtk+ widgets and + -- The interface that Taffybar provides to the end user is roughly as follows: + -- you give Taffybar a list of ('TaffyIO' actions that build) GTK widgets and -- it renders them in a horizontal bar for you (taking care of ugly details -- like reserving strut space so that window managers don't put windows over -- it). -- - -- The config file in which you specify the gtk+ widgets to render is just a + -- The config file in which you specify the GTK widgets to render is just a -- Haskell source file which is used to produce a custom executable with the - -- desired set of widgets. This approach requires that taffybar be installed - -- as a haskell library (not merely as an executable), and that the ghc + -- desired set of widgets. This approach requires that Taffybar be installed + -- as a Haskell library (not merely as an executable), and that the GHC -- compiler be available for recompiling the configuration. The upshot of this - -- approach is that taffybar's behavior and widget set are not limited to the + -- approach is that Taffybar's behavior and widget set are not limited to the -- set of widgets provided by the library, because custom code and widgets can - -- be provided to taffybar for instantiation and execution. + -- be provided to Taffybar for instantiation and execution. -- - -- The following code snippet is a simple example of what a taffybar + -- The following code snippet is a simple example of what a Taffybar -- configuration might look like (also see "System.Taffybar.Example"): -- -- > {-# LANGUAGE OverloadedStrings #-} @@ -73,30 +73,42 @@ -- and then system CPU use in a kind of semi-transparent purple on top of the -- green. -- - -- It is important to note that the widget lists are *not* [Widget]. They are - -- actually [TaffyIO Widget] since the bar needs to construct them after + -- It is important to note that the widget lists are __not__ @'GI.Gtk.Widget'@. They are + -- actually @'TaffyIO' 'GI.Gtk.Widget'@ since the bar needs to construct them after -- performing some GTK initialization. + + getTaffyFile + + -- ** Colors -- + -- | Although Taffybar is based on GTK, it ignores your GTK theme. The default + -- theme that it uses lives at + -- https://github.com/taffybar/taffybar/blob/master/taffybar.css You can alter + -- this theme by editing @~\/.config\/taffybar\/taffybar.css@ to your liking. + -- For an idea of the customizations you can make, see + -- . + + -- * Taffybar and DBus -- - -- | Taffybar has a strict dependency on dbus, so you must ensure that it is - -- started before starting taffybar. + -- | Taffybar has a strict dependency on "DBus", so you must ensure that the DBus daemon is + -- started before starting Taffybar. -- - -- * If you start your window manager using a graphical login manager like gdm - -- or kdm, DBus should be started automatically for you. + -- * If you start your window manager using a graphical login manager like @gdm@ + -- or @kdm@, DBus should be started automatically for you. -- -- * If you start xmonad with a different graphical login manager that does - -- not start DBus for you automatically, put the line @eval \`dbus-launch - -- --auto-syntax\`@ into your ~\/.xsession *before* xmonad and taffybar are + -- not start DBus for you automatically, put the line + -- @eval \`dbus-launch --auto-syntax\`@ into your @~\/.xsession@ *before* xmonad and taffybar are -- started. This command sets some environment variables that the two must -- agree on. -- -- * If you start xmonad via @startx@ or a similar command, add the - -- above command to ~\/.xinitrc + -- above command to @~\/.xinitrc@ -- -- * System tray compatability -- - -- | "System.Taffybar.Widget.SNITray" only supports the newer + -- "System.Taffybar.Widget.SNITray" only supports the newer -- StatusNotifierItem (SNI) protocol; older xembed applets will not work. -- AppIndicator is also a valid implementation of SNI. -- @@ -105,32 +117,27 @@ -- [status-notifier-item](https://github.com/taffybar/status-notifier-item) -- package early on system startup. -- In case this is not possible, the alternative widget - -- sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt is available, but + -- 'System.Taffybar.Widget.SNITray.sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt' is available, but -- this may not necessarily be able to pick up everything. - -- * Colors - -- - -- | While taffybar is based on GTK+, it ignores your GTK+ theme. The default - -- theme that it uses lives at - -- https://github.com/taffybar/taffybar/blob/master/taffybar.css You can alter - -- this theme by editing @~\/.config\/taffybar\/taffybar.css@ to your liking. - -- For an idea of the customizations you can make, see - -- . - dyreTaffybar + -- * Starting + , startTaffybar + + -- ** Using Dyre + , dyreTaffybar , dyreTaffybarMain - , getTaffyFile - , startTaffybar , taffybarDyreParams ) where import qualified Config.Dyre as Dyre import qualified Config.Dyre.Params as Dyre +import Control.Exception ( finally ) import Control.Monad import qualified Data.GI.Gtk.Threading as GIThreading import qualified Data.Text as T import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk -import Graphics.X11.Xlib.Misc +import Graphics.X11.Xlib.Misc ( initThreads ) import System.Directory import System.Environment.XDG.BaseDir ( getUserConfigFile ) import System.Exit ( exitFailure ) @@ -139,6 +146,7 @@ import System.Log.Logger import System.Taffybar.Context import System.Taffybar.Hooks +import System.Taffybar.Util ( onSigINT ) import Paths_taffybar ( getDataDir ) @@ -150,15 +158,15 @@ , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"] } --- | Use Dyre to configure and start taffybar. This will automatically recompile --- taffybar whenever there are changes to your taffybar.hs configuration file. +-- | Use Dyre to configure and start Taffybar. This will automatically recompile +-- Taffybar whenever there are changes to your @taffybar.hs@ configuration file. dyreTaffybar :: TaffybarConfig -> IO () dyreTaffybar = Dyre.wrapMain taffybarDyreParams showError :: TaffybarConfig -> String -> TaffybarConfig showError cfg msg = cfg { errorMsg = Just msg } --- | The main function that should be run by dyre given a TaffybarConfig. +-- | The main function that Dyre should run. This is used in 'taffybarDyreParams'. dyreTaffybarMain :: TaffybarConfig -> IO () dyreTaffybarMain cfg = case errorMsg cfg of @@ -190,6 +198,8 @@ Gtk.styleContextAddProviderForScreen scr taffybarProvider 800 return taffybarProvider +-- | Locates full the 'FilePath' of the given Taffybar config file. +-- The [XDG Base Directory](https://specifications.freedesktop.org/basedir-spec/latest/) convention is used, meaning that config files are usually in @~\/.config\/taffybar@. getTaffyFile :: String -> IO FilePath getTaffyFile = getUserConfigFile "taffybar" @@ -198,8 +208,8 @@ defaultUserConfig <- getTaffyFile "taffybar.css" return [defaultUserConfig] --- | Start taffybar with the provided 'TaffybarConfig'. This function will not --- handle recompiling taffybar automatically when taffybar.hs is updated. If you +-- | Start Taffybar with the provided 'TaffybarConfig'. This function will not +-- handle recompiling taffybar automatically when @taffybar.hs@ is updated. If you -- would like this feature, use 'dyreTaffybar' instead. If automatic -- recompilation is handled by another mechanism such as stack or a custom user -- script or not desired for some reason, it is perfectly fine (and probably @@ -218,7 +228,15 @@ then getDefaultCSSPaths else return $ cssPaths config _ <- startCSS $ defaultCSS:cssPathsToLoad - _ <- buildContext config + context <- buildContext config Gtk.main - return () + `finally` logTaffy DEBUG "Finished main loop" + `onSigINT` do + logTaffy INFO "Interrupted" + exitTaffybar context + + logTaffy DEBUG "Exited normally" + +logTaffy :: Priority -> String -> IO () +logTaffy = logM "System.Taffybar" diff --git a/src/System/Taffybar/Auth.hs b/src/System/Taffybar/Auth.hs --- a/src/System/Taffybar/Auth.hs +++ b/src/System/Taffybar/Auth.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Auth where -import Control.Arrow import Control.Monad.IO.Class import Data.Maybe import System.Taffybar.Util @@ -11,13 +10,13 @@ fieldRegex = mkRegexWithOpts "^(.*?): *(.*?)$" True True passGet :: MonadIO m => String -> m (Either String (String, [(String, String)])) -passGet credentialName = - right (getPassComponents . lines) <$> - runCommandFromPath ["pass", "show", credentialName] - where getPassComponents passLines = - let entries = - map buildEntry $ catMaybes $ - matchRegex fieldRegex <$> tail passLines - buildEntry [fieldName, fieldValue] = (fieldName, fieldValue) - buildEntry _ = ("", "") - in (head passLines, entries) +passGet credentialName = (>>= getPassComponents . lines) <$> runPassShow + where runPassShow = runCommand "pass" ["show", credentialName] + + getPassComponents [] = Left "pass show command produced no output" + getPassComponents (key:rest) = Right (key, buildEntries rest) + + buildEntries = mapMaybe buildEntry . mapMaybe (matchRegex fieldRegex) + + buildEntry [fieldName, fieldValue] = Just (fieldName, fieldValue) + buildEntry _ = Nothing diff --git a/src/System/Taffybar/Context.hs b/src/System/Taffybar/Context.hs --- a/src/System/Taffybar/Context.hs +++ b/src/System/Taffybar/Context.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ImpredicativeTypes #-} ----------------------------------------------------------------------------- @@ -23,30 +22,44 @@ ----------------------------------------------------------------------------- module System.Taffybar.Context - ( Context(..) - , TaffybarConfig(..) - , Taffy - , TaffyIO + ( -- * Configuration + TaffybarConfig(..) + , defaultTaffybarConfig + , appendHook + -- ** Bars , BarConfig(..) , BarConfigGetter - , appendHook + , showBarId + + -- * Taffy monad + , Taffy + , TaffyIO + -- ** Context + , Context(..) , buildContext , buildEmptyContext - , defaultTaffybarConfig + -- ** Context State , getState , getStateDefault , putState - , forceRefreshTaffyWindows + + -- * Control , refreshTaffyWindows + , exitTaffybar + + -- * X11 , runX11 , runX11Def + -- ** Event subscription , subscribeToAll , subscribeToPropertyEvents - , taffyFork , unsubscribe + + -- * Threading + , taffyFork ) where -import Control.Arrow ((&&&)) +import Control.Arrow ((&&&), (***)) import Control.Concurrent (forkIO) import qualified Control.Concurrent.MVar as MV import Control.Exception.Enclosed (catchAny) @@ -72,7 +85,7 @@ import qualified GI.Gtk as Gtk import Graphics.UI.GIGtkStrut import StatusNotifier.TransparentWindow -import System.Log.Logger +import System.Log.Logger (Priority(..), logM) import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo import System.Taffybar.Util @@ -80,17 +93,17 @@ import Text.Printf import Unsafe.Coerce -logIO :: System.Log.Logger.Priority -> String -> IO () +logIO :: Priority -> String -> IO () logIO = logM "System.Taffybar.Context" -logC :: MonadIO m => System.Log.Logger.Priority -> String -> m () +logC :: MonadIO m => Priority -> String -> m () logC p = liftIO . logIO p --- | 'Taffy' is a monad transformer that provides 'Reader' for 'Context'. +-- | 'Taffy' is a monad transformer that provides 'ReaderT' for 'Context'. type Taffy m v = ReaderT Context m v -- | 'TaffyIO' is 'IO' wrapped with a 'ReaderT' providing 'Context'. This is the --- type of most widgets and callback in taffybar. +-- type of most widgets and callback in Taffybar. type TaffyIO v = ReaderT Context IO v type Listener = Event -> Taffy IO () @@ -247,14 +260,26 @@ buildEmptyContext :: IO Context buildEmptyContext = buildContext def +-- | Format the 'barId' as a numeric string. +showBarId :: BarConfig -> String +showBarId = show . hashUnique . barId + buildBarWindow :: Context -> BarConfig -> IO Gtk.Window buildBarWindow context barConfig = do let thisContext = context { contextBarConfig = Just barConfig } - logIO DEBUG $ - printf "Building bar window with StrutConfig: %s" $ - show $ strutConfig barConfig + logC INFO $ + printf "Building window for Taffybar(id=%s) with %s" + (showBarId barConfig) + (show $ strutConfig barConfig) window <- Gtk.windowNew Gtk.WindowTypeToplevel + + void $ Gtk.onWidgetDestroy window $ do + let bId = showBarId barConfig + logC INFO $ printf "Window for Taffybar(id=%s) destroyed" bId + MV.modifyMVar_ (existingWindows context) (pure . filter ((/=) window . sel2)) + logC DEBUG $ printf "Window for Taffybar(id=%s) unregistered" bId + box <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral $ widgetSpacing barConfig _ <- widgetSetClassGI box "taffy-box" @@ -310,7 +335,7 @@ -- windows that should active. Will avoid recreating windows if there is already -- a window with the appropriate geometry and "BarConfig". refreshTaffyWindows :: TaffyIO () -refreshTaffyWindows = liftReader postGUIASync $ do +refreshTaffyWindows = mapReaderT postGUIASync $ do logC DEBUG "Refreshing windows" ctx <- ask windowsVar <- asks existingWindows @@ -355,17 +380,34 @@ logC DEBUG "Finished refreshing windows" return () +-- | Unconditionally delete all existing Taffybar top-level windows. +removeTaffyWindows :: TaffyIO () +removeTaffyWindows = asks existingWindows >>= liftIO . MV.readMVar >>= deleteWindows + where + deleteWindows = mapM_ (sequenceT . (msg *** del)) + + msg :: BarConfig -> TaffyIO () + msg barConfig = logC INFO $ + printf "Destroying window for Taffybar(id=%s)" (showBarId barConfig) + + del :: Gtk.Window -> TaffyIO () + del = Gtk.widgetDestroy + -- | Forcibly refresh taffybar windows, even if there are existing windows that -- correspond to the uniques in the bar configs yielded by 'barConfigGetter'. forceRefreshTaffyWindows :: TaffyIO () -forceRefreshTaffyWindows = - asks existingWindows >>= lift . flip MV.modifyMVar_ deleteWindows >> - refreshTaffyWindows - where deleteWindows windows = - do - mapM_ (Gtk.widgetDestroy . sel2) windows - return [] +forceRefreshTaffyWindows = removeTaffyWindows >> refreshTaffyWindows +-- | Destroys all top-level windows belonging to Taffybar, then +-- requests the GTK main loop to exit. +-- +-- This ensures that the windows disappear promptly. For GTK windows +-- to be destroyed, the main loop still needs to be running. +exitTaffybar :: Context -> IO () +exitTaffybar ctx = do + postGUIASync $ runReaderT removeTaffyWindows ctx + Gtk.mainQuit + asksContextVar :: (r -> MV.MVar b) -> ReaderT r IO b asksContextVar getter = asks getter >>= lift . MV.readMVar @@ -414,9 +456,9 @@ (return . (contextStateMap,)) (currentValue >>= fromValue) --- | A version of "forkIO" in "TaffyIO". +-- | A version of 'forkIO' in 'TaffyIO'. taffyFork :: ReaderT r IO () -> ReaderT r IO () -taffyFork = void . liftReader forkIO +taffyFork = void . mapReaderT forkIO startX11EventHandler :: Taffy IO () startX11EventHandler = taffyFork $ do diff --git a/src/System/Taffybar/DBus/Client/Params.hs b/src/System/Taffybar/DBus/Client/Params.hs --- a/src/System/Taffybar/DBus/Client/Params.hs +++ b/src/System/Taffybar/DBus/Client/Params.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE OverloadedStrings #-} module System.Taffybar.DBus.Client.Params where diff --git a/src/System/Taffybar/DBus/Client/Util.hs b/src/System/Taffybar/DBus/Client/Util.hs --- a/src/System/Taffybar/DBus/Client/Util.hs +++ b/src/System/Taffybar/DBus/Client/Util.hs @@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} module System.Taffybar.DBus.Client.Util where -import Control.Applicative +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif import DBus.Generation import qualified DBus.Internal.Types as T import qualified DBus.Introspection as I @@ -13,33 +15,20 @@ import Language.Haskell.TH import StatusNotifier.Util (getIntrospectionObjectFromFile) -#if __GLASGOW_HASKELL__ >= 802 deriveShowAndEQ :: [DerivClause] deriveShowAndEQ = [DerivClause Nothing [ConT ''Eq, ConT ''Show]] -#endif buildDataFromNameTypePairs :: Name -> [(Name, Type)] -> Dec buildDataFromNameTypePairs name pairs = DataD [] name [] Nothing [RecC name (map mkVarBangType pairs)] -#if __GLASGOW_HASKELL__ >= 802 deriveShowAndEQ -#else - [] -#endif where mkVarBangType (fieldName, fieldType) = (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, fieldType) standaloneDeriveEqShow :: Name -> [Dec] -#if __GLASGOW_HASKELL__ < 802 -standaloneDeriveEqShow name = - [ StandaloneDerivD [] (ConT ''Eq `AppT` ConT name) - , StandaloneDerivD [] (ConT ''Show `AppT` ConT name) - ] -#else standaloneDeriveEqShow _ = [] -#endif type GetTypeForName = String -> T.Type -> Maybe Type diff --git a/src/System/Taffybar/DBus/Toggle.hs b/src/System/Taffybar/DBus/Toggle.hs --- a/src/System/Taffybar/DBus/Toggle.hs +++ b/src/System/Taffybar/DBus/Toggle.hs @@ -15,7 +15,6 @@ module System.Taffybar.DBus.Toggle ( handleDBusToggles ) where -import Control.Applicative import qualified Control.Concurrent.MVar as MV import Control.Exception import Control.Monad @@ -29,9 +28,7 @@ import qualified Data.Map as M import Data.Maybe import qualified GI.Gdk as Gdk -import qualified GI.Gtk as Gtk import Graphics.UI.GIGtkStrut -import Prelude import System.Directory import System.FilePath.Posix import System.Log.Logger @@ -142,7 +139,7 @@ , autoMethod "showOnMonitor" $ takeInt $ toggleTaffyOnMon (const True) , autoMethod "refresh" $ runReaderT refreshTaffyWindows ctx - , autoMethod "exit" (Gtk.mainQuit :: IO ()) + , autoMethod "exit" $ exitTaffybar ctx ] } lift $ do diff --git a/src/System/Taffybar/Example.hs b/src/System/Taffybar/Example.hs --- a/src/System/Taffybar/Example.hs +++ b/src/System/Taffybar/Example.hs @@ -104,5 +104,4 @@ , barHeight = ExactSize 50 , widgetSpacing = 0 } - in withBatteryRefresh $ withLogServer $ - withToggleServer $ toTaffyConfig myConfig + in withLogServer $ withToggleServer $ toTaffybarConfig myConfig diff --git a/src/System/Taffybar/Hooks.hs b/src/System/Taffybar/Hooks.hs --- a/src/System/Taffybar/Hooks.hs +++ b/src/System/Taffybar/Hooks.hs @@ -8,7 +8,8 @@ -- Stability : unstable -- Portability : unportable -- --- This module provides various startup hooks that can be added to 'TaffyConfig'. +-- This module provides various startup hooks that can be added to +-- 'TaffybarConfig'. ----------------------------------------------------------------------------- module System.Taffybar.Hooks @@ -58,8 +59,13 @@ handler <- taffyLogHandler updateGlobalLogger loggerName $ setHandlers [handler] --- | Add 'refreshrefreshBatteriesOnPropChange' to the 'startupHook' of the --- provided 'TaffybarConfig'. +-- | Add 'refreshBatteriesOnPropChange' to the 'startupHook' of the +-- provided 'TaffybarConfig'. Use this if your system has issues with +-- the battery widget not updating or reporting the incorrect state. +-- +-- This function 'withBatteryRefresh' is __not normally needed__ +-- because the battery widget already subscribes to updates from +-- UPower, and UPower usually works correctly. withBatteryRefresh :: TaffybarConfig -> TaffybarConfig withBatteryRefresh = appendHook refreshBatteriesOnPropChange diff --git a/src/System/Taffybar/Information/Battery.hs b/src/System/Taffybar/Information/Battery.hs --- a/src/System/Taffybar/Information/Battery.hs +++ b/src/System/Taffybar/Information/Battery.hs @@ -59,10 +59,14 @@ => Priority -> String -> t -> m () batteryLogF = logPrintF batteryLogPath +-- | The DBus path prefix where UPower enumerates its objects. +uPowerDevicesPath :: ObjectPath +uPowerDevicesPath = objectPath_ (formatObjectPath uPowerBaseObjectPath ++ "/devices") + -- | The prefix of name of battery devices path. UPower generates the object -- path as "battery" + "_" + basename of the sysfs object. batteryPrefix :: String -batteryPrefix = formatObjectPath uPowerBaseObjectPath ++ "/devices/battery_" +batteryPrefix = formatObjectPath uPowerDevicesPath ++ "/battery_" -- | Determine if a power source is a battery. isBattery :: ObjectPath -> Bool @@ -202,10 +206,11 @@ client <- asks systemDBusClient lift $ DBus.registerForPropertiesChanged client - matchAny { matchInterface = Just uPowerDeviceInterfaceName } + matchAny { matchInterface = Just uPowerDeviceInterfaceName + , matchPathNamespace = Just uPowerDevicesPath } handleIfPropertyMatches where handleIfPropertyMatches rawSignal n propertiesMap l = - let propertyPresent prop = isJust $ M.lookup prop propertiesMap + let propertyPresent prop = M.member prop propertiesMap in when (any propertyPresent properties || null properties) $ signalHandler rawSignal n propertiesMap l @@ -232,7 +237,7 @@ runReaderT doUpdate ctx _ <- registerForUPowerPropertyChanges propertiesToMonitor signalCallback doUpdate - return () + return (chan, infoVar) -- | Call "refreshAllBatteries" whenever the BatteryInfo for the DisplayDevice @@ -256,7 +261,12 @@ let doRefresh path = batteryLogF DEBUG "Refreshing battery: %s" path >> refresh client path eerror <- runExceptT $ ExceptT getBatteryPaths >>= liftIO . mapM doRefresh - let logRefreshError = batteryLogF ERROR "Failed to refresh battery: %s" + + -- NB. The Refresh() method is only available if the UPower daemon + -- was started in debug mode. So ignore any errors about the method + -- not being implemented. + let logRefreshError e = unless (methodErrorName e == errorUnknownMethod) $ + batteryLogF ERROR "Failed to refresh battery: %s" e logGetPathsError = batteryLogF ERROR "Failed to get battery paths %s" void $ either logGetPathsError (mapM_ $ either logRefreshError return) eerror diff --git a/src/System/Taffybar/Information/Chrome.hs b/src/System/Taffybar/Information/Chrome.hs --- a/src/System/Taffybar/Information/Chrome.hs +++ b/src/System/Taffybar/Information/Chrome.hs @@ -11,7 +11,6 @@ import Data.Maybe import qualified GI.GLib as Gdk import qualified GI.GdkPixbuf as Gdk -import Prelude import System.Log.Logger import System.Taffybar.Context import System.Taffybar.Information.EWMHDesktopInfo @@ -56,7 +55,7 @@ outChan <- newBChanListener inChan _ <- lift $ forkIO $ scotty port $ post "/setTabImageData/:tabID" $ do - tabID <- param "tabID" + tabID <- queryParam "tabID" imageData <- LBS.toStrict <$> body when (BS.length imageData > 0) $ lift $ do loader <- Gdk.pixbufLoaderNew diff --git a/src/System/Taffybar/Information/Crypto.hs b/src/System/Taffybar/Information/Crypto.hs --- a/src/System/Taffybar/Information/Crypto.hs +++ b/src/System/Taffybar/Information/Crypto.hs @@ -30,6 +30,7 @@ import qualified Data.Map as M import Data.Maybe import Data.Proxy +import Data.Text (Text) import qualified Data.Text as T import GHC.TypeLits import Network.HTTP.Simple hiding (Proxy) @@ -38,7 +39,7 @@ import System.Taffybar.Util import Text.Printf -getSymbolToCoinGeckoId :: MonadIO m => m (M.Map T.Text T.Text) +getSymbolToCoinGeckoId :: MonadIO m => m (M.Map Text Text) getSymbolToCoinGeckoId = do let uri = "https://api.coingecko.com/api/v3/coins/list?include_platform=false" request = parseRequest_ uri @@ -52,7 +53,7 @@ return $ M.fromList $ map (\CoinGeckoInfo { identifier = theId, symbol = theSymbol } -> (theSymbol, theId)) coinInfos -newtype SymbolToCoinGeckoId = SymbolToCoinGeckoId (M.Map T.Text T.Text) +newtype SymbolToCoinGeckoId = SymbolToCoinGeckoId (M.Map Text Text) newtype CryptoPriceInfo = CryptoPriceInfo { lastPrice :: Double } @@ -66,15 +67,35 @@ getStateDefault $ buildCryptoPriceChannel (60.0 :: Double) symbolToId data CoinGeckoInfo = - CoinGeckoInfo { identifier :: T.Text, symbol :: T.Text } + CoinGeckoInfo { identifier :: Text, symbol :: Text } deriving (Show) instance FromJSON CoinGeckoInfo where parseJSON = withObject "CoinGeckoInfo" (\v -> CoinGeckoInfo <$> v .: "id" <*> v .: "symbol") +logCrypto :: MonadIO m => Priority -> String -> m () +logCrypto p = liftIO . logM "System.Taffybar.Information.Crypto" p + +resolveSymbolPair :: KnownSymbol a => Proxy a -> SymbolToCoinGeckoId -> Either String (Text, Text) +resolveSymbolPair sym symbolToId = do + (symbolName, inCurrency) <- parseSymbolPair (symbolVal sym) + cgIdentifier <- lookupSymbolCoinGeckoId symbolToId symbolName + pure (cgIdentifier, inCurrency) + + where + parseSymbolPair :: String -> Either String (Text, Text) + parseSymbolPair symbolPair = case T.splitOn "-" (T.toLower $ T.pack symbolPair) of + [symbolName, inCurrency] | not (T.null inCurrency) -> Right (symbolName, inCurrency) + _ -> Left $ printf "Type parameter \"%s\" does not match the form \"ASSET-CURRENCY\"" symbolPair + + lookupSymbolCoinGeckoId :: SymbolToCoinGeckoId -> Text -> Either String Text + lookupSymbolCoinGeckoId (SymbolToCoinGeckoId m) symbolName = maybeToEither + (printf "Symbol \"%s\" not found in coin gecko list" (T.unpack symbolName)) + (M.lookup symbolName m) + buildCryptoPriceChannel :: - forall a. KnownSymbol a => Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a) -buildCryptoPriceChannel delay (SymbolToCoinGeckoId symbolToId) = do + forall a. KnownSymbol a => Double -> SymbolToCoinGeckoId -> TaffyIO (CryptoPriceChannel a) +buildCryptoPriceChannel delay symbolToId = do let initialBackoff = delay chan <- newBroadcastChan var <- liftIO $ newMVar $ CryptoPriceInfo 0.0 @@ -86,24 +107,19 @@ _ <- swapMVar backoffVar initialBackoff return () - let symbolPair = T.pack $ symbolVal (Proxy :: Proxy a) - (symbolName:inCurrency:_) = T.splitOn "-" symbolPair - - case M.lookup (T.toLower symbolName) symbolToId of - Nothing -> liftIO $ logM "System.Taffybar.Information.Crypto" - WARNING $ printf "Symbol %s not found in coin gecko list" symbolName - Just cgIdentifier -> + case resolveSymbolPair (Proxy :: Proxy a) symbolToId of + Left err -> logCrypto WARNING err + Right (cgIdentifier, inCurrency) -> void $ foreverWithVariableDelay $ - catchAny (liftIO $ getLatestPrice cgIdentifier (T.toLower inCurrency) >>= + catchAny (liftIO $ getLatestPrice cgIdentifier inCurrency >>= maybe (return ()) (doWrites . CryptoPriceInfo) >> return delay) $ \e -> do - logPrintF "System.Taffybar.Information.Crypto" - WARNING "Error when fetching crypto price: %s" e + logCrypto WARNING $ printf "Error when fetching crypto price: %s" (show e) modifyMVar backoffVar $ \current -> return (min (current * 2) delay, current) return $ CryptoPriceChannel (chan, var) -getLatestPrice :: MonadIO m => T.Text -> T.Text -> m (Maybe Double) +getLatestPrice :: MonadIO m => Text -> Text -> m (Maybe Double) getLatestPrice tokenId inCurrency = do let uri = printf "https://api.coingecko.com/api/v3/simple/price?ids=%s&vs_currencies=%s" tokenId inCurrency diff --git a/src/System/Taffybar/Information/EWMHDesktopInfo.hs b/src/System/Taffybar/Information/EWMHDesktopInfo.hs --- a/src/System/Taffybar/Information/EWMHDesktopInfo.hs +++ b/src/System/Taffybar/Information/EWMHDesktopInfo.hs @@ -61,7 +61,7 @@ , withEWMHIcons ) where -import Control.Applicative +import Control.Monad ((>=>)) import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.List @@ -74,11 +74,9 @@ import Foreign.Ptr import Foreign.Storable import System.Log.Logger -import System.Taffybar.Information.SafeX11 hiding (logHere) +import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo -import Prelude - logHere :: MonadIO m => Priority -> String -> m () logHere p = liftIO . logM "System.Taffybar.Information.EWMHDesktopInfo" p @@ -232,7 +230,7 @@ -- point will not be executed, after the call to 'withEWMHIcons' completes. withEWMHIcons :: EWMHIconData -> ([EWMHIcon] -> IO a) -> IO a withEWMHIcons (fptr, size) action = - withForeignPtr fptr ((>>= action) . parseIcons size) + withForeignPtr fptr (parseIcons size >=> action) -- | Split icon raw integer data into EWMHIcons. Each icon raw data is an -- integer for width, followed by height, followed by exactly (width*height) @@ -263,7 +261,7 @@ -- | Get the window that currently has focus if such a window exists. getActiveWindow :: X11Property (Maybe X11Window) -getActiveWindow = listToMaybe . filter (> 0) <$> readAsListOfWindow Nothing ewmhActiveWindow +getActiveWindow = find (> 0) <$> readAsListOfWindow Nothing ewmhActiveWindow -- | Return a list of all @X11Window@s, sorted by initial mapping order, oldest to newest. getWindows :: X11Property [X11Window] diff --git a/src/System/Taffybar/Information/Network.hs b/src/System/Taffybar/Information/Network.hs --- a/src/System/Taffybar/Information/Network.hs +++ b/src/System/Taffybar/Information/Network.hs @@ -16,7 +16,6 @@ module System.Taffybar.Information.Network where -import Control.Applicative import qualified Control.Concurrent.MVar as MV import Control.Exception (catch, SomeException) import Control.Monad @@ -29,8 +28,6 @@ import System.Taffybar.Information.StreamInfo ( getParsedInfo ) import System.Taffybar.Util -import Prelude - networkInfoFile :: FilePath networkInfoFile = "/proc/net/dev" @@ -103,7 +100,7 @@ let speedInfo = map sampleToSpeeds samples onUpdate speedInfo return samples - doUpdate = MV.modifyMVar_ samplesVar ((>>= doOnUpdate) . updateSamples) + doUpdate = MV.modifyMVar_ samplesVar (updateSamples >=> doOnUpdate) foreverWithDelay interval doUpdate updateSamples :: diff --git a/src/System/Taffybar/Information/SafeX11.hs b/src/System/Taffybar/Information/SafeX11.hs --- a/src/System/Taffybar/Information/SafeX11.hs +++ b/src/System/Taffybar/Information/SafeX11.hs @@ -1,5 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances, InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-orphans #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Information.SafeX11 @@ -13,7 +15,13 @@ module System.Taffybar.Information.SafeX11 ( module Graphics.X11.Xlib , module Graphics.X11.Xlib.Extras - , module System.Taffybar.Information.SafeX11 + , getWMHints + , getWindowProperty8 + , getWindowProperty16 + , getWindowProperty32 + , postX11RequestSyncDef + , rawGetWindowPropertyBytes + , safeGetGeometry ) where @@ -32,7 +40,6 @@ hiding (rawGetWindowProperty, getWindowProperty8, getWindowProperty16, getWindowProperty32, xGetWMHints, getWMHints, refreshKeyboardMapping) -import Prelude import System.IO.Unsafe import System.Log.Logger import System.Timeout diff --git a/src/System/Taffybar/Information/X11DesktopInfo.hs b/src/System/Taffybar/Information/X11DesktopInfo.hs --- a/src/System/Taffybar/Information/X11DesktopInfo.hs +++ b/src/System/Taffybar/Information/X11DesktopInfo.hs @@ -9,42 +9,54 @@ -- Portability : unportable -- -- Low-level functions to access data provided by the X11 desktop via window --- properties. One of them ('getVisibleTags') depends on the PagerHints hook +-- properties. One of them ('getVisibleTags') depends on the +-- 'XMonad.Hooks.TaffybarPagerHints.pagerHints' hook -- being installed in your @~\/.xmonad\/xmonad.hs@ configuration: -- --- > import System.Taffybar.Support.PagerHints (pagerHints) +-- > import XMonad.Hooks.TaffybarPagerHints (pagerHints) -- > -- > main = xmonad $ ewmh $ pagerHints $ ... -- ----------------------------------------------------------------------------- module System.Taffybar.Information.X11DesktopInfo - ( X11Context(..) + ( -- * Context + X11Context(..) + , getDefaultCtx + , withDefaultCtx + + -- * Properties , X11Property - , X11Window - , doLowerWindow + + -- ** Event loop , eventLoop - , fetch - , getAtom - , getDefaultCtx + + -- ** Context getters , getDisplay - , getPrimaryOutputNumber - , getVisibleTags - , isWindowUrgent - , postX11RequestSyncProp + , getAtom + + -- ** Basic properties of windows + , X11Window + , PropertyFetcher + , fetch , readAsInt , readAsListOfInt , readAsListOfString , readAsListOfWindow , readAsString + + -- ** Getters + , isWindowUrgent + , getPrimaryOutputNumber + , getVisibleTags + + -- ** Operations + , doLowerWindow + , postX11RequestSyncProp , sendCommandEvent , sendWindowEvent - , withDefaultCtx ) where -import Data.List -import Data.Maybe - import Codec.Binary.UTF8.String as UTF8 import qualified Control.Concurrent.MVar as MV import Control.Monad @@ -52,28 +64,28 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Data.Bits (testBit, (.|.)) +import Data.List (elemIndex) import Data.List.Split (endBy) -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras - hiding (getWindowProperty8, getWindowProperty32, getWMHints) -import Graphics.X11.Xrandr -import Safe -import System.Taffybar.Information.SafeX11 - -import Prelude +import Data.Maybe (fromMaybe, listToMaybe) +import Graphics.X11.Xrandr (XRRScreenResources(..), XRROutputInfo(..), xrrGetOutputInfo, xrrGetScreenResources, xrrGetOutputPrimary) +import System.Taffybar.Information.SafeX11 hiding (displayName) +-- | Represents a connection to an X11 display. +-- Use 'getDefaultCtx' to construct one of these. data X11Context = X11Context { contextDisplay :: Display , _contextRoot :: Window , atomCache :: MV.MVar [(String, Atom)] } +-- | 'IO' actions with access to an 'X11Context'. type X11Property a = ReaderT X11Context IO a type X11Window = Window -type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a]) +type PropertyFetcher a = Display -> Atom -> X11Window -> IO (Maybe [a]) --- | Put the current display and root window objects inside a Reader transformer --- for further computation. +-- | Makes a connection to the default X11 display using +-- 'getDefaultCtx' and puts the current display and root window +-- objects inside a 'ReaderT' transformer for further computation. withDefaultCtx :: X11Property a -> IO a withDefaultCtx fun = do ctx <- getDefaultCtx @@ -81,7 +93,8 @@ closeDisplay (contextDisplay ctx) return res --- | An X11Property that returns the @Display@ object stored in the X11Context. +-- | An X11Property that returns the 'Display' object stored in the +-- 'X11Context'. getDisplay :: X11Property Display getDisplay = contextDisplay <$> ask @@ -91,7 +104,7 @@ -> String -> X11Property b doRead def transform windowPropFn window name = - (fromMaybe def) . (fmap transform) <$> fetch windowPropFn window name + maybe def transform <$> fetch windowPropFn window name -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a value of type Int. If that property hasn't been set, @@ -99,7 +112,7 @@ readAsInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window. -> String -- ^ name of the property to retrieve -> X11Property Int -readAsInt = doRead (-1) (maybe (-1) fromIntegral . headMay) getWindowProperty32 +readAsInt = doRead (-1) (maybe (-1) fromIntegral . listToMaybe) getWindowProperty32 -- | Retrieve the property of the given window (or the root window, if Nothing) -- with the given name as a list of Ints. If that property hasn't been set, then @@ -141,14 +154,15 @@ hints <- fetchWindowHints window return $ testBit (wmh_flags hints) urgencyHintBit --- | Retrieve the value of the special _XMONAD_VISIBLE_WORKSPACES hint set by --- the PagerHints hook provided by Taffybar (see module documentation for --- instructions on how to do this), or an empty list of strings if the --- PagerHints hook is not available. +-- | Retrieve the value of the special @_XMONAD_VISIBLE_WORKSPACES@ +-- hint set by the 'XMonad.Hooks.TaffybarPagerHints.pagerHints' hook +-- provided by [xmonad-contrib]("XMonad.Hooks.TaffybarPagerHints") +-- (see module documentation for instructions on how to do this), or +-- an empty list of strings if the @pagerHints@ hook is not available. getVisibleTags :: X11Property [String] getVisibleTags = readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES" --- | Return the Atom with the given name. +-- | Return the 'Atom' with the given name. getAtom :: String -> X11Property Atom getAtom s = do (X11Context d _ cacheVar) <- ask @@ -184,14 +198,18 @@ (X11Context dpy root _) <- ask sendCustomEvent dpy cmd arg root root --- | Similar to 'sendCommandEvent', but with an argument of type Window. +-- | Similar to 'sendCommandEvent', but with an argument of type 'X11Window'. sendWindowEvent :: Atom -> X11Window -> X11Property () sendWindowEvent cmd win = do (X11Context dpy root _) <- ask sendCustomEvent dpy cmd cmd root win --- | Build a new @X11Context@ containing the current X11 display and its root --- window. +-- | Builds a new 'X11Context' containing a connection to the default +-- X11 display and its root window. +-- +-- If the X11 connection could not be opened, it will throw +-- @'Control.Exception.userError' "openDisplay"@. This can occur if the +-- @X -maxclients@ limit has been exceeded. getDefaultCtx :: IO X11Context getDefaultCtx = do d <- openDisplay "" @@ -241,14 +259,14 @@ let action = runReaderT prop c lift $ postX11RequestSyncDef def action --- | X11Property which reflects whether or not the provided RROutput is active. +-- | 'X11Property' which reflects whether or not the provided 'RROutput' is active. isActiveOutput :: XRRScreenResources -> RROutput -> X11Property Bool isActiveOutput sres output = do (X11Context display _ _) <- ask maybeOutputInfo <- liftIO $ xrrGetOutputInfo display sres output return $ maybe 0 xrr_oi_crtc maybeOutputInfo /= 0 --- | Return all the active RR outputs. +-- | Return all the active RANDR outputs. getActiveOutputs :: X11Property [RROutput] getActiveOutputs = do (X11Context display rootw _) <- ask @@ -264,7 +282,7 @@ outputs <- getActiveOutputs return $ primary `elemIndex` outputs --- | Move the X11Windows to the bottom of the X11 window stack. +-- | Move the given 'X11Window' to the bottom of the X11 window stack. doLowerWindow :: X11Window -> X11Property () doLowerWindow window = asks contextDisplay >>= lift . flip lowerWindow window diff --git a/src/System/Taffybar/Information/XDG/Protocol.hs b/src/System/Taffybar/Information/XDG/Protocol.hs --- a/src/System/Taffybar/Information/XDG/Protocol.hs +++ b/src/System/Taffybar/Information/XDG/Protocol.hs @@ -36,7 +36,6 @@ import Data.Maybe import qualified Debug.Trace as D import GHC.IO.Encoding -import Prelude import Safe (headMay) import System.Directory import System.Environment diff --git a/src/System/Taffybar/LogFormatter.hs b/src/System/Taffybar/LogFormatter.hs --- a/src/System/Taffybar/LogFormatter.hs +++ b/src/System/Taffybar/LogFormatter.hs @@ -16,9 +16,6 @@ import System.Log.Logger import Text.Printf import System.IO -import Data.Monoid - -import Prelude setColor :: Color -> String setColor color = setSGRCode [SetColor Foreground Vivid color] diff --git a/src/System/Taffybar/SimpleConfig.hs b/src/System/Taffybar/SimpleConfig.hs --- a/src/System/Taffybar/SimpleConfig.hs +++ b/src/System/Taffybar/SimpleConfig.hs @@ -18,6 +18,7 @@ , simpleDyreTaffybar , simpleTaffybar , toTaffyConfig + , toTaffybarConfig , useAllMonitors , usePrimaryMonitor , StrutSize(..) @@ -125,10 +126,14 @@ newtype SimpleBarConfigs = SimpleBarConfigs (MV.MVar [(Int, BC.BarConfig)]) +{-# DEPRECATED toTaffyConfig "Use toTaffybarConfig instead" #-} +toTaffyConfig :: SimpleTaffyConfig -> BC.TaffybarConfig +toTaffyConfig = toTaffybarConfig + -- | Convert a 'SimpleTaffyConfig' into a 'BC.TaffybarConfig' that can be used -- with 'startTaffybar' or 'dyreTaffybar'. -toTaffyConfig :: SimpleTaffyConfig -> BC.TaffybarConfig -toTaffyConfig conf = +toTaffybarConfig :: SimpleTaffyConfig -> BC.TaffybarConfig +toTaffybarConfig conf = def { BC.getBarConfigsParam = configGetter , BC.cssPaths = cssPaths conf @@ -159,11 +164,11 @@ -- | Start taffybar using dyre with a 'SimpleTaffybarConfig'. simpleDyreTaffybar :: SimpleTaffyConfig -> IO () -simpleDyreTaffybar conf = dyreTaffybar $ toTaffyConfig conf +simpleDyreTaffybar conf = dyreTaffybar $ toTaffybarConfig conf -- | Start taffybar with a 'SimpleTaffybarConfig'. simpleTaffybar :: SimpleTaffyConfig -> IO () -simpleTaffybar conf = startTaffybar $ toTaffyConfig conf +simpleTaffybar conf = startTaffybar $ toTaffybarConfig conf getMonitorCount :: IO Int getMonitorCount = diff --git a/src/System/Taffybar/Support/PagerHints.hs b/src/System/Taffybar/Support/PagerHints.hs --- a/src/System/Taffybar/Support/PagerHints.hs +++ b/src/System/Taffybar/Support/PagerHints.hs @@ -5,7 +5,7 @@ -- License : BSD3-style (see LICENSE) -- -- Maintainer : José A. Romero L. --- Stability : unstable +-- Stability : deprecated -- Portability : unportable -- -- Complements the "XMonad.Hooks.EwmhDesktops" with two additional hints @@ -30,11 +30,12 @@ -- ----------------------------------------------------------------------------- -module System.Taffybar.Support.PagerHints ( +module System.Taffybar.Support.PagerHints + {-# DEPRECATED "Use XMonad.Hooks.TaffybarPagerHints instead" #-} ( -- * Usage -- $usage pagerHints -) where + ) where import Codec.Binary.UTF8.String (encode) import Control.Monad diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs --- a/src/System/Taffybar/Util.hs +++ b/src/System/Taffybar/Util.hs @@ -11,7 +11,43 @@ -- Portability : unportable ----------------------------------------------------------------------------- -module System.Taffybar.Util where +module System.Taffybar.Util ( + -- * Configuration + taffyStateDir + -- * GTK concurrency + , module Gtk + -- * GLib + , catchGErrorsAsLeft + -- * Logging + , logPrintF + -- * Text + , truncateString + , truncateText + -- * Resources + , downloadURIToPath + , getPixbufFromFilePath + , safePixbufNewFromFile + -- * Logic Combinators + , (<||>) + , (<|||>) + , forkM + , ifM + , anyM + , maybeTCombine + , maybeToEither + -- * Control + , foreverWithVariableDelay + , foreverWithDelay + -- * Process control + , runCommand + , onSigINT + -- * Deprecated + , logPrintFDebug + , liftReader + , liftActionTaker + , (??) + , runCommandFromPath + ) where import Conduit import Control.Applicative @@ -24,17 +60,19 @@ import Data.Either.Combinators import Data.GI.Base.GError import Control.Exception.Enclosed (catchAny) -import qualified Data.GI.Gtk.Threading as Gtk +import Data.GI.Gtk.Threading as Gtk (postGUIASync, postGUISync) import Data.Maybe +import Data.IORef (newIORef, readIORef, writeIORef) import qualified Data.Text as T import Data.Tuple.Sequence import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import Network.HTTP.Simple import System.Directory import System.Environment.XDG.BaseDir -import System.Exit (ExitCode (..)) +import System.Exit (ExitCode (..), exitWith) import System.FilePath.Posix import System.Log.Logger +import System.Posix.Signals (Signal, Handler(..), installHandler, sigINT) import qualified System.Process as P import Text.Printf @@ -42,10 +80,9 @@ taffyStateDir :: IO FilePath taffyStateDir = getUserDataDir "taffybar" -liftReader :: - Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b -liftReader modifier action = - ask >>= lift . modifier . runReaderT action +{-# DEPRECATED liftReader "Use Control.Monad.Trans.Reader.mapReaderT instead" #-} +liftReader :: Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b +liftReader = mapReaderT logPrintF :: (MonadIO m, Show t) @@ -53,6 +90,7 @@ logPrintF logPath priority format toPrint = liftIO $ logM logPath priority $ printf format $ show toPrint +{-# DEPRECATED logPrintFDebug "Use logPrintF instead" #-} logPrintFDebug :: (MonadIO m, Show t) => String -> String -> t -> m () logPrintFDebug path = logPrintF path DEBUG @@ -60,6 +98,7 @@ (??) :: Functor f => f (a -> b) -> a -> f b fab ?? a = fmap ($ a) fab {-# INLINE (??) #-} +{-# DEPRECATED (??) "Use @f <*> pure a@ instead" #-} ifM :: Monad m => m Bool -> m a -> m a -> m a ifM cond whenTrue whenFalse = @@ -81,10 +120,10 @@ | T.length incoming <= n = incoming | otherwise = T.append (T.take n incoming) "…" -runCommandFromPath :: MonadIO m => [String] -> m (Either String String) -runCommandFromPath = runCommand "/usr/bin/env" - -- | Run the provided command with the provided arguments. +-- +-- If the command filename does not contain a slash, then the @PATH@ +-- environment variable is searched for the executable. runCommand :: MonadIO m => FilePath -> [String] -> m (Either String String) runCommand cmd args = liftIO $ do (ecode, stdout, stderr) <- P.readProcessWithExitCode cmd args "" @@ -94,6 +133,10 @@ ExitSuccess -> Right stdout ExitFailure exitCode -> Left $ printf "Exit code %s: %s " (show exitCode) stderr +{-# DEPRECATED runCommandFromPath "Use runCommand instead" #-} +runCommandFromPath :: MonadIO m => FilePath -> [String] -> m (Either String String) +runCommandFromPath = runCommand + -- | Execute the provided IO action at the provided interval. foreverWithDelay :: (MonadIO m, RealFrac d) => d -> IO () -> m ThreadId foreverWithDelay delay action = @@ -170,12 +213,6 @@ runConduitRes (httpSource uri getResponseBody .| sinkFile filepath) where (directory, _) = splitFileName filepath -postGUIASync :: IO () -> IO () -postGUIASync = Gtk.postGUIASync - -postGUISync :: IO () -> IO () -postGUISync = Gtk.postGUISync - anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool anyM _ [] = return False anyM p (x:xs) = do @@ -183,3 +220,37 @@ if q then return True else anyM p xs + +-- | Installs a useful posix signal handler for 'sigINT' (i.e. Ctrl-C) +-- for cases when the 'Control.Exception.UserInterrupt' exception gets +-- swallowed within a main loop, preventing the program from exiting. +-- +-- The given callback should be a command which causes the main loop +-- action to exit. For example: +-- +-- > Gtk.main `onSigINT` Gtk.mainQuit +-- +-- If the signal handler was invoked, the program will exit with +-- status 130 after the main loop action returns. +onSigINT + :: IO a -- ^ The main loop 'IO' action + -> IO () -- ^ Callback for @SIGINT@ + -> IO a +onSigINT action callback = do + exitStatus <- newIORef Nothing + + let intHandler = do + writeIORef exitStatus (Just (ExitFailure 130)) + callback + + withSigHandler sigINT (CatchOnce intHandler) $ do + res <- action + readIORef exitStatus >>= mapM_ exitWith + pure res + +-- | Install a handler for the given signal, run an 'IO' action, then +-- restore the original handler. +withSigHandler :: Signal -> Handler -> IO a -> IO a +withSigHandler sig h = bracket (install h) install . const + where + install handler = installHandler sig handler Nothing diff --git a/src/System/Taffybar/Widget/Battery.hs b/src/System/Taffybar/Widget/Battery.hs --- a/src/System/Taffybar/Widget/Battery.hs +++ b/src/System/Taffybar/Widget/Battery.hs @@ -22,7 +22,6 @@ , textBatteryNewWithLabelAction ) where -import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -30,7 +29,6 @@ import Data.Int (Int64) import qualified Data.Text as T import GI.Gtk as Gtk -import Prelude import StatusNotifier.Tray (scalePixbufToSize) import System.Taffybar.Context import System.Taffybar.Information.Battery diff --git a/src/System/Taffybar/Widget/FreedesktopNotifications.hs b/src/System/Taffybar/Widget/FreedesktopNotifications.hs --- a/src/System/Taffybar/Widget/FreedesktopNotifications.hs +++ b/src/System/Taffybar/Widget/FreedesktopNotifications.hs @@ -38,7 +38,6 @@ import Data.Foldable import Data.Int ( Int32 ) import Data.Map ( Map ) -import Data.Monoid import Data.Sequence ( Seq, (|>), viewl, ViewL(..) ) import qualified Data.Sequence as S import Data.Text ( Text ) @@ -48,8 +47,6 @@ import GI.Gtk import qualified GI.Pango as Pango import System.Taffybar.Util - -import Prelude -- | A simple structure representing a Freedesktop notification data Notification = Notification diff --git a/src/System/Taffybar/Widget/Generic/Graph.hs b/src/System/Taffybar/Widget/Generic/Graph.hs --- a/src/System/Taffybar/Widget/Generic/Graph.hs +++ b/src/System/Taffybar/Widget/Generic/Graph.hs @@ -24,15 +24,13 @@ import Control.Monad ( when ) import Control.Monad.IO.Class import Data.Default ( Default(..) ) -import Data.Foldable ( mapM_ ) -import Data.Sequence ( Seq, (<|), viewl, ViewL(..) ) +import Data.Sequence ( Seq(..), (<|), viewl, ViewL(..) ) import qualified Data.Sequence as S import qualified Data.Text as T import qualified GI.Cairo.Render as C import GI.Cairo.Render.Connector import qualified GI.Cairo.Render.Matrix as M import qualified GI.Gtk as Gtk -import Prelude hiding ( mapM_ ) import System.Taffybar.Util import System.Taffybar.Widget.Util @@ -172,13 +170,13 @@ C.transform $ M.Matrix (-1) 0 0 1 (fromIntegral w) 0 let pctToY pct = fromIntegral h * (1 - pct) - renderDataSet hist color style - | S.length hist <= 1 = return () - | otherwise = do + renderDataSet hist color style = case viewl hist of + EmptyL -> return () + _oneSample :< Empty -> return () + newestSample :< hist' -> do let (r, g, b, a) = color originY = pctToY newestSample originX = 0 - newestSample :< hist' = viewl hist C.setSourceRGBA r g b a C.moveTo originX originY diff --git a/src/System/Taffybar/Widget/Generic/Icon.hs b/src/System/Taffybar/Widget/Generic/Icon.hs --- a/src/System/Taffybar/Widget/Generic/Icon.hs +++ b/src/System/Taffybar/Widget/Generic/Icon.hs @@ -10,7 +10,7 @@ import Control.Concurrent ( forkIO, threadDelay ) import qualified Data.Text as T import Control.Exception as E -import Control.Monad ( forever ) +import Control.Monad ( forever, void ) import Control.Monad.IO.Class import GI.Gtk import System.Taffybar.Util @@ -28,10 +28,10 @@ -- > iconWidgetNewFromName name -- -- returns a widget with the icon named @name@. Icon --- names are sourced from the current GTK theme. +-- names are sourced from the current GTK theme. iconImageWidgetNewFromName :: MonadIO m => T.Text -> m Widget -iconImageWidgetNewFromName name = liftIO $ - imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu) +iconImageWidgetNewFromName name = liftIO $ + imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu) >>= putInBox -- | Create a new widget that updates itself at regular intervals. The @@ -73,16 +73,16 @@ -> Double -- ^ Update interval (in seconds) -> IO T.Text -- ^ Command to run update the icon name -> m Widget -pollingIconImageWidgetNewFromName name interval cmd = +pollingIconImageWidgetNewFromName name interval cmd = pollingIcon interval cmd (imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu)) (\image name' -> imageSetFromIconName image (Just name') $ fromIntegral $ fromEnum IconSizeMenu) --- | Creates a polling icon. -pollingIcon +-- | Creates a polling icon. +pollingIcon :: MonadIO m => Double -- ^ Update Interval (in seconds) - -> IO name -- ^ IO action that updates image's icon-name/filepath + -> IO name -- ^ IO action that updates image's icon-name/filepath -> IO Image -- ^ MonadIO action that creates the initial image. -> (Image -> name -> IO b) -- ^ MonadIO action that updates the image. @@ -93,7 +93,7 @@ _ <- forkIO $ forever $ do let tryUpdate = liftIO $ do name' <- doUpdateName - postGUIASync $ doSetImage image name' >> return () + postGUIASync $ void $ doSetImage image name' E.catch tryUpdate ignoreIOException threadDelay $ floor (interval * 1000000) return () diff --git a/src/System/Taffybar/Widget/Layout.hs b/src/System/Taffybar/Widget/Layout.hs --- a/src/System/Taffybar/Widget/Layout.hs +++ b/src/System/Taffybar/Widget/Layout.hs @@ -37,10 +37,10 @@ -- $usage -- --- This widget requires that the "System.Taffybar.Support.PagerHints" hook be +-- This widget requires that the "XMonad.Hooks.TaffybarPagerHints" hook be -- installed in your @xmonad.hs@: -- --- > import System.Taffybar.Support.PagerHints (pagerHints) +-- > import XMonad.Hooks.TaffybarPagerHints (pagerHints) -- > main = do -- > xmonad $ ewmh $ pagerHints $ defaultConfig -- > ... @@ -79,7 +79,7 @@ -- This callback is run in a separate thread and needs to use -- postGUIASync - let callback _ = liftReader postGUIASync $ do + let callback _ = mapReaderT postGUIASync $ do layout <- runX11Def "" $ readAsString Nothing xLayoutProp markup <- formatLayout config (T.pack layout) lift $ Gtk.labelSetMarkup label markup diff --git a/src/System/Taffybar/Widget/SimpleClock.hs b/src/System/Taffybar/Widget/SimpleClock.hs --- a/src/System/Taffybar/Widget/SimpleClock.hs +++ b/src/System/Taffybar/Widget/SimpleClock.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Widget.SimpleClock ( textClockNew @@ -92,21 +90,6 @@ instance Default ClockConfig where def = defaultClockConfig -systemGetTZ :: IO TimeZone -systemGetTZ = setTZ >> getCurrentTimeZone - --- | Old versions of time do not call localtime_r properly. We set the time zone --- manually, if required. -setTZ :: IO () -#if MIN_VERSION_time(1, 4, 2) -setTZ = return () -#else -setTZ = c_tzsetp - -foreign import ccall unsafe "time.h tzset" - c_tzset :: IO () -#endif - -- | A configurable text-based clock widget. It currently allows for -- a configurable time zone through the 'ClockConfig'. -- @@ -118,7 +101,7 @@ , clockFormatString = formatString , clockUpdateStrategy = updateStrategy } = liftIO $ do - let getTZ = maybe systemGetTZ return userZone + let getTZ = maybe getCurrentTimeZone return userZone locale = fromMaybe L.defaultTimeLocale userLocale let getUserZonedTime = @@ -162,4 +145,3 @@ toggleCalendar label cal widgetShowAll ebox toWidget ebox - diff --git a/src/System/Taffybar/Widget/SimpleCommandButton.hs b/src/System/Taffybar/Widget/SimpleCommandButton.hs --- a/src/System/Taffybar/Widget/SimpleCommandButton.hs +++ b/src/System/Taffybar/Widget/SimpleCommandButton.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.SimpleCommandButton @@ -18,6 +17,7 @@ simpleCommandButtonNew) where +import Control.Monad (void) import Control.Monad.IO.Class import GI.Gtk import System.Process @@ -42,6 +42,5 @@ -> m Widget simpleCommandButtonNew txt cmd = do button <- buttonNewWithLabel txt - _ <- onButtonClicked button $ spawnCommand (T.unpack cmd) >> return () + void $ onButtonClicked button $ void $ spawnCommand $ T.unpack cmd toWidget button - diff --git a/src/System/Taffybar/Widget/Text/CPUMonitor.hs b/src/System/Taffybar/Widget/Text/CPUMonitor.hs --- a/src/System/Taffybar/Widget/Text/CPUMonitor.hs +++ b/src/System/Taffybar/Widget/Text/CPUMonitor.hs @@ -19,11 +19,11 @@ where callback = do (userLoad, systemLoad, totalLoad) <- cpuLoad - let [userLoad', systemLoad', totalLoad'] = map (formatPercent.(*100)) [userLoad, systemLoad, totalLoad] + let pct = formatPercent . (* 100) let template = ST.newSTMP fmt - let template' = ST.setManyAttrib [ ("user", userLoad'), - ("system", systemLoad'), - ("total", totalLoad') ] template + let template' = ST.setManyAttrib [ ("user", pct userLoad), + ("system", pct systemLoad), + ("total", pct totalLoad) ] template return $ ST.render template' formatPercent :: Double -> String diff --git a/src/System/Taffybar/Widget/Util.hs b/src/System/Taffybar/Widget/Util.hs --- a/src/System/Taffybar/Widget/Util.hs +++ b/src/System/Taffybar/Widget/Util.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.Util @@ -132,7 +132,7 @@ getImageForMaybeIconName :: Maybe T.Text -> Int32 -> IO (Maybe GI.Pixbuf) getImageForMaybeIconName mIconName size = - join <$> sequenceA (flip getImageForIconName size <$> mIconName) + join <$> traverse (`getImageForIconName` size) mIconName getImageForIconName :: T.Text -> Int32 -> IO (Maybe GI.Pixbuf) getImageForIconName iconName size = diff --git a/src/System/Taffybar/Widget/Windows.hs b/src/System/Taffybar/Widget/Windows.hs --- a/src/System/Taffybar/Widget/Windows.hs +++ b/src/System/Taffybar/Widget/Windows.hs @@ -79,7 +79,7 @@ subscription <- subscribeToPropertyEvents [ewmhActiveWindow, ewmhWMName, ewmhWMClass] activeWindowUpdatedCallback - _ <- liftReader (\x -> Gtk.onWidgetUnrealize label x) (unsubscribe subscription) + _ <- mapReaderT (Gtk.onWidgetUnrealize label) (unsubscribe subscription) context <- ask diff --git a/src/System/Taffybar/Widget/Workspaces.hs b/src/System/Taffybar/Widget/Workspaces.hs --- a/src/System/Taffybar/Widget/Workspaces.hs +++ b/src/System/Taffybar/Widget/Workspaces.hs @@ -13,7 +13,6 @@ module System.Taffybar.Widget.Workspaces where -import Control.Applicative import Control.Arrow ((&&&)) import Control.Concurrent import qualified Control.Concurrent.MVar as MV @@ -32,7 +31,6 @@ import qualified Data.Map as M import Data.Maybe import qualified Data.MultiMap as MM -import Data.Ord import qualified Data.Set as Set import qualified Data.Text as T import Data.Time.Units @@ -42,7 +40,6 @@ import qualified GI.Gdk.Structs.EventScroll as Gdk import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import qualified GI.Gtk as Gtk -import Prelude import StatusNotifier.Tray (scalePixbufToSize) import System.Log.Logger import System.Taffybar.Context @@ -283,7 +280,7 @@ hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0 void $ Gtk.widgetGetParent workspaceWidget >>= traverse (unsafeCastTo Gtk.Box) >>= - traverse (flip Gtk.containerRemove workspaceWidget) + traverse (`Gtk.containerRemove` workspaceWidget) Gtk.containerAdd hbox workspaceWidget Gtk.containerAdd cont hbox @@ -309,7 +306,7 @@ handleConfigureEvents _ = return () (workspaceSubscription, iconSubscription, geometrySubscription) <- flip runReaderT tContext $ sequenceT - ( subscribeToPropertyEvents (updateEvents cfg) $ doUpdate + ( subscribeToPropertyEvents (updateEvents cfg) doUpdate , subscribeToPropertyEvents [ewmhWMIcon] (lift . onIconChanged iconHandler) , subscribeToAll handleConfigureEvents ) @@ -683,8 +680,8 @@ const $ scaledWindowIconPixbufGetter getter constantSize handleIconGetterException :: WindowIconPixbufGetter -> WindowIconPixbufGetter -handleIconGetterException getter = - \size windowData -> catchAny (getter size windowData) $ \e -> do +handleIconGetterException getter size windowData = + catchAny (getter size windowData) $ \e -> do wLog WARNING $ printf "Failed to get window icon for %s: %s" (show windowData) (show e) return Nothing @@ -744,7 +741,7 @@ let getGeometryWorkspaces w = getDisplay >>= liftIO . (`safeGetGeometry` w) getGeometries = mapM (forkM return - ((((sel2 &&& sel3) <$>) .) getGeometryWorkspaces) . + (((sel2 &&& sel3) <$>) . getGeometryWorkspaces) . windowId) wins windowGeometries <- liftX11Def [] getGeometries diff --git a/src/System/Taffybar/WindowIcon.hs b/src/System/Taffybar/WindowIcon.hs --- a/src/System/Taffybar/WindowIcon.hs +++ b/src/System/Taffybar/WindowIcon.hs @@ -29,6 +29,7 @@ import System.Environment.XDG.DesktopEntry import System.Taffybar.Util import System.Taffybar.Widget.Util +import Text.Printf type ColorRGBA = Word32 @@ -100,9 +101,10 @@ -> TaffyIO (Maybe DesktopEntry) getDirectoryEntryByClass klass = do entries <- MM.lookup klass <$> getDirectoryEntriesByClassName - when (length entries > 1) $ - logPrintF "System.Taffybar.WindowIcon" INFO "Multiple entries for: %s" - (klass, entries) + when (length entries > 1) $ liftIO $ + logM "System.Taffybar.WindowIcon" DEBUG $ printf + "Class \"%s\" has multiple desktop entries: %s" + klass (intercalate ", " $ map deFilename entries) return $ listToMaybe entries getWindowIconForAllClasses diff --git a/taffybar.cabal b/taffybar.cabal --- a/taffybar.cabal +++ b/taffybar.cabal @@ -1,26 +1,32 @@ +cabal-version: 3.4 name: taffybar -version: 4.0.2 +version: 4.0.3 synopsis: A desktop bar similar to xmobar, but with more GUI -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Ivan Malison maintainer: IvanMalison@gmail.com category: System build-type: Simple -cabal-version: >=1.10 -tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2 +tested-with: GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.2 homepage: http://github.com/taffybar/taffybar data-files: taffybar.css icons/*.svg extra-source-files: - README.md - CHANGELOG.md dbus-xml/org.freedesktop.UPower.Device.xml dbus-xml/org.freedesktop.UPower.xml dbus-xml/org.mpris.MediaPlayer2.Player.xml dbus-xml/org.mpris.MediaPlayer2.xml + test/data/*.golden +extra-doc-files: + README.md + CHANGELOG.md + doc/*.md +flag Deprecated-Pager-Hints + description: Enables the deprecated System.Taffybar.Support.PagerHints module, which has been moved to xmonad-contrib. + library default-extensions: TupleSections @@ -28,7 +34,7 @@ MonoLocalBinds default-language: Haskell2010 - build-depends: base > 3 && < 5 + build-depends: base >= 4.15.0.0 && < 5 , HStringTemplate >= 0.8 && < 0.9 , X11 >= 1.5.0.1 , aeson @@ -45,19 +51,17 @@ , either >= 4.0.0.0 , enclosed-exceptions >= 1.0.0.1 , filepath - , gi-cairo , gi-cairo-connector , gi-cairo-render - , gi-gdk - , gi-gdkpixbuf + , gi-gdk >=3.0.6 && <3.1 + , gi-gdkpixbuf >=2.0.6 && <2.1 , gi-gdkx11 , gi-glib - , gi-gtk - , gi-gtk-hs + , gi-gtk >= 3.0.26 && < 4 + , gi-gtk-hs >= 0.3.9 && < 0.4 , gi-pango , gtk-sni-tray >= 0.1.8.0 , gtk-strut >= 0.1.2.1 - , haskell-gi >= 0.24 , haskell-gi-base >= 0.24 , hslogger , http-conduit @@ -65,13 +69,12 @@ , http-client-tls , http-types , multimap >= 1.2.1 - , old-locale , parsec >= 3.1 , process >= 1.0.1.1 , rate-limit >= 1.1.1 , regex-compat , safe >= 0.3 && < 1 - , scotty >= 0.11 && < 0.22 + , scotty >= 0.20 && < 0.23 , split >= 0.1.4.2 , status-notifier-item >= 0.3.1.0 , stm @@ -81,7 +84,6 @@ , time-locale-compat >= 0.1 && < 0.2 , time-units >= 1.0.0 , transformers >= 0.3.0.0 - , transformers-base >= 0.4 , tuple >= 0.3.0.2 , unix , utf8-string @@ -89,7 +91,6 @@ , xdg-basedir >= 0.2 && < 0.3 , xml , xml-helpers - , xmonad hs-source-dirs: src pkgconfig-depends: gtk+-3.0 @@ -116,7 +117,6 @@ , System.Taffybar.Information.XDG.Protocol , System.Taffybar.LogFormatter , System.Taffybar.SimpleConfig - , System.Taffybar.Support.PagerHints , System.Taffybar.Util , System.Taffybar.Widget , System.Taffybar.Widget.Battery @@ -154,6 +154,10 @@ , System.Taffybar.Widget.XDGMenu.MenuWidget , System.Taffybar.WindowIcon + if flag(Deprecated-Pager-Hints) + build-depends: xmonad + exposed-modules: System.Taffybar.Support.PagerHints + other-modules: Paths_taffybar , System.Taffybar.DBus.Client.MPRIS2 , System.Taffybar.DBus.Client.Params @@ -161,12 +165,14 @@ , System.Taffybar.DBus.Client.UPowerDevice , System.Taffybar.DBus.Client.Util + autogen-modules: Paths_taffybar + cc-options: -fPIC ghc-options: -Wall -funbox-strict-fields -fno-warn-orphans executable taffybar default-language: Haskell2010 - build-depends: base > 3 && < 5 + build-depends: base , data-default , directory , hslogger @@ -174,10 +180,29 @@ , taffybar other-modules: Paths_taffybar + autogen-modules: Paths_taffybar hs-source-dirs: app main-is: Main.hs pkgconfig-depends: gtk+-3.0 + ghc-options: -Wall -rtsopts -threaded + +test-suite unit + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: System.Taffybar.AuthSpec + , System.Taffybar.SpecUtil + default-language: Haskell2010 + build-depends: base + , directory + , filepath + , hspec + , hspec-core + , hspec-golden + , taffybar + , temporary + build-tool-depends: hspec-discover:hspec-discover == 2.* ghc-options: -Wall -rtsopts -threaded source-repository head diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/System/Taffybar/AuthSpec.hs b/test/System/Taffybar/AuthSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Taffybar/AuthSpec.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module System.Taffybar.AuthSpec (spec) where + +import Data.List (intercalate) +import System.FilePath ((), (<.>)) +import Text.Printf (printf) + +import Test.Hspec +import Test.Hspec.Core.Spec (getSpecDescriptionPath) +import Test.Hspec.Golden hiding (golden) + +import System.Taffybar.Auth +import System.Taffybar.SpecUtil (withMockCommand) + +spec :: Spec +spec = aroundAll_ (withMockPass mockDb) $ describe "passGet" $ do + golden "get a password" $ show <$> passGet "hello" + golden "get a password with info" $ show <$> passGet "multiline" + golden "missing entry" $ show <$> passGet "missing" + +golden :: String -> IO String -> Spec +golden description runAction = do + path <- (++ words description) <$> getSpecDescriptionPath + it description $ + taffybarGolden (intercalate "-" path) <$> runAction + +taffybarGolden :: String -> String -> Golden String +taffybarGolden name output = Golden + { output + , encodePretty = show + , writeToFile = writeFile + , readFromFile = readFile + , goldenFile = "test/data/" name <.> "golden" + , actualFile = Nothing + , failFirstTime = True + } + +mockDb :: [MockEntry] +mockDb = [ mockEntry "hello" "xyzzy" [] + , mockEntry "multiline" "secret" [("Username", "fred"), ("silly", "")] + , fallbackEntry "" "Error: is not in the password store.\n" 1 + ] + +withMockPass :: [MockEntry] -> IO a -> IO a +withMockPass db = withMockCommand "pass" (mockScript db) + +data MockEntry = MockEntry + { passName :: String + , out :: String + , err :: String + , status :: Int + } deriving (Show, Read, Eq) + +mockEntry :: String -> String -> [(String, String)] -> MockEntry +mockEntry passName key info = + MockEntry { passName, out = passFile key info, err = "", status = 0 } + +passFile :: String -> [(String, String)] -> String +passFile key info = unlines (key:[k ++ ": " ++ v | (k, v) <- info]) + +fallbackEntry :: String -> String -> Int -> MockEntry +fallbackEntry out err status = MockEntry { passName = "", .. } + +mockScript :: [MockEntry] -> String +mockScript db = unlines ("#!/usr/bin/env bash":map makeEntry db) + where + makeEntry MockEntry{..} = printf template passName out err status + template = unlines + [ "pass_name='%s'" + , "if [ -z \"$pass_name\" -o \"$2\" = \"$pass_name\" ]; then" + , " echo -n '%s'" + , " >&2 echo '%s'" + , " exit %d" + , "fi" + ] diff --git a/test/System/Taffybar/SpecUtil.hs b/test/System/Taffybar/SpecUtil.hs new file mode 100644 --- /dev/null +++ b/test/System/Taffybar/SpecUtil.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE ViewPatterns #-} + +module System.Taffybar.SpecUtil + ( withMockCommand + , writeScript + , withEnv + , prependPath + ) where + +import Control.Arrow (second) +import Control.Exception (bracket) +import Control.Monad (guard, join) +import Data.List (uncons) +import System.Directory (Permissions (..), findExecutable, getPermissions, setPermissions) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.FilePath (isRelative, takeFileName, ()) +import System.IO.Temp (withSystemTempDirectory) + +-- | Run the given 'IO' action with the @PATH@ environment variable +-- set up so that executing the given command name will run a +-- script. +withMockCommand + :: FilePath -- ^ Name of command - should not contain slashes + -> String -- ^ Contents of script + -> IO a -- ^ Action to run with command available in search path + -> IO a +withMockCommand name content action = + withSystemTempDirectory "specutil" $ \dir -> do + writeScript (dir takeFileName name) content + withEnv [("PATH", prependPath dir)] action + +-- | Write a text file, make it executable. +-- It ought to have a shebang line. +writeScript :: FilePath -> String -> IO () +writeScript scriptFile content = do + content' <- patchShebangs content + writeFile scriptFile content' + p <- getPermissions scriptFile + setPermissions scriptFile (p { executable = True }) + +-- | Given the text of a shell script, this replaces any relative path +-- in the shebang with an absolute path, according to the current +-- environment's @PATH@ variable. +-- +-- The only reason this exists is so that we can generate shell +-- scripts containing @#!/usr/bin/env bash@ and then be able to +-- execute them within a Nix build sandbox (which does not allow +-- @/usr/bin/env@). +patchShebangs :: String -> IO String +patchShebangs = patchShebangs' findExe + where + findExe = fmap join . traverse findExecutable . takeRelativeFileName + + takeRelativeFileName :: FilePath -> Maybe FilePath + takeRelativeFileName fp = guard (isRelative fp) >> pure (takeFileName fp) + +patchShebangs' :: Applicative m => (FilePath -> m (Maybe FilePath)) -> String -> m String +patchShebangs' replaceExe script = case parseInterpreter script of + Just (interpreter, rest) -> do + let unparse exe = "#! " ++ exe ++ rest + maybe script unparse <$> replaceExe interpreter + Nothing -> pure script + +parseInterpreter :: String -> Maybe (String, String) +parseInterpreter (lines -> content) = do + (header, rest) <- uncons content + (interpreter, args) <- parseShebang header + pure (interpreter, unlines (args:rest)) + + where + parseShebang :: String -> Maybe (String, String) + parseShebang ('#':'!':(findInterpreter -> shebang)) = + let catArgs args = unwords ("":args) + in second catArgs <$> shebang + parseShebang _ = Nothing + + findInterpreter = uncons . dropWhile ((== "env") . takeFileName) . words + +-- | Run an 'IO' action with the given environment variables set up +-- according to their current value. 'Nothing' denotes an unset +-- environment variable. After the 'IO' action completes, environment +-- variables are restored to their previous state. +withEnv :: [(String, Maybe String -> Maybe String)] -> IO a -> IO a +withEnv mods = bracket setup teardown . const + where + setup = mapM (uncurry changeEnv) mods + teardown = mapM (uncurry putEnv) . reverse + + changeEnv name f = do + old <- lookupEnv name + putEnv name (f old) + pure (name, old) + + putEnv :: String -> Maybe String -> IO () + putEnv name = maybe (unsetEnv name) (setEnv name) + +-- | Use this as a modifier function argument of 'withEnv' to ensure +-- that the given directory is prepended to a search path variable. +prependPath :: FilePath -> Maybe String -> Maybe String +prependPath p = Just . (++ ":/usr/bin") . (p ++) . maybe "" (":" ++) diff --git a/test/data/System.Taffybar.Auth-passGet-get-a-password-with-info.golden b/test/data/System.Taffybar.Auth-passGet-get-a-password-with-info.golden new file mode 100644 --- /dev/null +++ b/test/data/System.Taffybar.Auth-passGet-get-a-password-with-info.golden @@ -0,0 +1,1 @@ +Right ("secret",[("Username","fred"),("silly","")]) diff --git a/test/data/System.Taffybar.Auth-passGet-get-a-password.golden b/test/data/System.Taffybar.Auth-passGet-get-a-password.golden new file mode 100644 --- /dev/null +++ b/test/data/System.Taffybar.Auth-passGet-get-a-password.golden @@ -0,0 +1,1 @@ +Right ("xyzzy",[]) diff --git a/test/data/System.Taffybar.Auth-passGet-missing-entry.golden b/test/data/System.Taffybar.Auth-passGet-missing-entry.golden new file mode 100644 --- /dev/null +++ b/test/data/System.Taffybar.Auth-passGet-missing-entry.golden @@ -0,0 +1,1 @@ +Left "Exit code 1: Error: is not in the password store.\n\n "